diff --git a/ASTVersions.hs b/ASTVersions.hs deleted file mode 100644 --- a/ASTVersions.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE GADTs, EmptyDataDecls, DataKinds, KindSignatures, ExistentialQuantification #-} - -data Version = F77 | F90 - -data AST (v :: Version) where - Assign :: String -> AST F77 - Module :: String -> Int -> AST F90 - -data TopLevel = forall v . AST v - diff --git a/Analysis/Annotations.hs b/Analysis/Annotations.hs deleted file mode 100644 --- a/Analysis/Annotations.hs +++ /dev/null @@ -1,74 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Analysis.Annotations where - -import Data.Data -import Data.Generics.Uniplate.Operations - -import Data.Map.Lazy hiding (map) -import Debug.Trace - -import Language.Haskell.ParseMonad - -import Language.Fortran -import Analysis.IntermediateReps - -type Report = String - --- Additional "helper" syntax (NOT GENERATED BY PARSER) - --- Loop classifications - -data ReduceType = Reduce | NoReduce -data AccessPatternType = Regular | RegularAndConstants | Irregular | Undecidable -data LoopType = Functor ReduceType - | Gather ReduceType ReduceType AccessPatternType - | Scatter ReduceType AccessPatternType - -{- classify :: Fortran Annotation -> Fortran Annotation - classify x = -} - -type A = Annotation - -data Annotation = A { indices :: [Variable], - lives :: ([Access],[Access]), - arrsRead :: Map Variable [[Expr ()]], - arrsWrite :: Map Variable [[Expr ()]], - unitVar :: Int, - number :: Int, - refactored :: Maybe SrcLoc, - successorStmts :: [Int], - newNode :: Bool -- used to indicate when a node is newly introduced - } - deriving (Eq, Show, Typeable, Data) - -liveOut = snd . lives -liveIn = fst . lives - - -- Map Variable [[(Variable,Int)]], - -pRefactored :: Annotation -> Bool -pRefactored x = case (refactored x) of - Nothing -> False - Just _ -> True - -unitAnnotation = A [] ([], []) empty empty 0 0 Nothing [] False - diff --git a/Analysis/CallGraph.hs b/Analysis/CallGraph.hs deleted file mode 100644 --- a/Analysis/CallGraph.hs +++ /dev/null @@ -1,36 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Analysis.CallGraph where - -import Data.Data - -import Language.Fortran -import Language.Fortran.Pretty - -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy -import Debug.Trace - -import Analysis.Annotations -import Analysis.Syntax -import Traverse - --- Calculates inter-procedural information - -type DefSites = [(String, String)] diff --git a/Analysis/IntermediateReps.hs b/Analysis/IntermediateReps.hs deleted file mode 100644 --- a/Analysis/IntermediateReps.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Analysis.IntermediateReps where - -import Data.Data - -import Language.Fortran -import Language.Fortran.Pretty - -data AccessP p = VarA String | ArrayA String [Expr p] deriving (Eq, Typeable, Data) - -type Access = AccessP () - -accessToVarName :: AccessP a -> Variable -accessToVarName (VarA v) = v -accessToVarName (ArrayA v _) = v - -instance Show (AccessP ()) where - show (VarA s) = s - show (ArrayA v es) = v ++ "(" ++ (showList (map pprint es)) ++ ")" - where showList [] = "" - showList [x] = x - showList (x:xs) = x ++ ", " ++ showList xs diff --git a/Analysis/LVA.hs b/Analysis/LVA.hs deleted file mode 100644 --- a/Analysis/LVA.hs +++ /dev/null @@ -1,113 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ScopedTypeVariables #-} - -{-| - -Provides live-variable analysis for Fortran code. One of the simpler analyses in the suite (a good -starting point for any new developers). This demonstrates the use of the "zipper" format, and -various helpers from 'Analysis.Syntax' and 'Traverse'. - -'lva' is the top-level definition here. - --} -module Analysis.LVA where - -import Data.Data -import Data.List - -import Data.Generics.Zipper -import Data.Generics.Uniplate.Operations - -import Language.Fortran - -import Analysis.Annotations -import Analysis.Syntax -import Transformation.Syntax -import Analysis.IntermediateReps -import Traverse - - -{-| live-variable analysis on a program -} --- Recall: type Program a = [ProgUnit a] -lva :: Program Annotation -> Program Annotation -lva x = map lvaOnUnit x - -{-| live-variable analysis at the level of a unit, not whole-program,iterates @lva1@ until a fixed-point is reached -} -lvaOnUnit :: ProgUnit Annotation -> ProgUnit Annotation -lvaOnUnit x = let y = fromZipper . (everywhere lva1) . toZipper $ numberStmts . (transformBi reassociate) $ x - in if (y == x) then y else lvaOnUnit y - -{-| Single iteration of live-variable analysis over the zipper for an AST -} -lva1 :: Zipper (ProgUnit Annotation) -> Zipper (ProgUnit Annotation) - -lva1 z = case (getHole z)::(Maybe (Fortran Annotation)) of - Just f -> let anns = map tag ((successors z)::[Fortran Annotation]) -- annotations of the successors - liveOut = nub $ concat $ map (fst . lives) anns - killV = kill f - genV = gen f - liveIn = nub $ union genV (liveOut \\ killV) - annotation = (tag f) { lives = (liveIn, liveOut), successorStmts = map number anns } - in setHole (refill f annotation) z - Nothing -> z - -{-| Variables killed by the current statement -} -kill :: Fortran Annotation -> [Access] -kill (Assg _ _ e1 _) = killForLhsVar e1 - where - {-| variable killed by expressions on the left-hand side -} - killForLhsVar :: Expr Annotation -> [Access] - killForLhsVar (Var a p xes) = map (\((VarName _ v), _) -> VarA v) xes - killForLhsVar _ = [] -kill t = concatMap accesses (lhsExpr t) - -{-| Variables generated (made live) by the current statement -} -gen :: Fortran Annotation -> [Access] -gen t@(Assg _ _ e1 e2) = (concatMap accesses (rhsExpr t)) ++ (genForLhsVar e1) - where - {-| variables generated on the left-hand side -} - genForLhsVar :: Expr Annotation -> [Access] - genForLhsVar t@ (Var _ _ xes) = concatMap (\(_, es) -> accesses es) xes - genForLhsVar _ = [] -gen t = concatMap accesses (rhsExpr t) - - - - - - - - - - - - -{- - successorAnnotations :: Zipper (ProgUnit Annotation) -> [Annotation] - successorAnnotations x = goRight x ++ (case (up x) of - Just ux -> case (getHole ux)::(Maybe (Fortran Annotation)) of - Just f -> map tag (successors f) ++ (goRight ux) - Nothing -> (goRight ux) - Nothing -> []) - where goRight :: Zipper (ProgUnit Annotation) -> [Annotation] - goRight z = (case (getHole z)::(Maybe (Fortran Annotation)) of - Just f -> [tag f] - Nothing -> []) ++ - (case (right z) of - Just rz -> goRight rz - Nothing -> []) - - -} diff --git a/Analysis/Loops.hs b/Analysis/Loops.hs deleted file mode 100644 --- a/Analysis/Loops.hs +++ /dev/null @@ -1,97 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Analysis.Loops where - -import Data.Data -import Data.List -import Data.Ord - -import Language.Fortran -import Language.Fortran.Pretty - - -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy -import Debug.Trace - -import Analysis.LVA -import Analysis.Annotations -import Analysis.Syntax -import Analysis.Types - -import Helpers -import Traverse - -import Transformation.Syntax -- <- for doing reassociation - -import qualified Data.Map.Lazy as Map hiding (map, (\\)) - --- when travesing whole program collect all declarations with bounds --- collect all constants (#1) --- identify all loop 'variables' (#2) --- - identify all variables indexed by the loop variables - --- loopBody :: Fortran t -> State (TypeEnvStack t) (Fortran ([String], [String], [String])) --- loopBody (For _ v@(VarName _ s) e1 e2 e3 body) = --- let --- anno = ( --- in For anno v e1 e2 e3 body --- --- newFrame gammas = []:gammas --- pushVar v t (g:gs) = ((v, t):g):gs --- popVar (((v,t):g):gs) = (g:gs) --- popFrame (g:gs) = (g, gs) - --- ap (fmap ((,[""]),[""])) - -loopAnalyse :: Program a -> Program Annotation -loopAnalyse p = map ((descendBi arrayIndices) . ix . lvaOnUnit . (transformBi reassociate) . (fmap (const unitAnnotation))) p - -analyse' :: Program Annotation -> Program Annotation -analyse' p = map ((descendBi arrayIndices) . ix . lvaOnUnit . (transformBi reassociate)) p - - -collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a] -collect = collect' Map.empty - where collect' as [] = as - collect' as ((v, n):es) | Map.member v as = collect' (Map.insert v (nub $ n : ((Map.!) as v)) as) es - | otherwise = collect' (Map.insert v [n] as) es - -arrayIndices :: Block Annotation -> Block Annotation -arrayIndices x = - let tenv = typeEnv x - - arrIxsF :: Fortran Annotation -> Annotation - arrIxsF y = let readIxs = [(v, mfmap (const ()) e) | - (Var _ _ [(VarName _ v, e)]) <- rhsExpr y, - length e > 0, - isArrayTypeP' tenv v] - - writeIxs = [(v, mfmap (const ()) e) | - (Var _ _ [(VarName _ v, e)]) <- lhsExpr y, - length e > 0, - isArrayTypeP' tenv v] - - in (tag y) { arrsRead = (collect readIxs), arrsWrite = (collect writeIxs) } - in extendBi arrIxsF x - -ix :: ProgUnit Annotation -> ProgUnit Annotation -ix = let ixF :: Fortran Annotation -> Annotation - ixF f = (tag f) { indices = (nub [v | (For _ _ (VarName _ v) _ _ _ _) <- ((universeBi f)::[Fortran Annotation])])} - in extendBi ixF diff --git a/Analysis/Syntax.hs b/Analysis/Syntax.hs deleted file mode 100644 --- a/Analysis/Syntax.hs +++ /dev/null @@ -1,386 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, KindSignatures, - FlexibleContexts, GADTs, DeriveGeneric #-} - -{-| - -This module provides a number of helper functions for working with Fortran syntax that are useful -between different analyses and transformations. - --} -module Analysis.Syntax where - --- Standard imports -import Data.Char -import Data.List -import Data.Monoid -import Control.Monad.State.Lazy -import Debug.Trace - --- Data-type generics imports -import Data.Data -import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Zipper -import Data.Typeable - --- CamFort specific functionality -import Analysis.Annotations -import Analysis.IntermediateReps -import Traverse -import Language.Fortran - --- * Comparison and ordering - -{-| 'AnnotationFree' is a data type that wraps other types and denotes terms which should - be compared for equality modulo their annotations and source location information -} -data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show - -{-| short-hand constructor for 'AnnotationFree' -} -af = AnnotationFree -{-| short-hand deconstructor for 'AnnotationFree' -} -unaf = annotationBound - -{-| A helpful function, used by the 'Eq AnnotationFree' instance that resets and source - location information -} -eraseSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a -eraseSrcLocs = transformBi erase' - where erase' :: SrcLoc -> SrcLoc - erase' _ = SrcLoc { srcFilename = "", srcLine = 0, srcColumn = 0 } - -{-| Sets the @SrcLoc@ information to have the filename "compact" which triggers a special - compact form of pretty printing in the @Show SrcLoc@ instances -} -setCompactSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a -setCompactSrcLocs = transformBi cmpact' - where cmpact' :: SrcLoc -> SrcLoc - cmpact' (SrcLoc _ l c) = SrcLoc { srcFilename = "compact", srcLine = l, srcColumn = c } - -lower = map toLower - --- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' - -instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where - (AnnotationFree xs) == (AnnotationFree xs') = - if (length xs == length xs') - then foldl (\b -> \(x, x') -> ((af x) == (af x')) && b) True (zip xs xs') - else False - -instance Eq (AnnotationFree Int) where - x == y = (unaf x) == (unaf y) - -instance Eq (AnnotationFree Char) where - x == y = (unaf x) == (unaf y) - -instance Eq (AnnotationFree (AccessP ())) where - x == y = (unaf x) == (unaf y) - -instance (Eq (AnnotationFree a), Eq (AnnotationFree b)) => Eq (AnnotationFree (a, b)) where - (AnnotationFree (x, y)) == (AnnotationFree (x', y')) = ((af x) == (af x')) && ((af y) == (af y')) - -instance Eq (AnnotationFree (Expr a)) where - -- Compute variable equality modulo annotations and spans - (AnnotationFree (Var _ _ vs)) == (AnnotationFree (Var _ _ vs')) - = cmp vs vs' where cmp [] [] = True - cmp ((VarName _ v,es):vs) ((VarName _ v',es'):vs') = - - -- Since whether variable names are upper or lower case is irrelevant - -- in Fortran, we must compare variables for equality by normalising first - -- (here to lower case) - - if (lower v) == (lower v') then - (and (map (\(e, e') -> (af e) == (af e')) - (zip es es'))) && (cmp vs vs') - else False - - cmp _ _ = False - - -- For other expressions we can get away with reseting their annotations are erasing their source locs - (AnnotationFree e1) == (AnnotationFree e2) = (eraseSrcLocs $ fmap (const ()) e1) == - (eraseSrcLocs $ fmap (const ()) e2) - - -instance Eq (AnnotationFree (Type a)) where - (AnnotationFree (BaseType _ b attrs e1 e2)) == (AnnotationFree (BaseType _ b' attrs' e1' e2')) = - (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2') - - (AnnotationFree (ArrayT _ eps b attrs e1 e2)) == (AnnotationFree (ArrayT _ eps' b' attrs' e1' e2')) = - (af eps == af eps') && (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2') - -instance Eq (AnnotationFree (Attr p)) where - (AnnotationFree (Dimension _ es)) == (AnnotationFree (Dimension _ es')) = af es == af es' - (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) - -instance Eq (AnnotationFree (BaseType p)) where - (AnnotationFree (DerivedType _ s)) == (AnnotationFree (DerivedType _ s')) = (af s) == (af s') - (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) - - -instance Eq (AnnotationFree (SubName p)) where - (AnnotationFree (SubName _ s)) == (AnnotationFree (SubName _ s')) = (lower s) == (lower s') - (AnnotationFree (NullSubName _)) == (AnnotationFree (NullSubName _)) = True - _ == _ = False - -instance Eq (AnnotationFree (IntentAttr p)) where - (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) - - -instance Eq (AnnotationFree (MeasureUnitSpec p)) where - (AnnotationFree (UnitProduct _ u)) == (AnnotationFree (UnitProduct _ u')) = (af u) == (af u') - (AnnotationFree (UnitQuotient _ u1 u2)) == (AnnotationFree (UnitQuotient _ u1' u2')) = - (af u1 == af u1') && (af u2 == af u2') - (AnnotationFree (UnitNone _)) == (AnnotationFree (UnitNone _)) = True - _ == _ = False - -instance Eq (AnnotationFree (Fraction p)) where - (AnnotationFree (IntegerConst _ n)) == (AnnotationFree (IntegerConst _ n')) = (af n) == (af n') - (AnnotationFree (FractionConst _ p q)) == (AnnotationFree (FractionConst _ p' q')) = - (af p == af p') && (af q == af q') - (AnnotationFree (NullFraction _)) == (AnnotationFree (NullFraction _)) = True - _ == _ = False - - -{-| Ordering on accessor syntax -} -instance Ord (AccessP ()) where - (VarA s1) <= (VarA s2) = s1 <= s2 - (ArrayA s1 e1) <= (ArrayA s2 e2) = if (s1 == s2) then e1 <= e2 else s1 <= s2 - (VarA s1) <= (ArrayA s2 e1) = True - _ <= _ = False - -{-| Partial-ordering for expressions (constructors only so far), ignores annotations -} -instance Eq p => Ord (Expr p) where - (Con _ _ c) <= (Con _ _ c') = c <= c' - e <= e' = error "Ordering on expressions only for constructors so far" - --- * Accessor functions for extracting various pieces of information out of syntax trees - -{-| Extracts the subprocedure name from a program unit -} -getSubName :: ProgUnit p -> Maybe String -getSubName (Main _ _ (SubName _ s) _ _ _) = Just s -getSubName (Sub _ _ _ (SubName _ s) _ _) = Just s -getSubName (Function _ _ _ (SubName _ s) _ _ _) = Just s -getSubName (Module _ _ (SubName _ s) _ _ _ _) = Just s -getSubName (BlockData _ _ (SubName _ s) _ _ _) = Just s -getSubName _ = Nothing - -{-| Extracts all accessors (variables and array indexing) from a piece of syntax -} -accesses f = nub $ [VarA (lower v) | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]] - ++ concat [varExprToAccesses ve | ve@(Var _ _ _) <- (universeBi f)::[Expr Annotation]] - - -{-| Extracts a string of the (root) variable name from a variable expression (if it is indeed a variable - expression -} -varExprToVariable :: Expr a -> Maybe Variable -varExprToVariable (Var _ _ ((VarName _ v, es):_)) = Just v -varExprToVariable _ = Nothing - -{-| Extracts an 'accessor' form a variable from a variable expression -} -varExprToAccess :: Expr a -> Maybe Access -varExprToAccess v = varExprToVariable v >>= (Just . VarA) - -{-| Extracts all 'accessors' from a variable expression e.g., - @varExprToAccess@ on the syntax tree coming from @a(i, j)@ returns a list of @[VarA "a", VarA "i", VarA "j"]@ -} -varExprToAccesses :: Expr a -> [Access] -varExprToAccesses (Var _ _ ves) = [mkAccess v es | (VarName _ v, es) <- ves, all isConstant es] - where mkAccess v [] = VarA v - mkAccess v es = ArrayA v (map (fmap (const ())) es) -varExprToAccesses _ = [] - - -class Successors t where - {-| Computes the 'root' successor from the current -} - successorsRoot :: t a -> [t a] - {-| Computes the successors nodes of a CFG (described by a zipper) for certain node types -} - successors :: (Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a] - -instance Successors Fortran where - successorsRoot (FSeq _ _ f1 f2) = [f1] - successorsRoot (For _ _ _ _ _ _ f) = [f] - successorsRoot (If _ _ _ f efs f') = [f] - successorsRoot (Forall _ _ _ f) = [f] - successorsRoot (Where _ _ _ f Nothing) = [f] - successorsRoot (Where _ _ _ f (Just f')) = [f, f'] - successorsRoot (Label _ _ _ f) = [f] - successorsRoot _ = [] - - successors = - successorsF - where - successorsF :: forall a . (Eq a, Typeable a) => Zipper (ProgUnit a) -> [Fortran a] - successorsF z = maybe [] id - (do f <- (getHole z)::(Maybe (Fortran a)) - ss <- return $ successorsRoot f - return $ ss ++ seekUp f (Just z)) - - seekUp :: forall a . (Eq a, Typeable a) => Fortran a -> Maybe (Zipper (ProgUnit a)) -> [Fortran a] - seekUp f z = case (z >>= up >>= getHole)::(Maybe (Fortran a)) of - Just uf -> - case uf of - (FSeq _ _ f1 f2) -> if (f == f1) then [f2] - else seekUp uf (z >>= up) - (For _ _ _ _ _ _ f') -> seekUp uf (z >>= up) - (If _ _ _ gf efs f') -> if (f == gf) then (maybe [] (:[]) f') ++ (map snd efs) - else seekUp uf (z >>= up) - (Forall _ _ _ f') -> seekUp uf (z >>= up) - (Where _ _ _ f' _) -> seekUp uf (z >>= up) - (Label _ _ _ f') -> seekUp uf (z >>= up) - _ -> [] - Nothing -> [] - - -{-| extract all 'right-hand side' expressions e.g. - @rhsExpr (parse "x = e") = parse "e"@ -} -rhsExpr :: Fortran Annotation -> [Expr Annotation] -rhsExpr (Assg _ _ _ e2) = (universeBi e2)::[Expr Annotation] - -rhsExpr (For _ _ v e1 e2 e3 _) = ((universeBi e1)::[Expr Annotation]) ++ - ((universeBi e2)::[Expr Annotation]) ++ - ((universeBi e3)::[Expr Annotation]) - -rhsExpr (If _ _ e f1 fes f3) = ((universeBi e)::[Expr Annotation]) - -rhsExpr (Allocate x sp e1 e2) = ((universeBi e1)::[Expr Annotation]) ++ - ((universeBi e2)::[Expr Annotation]) - -rhsExpr (Call _ _ e as) = ((universeBi e)::[Expr Annotation]) ++ - ((universeBi as)::[Expr Annotation]) - -rhsExpr (Deallocate _ _ es e) = (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) ++ - ((universeBi e)::[Expr Annotation]) - -rhsExpr (Forall _ _ (es, e) f) = concatMap (\(_, e1, e2, e3) -> -- TODO: maybe different here - ((universeBi e1)::[Expr Annotation]) ++ - ((universeBi e2)::[Expr Annotation]) ++ - ((universeBi e3)::[Expr Annotation])) es ++ - ((universeBi e)::[Expr Annotation]) - -rhsExpr (Nullify _ _ es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es - -rhsExpr (Inquire _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es -rhsExpr (Stop _ _ e) = (universeBi e)::[Expr Annotation] -rhsExpr (Where _ _ e f _) = (universeBi e)::[Expr Annotation] - -rhsExpr (Write _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es - -rhsExpr (PointerAssg _ _ _ e2) = (universeBi e2)::[Expr Annotation] - -rhsExpr (Return _ _ e) = (universeBi e)::[Expr Annotation] -rhsExpr (Print _ _ e es) = ((universeBi e)::[Expr Annotation]) ++ - (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) -rhsExpr (ReadS _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es --- rhsExpr (Label x sp s f) = rhsExpr f -rhsExpr _ = [] - -{-| extract all 'left-hand side' expressions e.g. - @rhsExpr (parse "x = e") = parse "x"@ -} -lhsExpr :: Fortran Annotation -> [Expr Annotation] -lhsExpr (Assg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) -lhsExpr (For x sp v e1 e2 e3 fs) = [Var x sp [(v, [])]] -lhsExpr (PointerAssg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) -lhsExpr t = [] -- concatMap lhsExpr ((children t)::[Fortran Annotation]) - - --- * Various simple analyses - -{-| Set a default monoid instances for Int -} -instance Monoid Int where - mempty = 0 - mappend = (+) - -{-| Counts the number of declarations (of variables) in a whole program -} -countVariableDeclarations :: Program Annotation -> Int -countVariableDeclarations x = sum [length xs | (Decl _ _ xs _) <- (universeBi x)::[Decl Annotation]] - - -{-| Numbers all the statements in a program unit (successively) which is useful for analysis output -} -numberStmts :: ProgUnit Annotation -> ProgUnit Annotation -numberStmts x = let - numberF :: Fortran Annotation -> State Int (Fortran Annotation) - numberF = descendBiM number' - - number' :: Annotation -> State Int Annotation - -- actually numbers more than just statements, but this doesn't matter - number' x = do n <- get - put (n + 1) - return $ x { number = n } - - in fst $ runState (descendBiM numberF x) 0 - -{-| All variables from a Fortran syntax tree -} -variables f = nub $ map (map toLower) $ [v | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]] - ++ [v | (VarName _ v) <- (universeBi f)::[VarName Annotation]] - -{-| A predicate on whether an expression is actually a constant constructor -} -isConstant :: Expr p -> Bool -isConstant (Con _ _ _) = True -isConstant (ConL _ _ _ _) = True -isConstant (ConS _ _ _) = True -isConstant _ = False - -{-| Free-variables in a piece of Fortran syntax -} -freeVariables :: (Data (t a), Data a) => t a -> [String] -freeVariables f = (variables f) \\ (binders f) - -{-| All variables from binders -} -binders :: forall a t . (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> [String] -binders f = nub $ - [v | (ArgName _ v) <- (universeBi f)::[ArgName a]] - ++ [v | (VarName _ v) <- (universeBi ((universeBi f)::[Decl a]))::[VarName a]] - ++ [v | (For _ _ (VarName _ v) _ _ _ _) <- (universeBi f)::[Fortran a]] - - -{-| Tests whether an expression is an affine transformation (without scaling) - on some variable, if so returns the variable and the translation factor -} -affineMatch (Bin _ _ (Plus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, read n) -affineMatch (Bin _ _ (Plus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, read n) -affineMatch (Bin _ _ (Minus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, - read n) -affineMatch (Bin _ _ (Minus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, - read n) -affineMatch (Var _ _ [(VarName _ v, _)]) = Just (v, 0) -affineMatch _ = Nothing - - --- * An embedded domain-specific language for describing syntax tree queries - -{-| 'QueryCmd' provides 'commands' of which pieces of syntax to find -} - -data QueryCmd t where - Exprs :: QueryCmd (Expr Annotation) - Blocks :: QueryCmd (Block Annotation) - Decls :: QueryCmd (Decl Annotation) - Locs :: QueryCmd Access - Vars :: QueryCmd (Expr Annotation) - -{-| 'from' takes a command as its first parameter, a piece of syntax as its second, and - returns all pieces of syntax matching the query request. - - For example: @from Decls x@ returns a list of all declarations in @x@, of type @[Decl Annotation]@ - If @x@ is itself a declaration then this is returned as well (so be careful with recursive functions - over things defined in turns of 'from'. See 'topFrom' for a solution to this. --} -from :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] -from Locs x = accesses x -from Vars x = [v | v@(Var _ _ _) <- (universeBi x)::[Expr Annotation]] -from _ x = (universeBi x)::[synTyp] - -{-| 'topFrom' takes a command as first parameter, a piece of syntax as its second, and - returns all pieces of syntax matching the query request that are *children* of the current - piece of syntax. This means that it will not return itself. -} - -topFrom :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] -topFrom Locs x = accesses x -topFrom _ x = (childrenBi x)::[synTyp] - - diff --git a/Analysis/Types.hs b/Analysis/Types.hs deleted file mode 100644 --- a/Analysis/Types.hs +++ /dev/null @@ -1,108 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Analysis.Types where - -import Data.List -import Data.Char -import Data.Data -import Control.Monad.State.Lazy - -import Data.Generics.Uniplate.Operations - -import Analysis.Syntax -import Language.Fortran - -type TypeEnv t = [(Variable, Type t)] -type TypeEnvStack t = [TypeEnv t] -- stack of environments - -typeAnnotations :: (Typeable a, Data a) => Program a -> State (TypeEnv a) (Program a) -typeAnnotations = mapM (descendBiM buildTypeEnv) - -typeEnv :: (Typeable a, Data a) => Block a -> TypeEnv a -typeEnv x = snd $ runState (buildTypeEnv x) [] - -tenvLookup :: Variable -> TypeEnv t -> Maybe (Type t) -tenvLookup v = lookup (lowercase v) - - -buildTypeEnv :: (Typeable a, Data a) => Block a -> State (TypeEnv a) (Block a) -buildTypeEnv x = do tenv <- get - tenv' <- return $ gtypes x - put (tenv ++ tenv') - return x - -eqType :: Variable -> Variable -> TypeEnv t -> Bool -eqType v1 v2 vs = case lookup v1 vs of - Nothing -> False - Just t1 -> case lookup v2 vs of - Nothing -> False - Just t2 -> (AnnotationFree t1 == AnnotationFree t2) - - -gtypes :: forall a t . (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> TypeEnv a -gtypes x = let decAndTypes :: [([(Expr a, Expr a, Maybe Int)], Type a)] - decAndTypes = [(d, t) | (Decl _ _ d t) <- (universeBi x)::[Decl a]] - in concatMap (\(d, t) -> - [(lowercase v, toArrayType t es) | (Var _ _ [(VarName _ v, es)], _, _) <- d]) decAndTypes - -lowercase = map toLower - -isArrayTypeP :: Variable -> State (TypeEnv t) Bool -isArrayTypeP v = do tenv <- get - case (lookup v tenv) of - Nothing -> error $ "Variable not found: " ++ v - Just t -> case t of - (ArrayT _ _ _ _ _ _) -> return $ True - _ -> return $ False - -isArrayTypeP' :: (TypeEnv t) -> Variable -> Bool -isArrayTypeP' env v = case (lookup v env) of - Nothing -> False -- probably a primitive - Just t -> case t of - (ArrayT _ _ _ _ _ _) -> True - _ -> False - -toArrayType (BaseType x b a e1 e2) es - | boundsP es = ArrayT x (bounds es) b a e1 e2 - | otherwise = BaseType x b a e1 e2 -toArrayType t es = t - -arrayElementType :: Type p -> Type p -arrayElementType (ArrayT a dims t attrs kind len) = BaseType a t attrs kind len -arrayElementType t = t - -boundsP [] = False -boundsP ((Bound _ _ _ _):es) = True || (boundsP es) -boundsP _ = False - -bounds [] = [] -bounds ((Bound _ _ e1 e2):es) = (e1, e2) : (bounds es) -bounds _ = error "Bound expression is of the wrong form" - - -{- OLD - predBounds [] = False - predBounds [(Bound _ _ _)] = True - predBounds ((Bound _ _ _):bs) = True || predBounds bs - predBounds _ = False - - declsWithBounds :: forall a . (Data a, Typeable a) => [Program a] -> [String] - declsWithBounds x = [v | (VarName _ v, b) <- (universeBi ((universeBi x)::[Decl a]))::[(VarName a, [Expr a])], predBounds b] - --} diff --git a/Extensions/UnitParser.y b/Extensions/UnitParser.y deleted file mode 100644 --- a/Extensions/UnitParser.y +++ /dev/null @@ -1,151 +0,0 @@ -{ -module Extensions.UnitParser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -} - -%monad { Maybe } { >>= } { return } -%name parseUnit UNIT -%tokentype { Token } - -%token - unit { TId "unit" } - id { TId $$ } - one { TNum "1" } - num { TNum $$ } - '-' { TMinus } - '**' { TExponentiation } - '/' { TDivision } - '::' { TDoubleColon } - '=' { TEqual } - '(' { TLeftPar } - ')' { TRightPar } - -%left '/' -%left '**' -%% - -UNIT :: { UnitStatement } -: unit UEXP VARIABLE_ANNOTATION { UnitAssignment $3 $2 } -| unit '::' id '=' UEXP { UnitAlias $3 $5 } - -VARIABLE_ANNOTATION :: { Maybe String } -: '::' id { Just $2 } -| {-EMPTY-} { Nothing } - -UEXP :: { UnitOfMeasure } -: UEXP_LEVEL1 { $1 } -| one { Unitless } -| '(' ')' { Unitless } - -UEXP_LEVEL1 :: { UnitOfMeasure } -: UEXP_LEVEL1 UEXP_LEVEL2 { UnitProduct $1 $2 } -| UEXP_LEVEL1 '/' UEXP_LEVEL2 { UnitQuotient $1 $3 } -| UEXP_LEVEL2 { $1 } - -UEXP_LEVEL2 :: { UnitOfMeasure } -: UEXP_LEVEL2 '**' POW { UnitExponentiation $1 $3 } -| '(' UEXP_LEVEL1 ')' { $2 } -| id { UnitBasic $1 } - -POW :: { UnitPower } -: SIGNED_NUM { UnitPowerInteger $1 } -| '(' SIGNED_NUM ')' { UnitPowerInteger $2 } -| '(' SIGNED_NUM '/' SIGNED_NUM ')' { UnitPowerRational $2 $4 } - -SIGNED_NUM :: { Integer } -: NUM { read $1 } -| '-' NUM { read $ '-' : $2 } - -NUM :: { String } -: num { $1 } -| one { "1" } - -{ - -data UnitStatement = - UnitAssignment (Maybe String) UnitOfMeasure - | UnitAlias String UnitOfMeasure - -instance Show UnitStatement where - show (UnitAssignment (Just s) uom) = "= unit (" ++ show uom ++ ") :: " ++ s - show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")" - show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom - -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - -instance Show UnitOfMeasure where - show Unitless = "1" - show (UnitBasic s) = s - show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 - show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 - show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" - -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 - -data Token = - TUnit - | TDoubleColon - | TExponentiation - | TDivision - | TMinus - | TEqual - | TLeftPar - | TRightPar - | TId String - | TNum String - deriving (Show) - -lexer :: String -> Maybe [ Token ] -lexer ('=':xs) = lexer' xs -lexer _ = Nothing - -addToTokens :: Token -> String -> Maybe [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer' :: String -> Maybe [ Token ] -lexer' [] = Just [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':'*':xs) = addToTokens TExponentiation xs -lexer' ('/':xs) = addToTokens TDivision xs -lexer' ('-':xs) = addToTokens TMinus xs -lexer' ('=':xs) = addToTokens TEqual xs -lexer' ('(':xs) = addToTokens TLeftPar xs -lexer' (')':xs) = addToTokens TRightPar xs -lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = Nothing - where - aux p cons = - let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) -lexer' _ = Nothing - -unitParser :: String -> Maybe UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens - -happyError :: [ Token ] -> Maybe a -happyError _ = Nothing - -} diff --git a/Extensions/UnitSyntaxConversion.hs b/Extensions/UnitSyntaxConversion.hs deleted file mode 100644 --- a/Extensions/UnitSyntaxConversion.hs +++ /dev/null @@ -1,318 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleInstances #-} - -module Extensions.UnitSyntaxConversion ( convertSyntax - , convertSyntaxBack ) where - -import Prelude hiding (getLine) -import Data.List (isPrefixOf, isInfixOf, find, (\\), intercalate) -import Data.Char (isSpace, toLower) -import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Maybe (fromJust) - -import GHC.Exts (sortWith) - -import qualified Language.Fortran as LF - -import Extensions.UnitParser - -import Debug.Trace - -convertSyntax :: String -> String -> LF.Program () -> LF.Program () -convertSyntax fn src ast = - let (attrs, decls) = convert . cluster fn $ src - in addAliasDecls decls (addUnitAttrs attrs ast) - -convertSyntaxBack :: String -> LF.Program () -> String -convertSyntaxBack src ast = unlines (go info processedSource) - where - info = gatherUnitInformation ast - processedSource = processSource src - averageSpace = round $ (fromIntegral $ foldr ((+) . length . takeWhile isSpace) 0 processedSource) / (fromIntegral $ length processedSource) - go [] zs = zs - go inf@((var,uom):xs) (z:zs) - | isInfixOf var z = ((replicate averageSpace ' ') - ++ show' (UnitAssignment (Just var) uom)) : (go xs (z:zs)) - | otherwise = z : go inf zs - go qs _ = error "Not all unit annotations are correctly declared." - show' uom = "!" ++ show uom - --- Back to the source - -processSource :: String -> [ String ] -processSource src = - let ls = lines . map toLower $ src - in map snd . filter p . zip (map parse $ ls) $ ls - where - parse s = - case dropWhile isSpace s of - '!':xs -> unitParser xs - _ -> Nothing - p (Just UnitAssignment{}, _) = False - p _ = True - -gatherUnitInformation :: LF.Program () -> [ (String, UnitOfMeasure) ] -gatherUnitInformation ast = - let decls = [ d | d@(LF.Decl () _ _ _) <- universeBi ast ] - in foldr update' [ ] decls - where - update' decl mapping = - let names = [ name | LF.VarName () name <- universeBi decl ] - units = [ fromOldUnits u | LF.MeasureUnit () u <- universeBi decl ] - in foldr (:) mapping [ (map toLower name, unit) | name <- names, unit <- units ] - --- Source to new units of measure - -type TargetIndex = Int -type Line = Int - -type SrcSpan = (LF.SrcLoc, LF.SrcLoc) - -type ElaborateAttr = (LF.Attr (), Maybe String) - -containsSpan :: (LF.Span a, LF.Span b) => a -> b -> Bool -containsSpan a b - | (LF.SrcLoc _ l1 _, LF.SrcLoc _ l2 _) <- LF.srcSpan a - , (LF.SrcLoc _ l1' _, LF.SrcLoc _ l2' _) <- LF.srcSpan b - = l1 <= l1' && l2' <= l2 - -addUnitAttrs :: [ ([ ElaborateAttr ], TargetIndex) ] - -> LF.Program () - -> LF.Program () -addUnitAttrs attrStrIs ast = foldr addUnitAttr ast attrStrIs - where - addUnitAttr (attrStrs, ti) ast' - | null attrStrs = error "Attributes should not be empty." - {- - | length attrs' == 1 = - transformBi (breakUp ti attrs') ast' --} - | Just names <- mapM snd attrStrs = transformBi (breakUp ti attrStrs) ast' - | otherwise = error "Unit annotations needs to include names." - breakUp ti attrStrs (b :: LF.Block ()) = descendBi (breakUp' ti attrStrs) b - -- If there is a single declaration, then we have Decl inside Block - breakUp' ti attrStrs d@(LF.Decl () s ls t) - | getLine s == ti = - let newDecls = genNewDecls attrStrs d - in append newDecls (LF.NullDecl () s) - | otherwise = d - -- If there are multiple declarations we have DSeq inside Block - breakUp' ti attrStrs d@(LF.DSeq () decl@(LF.Decl () s ls t) drest) - | getLine s == ti = - let newDecls = genNewDecls attrStrs decl - in append newDecls drest - | (LF.DSeq () decl drest) <- d = LF.DSeq () decl (breakUp' ti attrStrs drest) - breakUp' _ _ x = x - genNewDecls :: [ (LF.Attr (), Maybe String) ] -> LF.Decl () -> [ LF.Decl () ] - genNewDecls attrStrs (LF.Decl () s ls t) = - let decls = map (\l -> LF.Decl () s [ l ] t) ls - dNames = extractNames ls - aNames = map (\s -> fromJust . snd $ s) attrStrs - diff = aNames \\ dNames - in if null diff - then let (pairs, rest) = pair aNames decls attrStrs - newDecls = map (\(a,b) -> transformBi (trans (getLine s) b) a) pairs - in newDecls ++ rest - else error $ "Annotated variables " ++ (intercalate ", " diff) ++ " do not appear in the following declaration." - pair intersection decls attrStrs = - let pickedDecls = filter (\d -> extractName d `elem` intersection) decls - sDecls = sortWith extractName pickedDecls - sAttrs = map fst $ sortWith (fromJust . snd) attrStrs - in (zip sDecls sAttrs, decls \\ pickedDecls) - append [ ] drest = drest - append (d:ds) drest = LF.DSeq () d (append ds drest) - trans ti attr d@(LF.Decl () s@((LF.SrcLoc _ l _),_) ls t) - | l == ti = - LF.Decl () s ls $ - case t of - LF.BaseType () a as b c -> - LF.BaseType () a (attr : as) b c - LF.ArrayT () z a as b c -> - LF.ArrayT () z a (attr : as) b c - | otherwise = d - trans _ _ x = x - - -class Named a where - extractNames :: a -> [ String ] - extractName :: a -> String - -extractName' :: (LF.Expr (), b, c) -> String -extractName' ((LF.Var _ _ [(LF.VarName _ name, _)]),_,_) = name -instance Named [ (LF.Expr (), b, c) ] where - extractNames = map extractName' - -instance Named (LF.Decl ()) where - extractNames (LF.Decl _ _ ls _) = extractNames ls - extractName (LF.Decl _ _ [ l ] _) = extractName' l - -addAliasDecls :: [ LF.Decl () ] -> LF.Program () -> LF.Program () -addAliasDecls decls ast = foldr addAliasDecl ast decls - where - addAliasDecl decl ast' = - let p = smallest [ p | (p :: LF.ProgUnit ()) <- universeBi ast', p `containsSpan` decl ] - in transformBi (trans decl p) ast' - trans decl p1 p2 - | p1 == p2 = insertDecl decl p2 - | otherwise = p2 - trans _ _ p = p - smallest ps = - let m = minimum $ map (getLen . LF.srcSpan) ps - in case find (\a -> (getLen . LF.srcSpan) a == m) ps of - Just a -> a - Nothing -> error "Couldn't find ProgUnit" - getLen (LF.SrcLoc _ l1 _, LF.SrcLoc _ l2 _) = l2 - l1 - -insertDecl :: LF.Decl () -> LF.ProgUnit () -> LF.ProgUnit () -insertDecl decl (LF.Main () a b c block d) = - LF.Main () a b c (insertDecl' decl block) d -insertDecl decl (LF.Sub () a b c d block) = - LF.Sub () a b c d (insertDecl' decl block) -insertDecl decl (LF.Function () a b c d e block) = - LF.Function () a b c d e (insertDecl' decl block) -insertDecl decl (LF.Module () a b c d decls e) = - LF.Module () a b c d (LF.DSeq () decl decls) e -insertDecl decl (LF.BlockData () a b c d decls) = - LF.BlockData () a b c d (LF.DSeq () decl decls) - -insertDecl' :: LF.Decl () -> LF.Block () -> LF.Block () -insertDecl' decl (LF.Block () a b c decls d) = - (LF.Block () a b c (LF.DSeq () decl decls) d) - -getLine :: SrcSpan -> Line -getLine (LF.SrcLoc _ l _, _) = l - -convert :: ( [ ([ UnitStatement ], TargetIndex) ] - , [ (UnitStatement, SrcSpan) ] ) - -> ( [ ([ElaborateAttr], TargetIndex) ] - , [ LF.Decl () ] ) -convert (attrs, decls) = (map l attrs, map r decls) - where - l (uss, targetIndex) = (map l' uss, targetIndex) - l' us = - case fromNewUnitStatements us of - Left attr -> attr - r (us, s) = - case fromNewUnitStatements us of - Right declF -> declF s - -cluster :: String - -> String - -> ( [ ([ UnitStatement ], TargetIndex) ] - , [ (UnitStatement, SrcSpan) ] ) -cluster f = filterCluster . cluster' . addIndex . parse f - -filterCluster (annotations, aliases) = - (filter (not . null . fst) annotations, aliases) - -cluster' :: [ (Maybe UnitStatement, SrcSpan) ] - -> ( [ ([ UnitStatement ], TargetIndex) ], - [ (UnitStatement, SrcSpan) ]) -cluster' [] = ([], []) -cluster' ((Nothing,s):xs) = - let (fs,sn) = cluster' xs - in (([],getLine s):fs, sn) -cluster' ((Just x@UnitAssignment{}, s):xs) = - case cluster' xs of - ([], as) -> ([ ([ x ], (getLine s) + 1) ], as) - ((h:t), as) -> ((x:fst h, snd h):t, as) -cluster' ((Just x@UnitAlias{}, s):xs) = - case cluster' xs of - (as, []) -> (([],getLine s):as, [ (x,s) ]) - (as, xs) -> (([],getLine s):as, (x,s):xs) - -addIndex :: [ (Maybe UnitStatement, Line -> SrcSpan) ] - -> [ (Maybe UnitStatement, SrcSpan) ] -addIndex xs = map f (zip xs [1..(length xs)]) - where - f ((us,toSrcLoc),i) = (us, toSrcLoc i) - -parse :: String - -> String - -> [ (Maybe UnitStatement, Line -> SrcSpan) ] -parse fn src = map (t 0) $ lines src - where - t col line - | isPrefixOf " " line = t (col + 1) (tail line) - | isPrefixOf "!" line = - (unitParser $ tail line, genSrcLoc col (length line)) - | otherwise = (Nothing, genSrcLoc 0 0) - genSrcLoc c len l = (LF.SrcLoc fn l c, LF.SrcLoc fn c (c + len)) - --- Convert new units of measure to old units of measure -fromNewUnitStatements :: UnitStatement - -> (Either ElaborateAttr) - (SrcSpan -> LF.Decl ()) -fromNewUnitStatements (UnitAssignment ms uom) = - Left (LF.MeasureUnit () (fromNewUnits uom), ms) -fromNewUnitStatements (UnitAlias s uom) = - Right $ flip (LF.MeasureUnitDef ()) [ (s, fromNewUnits uom) ] - -fromNewUnits :: UnitOfMeasure -> LF.MeasureUnitSpec () -fromNewUnits Unitless = LF.UnitNone () -fromNewUnits uom@(UnitBasic s) = LF.UnitProduct () (fromNewUnits' uom) -fromNewUnits (UnitProduct uom1 uom2) = - LF.UnitProduct () $ fromNewUnits' uom1 ++ fromNewUnits' uom2 -fromNewUnits (UnitQuotient uom1 uom2) = - LF.UnitQuotient () (fromNewUnits' uom1) (fromNewUnits' uom2) - -fromNewUnits' :: UnitOfMeasure -> [ (LF.MeasureUnit, LF.Fraction ()) ] -fromNewUnits' (UnitProduct uom1 uom2) = - fromNewUnits' uom1 ++ fromNewUnits' uom2 -fromNewUnits' (UnitBasic s) = [(s, LF.NullFraction ())] -fromNewUnits' (UnitExponentiation uom power) = - case uom of - UnitBasic s -> - case power of - UnitPowerInteger i -> [ (s, LF.IntegerConst () $ show i) ] - UnitPowerRational i1 i2 -> [ (s, LF.FractionConst () (show i1) (show i2)) ] - _ -> error "Only base units can be exponentiated." -fromNewUnits' (UnitQuotient _ _) = - error "Unit should have only one division." -fromNewUnits' Unitless = - error "Unit should not have unitless component inside." - --- Convert old units of measure to new units of measure -fromOldUnitAttribute :: String -> LF.Attr () -> Maybe UnitStatement -fromOldUnitAttribute s (LF.MeasureUnit () oldUnits) = - Just $ UnitAssignment (Just s) (fromOldUnits oldUnits) -fromOldUnitAttribute _ _ = Nothing - -fromOldUnitAlias :: LF.Decl () -> UnitStatement -fromOldUnitAlias (LF.MeasureUnitDef () _ [ (name, oldUnits) ] ) = - UnitAlias name (fromOldUnits oldUnits) - -fromOldUnits :: LF.MeasureUnitSpec () -> UnitOfMeasure -fromOldUnits (LF.UnitNone ()) = Unitless -fromOldUnits (LF.UnitProduct () [ (s, LF.NullFraction ()) ]) = UnitBasic s -fromOldUnits (LF.UnitProduct () xs) = fromOldUnits' xs -fromOldUnits (LF.UnitQuotient () l r) = UnitQuotient (fromOldUnits' l) (fromOldUnits' r) - -fromOldUnits' :: [ (LF.MeasureUnit, LF.Fraction ()) ] -> UnitOfMeasure -fromOldUnits' [ x ] = fromOldUnits'' x -fromOldUnits' (x:xs) = UnitProduct (fromOldUnits'' x) (fromOldUnits' xs) - -fromOldUnits'' :: (LF.MeasureUnit, LF.Fraction ()) -> UnitOfMeasure -fromOldUnits'' (s, LF.NullFraction ()) = UnitBasic s -fromOldUnits'' (s, f) = UnitExponentiation (UnitBasic s) $ fromOldUnits''' f - -fromOldUnits''' :: LF.Fraction () -> UnitPower -fromOldUnits''' (LF.FractionConst () i1 i2) = UnitPowerRational (read i1) (read i2) -fromOldUnits''' (LF.IntegerConst () i) = UnitPowerInteger (read i) diff --git a/Extensions/Units.hs b/Extensions/Units.hs deleted file mode 100644 --- a/Extensions/Units.hs +++ /dev/null @@ -1,1515 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{- - - Units of measure extension to Fortran - - Files: Units.hs - UnitsEnvironment.hs - - -TODO: - * Deal with variable shadowing in "contained" functions. - * Better errors with line number info - --} - - -{-# LANGUAGE ScopedTypeVariables, ImplicitParams, DoAndIfThenElse #-} - -module Extensions.Units where - -import Data.Ratio -import Data.Maybe -import Data.Matrix -import Data.List -import Data.Char (isNumber) -import qualified Data.Vector as V -import Data.Label.Mono (Lens) -import qualified Data.Label -import Data.Label.Monadic hiding (modify) -import Data.Function -import Data.Data -import Data.Char -import Control.Monad.State.Strict hiding (gets) -import Data.Generics.Uniplate.Operations - -import Helpers -import Output -import Analysis.Annotations -import Analysis.Syntax -import Analysis.Types -import Extensions.UnitsEnvironment -- Provides the types and data accessors used in this module -import Extensions.UnitsSolve -- Solvers for the Gaussian matrix - -import Language.Fortran -import Language.Fortran.Pretty -import Transformation.Syntax - --- For debugging and development purposes -import qualified Debug.Trace as D - -{- HELPERS -} - --- Update a list state by consing -infix 2 << -(<<) :: MonadState f m => Lens (->) f [o] -> o -> m () -(<<) lens o = lens =. (o:) - --- Update a list state by appending -infix 2 <<++ -(<<++) lens o = lens =. (++ [o]) - -{- START HERE! Two main functions of this file: inferUnits and removeUnits -} - -removeUnits :: (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -removeUnits (fname, x) = let ?criticals = False in ("", (fname, map (descendBi removeUnitsInBlock) x)) - - --- ************************************* --- Unit inference (top - level) --- ************************************* - - -inferCriticalVariables :: (?solver :: Solver, ?assumeLiterals :: AssumeLiterals) => - (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -inferCriticalVariables (fname, x) = - let ?criticals = True - ?debug = False - in let infer = do doInferUnits x - vars <- criticalVars - case vars of - [] -> do report <<++ "No critical variables. Appropriate annotations." - _ -> do report <<++ "Critical variables: " ++ (concat $ intersperse "," vars) - ifDebug debugGaussian - - - - (_, env) = runState infer emptyUnitEnv - r = concat [fname ++ ": " ++ r ++ "\n" | r <- Data.Label.get report env] - in (r, (fname, x)) - -inferUnits :: (?solver :: Solver, ?assumeLiterals :: AssumeLiterals) => (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -inferUnits (fname, x) = - let ?criticals = False - ?debug = False - in let (y, env) = runState (doInferUnits x) emptyUnitEnv - r = concat [fname ++ ": " ++ r ++ "\n" | r <- Data.Label.get report env] - ++ fname ++ ": checked/inferred " - ++ (show $ countVariables (_varColEnv env) (_debugInfo env) (_procedureEnv env) (fst $ _linearSystem env) (_unitVarCats env)) - ++ " user variables\n" - in (r, (fname, y)) - - -countVariables vars debugs procs matrix ucats = - length $ filter (\c -> case (ucats !! (c - 1)) of - Variable -> case (lookupVarsByCols vars [c]) of - [] -> False - _ -> True - Argument -> case (lookupVarsByCols vars [c]) of - [] -> False - _ -> True - _ -> False) [1..ncols matrix] - -doInferUnits :: (?criticals :: Bool, ?solver :: Solver, ?debug :: Bool, ?assumeLiterals :: AssumeLiterals) => Program Annotation -> State UnitEnv (Program Annotation) -doInferUnits x = do mapM inferProgUnits x - ifDebug (report <<++ "Finished inferring prog units") - ifDebug debugGaussian - inferInterproceduralUnits x - succeeded <- gets success - p <- if (?criticals || (not succeeded)) - then return x -- don't insert unit annotations - else mapM (descendBiM insertUnitsInBlock) x - (n, added) <- gets evUnitsAdded - if (?criticals || (not succeeded)) then return () else report <<++ ("Added " ++ (show n) ++ " non-unitless annotation: " ++ (concat $ intersperse "," $ added)) - return p - -inferProgUnits :: (?criticals :: Bool, ?solver :: Solver, ?debug :: Bool, ?assumeLiterals :: AssumeLiterals) => ProgUnit Annotation -> State UnitEnv () -inferProgUnits p = - do -- infer units for *root* program unit - inferPUnit p - -- infer units for the *children* program units (so that the parent scope is processed first) - mapM_ inferProgUnits $ ((children p)::[ProgUnit Annotation]) - - where - -- Infer the units for the *root* program unit (not children) - inferPUnit :: ProgUnit Annotation -> State UnitEnv () - inferPUnit (Main x sp n a b _) = inferBlockUnits b Nothing - inferPUnit (Sub x sp t (SubName _ n) (Arg _ a _) b) = inferBlockUnits b (Just (n, Nothing, argNames a)) - inferPUnit (Function _ _ _ (SubName _ n) (Arg _ a _) r b) = inferBlockUnits b (Just (n, Just (resultName n r), argNames a)) - inferPUnit (Module x sp (SubName _ n) _ _ d ds) = transformBiM (inferDecl (Just (n, Nothing, []))) d >> return () - inferPUnit x = return () - - argNames :: ArgName a -> [Variable] - argNames (ArgName _ n) = [n] - argNames (ASeq _ n1 n2) = argNames n1 ++ argNames n2 - argNames (NullArg _) = [] - - resultName :: Variable -> Maybe (VarName a) -> Variable - resultName n Nothing = n - resultName _ (Just (VarName _ r)) = r - - -inferBlockUnits :: (?solver :: Solver, ?criticals :: Bool, ?debug :: Bool, ?assumeLiterals :: AssumeLiterals) => Block Annotation -> Maybe ProcedureNames -> State UnitEnv () -inferBlockUnits x proc = do resetTemps - enterDecls x proc - addProcedure proc - descendBiM handleStmt x - - case proc of - Just _ -> {- not ?criticals -> -} - do -- Intermediate solve for procedures (subroutines & functions) - ifDebug (report <<++ "Pre doing row reduce") - consistent <- solveSystemM "" - success =: consistent - - linearSystem =. reduceRows 1 - ifDebug (report <<++ "Post doing reduce") - ifDebug (debugGaussian) - return () - _ -> return () - -- return x - - where - handleStmt :: Fortran Annotation -> State UnitEnv (Fortran Annotation) - handleStmt x = do inferStmtUnits x - return x - -{-| reduceRows is a core part of the polymorphic unit checking for procedures. - - It is essentially an "optimiation" of the Gaussian matrix (not in the sense of performance), - that elimiantes rows in the system such that there are as few variables as possible. Within - a function, assuming everything is consistent, then this should generate a linear constraint - between the parameters and the return as a single row in the matrix. This is then used by the - interprocedural constraints to hookup call-sites with definitions (in a parametrically polymorphic - way- i.e. lambda abstraction is polymorphic in its units, different to say ML). --} -reduceRows :: Col -> LinearSystem -> LinearSystem -reduceRows m (matrix, vector) - | m > ncols matrix = (matrix, vector) - | otherwise = case (find (\n -> matrix ! (n, m) /= 0) [1..nrows matrix]) of - Just r1 -> case (find (\n -> matrix ! (n, m) /= 0) [(r1 + 1)..nrows matrix]) of - Just r2 -> -- Found two rows with non-zero coeffecicients in this column - case (elimRow (matrix, vector) (Just r1) m r2) of - -- Eliminate the row and cut the system down - Ok (matrix', vector') -> reduceRows m (cutSystem r2 (matrix', vector')) - Bad _ _ _ -> reduceRows (m+1) (matrix, vector) - - Nothing -> -- If there are no two rows with non-zero coeffecieints in colum m - -- then move onto the next column - reduceRows (m+1) (matrix, vector) - Nothing -> reduceRows (m+1) (matrix, vector) - - -addProcedure :: Maybe ProcedureNames -> State UnitEnv () -addProcedure Nothing = return () -addProcedure (Just (name, resultName, argNames)) = - do uenv <- gets varColEnv - resultVar <- case resultName of - Just rname -> case (lookupWithoutSrcSpan rname uenv) of - Just (uvar, _) -> return $ Just uvar - Nothing -> do m <- addCol Variable - return $ Just (VarCol m) - Nothing -> return Nothing - let argVars = fmap (lookupUnitByName uenv) argNames - procedureEnv << (name, (resultVar, argVars)) - where - lookupUnitByName uenv v = maybe (VarCol 1) fst $ lookupWithoutSrcSpan v uenv - - - --- *************************************** --- --- * Unit inference (main, over all AST) --- --- *************************************** - -enterDecls :: (?assumeLiterals :: AssumeLiterals) => Block Annotation -> Maybe ProcedureNames -> State UnitEnv (Block Annotation) -enterDecls x proc = transformBiM (inferDecl proc) x - -processVar :: (?assumeLiterals :: AssumeLiterals) => - [UnitConstant] -> Maybe ProcedureNames -> - (Expr Annotation, Expr Annotation) -> Type Annotation -> - State UnitEnv (Expr Annotation, Expr Annotation) -processVar units proc exps@(Var a s names, e) typ = - do - let (VarName _ v, es) = head names - system <- gets linearSystem - let m = ncols (fst system) + 1 - unitVarCats <<++ (unitVarCat v proc) - extendConstraints units - ms <- case toArrayType typ es of - ArrayT _ bounds _ _ _ _ -> mapM (const $ fmap VarCol $ addCol Variable) bounds - _ -> return [] - varColEnv << (VarBinder (v, s), (VarCol m, ms)) - - uv <- gets varColEnv - -- If the declaration has a null expression, do not create a unifying variable - case e of - NullExpr _ _ -> return () - _ -> do uv <- inferExprUnits e - mustEqual False (VarCol m) uv - return () - return exps - -unitVarCat :: Variable -> Maybe ProcedureNames -> UnitVarCategory -unitVarCat v proc | Just (n, r, args) <- proc, v `elem` args = Argument - | otherwise = Variable - - -{-| inferDecl - extract and record information from explicit unit declarations -} -inferDecl :: (?assumeLiterals :: AssumeLiterals) => Maybe ProcedureNames -> Decl Annotation -> State UnitEnv (Decl Annotation) -inferDecl proc decl@(Decl a s d typ) = - do let BaseType _ _ attrs _ _ = arrayElementType typ - units <- sequence $ concatMap extractUnit attrs - mapM_ (\(e1, e2, multiplier) -> processVar units proc (e1, e2) typ) d - return $ decl - -inferDecl proc x@(MeasureUnitDef a s d) = - do mapM learnDerivedUnit d - return x - where - learnDerivedUnit (name, spec) = - do denv <- gets derivedUnitEnv - when (isJust $ lookup name denv) $ error "Redeclared unit of measure" - unit <- convertUnit spec - denv <- gets derivedUnitEnv - when (isJust $ lookup name denv) $ error "Recursive unit-of-measure definition" - derivedUnitEnv << (name, unit) -inferDecl _ x = return x - -extendConstraints :: [UnitConstant] -> State UnitEnv () -extendConstraints units = - do (matrix, vector) <- gets linearSystem - let n = nrows matrix + 1 - m = ncols matrix + 1 - linearSystem =: case units of - [] -> do (extendTo 0 0 m matrix, vector) - _ -> (setElem 1 (n, m) $ extendTo 0 n m matrix, vector ++ [last units]) - tmpColsAdded << m - tmpRowsAdded << n - return () - -inferInterproceduralUnits :: (?solver :: Solver, ?criticals :: Bool, ?debug :: Bool, ?assumeLiterals :: AssumeLiterals) => Program Annotation -> State UnitEnv () -inferInterproceduralUnits x = - do --reorderColumns - if ?criticals then reorderVarCols else return () - consistent <- solveSystemM "inconsistent" - if consistent then - do system <- gets linearSystem - let dontAssumeLiterals = case ?assumeLiterals of - Poly -> True - Unitless -> False - Mixed -> False - inferInterproceduralUnits' x dontAssumeLiterals system -- edited - return () - else - return () - -inferInterproceduralUnits' :: (?solver :: Solver, ?criticals :: Bool, ?debug :: Bool) => Program Annotation -> Bool -> LinearSystem -> State UnitEnv (Program Annotation) -inferInterproceduralUnits' x haveAssumedLiterals system1 = - do addInterproceduralConstraints x - consistent <- solveSystemM "inconsistent" - if not consistent then - do linearSystem =: system1 - return x - else do - system2 <- gets linearSystem - if system1 == system2 - then if ?criticals then nextStep else checkUnderdeterminedM >> nextStep - else inferInterproceduralUnits' x haveAssumedLiterals system2 - where nextStep | haveAssumedLiterals = return x - | otherwise = do consistent <- assumeLiteralUnits - if not consistent - then return x - else do system3 <- gets linearSystem - inferInterproceduralUnits' x True system3 - - -class UpdateColInfo t where - updateColInfo :: Col -> Col -> t -> t - -instance UpdateColInfo VarCol where - updateColInfo x n (VarCol y) | y == x = VarCol n - | y == n = VarCol x - | otherwise = VarCol y - -instance UpdateColInfo VarColEnv where - updateColInfo _ _ [] = [] - updateColInfo x n ((v, (uv, uvs)):ys) = (v, (updateColInfo x n uv, map (updateColInfo x n) uvs)) : (updateColInfo x n ys) - -instance UpdateColInfo Procedure where - updateColInfo x n (Nothing, ps) = (Nothing, map (updateColInfo x n) ps) - updateColInfo x n (Just p, ps) = (Just $ updateColInfo x n p, map (updateColInfo x n) ps) - -instance UpdateColInfo ProcedureEnv where - updateColInfo x n = map (\(s, p) -> (s, updateColInfo x n p)) - -instance UpdateColInfo (Int, a) where - updateColInfo x n (y, s) | y == x = (n, s) - | y == n = (x, s) - | otherwise = (y, s) - -instance UpdateColInfo Int where - updateColInfo x n y | y == x = x - | y == n = n - | otherwise = y - -swapUnitVarCats x n xs = swapUnitVarCats' x n xs xs 1 -swapUnitVarCats' x n [] ys c = [] -swapUnitVarCats' x n (z:zs) ys c | c == x = (ys !! (n - 1)) : (swapUnitVarCats' x n zs ys (c + 1)) - | c == n = (ys !! (x - 1)) : (swapUnitVarCats' x n zs ys (c + 1)) - | otherwise = z : (swapUnitVarCats' x n zs ys (c + 1)) - -swapCols :: Int -> Int -> State UnitEnv () -swapCols x n = do --report <<++ ("Pre swap - " ++ (show x) ++ " <-> " ++ (show n)) - --debugGaussian - varColEnv =. updateColInfo x n - procedureEnv =. updateColInfo x n - calls =. updateColInfo x n - unitVarCats =. swapUnitVarCats x n - linearSystem =. (\(m, v) -> (switchCols x n m, v)) - debugInfo =. map (updateColInfo x n) - tmpColsAdded =. map (updateColInfo x n) - --report <<++ "Post swap" - --debugGaussian - return () - - -{-| reorderVarCols puts any variable columns to the end of the Gaussian matrix (along with the associated information) -} -reorderVarCols :: State UnitEnv () -reorderVarCols = do ucats <- gets unitVarCats - (matrix, _) <- gets linearSystem - reorderVarCols' (ncols matrix) 1 - where correctEnd :: Int -> State UnitEnv Int - correctEnd 0 = return 0 - correctEnd end = do ucats <- gets unitVarCats - case (ucats !! (end - 1)) of - Variable -> correctEnd (end - 1) - _ -> return $ end - - reorderVarCols' :: Int -> Int -> State UnitEnv () - reorderVarCols' end c | c >= end = return () - reorderVarCols' end c = do ucats <- gets unitVarCats - case (ucats !! (c - 1)) of - Variable -> do end' <- correctEnd end - swapCols end' c - reorderVarCols' (end' - 1) (c+1) - _ -> reorderVarCols' end (c+1) - -assumeLiteralUnits :: (?solver :: Solver, ?debug :: Bool) => State UnitEnv Bool -assumeLiteralUnits = - do system@(matrix, vector) <- gets linearSystem - mapM_ assumeLiteralUnits' [1 .. ncols matrix] - consistent <- solveSystemM "underdetermined" - when (not consistent) $ linearSystem =: system - return consistent - -assumeLiteralUnits' m = - do (matrix, vector) <- gets linearSystem - ucats <- gets unitVarCats - let n = find (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix] - m' = n >>= (\n -> find (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix]) - nonLiteral n m = matrix ! (n, m) /= 0 && ucats !! (m - 1) /= (Literal True) - m's = n >>= (\n -> find (nonLiteral n) [1 .. ncols matrix]) - when (ucats !! (m - 1) == (Literal True) && (m' /= Just m || isJust m's)) $ do - n' <- addRow - modify $ liftUnitEnv $ setElem 1 (n', m) - -addInterproceduralConstraints :: (?debug :: Bool) => Program Annotation -> State UnitEnv () -addInterproceduralConstraints x = - do - cs <- gets calls - mapM_ addCall cs - where - addCall (name, (result, args)) = - do penv <- gets procedureEnv - case lookup name penv of - Just (r, as) -> - let (r1, r2) = decodeResult result r - in handleArgs (args ++ r1) (as ++ r2) - Nothing -> return () - - handleArgs actualVars dummyVars = - do order <- gets reorderedCols - let actual = map (\(VarCol uv) -> uv) actualVars - dummy = map (\(VarCol uv) -> uv) dummyVars - mapM_ (handleArg $ zip dummy actual) dummy - - -- experimentation but now deprecated. -{- - handleArgNew dummyToActual dummy = - do grid0 <- debugGaussian' - mapM (\(l, r) -> do n <- addRow - modify $ liftUnitEnv $ setElem 1 (n, l) - modify $ liftUnitEnv $ setElem (-1) (n, r) - ) dummyToActual - grid1 <- debugGaussian' - if (grid0 == grid1) then - return () - else - do report <<++ "HANDLED AND DIFFERENT!" - report <<++ ("\n" ++ grid0) - report <<++ ("\n" ++ grid1) - return ()-} - - -- TODO: this can be optimised - handleArg dummyToActual dummy = - do (matrix, vector) <- gets linearSystem - --grid0 <- debugGaussian' - ifDebug (debugGaussian) - - ifDebug (report <<++ ("hArg - " ++ show dummyToActual ++ "-" ++ show dummy)) - - let -- find the first row with a non-zero column for the variable - n = maybe 1 id $ find (\n -> matrix ! (n, dummy) /= 0) [1 .. nrows matrix] - - -- find the first non-zero column on the row just selected - Just m = find (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix] - - ifDebug (report <<++ ("n = " ++ show n ++ ", m = " ++ show m)) - - if (m == dummy) then - do let -- Get list of columns with non-zero coefficients to the right of the focus - ms = filter (\m -> matrix ! (n, m) /= 0) [m .. ncols matrix] - - -- Get the list of columns to which the non-zero coeffecients are paired by 'dummyToActual' relation. - m's = mapMaybe (flip lookup dummyToActual) ms - pairs = --if (length m's == 1) then -- i.e. there is not a direct relationship between variable and return - -- zip ms (repeat (head m's)) - --else - (zip ms m's) - - ifDebug(report <<++ ("ms = " ++ show ms ++ ", m's' = " ++ show m's ++ ", their zip = " ++ show pairs ++ " dA = " ++ show dummyToActual)) - - if (True) -- length m's == length ms) - then do { newRow <- addRow' $ vector !! (n - 1); --- mapM_ (handleArgPair matrix n newRow) pairs ; } - mapM_ (handleArgPair matrix n newRow) dummyToActual ; } - else return () - else - return () - - -- Copy the row - handleArgPair matrix n newRow (m, m') = do modify $ liftUnitEnv $ setElem (matrix ! (n, m)) (newRow, m') - - decodeResult (Just r1) (Just r2) = ([r1], [r2]) - decodeResult Nothing Nothing = ([], []) - decodeResult (Just _) Nothing = error "Subroutine used as a function!" - decodeResult Nothing (Just _) = error "Function used as a subroutine!" - - -inferLiteral e = do uv@(VarCol uvn) <- anyUnits (Literal (?assumeLiterals /= Mixed)) - debugInfo << (uvn, (srcSpan e, pprint e)) - return uv - - -data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp -binOpKind :: BinOp a -> BinOpKind -binOpKind (Plus _) = AddOp -binOpKind (Minus _) = AddOp -binOpKind (Mul _) = MulOp -binOpKind (Div _) = DivOp -binOpKind (Or _) = LogicOp -binOpKind (And _) = LogicOp -binOpKind (Concat _)= AddOp -binOpKind (Power _) = PowerOp -binOpKind (RelEQ _) = RelOp -binOpKind (RelNE _) = RelOp -binOpKind (RelLT _) = RelOp -binOpKind (RelLE _) = RelOp -binOpKind (RelGT _) = RelOp -binOpKind (RelGE _) = RelOp - -(<**>) :: Maybe a -> Maybe a -> Maybe a -Nothing <**> x = x -(Just x) <**> y = (Just x) - -lookupCaseInsensitive :: String -> [(String, a)] -> Maybe a -lookupCaseInsensitive x m = let x' = map toUpper x in (find (\(k, v) -> (map toUpper k) == x') m) >>= (return . snd) - -lookupWithoutSrcSpan :: Variable -> [(VarBinder, a)] -> Maybe a -lookupWithoutSrcSpan v env = snd `fmap` find f env - where - f (VarBinder (w, _), _) = map toUpper w == v' - v' = map toUpper v - -lookupWithSrcSpan :: Variable -> SrcSpan -> [(VarBinder, a)] -> Maybe a -lookupWithSrcSpan v s env = snd `fmap` find f env - where - f (VarBinder (w, t), _) = map toUpper w == v' && s == t - v' = map toUpper v - -inferExprUnits :: (?assumeLiterals :: AssumeLiterals) => Expr Annotation -> State UnitEnv VarCol -inferExprUnits e@(Con _ _ _) = inferLiteral e -inferExprUnits e@(ConL _ _ _ _) = inferLiteral e -inferExprUnits e@(ConS _ _ _) = inferLiteral e -inferExprUnits ve@(Var _ _ names) = - do uenv <- gets varColEnv - penv <- gets procedureEnv - let (VarName _ v, args) = head names - - case lookupWithoutSrcSpan v uenv of - -- array variable? - Just (uv, uvs@(_:_)) -> inferArgUnits' uvs >> return uv - -- function call? - Nothing | not (null args) -> do case (lookup (map toUpper v) intrinsicsDict) of - Just fun -> fun v - Nothing -> return () -- error $ "I don't know the intrinsic " ++ v -- return () - uv@(VarCol uvn) <- anyUnits Temporary - debugInfo << (uvn, (srcSpan ve, pprint ve)) - uvs <- inferArgUnits - let uvs' = justArgUnits args uvs - calls << (v, (Just uv, uvs')) - return uv - -- scalar variable or external function call? - Just (uv, []) -> inferArgUnits >> return uv - -- default specifier - _ | v == "*" -> inferLiteral ve - -- just bad code - x -> case lookupCaseInsensitive v penv of - Just (Just uv, argUnits) -> - if (null args) then inferArgUnits' argUnits >> return uv - else do uv <- anyUnits Temporary - uvs <- inferArgUnits - let uvs' = justArgUnits args uvs - calls << (v, (Just uv, uvs')) - return uv - - Nothing -> error $ "\n" ++ (showSrcFile . srcSpan $ ve) ++ ": undefined variable " ++ v ++ " at " ++ (showSrcSpan . srcSpan $ ve) - where inferArgUnits = sequence [mapM inferExprUnits exprs | (_, exprs) <- names, not (nullExpr exprs)] - inferArgUnits' uvs = sequence [(inferExprUnits expr) >>= (\uv' -> mustEqual True uv' uv) | ((_, exprs), uv) <- zip names uvs, expr <- exprs, not (nullExpr [expr])] - - nullExpr [] = False - nullExpr [NullExpr _ _] = True - nullExpr ((NullExpr _ _):xs) = nullExpr xs - nullExpr _ = False - - justArgUnits [NullExpr _ _] _ = [] -- zero-argument function call - justArgUnits _ uvs = head uvs -inferExprUnits e@(Bin _ _ op e1 e2) = do uv1 <- inferExprUnits e1 - uv2 <- inferExprUnits e2 - (VarCol n) <- case binOpKind op of - AddOp -> mustEqual True uv1 uv2 - MulOp -> mustAddUp uv1 uv2 1 1 - DivOp -> mustAddUp uv1 uv2 1 (-1) - PowerOp -> powerUnits uv1 e2 - LogicOp -> mustEqual True uv1 uv2 - RelOp -> do mustEqual True uv1 uv2 - return $ VarCol 1 - debugInfo << (n, (srcSpan e, pprint e)) - return (VarCol n) -inferExprUnits (Unary _ _ _ e) = inferExprUnits e -inferExprUnits (CallExpr _ _ e1 (ArgList _ e2)) = do uv <- anyUnits Temporary - inferExprUnits e1 - inferExprUnits e2 - error "CallExpr not implemented" - return uv --- inferExprUnits (NullExpr .... Shouldn't occur very often as adds unnnecessary cruft -inferExprUnits (NullExpr _ _) = anyUnits Temporary - -inferExprUnits (Null _ _) = return $ VarCol 1 -inferExprUnits (ESeq _ _ e1 e2) = do inferExprUnits e1 - inferExprUnits e2 - return $ error "ESeq units wanted" -inferExprUnits (Bound _ _ e1 e2) = do uv1 <- inferExprUnits e1 - uv2 <- inferExprUnits e2 - mustEqual False uv1 uv2 -inferExprUnits (Sqrt _ _ e) = do uv <- inferExprUnits e - sqrtUnits uv -inferExprUnits (ArrayCon _ _ (e:exprs)) = - do uv <- inferExprUnits e - mapM_ (\e' -> do { uv' <- inferExprUnits e'; mustEqual True uv uv'}) exprs - return uv -inferExprUnits (AssgExpr _ _ _ e) = inferExprUnits e - -inferExprSeqUnits :: (?assumeLiterals :: AssumeLiterals) => Expr Annotation -> State UnitEnv [VarCol] -inferExprSeqUnits (ESeq _ _ e1 e2) = liftM2 (++) (inferExprSeqUnits e1) (inferExprSeqUnits e2) -inferExprSeqUnits e = (:[]) `liftM` inferExprUnits e - -handleExpr :: (?assumeLiterals :: AssumeLiterals) => Expr Annotation -> State UnitEnv (Expr Annotation) -handleExpr x = do inferExprUnits x - return x - -inferForHeaderUnits :: (?assumeLiterals :: AssumeLiterals) => (Variable, Expr Annotation, Expr Annotation, Expr Annotation) -> State UnitEnv () -inferForHeaderUnits (v, e1, e2, e3) = - do uenv <- gets varColEnv - case (lookupWithoutSrcSpan v uenv) of - Just (uv, []) -> do uv1 <- inferExprUnits e1 - mustEqual True uv uv1 - uv2 <- inferExprUnits e2 - mustEqual True uv uv2 - uv3 <- inferExprUnits e3 - mustEqual True uv uv3 - return () - Nothing -> report <<++ "Ill-formed Fortran code. Variable '" ++ v ++ "' is not declared." - -inferSpecUnits :: (?assumeLiterals :: AssumeLiterals) => [Spec Annotation] -> State UnitEnv () -inferSpecUnits = mapM_ $ descendBiM handleExpr - -{-| inferStmtUnits, does what it says on the tin -} -inferStmtUnits :: (?assumeLiterals :: AssumeLiterals) => Fortran Annotation -> State UnitEnv () -inferStmtUnits e@(Assg _ _ e1 e2) = - do uv1 <- inferExprUnits e1 - uv2 <- inferExprUnits e2 - mustEqual False uv1 uv2 - return () - -inferStmtUnits (DoWhile _ _ _ f) = inferStmtUnits f -inferStmtUnits (For _ _ _ (NullExpr _ _) _ _ s) = inferStmtUnits s -inferStmtUnits (For _ _ (VarName _ v) e1 e2 e3 s) = - do inferForHeaderUnits (v, e1, e2, e3) - inferStmtUnits s - -inferStmtUnits (FSeq _ _ s1 s2) = mapM_ inferStmtUnits [s1, s2] -inferStmtUnits (If _ _ e1 s1 elseifs ms2) = - do inferExprUnits e1 - inferStmtUnits s1 - sequence [inferExprUnits e >> inferStmtUnits s | (e, s) <- elseifs] - case ms2 of - Just s2 -> inferStmtUnits s2 - Nothing -> return () -inferStmtUnits (Allocate _ _ e1 e2) = mapM_ inferExprUnits [e1, e2] -inferStmtUnits (Backspace _ _ specs) = inferSpecUnits specs -inferStmtUnits (Call _ _ (Var _ _ [(VarName _ v, [])]) (ArgList _ e2)) = - do uvs <- case e2 of - NullExpr _ _ -> return [] - _ -> inferExprSeqUnits e2 - calls << (v, (Nothing, uvs)) -inferStmtUnits (Call _ _ e1 (ArgList _ e2)) = mapM_ inferExprUnits [e1, e2] -inferStmtUnits (Open _ _ specs) = inferSpecUnits specs -inferStmtUnits (Close _ _ specs) = inferSpecUnits specs -inferStmtUnits (Continue _ _) = return () -inferStmtUnits (Cycle _ _ _) = return () -inferStmtUnits (Deallocate _ _ exprs e) = - do mapM_ inferExprUnits exprs - inferExprUnits e - return () -inferStmtUnits (Endfile _ _ specs) = inferSpecUnits specs -inferStmtUnits (Exit _ _ _) = return () -inferStmtUnits (Forall _ _ (header, e) s) = - do mapM_ inferForHeaderUnits header - inferExprUnits e - inferStmtUnits s -inferStmtUnits (Goto _ _ _) = return () -inferStmtUnits (Nullify _ _ exprs) = mapM_ inferExprUnits exprs -inferStmtUnits (Inquire _ _ specs exprs) = - do inferSpecUnits specs - mapM_ inferExprUnits exprs -inferStmtUnits (Rewind _ _ specs) = inferSpecUnits specs -inferStmtUnits (Stop _ _ e) = - do inferExprUnits e - return () -inferStmtUnits (Where _ _ e s s') = - do inferExprUnits e - inferStmtUnits s - case s' of - Nothing -> return () - Just s' -> inferStmtUnits s' -inferStmtUnits (Write _ _ specs exprs) = - do inferSpecUnits specs - mapM_ inferExprUnits exprs -inferStmtUnits (PointerAssg _ _ e1 e2) = - do uv1 <- inferExprUnits e1 - uv2 <- inferExprUnits e2 - mustEqual False uv1 uv2 - return () -inferStmtUnits (Return _ _ e) = - do inferExprUnits e - return () -inferStmtUnits (Label _ _ _ s) = inferStmtUnits s -inferStmtUnits (Print _ _ e exprs) = mapM_ inferExprUnits (e:exprs) -inferStmtUnits (ReadS _ _ specs exprs) = - do inferSpecUnits specs - mapM_ inferExprUnits exprs -inferStmtUnits (TextStmt _ _ _) = return () -inferStmtUnits (NullStmt _ _) = return () - - - - --- ************************************* --- Matrix operations --- --- ************************************* - - -inverse :: [Int] -> [Int] -inverse perm = [j + 1 | Just j <- map (flip elemIndex perm) [1 .. length perm]] - -fixValue :: Eq a => (a -> a) -> a -> a -fixValue f x = snd $ until (uncurry (==)) (\(x, y) -> (y, f y)) (x, f x) - --- The indexing for switchScaleElems and moveElem is 1-based, in line with Data.Matrix. - - - -moveElem :: Int -> Int -> [a] -> [a] -moveElem i j [] = [] -moveElem i j xs | i > j = moveElem j i xs - | otherwise = moveElemA i j xs Nothing - where moveElemA i j [] (Just z) = [z] - moveElemA i j [] Nothing = [] - moveElemA 1 j (x:xs) (Just z) = x : moveElemA 1 (j - 1) xs (Just z) - moveElemA 1 j (x:xs) Nothing = moveElemA 1 j xs (Just x) - moveElemA i j (x:xs) Nothing = x : moveElemA (i - 1) j xs Nothing - - -incrElem :: Num a => a -> (Int, Int) -> Matrix a -> Matrix a -incrElem value pos matrix = setElem (matrix ! pos + value) pos matrix - -moveCol :: Int -> Int -> Matrix a -> Matrix a -moveCol i j m - | i > j = moveCol j i m - | otherwise = matrix (nrows m) (ncols m) - $ \(r, c) -> if (c < i || c > j) then m ! (r, c) - else if (c >= i && c < j) then m ! (r, c+1) - else m ! (r, i) - -addCol :: UnitVarCategory -> State UnitEnv Int -addCol category = - do (matrix, vector) <- gets linearSystem - let m = ncols matrix + 1 - linearSystem =: (extendTo 0 0 m matrix, vector) - unitVarCats <<++ category - tmpColsAdded << m - return m - -addRow :: State UnitEnv Int -addRow = addRow' (Unitful []) - -addRow' :: UnitConstant -> State UnitEnv Int -addRow' uc = - do (matrix, vector) <- gets linearSystem - let n = nrows matrix + 1 - linearSystem =: (extendTo 0 n 0 matrix, vector ++ [uc]) - tmpRowsAdded << n - return n - -liftUnitEnv :: (Matrix Rational -> Matrix Rational) -> UnitEnv -> UnitEnv -liftUnitEnv f = Data.Label.modify linearSystem $ \(matrix, vector) -> (f matrix, vector) - - --- ************************************* --- Unit inferences (Helpers) --- --- ************************************* - --- mustEqual - used for saying that two units must be the same- returns one of the variables --- (choice doesn't matter, but left is chosen). --- Returns the unit variables equaled upon -mustEqual :: (?assumeLiterals :: AssumeLiterals) => Bool -> VarCol -> VarCol -> State UnitEnv VarCol -mustEqual flagAsUnitlessIfLit (VarCol uv1) (VarCol uv2) = - do n <- addRow - modify $ liftUnitEnv $ incrElem (-1) (n, uv1) . incrElem 1 (n, uv2) - ucats <- gets unitVarCats - if flagAsUnitlessIfLit then - case ?assumeLiterals of - Mixed -> unitVarCats =: (map (\(n, cat) -> if ((n == uv1 || n == uv2) && ((cat == Literal True) || (cat == Literal False))) - then Literal True - else cat) (zip [1..] ucats)) - _ -> return () - else return () - return $ VarCol uv1 - --- mustAddUp - used for multipling and dividing. Creates a new 'temporary' column and returns --- the variable associated with it -mustAddUp :: VarCol -> VarCol -> Rational -> Rational -> State UnitEnv VarCol -mustAddUp (VarCol uv1) (VarCol uv2) k1 k2 = - do m <- addCol Temporary - n <- addRow - modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem k1 (n, uv1) . incrElem k2 (n, uv2) - return $ VarCol m - --- TODO: error handling in powerUnits - -powerUnits :: (?assumeLiterals :: AssumeLiterals) => VarCol -> Expr Annotation -> State UnitEnv VarCol -powerUnits (VarCol uv) (Con _ _ powerString) = - case fmap (fromInteger . fst) $ listToMaybe $ reads powerString of - Just power -> do - m <- addCol Temporary - n <- addRow - modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem power (n, uv) - return $ VarCol m - Nothing -> mustEqual False (VarCol uv) (VarCol 1) - -powerUnits uv e = - do mustEqual False uv (VarCol 1) - uv <- inferExprUnits e - mustEqual False uv (VarCol 1) - -sqrtUnits :: VarCol -> State UnitEnv VarCol -sqrtUnits (VarCol uv) = - do m <- addCol Temporary - n <- addRow - modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem 0.5 (n, uv) - return $ VarCol m - -anyUnits :: UnitVarCategory -> State UnitEnv VarCol -anyUnits category = - do m <- addCol category - return $ VarCol m - - --- ************************************* --- Gaussian Elimination (Main) --- --- ************************************* - -{-| Print debug information for non-zero coefficients from the Gaussian matrix -} -debugInfoForNonZeros :: [Rational] -> State UnitEnv String -debugInfoForNonZeros row = do debugs <- gets debugInfo - let cSpots = concatMap (getInfo debugs) (zip [1..] row) - return $ if (cSpots == []) then "" else (" arising from \n" ++ cSpots) - where - getInfo debugs (n, 0) = "" - getInfo debugs (n, r) = - case lookup n debugs of - (Just (span, s)) -> "\t" ++ (showSrcSpan span) ++ " - " ++ s ++ "\n" - _ -> "" - -{- | An attempt at getting some useful user information. Needs position information -} -errorMessage :: (?debug :: Bool) => Row -> UnitConstant -> [Rational] -> State UnitEnv String -errorMessage row unit rowCoeffs = - let ?num = 0 in - do uvarEnv <- gets varColEnv - debugs <- gets debugInfo - u <- makeUnitSpec unit - let unitStr = pprint u - let varCols = map (+1) (findIndices (\n -> n /= 0) rowCoeffs) - if varCols == [] then - case unit of - Unitful xs | length xs > 1 -> - do let xs' = map (\(v, r) -> (v, r * (-1))) (tail xs) - uR <- makeUnitSpec (Unitful $ xs') - uL <- makeUnitSpec (Unitful [head xs]) - success =: False - conflictInfo <- debugInfoForNonZeros rowCoeffs - return $ - let unitStrL = pprint uL - unitStrR = pprint uR - msg = "Conflict since " ++ unitStrL ++ " != " ++ unitStrR - in msg ++ conflictInfo - {- A single unit with no variable column suggests an attempt to unify an unit - with unitless -} - Unitful xs | length xs == 1 -> - do let xs' = map (\(v, r) -> (v, r * (-1))) xs - uL <- makeUnitSpec (Unitful xs') - let unitStrL = pprint uL - ifDebug debugGaussian - conflictInfo <- debugInfoForNonZeros rowCoeffs - return $ "Conflict since " ++ unitStrL ++ " != 1" ++ conflictInfo - _ -> do debugGaussian - return "Sorry, I can't give a better error." - else - let varColsAndNames = zip varCols (lookupVarsByCols uvarEnv varCols) - exprStr' = map (\(k,v) -> if (rowCoeffs !! (k - 1)) == 1 - then v - else (showRational (rowCoeffs !! (k - 1))) ++ "*" ++ v) varColsAndNames - exprStr = concat $ intersperse "*" exprStr' - msg = "Conflict arising from " ++ exprStr ++ " of unit " ++ unitStr - in do conflictInfo <- debugInfoForNonZeros rowCoeffs - return $ msg ++ conflictInfo - -reportInconsistency :: (?debug :: Bool) => LinearSystem -> [Int] -> State UnitEnv () -reportInconsistency (m, v) ns = do - uvarEnv <- gets varColEnv - debugs <- gets debugInfo - - -- helper functions - let srcLineCompare = compare `on` (srcLine . fst . fst) - let nonZeroVectorIndices = V.toList . V.map (+1) . V.findIndices (/= 0) - - -- examine all row numbers given to us as the parameter - vs <- fmap (sortBy srcLineCompare . concat) . forM ns $ \ n -> do - -- find out column indices of interest in the row - let colsOfInterest = nonZeroVectorIndices (getRow n m) - - -- for each index of interest in the row, see what other rows also use it - vs <- forM colsOfInterest $ \ i -> do - let rowsOfInterest = nub . (i:) . nonZeroVectorIndices $ getCol i m - -- lookup debug info for those row indices of interest - let colDebugs = mapMaybe (flip lookup debugs) $ rowsOfInterest - -- also lookup VarBinder info for i and convert it to same format - let vs = map (\ (VarBinder (v, s)) -> (s, v)) $ lookupVarBindersByCols uvarEnv [i] - return $ vs ++ colDebugs - - -- flatten it out - return (concat vs) - - report <<++ "Caused by at least one of the following terms:" - forM_ (nub vs) $ \ ((s1, _), str) -> do - unless (all (\ x -> isNumber x || x == '.' || x == '-') str) $ - report <<++ "line " ++ show (srcLine s1) ++ ": " ++ str - -solveSystemM :: (?solver :: Solver, ?debug :: Bool) => String -> State UnitEnv Bool -solveSystemM adjective = do - system <- gets linearSystem - ifDebug debugGaussian - case (solveSystemH_Either system) of - Right system' -> do - linearSystem =: system' - ifDebug (report <<++ "After solve") - ifDebug (debugGaussian) - return True - Left ns -> do - report <<++ (adjective ++ " units of measure") - reportInconsistency system ns - return False - -- linearSystem =: system' - -- if (adjective `elem` ["inconsistent", "underdetermined"]) then - -- do msg <- errorMessage row unit vars - -- report <<++ msg - -- return False - -- else - -- return False - -checkUnderdeterminedM :: State UnitEnv () -checkUnderdeterminedM = do ucats <- gets unitVarCats - system <- gets linearSystem - varenv <- gets varColEnv - debugs <- gets debugInfo - procenv <- gets procedureEnv - - let badCols = checkUnderdetermined ucats system - uenv <- gets varColEnv - if not (null badCols) then - do let exprs = map (showExprLines ucats varenv procenv debugs) badCols - let exprsL = concat $ intersperse "\n\t" exprs - debugGaussian - report <<++ "Underdetermined units of measure. Try adding units to: \n\t" ++ exprsL - return () - else return () - underdeterminedCols =: badCols - - -checkUnderdetermined :: [UnitVarCategory] -> LinearSystem -> [Int] -checkUnderdetermined ucats system@(matrix, vector) = - fixValue (propagateUnderdetermined matrix) $ checkUnderdetermined' ucats system 1 - -criticalVars :: State UnitEnv [String] -criticalVars = do uvarenv <- gets varColEnv - (matrix, _) <- gets linearSystem - ucats <- gets unitVarCats - dbgs <- gets debugInfo - -- debugGaussian - let cv1 = criticalVars' uvarenv ucats matrix 1 dbgs - let cv2 = [] -- criticalVars - return (cv1 ++ cv2) - -criticalVars' :: VarColEnv -> [UnitVarCategory] -> Matrix Rational -> Row -> DebugInfo -> [String] -criticalVars' varenv ucats matrix i dbgs = - let m = firstNonZeroCoeff matrix ucats - in - if (i == nrows matrix) then - if (m i) /= (ncols matrix) then - lookupVarsByColsFilterByArg matrix varenv ucats [((m i) + 1)..(ncols matrix)] dbgs - else [] - else - if (m (i + 1)) /= ((m i) + 1) - then (lookupVarsByColsFilterByArg matrix varenv ucats [((m i) + 1)..(m (i + 1) - 1)] dbgs) ++ (criticalVars' varenv ucats matrix (i + 1) dbgs) - else criticalVars' varenv ucats matrix (i + 1) dbgs - -lookupVarsByColsFilterByArg :: Matrix Rational -> VarColEnv -> [UnitVarCategory] -> [Int] -> DebugInfo -> [String] -lookupVarsByColsFilterByArg matrix uenv ucats cols dbgs = - mapMaybe (\j -> lookupEnv j uenv) cols - where lookupEnv j [] = --Nothing - if (ucats !! (j - 1) == Temporary && (not (all (==0) (V.toList (getCol j matrix))))) then - case (lookup j dbgs) of - Just (srcSpan, info) -> Just ("[expr: " ++ (showSrcSpan srcSpan) ++ "@" ++ info ++ "]") - Nothing -> Nothing - - else Nothing - lookupEnv j ((VarBinder (v, _), (VarCol i, _)):uenv) - | i == j = if (j <= length ucats) then - case (ucats !! (j - 1)) of - Argument -> Nothing - _ -> if (all (==0) (V.toList (getCol j matrix))) - then Nothing - else Just v - else Nothing - | otherwise = lookupEnv j uenv - -firstNonZeroCoeff :: Matrix Rational -> [UnitVarCategory] -> Row -> Col -firstNonZeroCoeff matrix ucats row = - case (V.findIndex (/= 0) (getRow row matrix)) of - Nothing -> ncols matrix - Just i -> i + 1 -{- firstNonZeroCoeff' (V.toList $ getRow row matrix) 0 - where - {- -} - firstNonZeroCoeff' [] n = n + 1 - firstNonZeroCoeff' (0:rs) n = firstNonZeroCoeff' rs (n+1) - firstNonZeroCoeff' (r:rs) n = case (ucats !! n) of - Literal -> firstNonZeroCoeff' rs (n + 1) - _ -> n + 1-} - - - --- debug string ("n = " ++ show n ++ " vc = " ++ (show (vector !! (n - 1))) ++ " ms = " ++ show ms ++ " rest = " ++ show rest) `D.trace` -checkUnderdetermined' :: [UnitVarCategory] -> LinearSystem -> Int -> [Int] -checkUnderdetermined' ucats system@(matrix, vector) n - | n > nrows matrix = [] - | not ((drop 1 ms) == []) && vector !! (n - 1) /= Unitful [] = ms ++ rest - | otherwise = rest - where ms = filter significant [2 .. ncols matrix] - significant m = matrix ! (n, m) /= 0 && ucats !! (m - 1) `notElem` [Literal False, Literal True, Argument, Temporary] - rest = checkUnderdetermined' ucats system (n + 1) - -propagateUnderdetermined :: Matrix Rational -> [Int] -> [Int] -propagateUnderdetermined matrix list = - nub $ do m <- list - n <- filter (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix] - filter (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix] - - - - - --- ************************************* --- Intrinsic functions: information & --- setup functions for them. --- --- ************************************* - -intrinsicsDict :: (?assumeLiterals :: AssumeLiterals) => [(String, String -> State UnitEnv ())] -intrinsicsDict = - map (\x -> (x, addPlain1ArgIntrinsic)) ["ABS", "ACHAR", "ADJUSTL", "ADJUSTR", "AIMAG", "AINT", "ANINT", "CEILING", "CONJG", "DBLE", "EPSILON", "FLOOR","FLOAT", "FRACTION", "HUGE", "IACHAR", "ICHAR", "INT", "IPARITY", "LOGICAL", "MAXEXPONENT", "MINEXPONENT", "NEW_LINE", "NINT", "NORM2", "NOT", "NULL", "PARITY", "REAL", "RRSPACING", "SPACING", "SUM", "TINY", "TRANSPOSE", "TRIM"] - - ++ map (\x -> (x, addPlain2ArgIntrinsic)) ["ALL", "ANY", "IALL", "IANY", "CHAR", "CMPLX", "DCOMPLX", "DIM", "HYPOT", "IAND", "IEOR", "IOR", "MAX", "MIN", "MAXVAL", "MINVAL","MODULO", "MOD"] - - ++ map (\x -> (x, addPlain1Arg1ExtraIntrinsic)) ["CSHIFT", "EOSHIFT", "IBCLR", "IBSET", "NEAREST", "PACK", "REPEAT", "RESHAPE", "SHIFTA", "SHIFTL", "SHIFTR", "SIGN"] - - ++ map (\x -> (x, addPlain2Arg1ExtraIntrinsic)) ["DSHIFTL", "DSHIFTR", "ISHFT", "ISHFTC", "MERGE", "MERGE_BITS"] - - ++ map (\x -> (x, addProductIntrinsic)) ["DOT_PRODUCT", "DPROD", "MATMUL"] - - ++ map (\x -> (x, addPowerIntrinsic)) ["SCALE", "SET_EXPONENT"] - - ++ map (\x -> (x, addUnitlessIntrinsic)) ["ACOS", "ACOSH", "ASIN", "ASINH", "ATAN", "ATANH", "BESSEL_J0", "BESSEL_J1", "BESSEL_Y0", "BESSEL_Y1", "COS", "COSH", "ERF", "ERFC", "ERFC_SCALED", "EXP", "EXPONENT", "GAMMA", "LOG", "ALOG", "LOG10", "LOG_GAMMA", "PRODUCT", "SIN", "SINH", "TAN", "TANH"] - - ++ map (\x -> (x, addUnitlessSubIntrinsic)) ["CPU_TIME", "RANDOM_NUMBER"] - - ++ map (\x -> (x, addUnitlessResult0ArgIntrinsic)) ["COMMAND_ARGUMENT_COUNT", "COMPILER_OPTIONS", "COMPILER_VERSION"] - - ++ map (\x -> (x, addUnitlessResult1ArgIntrinsic)) ["ALLOCATED", "ASSOCIATED", "BIT_SIZE", "COUNT", "DIGITS", "IS_IOSTAT_END", "IS_IOSTAT_EOR", "KIND", "LBOUND", "LCOBOUND", "LEADZ", "LEN", "LEN_TRIM", "MASKL", "MASKR", "MAXLOC", "MINLOC", "POPCOUNT", "POPPAR", "PRECISION", "PRESENT", "RADIX", "RANGE", "SELECTED_CHAR_KIND", "SELECTED_INT_KIND", "SELECTED_REAL_KIND", "SHAPE", "SIZE", "STORAGE_SIZE", "TRAILZ", "UBOUND", "UCOBOUND"] - - ++ map (\x -> (x, addUnitlessResult2SameArgIntrinsic)) ["ATAN2", "BGE", "BGT", "BLE", "BLT", "INDEX", "LGE", "LGT", "LLE", "LLT", "SCAN", "VERIFY"] - - ++ map (\x -> (x, addUnitlessResult2AnyArgIntrinsic)) ["BTEST", "EXTENDS_TYPE_OF", "SAME_TYPE_AS"] - - -- missing: ATOMIC_DEFINE, ATOMIC_REF, BESSEL_JN, BESSEL_YN, C_*, DATE_AND_TIME, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, IBITS, any of the image stuff, MOVE_ALLOC, MVBITS, RANDOM_SEED, SPREAD, SYSTEM_CLOCK, TRANSFER, UNPACK - - -{- [A] Various helpers for adding information about procedures to the type system -} - -addPlain1ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addPlain1ArgIntrinsic name = - do result <- anyUnits Variable - arg <- anyUnits Argument - mustEqual False result arg - procedureEnv << (name, (Just result, [arg])) - -addPlain2ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addPlain2ArgIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - mustEqual False result arg1 - mustEqual False result arg2 - procedureEnv << (name, (Just result, [arg1, arg2])) - -addPlain1Arg1ExtraIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addPlain1Arg1ExtraIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - mustEqual False result arg1 - procedureEnv << (name, (Just result, [arg1, arg2])) - -addPlain2Arg1ExtraIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addPlain2Arg1ExtraIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - arg3 <- anyUnits Argument - mustEqual False result arg1 - mustEqual False result arg2 - procedureEnv << (name, (Just result, [arg1, arg2, arg3])) - -addProductIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addProductIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - temp <- mustAddUp arg1 arg2 1 1 - mustEqual False result temp - procedureEnv << (name, (Just result, [arg1, arg2])) - -addPowerIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addPowerIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - mustEqual False result arg1 - mustEqual False arg2 (VarCol 1) - procedureEnv << (name, (Just result, [arg1, arg2])) - -addUnitlessIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessIntrinsic name = - do result <- anyUnits Variable - arg <- anyUnits Argument - mustEqual False result (VarCol 1) - mustEqual False arg (VarCol 1) - procedureEnv << (name, (Just result, [arg])) - -addUnitlessSubIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessSubIntrinsic name = - do arg <- anyUnits Variable - mustEqual False arg (VarCol 1) - procedureEnv << (name, (Nothing, [arg])) - -addUnitlessResult0ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessResult0ArgIntrinsic name = - do result <- anyUnits Variable - mustEqual False result (VarCol 1) - procedureEnv << (name, (Just result, [])) - -addUnitlessResult1ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessResult1ArgIntrinsic name = - do result <- anyUnits Variable - arg <- anyUnits Argument - mustEqual False result (VarCol 1) - procedureEnv << (name, (Just result, [arg])) - -addUnitlessResult2AnyArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessResult2AnyArgIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - mustEqual False result (VarCol 1) - procedureEnv << (name, (Just result, [arg1, arg2])) - -addUnitlessResult2SameArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv () -addUnitlessResult2SameArgIntrinsic name = - do result <- anyUnits Variable - arg1 <- anyUnits Argument - arg2 <- anyUnits Argument - mustEqual False result (VarCol 1) - mustEqual False arg1 arg2 - procedureEnv << (name, (Just result, [arg1, arg2])) - - - --- ************************************* --- Debugging and testing functions --- --- ************************************* - - - --- QuickCheck instance for matrices, used for testing matrix operations -{- -instance (Arbitrary a) => Arbitrary (Matrix a) where - arbitrary = sized (\n -> do xs <- vectorOf (n*n) arbitrary - return $ matrix n n (\(i, j) -> xs !! ((i-1)*n + (j-1)))) --} - --- Matrix for development -fooMatrix :: Matrix Rational -fooMatrix = matrix 4 4 $ (\(i,j) -> if (i==j) then (toInteger i) % 1 else 0) - - -{-| debugGaussian - a debugging routine which shose the Gaussian matrix with various peieces of info - mainly used for development purposes -} -debugGaussian :: State UnitEnv String -debugGaussian = do grid' <- debugGaussian' - report <<++ ("Dump of units-of-measure system matrix\n" ++ grid') - return grid' - -debugGaussian' = do ucats <- gets unitVarCats - (matrix,rowv) <- gets linearSystem - varenv <- gets varColEnv - debugs <- gets debugInfo - procenv <- gets procedureEnv - - let -- Column headings and then a space - grid = ["" : map show [1..(ncols matrix)], []] - -- Gaussian matrix - ++ map (\r -> (show r) : (map showRational $ V.toList $ getRow r matrix) ++ [show $ rowv !! (r - 1)]) [1..(nrows matrix)] - -- Column categories - ++ [[], "" : map showCat ucats] - -- Debug info, e.g., expression or variable - ++ ["" : map (showExpr ucats varenv procenv debugs) [1.. (ncols matrix)]] - -- Additional debug info for args that are also variables - ++ ["" : map (showArgVars ucats varenv) [1..(ncols matrix)]] - let colSize = maximum' (map maximum' (map (notLast . (map length)) grid)) - let expand r = r ++ (replicate (colSize - length r) ' ') - let showLine x = (concatMap expand x) ++ "\n" - - let grid' = concatMap showLine grid - return grid' - - where maximum' [] = 0 - maximum' xs = maximum xs - - notLast xs = take (length xs - 1) xs - -showExpr cats vars procs debugInfo c = - case (cats !! (c - 1)) of - Variable -> case (lookupVarsByCols vars [c]) of - [] -> case (lookupProcByCols procs [c]) of - [] -> "?" - (x:_) -> "=" ++ x - (x:_) -> x - Temporary -> snd $ case (lookup c debugInfo) of - Just x -> x - Nothing -> (undefined, "") -- error $ "Temporary fail " ++ (show c) " not in " ++ (show cats) - Argument -> case (lookupProcByArgCol procs [c]) of - [] -> "?" - (x:_) -> x - Literal _ -> snd $ case (lookup c debugInfo) of - Just x -> x - Nothing -> show c `D.trace` error "Literal fail" - Magic -> "" - -showSrcLoc loc = show (srcLine loc) ++ ":" ++ show (srcColumn loc) -showSrcSpan (start, end) = "(" ++ showSrcLoc start ++ " - " ++ showSrcLoc end ++ ")" - -showSrcFile (start, _) = srcFilename start - -showExprLines cats vars procs debugInfo c = - case (cats !! (c - 1)) of - Variable -> case (lookup c debugInfo) of - Just (sp, expr) -> (showSrcSpan sp) ++ "\t" ++ expr - Nothing -> - case (lookupVarsByCols vars [c]) of - [] -> case (lookupProcByCols procs [c]) of - [] -> "?" - (x:_) -> "=" ++ x - (x:_) -> x - Temporary -> let (sp, expr) = fromJust $ lookup c debugInfo - in (showSrcSpan sp) ++ "\t" ++ expr - Argument -> case (lookupProcByArgCol procs [c]) of - [] -> "?" - (x:_) -> x - Literal _ -> let (sp, expr) = fromJust $ lookup c debugInfo - in (showSrcSpan sp) ++ "\t" ++ expr - Magic -> "" - -showArgVars cats vars c = - case (cats !! (c - 1)) of - Argument -> case (lookupVarsByCols vars [c]) of - [] -> "" - (x:_) -> x - _ -> "" - - -showCat Variable = "Var" -showCat Magic = "Magic" -showCat Temporary = "Temp" -showCat Argument = "Arg" -showCat (Literal False) = "Lit" -showCat (Literal True) = "Lit=" - -lookupProcByArgCol :: ProcedureEnv -> [Int] -> [String] -lookupProcByArgCol penv cols = - mapMaybe (\j -> lookupEnv j penv) cols - where lookupEnv j [] = Nothing - lookupEnv j ((p, (_, args)):penv) - | elem (VarCol j) args = Just (p ++ "#" ++ (show $ fromJust $ elemIndex (VarCol j) args)) - | otherwise = lookupEnv j penv - - -lookupProcByCols :: ProcedureEnv -> [Int] -> [String] -lookupProcByCols penv cols = - mapMaybe (\j -> lookupEnv j penv) cols - where lookupEnv j [] = Nothing - lookupEnv j ((p, (Just (VarCol i), _)):penv) - | i == j = Just p - | otherwise = lookupEnv j penv - lookupEnv j ((p, (Nothing, _)):penv) = lookupEnv j penv - -lookupVarsByCols :: VarColEnv -> [Int] -> [Variable] -lookupVarsByCols uenv cols = mapMaybe (\j -> lookupEnv j uenv) cols - where lookupEnv j [] = Nothing - lookupEnv j ((VarBinder (v, _), (VarCol i, _)):uenv) - | i == j = Just v - | otherwise = lookupEnv j uenv - -lookupVarBindersByCols :: VarColEnv -> [Int] -> [VarBinder] -lookupVarBindersByCols uenv cols = mapMaybe (\j -> lookupEnv j uenv) cols - where lookupEnv j [] = Nothing - lookupEnv j ((vb@(VarBinder (v, _)), (VarCol i, _)):uenv) - | i == j = Just vb - | otherwise = lookupEnv j uenv - -showRational r = show (numerator r) ++ if ((denominator r) == 1) then "" else "%" ++ (show $ denominator r) - --- ************************************* --- Insert unit declarations into code --- --- ************************************* - -insertUnitsInBlock :: Block Annotation -> State UnitEnv (Block Annotation) -insertUnitsInBlock x = transformBiM insertUnits x - -removeUnitsInBlock :: Block Annotation -> Block Annotation -removeUnitsInBlock = transformBi deleteUnits - -convertUnit :: MeasureUnitSpec a -> State UnitEnv UnitConstant -convertUnit (UnitProduct _ units) = convertUnits units -convertUnit (UnitQuotient _ units1 units2) = liftM2 (-) (convertUnits units1) (convertUnits units2) -convertUnit (UnitNone _) = return $ Unitful [] - -convertUnits :: [(MeasureUnit, Fraction a)] -> State UnitEnv UnitConstant -convertUnits units = - foldl (+) (Unitful []) `liftM` sequence [convertSingleUnit unit (fromFraction f) | (unit, f) <- units] - -convertSingleUnit :: MeasureUnit -> Rational -> State UnitEnv UnitConstant -convertSingleUnit unit f = - do denv <- gets derivedUnitEnv - let uc f' = Unitful [(unit, f')] - case lookup unit denv of - Just uc' -> return $ uc' * (fromRational f) - Nothing -> derivedUnitEnv << (unit, uc 1) >> return (uc f) - -fromFraction :: Fraction a -> Rational -fromFraction (IntegerConst _ n) = fromInteger $ read n -fromFraction (FractionConst _ p q) = fromInteger (read p) / fromInteger (read q) -fromFraction (NullFraction _) = 1 - -extractUnit :: Attr a -> [State UnitEnv UnitConstant] -extractUnit attr = case attr of - MeasureUnit _ unit -> [convertUnit unit] - _ -> [] - - -lookupUnit :: [UnitVarCategory] -> [Int] -> LinearSystem -> Col -> Maybe UnitConstant -lookupUnit ucats badCols system@(matrix, vector) m = - let -- m is the column corresopnding to the variable for which we are looking up the unit - n = find (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix] - defaultUnit = if ucats !! (m - 1) == Argument then Nothing else Just (Unitful []) - in maybe defaultUnit (lookupUnit' ucats badCols system m) n - - -lookupUnit' :: [UnitVarCategory] -> [Int] -> LinearSystem -> Int -> Int -> Maybe UnitConstant -lookupUnit' ucats badCols (matrix, vector) m n - | not $ null ms = Nothing - | ucats !! (m - 1) /= Argument && m `notElem` badCols = Just $ vector !! (n - 1) - | ms' /= [m] = Nothing - | otherwise = Just $ vector !! (n - 1) - where ms = filter significant [1 .. ncols matrix] - significant m' = m' /= m && matrix ! (n, m') /= 0 && ucats !! (m' - 1) == Argument - ms' = filter (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix] - -insertUnits :: Decl Annotation -> State UnitEnv (Decl Annotation) -insertUnits decl@(Decl a sp@(s1, s2) d t) | not (pRefactored a || hasUnits t) = - do system <- gets linearSystem - ucats <- gets unitVarCats - badCols <- gets underdeterminedCols - vColEnv <- gets varColEnv - let varCol (Var _ s ((VarName _ v, _):_), _, _) = case (lookupWithSrcSpan v s (vColEnv)) of - (Just (VarCol m,_)) -> m - Nothing -> error $ "No variable " ++ (show v) - let sameUnits = (==) `on` (lookupUnit ucats badCols system . varCol) - let groups = groupBy sameUnits d - types <- mapM (\g -> let ?num = length g in insertUnit ucats badCols system t . varCol . head $ g) groups - let a' = a { refactored = Just s1 } - let sp' = dropLine $ refactorSpan sp - let sp'' = (toCol0 s1, snd $ dropLine sp) - let decls = [Decl a' sp' group t' | (group, t') <- zip groups types] - if (not (types == [t])) then - return $ DSeq a (NullDecl a' sp'') (foldr1 (DSeq a) decls) - else - return $ decl - -insertUnits decl = return decl - -deleteUnits :: Decl Annotation -> Decl Annotation -deleteUnits (Decl a sp@(s1, s2) d t) | hasUnits t = - Decl a' (dropLine sp) d t' - where a' = a { refactored = Just $ toCol0 s1 } - t' = deleteUnit t -deleteUnits (MeasureUnitDef a sp@(s1, s2) d) = - NullDecl a' sp' - where a' = a { refactored = Just s1 } - sp' = (toCol0 s1, snd $ dropLine sp) -deleteUnits decl = decl - -hasUnits :: Type a -> Bool -hasUnits (BaseType _ _ attrs _ _) = any isUnit attrs -hasUnits (ArrayT _ _ _ attrs _ _) = any isUnit attrs - -isUnit :: Attr a -> Bool -isUnit (MeasureUnit _ _) = True -isUnit _ = False - -insertUnit :: (?num :: Int) => [UnitVarCategory] -> [Int] -> LinearSystem -> Type Annotation -> Int -> State UnitEnv (Type Annotation) -insertUnit ucats badCols system (BaseType aa tt attrs kind len) uv = - do let unit = lookupUnit ucats badCols system uv - u <- (insertUnitAttribute unit attrs) - return $ BaseType aa tt u kind len - -insertUnit ucats badCols system (ArrayT dims aa tt attrs kind len) uv = - do let unit = lookupUnit ucats badCols system uv - u <- insertUnitAttribute unit attrs - return $ ArrayT dims aa tt u kind len - -deleteUnit :: Type Annotation -> Type Annotation -deleteUnit (BaseType aa tt attrs kind len) = - BaseType aa tt (filter (not . isUnit) attrs) kind len -deleteUnit (ArrayT dims aa tt attrs kind len) = - ArrayT dims aa tt (filter (not . isUnit) attrs) kind len - -insertUnitAttribute :: (?num :: Int) => Maybe UnitConstant -> [Attr Annotation] -> State UnitEnv [Attr Annotation] -insertUnitAttribute (Just unit) attrs = do spec <- makeUnitSpec unit - return $ attrs ++ [MeasureUnit unitAnnotation $ spec] -insertUnitAttribute Nothing attrs = return attrs - --- Used for evaluation -updateAdded k s = do (n, xs) <- gets evUnitsAdded - let k' = if k == 0 then 1 else k - evUnitsAdded =: (n + k, xs ++ [s]) - - -makeUnitSpec :: (?num :: Int) => UnitConstant -> State UnitEnv (MeasureUnitSpec Annotation) -makeUnitSpec (UnitlessC r) = - do let u = UnitProduct unitAnnotation [("1", (FractionConst unitAnnotation (show $ numerator r) (show $ denominator r)))] --hm! - updateAdded ?num (pprint u) - return $ u - -makeUnitSpec (Unitful []) = return $ UnitNone unitAnnotation -makeUnitSpec (Unitful units) - | null neg = let u = UnitProduct unitAnnotation $ formatUnits pos - in do updateAdded ?num (pprint u) - return u - | otherwise = let u = UnitQuotient unitAnnotation (formatUnits pos) (formatUnits neg) - in do updateAdded ?num (pprint u) - return u - where pos = filter (\(unit, r) -> r > 0) units - neg = [(unit, -r) | (unit, r) <- units, r < 0] - -formatUnits :: [(MeasureUnit, Rational)] -> [(MeasureUnit, Fraction Annotation)] -formatUnits units = [(unit, toFraction r) | (unit, r) <- units] - -toFraction :: Rational -> Fraction Annotation -toFraction 1 = NullFraction unitAnnotation -toFraction r - | q == 1 = IntegerConst unitAnnotation $ show p - | otherwise = FractionConst unitAnnotation (show p) (show q) - where p = numerator r - q = denominator r diff --git a/Extensions/UnitsEnvironment.hs b/Extensions/UnitsEnvironment.hs deleted file mode 100644 --- a/Extensions/UnitsEnvironment.hs +++ /dev/null @@ -1,147 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE TemplateHaskell, ImplicitParams #-} - -{- Provides various data types and type class instances for the Units extension -} - -module Extensions.UnitsEnvironment where - - -import qualified Data.Label -import Data.Label.Mono (Lens) -import Data.Label.Monadic hiding (modify) -import Control.Monad.State.Strict hiding (gets) -import Language.Fortran -import Data.Matrix - -type EqualityConstrained = Bool - -data Solver = LAPACK | Custom deriving (Show, Read, Eq) -data AssumeLiterals = Poly | Unitless | Mixed deriving (Show, Read, Eq) - -{- Represents a constant unit expression (i.e. one without unit variables) for the RHSs of the Gaussian matrix. - e.g. Unitful [("a", 2/3), ("b",2)] represents the linear term 2/3 log a + 2 log b - UnitlessC marks unitless i.e., 1 --} -data UnitConstant = Unitful [(MeasureUnit, Rational)] | UnitlessC Rational deriving (Eq, Show) - --- Column of the Guassian matrix associated with a variable -newtype VarCol = VarCol Col deriving (Eq, Show) - --- Map from Variable names to their column paired with any column of their indices --- e.g., for a(i,k) we have a map from 'a' to its column paired with --- a two element list of the columns for 'i' and 'j' - -newtype VarBinder = VarBinder (Variable, SrcSpan) deriving Show -type VarColEnv = [(VarBinder, (VarCol, [VarCol]))] - -data UnitVarCategory = Literal EqualityConstrained | Temporary | Variable | Argument | Magic deriving (Eq, Show) - - - -type DerivedUnitEnv = [(MeasureUnit, UnitConstant)] - -type ProcedureNames = (String, Maybe Variable, [Variable]) -type Procedure = (Maybe VarCol, [VarCol]) -type ProcedureEnv = [(String, Procedure)] - -type LinearSystem = (Matrix Rational, [UnitConstant]) - -type Row = Int -type Col = Int - -type DebugInfo = [(Col, (SrcSpan, String))] - -data UnitEnv = UnitEnv { - _report :: [String], - _varColEnv :: VarColEnv, - _derivedUnitEnv :: DerivedUnitEnv, - _procedureEnv :: ProcedureEnv, - _calls :: ProcedureEnv, - _unitVarCats :: [UnitVarCategory], - _reorderedCols :: [Int], - _underdeterminedCols :: [Int], - _linearSystem :: LinearSystem, - _debugInfo :: DebugInfo, - _tmpRowsAdded :: [Int], - _tmpColsAdded :: [Int], - _success :: Bool, - -- This part of the state is just for some evaluation metrics - _evUnitsAdded :: (Int, [String]), - _evCriticals :: [Int] -} deriving Show - -emptyUnitEnv = UnitEnv { _report = [], - _varColEnv = [], - _derivedUnitEnv = [], - _procedureEnv = [], - _calls = [], - _unitVarCats = [Magic], - _reorderedCols = [], - _underdeterminedCols = [], - _linearSystem = (fromLists [[1]], [Unitful []]), - _debugInfo = [], - _tmpRowsAdded = [], - _tmpColsAdded = [], - _success = True, - --- - _evUnitsAdded = (0, []), - _evCriticals = [] - } - -Data.Label.mkLabels [''UnitEnv] - -resetTemps :: State UnitEnv () -resetTemps = do tmpRowsAdded =: [] - tmpColsAdded =: [] - -trim = filter $ \(unit, r) -> r /= 0 - -{- Treat 'UnitConstant's as numbers -} -instance Num UnitConstant where - (Unitful u1) + (Unitful u2) = Unitful $ trim $ merge u1 u2 - where merge [] u2 = u2 - merge u1 [] = u1 - merge ((unit1, r1) : u1) ((unit2, r2) : u2) - | unit1 == unit2 = (unit1, r1 + r2) : merge u1 u2 - | unit1 < unit2 = (unit1, r1) : merge u1 ((unit2, r2) : u2) - | otherwise = (unit2, r2) : merge ((unit1, r1) : u1) u2 - (UnitlessC n1) + (UnitlessC n2) = UnitlessC (n1 + n2) - (Unitful units) * (UnitlessC n) = Unitful $ trim [(unit, r * n) | (unit, r) <- units] - (UnitlessC n) * (Unitful units) = Unitful $ trim [(unit, n * r) | (unit, r) <- units] - (UnitlessC n1) * (UnitlessC n2) = UnitlessC (n1 * n2) - negate (Unitful units) = Unitful [(unit, -r) | (unit, r) <- units] - negate (UnitlessC n) = UnitlessC (-n) - abs (Unitful units) = Unitful [(unit, abs r) | (unit, r) <- units] - abs (UnitlessC n) = UnitlessC $ abs n - signum (Unitful units) = Unitful [(unit, signum r) | (unit, r) <- units] - signum (UnitlessC n) = UnitlessC $ signum n - fromInteger = UnitlessC . fromInteger - -{- Treat 'UnitConstant's as fractionals -} -instance Fractional UnitConstant where - (Unitful units) / (UnitlessC n) = Unitful [(unit, r / n) | (unit, r) <- units] - (UnitlessC n1) / (UnitlessC n2) = UnitlessC (n1 / n2) - fromRational = UnitlessC . fromRational - -data Consistency a = Ok a | Bad a Int (UnitConstant, [Rational]) deriving Show - -efmap :: (a -> a) -> Consistency a -> Consistency a -efmap f (Ok x) = Ok (f x) -efmap f (Bad x l msg) = Bad x l msg - -ifDebug :: (?debug :: Bool, Monad m) => m a -> m () -ifDebug e = if ?debug then e >> return () else return () diff --git a/Extensions/UnitsSolve.hs b/Extensions/UnitsSolve.hs deleted file mode 100644 --- a/Extensions/UnitsSolve.hs +++ /dev/null @@ -1,122 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams, BangPatterns #-} - -module Extensions.UnitsSolve where - -import Data.Ratio -import Data.List -import Data.Matrix -import qualified Data.Vector as V -import Control.Exception -import System.IO.Unsafe -import qualified Debug.Trace as D - - -import Language.Fortran -import Extensions.UnitsEnvironment -import Extensions.UnitsSolveHMatrix - --- Top-level, select the solver -solveSystem :: (?solver :: Solver) => LinearSystem -> Consistency LinearSystem -solveSystem = case ?solver of --- LAPACK -> solveSystemL --- Custom -> solveSystemC - Custom -> solveSystemH --------------------------------------------------- --- CUSTOM SOLVER --------------------------------------------------- - --- Top-level custom solver -solveSystemC :: LinearSystem -> Consistency LinearSystem -solveSystemC system = solveSystem' system 1 1 - -solveSystem' :: LinearSystem -> Col -> Row -> Consistency LinearSystem -solveSystem' (matrix, vector) m k - | m > ncols matrix = efmap (cutSystem k) $ checkSystem (matrix, vector) k - | otherwise = elimRow (matrix, vector) n m k - where n = find (\n -> matrix ! (n, m) /= 0) [k .. nrows matrix] - -cutSystem :: Int -> LinearSystem -> LinearSystem -cutSystem k (matrix, vector) = (matrix', vector') - where matrix' = submatrix 1 (k - 1) 1 (ncols matrix) matrix - vector' = take (k - 1) vector - -checkSystem :: LinearSystem -> Row -> Consistency LinearSystem -checkSystem (matrix, vector) k - | k > nrows matrix = Ok (matrix, vector) - | vector !! (k - 1) /= Unitful [] = let vars = V.toList $ getRow k matrix - bad = Bad (matrix, vector) k (vector !! (k - 1), vars) - in bad - | otherwise = checkSystem (matrix, vector) (k + 1) - -elimRow :: LinearSystem -> Maybe Row -> Col -> Row -> Consistency LinearSystem -elimRow system Nothing m k = solveSystem' system (m + 1) k -elimRow (matrix, vector) (Just n) m k = -- (show (m, k)) `D.trace` - solveSystem' system' (m + 1) (k + 1) - where matrix' = let s = matrix ! (n, m) in - (if (k == n) then id else switchRows k n) - (if s == 1 then matrix else scaleRow (recip $ s) n matrix) - vector' = switchScaleElems k n (fromRational $ recip $ matrix ! (n, m)) vector - system' = elimRow' (matrix', vector') k m - -msteeper matrix k m = msteep matrix 1 - where - r = nrows matrix - msteep matrix n | n > r = matrix - | n == k = msteep matrix (n+1) - | otherwise = let s = (- matrix ! (n, m)) - in if s == 0 then msteep matrix (n+1) - else msteep (combineRows n s k matrix) (n+1) - -elimRow' :: LinearSystem -> Row -> Col -> LinearSystem -elimRow' (matrix, vector) k m = (matrix', vector') - where mstep matrix n = let s = (- matrix ! (n, m)) in if s == 0 then matrix else combineRows n s k matrix - matrix' = foldl mstep matrix $ [1 .. k - 1] ++ [k + 1 .. nrows matrix] - --matrix' = msteeper matrix k m - vector'' = [x - fromRational (matrix ! (n, m)) * vector !! (k - 1) | (n, x) <- zip [1..] vector] - (a, _ : b) = splitAt (k - 1) vector'' - vector' = a ++ vector !! (k - 1) : b - -switchScaleElems :: Num a => Int -> Int -> a -> [a] -> [a] -switchScaleElems i j factor list = a ++ factor * b : c - where (lj, b:rj) = splitAt (j - 1) list - (a, _:c) = splitAt (i - 1) (lj ++ list !! (i - 1) : rj) - --------------------------------------------------- --- Top-level custom solver based on HMatrix -solveSystemH :: LinearSystem -> Consistency LinearSystem -solveSystemH system@(m,v) = - case convertToHMatrix system of - Left (n:_) -> Bad system (nrows m) (v !! n, V.toList (getRow n m)) - Right (m', units) -> Ok sys' - where - m2 = rref m' - m3 = takeRows (rank m2) m2 - sys' = convertFromHMatrix (m3, units) - --------------------------------------------------- --- Top-level custom solver based on HMatrix --- This version uses "Either" result instead of "Consistency". -solveSystemH_Either :: LinearSystem -> Either [Int] LinearSystem -solveSystemH_Either system@(m,v) = - case convertToHMatrix system of - Left ns -> Left ns - Right (m', units) -> Right sys' - where - m2 = rref m' - m3 = takeRows (rank m2) m2 - sys' = convertFromHMatrix (m3, units) diff --git a/Extensions/UnitsSolveHMatrix.hs b/Extensions/UnitsSolveHMatrix.hs deleted file mode 100644 --- a/Extensions/UnitsSolveHMatrix.hs +++ /dev/null @@ -1,215 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleContexts #-} - -module Extensions.UnitsSolveHMatrix - ( rref, rrefMatrices, convertToHMatrix, convertFromHMatrix, isInconsistentRREF - , dispf, Units, lu, rank, takeRows ) -where - -import Data.Ratio -import Debug.Trace (trace) -import Numeric.LinearAlgebra ( - atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, - Matrix, takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks, - ident, flatten, lu, dispf - ) -import Numeric.LinearAlgebra.Devel ( - newMatrix, writeMatrix, runSTMatrix - ) -import Control.Monad (filterM) -import Control.Monad.ST -import qualified Data.Matrix as Old (nrows, ncols, toList, Matrix, fromList) -import Foreign.Storable (Storable) -import Data.List (findIndex, nub, sort, (\\)) -import Data.Maybe (fromMaybe) -import Extensions.UnitsEnvironment (LinearSystem, UnitConstant(..)) -import Language.Fortran (MeasureUnit) - --- | Returns True iff the given matrix in reduced row echelon form --- represents an inconsistent system of linear equations -isInconsistentRREF a = a @@> (rows a - 1, cols a - 1) == 1 && rank (takeColumns (cols a - 1) (dropRows (rows a - 1) a))== 0 - --- | Returns given matrix transformed into Reduced Row Echelon Form -rref :: Matrix Double -> Matrix Double -rref a = snd $ rrefMatrices' a 0 0 [] - --- | List of matrices that when multiplied transform input into --- Reduced Row Echelon Form -rrefMatrices :: Matrix Double -> [Matrix Double] -rrefMatrices a = fst $ rrefMatrices' a 0 0 [] - --- | Single matrix that transforms input into Reduced Row Echelon form --- when multiplied to the original. -rrefMatrix :: Matrix Double -> Matrix Double -rrefMatrix a = foldr (<>) (ident (rows a)) . fst $ rrefMatrices' a 0 0 [] - --- worker function --- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n) -rrefMatrices' a j k mats - -- Base cases: - | j - k == n = (mats, a) - | j == m = (mats, a) - - -- When we haven't yet found the first non-zero number in the row, but we really need one: - | a @@> (j - k, j) == 0 = case findIndex (/= 0) below of - -- this column is all 0s below current row, must move onto the next column - Nothing -> rrefMatrices' a (j + 1) (k + 1) mats - -- we've found a row that has a non-zero element that can be swapped into this row - Just i' -> rrefMatrices' (swapMat <> a) j k (swapMat:mats) - where i = j - k + i' - swapMat = elemRowSwap n i (j - k) - - -- We have found a non-zero cell at (j - k, j), so transform it into - -- a 1 if needed using elemRowMult, and then clear out any lingering - -- non-zero values that might appear in the same column, using - -- elemRowAdd: - | otherwise = rrefMatrices' a2 (j + 1) k mats2 - where - n = rows a - m = cols a - below = getColumnBelow a (j - k, j) - - -- scale the row if the cell is not already equal to 1 - erm = elemRowMult n (j - k) (recip (a @@> (j - k, j))) - (a1, mats1) = if a @@> (j - k, j) /= 1 then - (erm <> a, erm:mats) - else (a, mats) - - -- Locate any non-zero values in the same column as (j - k, j) and - -- cancel them out. Optimisation: instead of constructing a - -- separate elemRowAdd matrix for each cancellation that are then - -- multiplied together, simply build a single matrix that cancels - -- all of them out at the same time, using the ST Monad. - findAdds i m ms = (new <> m, new:ms) - where - new = runSTMatrix $ do - new <- newMatrix 0 n n - sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ] - let f i | i >= n = return () - | i == j - k = f (i + 1) - | a @@> (i, j) == 0 = f (i + 1) - | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j))) - >> f (i + 1) - f 0 - return new - (a2, mats2) = findAdds 0 a1 mats1 - --- Get a list of values that occur below (i, j) in the matrix a. -getColumnBelow a (i, j) = concat . toLists $ subMatrix (i, j) (n - i, 1) a - where n = rows a - --- 'Elementary row operation' matrices -elemRowMult n i k = diag (fromList (replicate i 1.0 ++ [k] ++ replicate (n - i - 1) 1.0)) - - -elemRowAdd :: Int -> Int -> Int -> Double -> Matrix Double -elemRowAdd n i j k = runSTMatrix $ do - m <- newMatrix 0 n n - sequence [ writeMatrix m i' i' 1 | i' <- [0 .. (n - 1)] ] - writeMatrix m i j k - return m - -elemRowAdd_spec n i j k - | i < 0 || i >= n = undefined - | j < 0 || j >= n = undefined - | otherwise = build n n f - where - f (i', j') | i == i' && j == j' = k - | i' == j' = 1 - | otherwise = 0 - -elemRowSwap n i j - | i == j = ident n - | i > j = elemRowSwap n j i - | otherwise = extractRows ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) $ ident n - - --------------------------------------------------- - -type Units = [MeasureUnit] - --- | Convert a LinearSystem into an hmatrix and a list of units that are used -convertToHMatrix :: LinearSystem -> Either [Int] (Matrix Double, Units) -convertToHMatrix (a, ucs) = case findInconsistentRows a' augA of - [] -> Right (augA, units) - ns -> Left ns - where - a' = convertMatrixToHMatrix a - m = cols a' - units = ucsToUnits ucs - unitA = unitsToUnitA ucs units - augA = fromBlocks [[a', unitA]] - --- | Convert an hmatrix and the list of units used back into a LinearSystem -convertFromHMatrix :: (Matrix Double, [MeasureUnit]) -> LinearSystem -convertFromHMatrix (a, units) = (a', ucs') - where - ulen = length units - a' = convertHMatrixToMatrix (takeColumns (cols a - ulen) a) - unitA = dropColumns (cols a - ulen) a - ucs = unitAToUcs unitA units - -- special case: when there are no units, ensure the empty list is replaced with [Unitful [] ...] - ucs' = if null ucs then replicate (rows a) (Unitful []) else ucs - - --- Worker functions: - -convertMatrixToHMatrix :: Old.Matrix Rational -> Matrix Double -convertMatrixToHMatrix a = (Old.nrows a >< Old.ncols a) . map toDouble $ Old.toList a - -convertHMatrixToMatrix :: Matrix Double -> Old.Matrix Rational -convertHMatrixToMatrix a = Old.fromList (rows a) (cols a) . map fromDouble . toList $ flatten a - -toDouble :: Rational -> Double -toDouble = fromRational - -fromDouble :: Double -> Rational -fromDouble = toRational - -unitsToUnitA :: [UnitConstant] -> Units -> Matrix Double -unitsToUnitA ucs units = unitA - where - unitA = fromLists . flip map ucs $ \ uc -> case uc of - Unitful us -> flip map units (toDouble . fromMaybe 0 . flip lookup us) - _ -> map (const 0) units - -ucsToUnits :: [UnitConstant] -> Units -ucsToUnits ucs = sort . nub . (ucs >>=) $ \ uc -> case uc of - Unitful us -> map fst us - _ -> [] - -unitAToUcs :: Matrix Double -> Units -> [UnitConstant] -unitAToUcs unitA units = - flip map (toLists unitA) (Unitful . filter ((/= 0) . snd) . zip units . map fromDouble) - -findInconsistentRows :: Matrix Double -> Matrix Double -> [Int] -findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent - where - consistent = head (filter (tryRows coA augA) (pset ( [0..(rows augA - 1)])) ++ [[]]) - - -- Rouché–Capelli theorem is that if the rank of the coefficient - -- matrix is not equal to the rank of the augmented matrix then - -- the system of linear equations is inconsistent. - tryRows coA augA ns = (rank coA' == rank augA') - where - coA' = extractRows ns coA - augA' = extractRows ns augA - - pset = filterM (const [True, False]) - -extractRows = flip (?) -- hmatrix 0.17 changed interface -m @@> i = m `atIndex` i diff --git a/Helpers.hs b/Helpers.hs deleted file mode 100644 --- a/Helpers.hs +++ /dev/null @@ -1,72 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE TypeOperators #-} - -module Helpers where - -type Filename = String -type Directory = String -type SourceText = String -type FileOrDir = String - --- Helpers - -fanout :: (a -> b) -> (a -> c) -> a -> (b, c) -fanout f g x = (f x, g x) - -(<>) :: (a -> b) -> (a -> c) -> a -> (b, c) -f <> g = fanout f g - -(><) :: (a -> c) -> (b -> d) -> (a, b) -> (c, d) -f >< g = \(x, y) -> (f x, g y) - --- Lookup functions over relation s - -lookups :: Eq a => a -> [(a, b)] -> [b] -lookups _ [] = [] -lookups x ((a, b):xs) = if (x == a) then b : lookups x xs - else lookups x xs - -lookups' :: Eq a => a -> [((a, b), c)] -> [(b, c)] -lookups' _ [] = [] -lookups' x (((a, b), c):xs) = if (x == a) then (b, c) : lookups' x xs - else lookups' x xs - -{-| Computes all pairwise combinations -} -pairs :: [a] -> [(a, a)] -pairs [] = [] -pairs (x:xs) = (zip (repeat x) xs) ++ (pairs xs) - -{-| Functor composed with list functor -} -mfmap :: Functor f => (a -> b) -> [f a] -> [f b] -mfmap f = map (fmap f) - -{-| An infix `map` operation.-} -each = flip (map) - -{-| Is the Ordering an EQ? -} -cmpEq :: Ordering -> Bool -cmpEq EQ = True -cmpEq _ = False - -cmpFst :: (a -> a -> Ordering) -> (a, b) -> (a, b) -> Ordering -cmpFst c (x1, y1) (x2, y2) = c x1 x2 - -cmpSnd :: (b -> b -> Ordering) -> (a, b) -> (a, b) -> Ordering -cmpSnd c (x1, y1) (x2, y2) = c y1 y2 - -{-| used for type-level annotations giving documentation -} -type (:?) a b = a diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,461 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams, DoAndIfThenElse #-} - -module Main where - -import qualified Language.Fortran.Parser as Fortran -import Language.Fortran.PreProcess -import Language.Fortran - -import System.Console.GetOpt -import System.Directory -import System.Environment -import System.IO - -import Language.Haskell.ParseMonad - -import Data.Monoid -import Data.Generics.Uniplate.Operations - -import Analysis.Annotations - -import Transformation.DeadCode -import Transformation.CommonBlockElim -import Transformation.CommonBlockElimToCalls -import Transformation.EquivalenceElim -import Transformation.DerivedTypeIntro -import Extensions.Units -import Extensions.UnitSyntaxConversion -import Extensions.UnitsEnvironment -import Extensions.UnitsSolve - -import Analysis.Types -import Analysis.Loops -import Analysis.LVA -import Analysis.Syntax - -import Helpers -import Output -import Traverse - -import Debug.Trace - -import Data.List (nub, (\\), elemIndices, intersperse) -import Data.Text (pack, unpack, split) - - - --- * The main entry point to CamFort -{-| The entry point to CamFort. Displays user information, and handlers which functionality - is being requested -} -main = do putStrLn introMessage - args <- getArgs - - if (length args >= 2) then - - let (func : (inp : _)) = args - in case lookup func functionality of - Just (fun, _) -> - do (numReqArgs, outp) <- if (func `elem` outputNotRequired) - then if (length args >= 3 && (head (args !! 2) == '-')) - then return (2, "") - else -- case where an unnecessary output is specified - return (3, "") - - else if (length args >= 3) - then return (3, args !! 2) - else error $ usage ++ "This mode requires an output file/directory to be specified." - (opts, _) <- compilerOpts (drop numReqArgs args) - let excluded_files = map unpack (split (==',') (pack (getExcludes opts))) - fun inp excluded_files outp opts - Nothing -> putStrLn $ fullUsageInfo - - else if (length args == 1) then putStrLn $ usage ++ "Please specify an input file/directory" - else putStrLn $ fullUsageInfo - --- * Options for CamFort and information on the different modes - -fullUsageInfo = (usageInfo (usage ++ menu ++ "\nOptions:") options) - -type Options = [Flag] -data Flag = Version | Input String | Output String - | Solver Solver | Excludes String - | Literals AssumeLiterals | Debug deriving Show - -solverType [] = Custom -solverType ((Solver s) : _) = s -solverType (x : xs) = solverType xs - -literalsBehaviour [] = Poly -literalsBehaviour ((Literals l) : _) = l -literalsBehaviour (x : xs) = literalsBehaviour xs - -getExcludes [] = "" -getExcludes ((Excludes s) : xs) = s -getExcludes (x : xs) = getExcludes xs - -options :: [OptDescr Flag] -options = - [ Option ['v','?'] ["version"] (NoArg Version) "show version number" - , Option ['e'] ["exclude"] (ReqArg Excludes "FILES") "files to exclude (comma separated list, no spaces)" - , Option ['s'] ["units-solver"] (ReqArg (Solver . read) "ID") "units-of-measure solver. ID = Custom or LAPACK" - , Option ['l'] ["units-literals"] (ReqArg (Literals . read) "ID") "units-of-measure literals mode. ID = Unitless, Poly, or Mixed" - ] - -compilerOpts :: [String] -> IO ([Flag], [String]) -compilerOpts argv = - case getOpt Permute options argv of - (o,n,[] ) -> return (o,n) - (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) - where header = introMessage ++ usage ++ menu ++ "\nOptions:" - --- * Which modes do not require an output -outputNotRequired = ["criticalUnits", "count"] - -functionality = analyses ++ refactorings - -{-| List of refactorings provided in CamFort -} -refactorings :: [(String, (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO (), String))] -refactorings = - [("common", (common, "common block elimination")), - ("commonArg", (commonToArgs, "common block elimination (to parameter passing)")), - ("equivalence", (equivalences, "equivalence elimination")), - ("dataType", (typeStructuring, "derived data type introduction")), - ("dead", (dead, "dead-code elimination")), - ("units", (units, "unit-of-measure inference")) ] - -{-| List of analses provided by CamFort -} -analyses :: [(String, (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO (), String))] -analyses = - [("asts", (asts, "blank analysis, outputs analysis files with AST information")), - ("lva", (lvaA, "live-variable analysis")), - ("loops", (loops, "loop information")), - ("count", (countVarDecls, "count variable declarations")), - ("criticalUnits", (unitCriticals, "calculate the critical variables for units-of-measure inference")), - ("ast", (ast, "print the raw AST -- for development purposes"))] - --- * Usage and about information -version = 0.700 -introMessage = "CamFort " ++ (show version) ++ " - Cambridge Fortran Infrastructure." -usage = "Usage: camfort [OUTPUT] [OPTIONS...]\n" -menu = "Refactor functions:\n" - ++ concatMap (\(k, (_, info)) -> "\t" ++ k ++ (replicate (15 - length k) ' ') - ++ "\t [" ++ info ++ "] \n") refactorings - ++ "\nAnalysis functions:\n" - ++ concatMap (\(k, (_, info)) -> "\t" ++ k ++ (replicate (15 - length k) ' ') - ++ "\t [" ++ info ++ "] \n") analyses - --- * Wrappers on all of the features -typeStructuring inSrc excludes outSrc _ = - do putStrLn $ "Introducing derived data types in " ++ show inSrc ++ "\n" - doRefactor typeStruct inSrc excludes outSrc - -ast d _ f _ = do (_, _, p) <- readParseSrcFile (d ++ "/" ++ f) - putStrLn $ show p - -asts inSrc excludes _ _ = - do putStrLn $ "Do a basic analysis and output the HTML files with AST information for " ++ show inSrc ++ "\n" - doAnalysis ((map numberStmts) . map (fmap (const unitAnnotation))) inSrc excludes - -countVarDecls inSrc excludes _ _ = - do putStrLn $ "Counting variable declarations in " ++ show inSrc ++ "\n" - doAnalysisSummary countVariableDeclarations inSrc excludes - -loops inSrc excludes _ _ = - do putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n" - doAnalysis loopAnalyse inSrc excludes - -lvaA inSrc excludes _ _ = - do putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n" - doAnalysis lva inSrc excludes - -dead inSrc excludes outSrc _ = - do putStrLn $ "Eliminating dead code in " ++ show inSrc ++ "\n" - doRefactor ((mapM (deadCode False))) inSrc excludes outSrc - -commonToArgs inSrc excludes outSrc _ = - do putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n" - doRefactor (commonElimToCalls inSrc) inSrc excludes outSrc - -common inSrc excludes outSrc _ = - do putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n" - doRefactor (commonElimToModules inSrc) inSrc excludes outSrc - -equivalences inSrc excludes outSrc _ = - do putStrLn $ "Refactoring equivalences blocks in " ++ show inSrc ++ "\n" - doRefactor (mapM refactorEquivalences) inSrc excludes outSrc - -{- Units feature -} -units inSrc excludes outSrc opt = - do putStrLn $ "Inferring units for " ++ show inSrc ++ "\n" - let ?solver = solverType opt - in let ?assumeLiterals = literalsBehaviour opt - in doRefactor' (mapM inferUnits) inSrc excludes outSrc - -unitCriticals inSrc excludes outSrc opt = - do putStrLn $ "Infering critical variables for units inference in directory " ++ show inSrc ++ "\n" - let ?solver = solverType opt - in let ?assumeLiterals = literalsBehaviour opt - in doAnalysisReport' (mapM inferCriticalVariables) inSrc excludes outSrc - --- * Builders for analysers and refactorings - -{-| Performs an analysis provided by its first parameter on the directory of its second, excluding files listed by - its third -} -doAnalysis :: (Program A -> Program Annotation) -> FileOrDir -> [Filename] -> IO () -doAnalysis aFun d excludes = - do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ d ++ "/" - else return () - - ps <- readParseSrcDir d excludes - - let inFiles = map Fortran.fst3 ps - let outFiles = filter (\f -> not ((take (length $ d ++ "out") f) == (d ++ "out"))) inFiles - let asts' = map (\(f, _, ps) -> aFun ps) ps - outputAnalysisFiles d asts' outFiles - -{-| Performs an analysis provided by its first parameter which generates information 's', which is then combined - together (via a monoid) -} -doAnalysisSummary :: (Monoid s, Show s) => (Program A -> s) -> FileOrDir -> [Filename] -> IO () -doAnalysisSummary aFun d excludes = - do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ d ++ "/" - else return () - - ps <- readParseSrcDir d excludes - - let inFiles = map Fortran.fst3 ps - putStrLn "Output of the analysis:" - putStrLn $ show $ Prelude.foldl (\n (f, _, ps) -> n `mappend` (aFun ps)) mempty ps - -{-| Performs an analysis which reports to the user, but does not output any files -} -doAnalysisReport :: ([(Filename, Program A)] -> (String, t1)) -> FileOrDir -> [Filename] -> t -> IO () -doAnalysisReport rFun inSrc excludes outSrc - = do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - putStr "\n" - let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - putStrLn report - --- Temporary doAnalysisReport version to make it work with Units-Of-Measure --- glue code. -doAnalysisReport' :: ([(Filename, Program A)] -> (String, t1)) -> FileOrDir -> [Filename] -> t -> IO () -doAnalysisReport' rFun inSrc excludes outSrc - = do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - putStr "\n" - let (report, ps') = rFun (map modifyAST ps) - putStrLn report - where - modifyAST (f, inp, ast) = - let ast' = map (fmap (const ())) ast - ast'' = convertSyntax f inp ast' - ast''' = map (fmap (const unitAnnotation)) ast'' - in (f, ast''') - -{-| Performs a refactoring provided by its first parameter, on the directory of the second, excluding files listed by third, - output to the directory specified by the fourth parameter -} -doRefactor :: ([(Filename, Program A)] -> (String, [(Filename, Program Annotation)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO () -doRefactor rFun inSrc excludes outSrc - = do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ inSrc ++ "/" - else return () - - ps <- readParseSrcDir inSrc excludes - let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - --let outFiles = filter (\f -not ((take (length $ d ++ "out") f) == (d ++ "out"))) (map fst ps') - let outFiles = map fst ps' - putStrLn report - outputFiles inSrc outSrc (zip3 outFiles (map Fortran.snd3 ps ++ (repeat "")) (map snd ps')) - --- Temporarily for the units-of-measure glue code -doRefactor' :: ([(Filename, Program A)] -> (String, [(Filename, Program Annotation)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO () -doRefactor' rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - let (report, ps') = rFun (map modifyAST ps) - let outFiles = map fst ps' - let newASTs = map (map (fmap (const ()))) (map snd ps') - let inputs = map Fortran.snd3 ps - let outputs = zip outFiles (map (\(a,b) -> a b) (zip (map convertSyntaxBack inputs) newASTs)) - putStrLn report - outputFiles' inSrc outSrc outputs - where - modifyAST (f, inp, ast) = - let ast' = map (fmap (const ())) ast - ast'' = convertSyntax f inp ast' - ast''' = map (fmap (const unitAnnotation)) ast'' - in (f, ast''') - --- gets the directory part of a filename -getDir :: String -> String -getDir file = take (last $ elemIndices '/' file) file - --- * Source directory and file handling - -{-| Read files from a direcotry, excluding those listed by the second parameter -} -readParseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, SourceText, Program A)] -readParseSrcDir inp excludes = do isdir <- isDirectory inp - files <- if isdir then - do files <- rGetDirContents inp - return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes - else return [inp] - mapM readParseSrcFile files - -rGetDirContents :: FileOrDir -> IO [String] -rGetDirContents d = do ds <- getDirectoryContents d - ds' <- return $ ds \\ [".", ".."] -- remove '.' and '..' entries - rec ds' - where - rec [] = return $ [] - rec (x:xs) = do xs' <- rec xs - g <- doesDirectoryExist (d ++ "/" ++ x) - if g then - do x' <- rGetDirContents (d ++ "/" ++ x) - return $ (map (\y -> x ++ "/" ++ y) x') ++ xs' - else if (isFortran x) then - return $ x : xs' - else return $ xs' - -{-| predicate on which fileextensions are Fortran files -} -isFortran x = elem (fileExt x) [".f", ".f90", ".f77", ".cmn", ".inc"] - -{-| Read a specific file, and parse it -} -readParseSrcFile :: Filename -> IO (Filename, SourceText, Program A) -readParseSrcFile f = do putStrLn f - inp <- readFile f - ast <- parse f - return $ (f, inp, map (fmap (const unitAnnotation)) ast) - - -{-| Creates a directory (from a filename string) if it doesn't exist -} -checkDir f = case (elemIndices '/' f) of - [] -> return () - ix -> let d = take (last ix) f - in createDirectoryIfMissing True d - -isDirectory :: FileOrDir -> IO Bool -isDirectory s = doesDirectoryExist s - -{-| Given a directory and list of triples of filenames, with their source text (if it exists) and - their AST, write these to the director -} -outputFiles :: FileOrDir -> FileOrDir -> [(Filename, SourceText, Program Annotation)] -> IO () -outputFiles inp outp pdata = - do outIsDir <- isDirectory outp - inIsDir <- isDirectory inp - if outIsDir then - do createDirectoryIfMissing True outp - putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/" - isdir <- isDirectory inp - let inSrc = if isdir then inp else getDir inp - mapM_ (\(f, input, ast') -> let f' = changeDir outp inSrc f - in do checkDir f' - putStrLn $ "Writing " ++ f' - writeFile f' (reprint input f' ast')) pdata - else - if inIsDir || length pdata > 1 then - error $ "Error: attempting to output multiple files, but the given output destination " ++ - "is a single file. \n" ++ "Please specify an output directory" - else let outSrc = getDir outp - in do createDirectoryIfMissing True outSrc - putStrLn $ "Writing refactored file to: " ++ outp - let (f, input, ast') = head pdata - putStrLn $ "Writing " ++ outp - writeFile outp (reprint input outp ast') - -outputFiles' :: FileOrDir -> FileOrDir -> [(Filename, SourceText)] -> IO () -outputFiles' inp outp pdata = - do outIsDir <- isDirectory outp - inIsDir <- isDirectory inp - if outIsDir then - do createDirectoryIfMissing True outp - putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/" - isdir <- isDirectory inp - let inSrc = if isdir then inp else getDir inp - mapM_ (\(f, output) -> let f' = changeDir outp inSrc f - in do checkDir f' - putStrLn $ "Writing " ++ f' - writeFile f' output) pdata - else - if inIsDir || length pdata > 1 then - error $ "Error: attempting to output multiple files, but the given output destination " ++ - "is a single file. \n" ++ "Please specify an output directory" - else let outSrc = getDir outp - in do createDirectoryIfMissing True outSrc - putStrLn $ "Writing refactored file to: " ++ outp - let (f, output) = head pdata - putStrLn $ "Writing " ++ outp - writeFile outp output - -{-| changeDir is used to change the directory of a filename string. - If the filename string has no directory then this is an identity -} -changeDir newDir oldDir oldFilename = newDir ++ (listDiffL oldDir oldFilename) - where listDiffL [] ys = ys - listDiffL xs [] = [] - listDiffL (x:xs) (y:ys) | x==y = listDiffL xs ys - | otherwise = ys - -{-| output pre-analysis ASTs into the directory with the given file names (the list of ASTs should match the - list of filenames) -} -outputAnalysisFiles :: FileOrDir -> [Program Annotation] -> [Filename] -> IO () -outputAnalysisFiles dir asts files = - do putStrLn $ "Writing analysis files to directory: " ++ dir ++ "/" - mapM (\(ast', f) -> writeFile (f ++ ".html") ((concatMap outputHTML) ast')) (zip asts files) - return () - - -{-| parse file into an un-annotated Fortran AST -} -parse :: Filename -> IO (Program ()) -parse f = let mode = ParseMode { parseFilename = f } - selectedParser = case (fileExt f) of - ".cmn" -> Fortran.include_parser - ".inc" -> Fortran.include_parser - _ -> Fortran.parser - in do inp <- readFile f - case (runParserWithMode mode selectedParser (pre_process inp)) of - (ParseOk p) -> return $ p - (ParseFailed l e) -> error e - -{-| extract a filename's extension -} -fileExt x = let ix = elemIndices '.' x - in if (length ix == 0) then "" - else Prelude.drop (Prelude.last ix) x - - --- * Simple example - -{-| A simple, sample transformation using the 'transformBi' function -} -fooTrans p = transformBi f p - where f :: Fortran A1 -> Fortran A1 - f p@(Call x sp e as) = Label True sp "10" p - f p@(Assg x sp e1 e2) = Label True sp "5" p - f p = p - -{-| Parse a file and apply the 'fooTrans' transformation, outputting to the filename + .out -} -doFooTrans f = do inp <- readFile f - p <- parse f - let p' = fooTrans $ (map (fmap (const unitAnnotation)) p) - let out = reprint inp f p' - writeFile (f ++ ".out") out - return $ (out, p') diff --git a/Output.hs b/Output.hs deleted file mode 100644 --- a/Output.hs +++ /dev/null @@ -1,470 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleInstances, UndecidableInstances, ImplicitParams #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables, DeriveGeneric, DeriveDataTypeable #-} - -module Output where - -import Helpers -import Traverse - -import Analysis.Annotations -import Analysis.Syntax -import Language.Fortran as Fortran -import Language.Fortran.Pretty -import Transformation.Syntax - -import Data.Text hiding (foldl,map,concatMap,take,drop,length,last,head,tail,replicate,concat) -import qualified Data.Text as Text -import Data.Map.Lazy hiding (map, foldl) -import Data.Functor.Identity -import Data.Generics -import GHC.Generics -import Data.List -import Data.Generics.Uniplate.Data -import Generics.Deriving.Copoint -import Data.Char -import Data.Generics.Zipper -import Data.Maybe -import Debug.Trace -import Control.Monad.Trans.State.Lazy -import Text.Printf - --- Define new pretty printing version for HTML output -data HTMLPP = HTMLPP -instance PPVersion HTMLPP - -keyword = map pack - ["end","subroutine","function","program","module","data", "common", - "namelist", "external", "interface", "type", "include", "format", - "len", "kind", "dimension", "allocatable", "parameter", "external", - "intent", "intrinsic", "optional", "pointer", "save", "target", - "volatile", "public", "private", "sequence", "operator", "assignment", - "procedure", "do", "if", "else", "then", "allocate", "backspace", - "call", "open", "close", "continue", "cycle", "deallocate", "endfile", - "exit", "forall", "goto", "nullify", "inquire", "rewind", "stop", "where", - "write", "rerun", "print", "read", "write", "implicit", "use"] - -outputHTML :: forall p . (Data p, Typeable p, PrintSlave p HTMLPP, PrintIndSlave (Fortran p) HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => - Fortran.ProgUnit p -> String -outputHTML prog = unpack html - where - t :: SubName p -> SubName p - t (SubName p n) = SubName p (addColor blue n) - t x = x - - purple = "#800080" - green = "#008000" - blue = "#000080" - - toColor c t k = replace k (Text.concat [pack (""), k, pack ""]) t - addColor c k = "" ++ k ++ "" - pre l = Text.concat [pack "
", l, pack "
"] - types = map pack ["real", "integer", "character", "type", "logical"] - - html = let ?variant = HTMLPP - in - (Text.append (pack $ "" - ++ "")) - . (\t -> replace (pack "newline") (pack "\n") t) - . (Text.concat . (map pre) . Text.lines) - . (\t -> foldl (toColor green) t types) - . (\t -> foldl (toColor purple) t keyword) - . (pack . printMaster) - -- . (pack . output) - -- . (pack . paraBi (\p -> \ss -> (showPara p) ++ ss) "") - -- . (pack . (para (\p -> \ss -> showPara p ++ (Prelude.concat ss)))) - . (transformBi t) $ prog - -{- | Pretty printer for HTML, specialised to the analysis of CamFort, which mostly uses the default master - behaviour, but with a few special cases -} - -instance PrintSlave Bool HTMLPP where - printSlave = show - -instance PrintSlave SrcLoc HTMLPP where - printSlave _ = "" -- not sure if I want this to shown - -instance (PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => PrintSlave (ProgUnit p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (DataForm p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (SubName p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Implicit p) HTMLPP where - printSlave = printMaster - -instance (Indentor (Decl p), PrintSlave (DataForm p) HTMLPP) => PrintSlave (Decl p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Type p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (VarName p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (Expr p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (UnaryOp p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (BinOp p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (ArgList p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (BaseType p) HTMLPP where - printSlave = printMaster - -instance (Indentor (Decl p)) => PrintSlave (InterfaceSpec p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Arg p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (ArgName p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (GSpec p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Attr p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Fraction p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (MeasureUnitSpec p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (DataForm p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p), Indentor (Decl p)) => PrintSlave (Block p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Uses p) HTMLPP where - printSlave u = showUse' u - -showUse' :: Uses p -> String -showUse' (UseNil _) = "" -showUse' (Uses _ (Use n []) us _) = ("use "++n++"\n") ++ (showUse' us) -showUse' (Uses _ (Use n renames) us _) = ("use "++n++", " ++ (Prelude.concat $ Data.List.intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ "\n") ++ (showUse' us) - -instance (PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p)) => PrintSlave (Fortran p) HTMLPP where - printSlave (For p _ v e e' e'' f) = "do"++" "++printSlave v++" = "++printSlave e++", "++ - printSlave e'++", "++printSlave e''++"\n"++ - ""++"{"++printSlave p++"}\n" ++ - (printIndSlave 1 f)++"\n"++(ind 1)++"end do" - printSlave t = printMaster t - -instance PrintSlave (Spec p) HTMLPP where - printSlave = printMaster - -instance Indentor (Fortran Bool) where - indR t i = if (tag t) then - let (s, SrcLoc f l c) = srcSpan t - in Prelude.take c (repeat ' ') - else ind i - -instance PrintIndSlave (Fortran A1) HTMLPP where - printIndSlave = printIndMaster - -instance PrintIndSlave (Fortran Annotation) HTMLPP where - - printIndSlave i t@(For p _ v e e' e'' f) = (outputAnn p False i (show t)) ++ - annotationMark i t - ((ind i) ++ "do"++" "++printSlave v++" = "++ - printSlave e++", "++ - printSlave e'++", "++printSlave e''++"\n"++ - (printIndSlave (i+1) f)++"\n"++(ind i)++"end do") - - - -- printIndSlave i t@(FSeq p f1 f2) = (outputAnn p False i) ++ printIndSlave i f1 ++ printIndSlave i f2 - printIndSlave i t = "
" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
" - where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t)) - -{- -instance PrintIndSlave (Decl p) HTMLPP where - outputPrintSlave i t = "
" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
" - where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))x --} - -countToColor n = colors !! (n `mod` (length colors)) -- printf "#%06x" ((256*256*256 - (n * 40)) :: Int) - -colors = ["#ffeeee", "#eeffee", "#eeeeff", "#ffffee", - "#eeffff", "#eeffee", "#ffdddd", "#ddffdd", - "#ddddff", "#ffffdd", "#ffddff", "#ddffff", - "#eecccc", "#cceecc", "#eeeecc", "#ddeeee"] - -prettyp xs = prettyp' xs 0 [] -prettyp' [] n f = [] -prettyp' ('(':xs) n f = let k = "" - in if (nearbyClose xs 10) then - k ++ ('(':(prettyp' xs n (False:f))) - else - ("
" ++ (concat $ replicate (2 * (n+1)) " ")) ++ k ++ ('(' : (prettyp' xs (n+1) (True:f))) -prettyp' (')':xs) n (False:f) = ')' : ("" ++ prettyp' xs n f) -prettyp' (')':xs) n (True:f) = ')' : ("" ++ prettyp' xs (n - 1) f) -prettyp' (x:xs) n f = x : prettyp' xs n f - -nearbyClose [] n = False -nearbyClose _ 0 = False -nearbyClose ('(':(')':xs)) n = nearbyClose xs (n - 2) -nearbyClose (')':xs) n = True -nearbyClose (x:xs) n = nearbyClose xs (n - 1) - - -annotationMark i t x = "
" ++ - x ++ "
" - - -row xs = "" ++ (concatMap (\x -> "" ++ x ++ "") xs) ++ "" - -instance PrintSlave Annotation HTMLPP where - printSlave t = outputAnn t False 0 (show t) - -breakUp xs = breakup' xs 0 False - where breakup' [] _ _ = [] - breakup' (x:xs) c mode | x == '<' = x : (breakup' xs c True) - | x == '>' = x : (breakup' xs c False) - | c >= 80 && (not mode) = x : ("newline" ++ breakup' xs 0 False) - | mode = x : (breakup' xs c mode) - | otherwise = x : (breakup' xs (c+1) mode) - - -- (take 80 xs) ++ "newline" ++ (if (drop 80 xs) == [] then [] else breakUp (drop 80 xs)) - -outputAnn t visible i astString = - "
" ++ (indent 3 i) ++ "
" ++ - "
" ++ (show $ number t) ++ "
" ++ - "
" ++ - "show ast
" ++ (astString) ++ "
" ++ "

" ++ - row ["lives: (in) ", showList $ (map show) $ fst $ lives t, "(out)", showList $ (map show) $ snd $ lives t] ++ - row ["indices:", showList $ indices t] ++ - row ["successors:", showList $ (map show) (successorStmts t)] ++ - row ["arrays R:", showExps (assocs $ arrsRead t)] ++ - row ["arrays W:", showExps (assocs $ arrsWrite t)] ++ - "


\n\r\n" - where - listToPair x = "(" ++ listToPair' x ++ ")" - listToPair' [] = "" - listToPair' [x] = printMaster x - listToPair' (x:xs) = printMaster x ++ ", " ++ listToPair' xs - - showExps [] = "" - showExps [(v, es)] = "[" ++ v ++ ": " ++ (showList $ map listToPair es) ++ "]" - showExps ((v, es):ys) = (showExps [(v, es)]) ++ ", " ++ (showExps ys) - - - showList [] = "" - showList [x] = x - showList (x:xs) = x ++ ", " ++ showList xs - - -type A1 = Bool - -lineCol :: SrcLoc -> (Int, Int) -lineCol x = (srcLine x, srcColumn x) - --- inBounds :: SrcLoc -> (SrcLoc, SrcLoc) -> Bool --- inBounds x (l,u) = (lineCol x) >= (lineCol l) && (lineCol x) < (lineCol u) - - -takeBounds (l, u) inp = takeBounds' (lineCol l, lineCol u) [] inp - -takeBounds' ((ll, lc), (ul, uc)) tk inp = - if (ll == ul && lc == uc) || (ll > ul) then (Prelude.reverse tk, inp) - else case inp of [] -> (Prelude.reverse tk, inp) - ([]:[]) -> (Prelude.reverse tk, inp) - ([]:ys) -> takeBounds' ((ll+1, 0), (ul, uc)) ('\n':tk) ys - ((x:xs):ys) -> takeBounds' ((ll, lc+1), (ul, uc)) (x:tk) (xs:ys) - -{- Indenting for refactored code -} - -instance Tagged p => Indentor (p Annotation) where - indR t i = case (refactored . tag $ t) of - Just (SrcLoc f _ c) -> Prelude.take c (repeat ' ') - Nothing -> ind i - - --- Start of GLORIOUS REFACTORING ALGORITHM! - -{-| -} -reprint :: SourceText -> Filename -> Program Annotation -> String -reprint "" f p = let ?variant = DefaultPP in foldl (\a b -> a ++ "\n" ++ printMaster b) "" p -reprint input f p = let input' = Prelude.lines input - start = SrcLoc f 1 0 - end = SrcLoc f (Prelude.length input') (1 + (Prelude.length $ Prelude.last input')) - (pn, cursorn) = runIdentity $ evalStateT (reprintC start input' (toZipper p)) 0 - (_, inpn) = takeBounds (start, cursorn) input' - (pe, _) = takeBounds (cursorn, end) inpn - in pn ++ pe - -reprintC :: Monad m => SrcLoc -> [String] -> Zipper a -> StateT Int m (String, SrcLoc) -reprintC cursor inp z = - do (p1, cursor', flag) <- query (refactoring inp cursor) z - - (_, inp') <- return $ takeBounds (cursor, cursor') inp - (p2, cursor'') <- if flag then return ("", cursor') - else enterDown cursor' inp' z - - (_, inp'') <- return $ takeBounds (cursor', cursor'') inp' - (p3, cursor''') <- enterRight cursor'' inp'' z - - return (p1 ++ p2 ++ p3, cursor''') - -enterDown cursor inp z = case (down' z) of - Just dz -> reprintC cursor inp dz - Nothing -> return $ ("", cursor) - -enterRight cursor inp z = case (right z) of - Just rz -> reprintC cursor inp rz - Nothing -> return $ ("", cursor) - --- End of GLORIOUS REFACTORING ALGORITHM - - -{- Specifies how to do specific refactorings - (uses generic query extension - remember extQ is non-symmetric) --} - -refactoring :: (Typeable a, Monad m) => [String] -> SrcLoc -> a -> StateT Int m (String, SrcLoc, Bool) -refactoring inp cursor = ((((\_ -> return ("", cursor, False)) - `extQ` (refactorUses inp cursor)) - `extQ` (refactorDecl inp cursor)) - `extQ` (refactorArgName inp cursor)) - `extQ` (refactorFortran inp cursor) - - -refactorFortran :: Monad m => [String] -> SrcLoc -> Fortran Annotation -> StateT Int m (String, SrcLoc, Bool) -refactorFortran inp cursor e = return $ - if (pRefactored $ tag e) then - let (lb, ub) = srcSpan e - (p0, _) = takeBounds (cursor, lb) inp - outE = pprint e - lnl = case e of (NullStmt _ _) -> (if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else "") - _ -> "" - lnl2 = if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else "" - textOut = if p0 == "\n" then outE else (p0 ++ lnl2 ++ outE ++ lnl) - in (show $ Prelude.last p0) `trace` (textOut, ub, True) - else ("", cursor, False) - - -refactorDecl :: Monad m => [String] -> SrcLoc -> Decl Annotation -> StateT Int m (String, SrcLoc, Bool) -refactorDecl inp cursor d = - if (pRefactored $ tag d) then - let (lb, ub) = srcSpan d - (p0, _) = takeBounds (cursor, lb) inp - textOut = p0 ++ (pprint d) - in do textOut' <- -- The following compensates new lines with removed lines - case d of - (NullDecl _ _) -> - do added <- get - let diff = linesCovered ub lb - -- remove empty newlines here if extra lines have been added - let (text, removed) = if added <= diff - then removeNewLines textOut added - else removeNewLines textOut diff - put (added - removed) - return text - otherwise -> return textOut - return (textOut', ub, True) - else return ("", cursor, False) - -refactorArgName :: Monad m => [String] -> SrcLoc -> ArgName Annotation -> m (String, SrcLoc, Bool) -refactorArgName inp cursor a = return $ - case (refactored $ tag a) of - Just lb -> let (p0, _) = takeBounds (cursor, lb) inp - in (p0 ++ pprint a, lb, True) - Nothing -> ("", cursor, False) - -refactorUses :: Monad m => [String] -> SrcLoc -> Uses Annotation -> StateT Int m (String, SrcLoc, Bool) -refactorUses inp cursor u = - let ?variant = HTMLPP in - case (refactored $ tag u) of - Just lb -> let (p0, _) = takeBounds (cursor, lb) inp - syntax = printSlave u - in do added <- get - if (newNode $ tag u) then put (added + (countLines syntax)) - else return () - return (p0 ++ syntax, toCol0 lb, True) - Nothing -> return ("", cursor, False) - -countLines [] = 0 -countLines ('\n':xs) = 1 + countLines xs -countLines (x:xs) = countLines xs - -{- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string - xs, returning the new string and the number of new lines that were removed. Note - that the number of new lines removed might actually be less than 'n'- but in principle - this should not happen with the usaage in 'refactorDecl' -} - -removeNewLines [] n = ([], 0) - -removeNewLines xs 0 = (xs, 0) - --- Deal with CR LF in the same way as just LF -removeNewLines ('\r':('\n':('\r':('\n':xs)))) n = let (xs', n') = removeNewLines ('\r':'\n':xs) (n - 1) - in (xs', n' + 1) - -removeNewLines ('\n':('\n':xs)) n = let (xs', n') = removeNewLines ('\n':xs) (n - 1) - in (xs', n' + 1) -removeNewLines (x:xs) n = let (xs', n') = removeNewLines xs n - in (x:xs', n) - ---removeNewLines ('\n':xs) 0 = let (xs', n') = removeNewLines xs 0 --- in ('\n':xs', 0) - - - -{- -OLD (FLAKEY) ALGORITHM - - reprint :: String -> String -> Program A1 -> String - reprint input f z = let input' = Prelude.lines input - in reprintA (SrcLoc f 1 0) (SrcLoc f (Prelude.length input') (1 + (Prelude.length $ Prelude.last input'))) input' (toZipper z) - - - doHole :: (Show (d A1)) => SrcLoc -> SrcLoc -> [String] -> Zipper (d A1) -> (String, SrcLoc) - doHole cursor end inp z = let ?variant = HTMLPP in - case (getHole z)::(Maybe (Fortran A1)) of - Just e -> let flag = tag e - (lb, ub) = srcSpan e - (p1, rest1) = takeBounds (cursor, lb) inp - in if flag then let ?variant = HTMLPP - in (p1 ++ printMaster e, ub) - else case (down' z) of - Just cz -> (p1 ++ reprintA lb ub rest1 cz, ub) - Nothing -> let (p2, _) = takeBounds (lb, ub) rest1 - in (p1 ++ p2, ub) - Nothing -> case (down' z) of - Just cz -> "no - down\n" `trace` (reprintA cursor end inp cz, cursor) - Nothing -> ("", cursor) - - reprintA :: (Show (d A1)) => SrcLoc -> SrcLoc -> [String] -> Zipper (d A1) -> String - reprintA cursor end inp z = let (p1, cursor') = doHole cursor end inp z - (p2, inp') = takeBounds (cursor, cursor') inp - in p1 ++ case (right z) of - Just rz -> reprintA cursor' end inp' rz - Nothing -> fst $ takeBounds (cursor', end) inp' - --} diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,90 +0,0 @@ -# CamFort - -## Installation & Building - -### Using Stack - -We recommend using Stack (http://www.haskellstack.org) to build Camfort. - - 1. Install Stack following the instructions here: http://docs.haskellstack.org/en/stable/README/#how-to-install - 2. Checkout the latest version of language-fortran - 3. Checkout the latest version of camfort - 4. Build using Stack - -``` -git clone git@github.com:dorchard/language-fortran.git -git clone git@github.com:dorchard/camfort.git -cd camfort -stack build -stack install # install binary -stack exec camfort # run camfort -``` - -Please note that at this time we have been unable to compile Camfort on Windows due to a problem with the hmatrix dependency. - -### Using Cabal - -Cabal does not automatically install the build tools. If you wonder why -checkout haskell/cabal#220. - -``` -$ cabal install alex happy -``` - -Install the native packages needed for `hmatrix` dependency - -``` -sudo apt-get install libgsl0-dev liblapack-dev libatlas-base-dev -``` - -### For general usage - -``` -$ cabal install camfort -``` - -### For development - -``` -$ cabal sandbox init -$ cabal install --only-dependencies -$ cabal exec bash -``` - -This spawns a new shell with only the packages within the sandbox available. - -``` -$ ghc Main.hs -o camfort -``` - -This generates a camfort executable in the root directory using only the -packages in the sandbox and none of ~/.cabal or system Haskell packages. - -## Usage - -``` -CamFort - Cambridge Fortran Infrastructure. -Usage: camfort [OUTPUT] [OPTIONS...] -Refactor functions: - common [common block elimination] - commonArg [common block elimination (to parameter passing)] - equivalence [equivalence elimination] - dataType [derived data type introduction] - dead [dead-code elimination] - units [unit-of-measure inference] - removeUnits [unit-of-measure removal] - -Analysis functions: - asts [blank analysis, outputs analysis files with AST information] - lva [live-variable analysis] - loops [loop information] - count [count variable declarations] - criticalUnits [calculate the critical variables for units-of-measure inference] - ast [print the raw AST -- for development purposes] - -Options: - -v, -? --version show version number - -e FILES --exclude=FILES files to exclude (comma separated list, no spaces) - -s ID --units-solver=ID units-of-measure solver. ID = Custom or LAPACK - -l ID --units-literals=ID units-of-measure literals mode. ID = Unitless, Poly, or Mixed -``` diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,30 +0,0 @@ -Units - * Proper scoping for units of measure (see code21.f90 - NMAX and N) - * Confirm the signature for MOD and MODULO - * Consider the UNIT program: -program square - implicit none - - real :: a, b - real, unit(m) :: x - real, unit(s) :: t - - x = 20.0 - t = 3.0 - a = sqr(x) - b = sqr(t) - - print *, a - print *, b - - contains - - real function sqr(y) - real y - real z - sqr = y * y * z - end function -end program - -What happens to z. Currently it does not get copied! Instead, a temporary column should be generated for -it. diff --git a/Transformation/CommonBlockElim.hs b/Transformation/CommonBlockElim.hs deleted file mode 100644 --- a/Transformation/CommonBlockElim.hs +++ /dev/null @@ -1,333 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ImplicitParams, DeriveDataTypeable, TypeOperators #-} - -module Transformation.CommonBlockElim where - -import Control.Monad -import Control.Monad.State.Lazy - -import Debug.Trace -import Data.Data -import Data.List -import Data.Ord -import qualified Data.Map as Data.Map -import Data.Generics.Uniplate.Operations - -import Language.Fortran -import Language.Fortran.Pretty - -import Helpers -import Traverse -import Analysis.Annotations -import Analysis.Syntax -import Analysis.Types -import Transformation.Syntax - --- Typed common block representation -type TCommon p = (Maybe String, [(Variable, Type p)]) - --- Typed and "located" common block representation --- TODO: include column + line information -type TLCommon p = (Filename, (String, TCommon p)) - --- Top-level functions for eliminating common blocks in a set of files -commonElimToModules :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)]) - --- Eliminates common blocks in a program directory (and convert to modules) -commonElimToModules d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", []) - (r', ps'') = introduceModules d cg - psR = updateUseDecls ps' cg - in (r ++ r', psR ++ ps'') - - - -analyseCommons :: [(Filename, Program A)] -> State (Report, [TLCommon A]) [(Filename, Program A)] -analyseCommons pss = let - defs' :: Filename -> ProgUnit A -> State (Report, [TLCommon A]) (ProgUnit A) - defs' fname p = case (getSubName p) of - Just pname -> transformBiM (collectCommons fname pname) p - Nothing -> case p of - IncludeProg a sp ds f -> - -- ("doing an include: " ++ (show fname)) `trace` - let -- create dummy block - a0 = unitAnnotation - b = Block a (UseBlock (UseNil a0) nullLoc) - (ImplicitNull a0) sp ds - (NullStmt a0 nullSpan) - in do (Block _ _ _ _ ds' _) <- transformBiM (collectCommons fname fname) b - return $ IncludeProg a sp ds' f - otherwise -> return p - -- defs' f (Sub _ _ _ (SubName _ n) _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons' b) []))] - -- Don't support functions yet - -- defs' f (Function _ _ _ (SubName _ n) _ _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons b) []))] - -- defs' _ _ rs = concat rs - - in mapM (\(f, ps) -> do ps' <- mapM (transformBiM (defs' f)) ps - return (f, ps')) pss - -collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A) -collectCommons fname pname b = - let tenv = typeEnv b - - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A) - commons' f@(Common a sp cname exprs) = - do let r' = fname ++ (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n" - (r, env) <- get - put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env) - return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp) - commons' f = return f - - typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)] - typeCommonExprs [] = [] - typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) = - case (tenvLookup v tenv) of - Just t -> (v, t) : (typeCommonExprs es) - Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp - typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e) - - in transformBiM commons' b - -{- Comparison functions for common block names and variables -} -cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering -cmpTLConFName (f1, (_, _)) (f2, (_, _)) = compare f1 f2 - -cmpTLConPName :: TLCommon A -> TLCommon A -> Ordering -cmpTLConPName (_, (p1, _)) (_, (p2, _)) = compare p1 p2 - -cmpTLConBNames :: TLCommon A -> TLCommon A -> Ordering -cmpTLConBNames (_, (_, c1)) (_, (_, c2)) = cmpTConBNames c1 c2 - -cmpTConBNames :: TCommon A -> TCommon A -> Ordering -cmpTConBNames (Nothing, _) (Nothing, _) = EQ -cmpTConBNames (Nothing, _) (Just _, _) = LT -cmpTConBNames (Just _, _) (Nothing, _) = GT -cmpTConBNames (Just n, _) (Just n', _) = if (n < n') then LT - else if (n > n') then GT else EQ - --- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)], [(Filename, Program A)]) --- How to decide which gets to be the "head" perhaps the one which triggers the *least* renaming (ooh!) --- (this is calculated by looking for the mode of the TLCommon (for a particular Common) --- (need to do gorouping, but sortBy is used already so... (IS THIS STABLE- does this matter?)) - -onCommonBlock :: (TCommon A -> TCommon A) -> TLCommon A -> TLCommon A -onCommonBlock f (fname, (pname, tcommon)) = (fname, (pname, f tcommon)) - -commonName Nothing = "Common" -commonName (Just x) = x - --- Freshen the names for a common block and generate a renamer from the old block to this -freshenCommonNames :: TLCommon A -> (TLCommon A, RenamerCoercer) -freshenCommonNames (fname, (pname, (cname, fields))) = - let mkRenamerAndCommon (r, tc) (v, t) = - let v' = (caml $ commonName cname) ++ "_" ++ v - in (Data.Map.insert v (Just v', Nothing) r, (v', t) : tc) - (r, fields') = foldl mkRenamerAndCommon (Data.Map.empty, []) fields - in ((fname, (pname, (cname, fields'))), Just r) - --- From a list of typed and located common blocks --- group by the common block name, and then group/sort within such that the "mode" block is first -groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]] -groupSortCommonBlock commons = let -- Group by names of the common blocks - gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons - -- Group within by the different common block variable-type fields - gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs - in gccs - -cmpVarName :: TLCommon A -> TLCommon A -> Ordering -cmpVarName (fname1, (pname1, (name1, vtys1))) (fnam2, (pname2, (name2, vtys2))) = map fst vtys1 `compare` map fst vtys2 - -mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)] -mkTLCommonRenamers commons = case allCoherentCommonsP commons of - (r, False) -> error $ "Common blocks are incoherent!\n" ++ r -- (r, []) -- Incoherent commons - (_, True) -> let gccs = groupSortCommonBlock commons - -- Find the "mode" common block and freshen the names for this, creating - -- a renamer between this and every module - gcrcs = map (\grp -> -- grp are block decls all for the same block - let (com, r) = freshenCommonNames (head (head grp)) - in map (\c -> (c, r)) (head grp) ++ - map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs - -- Now re-sort based on the file and program unit - gcrcs' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs)) - in gcrcs' - - -updateUseDecls :: [(Filename, Program A)] -> [TLCommon A] -> [(Filename, Program A)] -updateUseDecls fps tcs = - let tcrs = mkTLCommonRenamers tcs - - concatUses :: Uses A -> Uses A -> Uses A - concatUses (UseNil p) y = y - concatUses (Uses p x us p') y = Uses p x (UseNil p) p' - - inames :: Decl A -> Maybe String - inames (Include _ (Con _ _ inc)) = Just inc - inames _ = Nothing - - importIncludeCommons :: ProgUnit A -> ProgUnit A - importIncludeCommons p = foldl (\p' iname -> ("Iname = " ++ iname) `trace` matchPUnitAlt iname p') p (reduceCollect inames p) - - matchPUnitAlt :: Filename -> ProgUnit A -> ProgUnit A - matchPUnitAlt fname p = ("fname = " ++ fname ++ "\n" ++ (show ((lookups' fname) (lookups' fname tcrs)))) `trace` - let tcrs' = (lookups' fname) (lookups' fname tcrs) - srcloc = useSrcLoc p - uses = mkUseStatements srcloc tcrs' - p' = transformBi ((flip concatUses) uses) p - in let ?fname = fname in removeDecls (map snd tcrs') p' - - - matchPUnit :: Filename -> ProgUnit A -> ProgUnit A - matchPUnit fname p = let pname = case getSubName p of - Nothing -> fname -- If no subname is available, use the filename - Just pname -> pname - tcrs' = (lookups' pname) (lookups' fname tcrs) - srcloc = useSrcLoc p - uses = mkUseStatements srcloc tcrs' - p' = transformBi ((flip concatUses) uses) p - in let ?fname = fname in removeDecls (map snd tcrs') p' - - -- Given the list of renamed/coercerd variables form common blocks, remove any declaration sites - removeDecls :: (?fname :: Filename) => [RenamerCoercer] -> ProgUnit A -> ProgUnit A - removeDecls rcs p = let (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) [] - in addToProgUnit p' remainingAssignments - - -- Removes a declaration and collects a list of any default values given at declaration time - -- (which then need to be turned into separate assignment statements) - removeDecl :: (?fname :: Filename) => [RenamerCoercer] -> Decl A -> State [Fortran A] (Decl A) - removeDecl rcs d@(Decl p srcP vars typ) = - (modify (++ assgns)) >> (return $ if (vars' == []) then NullDecl p' srcP - else Decl p' srcP vars' typ) - where - (assgns, vars') = foldl matchVar ([],[]) vars - p' = if (length vars == length vars') then p else p { refactored = Just (fst srcP) } - - matchVar :: ([Fortran A], [(Expr A, Expr A, Maybe Int)]) - -> (Expr A, Expr A, Maybe Int) - -> ([Fortran A], [(Expr A, Expr A, Maybe Int)]) - matchVar (assgns, decls) dec@(lvar@(Var _ _ [(VarName _ v, _)]), e, _) = - if (hasRenaming v rcs) then - case e of - -- Renaming exists and no default, then remove - NullExpr _ _ -> (assgns, decls) - -- Renaming exists but has default, so create an assignment for this - e -> ((Assg p' srcP lvar e) : assgns, decls) - else -- no renaming, preserve declaration - (assgns, dec : decls) - matchVar (assgns, decls) _ = (assgns, decls) - removeDecl _ d = return d - - in each fps (\(f, p) -> (f, map importIncludeCommons $ transformBi (matchPUnit f) p)) - --- Adds additional statements to the start of the statement block in a program unit -addToProgUnit :: ProgUnit A -> [Fortran A] -> ProgUnit A -addToProgUnit p [] = p -addToProgUnit (IncludeProg p sp decl Nothing) stmts = IncludeProg p sp decl (Just $ - prependStatements (Just $ afterEnd sp) (NullStmt unitAnnotation (afterEnd sp)) stmts) -addToProgUnit (IncludeProg p sp decl (Just f)) stmts = IncludeProg p sp decl (Just $ prependStatements Nothing f stmts) -addToProgUnit p stmts = transformBi (flip addToBlock stmts) p - --- Add additional statements to the start of a block -addToBlock :: Block A -> [Fortran A] -> Block A -addToBlock b [] = b -addToBlock (Block p useBlock imps sp decls stmt) stmts = Block p useBlock imps sp decls (prependStatements Nothing stmt stmts) - --- Prepends statements onto a statement -prependStatements :: Maybe SrcSpan -> Fortran A -> [Fortran A] -> Fortran A -prependStatements sp stmt ss = FSeq p' sp' (foldl1 (FSeq p' sp') ss) stmt - where p' = (annotation stmt) { refactored = Just (fst sp') } - sp' = case sp of - Nothing -> srcSpan stmt - Just s -> s - -useSrcLoc :: ProgUnit A -> SrcLoc -useSrcLoc (Main _ _ _ _ b _) = useSrcLocB b -useSrcLoc (Sub _ _ _ _ _ b) = useSrcLocB b -useSrcLoc (Function _ _ _ _ _ _ b)= useSrcLocB b -useSrcLoc (Module _ s _ _ _ _ _) = fst s -- TOOD: this isn't very accurate -useSrcLoc (BlockData _ s _ _ _ _) = fst s -useSrcLocB (Block _ (UseBlock _ s) _ _ _ _) = s - -renamerToUse :: RenamerCoercer -> [(Variable, Variable)] -renamerToUse Nothing = [] -renamerToUse (Just m) = let entryToPair v (Nothing, _) = [] - entryToPair v (Just v', _) = [(v, v')] - in Data.Map.foldlWithKey (\xs v e -> (entryToPair v e) ++ xs) [] m - --- make the use statements for a particular program unit's common blocks -mkUseStatements :: SrcLoc -> [(TCommon A, RenamerCoercer)] -> Uses A -mkUseStatements s [] = UseNil (unitAnnotation) -mkUseStatements s (((name, _), r):trs) = - let a = unitAnnotation { refactored = Just s, newNode = True } -- previously-- Just (toCol0 s) - in Uses a (Use (commonName name) (renamerToUse r)) (mkUseStatements s trs) a - - -mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer -mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) = mkRenamerCoercer common1 common2 - -mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer -mkRenamerCoercer (name1, vtys1) (name2, vtys2) - | name1 == name2 = if (vtys1 == vtys2) then Nothing else Just $ generate vtys1 vtys2 Data.Map.empty - | otherwise = error "Can't generate renamer between different common blocks\n" - where - generate [] [] theta = theta - generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta = - let varR = if (var1 == var2) then Nothing else Just var2 - typR = if (ty1 == ty2) then Nothing else Just (ty1, ty2) - in generate vtys1 vtys2 (Data.Map.insert var1 (varR, typR) theta) - generate _ _ _ = error "Common blocks of different field length\n" - -allCoherentCommonsP :: [TLCommon A] -> (Report, Bool) -allCoherentCommonsP commons = foldM (\p (c1, c2) -> (coherentCommonsP c1 c2) >>= (\p' -> return $ p && p')) True (pairs commons) - -coherentCommonsP :: TLCommon A -> TLCommon A -> (Report, Bool) -coherentCommonsP (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) = - if (n1 == n2) then - let coherent :: [(Variable, Type A)] -> [(Variable, Type A)] -> (Report, Bool) - coherent [] [] = ("", True) - coherent ((var1, ty1):xs) ((var2, ty2):ys) - | af ty1 == af ty2 = let (r', c) = coherent xs ys - in (r', c && True) - | otherwise = let r = (var1 ++ ":" ++ (pprint ty1) ++ "(" ++ (show $ af ty1) ++ ")" ++ " differs from " ++ - var2 ++ ":" ++ (pprint ty2) ++ "(" ++ (show $ af ty2) ++ ")" ++ "\n") - (r', _) = coherent xs ys - in (r ++ r', False) - coherent _ _ = ("Common blocks of different field lengths", False) -- Doesn't say which is longer - in coherent vtys1 vtys2 - - else ("", True) -- Not sure if this is supposed to fail here- in retrospect I think no - -- False -> ("Trying to compare differently named common blocks: " ++ show n1 ++ " and " ++ show n2 ++ "\n", False) - -introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)]) -introduceModules d cenv = mapM (mkModuleFile d) (map (head . head) (groupSortCommonBlock cenv)) - - -mkModuleFile :: Directory -> (TLCommon A) -> (Report, (Filename, Program A)) -mkModuleFile d (_, (_, (name, varTys))) = - let modname = commonName name - fullpath = d ++ "/" ++ modname ++ ".f90" - r = "Created module " ++ modname ++ " at " ++ fullpath ++ "\n" - in (r, (fullpath, [mkModule modname varTys modname])) - -mkModule :: String -> [(Variable, Type A)] -> String -> ProgUnit A -mkModule name vtys fname = - let a = unitAnnotation { refactored = Just loc } - loc = SrcLoc (fname ++ ".f90") 0 0 - sp = (loc, loc) - toDecl (v, t) = Decl a sp [(Var a sp [(VarName a (name ++ "_" ++ v), [])], NullExpr a sp, Nothing)] -- note here could pull in initialising definition? What if conflicts- highlight as potential source of error? - t - decls = foldl1 (DSeq a) (map toDecl vtys) - in Module a (loc, loc) (SubName a fname) (UseNil a) (ImplicitNone a) decls [] - diff --git a/Transformation/CommonBlockElimToCalls.hs b/Transformation/CommonBlockElimToCalls.hs deleted file mode 100644 --- a/Transformation/CommonBlockElimToCalls.hs +++ /dev/null @@ -1,176 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -module Transformation.CommonBlockElimToCalls where - -import Control.Monad -import Control.Monad.State.Lazy - -import Data.Generics.Uniplate.Operations - -import Data.List - -import Language.Fortran -import Language.Haskell.Syntax (SrcLoc(..)) - -import Helpers -import Traverse -import Analysis.Annotations -import Analysis.Syntax -import Analysis.Types -import Transformation.Syntax -import Transformation.CommonBlockElim - -{- This is somewhat experimental and incomplete -} - --- Top-level functions for eliminating common blocks in a set of files -commonElimToCalls :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)]) - --- Eliminates common blocks in a program directory (and convert to calls) -commonElimToCalls d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", []) - (r', ps'') = mapM (introduceCalls cg) ps' - in (r ++ r', ps'') - -{-Extending calls version-} -introduceCalls :: [TLCommon A] -> (Filename, Program A) -> (Report, (Filename, Program A)) -introduceCalls cenv (fname, ps) = do ps' <- mapM (transformBiM commonElim) ps - -- ps'' <- mapM (transformBiM commonElim'') ps' - return (fname, ps') - - where commonElim s@(Sub a sp mbt (SubName a' moduleName) (Arg p arg asp) b) = - - let commons = lookups moduleName (lookups fname cenv) - sortedC = sortBy cmpTConBNames commons - tArgs = extendArgs (nonNullArgs arg) asp (concatMap snd sortedC) - ra = p { refactored = Just (fst sp) } - arg' = Arg unitAnnotation (ASeq unitAnnotation arg tArgs) asp - a' = a -- { pRefactored = Just sp } - r = fname ++ (show $ srcLineCol $ snd asp) ++ ": changed common variables to parameters\n" - in do b' <- transformBiM (extendCalls fname moduleName cenv) b - (r, Sub a' sp mbt (SubName a' moduleName) arg' b') - - commonElim s = --case (getSubName s) of - -- Just n -> transformBiM (extendCalls fname n cenv) s - -- Nothing -> - transformBiM r s - where r :: ProgUnit A -> (Report, ProgUnit A) - r p = case getSubName p of - Just n -> transformBiM (extendCalls fname n cenv) p - Nothing -> return p - - -extendCalls :: String -> String -> [TLCommon A] -> Fortran A -> (Report, Fortran A) -extendCalls fname localSub cenv f@(Call p sp v@(Var _ _ ((VarName _ n, _):_)) (ArgList ap arglist)) = - let commons = lookups n (map snd cenv) - targetCommonNames = map fst (sortBy cmpTConBNames commons) - - localCommons = lookups localSub (lookups fname cenv) - localCommons' = sortBy cmpTConBNames localCommons - - p' = p { refactored = Just $ toCol0 $ fst sp } - ap' = ap { refactored = Just $ fst sp } - - arglist' = toArgList p' sp (select targetCommonNames localCommons') - r = fname ++ (show $ srcLineCol $ fst sp) ++ ": call, added common variables as parameters\n" - in (r, Call p' sp v (ArgList ap' $ ESeq p' sp arglist arglist')) - - -- Nothing -> error "Source has less commons than the target!" -extendCalls _ _ _ f = return f - - -toArgList :: A -> SrcSpan -> [(Variable, Type A)] -> Expr A -toArgList p sp [] = NullExpr p sp -toArgList p sp ((v, _):xs) = ESeq p sp (Var p sp [(VarName p v, [])]) (toArgList p sp xs) - -select :: [Maybe String] -> [TCommon A] -> [(Variable, Type A)] -select [] _ = [] -select x [] = error $ "Source has less commons than the target!" ++ show x -select a@(x:xs) b@((y, e):yes) | x == y = e ++ select xs yes - | otherwise = select xs yes - -nonNullArgs (ASeq _ _ _) = True -nonNullArgs (ArgName _ _) = True -nonNullArgs (NullArg _) = False - - -extendArgs nonNullArgs sp' args = if nonNullArgs then - let p' = unitAnnotation { refactored = Just $ snd sp' } - in ASeq p' (ArgName p' "") (extendArgs' sp' args) - else extendArgs' sp' args - - -extendArgs' _ [] = NullArg unitAnnotation -extendArgs' sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ fst sp' } - in ASeq p' (ArgName p' v) (extendArgs' sp' vts) - -{- blockExtendDecls (Block a s i sp ds f) ds' = Block a s i sp (DSeq unitAnnotation ds ds') f - - extendArgs _ [] = (NullDecl unitAnnotation, NullArg unitAnnotation) - extendArgs sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ toCol0 $ fst sp' } - dec = Decl p' [(Var p' sp' [(VarName p' v, [])], NullExpr p' sp')] t - arg = ArgName p' v - (decs, args) = extendArgs sp' vts - in (DSeq p' dec decs, ASeq p' arg args) --} - - - - -{- - collectTCommons :: [Program Annotation] -> State (TCommons Annotation) [Program Annotation] - collectTCommons p = transformBiM collectTCommons' p -(transformBiM collectTCommons) --} - - -collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A) -collectCommons fname pname b = - let tenv = typeEnv b - - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A) - commons' f@(Common a sp cname exprs) = - do let r' = fname ++ (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n" - (r, env) <- get - put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env) - return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp) - commons' f = return f - - typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)] - typeCommonExprs [] = [] - typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) = - case (tenvLookup v tenv) of - Just t -> (v, t) : (typeCommonExprs es) - Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp - typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e) - - in transformBiM commons' b - -{- --- Turn common blocks into type defs - - commonToTypeDefs :: String -> [(String, [Program Annotation])] -> IO Report - commonToTypeDefs d = - let name = d ++ "Types" - unitSrcLoc = SrcLoc (name ++ ".f90") 0 0 - decls = undefined - mod = Module () (unitSrcLoc, unitSrcLoc) (SubName () name) [] ImplicitNode decls [] - in let ?variant = DefaultPP in writeFile (d ++ "/" ++ name ++ ".f90") (outputF mod) - - - commonToTypeDefs' :: String -> (String, [Program Annotation]) -> [Decls] - commonToTypeDefs' = undefined -- DerivedTypeDef p --} diff --git a/Transformation/DeadCode.hs b/Transformation/DeadCode.hs deleted file mode 100644 --- a/Transformation/DeadCode.hs +++ /dev/null @@ -1,58 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} - -module Transformation.DeadCode where - -import Analysis.Annotations -import Analysis.LVA -import Analysis.Syntax -import Transformation.Syntax -import Traverse -import Language.Fortran - -import Helpers - -import Generics.Deriving.Copoint -import GHC.Generics - -import Debug.Trace - -import Data.Generics.Uniplate.Operations - -deadCode :: Bool -> (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -deadCode flag (fname, p) = - let (r, p') = mapM ((transformBi elimEmptyFseq) . transformBiM (elimDead flag)) (lva p) - in if r == "" then (r, (fname, p')) - else (r, (fname, p')) >>= (deadCode flag) - -elimEmptyFseq :: Fortran Annotation -> Fortran Annotation -elimEmptyFseq (FSeq _ _ (NullStmt _ _) n2@(NullStmt _ _)) = n2 -elimEmptyFseq f = f - -elimDead :: Bool -> Fortran Annotation -> (Report, Fortran Annotation) -elimDead flag x@(Assg a sp@(s1, s2) e1 e2) | (pRefactored a) == flag = - let lOut = liveOut a - -- currently assumes an assign defines only one access (which is usual) - in if ((varExprToAccesses e1) == []) || ((head $ varExprToAccesses e1) `elem` lOut) then - return x - else let report = "o" ++ (show . srcLineCol $ s1) ++ ": removed dead code\n" - in (report, NullStmt (a { refactored = (Just s1) }) (dropLine sp)) -elimDead _ x = return x - diff --git a/Transformation/DerivedTypeIntro.hs b/Transformation/DerivedTypeIntro.hs deleted file mode 100644 --- a/Transformation/DerivedTypeIntro.hs +++ /dev/null @@ -1,260 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Transformation.DerivedTypeIntro where - -import Data.Data -import Data.List hiding (union, insert) -import Data.Maybe -import Data.Set hiding (foldl, map) - -import Data.Generics.Uniplate.Operations - -import Control.Monad.State.Lazy - -import Debug.Trace - -import qualified Data.Map as Data.Map - -import Language.Fortran - -import Analysis.Annotations -import Analysis.IntermediateReps -import Analysis.Loops -import Analysis.Syntax -import Transformation.Syntax -import Analysis.Types - -import Helpers -import Traverse - -typeStruct :: [(Filename, Program Annotation)] -> (Report, [(Filename, Program Annotation)]) -typeStruct fps = mapM (\(f, ps) -> mapM typeStructPerProgram ps >>= (\ps' -> return (f, ps'))) fps - --- raph data structures used to build interference graphs - -type Graph v a = [((v, v), a)] -- Note, this is graphs with labelled edges - -type WeightedEdge v a = ((v, v), (a, Int)) -type WeightedGraph v a = [WeightedEdge v a] - --- vertices :: WeightedGraph v a -> [v] (also works for Graph v a) -vertices = concatMap (\((x, y), _) -> [x, y]) - --- isVertex :: v -> WeightedGraph v a -> Bool (also works Graph v a) -isVertex v wgs = elem v (vertices wgs) - -getVertex v [] = Nothing -getVertex v (((v1, v2), d):es) = if v == v1 || v == v2 then Just d - else getVertex v es - - --- on-interprocedural version first - -typeStructPerProgram :: ProgUnit Annotation -> (Report, ProgUnit Annotation) -typeStructPerProgram p = descendBiM - (\b@(Block a uses implicits span decs blockBody) -> - let - tenv = typeEnv b - - -- Compute graph of semantically related projection variables - es = Exprs `topFrom` b - prjVarsWTarget = map locsFromArrayIndex es - iGraph = toInterferenceGraph prjVarsWTarget - wiGraph = calculateWeights iGraph -- weighted inteference graph - wgf = decomposeWeightedGraph wiGraph - - -- Generate definitions - tDefsAndNames = evalState (mapM (mkTypeDef tenv (fst span, fst span)) wgf) 0 - - nwgf = zip wgf (map snd tDefsAndNames) - - rAnnotation = if (length tDefsAndNames > 0) - then unitAnnotation { refactored = Just (fst span) } - else unitAnnotation - - blockBody' = elimProjectionDefs blockBody iGraph - - decs' = foldl (DSeq unitAnnotation) decs (map fst tDefsAndNames) - a' = if (length tDefsAndNames > 0) then a { refactored = Just (fst span) } else a - in -- Create outgoing block - (show wiGraph ++ "\n\n" ++ show wgf, Block a' uses implicits span decs' blockBody')) p - --- - Graph Access Variable here is a graph with projection variables at nodes --- - and the array target that they both index as the edge label - -toInterferenceGraph :: [[(Variable, Access)]] -> Graph Access Variable -toInterferenceGraph pvars = let rel = concatMap listToSymmRelation pvars - matchingArrayTargets r ((a, x), (b, y)) - | a == b = ((x, y), a) : r - | otherwise = r - in foldl matchingArrayTargets [] rel - - -listToSymmRelation :: [a] -> [(a, a)] -listToSymmRelation [] = [] -listToSymmRelation (x:xs) = ((repeat x) `zip` xs) ++ (listToSymmRelation xs) - - --- heck coherence of original manual projection approach - -correctManualImpl ranges stmt graph = - let (_, pvarmap) = runState (transformBiM collect stmt) Data.Map.empty - in Data.Map.foldWithKey - (\arr vixs p -> case (lookup arr ranges) of - Just (l, u) -> (sort (map snd vixs) == [l..u]) && p) True pvarmap - - where - collect :: Fortran A -> State (Data.Map.Map Variable [(Variable, Integer)]) (Fortran A) - collect a@(Assg p sp e1 e2) = - do indexMap <- get - case (do v <- varExprToVariable e1 - arr <- getVertex (VarA v) graph - case e2 of - (ConS _ _ val) -> - case (Data.Map.lookup arr indexMap) of - Just ixs -> - case (lookup v ixs) of - Just val' -> Nothing -- error "Repeated definition of projection" - Nothing -> Just $ Data.Map.update (\ixs -> Just $ ((v, read $ val) : ixs)) arr indexMap - Nothing -> Just $ Data.Map.insert arr [(v, read $ val)] indexMap) of - Just indexMap' -> do put indexMap'; return a - Nothing -> return a - collect f = return f - - -elimProjectionDefs :: Fortran A -> Graph Access Variable -> Fortran A -elimProjectionDefs stmt graph = transformBi ef stmt - where ef a@(Assg p sp e1 e2) = - case (varExprToVariable e1) of - Just v -> if (isVertex (VarA v) graph) then - NullStmt (p { refactored = Just $ dropLine' sp }) sp - else a - Nothing -> a - ef f = f - - -arrayAccessToProjection :: Fortran A -> Graph Access Variable -> Fortran A -arrayAccessToProjection = undefined - - --- ounts number of duplicate edges and makes this the "weight" - -calculateWeights :: (Eq (AnnotationFree a), Eq (AnnotationFree v), Ord a, Ord v) => Graph v a -> WeightedGraph v a -calculateWeights xs = calcWs (sort xs) 1 - where calcWs [] _ = [] - calcWs [((v1, v2), a)] n = [((v1, v2), (a, n))] - calcWs (e@((v1, v2), a):(e':es)) n | ((af e == af e') || (af e == (af (swap e')))) - = calcWs (e':es) (n + 1) - | otherwise = ((v1, v2), (a, n)) : (calcWs (e':es) 1) - -swap ((a, b), v) = ((b, a), v) - --- inds the variables that are used to index arrays directly - -locsFromArrayIndex :: Data t => t -> [(Variable, Access)] -locsFromArrayIndex x = - concat . concat $ - each (Vars `from` x) - (\(Var _ _ ves) -> - each ves (\(VarName _ v, ixs) -> - if (not $ all isConstant ixs) - then map (\x -> (v, x)) (Locs `from` ixs) - else [])) - - - - -findMatch v ix ((wg, n):wgns) = vertices - - --- replaceAccess :: [(WeightedGraph Variable Access, Variable)] -> Block Annotation -> Block Annotation --- replaceAccess wgns x = transformBi (\t@(VarName _ v, ixs) -> t) x --- --- - -mkTyDecl :: SrcSpan -> Variable -> Type Annotation -> Decl Annotation -mkTyDecl sp v t = let ua = unitAnnotation - in Decl ua sp [(Var ua sp [(VarName ua v, [])], NullExpr ua sp, Nothing)] t - -mkTypeDef :: TypeEnv Annotation -> SrcSpan -> WeightedGraph Access Variable -> State Int (Decl Annotation, String) -mkTypeDef tenv sp wg = (inventName wg) >>= (\name -> - let edgeToDecls ((vx, vy), (va, w)) = - case (lookup va tenv) of - Just t -> [mkTyDecl sp (accessToVarName vx) (arrayElementType t), - mkTyDecl sp (accessToVarName vy) (arrayElementType t)] - Nothing -> error $ "Can't find the type of " ++ show va ++ "\n" - - ra = unitAnnotation { refactored = Just (fst sp) } - - (_, (arrayVar, _)) = head wg - - tdecls = concatMap edgeToDecls wg - typeDecl = DerivedTypeDef ra sp (SubName ra name) [] [] tdecls - - typeCons = BaseType ra (DerivedType ra (SubName ra name)) [] (NullExpr ra sp) (NullExpr ra sp) - valDecl = Decl ra sp [(Var ra sp [(VarName ra (arrayVar ++ name), [])] , NullExpr ra sp, Nothing)] typeCons - in return $ (DSeq unitAnnotation typeDecl valDecl, name)) - -inventName :: WeightedGraph Access Variable -> State Int String -inventName graph = do n <- get - put (n + 1) - let vs = vertices graph - return $ map mode (transpose (map accessToVarName vs)) ++ (show n) --- -mode :: String -> Char -mode x = let freqs = (map (\x -> (head x, length x))) . group . sort $ x - sortedFreqs = sortBy (\x -> \y -> (snd x) `compare` (snd y)) freqs - max = last sortedFreqs - in -- mode or 'X' if mode is less than the majority - if (snd max) > ((length x) `div` 2) then fst max else 'X' - -decomposeWeightedGraph :: forall v a . (Show v, Ord v, Ord a) => WeightedGraph v a -> [WeightedGraph v a] -decomposeWeightedGraph g = map snd (concatMap (foldl binEdge []) (groupBy groupOnArrayVar (sortBy sortOnArrayVar g))) - where groupOnArrayVar (_, (av, _)) (_, (av', _)) = av == av' - sortOnArrayVar (_, (av, _)) (_, (av', _)) = compare av av' - --- ap snd (foldl binEdge [] g) - --- bins" edges into a list of graphs with a set of their vertices - -binEdge :: (Show v, Ord v, Ord a) => [(Set v, WeightedGraph v a)] -> WeightedEdge v a -> [(Set v, WeightedGraph v a)] -binEdge bins e@((x, y), _) = - let findBin v [] = ((insert x empty, []), []) - findBin v ((vs, es):bs) | member v vs = ((insert v vs, es), bs) - | otherwise = let (n, bs') = findBin v bs - in (n, (vs, es) : bs') - ((vs, es), bins') = findBin x bins - ((vs', es'), bins'') = findBin y bins' - in (vs `union` vs', e : (es ++ es')) : bins'' - - - - --- binEdge bins e@((x, y), _) = let r = binVertex y e (binVertex x e bins) in (show r) `trace` r - --- binVertex :: Ord a => a -> WeightedEdge a -> [(Set a, WeightedGraph a)] -> [(Set a, WeightedGraph a)] --- binVertex x e ss = bin' x e ss [] Nothing --- where bin' x e [] bs' Nothing = (insert x empty, [e]) : bs' --- bin' x e [] bs' (Just s) = s : bs' --- --- bin' x e ((vs, es):bs) bs' ms | member x vs = --- case ms of --- Nothing -> bin' x e bs bs' (Just (insert x vs, e:es)) --- Just (vs', es') -> bin' x e bs bs' (Just (union vs' (insert x vs'), (e:es) ++ es')) --- | otherwise = bin' x e bs ((vs, es):bs) ms diff --git a/Transformation/EquivalenceElim.hs b/Transformation/EquivalenceElim.hs deleted file mode 100644 --- a/Transformation/EquivalenceElim.hs +++ /dev/null @@ -1,108 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ImplicitParams #-} - -module Transformation.EquivalenceElim where - -import Data.Data -import Data.List - -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy - -import Language.Fortran - -import Output -import Traverse -import Helpers - -import Language.Fortran.Pretty - -import Analysis.Annotations -import Analysis.Syntax -import Analysis.Types - -import Transformation.DeadCode -import Transformation.Syntax - -import Debug.Trace - -type RfEqState = ([[Expr Annotation]], Int, Report) - -refactorEquivalences :: (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -refactorEquivalences (fname, p) = - let ?fname = fname - in do p' <- mapM (transformBiM equivalences) p - deadCode True (fname, p') - where equivalences :: (?fname :: String) => Block Annotation -> (Report, Block Annotation) - equivalences b = let equiv = do b' <- rmEquivalences b - transformBiM (addCopy (typeEnv b)) b' - (b', (_, _, r)) = runState equiv ([], 0, "") - in (r, b') - -addCopy :: (?fname :: String) => TypeEnv Annotation -> Fortran Annotation -> State RfEqState (Fortran Annotation) -addCopy tys x@(Assg a sp@(s1, s2) e1 e2) | not (pRefactored a) = - do eqs <- equivalents e1 - if (length eqs > 1) then - - - let a' = a { refactored = Just s1 } - sp' = refactorSpan sp - eqs' = deleteBy (\x -> \y -> (af x) == (af y)) e1 eqs -- remove self from list - - -- Create copy statements - mkCopy (n, e') = let sp' = refactorSpanN n sp - in - case ((varExprToVariable e1) >>= (\v1' -> varExprToVariable e' >>= (\v' -> return $ eqType v1' v' tys))) of - Nothing -> Assg a' sp' e' e1 -- could be an error - Just False -> Assg a' sp' e' (Var a' sp' [(VarName a' "transfer", [e1, e'])]) - Just True -> Assg a' sp' e' e1 - eqs'' = map mkCopy (zip [0..(length eqs')] eqs') - - -- Reporting - (l, c) = srcLineCol s1 - reportF (e', i) = ?fname ++ show (l + i, c) ++ ": addded copy: " ++ (pprint e') ++ " due to refactored equivalence\n" - report n = concatMap reportF (zip eqs'' [n..(n + length eqs'')]) - - in do -- Update refactoring state - (equivs, n, r) <- get - put (equivs, n + (length eqs'), r ++ (report n)) - - -- Sequence original assignment with new assignments - return $ FSeq a sp x (foldl1 (FSeq a' sp') eqs'') - else - return x -addCopy tys x = return x - - -rmEquivalences :: (?fname :: String) => (Block Annotation) -> State RfEqState (Block Annotation) -rmEquivalences = transformBiM rmEquiv' - where rmEquiv' :: Decl Annotation -> State RfEqState (Decl Annotation) - rmEquiv' f@(Equivalence a sp equivs) = - do (ess, n, r) <- get - put (equivs:ess, n - 1, r ++ ?fname ++ (show . srcLineCol . fst $ sp) ++ ": removed equivalence \n") - return (NullDecl (a { refactored = (Just $ fst sp) }) (dropLine sp)) - rmEquiv' f = return f - --- equivalents e" returns a list of variables/memory cells that have been equivalenced with "e". --- -equivalents :: (?fname :: String) => Expr Annotation -> State RfEqState [Expr Annotation] -equivalents x = let inGroup x [] = [] - inGroup x (xs:xss) = if (AnnotationFree x `elem` (map AnnotationFree xs)) then xs - else inGroup x xss - in do (equivs, _, _) <- get - return (inGroup x equivs) diff --git a/Transformation/Syntax.hs b/Transformation/Syntax.hs deleted file mode 100644 --- a/Transformation/Syntax.hs +++ /dev/null @@ -1,123 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -{-# LANGUAGE DeriveGeneric #-} - -module Transformation.Syntax where - --- tandard imports - -import Data.Char -import Data.List -import Control.Monad.State.Lazy -import qualified Data.Map as Data.Map - --- ata-type generics imports - -import Data.Data -import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Zipper -import Data.Typeable - --- amFort specific functionality - -import Analysis.Annotations -import Analysis.IntermediateReps -import Traverse -import Language.Fortran - --- import Language.Haskell.Syntax (SrcLoc(..)) - --- ODO: Needs fixing with the spans - need to pull apart and put back together - -reassociate :: Fortran Annotation -> Fortran Annotation -reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c)) -reassociate t = t - --- reassociate :: Fortran Annotation -> Fortran Annotation --- reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c)) --- reassociate t = t - - --- elpers to do with source locations and parsing - -refactorSpan :: SrcSpan -> SrcSpan -refactorSpan (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1) 0, SrcLoc f lu cu) - -refactorSpanN :: Int -> SrcSpan -> SrcSpan -refactorSpanN n (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1+n) 0, SrcLoc f (lu+n) cu) - -toCol0 (SrcLoc f l c) = SrcLoc f l 0 - --- ropLine extends a span to the start of the next line --- his is particularly useful if a whole line is being redacted from a source file - -linesCovered :: SrcLoc -> SrcLoc -> Int -linesCovered (SrcLoc _ l1 _) (SrcLoc _ l2 _) = l2 - l1 + 1 - -dropLine :: SrcSpan -> SrcSpan -dropLine (s1, SrcLoc f l c) = (s1, SrcLoc f (l+1) 0) - -dropLine' :: SrcSpan -> SrcLoc -dropLine' (SrcLoc f l c, _) = SrcLoc f l 0 - -srcLineCol :: SrcLoc -> (Int, Int) -srcLineCol (SrcLoc _ l c) = (l, c) - -minaa (SrcLoc f l c) = (SrcLoc f (l-1) c) - -nullLoc :: SrcLoc -nullLoc = SrcLoc "" 0 0 - -nullSpan :: SrcSpan -nullSpan = (nullLoc, nullLoc) - -afterEnd :: SrcSpan -> SrcSpan -afterEnd (_, SrcLoc f l c) = (SrcLoc f (l+1) 0, SrcLoc f (l+1) 0) - --- ariable renaming - -caml (x:xs) = (toUpper x) : xs - -type Renamer = Data.Map.Map Variable Variable - -type RenamerCoercer = Maybe (Data.Map.Map Variable (Maybe Variable, Maybe (Type A, Type A))) - -- Nothing represents an overall identity renamer/coercer for efficiency - -- a Nothing for a variable represent a variable-level (renamer) identity - -- a Nothing for a type represents a type-level (coercer) identity - -applyRenaming :: (Typeable (t A), Data (t A)) => Renamer -> (t A) -> (t A) -applyRenaming r = transformBi ((\vn@(VarName p v) -> case Data.Map.lookup v r of - Nothing -> vn - Just v' -> VarName p v')::(VarName A -> VarName A)) - -class Renaming r where - hasRenaming :: Variable -> r -> Bool - -instance Renaming RenamerCoercer where - hasRenaming _ Nothing = False - hasRenaming v (Just rc) = Data.Map.member v rc - --- sometimes we have a number of renamer coercers together -instance Renaming [RenamerCoercer] where - hasRenaming v rcss = or (map (hasRenaming v) rcss) diff --git a/Transformation/Tutorial.lhs b/Transformation/Tutorial.lhs deleted file mode 100644 --- a/Transformation/Tutorial.lhs +++ /dev/null @@ -1,62 +0,0 @@ -This tutorial provides a walkthrough on how to construct a program analysis and refactoring transformation -for Fortran using CamFort. The task which we'll cover is fairly simple, but gives a flavour of how to use -the parser and existing analysis and transformation infrastructure and tools. - -Task: to create a refactoring for Fortran that replaces 'if-then' blocks, which have only a 'true' branch -with 'if-then-else' blocks where the new 'else' now has some logging to show why the guard was false. -The refactoring will also create an analysis report showing which 'if-then' blocks were refactored. - -* 1. Understanding the relevant AST components - -The first thing we need to know is: how are 'if-then' and 'if-then-else' blocks represented inside of -CamFort. What is the corresponding AST data constructor? We can find this out by using the existing -'ast' analysis function in CamFort with some small sample programs. Let's create a sample program then -in the director "samples/tutorial" called "test.f90" with the code: - - program test - implicit none - - integer :: n - read *, n - - if (n < 3) then - print *, "n is small" - end if - - if (mod(n, 2) == 0) then - print *, "n is even" - else - print *, "n is odd" - end if - - end program test - -Let's check first that this is a valid Fortran program by running it through 'gfortran'. - - - cd samples/tutorial - gfortran test.f90 -o test - ./test 42 - -Which should print out "n is even". -Next we are going to run this through CamFort using the 'ast' analysis option. We can look at what functionality -is available in CamFort just by running the binary: - - cd ../.. - ./camfort - -This show us the various refactoring and analysis options. In this case, we want the "asts" option, and we don't - need to specify an output directory or any exluded files so we just using the command: - - ./camfort asts samples/tutorial - -This will generate a file 'samples/tutorail/test.f90.html' which gives a syntax highlighted pretty-printed version -of the source code where each statement can be clicked, revealing some analysis output information. -Load this up into your browser and click on the two headers for the 'if' blocks. This should reveal two boxes -marked '8' and '18' (the statement number given by the analysis). Click on 'show ast' for each. -This will reveal a highlighted syntax tree. The colours don't mean anything other than helping to separate out the -parts. Comparing the two tree fragements we should be able to see the difference between the two. - -Look in Haddock to see: - -If p SrcSpan (Expr p) (Fortran p) [(Expr p, Fortran p)] (Maybe (Fortran p)) diff --git a/Traverse.hs b/Traverse.hs deleted file mode 100644 --- a/Traverse.hs +++ /dev/null @@ -1,235 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} - -module Traverse where - -import Analysis.Annotations -import Language.Fortran - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import GHC.Generics - -import Control.Monad.Trans.Writer.Lazy - -import Data.Generics.Zipper -import Data.Generics.Aliases -import Data.Generics.Str -import Data.Generics.Uniplate.Operations - -import Language.Fortran.Lexer - -import Control.Comonad - -import Data.Data -import Data.Maybe -import Data.Monoid - -import Debug.Trace - -instance Monoid x => Monad ((,) x) where - return a = (mempty, a) - (x, a) >>= k = let (x', b) = k a - in (mappend x x', b) - - - --- Data-type generic comonad-style traversal - -extendBi :: (Biplate (from a) (to a), RComonad to) => (to a -> a) -> (from a) -> (from a) -extendBi f x = case biplate x of - (current, generate) -> generate $ strMap (rextend f) current - -reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] -reduceCollect k x = execWriter (transformBiM (\y -> do case k y of - Just x -> tell [x] - Nothing -> return () - return y) x) - --- Data-type generic comonad-style traversal with zipper (contextual traversal) - -everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a -everywhere k z = let everywhere' = enterRight . enterDown . k - - enterDown z = case (down' z) of - Just dz -> let dz' = everywhere' dz - in case (up $ dz') of - Just uz -> uz - Nothing -> dz' - Nothing -> z - - enterRight z = case (right z) of - Just rz -> let rz' = everywhere' rz - in case (left $ rz') of - Just lz -> lz - Nothing -> rz' - Nothing -> z - in everywhere' z - - -zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a) -zfmap f x = zeverywhere (mkT f) x - --- This one is less useful as the definitions for comonads are then very annoying - -extendBi' :: (Biplate (from a) (to a), Comonad to) => (to a -> a) -> (from a) -> (from a) -extendBi' f x = case biplate x of - (current, generate) -> generate $ strMap (extend f) current - -class RComonad t where - rextract :: t a -> a - rextend :: (t a -> a) -> t a -> t a - -class RFunctor t where - rfmap :: (a -> a) -> t a -> t a - - -instance RComonad Fortran where - rextract x = tag x - - rextend k y@(Assg _ sp e1 e2) = Assg (k y) sp e1 e2 - rextend k y@(For _ sp v e1 e2 e3 fs) = For (k y) sp v e1 e2 e3 (rextend k fs) - rextend k y@(FSeq _ sp f1 f2) = FSeq (k y) sp (rextend k f1) (rextend k f2) - rextend k y@(If _ sp e f1 fes f3) = let fes' = map (\(e, f) -> (e, rextend k f)) fes - f3' = case f3 of - Nothing -> Nothing - Just f3a -> Just (rextend k f3a) - in If (k y) sp e (rextend k f1) fes' f3' - rextend k y@(Allocate _ sp e1 e2) = Allocate (k y) sp e1 e2 - rextend k y@(Backspace _ sp sp') = Backspace (k y) sp sp' - rextend k y@(Call _ sp e as) = Call (k y) sp e as - rextend k y@(Open _ sp s) = Open (k y) sp s - rextend k y@(Close _ sp s) = Close (k y) sp s - rextend k y@(Continue _ sp) = Continue (k y) sp - rextend k y@(Cycle _ sp s) = Cycle (k y) sp s - rextend k y@(Deallocate _ sp es e) = Deallocate (k y) sp es e - rextend k y@(Endfile _ sp s) = Endfile (k y) sp s - rextend k y@(Exit _ sp s) = Exit (k y) sp s - rextend k y@(Forall _ sp es f) = Forall (k y) sp es (rextend k f) - rextend k y@(Goto _ sp s) = Goto (k y) sp s - rextend k y@(Nullify _ sp e) = Nullify (k y) sp e - rextend k y@(Inquire _ sp s e) = Inquire (k y) sp s e - rextend k y@(Rewind _ sp s) = Rewind (k y) sp s - rextend k y@(Stop _ sp e) = Stop (k y) sp e - rextend k y@(Where _ sp e f Nothing) = Where (k y) sp e (rextend k f) Nothing - rextend k y@(Where _ sp e f (Just f')) = Where (k y) sp e (rextend k f) (Just (rextend k f')) - rextend k y@(Write _ sp s e) = Write (k y) sp s e - rextend k y@(PointerAssg _ sp e1 e2) = PointerAssg (k y) sp e1 e2 - rextend k y@(Return _ sp e) = Return (k y) sp e - rextend k y@(Label _ sp s f) = Label (k y) sp s (rextend k f) - rextend k y@(Print _ sp e es) = Print (k y) sp e es - rextend k y@(ReadS _ sp s e) = ReadS (k y) sp s e - rextend k y@(TextStmt _ sp s) = TextStmt (k y) sp s - rextend k y@(NullStmt _ sp) = NullStmt (k y) sp - -class Refill d where - refill :: d a -> a -> d a - -instance Refill Fortran where - refill y@(Assg _ sp e1 e2) a = Assg a sp e1 e2 - refill y@(For _ sp v e1 e2 e3 fs) a = For a sp v e1 e2 e3 fs - refill y@(DoWhile _ sp e f) a = DoWhile a sp e f - refill y@(FSeq _ sp f1 f2) a = FSeq a sp f1 f2 - refill y@(If _ sp e f1 fes f3) a = If a sp e f1 fes f3 - refill y@(Allocate _ sp e1 e2) a = Allocate a sp e1 e2 - refill y@(Backspace _ sp sp') a = Backspace a sp sp' - refill y@(Call _ sp e as) a = Call a sp e as - refill y@(Open _ sp s) a = Open a sp s - refill y@(Close _ sp s) a = Close a sp s - refill y@(Continue _ sp) a = Continue a sp - refill y@(Cycle _ sp s) a = Cycle a sp s - refill y@(DataStmt _ sp p) a = DataStmt a sp p - refill y@(Deallocate _ sp es e) a = Deallocate a sp es e - refill y@(Endfile _ sp s) a = Endfile a sp s - refill y@(Exit _ sp s) a = Exit a sp s - refill y@(Forall _ sp es f) a = Forall a sp es f - refill y@(Format _ sp s) a = Format a sp s - refill y@(Goto _ sp s) a = Goto a sp s - refill y@(Nullify _ sp e) a = Nullify a sp e - refill y@(Inquire _ sp s e) a = Inquire a sp s e - refill y@(Pause _ sp s) a = Pause a sp s - refill y@(Rewind _ sp s) a = Rewind a sp s - refill y@(Stop _ sp e) a = Stop a sp e - refill y@(Where _ sp e f f') a = Where a sp e f f' - refill y@(Write _ sp s e) a = Write a sp s e - refill y@(PointerAssg _ sp e1 e2) a = PointerAssg a sp e1 e2 - refill y@(Return _ sp e) a = Return a sp e - refill y@(Label _ sp s f) a = Label a sp s f - refill y@(Print _ sp e es) a = Print a sp e es - refill y@(ReadS _ sp s e) a = ReadS a sp s e - refill y@(TextStmt _ sp s) a = TextStmt a sp s - refill y@(NullStmt _ sp) a = NullStmt a sp - - --- > instance Comonad Fortran where --- > extract x = rextract x - --- > extend k y@(Assg _ sp e1 e2) = Assg (k y) sp (fmap (k . NullStmt) e1) --- > (fmap (k . NullStmt) e2) - --- > extend k y@(For _ sp v e1 e2 e3 fs) = For (k y) sp (fmap (k . NullStmt) v) --- > (fmap (k . NullStmt) e1) --- > (fmap (k . NullStmt) e2) --- > (fmap (k . NullStmt) e3) --- > (extend k fs) - --- > extend k y@(FSeq _ sp f1 f2) = FSeq (k y) sp (extend k f1) (extend k f2) --- > extend k y@(If _ sp e f1 fes f3) = let fes' = map (\(e, f) -> (fmap (k . NullStmt) e, extend k f)) fes --- > f3' = case f3 of --- > Nothing -> Nothing --- > Just f3a -> Just (extend k f3a) --- > in If (k y) sp (fmap (k . NullStmt) e) (extend k f1) fes' f3' - --- > extend k y@(Allocate _ sp e1 e2) = Allocate (k y) sp (fmap (k . NullStmt) e1) --- > (fmap (k . NullStmt) e2) --- > extend k y@(Backspace _ sp sp') = Backspace (k y) sp (map (fmap (k . NullStmt)) sp') --- > extend k y@(Call _ sp e as) = Call (k y) sp (fmap (k . NullStmt) e) --- > (fmap (k . NullStmt) as) --- > extend k y@(Open _ sp s) = Open (k y) sp (map (fmap (k . NullStmt)) s) --- > extend k y@(Close _ sp s) = Close (k y) sp (map (fmap (k . NullStmt)) s) --- > extend k y@(Continue _ sp) = Continue (k y) sp --- > extend k y@(Cycle _ sp s) = Cycle (k y) sp s --- > extend k y@(Deallocate _ sp es e) = Deallocate (k y) sp (map (fmap (k . NullStmt)) es) (fmap (k . NullStmt) e) --- > extend k y@(Endfile _ sp s) = Endfile (k y) sp (map (fmap (k . NullStmt)) s) --- > extend k y@(Exit _ sp s) = Exit (k y) sp s --- > extend k y@(Forall _ sp (es, e) f) = let g (s, e1, e2, e3) = (s, fmap (k . NullStmt) e1, --- > fmap (k . NullStmt) e2, --- > fmap (k . NullStmt) e3) --- > in Forall (k y) sp (map g es, fmap (k . NullStmt) e) (extend k f) --- > extend k y@(Goto _ sp s) = Goto (k y) sp s --- > extend k y@(Nullify _ sp es) = Nullify (k y) sp (map (fmap (k . NullStmt)) es) --- > extend k y@(Inquire _ sp ss es) = Inquire (k y) sp (map (fmap (k . NullStmt)) ss) (map (fmap (k . NullStmt)) es) --- > extend k y@(Rewind _ sp ss) = Rewind (k y) sp (map (fmap (k . NullStmt)) ss) --- > extend k y@(Stop _ sp e) = Stop (k y) sp (fmap (k . NullStmt) e) --- > extend k y@(Where _ sp e f) = Where (k y) sp (fmap (k . NullStmt) e) (extend k f) --- > extend k y@(Write _ sp ss es) = Write (k y) sp (map (fmap (k . NullStmt)) ss) (map (fmap (k . NullStmt)) es) --- > extend k y@(PointerAssg _ sp e1 e2) = PointerAssg (k y) sp (fmap (k . NullStmt) e1) (fmap (k . NullStmt) e2) --- > extend k y@(Return _ sp e) = Return (k y) sp (fmap (k . NullStmt) e) --- > extend k y@(Label _ sp s f) = Label (k y) sp s (extend k f) --- > extend k y@(Print _ sp e es) = Print (k y) sp (fmap (k . NullStmt) e) (map (fmap (k . NullStmt)) es) --- > extend k y@(ReadS _ sp ss es) = ReadS (k y) sp (map (fmap (k . NullStmt)) ss) (map (fmap (k . NullStmt)) es) --- > extend k y@(TextStmt _ sp s) = TextStmt (k y) sp s --- > extend k y@(NullStmt _ sp) = NullStmt (k y) sp - - -annotation :: Tagged g => g a -> a -annotation = tag - diff --git a/bin/linux/camfort b/bin/linux/camfort deleted file mode 100644 # file too large to diff: bin/linux/camfort diff --git a/bin/macosx/camfort b/bin/macosx/camfort deleted file mode 100644 # file too large to diff: bin/macosx/camfort diff --git a/bin/windows/camfort.exe b/bin/windows/camfort.exe deleted file mode 100644 # file too large to diff: bin/windows/camfort.exe diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,7 +1,7 @@ name: camfort -version: 0.700 +version: 0.800 synopsis: CamFort - Cambridge Fortran infrastructure -description: CamFort is a tool for the analysis, transformation, and extension of Fortran code base. +description: CamFort is a tool for the analysis, transformation, verification of Fortran code. copyright: 2012-2016 University of Cambridge author: Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan @@ -14,39 +14,78 @@ build-type: Simple category: Language, tools -cabal-version: >= 1.6 -tested-with: GHC >= 7.4 +cabal-version: >= 1.8 +tested-with: GHC >= 7.10.1 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + build-depends: base < 5, + containers >= 0.5, + filepath >= 1.4, + directory >= 1.2, + hspec >= 2.2, + QuickCheck >= 2.8, + fortran-src >= 0.1, + uniplate >= 1.6.10, + mtl >= 2.1, + bytestring >= 0.10, + camfort + source-repository head type: git location: https://github.com/dorchard/camfort executable camfort main-is: Main.hs - hs-source-dirs: . - other-modules: Analysis.Annotations - Analysis.IntermediateReps - Analysis.LVA - Analysis.Loops - Analysis.Syntax - Analysis.Types - Extensions.UnitSyntaxConversion - Extensions.Units - Extensions.UnitsEnvironment - Extensions.UnitParser - Extensions.UnitsSolve - Extensions.UnitsSolveHMatrix - Helpers - Output - Transformation.CommonBlockElim - Transformation.CommonBlockElimToCalls - Transformation.DeadCode - Transformation.DerivedTypeIntro - Transformation.EquivalenceElim - Transformation.Syntax - Traverse + hs-source-dirs: src + other-modules: Camfort.Analysis.Annotations + Camfort.Analysis.CallGraph + Camfort.Analysis.CommentAnnotator + Camfort.Analysis.IntermediateReps + Camfort.Analysis.Loops + Camfort.Analysis.LVA + Camfort.Analysis.Syntax + Camfort.Analysis.Types + Camfort.Specification.Stencils.Annotation + Camfort.Specification.Stencils.CheckBackend + Camfort.Specification.Stencils.CheckFrontend + Camfort.Specification.Stencils.InferenceBackend + Camfort.Specification.Stencils.InferenceFrontend + Camfort.Specification.Stencils.Model + Camfort.Specification.Stencils.Syntax + Camfort.Specification.Stencils.Grammar + Camfort.Specification.Stencils.Synthesis + Camfort.Specification.Stencils + Camfort.Specification.Units + Camfort.Specification.Units.Debug + Camfort.Specification.Units.InferenceFrontend + Camfort.Specification.Units.InferenceBackend + Camfort.Specification.Units.Environment + Camfort.Specification.Units.Parser + Camfort.Specification.Units.Solve + Camfort.Specification.Units.SolveHMatrix + Camfort.Specification.Units.Strip + Camfort.Specification.Units.Synthesis + Camfort.Transformation.CommonBlockElim + Camfort.Transformation.CommonBlockElimToCalls + Camfort.Transformation.DeadCode + Camfort.Transformation.DerivedTypeIntro + Camfort.Transformation.EquivalenceElim + Camfort.Transformation.Syntax + Camfort.Helpers + Camfort.Helpers.Vec + Camfort.Functionality + Camfort.Input + Camfort.Output + Camfort.Reprint + Camfort.PrettyPrint + Camfort.Traverse + Main build-depends: base < 5, + ghc-prim == 0.4.0.0, containers >= 0.5.0.0, template-haskell >=2.4, generic-deriving >=1.5.5, @@ -57,48 +96,75 @@ syz >= 0.2, syb >= 0.4, matrix >=0.2.2, + vector >= 0.1, hmatrix >= 0.15, mtl >= 2.1, text >= 0.11.2.3, array >= 0.4, directory >= 1.2, - language-fortran >= 0.4, + language-fortran >= 0.5.1, transformers >= 0.4, - vector >= 0.1 + GenericPretty >= 1.2, + QuickCheck >= 2.8, + fortran-src >= 0.1, + filepath, + fgl >= 5.5, + bytestring >= 0.10 library - hs-source-dirs: . + hs-source-dirs: src -- ghc-options: -package mtl-2.1.3.1 build-tools: alex, happy - exposed-modules: Analysis.Annotations - Analysis.CallGraph - Analysis.IntermediateReps - Analysis.Loops - Analysis.LVA - Analysis.Syntax - Analysis.Types - Transformation.CommonBlockElim - Transformation.CommonBlockElimToCalls - Transformation.DeadCode - Transformation.DerivedTypeIntro - Transformation.EquivalenceElim - Transformation.Syntax - Extensions.UnitParser - Extensions.UnitSyntaxConversion - Extensions.Units - Extensions.UnitsEnvironment - Extensions.UnitsSolve - Extensions.UnitsSolveHMatrix - Helpers - Main - Output - Traverse + exposed-modules: Camfort.Analysis.Annotations + Camfort.Analysis.CallGraph + Camfort.Analysis.CommentAnnotator + Camfort.Analysis.IntermediateReps + Camfort.Analysis.Loops + Camfort.Analysis.LVA + Camfort.Analysis.Syntax + Camfort.Analysis.Types + Camfort.Specification.Stencils.Annotation + Camfort.Specification.Stencils.CheckBackend + Camfort.Specification.Stencils.CheckFrontend + Camfort.Specification.Stencils.InferenceBackend + Camfort.Specification.Stencils.InferenceFrontend + Camfort.Specification.Stencils.Model + Camfort.Specification.Stencils.Syntax + Camfort.Specification.Stencils.Grammar + Camfort.Specification.Stencils.Synthesis + Camfort.Specification.Stencils + Camfort.Specification.Units + Camfort.Specification.Units.Debug + Camfort.Specification.Units.InferenceFrontend + Camfort.Specification.Units.InferenceBackend + Camfort.Specification.Units.Environment + Camfort.Specification.Units.Parser + Camfort.Specification.Units.Solve + Camfort.Specification.Units.SolveHMatrix + Camfort.Specification.Units.Strip + Camfort.Specification.Units.Synthesis + Camfort.Transformation.CommonBlockElim + Camfort.Transformation.CommonBlockElimToCalls + Camfort.Transformation.DeadCode + Camfort.Transformation.DerivedTypeIntro + Camfort.Transformation.EquivalenceElim + Camfort.Transformation.Syntax + Camfort.Helpers + Camfort.Helpers.Vec + Camfort.Functionality + Camfort.Input + Camfort.Output + Camfort.Reprint + Camfort.PrettyPrint + Camfort.Traverse + other-modules: build-depends: base < 5, + ghc-prim == 0.4.0.0, containers >= 0.5.0.0, template-haskell >=2.4, generic-deriving >=1.5.5, @@ -109,11 +175,26 @@ syz >= 0.2, syb >= 0.4, matrix >=0.2.2, - hmatrix >= 0.15, + hmatrix >= 0.17.0.1, mtl >= 2.1, text >= 0.11.2.3, array >= 0.4, directory >= 1.2, - language-fortran >= 0.5, + language-fortran >= 0.5.1, transformers >= 0.4, - vector >= 0.1 + vector >= 0.1, + GenericPretty >= 1.2, + fortran-src >= 0.1, + filepath, + bytestring >= 0.10, + fgl >= 5.5 + +executable analyse + main-is: Analyse.hs + hs-source-dirs: eval + build-depends: base < 5, + array >= 0.5.1, + bytestring >= 0.10, + containers >= 0.5.0.0, + regex-base >= 0.93.2, + regex-pcre >= 0.94.4 diff --git a/dev/lapack-test.hs b/dev/lapack-test.hs deleted file mode 100644 --- a/dev/lapack-test.hs +++ /dev/null @@ -1,176 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleInstances, ImplicitParams #-} - -import Numeric.LinearAlgebra.LAPACK -import Numeric.LinearAlgebra.Algorithms -import Data.Packed.Matrix -import qualified Data.Matrix as M -import Extensions.Units -import Extensions.UnitsSolve -import Extensions.UnitsEnvironment -import Data.Ratio -import Data.List -import System.Random - -import System.IO.Unsafe -import Control.Exception - -import Debug.Trace -import Test.QuickCheck - -coeff :: Num a => [[a]] -coeff = [[1, 0, 1, 0], [0, 4, 0, 3], [0, 0, 2, 0]] - -rhs :: Num a => [a] -rhs = [1, 2, 3] - -rhs' = [[0, 1, 0], [0, 2, 0], [0, 0, 3]] - -{- Lapack -} -coeffL, rhsL :: Matrix Double -coeffL = fromLists $ coeff -rhsL = fromLists $ map (\x -> [x]) rhs -- (map (\x -> x) rhs) -solveL = linearSolveSVDR Nothing coeffL rhsL - -{- CamFort -} -coeffC :: M.Matrix Rational -coeffC = M.fromLists coeff -rhsC = map (\x -> Unitless x) rhs -linearSys = (coeffC, rhsC) -solveC = let ?solver = Custom in solveSystem linearSys - -data LSystem a = LSystem (M.Matrix a) [a] Int deriving (Show, Eq) - -instance Random (Ratio Integer) where - random g = let (n, g') = random g - (d, g'') = random g' - in (n % d, g'') - randomR (l, h) g = let (ln, hn) = (numerator l, numerator h) - (ld, hd) = (denominator l, denominator h) - (n, g') = randomR (ln, hn) g - (d, g'') = randomR (ld, hd) g' - in (n % d, g'') - -instance (Arbitrary a, Num a, Random a) => Arbitrary (LSystem a) where - -- NB: for square matrices, but row echelon form - arbitrary = sized (\n -> do m <- choose(1, n) - xs <- vectorOf (n*m) (choose (1, 20)) -- arbitrary - v <- vectorOf n (choose (1, 20)) -- arbitrary - let mx = M.matrix n m (\(i, j) -> if (i <= j) then xs !! ((i-1)*n + (j-1)) else 0) - return $ LSystem mx v n) - -{- -speedTest = do let g = (resize 40 arbitrary)::(Gen (LSystem Rational)) - lapackSolve g - camfortSolve g --} - -toLapack :: LSystem Rational -> (Matrix Double, Matrix Double) -toLapack (LSystem m v n) = (fromLists (map (map fromRational) (M.toLists $ m)), - fromLists (map (\x -> [fromRational x]) v)) --- fromLists (map (\x -> ((fromRational x) : (take (n - 1) (repeat 0)))) v)) - -fromLapack :: (Matrix Double, Matrix Double) -> [Double] -fromLapack (m, v) = map (\x -> head x) (toLists v) - -fromLapackSol :: Matrix Double -> [Double] -fromLapackSol v = map (\x -> toNearestEps $ head x) (toLists v) - -toCamfort :: LSystem Rational -> LinearSystem -toCamfort (LSystem m v n) = (m, map (\x -> Unitless x) v) - -fromCamfort :: LinearSystem -> [Double] -fromCamfort (m, v) = map (\(Unitless r) -> fromRational r) v - -fromCamfortSol :: Consistency LinearSystem -> TestResult -fromCamfortSol (Ok m) = Solved $ fromCamfort m -fromCamfortSol (Bad m _) = "Error" `trace` Solved $ fromCamfort m -- sometimes the partial result is similar - -data TestResult = Solved [Double] | Unsolved deriving Show - -lapackSolve x = unsafePerformIO $ - do x <- catch (evaluate $ (uncurry linearSolveLSR) . toLapack $ x) - (\e -> let x = (e :: SomeException) in return $ fromLists []) - if (toLists x == []) - then return Unsolved - else return $ Solved . fromLapackSol $ x - ---lapackSolve x = fromLapackSol . (uncurry linearSolveR) . toLapack $ x -camfortSolve = let ?solver = Custom in fromCamfortSol . solveSystem . toCamfort - - -class ApproxEq t where - (~~) :: t -> t -> Bool -instance ApproxEq Double where - x ~~ y = -- abs (x - y) <= 0.00001 - let x' = toNearestEps x - y' = toNearestEps y - in x' == y' -instance ApproxEq a => ApproxEq [a] where - x ~~ y = and (zipWith (~~) x y) -instance ApproxEq TestResult where - (Solved x) ~~ (Solved y) = x ~~ y - Unsolved ~~ Unsolved = True - x ~~ y = False - -convTest = quickCheck (\x -> ((fromLapack . toLapack) x) == ((fromCamfort . toCamfort) x)) -solveTest = quickCheck (\x@(LSystem _ _ n) -> if n >= 1 - then let l = lapackSolve x - c = camfortSolve x - in l ~~ c - else True) - -foo = LSystem (M.fromLists [[15 % 1, 17 % 1], - [0 % 1, 8 % 1], - [0 % 1, 0 % 1]]) [4 % 1, 5 % 1, 10 % 1] 3 - - -foo2 = LSystem (M.fromLists [[10 % 1, 2 % 1], - [0 % 1, 0 % 1]]) - [(-8) % 1,(-5) % 1] 2 - -fooExample = LSystem (M.fromLists (map (map toRational) m)) rhs 10 - where - m = [[ 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ] - , [ 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0 ] - , [ 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, -1.0, 0.0, 0.0, 0.0 ] - , [ 0.0, 0.0, 0.0, 0.0, -1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ] - , [ 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, -1.0, 0.0, 0.0 ] - , [ 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, -1.0, 0.0 ] - , [ 0.0, 0.0, -1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0 ]] - rhs = [ 0.0, 1.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 ] - -fooExample2 = linearSolveSVDR Nothing (fromLists m) (fromLists rhs) - where - m = [[ 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, 0.0, -1.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, 0.0, 0.0, -1.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, -1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0] - ,[ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2.0, 0.0, -1.0] - ,[0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, -1.0, 1.0 ]] - rhs = [[ 0.0, 0.0, 0.0] - ,[0.0, 1.0, 0.0] - ,[0.0, 0.0, 1.0] - ,[0.0, 0.0, 0.0] - ,[0.0, 0.0, 0.0] - ,[0.0, 0.0, 0.0] - ,[0.0, 0.0, 0.0] - ,[0.0, 0.0, 0.0] - ,[0.0, 0.0, 0.0 ]] diff --git a/dev/rawdata b/dev/rawdata deleted file mode 100644 --- a/dev/rawdata +++ /dev/null @@ -1,204 +0,0 @@ -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/one" - -Excluding [] from samples/booku/one/ -samples/booku/one/code11.f90 -samples/booku/one/code11.f90: Added 3 non-unitless annotation: n,n,m / s -samples/booku/one/code11.f90: checked/inferred 8 user variables - -Writing refactored files to directory: samples/bookoo/one/ -Writing samples/bookoo/one/code11.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/two" - -Excluding [] from samples/booku/two/ -samples/booku/two/code21.f90 -samples/booku/two/code210.f90 -samples/booku/two/code211.f90 -samples/booku/two/code212.f90 -samples/booku/two/code213.f90 -samples/booku/two/code214.f90 -samples/booku/two/code22.f90 -samples/booku/two/code23.f90 -samples/booku/two/code24.f90 -samples/booku/two/code25.f90 -samples/booku/two/code26.f90 -samples/booku/two/code27.f90 -samples/booku/two/code28.f90 -samples/booku/two/code29.f90 -samples/booku/two/code2a.f90 -samples/booku/two/code2b.f90 -samples/booku/two/code21.f90: Added 3 non-unitless annotation: n,n -samples/booku/two/code21.f90: checked/inferred 20 user variables -samples/booku/two/code210.f90: Added 4 non-unitless annotation: b,b,1 / b**4 -samples/booku/two/code210.f90: checked/inferred 59 user variables -samples/booku/two/code211.f90: Added 2 non-unitless annotation: i,i -samples/booku/two/code211.f90: checked/inferred 9 user variables -samples/booku/two/code212.f90: Added 2 non-unitless annotation: i,i -samples/booku/two/code212.f90: checked/inferred 12 user variables -samples/booku/two/code213.f90: Added 5 non-unitless annotation: is / ia,is,is / ih -samples/booku/two/code213.f90: checked/inferred 16 user variables -samples/booku/two/code214.f90: Added 3 non-unitless annotation: r,i,i -samples/booku/two/code214.f90: checked/inferred 17 user variables -samples/booku/two/code22.f90: Added 5 non-unitless annotation: n,n,n -samples/booku/two/code22.f90: checked/inferred 14 user variables -samples/booku/two/code23.f90: Added 0 non-unitless annotation: -samples/booku/two/code23.f90: checked/inferred 25 user variables -samples/booku/two/code24.f90: Added 1 non-unitless annotation: n -samples/booku/two/code24.f90: checked/inferred 16 user variables -samples/booku/two/code25.f90: Added 0 non-unitless annotation: -samples/booku/two/code25.f90: checked/inferred 15 user variables -samples/booku/two/code26.f90: Added 3 non-unitless annotation: a,a -samples/booku/two/code26.f90: checked/inferred 11 user variables -samples/booku/two/code27.f90: Added 5 non-unitless annotation: a,a,f / a -samples/booku/two/code27.f90: checked/inferred 15 user variables -samples/booku/two/code28.f90: Added 1 non-unitless annotation: a -samples/booku/two/code28.f90: checked/inferred 17 user variables -samples/booku/two/code29.f90: Added 3 non-unitless annotation: ro,ro,ee / ro**2 -samples/booku/two/code29.f90: checked/inferred 25 user variables -samples/booku/two/code2a.f90: Added 19 non-unitless annotation: nmax,dx,dt dx,dx,dt dx,nmax,nmax,dx,dt dx,dx,dx,dt dx,dt dx -samples/booku/two/code2a.f90: checked/inferred 24 user variables -samples/booku/two/code2b.f90: Added 7 non-unitless annotation: cb**2,ca cb,cb**2,ca / cb,ca,cb,ca -samples/booku/two/code2b.f90: checked/inferred 11 user variables - -Writing refactored files to directory: samples/bookoo/two/ -Writing samples/bookoo/two/code21.f90 -Writing samples/bookoo/two/code210.f90 -Writing samples/bookoo/two/code211.f90 -Writing samples/bookoo/two/code212.f90 -Writing samples/bookoo/two/code213.f90 -Writing samples/bookoo/two/code214.f90 -Writing samples/bookoo/two/code22.f90 -Writing samples/bookoo/two/code23.f90 -Writing samples/bookoo/two/code24.f90 -Writing samples/bookoo/two/code25.f90 -Writing samples/bookoo/two/code26.f90 -Writing samples/bookoo/two/code27.f90 -Writing samples/bookoo/two/code28.f90 -Writing samples/bookoo/two/code29.f90 -Writing samples/bookoo/two/code2a.f90 -Writing samples/bookoo/two/code2b.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/three" - -Excluding [] from samples/booku/three/ -samples/booku/three/code31.f90 -samples/booku/three/code32.f90 -samples/booku/three/code34.f90 -samples/booku/three/code3a.f90 -samples/booku/three/code3b.f90 -samples/booku/three/code3c.f90 -samples/booku/three/code31.f90: Added 3 non-unitless annotation: n,n,v -samples/booku/three/code31.f90: checked/inferred 8 user variables -samples/booku/three/code32.f90: Added 6 non-unitless annotation: 1 / w,1 / q,1 / q,1 / w,1 / q,1 / w -samples/booku/three/code32.f90: checked/inferred 33 user variables -samples/booku/three/code34.f90: Added 0 non-unitless annotation: -samples/booku/three/code34.f90: checked/inferred 21 user variables -samples/booku/three/code3a.f90: Added 1 non-unitless annotation: i -samples/booku/three/code3a.f90: checked/inferred 12 user variables -samples/booku/three/code3b.f90: Added 1 non-unitless annotation: i -samples/booku/three/code3b.f90: checked/inferred 12 user variables -samples/booku/three/code3c.f90: Added 3 non-unitless annotation: ak -samples/booku/three/code3c.f90: checked/inferred 26 user variables - -Writing refactored files to directory: samples/bookoo/three/ -Writing samples/bookoo/three/code31.f90 -Writing samples/bookoo/three/code32.f90 -Writing samples/bookoo/three/code34.f90 -Writing samples/bookoo/three/code3a.f90 -Writing samples/bookoo/three/code3b.f90 -Writing samples/bookoo/three/code3c.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/four" - -Excluding [] from samples/booku/four/ -samples/booku/four/code41.f90 -samples/booku/four/code42.f90 -samples/booku/four/code44.f90 -samples/booku/four/code45.f90 -samples/booku/four/code46.f90 -samples/booku/four/code41.f90: Added 7 non-unitless annotation: i,i,i,p,1 / p -samples/booku/four/code41.f90: checked/inferred 12 user variables -samples/booku/four/code42.f90: Added 11 non-unitless annotation: i,i,i,i,i,i,p,1 / p -samples/booku/four/code42.f90: checked/inferred 19 user variables -samples/booku/four/code44.f90: Added 12 non-unitless annotation: i,i,i,i,i,i,p,1 / p -samples/booku/four/code44.f90: checked/inferred 20 user variables -samples/booku/four/code45.f90: Added 1 non-unitless annotation: I -samples/booku/four/code45.f90: checked/inferred 7 user variables -samples/booku/four/code46.f90: Added 7 non-unitless annotation: i,i,i / r,i / a,i,r -samples/booku/four/code46.f90: checked/inferred 23 user variables - -Writing refactored files to directory: samples/bookoo/four/ -Writing samples/bookoo/four/code41.f90 -Writing samples/bookoo/four/code42.f90 -Writing samples/bookoo/four/code44.f90 -Writing samples/bookoo/four/code45.f90 -Writing samples/bookoo/four/code46.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/five" - -Excluding [] from samples/booku/five/ -samples/booku/five/code51.f90 -samples/booku/five/code52.f90 -samples/booku/five/code53.f90 -samples/booku/five/code54.f90 -samples/booku/five/code55.f90 -samples/booku/five/code51.f90: Added 1 non-unitless annotation: 1 / n -samples/booku/five/code51.f90: checked/inferred 20 user variables -samples/booku/five/code52.f90: Added 3 non-unitless annotation: a,a -samples/booku/five/code52.f90: checked/inferred 18 user variables -samples/booku/five/code53.f90: Added 5 non-unitless annotation: a,a,a -samples/booku/five/code53.f90: checked/inferred 26 user variables -samples/booku/five/code54.f90: Added 1 non-unitless annotation: l -samples/booku/five/code54.f90: checked/inferred 4 user variables -samples/booku/five/code55.f90: Added 5 non-unitless annotation: nm,nm,s,s,s -samples/booku/five/code55.f90: checked/inferred 14 user variables - -Writing refactored files to directory: samples/bookoo/five/ -Writing samples/bookoo/five/code51.f90 -Writing samples/bookoo/five/code52.f90 -Writing samples/bookoo/five/code53.f90 -Writing samples/bookoo/five/code54.f90 -Writing samples/bookoo/five/code55.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/seven" - -Excluding [] from samples/booku/seven/ -samples/booku/seven/code71.f90 -samples/booku/seven/code72.f90 -samples/booku/seven/code71.f90: Added 8 non-unitless annotation: n,x,x / h,k / x**2,h n,x -samples/booku/seven/code71.f90: checked/inferred 14 user variables -samples/booku/seven/code72.f90: Added 6 non-unitless annotation: i,i / r,i / a,i,r -samples/booku/seven/code72.f90: checked/inferred 23 user variables - -Writing refactored files to directory: samples/bookoo/seven/ -Writing samples/bookoo/seven/code71.f90 -Writing samples/bookoo/seven/code72.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/eight" - -Excluding [] from samples/booku/eight/ -samples/booku/eight/code81.f90 -samples/booku/eight/code81.f90: Added 13 non-unitless annotation: n,1 / p,1 / n p,d,n p**2,n p,1 / p,n p,n p / d,d -samples/booku/eight/code81.f90: checked/inferred 17 user variables - -Writing refactored files to directory: samples/bookoo/eight/ -Writing samples/bookoo/eight/code81.f90 -CamFort 0.615 - Cambridge Fortran Infrastructure. -Inferring units for source in directory "samples/booku/twelve" - -Excluding [] from samples/booku/twelve/ -samples/booku/twelve/code121.f90 -samples/booku/twelve/code123.f90 -samples/booku/twelve/code124.f90 -samples/booku/twelve/code121.f90: Added 0 non-unitless annotation: -samples/booku/twelve/code121.f90: checked/inferred 4 user variables -samples/booku/twelve/code123.f90: Added 0 non-unitless annotation: -samples/booku/twelve/code123.f90: checked/inferred 11 user variables -samples/booku/twelve/code124.f90: Added 5 non-unitless annotation: nx,ny,nx,1 / ny,1 / ny**2 -samples/booku/twelve/code124.f90: checked/inferred 16 user variables - -Writing refactored files to directory: samples/bookoo/twelve/ -Writing samples/bookoo/twelve/code121.f90 -Writing samples/bookoo/twelve/code123.f90 -Writing samples/bookoo/twelve/code124.f90 diff --git a/doc/units.html b/doc/units.html deleted file mode 100644 --- a/doc/units.html +++ /dev/null @@ -1,192 +0,0 @@ - - - - - - - - -

Download CamFort

- -
  • Binaries - -
  • Build from source: -
    - Download the source from GitHub. -
    Compilation requires ghc (6.3 or above). Then compile to binary via:
    - - 
    -         runhaskell Setup.hs configure
-         runhaskell Setup.hs build
-         ghc --make Main.hs -o camfort -package mtl
    -
- - - -

CamFort is in development and we would value any feedback! Please e-mail - dominic.orchard AT cl.cam.ac.uk if you have any problems.

- -

Quick guide to using units-of-measure feature of CamFort

- -More details of this tool can be found in the ICCS'15 publication. We give a quick guide to getting started here.

-Consider the following Fortran source file:

- -example.f90 -
-program example
-  implicit none
-
-  real :: x 
-  real :: t 
-  real :: v  
-
-  x = 50 
-  t = 1.3
-  v = x / t
-
-end program
-
- -CamFort can report the set of critical variables, that is, a minimal set -of variables which, if given a unit, would provide the most amount of information to -the type checker. This can be done as follows: - -
-$ camfort criticalUnits 
-
- -For example, if we are in the current directory of example.f90 we can just do: - -
-$ camfort criticalUnits .
-CamFort 0.615 - Cambridge Fortran Infrastructure.
-Infering critical variables for units inference in directory "."
-
-./iccs.f90
-./iccs.f90: Critical variables: t,x
-
- -CamFort tells us that t and x are critical variables, so we annotate -those with unit information (m (metres) for x and s (seconds) for t here):

- -example.f90 -
-program example
-  implicit none
-
-  real, unit(m) :: x 
-  real, unit(s) :: t 
-  real :: v  
-
-  x = 50 
-  t = 1.3
-  v = x / t
-
-end program
-
- -We can now ask CamFort to infer the rest of the units, which outputs to a file: - -
-$ camfort units  
-
- -For example, if we are in the current directory of example.f90 and we want to output -to a new directory 'out' then we can do: - -
-$ mkdir out
-$ camfort units . out
-CamFort 0.615 - Cambridge Fortran Infrastructure.
-Inferring units for "."
-
-./iccs.f90
-./iccs.f90: Added 1 non-unitless annotation: m / s
-./iccs.f90: checked/inferred 3 user variables
-
-Writing refactored files to directory: out/
-Writing out/iccs.f90
-
- -We see that CamFort has added one annotation:

- -out/example.f90 -
-program example
-  implicit none
-
-  real, unit(m) :: x 
-  real, unit(s) :: t 
-  real, unit(m / s) :: v  
-
-  x = 50 
-  t = 1.3
-  v = x / t
-
-end program
-
- -So now we have units for all variables. But when we want to compile using our usual compiler tool chain we need to erase these annotations. CamFort can do this as part of your build process: - -
-$ camfort removeUnits  
-
- -For example: - -
-$ mkdir src
-$ camfort removeUnits out src
-
- -Which now give us:

- -src/example.f90 -
-program example
-  implicit none
-
-  real :: x 
-  real :: t 
-  real :: v  
-
-  x = 50 
-  t = 1.3
-  v = x / t
-
-end program
-
- -We are currently in the process of allowing unit attributes to be given only as comments, -which simplifies the integration of CamFort with your existing tool chain (no need to -run the 'remove' step). - -

CamFort is in development and we would value any feedback! Please e-mail - dominic.orchard AT cl.cam.ac.uk if you have any problems. -More details of our project can be found here.

- - - -
-
- Last modified: Tue Jun 2 13:28:15 GMT 2015 - diff --git a/eval/Analyse.hs b/eval/Analyse.hs new file mode 100644 --- /dev/null +++ b/eval/Analyse.hs @@ -0,0 +1,299 @@ +import Text.Printf (printf) +import Text.Regex.PCRE ((=~)) +import Text.Regex.Base +import System.Environment +import qualified Data.ByteString.Char8 as S +import Data.Maybe +import Data.List (unfoldr, groupBy, foldl', nub) +import Data.Function (on) +import Data.Array +import qualified Data.Map as M +import Control.Monad + +varKeywords = [ "readOnce", "reflexive", "irreflexive", "forward", "backward", "centered", "atLeast", "atMost" ] +spanKeywords = [ "tickAssign", "LHSnotHandled", "nonNeighbour", "emptySpec", "inconsistentIV", "relativized" ] + +dimName :: Int -> String +dimName n = "dims"++show n +depthName :: Int -> String +depthName n = "depth"++show n +regionOpsName :: Int -> String +regionOpsName n = "regionOps"++ show n +plusOpsName :: Int -> String +plusOpsName n = "plusOps" ++ show n +mulOpsName :: Int -> String +mulOpsName n = "mulOps" ++ show n +dimDistName :: Int -> String +dimDistName n = "dimDist" ++ show n +dimTagName :: Int -> String +dimTagName n = "dimTag" ++ show n + +type Analysis = M.Map String Int +type ModAnalysis = M.Map String Analysis + +-- Alongside countBySpan, also do some counts grouped by spans and variables. +countByVars :: Analysis -> S.ByteString -> Analysis +countByVars a l = M.unionsWith (+) $ [a, keysA] ++ map snd (filter fst counts) + where + counts = [ ((get a "atLeast" > 0 && get keysA "atMost" > 0) || + (get keysA "atLeast" > 0 && get a "atMost" > 0), {- ==> -} M.singleton "boundedBoth" n) + , ( get keysA "reflexive" > 0 && + M.size keysA == 1 , {- ==> -} M.singleton "justReflexive" n ) + , ( ndims > 0 , {- ==> -} M.singleton (dimName ndims) n) + , ( isJust mdep , {- ==> -} M.singleton (depthName (fromJust mdep)) n) + , ( regOps >= 0 && isSten , {- ==> -} M.singleton (regionOpsName regOps) n) + , ( plusOps >= 0 && isSten , {- ==> -} M.singleton (plusOpsName plusOps) n) + , ( mulOps >= 0 && isSten , {- ==> -} M.singleton (mulOpsName mulOps) n) + , ( dimDist > 0 && isSten , {- ==> -} M.singleton (dimDistName dimDist) n) + ] + keysA = M.fromList [ (k, n) | k <- varKeywords, l =~ re k ] -- try each keyword + re k = "[^A-Za-z]" ++ k ++ "[^A-Za-z]" -- form a regular expression from a keyword + get m k = 0 `fromMaybe` M.lookup k m -- convenience function + n = numVars l -- note that this will treat an EVALMODE line as having 1 variable + ndims = numDims l + mdep = depth l + regOps = countRegionOps l + plusOps = countPlusOps l + mulOps = countMulOps l + dimDist = countDimDist l + isSten = l =~ "\\)[[:space:]]*stencil " + +-- Count interesting stuff in a given line, and given the group's +-- analysis to this point, grouped by span. +countBySpan :: Analysis -> S.ByteString -> Analysis +countBySpan a l = M.unionsWith (+) $ [a, keysA] ++ map snd (filter fst counts) + where + counts = [ ( l =~ "stencil " , {- ==> -} M.fromList [("numStencilLines", 1), + ("numStencilSpecs", n)] ) + , ( get a "numStencilSpecs" > 0 && + get keysA "tickAssign" > 0 , {- ==> -} M.singleton "tickAssignSuccess" 1 ) + , ( isJust mDimTag , {- ==> -} M.singleton (dimTagName (fromJust mDimTag)) n) + ] + keysA = M.fromList [ (k, n) | k <- spanKeywords, l =~ re k ] -- try each keyword + re k = "[^A-Za-z]" ++ k ++ "[^A-Za-z]" -- form a regular expression from a keyword + get m k = 0 `fromMaybe` M.lookup k m -- convenience function + n = numVars l -- note that this will treat an EVALMODE line as having 1 variable + mDimTag = countDimTag l + +-- Look at each group that shares a source span, then each group that shares a source span and vars. +eachGroup :: [S.ByteString] -> Analysis +eachGroup g = M.unionsWith (+) $ a':map (foldl' countByVars M.empty) gbv + where + a' = foldl' countBySpan M.empty g + gbv = groupBy ((==) `on` vars) (filter (not . S.null . vars) g) + +-- Group by source span and variable in order to group multiple lines +-- that happen to pertain to the same expression (e.g. for boundedBoth). +analyseExec :: [S.ByteString] -> ModAnalysis +analyseExec [] = M.empty +analyseExec (e1:es) + | any (=~ "Lexing failed") es = M.singleton modName . M.fromList $ [("lexFailed", 1), ("lexOrParseFailed", 1)] ++ linesTotal + | any (=~ "Parsing failed") es = M.singleton modName . M.fromList $ [("parseFailed", 1), ("lexOrParseFailed", 1)] ++ linesTotal + | otherwise = M.singleton modName . M.unionsWith (+) . (parseOk:) . map eachGroup $ gs + where + gs = groupBy ((==) `on` srcSpan) . filter (=~ "\\)[[:space:]]*(stencil|EVALMODE)") $ es + modName = drop 4 . S.unpack . (=~ "MOD=([^ ]*)") $ e1 + lineCount = msum (es >>= map (fmap fst . S.readInt) . mrSubList . (=~ "LineCount: ([0-9]*)")) + linesTotal = case lineCount of Just n -> [("linesTotal", n)]; _ -> [] + parseOk = M.fromList (("parseOk", 1):(case lineCount of Just n -> [("linesParsed", n)]; _ -> []) ++ linesTotal) + +-- helper functions +srcSpan :: S.ByteString -> S.ByteString +srcSpan = (=~ "^\\([^[:space:]]*\\)") +vars :: S.ByteString -> S.ByteString +vars = (=~ ":: .*$") +srcSpanAndVars l1 l2 = srcSpan l1 == srcSpan l2 && vars l1 == vars l2 +numVars = (1 +) . S.length . S.filter (== ',') . vars +numDims :: S.ByteString -> Int +numDims s + | S.null match = 0 + | otherwise = (1 +) . S.length . S.filter (== ',') $ match + where + match = s =~ "\\(dims=[^\\)]*\\)" +depth :: S.ByteString -> Maybe Int +depth = fmap fst . S.readInt . S.concat . mrSubList . (=~ "depth=([0-9]*)") +countRegionOps :: S.ByteString -> Int +countRegionOps = S.length . S.filter (`elem` "+*") +countMulOps :: S.ByteString -> Int +countMulOps = S.length . S.filter (`elem` "*") +countPlusOps :: S.ByteString -> Int +countPlusOps = S.length . S.filter (`elem` "+") +countDimDist :: S.ByteString -> Int +countDimDist l = length . nub . filter (>0) $ (dimList ++ dimsList) + where + matchToInt = fromMaybe 0 . fmap fst . S.readInt + -- search for "dim=n" + dimList = map (matchToInt . (! 1)) (getAllTextMatches (l =~ "dim=([0-9]*)" :: AllTextMatches [] (Array Int S.ByteString))) + -- search for "(dims=n,n,...)" + dimsList = map matchToInt . concatMap (S.split ',') . mrSubList $ l =~ "\\(dims=([^\\)]*)\\)" +countDimTag :: S.ByteString -> Maybe Int +countDimTag = fmap fst . S.readInt . S.concat . mrSubList . (=~ "dimensionality=([0-9]*)") + +-- Extract one set of text that occurs between "%%% begin" and "%%% end", +-- returning the remainder if present. +oneExec :: [S.ByteString] -> Maybe ([S.ByteString], [S.ByteString]) +oneExec ls + | null b = Nothing + | otherwise = Just (e, b) + where + a = dropWhile (not . (=~ "^%%% begin stencils-infer")) ls + (e, b) = break (=~ "^%%% end stencils-infer") a + +prettyOutput :: ModAnalysis -> String +prettyOutput = unlines . prettyOutput' +prettyOutput' :: ModAnalysis -> [String] +prettyOutput' ma = concat [ ("corpus module: " ++ m):map (replicate 4 ' ' ++) (prettyAnal a) | (m, a) <- M.toList ma ] ++ + ( "overall":map (replicate 4 ' ' ++) (prettyAnal combined) ) ++ + ( map (replicate 4 ' '++) [ + printf "numStencilSpecs (%d) <= forward (%d) + backward (%d) + centered (%d) + reflexive (%d) = %d" + numStencilSpecs forward backward centered reflexive numSpeced + ] ) + where + combined = M.unionsWith (+) $ M.elems ma + get = fromMaybe 0 . flip M.lookup combined + numStencilSpecs = get "numStencilSpecs" + forward = get "forward" + backward = get "backward" + centered = get "centered" + reflexive = get "reflexive" + numSpeced = forward + backward + centered + reflexive +prettyAnal a = [ k ++ ": " ++ show v | (k, v) <- M.toList a ] + + +main :: IO () +main = do + input <- S.getContents + let ls = S.lines input + let execs = unfoldr oneExec ls + let ma = M.unionsWith (M.unionWith (+)) $ map analyseExec execs + args <- getArgs + case args of + "-R":_ -> print ma + _ -> putStrLn . prettyOutput $ ma + return () + +runTest = M.unionsWith (M.unionWith (+)) . map analyseExec . unfoldr oneExec + +test0 = map S.pack [ + "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\"" + , "CamFort 0.775 - Cambridge Fortran Infrastructure." + , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f\"" + , "" + , "Output of the analysis:" + , "((38,9),(38,32)) stencil readOnce, reflexive(dims=1) :: real" + , "((38,9),(38,32)) EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)" + , "((42,9),(42,32)) stencil readOnce, reflexive :: x" + , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\"" + ] + +test1 = map S.pack [ + "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\"" + , "CamFort 0.775 - Cambridge Fortran Infrastructure." + , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f\"" + , "" + , "Output of the analysis:" + , "((38,9),(38,32)) stencil readOnce, reflexive(dims=1) :: real" + , "((38,9),(38,32)) EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)" + , "((44,11),(44,23)) stencil readOnce, reflexive(dims=1) :: u" + , "((51,12),(51,54)) stencil readOnce, reflexive(dims=1) :: real, v" + , "((51,12),(51,54)) EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)" + , "((56,12),(56,22)) stencil readOnce, reflexive(dims=1) :: v" + , "((70,9),(70,34)) stencil readOnce, irreflexive(dims=1), (backward(depth=1, dim=1)) :: c" + , "((70,9),(70,34)) stencil readOnce, reflexive(dims=1) :: d" + , "((71,9),(71,34)) stencil readOnce, (backward(depth=1, dim=1)) :: b" + , "((75,9),(75,40)) stencil readOnce, reflexive(dims=1) :: b, c, d, e" + , "((75,9),(75,40)) stencil readOnce, irreflexive(dims=1), (forward(depth=1, dim=1)) :: x" + , "" + , "0.14user 0.00system 0:00.15elapsed 98%CPU (0avgtext+0avgdata 20616maxresident)k" + , "0inputs+8outputs (0major+1395minor)pagefaults 0swaps" + , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\"" + , "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f90\"" + , "CamFort 0.775 - Cambridge Fortran Infrastructure." + , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f90\"" + , "" + , "Output of the analysis:" + , "" + , "0.10user 0.00system 0:00.11elapsed 96%CPU (0avgtext+0avgdata 20908maxresident)k" + , "0inputs+8outputs (0major+1510minor)pagefaults 0swaps" + , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f90\"" + , "%%% begin stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\"" + , "LineCount: 155" + , "StartTime: 2016-06-24 11:23:44+01:00" + , "CamFort 0.775 - Cambridge Fortran Infrastructure." + , "Inferring stencil specs for \"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\"" + , "" + , "Output of the analysis:" + , "" + , "/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90" + , "((108,3),(108,60)) stencil readOnce, reflexive(dims=2) :: offset_map" + , "((108,3),(108,60)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((109,3),(110,37)) stencil readOnce, reflexive(dims=2) :: offset_map, size_map" + , "((109,3),(110,37)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((111,3),(112,55)) stencil readOnce, reflexive(dims=1) :: grid_row_end, grid_row_start" + , "((111,3),(112,55)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((130,3),(130,41)) stencil reflexive(dims=2) :: size_map" + , "((130,3),(130,41)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((136,3),(136,37)) stencil reflexive(dims=2) :: size_map" + , "((136,3),(136,37)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((137,3),(138,59)) stencil readOnce, reflexive(dims=1) :: grid_point_end, grid_point_start" + , "((137,3),(138,59)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((139,24),(141,48)) stencil readOnce, irreflexive(dims=1,2,3), (reflexive(dim=1))*(centered(depth=1, dim=2)) + (reflexive(dim=2))*(centered(depth=1, dim=1)) :: p" + , "((139,24),(141,48)) stencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: rhs" + , "((147,7),(147,78)) EVALMODE: LHS is an array subscript we can't handle (tag: LHSnotHandled)" + , "((148,10),(148,68)) EVALMODE: dimensionality=1" + , "" + , "1.33user 0.04system 0:02.08elapsed 66%CPU (0avgtext+0avgdata 75672maxresident)k" + , "0inputs+0outputs (0major+15984minor)pagefaults 0swaps" + , "EndTime: 2016-06-24 11:23:46+01:00" + , "%%% end stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\"" + ] + +test2 = map S.pack [ + "%%% begin stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\"" + , "LineCount: 210" + , "StartTime: 2016-06-24 12:28:13+01:00" + , "Progress: 46 / 2533" + , "CamFort 0.775 - Cambridge Fortran Infrastructure." + , "Inferring stencil specs for \"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\"" + , "" + , "Output of the analysis:" + , "" + , "/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90" + , "((126,5),(126,18)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((131,9),(131,66)) stencil readOnce, reflexive(dims=1,2) :: q, wqsat" + , "((131,9),(131,66)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((132,9),(132,36)) stencil reflexive(dims=1,2) :: ocf" + , "((132,9),(132,36)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((136,9),(136,42)) stencil readOnce, reflexive(dims=1,2) :: q, wqsat" + , "((136,9),(136,42)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((137,9),(137,42)) stencil readOnce, reflexive(dims=1,2) :: ocf" + , "((137,9),(137,42)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((146,9),(146,22)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((148,9),(148,22)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((195,5),(195,19)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((196,5),(196,19)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((199,7),(199,20)) stencil reflexive(dims=1,2) :: ocf" + , "((199,7),(199,20)) stencil readOnce, reflexive(dims=1,2) :: q" + , "((199,7),(199,20)) stencil reflexive(dims=1,2) :: t, wqsat" + , "((199,7),(199,20)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((201,7),(201,20)) stencil reflexive(dims=1,2) :: ocf" + , "((201,7),(201,20)) stencil readOnce, reflexive(dims=1,2) :: q" + , "((201,7),(201,20)) stencil reflexive(dims=1,2) :: t, wqsat" + , "((201,7),(201,20)) EVALMODE: assign to relative array subscript (tag: tickAssign)" + , "((275,11),(275,54)) stencil atLeast, readOnce, reflexive(dims=1,2,3) :: p" + , "((275,11),(275,54)) stencil atMost, readOnce, (forward(depth=2, dim=3)) :: p" + , "" + , "1.23user 0.03system 0:01.83elapsed 69%CPU (0avgtext+0avgdata 76092maxresident)k" + , "0inputs+0outputs (0major+15975minor)pagefaults 0swaps" + , "EndTime: 2016-06-24 12:28:15+01:00" + , "%%% end stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\"" + ] + +test2out = M.fromList [("um",M.fromList [("atLeast",1),("atMost",1),("boundedBoth",1),("depth2",1),("dims2",14),("dims3",1),("forward",1),("justReflexive",7),("numStencilLines",12),("numStencilSpecs",16),("parseOk",1),("readOnce",9),("reflexive",15),("tickAssign",11),("tickAssignSuccess",6)])] + +runTests = do + print $ runTest test2 == test2out + +-- Local variables: +-- mode: haskell +-- End: diff --git a/notes b/notes deleted file mode 100644 --- a/notes +++ /dev/null @@ -1,5 +0,0 @@ -Profiling build - -ghc -O2 -o camfort -rtsopts Main.lhs -osuf p_o -hisuf p_hi -package mtl-2.1.3.1 -prof -fprof-auto - -Profiling run on units diff --git a/samples/book/eight/code81.f90 b/samples/book/eight/code81.f90 deleted file mode 100644 --- a/samples/book/eight/code81.f90 +++ /dev/null @@ -1,66 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 8.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM GALERKIN -! -! This program solves the one-dimensional Poisson equation with the -! Galerkin method as described in the text. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=99 - INTEGER :: I - REAL :: PI,XL,H,D,E,B0,B1,XIM,XI,XIP - REAL, DIMENSION (N) :: B,A,Y,W,U -! - PI = 4.0*ATAN(1.0) - XL = 1.0 - H = XL/(N+1) - D = 2.0/H - E = -1.0/H - B0 = PI/H - B1 = 1.0/H -! -! Find the elements in L and U -! - W(1) = D - U(1) = E/D - DO I = 2, N - W(I) = D-E*U(I-1) - U(I) = E/W(I) - END DO -! -! Assign the array B -! - DO I = 1, N - XIM = H*(I-1) - XI = H*I - XIP = H*(I+1) - B(I) = B0*COS(PI*XI)*(XIM+XIP-2.0*XI) & - +B1*(2.0*SIN(PI*XI)-SIN(PI*XIM)-SIN(PI*XIP)) - END DO -! -! Find the solution -! - Y(1) = B(1)/W(1) - DO I = 2, N - Y(I) = (B(I)-E*Y(I-1))/W(I) - END DO -! - A(N) = Y(N) - DO I = N-1,1,-1 - A(I) = Y(I)-U(I)*A(I+1) - END DO -! - WRITE (6,"(2F16.8)") (I*H,A(I), I=1,N) -END PROGRAM GALERKIN diff --git a/samples/book/five/code51.f90 b/samples/book/five/code51.f90 deleted file mode 100644 --- a/samples/book/five/code51.f90 +++ /dev/null @@ -1,81 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM DFT_EXAMPLE -! -! Example of the discrete Fourier transform with function f(x) = -! x(1-x) in [0,1]. The inverse transform is also performed for -! comparison. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=128,M=8 - INTEGER :: I - REAL :: F0,H,X - REAL, DIMENSION (N) :: FR,FI,GR,GI -! - F0 = 1.0/SQRT(FLOAT(N)) - H = 1.0/(N-1) -! - DO I = 1, N - X = H*(I-1) - FR(I) = X*(1.0-X) - FI(I) = 0.0 - END DO -! - CALL DFT (FR,FI,GR,GI,N) - DO I = 1, N - GR(I) = F0*GR(I) - GI(I) = F0*GI(I) - END DO -! -! Perform inverse Fourier transform -! - DO I = 1, N - GI(I) = -GI(I) - END DO - CALL DFT (GR,GI,FR,FI,N) - DO I = 1, N - FR(I) = F0*FR(I) - FI(I) = -F0*FI(I) - END DO - WRITE (6,"(2F16.8)") (H*(I-1),FR(I),I=1,N,M) - WRITE (6,"(2F16.8)") H*(N-1),FR(N) -END PROGRAM DFT_EXAMPLE -! -SUBROUTINE DFT (FR,FI,GR,GI,N) -! -! Subroutine to perform the discrete Fourier transform with -! FR and FI as the real and imaginary parts of the input and -! GR and GI as the corresponding output. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J - REAL :: PI,X,Q - REAL, INTENT (IN), DIMENSION (N) :: FR,FI - REAL, INTENT (OUT), DIMENSION (N) :: GR,GI -! - PI = 4.0*ATAN(1.0) - X = 2*PI/N -! - DO I = 1, N - GR(I) = 0.0 - GI(I) = 0.0 - DO J = 1, N - Q = X*(J-1)*(I-1) - GR(I) = GR(I)+FR(J)*COS(Q)+FI(J)*SIN(Q) - GI(I) = GI(I)+FI(J)*COS(Q)-FR(J)*SIN(Q) - END DO - END DO -END SUBROUTINE DFT diff --git a/samples/book/five/code52.f90 b/samples/book/five/code52.f90 deleted file mode 100644 --- a/samples/book/five/code52.f90 +++ /dev/null @@ -1,76 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - SUBROUTINE FFT (AR,AI,N,M) -! -! An example of the fast Fourier transform subroutine with N = 2**M. -! AR and AI are the real and imaginary part of data in the input and -! corresponding Fourier coefficients in the output. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: N1,N2,I,J,K,L,L1,L2 - REAL :: PI,A1,A2,Q,U,V - REAL, INTENT (INOUT), DIMENSION (N) :: AR,AI -! - PI = 4.0*ATAN(1.0) - N2 = N/2 -! - N1 = 2**M - IF(N1.NE.N) STOP 'Indices do not match' -! -! Rearrange the data to the bit reversed order -! - L = 1 - DO K = 1, N-1 - IF (K.LT.L) THEN - A1 = AR(L) - A2 = AI(L) - AR(L) = AR(K) - AR(K) = A1 - AI(L) = AI(K) - AI(K) = A2 - END IF - J = N2 - DO WHILE (J.LT.L) - L = L-J - J = J/2 - END DO - L = L+J - END DO -! -! Perform additions at all levels with reordered data -! - L2 = 1 - DO L = 1, M - Q = 0.0 - L1 = L2 - L2 = 2*L1 - DO K = 1, L1 - U = COS(Q) - V = -SIN(Q) - Q = Q + PI/L1 - DO J = K, N, L2 - I = J + L1 - A1 = AR(I)*U-AI(I)*V - A2 = AR(I)*V+AI(I)*U - AR(I) = AR(J)-A1 - AR(J) = AR(J)+A1 - AI(I) = AI(J)-A2 - AI(J) = AI(J)+A2 - END DO - END DO - END DO -END SUBROUTINE FFT diff --git a/samples/book/five/code53.f90 b/samples/book/five/code53.f90 deleted file mode 100644 --- a/samples/book/five/code53.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE FFT2D (FR,FI,N1,N2,M1,M2) -! -! Subroutine for the two-dimensional fast Fourier transform -! with N=N1*N2 and N1=2**M1 and N2=2**M2. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N1,N2,M1,M2 - INTEGER :: I,J - REAL, INTENT (INOUT), DIMENSION (N1,N2) :: FR,FI -! -! Transformation on the second index -! - DO I = 1, N1 - CALL FFT (FR(I,1),FI(I,1),N2,M2) - END DO -! -! Transformation on the first index -! - DO J = 1, N2 - CALL FFT (FR(1,J),FI(1,J),N1,M1) - END DO -END SUBROUTINE FFT2D -! - SUBROUTINE FFT (AR,AI,N,M) -! -! An example of the fast Fourier transform subroutine with N = 2**M. -! AR and AI are the real and imaginary part of data in the input and -! corresponding Fourier coefficients in the output. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: N1,N2,I,J,K,L,L1,L2 - REAL :: PI,A1,A2,Q,U,V - REAL, INTENT (INOUT), DIMENSION (N) :: AR,AI -! - PI = 4.0*ATAN(1.0) - N2 = N/2 -! - N1 = 2**M - IF(N1.NE.N) STOP 'Indices do not match' -! -! Rearrange the data to the bit reversed order -! - L = 1 - DO K = 1, N-1 - IF (K.LT.L) THEN - A1 = AR(L) - A2 = AI(L) - AR(L) = AR(K) - AR(K) = A1 - AI(L) = AI(K) - AI(K) = A2 - END IF - J = N2 - DO WHILE (J.LT.L) - L = L-J - J = J/2 - END DO - L = L+J - END DO -! -! Perform additions at all levels with reordered data -! - L2 = 1 - DO L = 1, M - Q = 0.0 - L1 = L2 - L2 = 2*L1 - DO K = 1, L1 - U = COS(Q) - V = -SIN(Q) - Q = Q + PI/L1 - DO J = K, N, L2 - I = J + L1 - A1 = AR(I)*U-AI(I)*V - A2 = AR(I)*V+AI(I)*U - AR(I) = AR(J)-A1 - AR(J) = AR(J)+A1 - AI(I) = AI(J)-A2 - AI(J) = AI(J)+A2 - END DO - END DO - END DO -END SUBROUTINE FFT diff --git a/samples/book/five/code54.f90 b/samples/book/five/code54.f90 deleted file mode 100644 --- a/samples/book/five/code54.f90 +++ /dev/null @@ -1,31 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE LGND (LMAX,X,P) -! -! Subroutine to generate Legendre polynomials P_L(X) -! for L = 0,1,...,LMAX with given X. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: LMAX - INTEGER :: L - REAL, INTENT (IN) :: X - REAL, INTENT (OUT), DIMENSION (0:LMAX) :: P -! - P(0) = 1.0 - P(1) = X - DO L = 1, LMAX-1 - P(L+1) = ((2.0*L+1)*X*P(L)-L*P(L-1))/(L+1) - END DO -END SUBROUTINE LGND diff --git a/samples/book/five/code55.f90 b/samples/book/five/code55.f90 deleted file mode 100644 --- a/samples/book/five/code55.f90 +++ /dev/null @@ -1,60 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE BSSL (BJ,BY,N,X) -! -! Subroutine to generate J_n(x) and Y_n(x) with given x and -! up to N=NMAX-NTEL. -! - INTEGER, PARAMETER :: NMAX=30,NTEL=5 - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K - REAL, INTENT (IN) :: X - REAL :: PI,GAMMA,SUM,SUM1 - REAL, INTENT (OUT), DIMENSION (0:N) :: BJ,BY - REAL, DIMENSION (0:NMAX) :: B1 -! - PI = 4.0*ATAN(1.0) - GAMMA = 0.5772156649 -! - B1(NMAX) = 0.0 - B1(NMAX-1) = 1.0 -! -! Generating J_n(x) -! - SUM = 0.0 - DO I = NMAX-1, 1, -1 - B1(I-1) = 2*I*B1(I)/X-B1(I+1) - IF (MOD(I,2).EQ.0) SUM = SUM+2.0*B1(I) - END DO - SUM = SUM+B1(0) -! - DO I = 0, N - BJ(I) = B1(I)/SUM - END DO -! -! Generating Y_n(x) starts here -! - SUM1 = 0.0 - DO K = 1, NMAX/2 - SUM1 = SUM1+(-1)**K*B1(2*K)/K - END DO -! - SUM1 = -4.0*SUM1/(PI*SUM) - BY(0) = 2.0*(ALOG(X/2.0)+GAMMA)*BJ(0)/PI+SUM1 - BY(1) = (BJ(1)*BY(0)-2.0/(PI*X))/BJ(0) - DO I = 1, N-1 - BY(I+1) = 2*I*BY(I)/X-BY(I-1) - END DO -END SUBROUTINE BSSL diff --git a/samples/book/five/code5a.f90 b/samples/book/five/code5a.f90 deleted file mode 100644 --- a/samples/book/five/code5a.f90 +++ /dev/null @@ -1,160 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.A !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CB - REAL :: Q,B,W -END MODULE CB -! -PROGRAM PENDULUM -! -! Program for the power spectra of a driven pendulum under damping with -! the fourth order Runge-Kutta algorithm. Given parameters: Q, B, and W -! (omega_0). Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - INTEGER, PARAMETER :: N=65536,L=128,M=16,MD=16 - INTEGER :: I,J - REAL :: PI,F1,H,OD,T,Y1,Y2,G1,GX1,G2,GX2 - REAL :: DK11,DK21,DK12,DK22,DK13,DK23,DK14,DK24 - REAL, DIMENSION (N) :: AR,AI,WR,WI,O - REAL, DIMENSION (2,N) :: Y - -! - PI = 4.0*ATAN(1.0) - F1 = 1.0/SQRT(FLOAT(N)) - W = 2.0/3.0 - H = 2.0*PI/(L*W) - OD = 2.0*PI/(N*H*W*W) - Q = 0.5 - B = 1.15 - Y(1,1) = 0.0 - Y(2,1) = 2.0 -! -! Runge-Kutta algorithm to integrate the equation -! - DO I = 1, N-1 - T = H*I - Y1 = Y(1,I) - Y2 = Y(2,I) - DK11 = H*GX1(Y1,Y2,T) - DK21 = H*GX2(Y1,Y2,T) - DK12 = H*GX1((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK22 = H*GX2((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK13 = H*GX1((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK23 = H*GX2((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK14 = H*GX1((Y1+DK13),(Y2+DK23),(T+H)) - DK24 = H*GX2((Y1+DK13),(Y2+DK23),(T+H)) - Y(1,I+1) = Y(1,I)+(DK11+2.0*(DK12+DK13)+DK14)/6.0 - Y(2,I+1) = Y(2,I)+(DK21+2.0*(DK22+DK23)+DK24)/6.0 -! -! Bring theta back to region [-pi,pi] -! - IF (ABS(Y(1,I+1)).GT.PI) THEN - Y(1,I+1) = Y(1,I+1) - 2.*PI*ABS(Y(1,I+1))/Y(1,I+1) - END IF - END DO -! - DO I = 1, N - AR(I) = Y(1,I) - WR(I) = Y(2,I) - AI(I) = 0.0 - WI(I) = 0.0 - END DO - CALL FFT (AR,AI,N,M) - CALL FFT (WR,WI,N,M) -! - DO I = 1, N - O(I) = (I-1)*OD - AR(I) = (F1*AR(I))**2+(F1*AI(I))**2 - WR(I) = (F1*WR(I))**2+(F1*WI(I))**2 - AR(I) = ALOG10(AR(I)) - WR(I) = ALOG10(WR(I)) - END DO - WRITE(6,"(3F16.10)") (O(I),AR(I),WR(I),I=1,(L*MD),4) -END PROGRAM PENDULUM -! - SUBROUTINE FFT (AR,AI,N,M) -! -! An example of the fast Fourier transform subroutine with N = 2**M. -! AR and AI are the real and imaginary part of data in the input and -! corresponding Fourier coefficients in the output. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: N1,N2,I,J,K,L,L1,L2 - REAL :: PI,A1,A2,Q,U,V - REAL, INTENT (INOUT), DIMENSION (N) :: AR,AI -! - PI = 4.0*ATAN(1.0) - N2 = N/2 -! - N1 = 2**M - IF(N1.NE.N) STOP 'Indices do not match' -! -! Rearrange the data to the bit reversed order -! - L = 1 - DO K = 1, N-1 - IF (K.LT.L) THEN - A1 = AR(L) - A2 = AI(L) - AR(L) = AR(K) - AR(K) = A1 - AI(L) = AI(K) - AI(K) = A2 - END IF - J = N2 - DO WHILE (J.LT.L) - L = L-J - J = J/2 - END DO - L = L+J - END DO -! -! Perform additions at all levels with reordered data -! - L2 = 1 - DO L = 1, M - Q = 0.0 - L1 = L2 - L2 = 2*L1 - DO K = 1, L1 - U = COS(Q) - V = -SIN(Q) - Q = Q + PI/L1 - DO J = K, N, L2 - I = J + L1 - A1 = AR(I)*U-AI(I)*V - A2 = AR(I)*V+AI(I)*U - AR(I) = AR(J)-A1 - AR(J) = AR(J)+A1 - AI(I) = AI(J)-A2 - AI(J) = AI(J)+A2 - END DO - END DO - END DO -END SUBROUTINE FFT -! -FUNCTION GX1 (Y1,Y2,T) RESULT (G1) -! - G1 = Y2 -END FUNCTION GX1 -! -FUNCTION GX2 (Y1,Y2,T) RESULT (G2) - USE CB -! - G2 = -Q*Y2-SIN(Y1)+B*COS(W*T) -END FUNCTION GX2 diff --git a/samples/book/four/code41.f90 b/samples/book/four/code41.f90 deleted file mode 100644 --- a/samples/book/four/code41.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL :: C1,PI,PI1,PJ - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/book/four/code42.f90 b/samples/book/four/code42.f90 deleted file mode 100644 --- a/samples/book/four/code42.f90 +++ /dev/null @@ -1,112 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE DTRM (A,N,D,INDX) -! -! Subroutine for evaluating the determinant of a matrix using -! the partial-pivoting Gaussian elimination scheme. -! Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,MSGN - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, INTENT (OUT) :: D - REAL, INTENT (INOUT), DIMENSION (N,N) :: A -! - CALL ELGS(A,N,INDX) -! - D = 1.0 - DO I = 1, N - D = D*A(INDX(I),I) - END DO -! - MSGN = 1 - DO I = 1, N - DO WHILE (I.NE.INDX(I)) - MSGN = -MSGN - J = INDX(I) - INDX(I) = INDX(J) - INDX(J) = J - END DO - END DO - D = MSGN*D -END SUBROUTINE DTRM -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL :: C1,PI,PI1,PJ - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/book/four/code44.f90 b/samples/book/four/code44.f90 deleted file mode 100644 --- a/samples/book/four/code44.f90 +++ /dev/null @@ -1,124 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE MIGS (A,N,X,INDX) -! -! Subroutine to invert matrix A(N,N) with the inverse stored -! in X(N,N) in the output. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, INTENT (IN), DIMENSION (N,N):: A - REAL, INTENT (OUT), DIMENSION (N,N):: X - REAL, DIMENSION (N,N) :: B -! - DO I = 1, N - DO J = 1, N - B(I,J) = 0.0 - END DO - END DO - DO I = 1, N - B(I,I) = 1.0 - END DO -! - CALL ELGS (A,N,INDX) -! - DO I = 1, N-1 - DO J = I+1, N - DO K = 1, N - B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K) - END DO - END DO - END DO -! - DO I = 1, N - X(N,I) = B(INDX(N),I)/A(INDX(N),N) - DO J = N-1, 1, -1 - X(J,I) = B(INDX(J),I) - DO K = J+1, N - X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I) - END DO - X(J,I) = X(J,I)/A(INDX(J),J) - END DO - END DO -END SUBROUTINE MIGS -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL :: C1,PI,PI1,PJ - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/book/four/code45.f90 b/samples/book/four/code45.f90 deleted file mode 100644 --- a/samples/book/four/code45.f90 +++ /dev/null @@ -1,37 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE TDPL(A,B,N,X,P) -! -! Subroutine to generate determinant polynomial P_N(X). -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: X - REAL :: P0 - REAL, INTENT (IN), DIMENSION (N) :: A,B - REAL, INTENT (OUT), DIMENSION (N) :: P -! - P0 = 1.0 - IF (N.LT.1) STOP 'The dimension is less than 1.' - P(1) = A(1)-X - IF (N.GE.2) P(2) = (A(2)-X)*P(1)-B(1)*B(1)*P0 - IF (N.GE.3) THEN - DO I = 2, N-1 - P(I+1) = (A(I+1)-X)*P(I)-B(I)*B(I)*P(I-1) - END DO - END IF -END SUBROUTINE TDPL diff --git a/samples/book/four/code46.f90 b/samples/book/four/code46.f90 deleted file mode 100644 --- a/samples/book/four/code46.f90 +++ /dev/null @@ -1,83 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CSEED - INTEGER ISEED -END MODULE CSEED -! -SUBROUTINE RMSG (N,XS,A) -! -! Subroutine for generating a random matrix in the Gaussian -! orthogonal ensemble with XS as the standard deviation of -! the off-diagonal elements. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J - REAL, INTENT (IN) :: XS - REAL :: G1,G2 - REAL, INTENT (OUT), DIMENSION (N,N) :: A -! - DO I = 1, N - CALL GRNF (G1,G2) - A(I,I) = SQRT(2.0)*G1*XS - END DO -! - DO I = 1, N - DO J = I+1, N - CALL GRNF(G1,G2) - A(I,J) = G1*XS - A(J,I) = A(I,J) - END DO - END DO -END SUBROUTINE RMSG -! -SUBROUTINE GRNF (X,Y) -! -! Two Gaussian random numbers generated from two uniform random -! numbers. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - REAL, INTENT (OUT) :: X,Y - REAL :: PI,R1,R2,R,RANF -! - PI = 4.0*ATAN(1.0) - R1 = -ALOG(1.0-RANF()) - R2 = 2.0*PI*RANF() - R1 = SQRT(2.0*R1) - X = R1*COS(R2) - Y = R1*SIN(R2) -END SUBROUTINE GRNF -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/nine/code92.f90 b/samples/book/nine/code92.f90 deleted file mode 100644 --- a/samples/book/nine/code92.f90 +++ /dev/null @@ -1,135 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 9.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CSEED - INTEGER :: ISEED -END MODULE CSEED -! -MODULE CB - INTEGER :: ICPT - REAL :: X,B,W -END MODULE CB -! -PROGRAM MCMA -! -! Integral evaluated with the Metropolis Monte Carlo scheme. The -! distribution function is W(x)= (exp(x*x)-1)/Z and the function -! sampled is is g(x) = Z*x*x/(exp(x*x)-1). Copyright (c) Tao Pang 1997. -! - USE CSEED - USE CB - IMPLICIT NONE - INTEGER, PARAMETER :: ITHM=10000,ISIZ=10000,L=15 - INTEGER :: time,STIME,I - INTEGER, DIMENSION (9) :: T - REAL :: SUM1,SUM2,S,DS,Z,ACPT,G,GX,R,RANF,WX,WFNT -! - B = 0.4 - Z = 0.46265167 -! -! Initial seed from the system time and and forced to be odd -! - STIME = time(%REF(0)) - CALL gmtime(STIME,T) - ISEED = T(6)+70*(T(5)+12*(T(4)+31*(T(3)+23*(T(2)+59*T(1))))) - IF (MOD(ISEED,2).EQ.0) ISEED = ISEED-1 -! -! Runs to remove the initial configuration dependence -! - X = RANF() - W = WFNT(X) - DO I = 1, ITHM - CALL MTSP - END DO -! -! Collect data at every L steps -! - SUM1 = 0.0 - SUM2 = 0.0 - ICPT = 0 - DO I = 1, ISIZ*L - CALL MTSP - IF (MOD(I,L).EQ.0) THEN - SUM1 = SUM1+GX(X) - SUM2 = SUM2+GX(X)*GX(X) - ELSE - END IF - END DO -! - S = Z*SUM1/ISIZ - DS = Z*SQRT(ABS(SUM2/ISIZ-(SUM1/ISIZ)**2)/ISIZ) - ACPT = 100.0*ICPT/(ISIZ*L) -! - WRITE(6,"(3F16.8)") S,DS,ACPT -END PROGRAM MCMA -! -SUBROUTINE MTSP -! -! Subroutine for one Metropolis step. Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - REAL :: XSAV,RNDX,RNDW,WTRY,R,RANF,WX,WFNT -! - XSAV = X -! - RNDX = RANF() - X = X+2.0*B*(RNDX-0.5) - IF ((X.LT.0).OR.(X.GT.1)) THEN - X = XSAV - ELSE - WTRY = WFNT(X) - RNDW = RANF() - IF (WTRY.GT.(W*RNDW)) THEN - W = WTRY - ICPT = ICPT+1 - ELSE - X = XSAV - END IF - END IF -END SUBROUTINE MTSP -! -FUNCTION GX(X) RESULT (G) - IMPLICIT NONE - REAL :: X,G - G = X*X/(EXP(X*X)-1.0) -END FUNCTION GX -! -FUNCTION WFNT(X) RESULT (WX) - IMPLICIT NONE - REAL :: X,WX - WX = EXP(X*X)-1.0 -END FUNCTION WFNT -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/one/code11.f90 b/samples/book/one/code11.f90 deleted file mode 100644 --- a/samples/book/one/code11.f90 +++ /dev/null @@ -1,48 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 1.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ONE_D_MOTION -! -! Program for the motion of a particle subject to an external -! force f(x) = -x. We have divided the total time 2*pi into -! 10000 intervals with an equal time step. The position and -! velocity of the particle are written out at every 500 steps. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=10001,IN=500 - INTEGER :: I - REAL :: PI,DT - REAL, DIMENSION (N):: T,V,X -! -! Assign constants, initial position, and initial velocity -! - PI = 4.0*ATAN(1.0) - DT = 2.0*PI/FLOAT(N-1) - X(1) = 0.0 - T(1) = 0.0 - V(1) = 1.0 -! -! Recursion for position and velocity at later time -! - DO I = 1, N-1 - T(I+1) = DT*I - X(I+1) = X(I)+V(I)*DT - V(I+1) = V(I)-X(I)*DT - END DO -! -! Write the position and velocity every 500 steps -! - WRITE (6,"(3F16.8)") (T(I),X(I),V(I),I=1,N,IN) -END PROGRAM ONE_D_MOTION diff --git a/samples/book/seven/code71.f90 b/samples/book/seven/code71.f90 deleted file mode 100644 --- a/samples/book/seven/code71.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 7.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM COMET -! -! Program for the time-dependent position of Halley's comet -! with the velocity version of the Verlet algorithm. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=20001,NP=10000,NI =200 - INTEGER :: I - REAL :: H,KAPPA - REAL, DIMENSION (N) :: X,Y,VX,VY,GX,GY,T,R -! -! Initialization of the problem -! - H = 1.0/NP - KAPPA = 39.478428 - T(1) = 0.0 - X(1) = 1.966843 - Y(1) = 0.0 - R(1) = X(1) - GX(1) = -KAPPA*X(1)/R(1)**3 - GY(1) = 0.0 - VX(1) = 0.0 - VY(1) = 0.815795 -! -! Verlet algorithm for the position and velocity -! - DO I = 1, N-1 - T(I+1) = I*H - X(I+1) = X(I)+H*VX(I)+H*H*GX(I)/2.0 - Y(I+1) = Y(I)+H*VY(I)+H*H*GY(I)/2.0 - R(I+1) = SQRT(X(I+1)*X(I+1)+Y(I+1)*Y(I+1)) - GX(I+1) = -KAPPA*X(I+1)/R(I+1)**3 - GY(I+1) = -KAPPA*Y(I+1)/R(I+1)**3 - VX(I+1) = VX(I)+H*(GX(I+1)+GX(I))/2.0 - VY(I+1) = VY(I)+H*(GY(I+1)+GY(I))/2.0 - END DO - WRITE (6,"(2F16.8)") (T(I),R(I), I=1,N,NI) -END PROGRAM COMET diff --git a/samples/book/seven/code72.f90 b/samples/book/seven/code72.f90 deleted file mode 100644 --- a/samples/book/seven/code72.f90 +++ /dev/null @@ -1,90 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 7.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CSEED - INTEGER :: ISEED -END MODULE CSEED -! -SUBROUTINE MXWL (N,M,T,V) -! -! This subroutine assigns velocities according to the Maxwell distribution. -! N is the total number of velocity components and M is the total number of -! degrees of freedom. T is the system temperature in the reduced units. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: I - REAL, INTENT (IN) :: T - REAL :: V1,V2,EK,VS - REAL, INTENT (OUT), DIMENSION (N) :: V -! -! Assign a Gaussian distribution to each velocity component -! - DO I = 1, N-1, 2 - CALL GRNF (V1,V2) - V(I) = V1 - V(I+1) = V2 - END DO -! -! Scale the velocity to satisfy the partition theorem -! - EK = 0.0 - DO I = 1, N - EK = EK+V(I)*V(I) - END DO - VS = SQRT(EK/(M*T)) - DO I = 1, N - V(I) = V(I)/VS - END DO -END SUBROUTINE MXWL -! -SUBROUTINE GRNF (X,Y) -! -! Two Gaussian random numbers generated from two uniform random -! numbers. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - REAL, INTENT (OUT) :: X,Y - REAL :: PI,R1,R2,R,RANF -! - PI = 4.0*ATAN(1.0) - R1 = -ALOG(1.0-RANF()) - R2 = 2.0*PI*RANF() - R1 = SQRT(2.0*R1) - X = R1*COS(R2) - Y = R1*SIN(R2) -END SUBROUTINE GRNF -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/six/code61.f90 b/samples/book/six/code61.f90 deleted file mode 100644 --- a/samples/book/six/code61.f90 +++ /dev/null @@ -1,70 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM BENCH -! -! This program solves the problem of a person sitting on a -! bench as described in the text. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=99 - INTEGER :: I - REAL :: XL,H,H2,Y0,X0,RHO,G,F0,D,E,Ee0,XD - REAL, DIMENSION (N):: B,X,Y,W,U -! - XL = 3.0 - H = XL/(N+1) - H2 = H*H - Y0 = 1.0E09*0.03**3*0.20/3.0 - X0 = 0.25 - RHO = 3.0 - G = 9.8 - F0 = 200.0 - D = 2.0 - E =-1.0 - Ee0 = 1.0/EXP(1.0) -! -! Find elements in L and U -! - W(1) = D - U(1) = E/D - DO I = 2, N - W(I) = D-E*U(I-1) - U(I) = E/W(I) - END DO -! -! Assign the array B -! - DO I = 1, N - XD = H*I - B(I) = -H2*RHO*G - IF (ABS(XD-XL/2.0).LT.X0) THEN - B(I) = B(I)-H2*F0*(EXP(-((XD-XL/2)/X0)**2)-Ee0) - END IF - B(I) = B(I)/Y0 - END DO -! -! Find the solution of the curvature -! - Y(1) = B(1)/W(1) - DO I = 2, N - Y(I) = (B(I)+Y(I-1))/W(I) - END DO -! - X(N) = Y(N) - DO I = N-1,1,-1 - X(I) = Y(I)-U(I)*X(I+1) - END DO - WRITE(6,"(2F20.10)") (H*I,100*X(I),I=1,N) -END PROGRAM BENCH diff --git a/samples/book/six/code62.f90 b/samples/book/six/code62.f90 deleted file mode 100644 --- a/samples/book/six/code62.f90 +++ /dev/null @@ -1,34 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE RLXN (FN,DN,S,N,P,H) -! -! Subroutine performing one iteration of Relaxation for the one-dimensional -! stationary diffusion equation. DN is the diffusion coefficient shifted -! half step towards x=0. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H,P - REAL :: H2,Q - REAL, INTENT (IN), DIMENSION (N) :: DN,S - REAL, INTENT (INOUT), DIMENSION (N) :: FN -! - H2 = H*H - Q = 1.0-P - DO I = 2, N-1 - FN(I) = Q*FN(I)+P*(DN(I+1)*FN(I+1)+DN(I)*FN(I-1)+H2*S(I))/(DN(I+1)+DN(I)) - END DO -END SUBROUTINE RLXN diff --git a/samples/book/six/code63.f90 b/samples/book/six/code63.f90 deleted file mode 100644 --- a/samples/book/six/code63.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM G_WATER -! -! This program solves the groundwater dynamics problem in the -! rectangular geometry through the relaxation method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: NX=101,NY=51,ISKX=10,ISKY=5,ITMX=5 - INTEGER :: I,J,ISTP - REAL :: PI,A0,B0,H0,CH,SX,SY,HX,HY,P,X,Y - REAL, DIMENSION (NX,NY) :: PHI,CK,SN -! - PI = 4.0*ATAN(1.0) - A0 = 1.0 - B0 = -0.04 - H0 = 200.0 - CH = -20.0 - SX = 1000.0 - SY = 500.0 - HX = SX/(NX-1) - HY = SY/(NY-1) - P = 0.5 -! -! Set up boundary conditions and initial guess of the solution -! - DO I = 1, NX - X = (I-1)*HX - DO J = 1, NY - Y = (J-1)*HY - SN(I,J) = 0.0 - CK(I,J) = A0+B0*Y - PHI(I,J) = H0+CH*COS(PI*X/SX)*Y/SY - END DO - END DO -! - DO ISTP = 1, ITMX -! -! Ensure the boundary conditions by the 4-point formula -! - DO J = 1, NY - PHI(1,J) = (4.0*PHI(2,J)-PHI(3,J))/3.0 - PHI(NX,J) = (4.0*PHI(NX-1,J)-PHI(NX-2,J))/3.0 - END DO -! - CALL RX2D (PHI,CK,SN,NX,NY,P,HX,HY) - END DO -! - DO I = 1, NX, ISKX - X = (I-1)*HX - DO J = 1, NY, ISKY - Y = (J-1)*HY - WRITE (6,"(3F16.8)") X,Y,PHI(I,J) - END DO - END DO -END PROGRAM G_WATER -! -SUBROUTINE RX2D (FN,DN,S,NX,NY,P,HX,HY) -! -! Subroutine performing one iteration of the relaxation for -! the two-dimensional Poisson equation. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: NX,NY - INTEGER :: I,J - REAL, INTENT (IN) :: HX,HY,P - REAL :: HX2,A,B,Q,CIP,CIM,CJP,CJM - REAL, INTENT (IN), DIMENSION (NX,NY) :: DN,S - REAL, INTENT (INOUT), DIMENSION (NX,NY) :: FN -! - HX2 = HX*HX - A = HX2/(HY*HY) - B = 1.0/(4.0*(1.0+A)) - Q = 1.0-P -! - DO I = 2, NX-1 - DO J = 2, NY-1 - CIP = B*(DN(I+1,J)/DN(I,J)+1.0) - CIM = B*(DN(I-1,J)/DN(I,J)+1.0) - CJP = A*B*(DN(I,J+1)/DN(I,J)+1.0) - CJM = A*B*(DN(I,J-1)/DN(I,J)+1.0) - FN(I,J) = Q*FN(I,J)+P*(CIP*FN(I+1,J)+CIM*FN(I-1,J) & - +CJP*FN(I,J+1)+CJM*FN(I,J-1)+HX2*S(I,J)) - END DO - END DO -END SUBROUTINE RX2D diff --git a/samples/book/six/code64.f90 b/samples/book/six/code64.f90 deleted file mode 100644 --- a/samples/book/six/code64.f90 +++ /dev/null @@ -1,118 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM N_T_FIELD -! -! This program solves the time dependent temperature field -! around a nuclear waste rod in a two-dimensional model. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: M1=1001,M=2001,N=19 - INTEGER :: I,J - REAL :: HT,TC,XK,RA,RB,H,H2,T0,S0,CS,A0,B0,C0,R,T - REAL, DIMENSION (N) :: A,B,C,Y,G,W,V,U - REAL, DIMENSION (M,N) :: S - REAL, DIMENSION (M,N+1) :: X -! - HT = 1.0/(M1-1) - TC = 1.0 - XK = 3153.6 - RA = 25.0 - RB = 100.0 - H = RB/(N+1) - H2 = H*H - T0 = 10.0 - S0 = HT*XK*T0/RA**2 - CS = HT*XK/H2 -! - DO I = 1, M - DO J = 1, N+1 - X(I,J) = 0.0 - END DO - END DO -! - DO I = 1, N - R = H*I - A(I) = 2.0*(1.0+CS)*R - B(I) = -(1.0+0.5/I)*CS*R - C(I) = -(1.0-0.5/I)*CS*R - IF (R.LT.RA) THEN - S(1,I) = S0*R - ELSE - S(1,I) = 0.0 - END IF - END DO -! -! Assign the source of the radiation heat -! - DO I = 2, M - T = HT*(I-1) - DO J = 1, N - R = H*J - IF (R.LT.RA) THEN - S(I,J) = R*S0/EXP(T/TC) - ELSE - S(I,J) = 0.0 - END IF - END DO - END DO -! - DO I = 2, M -! -! Find the values from the last time step -! - A0 = 2.0*(1.0-CS)*H - B0 = (1.0+0.5)*CS*H - C0 = (1.0-0.5)*CS*H - G(1) = A0*X(I-1,1)+B0*X(I-1,2) & - +C0*(4.0*X(I-1,1)-X(I-1,2))/3.0+S(I-1,1)+S(I,1) - DO J = 2, N - R = J*H - A0 = 2.0*(1.0-CS)*R - B0 = (1.0+0.5/J)*CS*R - C0 = (1.0-0.5/J)*CS*R - G(J) = A0*X(I-1,J)+B0*X(I-1,J+1)+C0*X(I-1,J-1)+(S(I-1,J)+S(I,J)) - END DO -! -! Find the elements in L and U -! - W(1) = A(1) - V(1) = C(1) - U(1) = B(1)/W(1) - DO J = 2, N - V(J) = C(J) - W(J) = A(J)-V(J-1)*U(J-1) - U(J) = B(J)/W(J) - END DO -! -! Find the solution of the temperature -! - Y(1) = G(1)/W(1) - DO J = 2, N - Y(J) = (G(J)-V(J-1)*Y(J-1))/W(J) - END DO -! - X(I,N) = Y(N) - DO J = N-1,1,-1 - X(I,J) = Y(J)-U(J)*X(I,J+1) - END DO - END DO -! - I = M - DO J = 1, N+1 - R = J*H - WRITE (6,"(2F16.8)") R,X(I,J) - END DO -END PROGRAM N_T_FIELD diff --git a/samples/book/three/code31.f90 b/samples/book/three/code31.f90 deleted file mode 100644 --- a/samples/book/three/code31.f90 +++ /dev/null @@ -1,46 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ONE_D_MOTION2 -! -! Simplest predictor-corector algorithm applied to a particle in one -! dimension under an elastic force. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=101,IN=5 - INTEGER :: I - REAL :: PI,DT - REAL, DIMENSION (N) :: T,V,X -! - PI = 4.0*ATAN(1.0) - DT =2.0*PI/100 - X(1)=0.0 - T(1)=0.0 - V(1)=1.0 -! - DO I = 1, N-1 - T(I+1) = I*DT -! -! Predictor for position and velocity -! - X(I+1) = X(I)+V(I)*DT - V(I+1) = V(I)-X(I)*DT -! -! Corrector for position and velocity -! - X(I+1) = X(I)+(V(I)+V(I+1))*DT/2.0 - V(I+1) = V(I)-(X(I)+X(I+1))*DT/2.0 - END DO - WRITE(6,"(3F16.8)") (T(I),X(I),V(I),I=1,N,IN) -END PROGRAM ONE_D_MOTION2 diff --git a/samples/book/three/code32.f90 b/samples/book/three/code32.f90 deleted file mode 100644 --- a/samples/book/three/code32.f90 +++ /dev/null @@ -1,79 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.12 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CB - REAL :: Q,B,W -END MODULE CB -! -PROGRAM PENDULUM -! -! Main Program for a driven pendulum under damping solved with -! the fourth-order Runge-Kutta algorithm. Parameters: Q, B, -! and W (omega_0). Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - INTEGER, PARAMETER :: N=1000,L=100,M=1 - INTEGER :: I - REAL :: PI,H,T,Y1,Y2,G1,G1F,G2,G2F - REAL :: DK11,DK21,DK12,DK22,DK13,DK23,DK14,DK24 - REAL, DIMENSION (2,N) :: Y -! - PI = 4.0*ATAN(1.0) - H = 3.0*PI/L - Q = 0.5 - B = 0.9 - W = 2.0/3.0 - Y(1,1) = 0.0 - Y(2,1) = 2.0 -! -! Using the Runge-Kutta algorithm to integrate the equation -! - DO I = 1, N-1 - T = H*I - Y1 = Y(1,I) - Y2 = Y(2,I) - DK11 = H*G1F(Y1,Y2,T) - DK21 = H*G2F(Y1,Y2,T) - DK12 = H*G1F((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK22 = H*G2F((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK13 = H*G1F((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK23 = H*G2F((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK14 = H*G1F((Y1+DK13),(Y2+DK23),(T+H)) - DK24 = H*G2F((Y1+DK13),(Y2+DK23),(T+H)) - Y(1,I+1) = Y(1,I)+(DK11+2.0*(DK12+DK13)+DK14)/6.0 - Y(2,I+1) = Y(2,I)+(DK21+2.0*(DK22+DK23)+DK24)/6.0 -! -! Bring theta back to the region [-pi,pi] -! - Y(1,I+1) = Y(1,I+1)-2.0*PI*NINT(Y(1,I+1)/(2.0*PI)) - END DO - WRITE (6,"(2F16.8)") (Y(1,I),Y(2,I),I=1,N,M) -END PROGRAM PENDULUM -! -FUNCTION G1F (Y1,Y2,T) RESULT (G1) - USE CB - IMPLICIT NONE - REAL :: Y1,Y2,T,G1 -! - G1 = Y2 -END FUNCTION G1F -! -FUNCTION G2F (Y1,Y2,T) RESULT (G2) - USE CB - IMPLICIT NONE - REAL :: Y1,Y2,T,G2 -! - G2 = -Q*Y2-SIN(Y1)+B*COS(W*T) -END FUNCTION G2F diff --git a/samples/book/three/code33.f90 b/samples/book/three/code33.f90 deleted file mode 100644 --- a/samples/book/three/code33.f90 +++ /dev/null @@ -1,109 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM SHOOTING -! -! Program for the boundary value problem with the shooting -! method. The Runge-Kutta and secant methods are used. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=101,M=5 - REAL :: DK11,DK21,DK12,DK22,DK13,DK23,DK14,DK24 - REAL :: DL,XL,XU,H,D,YL,YU,X0,DX,X1,X2,F0,F1 - REAL :: X ! added by DAO - INTEGER :: I ! added by DAO - REAL :: Y1,Y2,G1,G1F,G2,G2F - REAL, DIMENSION (2,N) :: Y -! -! Initialization of the problem -! - DL = 1.0E-06 - XL = 0.0 - XU = 1.0 - H = (XU-XL)/(N-1) - D = 0.1 - YL = 0.0 - YU = 1.0 - X0 = (YU-YL)/(XU-XL) - DX = 0.01 - X1 = X0+DX -! -! The secant search for the root -! - Y(1,1) = YL - DO WHILE (ABS(D).GT.DL) -! -!C The!Runge-Kutta calculation of the first trial solution -! - Y(2,1) = X0 - DO I = 1, N-1 - X = XL+H*I - Y1 = Y(1,I) - Y2 = Y(2,I) - DK11 = H*G1F(Y1,Y2,X) - DK21 = H*G2F(Y1,Y2,X) - DK12 = H*G1F((Y1+DK11/2.0),(Y2+DK21/2.0),(X+H/2.0)) - DK22 = H*G2F((Y1+DK11/2.0),(Y2+DK21/2.0),(X+H/2.0)) - DK13 = H*G1F((Y1+DK12/2.0),(Y2+DK22/2.0),(X+H/2.0)) - DK23 = H*G2F((Y1+DK12/2.0),(Y2+DK22/2.0),(X+H/2.0)) - DK14 = H*G1F((Y1+DK13),(Y2+DK23),(X+H)) - DK24 = H*G2F((Y1+DK13),(Y2+DK23),(X+H)) - Y(1,I+1) = Y(1,I)+(DK11+2.0*(DK12+DK13)+DK14)/6.0 - Y(2,I+1) = Y(2,I)+(DK21+2.0*(DK22+DK23)+DK24)/6.0 - END DO - F0 = Y(1,N)-1.0 -! -! Runge-Kutta calculation of the second trial solution -! - Y(2,1) = X1 - DO I = 1, N-1 - X = XL+H*I - Y1 = Y(1,I) - Y2 = Y(2,I) - DK11 = H*G1(Y1,Y2,X) - DK21 = H*G2(Y1,Y2,X) - DK12 = H*G1((Y1+DK11/2.0),(Y2+DK21/2.0),(X+H/2.0)) - DK22 = H*G2((Y1+DK11/2.0),(Y2+DK21/2.0),(X+H/2.0)) - DK13 = H*G1((Y1+DK12/2.0),(Y2+DK22/2.0),(X+H/2.0)) - DK23 = H*G2((Y1+DK12/2.0),(Y2+DK22/2.0),(X+H/2.0)) - DK14 = H*G1((Y1+DK13),(Y2+DK23),(X+H)) - DK24 = H*G2((Y1+DK13),(Y2+DK23),(X+H)) - Y(1,I+1) = Y(1,I)+(DK11+2.0*(DK12+DK13)+DK14)/6.0 - Y(2,I+1) = Y(2,I)+(DK21+2.0*(DK22+DK23)+DK24)/6.0 - END DO - F1 = Y(1,N)-1.0 -! - D = F1-F0 - X2 = X1-F1*(X1-X0)/D - X0 = X1 - X1 = X2 - END DO - WRITE (6,"(2F16.8)") (H*(I-1), Y(1,I),I=1,N,M) -END -! -FUNCTION G1F (Y1,Y2,T) RESULT (G1) - IMPLICIT NONE - REAL :: Y1,Y2,T,G1 -! - G1 = Y2 -END FUNCTION G1F -! -FUNCTION G2F (Y1,Y2,T) RESULT (G2) - IMPLICIT NONE - REAL :: PI,Y1,Y2,T,G2 -! - PI = 4.0*ATAN(1.0) - G2 =-PI*PI*(Y1+1.0)/4.0 -END FUNCTION G2F diff --git a/samples/book/three/code34.f90 b/samples/book/three/code34.f90 deleted file mode 100644 --- a/samples/book/three/code34.f90 +++ /dev/null @@ -1,81 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM S_L_LEGENDRE -! -! Main program for solving the Legendre equation with the simplest -! algorithm for the Sturm-Liouville equation and the bisection method -! for the root search. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=501 - INTEGER :: ISTEP - REAL :: DL,H,AK,BK,DK,EK,F0,F1 - REAL, DIMENSION (N) :: U -! -! Initialization of the problem -! - DL = 1.0E-06 - H = 2.0/(N-1) - AK = 0.5 - BK = 1.5 - DK = 0.5 - EK = AK - U(1) = -1.0 - U(2) = -1.0+H - ISTEP = 0 - CALL SMPL (N,H,EK,U) - F0 = U(N)-1.0 -! -! Bisection method for the root -! - DO WHILE (ABS(DK).GT.DL) - EK = (AK+BK)/2.0 - CALL SMPL (N,H,EK,U) - F1 = U(N)-1.0 - IF ((F0*F1).LT.0) THEN - BK = EK - DK = BK-AK - ELSE - AK = EK - DK = BK-AK - F0 = F1 - END IF - ISTEP = ISTEP+1 - END DO -! - WRITE (6,"(I4,3F16.8)") ISTEP,EK,DK,F1 -END PROGRAM S_L_LEGENDRE -! -SUBROUTINE SMPL (N,H,EK,U) -! -! The simplest algorithm for the Sturm-Liouville equation. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H,EK - REAL :: H2,Q,X,P,P1 - REAL, INTENT (OUT), DIMENSION (N) :: U -! - H2 = 2.0*H*H - Q = EK*(1.0+EK) - DO I = 2, N-1 - X = (I-1)*H-1.0 - P = 2.0*(1.0-X*X) - P1 = -2.0*X*H - U(I+1) = ((2.0*P-H2*Q)*U(I)+(P1-P)*U(I-1))/(P1+P) - END DO -END SUBROUTINE SMPL diff --git a/samples/book/three/code3a.f90 b/samples/book/three/code3a.f90 deleted file mode 100644 --- a/samples/book/three/code3a.f90 +++ /dev/null @@ -1,39 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.A !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE NMRV (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.77)-(3.80) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (OUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*((Q(I-1)-Q(I+1))/2.0+Q(I)) - C1 = 2.0-G*(Q(I+1)+Q(I-1)+8.0*Q(I)) - C2 = 1.0+G*((Q(I+1)-Q(I-1))/2.0+Q(I)) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV diff --git a/samples/book/three/code3b.f90 b/samples/book/three/code3b.f90 deleted file mode 100644 --- a/samples/book/three/code3b.f90 +++ /dev/null @@ -1,39 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.B !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE NMRV2 (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.82)-(3.85) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL,INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (INOUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*Q(I-1) - C1 = 2.0-10.0*G*Q(I) - C2 = 1.0+G*Q(I+1) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV2 diff --git a/samples/book/three/code3c.f90 b/samples/book/three/code3c.f90 deleted file mode 100644 --- a/samples/book/three/code3c.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.C !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM WAVE -! -! Program for the eigenvalue problem with a combination of the -! bisection method and the Numerov algorithm for u" = -k**2*u -! with boundary conditions u(0)=u(1)=0. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=101 - INTEGER :: I,ISTEP - REAL :: DL,H,AK,BK,DK,EK,F0,F1 - REAL, DIMENSION (N) :: Q,S,U -! -! Initialization of the problem -! - DL = 1.0E-06 - H = 1.0/(N-1) - AK = 2.0 - BK = 4.0 - DK = 1.0 - EK = AK - U(1) = 0.0 - U(2) = 0.01 - ISTEP = 0 -! - DO I = 1,N - S(I) = 0.0 - Q(I) = EK*EK - END DO - CALL NMRV (N,H,Q,S,U) - F0 = U(N) -! -! Bisection method for the root -! - DO WHILE (ABS(DK).GT.DL) - EK = (AK+BK)/2.0 - DO I = 1,N - Q(I) = EK*EK - END DO - CALL NMRV (N,H,Q,S,U) - F1 = U(N) - IF ((F0*F1).LT.0) THEN - BK = EK - DK = BK-AK - ELSE - AK = EK - DK = BK-AK - F0 = F1 - END IF - ISTEP = ISTEP+1 - END DO - WRITE (6,"(I4,3F16.8)") ISTEP,EK,DK,F1 -END PROGRAM WAVE -! -SUBROUTINE NMRV (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.77)-(3.80) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (INOUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*((Q(I-1)-Q(I+1))/2.0+Q(I)) - C1 = 2.0-G*(Q(I+1)+Q(I-1)+8.0*Q(I)) - C2 = 1.0+G*((Q(I+1)-Q(I-1))/2.0+Q(I)) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV diff --git a/samples/book/three/code3d.f90 b/samples/book/three/code3d.f90 deleted file mode 100644 --- a/samples/book/three/code3d.f90 +++ /dev/null @@ -1,171 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.D !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM SCHR -! -! Main program for solving the eigenvalue problem of the -! one-dimensional Schroedinger equation. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=501,M=5,IMAX=100 - INTEGER :: I,IM,NL,NR,ISTEP - REAL :: DL,H2M,EA,EB,E,DE,XL0,XR0,H,C - REAL :: XL,XR,FACT,F0,F1,E1,SUM,V,VX - REAL, DIMENSION (N) :: UL,UR,QL,QR,S -! - DL = 1.0E-06 - H2M = 0.5 - EA = 2.4 - EB = 2.7 - E = EA - DE = 0.1 - XL0 = -10.0 - XR0 = 10.0 - H = (XR0-XL0)/(N-1) - C = 1.0/H2M - UL(1) = 0.0 - UL(2) = 0.01 - UR(1) = 0.0 - UR(2) = 0.01 -! -! Set up the potential q(x) and source s(x) -! - DO I = 1, N - XL = XL0+(I-1)*H - XR = XR0-(I-1)*H - QL(I) = C*(E-VX(XL)) - QR(I) = C*(E-VX(XR)) - S(I) = 0.0 - END DO -! -! Find the matching point at the right turning point -! - DO I = 1, N-1 - IF(((QL(I)*QL(I+1)).LE.0).AND.(QL(I).GT.0)) IM = I - END DO -! -! Numerov algorithm from left to right and vice versa -! - NL = IM+1 - NR = N-IM+2 - CALL NMRV2 (NL,H,QL,S,UL) - CALL NMRV2 (NR,H,QR,S,UR) -! -! Rescale the left solution -! - FACT = UR(NR-1)/UL(IM) - DO I = 1, NL - UL(I) = FACT*UL(I) - END DO -! - F0 = UR(NR)+UL(NL)-UR(NR-2)-UL(NL-2) - F0 = F0/(2.0*H*UR(NR-1)) -! -! Bisection method for the root -! - ISTEP = 0 - DO WHILE ((ABS(DE).GT.DL).AND.(ISTEP.LT.IMAX)) - E1 = E - E = (EA+EB)/2.0 - DO I = 1, N - QL(I) = QL(I)+C*(E-E1) - QR(I) = QR(I)+C*(E-E1) - END DO -! -! Find the matching point at the right turning point -! - DO I = 1, N-1 - IF(((QL(I)*QL(I+1)).LE.0).AND.(QL(I).GT.0)) IM = I - END DO -! -! Numerov algorithm from left to right and vice versa -! - NL = IM+1 - NR = N-IM+2 - CALL NMRV2 (NL,H,QL,S,UL) - CALL NMRV2 (NR,H,QR,S,UR) -! -! Rescale the left solution -! - FACT = UR(NR-1)/UL(IM) - DO I = 1, NL - UL(I) = FACT*UL(I) - END DO -! - F1 = UR(NR)+UL(NL)-UR(NR-2)-UL(NL-2) - F1 = F1/(2.0*H*UR(NR-1)) -! - IF ((F0*F1).LT.0) THEN - EB = E - DE = EB-EA - ELSE - EA = E - DE = EB-EA - F0 = F1 - END IF - ISTEP = ISTEP+1 - END DO -! - SUM = 0.0 - DO I = 1, N - IF(I.GT.IM) UL(I) = UR(N-I) - SUM = SUM+UL(I)*UL(I) - END DO -! - WRITE(6,"(2I4)") ISTEP,IMAX - WRITE(6,"(4F20.8)") E,DE,F0,F1 -! - SUM=SQRT(H*SUM) - DO I = 1, N, M - XL = XL0+(I-1)*H - UL(I) = UL(I)/SUM - WRITE(15,"(4F20.8)") XL,UL(I) - WRITE(16,"(4F20.8)") XL,VX(XL) - END DO -END PROGRAM SCHR -! -FUNCTION VX (X) RESULT (V) - REAL :: A,B,X,V -! - A = 1.0 - B = 4.0 - V = 3.0-A*A*B*(B-1.0)/(COSH(A*X)**2)/2.0 -END FUNCTION VX -! -SUBROUTINE NMRV2 (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.82)-(3.85) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL,INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (INOUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*Q(I-1) - C1 = 2.0-10.0*G*Q(I) - C2 = 1.0+G*Q(I+1) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV2 diff --git a/samples/book/twelve/code121.f90 b/samples/book/twelve/code121.f90 deleted file mode 100644 --- a/samples/book/twelve/code121.f90 +++ /dev/null @@ -1,20 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.1 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE RPHI_TO_XY (R,PHI,X,Y) - IMPLICIT NONE - REAL, INTENT (IN) :: R,PHI - REAL, INTENT (OUT) :: X,Y - X = R*COS(PHI); Y = R*SIN(PHI) ! Assign x and y -END SUBROUTINE RPHI_TO_XY diff --git a/samples/book/twelve/code122.f90 b/samples/book/twelve/code122.f90 deleted file mode 100644 --- a/samples/book/twelve/code122.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.2 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ARRAY_EXAMPLE - IMPLICIT NONE - REAL :: TWO_PI - REAL, ALLOCATABLE :: A(:,:), B(:,:), C(:,:), D(:) - INTEGER :: N,M,L,I -! - TWO_PI = 8.0*ATAN(1.0) - READ "(3I4)", N, M, L - ALLOCATE (A(N,M)); ALLOCATE (B(L,N)) - ALLOCATE (C(L,M)); ALLOCATE (D(M)) - CALL RANDOM_NUMBER (A); CALL RANDOM_NUMBER (B) - A = SIN(TWO_PI*A); B = COS(TWO_PI*B) - C = MATMUL(B,A) - DO I = 1, M - D(I) = DOT_PRODUCT(A(:,I),B(I,:)) - END DO - PRINT "(8F10.6)", D -END PROGRAM ARRAY_EXAMPLE diff --git a/samples/book/twelve/code123.f90 b/samples/book/twelve/code123.f90 deleted file mode 100644 --- a/samples/book/twelve/code123.f90 +++ /dev/null @@ -1,56 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.3 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE ORDER_AN_ARRAY - PRIVATE EXCHANGE -! - CONTAINS -! - SUBROUTINE REARRANGE (A) - IMPLICIT NONE - REAL, INTENT(INOUT) :: A(:) - LOGICAL, ALLOCATABLE :: MASK(:) - INTEGER :: I, N - INTEGER, DIMENSION(1) :: K - N = SIZE (A) - ALLOCATE (MASK(N)) - MASK = .TRUE. - DO I = 0, N-1 - MASK(N-I) = .FALSE. - K = MAXLOC(A,MASK) - CALL EXCHANGE(A(K(1)),A(N-I)) - END DO - END SUBROUTINE REARRANGE -! - SUBROUTINE EXCHANGE (X,Y) - IMPLICIT NONE - REAL, INTENT(INOUT):: X,Y - REAL TX - TX = X; X = Y; Y = TX - END SUBROUTINE EXCHANGE -! -END MODULE ORDER_AN_ARRAY -! -PROGRAM RANDOM_ARRAY_ORDERED - USE ORDER_AN_ARRAY -! - IMPLICIT NONE - INTEGER, PARAMETER :: N = 100 - REAL, DIMENSION(N) :: A - INTEGER :: I -! - CALL RANDOM_NUMBER (A) - CALL REARRANGE (A) - WRITE(6, "(F10.8)") (A(I),I=1,N) -END PROGRAM RANDOM_ARRAY_ORDERED diff --git a/samples/book/twelve/code124.f90 b/samples/book/twelve/code124.f90 deleted file mode 100644 --- a/samples/book/twelve/code124.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.4 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM LAPLACE_2D -! -! Example program for the 2D Laplace equation as defined -! in the text. -! - IMPLICIT NONE - INTEGER, PARAMETER :: NX=101, NY=101 - INTEGER I, J, IMAX - REAL, DIMENSION (NX,NY) :: BOUND,FIELD,U,UTMP, DU - REAL :: TL,Q,P,A,B - LOGICAL, DIMENSION (NX,NY) :: MASK -! - TL = 1.0E-08 - A = 1.0/(NY-1) - B = 1.0/((NY-1)**2) - P = 0.5 - Q = 1.0 - P -! -! Align the data accordingly -! -!HPF$ DISTRIBUTE U(BLOCK,BLOCK) -! -!HPF$ ALIGN BOUND(:,:) WITH U(:,:) -!HPF$ ALIGN FIELD(:,:) WITH U(:,:) -!HPF$ ALIGN UTMP(:,:) WITH U(:,:) -!HPF$ ALIGN MASK(:,:) WITH U(:,:) -! - MASK = .FALSE. - MASK(2:NX-1,2:NY-1) = .TRUE. -! - BOUND = 0.0 - FIELD = 0.0 - WHERE (MASK) - FIELD = 0.25 - ELSEWHERE - BOUND = 0.25 - END WHERE -! -! Assign the initial value for iteration -! - FORALL (I=1:NX,J=1:NY) U(I,J) = A*(J-1)*(NX-I)/(NX-1) & - +B*(J-1)**2*(I-1)/(NX-1) -! -! The main iteration loop -! - DO I = 1, IMAX - UTMP = FIELD*( CSHIFT(U,SHIFT= 1,DIM=1) & - + CSHIFT(U,SHIFT= 1,DIM=2) & - + CSHIFT(U,SHIFT=-1,DIM=1) & - + CSHIFT(U,SHIFT=-1,DIM=2) ) & - + BOUND - DU = U - UTMP - U = Q*U + P*UTMP - DU = MAXVAL(ABS(U - UTMP)) - IF (DU.LE.TL) EXIT - END DO - IF (I.NE.IMAX) THEN - PRINT*, 'The number of iteration is ', I, & -' and the largest error is ', DU - PRINT*, 'The solution is ', U - ELSE - PRINT*, 'The required convergence is not reached yet' - END IF -END PROGRAM LAPLACE_2D diff --git a/samples/book/twelve/code125.f90.save b/samples/book/twelve/code125.f90.save deleted file mode 100644 --- a/samples/book/twelve/code125.f90.save +++ /dev/null @@ -1,42 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM TALK_0_TO_1 - INCLUDE 'mpif.h' - INTEGER :: IRANK,IPROC,ITAG,ISEND,IRECV,IERR,IM,ID,IFINISH - INTEGER, DIMENSION (MPI_STATUS_SIZE) :: ISTAT - CHARACTER*40 :: HELLO -! - ITAG = 730 - ID = 40 - ISEND = 0 - IRECV = 1 - CALL MPI_INIT (IERR) - CALL MPI_COMM_RANK (MPI_COMM_WORLD,IRANK,IERR) - CALL MPI_COMM_SIZE (MPI_COMM_WORLD,IPROC,IERR) - PRINT*, IRANK, IPROC - CALL MPI_BARRIER (MPI_COMM_WORLD,IERR) - IF (IRANK.EQ.ISEND) THEN - HELLO = 'I am process 0, who are you ?' - IM = 29 - CALL MPI_SEND (HELLO,IM,MPI_CHARACTER,IRECV, & - ITAG,MPI_COMM_WORLD,IERR) - PRINT*, 'I sent the message: ', HELLO - ELSE IF (IRANK.EQ.IRECV) THEN - CALL MPI_RECV (HELLO,ID,MPI_CHARACTER,ISEND, & - ITAG,MPI_COMM_WORLD,ISTAT,IERR) - PRINT*, 'I got your message which is: ', HELLO - END IF - CALL MPI_FINALIZE(IFINISH) -END PROGRAM TALK_0_TO_1 diff --git a/samples/book/two/code21.f90 b/samples/book/two/code21.f90 deleted file mode 100644 --- a/samples/book/two/code21.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM INTERPOLATION -! -! Main program for the Lagrange interpolation with the Aitken method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=5 - REAL :: X,F,DF - REAL, DIMENSION (N) :: XI,FI - DATA XI/0.0,0.5,1.0,1.5,2.0/, & - FI/1.0,0.938470,0.765198,0.511828,0.223891/ -! - X = 0.9 - CALL AITKEN (N,XI,FI,X,F,DF) - WRITE (6,"(3F16.8)") X,F,DF -END PROGRAM INTERPOLATION -! -SUBROUTINE AITKEN (N,XI,FI,X,F,DF) -! -! Subroutine performing the Lagrange interpolation with the -! Aitken method. F: interpolated value. DF: error estimated. -! Copyright (c) Tao Pang 1997. -! - INTEGER, PARAMETER :: NMAX=21 - INTEGER, INTENT (IN) :: N - INTEGER :: I,J - REAL, INTENT (IN) :: X - REAL, INTENT (OUT) :: F,DF - REAL :: X1,X2,F1,F2 - REAL, INTENT (IN), DIMENSION (N):: XI,FI - REAL, DIMENSION (NMAX):: FT -! - IF (N.GT.NMAX) STOP 'Dimension of the data is too large.' - DO I = 1, N - FT(I) = FI(I) - END DO -! - DO I = 1, N-1 - DO J = 1, N-I - X1 = XI(J) - X2 = XI(J+I) - F1 = FT(J) - F2 = FT(J+1) - FT(J) = (X-X1)/(X2-X1)*F2+(X-X2)/(X1-X2)*F1 - END DO - END DO - F = FT(1) - DF = (ABS(F-F1)+ABS(F-F2))/2.0 -END SUBROUTINE AITKEN diff --git a/samples/book/two/code210.f90 b/samples/book/two/code210.f90 deleted file mode 100644 --- a/samples/book/two/code210.f90 +++ /dev/null @@ -1,185 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.10 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CB - REAL :: B,E,A -END MODULE CB -! -PROGRAM SCATTERING -! -! This is the main program for the scattering problem. -! Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - INTEGER, PARAMETER :: M=21,N=10001 - INTEGER I,J,ISTEP - REAL :: DL,B0,DB,DX,X0,X,DX0,F,FX,FB,FBX,G1,G2,RU,RUTH,SI - REAL, DIMENSION (N) :: FI - REAL, DIMENSION (M) :: THETA,SIG,SIG1 -! - DL = 1.E-06 - B0 = 0.01 - DB = 0.5 - DX = 0.01 - E = 1.0 - A = 100.0 - DO I = 1, M - B = B0+(I-1)*DB -! -! Calculate the first term of theta -! - DO J = 1, N - X = B+DX*J - FI(J) = 1.0/(X*X*SQRT(FBX(X))) - END DO - CALL SIMP(N,DX,FI,G1) -! -! Find r_m from 1-b*b/(r*r)-U/E=0 -! - X0 = B - DX0 = DX - CALL SECANT (DL,X0,DX0,ISTEP) -! -! Calculate the second term of theta -! - DO J = 1, N - X = X0+DX*J - FI(J) = 1.0/(X*X*SQRT(FX(X))) - END DO - CALL SIMP (N,DX,FI,G2) - THETA(I) = 2.0*B*(G1-G2) - END DO -! -! Calculate d_theta/d_b -! - CALL THREE (M,DB,THETA,SIG,SIG1) -! -! Put the cross section in log form with the exact result of -! the Coulomb scattering (RUTH) -! - DO I = M, 1, -1 - B = B0+(I-1)*DB - SIG(I) = B/ABS(SIG(I))/SIN(THETA(I)) - RUTH = 1.0/SIN(THETA(I)/2.0)**4/16.0 - SI = ALOG(SIG(I)) - RU = ALOG(RUTH) - WRITE (6,"(3F16.8)") THETA(I),SI,RU - END DO -END PROGRAM SCATTERING -! -SUBROUTINE SIMP (N,H,FI,S) -! -! Subroutine for integration over f(x) with the Simpson rule. FI: -! integrand f(x); H: interval; S: integral. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL :: S0,S1,S2 - REAL, INTENT (OUT) :: S - REAL, INTENT (IN), DIMENSION (N) :: FI -! - S = 0.0 - S0 = 0.0 - S1 = 0.0 - S2 = 0.0 - DO I = 2, N-1, 2 - S1 = S1+FI(I-1) - S0 = S0+FI(I) - S2 = S2+FI(I+1) - END DO - S = H*(S1+4.0*S0+S2)/3.0 -! -! If N is even, add the last slice separately -! - IF (MOD(N,2).EQ.0) S = S & - +H*(5.0*FI(N)+8.0*FI(N-1)-FI(N-2))/12.0 -END SUBROUTINE SIMP -! -SUBROUTINE SECANT (DL,X0,DX,ISTEP) -! -! Subroutine for the root of f(x)=0 with the secant method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: ISTEP - REAL, INTENT (INOUT) :: X0,DX - REAL :: X1,X2,D,F,FX - REAL, INTENT (IN) :: DL -! - ISTEP = 0 - X1 = X0+DX - DO WHILE (ABS(DX).GT.DL) - D = FX(X1)-FX(X0) - X2 = X1-FX(X1)*(X1-X0)/D - X0 = X1 - X1 = X2 - DX = X1-X0 - ISTEP = ISTEP+1 - END DO -END SUBROUTINE SECANT -! -SUBROUTINE THREE (N,H,FI,F1,F2) -! -! Subroutine for 1st and 2nd order derivatives with the three-point -! formulas. Extrapolations are made at the boundaries. FI: input -! f(x); H: interval; F1: f'; and F2: f". Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL, INTENT (IN), DIMENSION (N) :: FI - REAL, INTENT (OUT), DIMENSION (N) :: F1,F2 -! -! f' and f" from three-point formulas -! - DO I = 2, N-1 - F1(I) = (FI(I+1)-FI(I-1))/(2.*H) - F2(I) = (FI(I+1)-2.0*FI(I)+FI(I-1))/(H*H) - END DO -! -! Linear extrapolation for the boundary points -! - F1(1) = 2.0*F1(2)-F1(3) - F1(N) = 2.0*F1(N-1)-F1(N-2) - F2(1) = 2.0*F2(2)-F2(3) - F2(N) = 2.0*F2(N-1)-F2(N-2) -END SUBROUTINE THREE -! -FUNCTION FX(X) RESULT (F) - USE CB - IMPLICIT NONE - REAL :: X,F,U,UX -! - F = 1.0-B*B/(X*X)-UX(X)/E -END FUNCTION FX -! -FUNCTION FBX(X) RESULT (FB) - USE CB - IMPLICIT NONE - REAL :: X,FB -! - FB = 1.0-B*B/(X*X) -END FUNCTION FBX -! -FUNCTION UX(X) RESULT (U) - USE CB - IMPLICIT NONE - REAL :: X,U -! - U = 1.0/X*EXP(-X/A) -END FUNCTION UX diff --git a/samples/book/two/code211.f90 b/samples/book/two/code211.f90 deleted file mode 100644 --- a/samples/book/two/code211.f90 +++ /dev/null @@ -1,40 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.11 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!MODULE CSEED -! INTEGER :: ISEED -!END MODULE CSEED -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! -! USE CSEED - IMPLICIT NONE - INTEGER :: ISEED - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/two/code212.f90 b/samples/book/two/code212.f90 deleted file mode 100644 --- a/samples/book/two/code212.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.12 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! -FUNCTION ERNF() RESULT (E) -! -! Exponential random number generator from a uniform random -! number generator. Copyright (c) Tao Pang 1997. -! - REAL E,R,RANF -! - E = -ALOG(1.0-RANF()) -END FUNCTION ERNF -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: ISEED - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/two/code213.f90 b/samples/book/two/code213.f90 deleted file mode 100644 --- a/samples/book/two/code213.f90 +++ /dev/null @@ -1,58 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.13 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!MODULE CSEED -! INTEGER :: ISEED -!END MODULE CSEED -! -SUBROUTINE GRNF (X,Y) -! -! Two Gaussian random numbers generated from two uniform random -! numbers. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - REAL, INTENT (OUT) :: X,Y - REAL :: PI,R1,R2,R,RANF -! - PI = 4.0*ATAN(1.0) - R1 = -ALOG(1.0-RANF()) - R2 = 2.0*PI*RANF() - R1 = SQRT(2.0*R1) - X = R1*COS(R2) - Y = R1*SIN(R2) -END SUBROUTINE GRNF -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! -! USE CSEED - - IMPLICIT NONE -INTEGER :: ISEED - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/two/code214.f90 b/samples/book/two/code214.f90 deleted file mode 100644 --- a/samples/book/two/code214.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.14 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!MODULE CSEED -! INTEGER :: ISEED -!END MODULE CSEED -! -SUBROUTINE PERCOLATION (L,N,M,P) -! -! Subroutine to create an N*M percolation network. -! Copyright (c) Tao Pang 1997. -! - INTEGER, INTENT (IN) :: N,M - REAL, INTENT (IN) :: P - REAL:: R,RANF - INTEGER I,J - LOGICAL, INTENT (OUT), DIMENSION (N,M) :: L -! - DO I = 1, N - DO J = 1, M - R = RANF() - IF(R.LT.P) THEN - L(I,J) = .TRUE. - ELSE - L(I,J) = .FALSE. - END IF - END DO - END DO -END SUBROUTINE PERCOLATION -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! -! USE CSEED - IMPLICIT NONE - INTEGER :: ISEED - INTEGER :: IH,IL,IT,IA,IC,IQ,IR - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/book/two/code22.f90 b/samples/book/two/code22.f90 deleted file mode 100644 --- a/samples/book/two/code22.f90 +++ /dev/null @@ -1,80 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE PFIT (N,M,X,F,A,U) -! -! Subroutine generating orthonormal polynomials U(M,N) up to -! (M-1)th order and coefficients A(M), for the least squares -! approximation of the function F(N) at X(N). Other variables -! used: G(K) for g_k, H(K) for h_k, S(K) for . -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: NMAX=101,MMAX=101 - INTEGER, INTENT (IN) :: N,M - INTEGER :: I,J - REAL :: TMP - REAL, INTENT (IN), DIMENSION (N) :: X,F - REAL, INTENT (OUT), DIMENSION (M) :: A - REAL, INTENT (OUT), DIMENSION (M,N) :: U - REAL, DIMENSION (MMAX) :: G,H,S -! - IF(N.GT.NMAX) STOP 'Too many points' - IF(M.GT.MMAX) STOP 'Order too high' -! -! Set up the zeroth order polynomial u_0 -! - DO I = 1, N - U(1,I) = 1.0 - END DO - DO I = 1, N - TMP = U(1,I)*U(1,I) - S(1) = S(1)+TMP - G(1) = G(1)+X(I)*TMP - A(1) = A(1)+U(1,I)*F(I) - END DO - G(1) = G(1)/S(1) - H(1) = 0.0 - A(1) = A(1)/S(1) -! -! Set up the first order polynomial u_1 -! - DO I = 1, N - U(2,I) = X(I)*U(1,I)-G(1)*U(1,I) - S(2) = S(2)+U(2,I)**2 - G(2) = G(2)+X(I)*U(2,I)**2 - H(2) = H(2)+X(I)*U(2,I)*U(1,I) - A(2) = A(2)+U(2,I)*F(I) - END DO - G(2) = G(2)/S(2) - H(2) = H(2)/S(1) - A(2) = A(2)/S(2) -! -! Higher order polynomials u_k from the recursive relation -! - IF(M.GE.3) THEN - DO I = 2, M-1 - DO J = 1, N - U(I+1,J) = X(J)*U(I,J)-G(I)*U(I,J)-H(I)*U(I-1,J) - S(I+1) = S(I+1) + U(I+1,J)**2 - G(I+1) = G(I+1) + X(J)*U(I+1,J)**2 - H(I+1) = H(I+1) + X(J)*U(I+1,J)*U(I,J) - A(I+1) = A(I+1) + U(I+1,J)*F(J) - END DO - G(I+1) = G(I+1)/S(I+1) - H(I+1) = H(I+1)/S(I) - A(I+1) = A(I+1)/S(I+1) - END DO - END IF -END SUBROUTINE PFIT diff --git a/samples/book/two/code23.f90 b/samples/book/two/code23.f90 deleted file mode 100644 --- a/samples/book/two/code23.f90 +++ /dev/null @@ -1,110 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! foo 2.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM MILLIKAN -! -! Main program for a linear fit of the Millikan experimental -! data on the fundamental charge e_0 from e_n = e_0*n + de. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=15,M=2 - INTEGER :: I - REAL :: SUM0,SUMT,E0,DE - REAL, DIMENSION (N) :: X,F - REAL, DIMENSION (M) :: A - REAL, DIMENSION (M,N) :: U - DATA X /4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0, & - 12.0,13.0,14.0,15.0,16.0,17.0,18.0/ - DATA F /6.558,8.206,9.880,11.50,13.14,14.81,16.40,18.04, & - 19.68,21.32,22.96,24.60,26.24,27.88,29.52/ -! - CALL PFIT (N,M,X,F,A,U) - SUM0 = 0.0 - SUMT = 0.0 - DO I = 1, N - SUM0 = SUM0+U(1,I)**2 - SUMT = SUMT+X(I)*U(1,I)**2 - END DO - E0 = A(2) - DE = A(1)-A(2)*SUMT/SUM0 - WRITE (6,"(2F16.8)") E0,DE -END PROGRAM MILLIKAN -! -SUBROUTINE PFIT (N,M,X,F,A,U) -! -! Subroutine generating orthonormal polynomials U(M,N) up to -! (M-1)th order and coefficients A(M), for the least squares -! approximation of the function F(N) at X(N). Other variables -! used: G(K) for g_k, H(K) for h_k, S(K) for . -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: NMAX=101,MMAX=101 - INTEGER, INTENT (IN) :: N,M - INTEGER :: I,J - REAL :: TMP - REAL, INTENT (IN), DIMENSION (N) :: X,F - REAL, INTENT (OUT), DIMENSION (M) :: A - REAL, INTENT (OUT), DIMENSION (M,N) :: U - REAL, DIMENSION (MMAX) :: G,H,S -! - IF(N.GT.NMAX) STOP 'Too many points' - IF(M.GT.MMAX) STOP 'Order too high' -! -! Set up the zeroth order polynomial u_0 -! - DO I = 1, N - U(1,I) = 1.0 - END DO - DO I = 1, N - TMP = U(1,I)*U(1,I) - S(1) = S(1)+TMP - G(1) = G(1)+X(I)*TMP - A(1) = A(1)+U(1,I)*F(I) - END DO - G(1) = G(1)/S(1) - H(1) = 0.0 - A(1) = A(1)/S(1) -! -! Set up the first order polynomial u_1 -! - DO I = 1, N - U(2,I) = X(I)*U(1,I)-G(1)*U(1,I) - S(2) = S(2)+U(2,I)**2 - G(2) = G(2)+X(I)*U(2,I)**2 - H(2) = H(2) + X(I)*U(2,I)*U(1,I) - A(2) = A(2)+U(2,I)*F(I) - END DO - G(2) = G(2)/S(2) - H(2) = H(2)/S(1) - A(2) = A(2)/S(2) -! -! Higher order polynomials u_k from the recursive relation -! - IF(M.GE.3) THEN - DO I = 2, M-1 - DO J = 1, N - U(I+1,J) = X(J)*U(I,J)-G(I)*U(I,J)-H(I)*U(I-1,J) - S(I+1) = S(I+1) + U(I+1,J)**2 - G(I+1) = G(I+1) + X(J)*U(I+1,J)**2 - H(I+1) = H(I+1) + X(J)*U(I+1,J)*U(I,J) - A(I+1) = A(I+1) + U(I+1,J)*F(J) - END DO - G(I+1) = G(I+1)/S(I+1) - H(I+1) = H(I+1)/S(I) - A(I+1) = A(I+1)/S(I+1) - END DO - END IF -END SUBROUTINE PFIT diff --git a/samples/book/two/code24.f90 b/samples/book/two/code24.f90 deleted file mode 100644 --- a/samples/book/two/code24.f90 +++ /dev/null @@ -1,67 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM DERIVATIVES -! -! Main program for derivatives of f(x) = sin(x). F1: f'; -! F2: f"; D1: error in f'; and D2: error in f". -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=101 - INTEGER :: I - REAL :: PI,H - REAL, DIMENSION (N) :: X,F,F1,D1,F2,D2 -! - PI = 4.0*ATAN(1.0) - H = PI/(2*100) - DO I = 1, N - X(I) = H*(I-1) - F(I) = SIN(X(I)) - END DO - CALL THREE(N,H,F,F1,F2) - DO I = 1, N - D1(I) = F1(I)-COS(X(I)) - D2(I) = F2(I)+SIN(X(I)) - WRITE (6, "(5F10.6)") X(I),F1(I),D1(I),F2(I),D2(I) - END DO -END PROGRAM DERIVATIVES -! -SUBROUTINE THREE (N,H,FI,F1,F2) -! -! Subroutine for 1st and 2nd order derivatives with the three-point -! formulas. Extrapolations are made at the boundaries. FI: input -! f(x); H: interval; F1: f'; and F2: f". Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL, INTENT (IN), DIMENSION (N) :: FI - REAL, INTENT (OUT), DIMENSION (N) :: F1,F2 -! -! f' and f" from three-point formulas -! - DO I = 2, N-1 - F1(I) = (FI(I+1)-FI(I-1))/(2.*H) - F2(I) = (FI(I+1)-2.0*FI(I)+FI(I-1))/(H*H) - END DO -! -! Linear extrapolation for the boundary points -! - F1(1) = 2.0*F1(2)-F1(3) - F1(N) = 2.0*F1(N-1)-F1(N-2) - F2(1) = 2.0*F2(2)-F2(3) - F2(N) = 2.0*F2(N-1)-F2(N-2) -END SUBROUTINE THREE diff --git a/samples/book/two/code25.f90 b/samples/book/two/code25.f90 deleted file mode 100644 --- a/samples/book/two/code25.f90 +++ /dev/null @@ -1,64 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM INTEGRAL -! -! Main program for evaluation of an integral with integrand -! sin(x) in the region of [0,pi/2]. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=9 - INTEGER :: I - REAL :: PI,H,S - REAL, DIMENSION (N) :: X,F -! - PI = 4.0*ATAN(1.0) - H = PI/(2*(N-1)) - DO I = 1, N - X(I) = H*(I-1) - F(I) = SIN(X(I)) - END DO - CALL SIMP (N,H,F,S) - WRITE (6, "(F16.8)") S -END PROGRAM INTEGRAL -! -SUBROUTINE SIMP (N,H,FI,S) -! -! Subroutine for integration over f(x) with the Simpson rule. FI: -! integrand f(x); H: interval; S: integral. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL :: S0,S1,S2 - REAL, INTENT (OUT) :: S - REAL, INTENT (IN), DIMENSION (N) :: FI -! - S = 0.0 - S0 = 0.0 - S1 = 0.0 - S2 = 0.0 - DO I = 2, N-1, 2 - S1 = S1+FI(I-1) - S0 = S0+FI(I) - S2 = S2+FI(I+1) - END DO - S = H*(S1+4.0*S0+S2)/3.0 -! -! If N is even, add the last slice separately -! - IF (MOD(N,2).EQ.0) S = S & - +H*(5.0*FI(N)+8.0*FI(N-1)-FI(N-2))/12.0 -END SUBROUTINE SIMP diff --git a/samples/book/two/code26.f90 b/samples/book/two/code26.f90 deleted file mode 100644 --- a/samples/book/two/code26.f90 +++ /dev/null @@ -1,49 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM BISECTION -! -! This program uses the bisection method to find the root of -! f(x)=exp(x)*ln(x)-x*x=0. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER :: ISTEP - REAL :: A,B,DL,DX,X0,X1,F,FX -! - DL = 1.0E-06 - A = 1.0 - B = 2.0 - DX = B - A - ISTEP = 0 - DO WHILE (ABS(DX).GT.DL) - X0 = (A+B)/2.0 - IF ((FX(A)*FX(X0)).LT.0) THEN - B = X0 - DX = B-A - ELSE - A = X0 - DX = B-A - END IF - ISTEP = ISTEP+1 - END DO - WRITE (6,"(I4,2F16.8)") ISTEP,X0,DX -END PROGRAM BISECTION -! -FUNCTION FX(X) RESULT (F) - IMPLICIT NONE - REAL :: F - REAL, INTENT (IN) :: X -! - F = EXP(X)*ALOG(X)-X*X -END FUNCTION FX diff --git a/samples/book/two/code27.f90 b/samples/book/two/code27.f90 deleted file mode 100644 --- a/samples/book/two/code27.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.7 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM NEWTON -! -! This program uses the Newton method to find the root of -! f(x)=exp(x)*ln(x)-x*x=0. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER :: ISTEP - REAL :: A,B,DL,DX,X0,X1,F,FX,DF,DFX -! - DL = 1.0E-06 - A = 1.0 - B = 2.0 - DX = B-A - X0 = (A+B)/2.0 - ISTEP = 0 - DO WHILE (ABS(DX).GT.DL) - X1 = X0-FX(X0)/DFX(X0) - DX = X1-X0 - X0 = X1 - ISTEP = ISTEP+1 - END DO - WRITE (6,"(I4,2F16.8)") ISTEP,X0,DX -END PROGRAM NEWTON -! -FUNCTION FX(X) RESULT (F) - IMPLICIT NONE - REAL :: F - REAL, INTENT (IN) :: X -! - F = EXP(X)*ALOG(X)-X*X -END FUNCTION FX -! -FUNCTION DFX (X) RESULT (DF) - IMPLICIT NONE - REAL :: DF - REAL, INTENT (IN) :: X -! - DF = EXP(X)*(ALOG(X)+1.0/X)-2.0*X -END FUNCTION DFX diff --git a/samples/book/two/code28.f90 b/samples/book/two/code28.f90 deleted file mode 100644 --- a/samples/book/two/code28.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ROOT -! -! Main program to use the Secant Method to find the root of -! f(x)=exp(x)*ln(x)-x*x=0. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER :: ISTEP - REAL :: A,B,DL,DX,X0 -! - DL = 1.0E-06 - A = 1.0 - B = 2.0 - DX = (B-A)/10.0 - X0 = (A+B)/2.0 - CALL SECANT (DL,X0,DX,ISTEP) - - WRITE (6,"(I4,2F16.8)") ISTEP,X0,DX -END PROGRAM ROOT -! -SUBROUTINE SECANT (DL,X0,DX,ISTEP) -! -! Subroutine for the root of f(x)=0 with the secant method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (INOUT) :: ISTEP - REAL, INTENT (INOUT) :: X0,DX - REAL :: X1,X2,D,F,FX - REAL, INTENT (IN) :: DL -! - ISTEP = 0 - X1 = X0+DX - DO WHILE (ABS(DX).GT.DL) - D = FX(X1)-FX(X0) - X2 = X1-FX(X1)*(X1-X0)/D - X0 = X1 - X1 = X2 - DX = X1-X0 - ISTEP = ISTEP+1 - END DO -END SUBROUTINE SECANT -! -FUNCTION FX(X) RESULT (F) - IMPLICIT NONE - REAL :: F - REAL, INTENT (IN) :: X -! - F = EXP(X)*ALOG(X)-X*X -END FUNCTION FX diff --git a/samples/book/two/code29.f90 b/samples/book/two/code29.f90 deleted file mode 100644 --- a/samples/book/two/code29.f90 +++ /dev/null @@ -1,84 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.9 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CB - REAL :: EE2,A0,R0 -END MODULE CB -! -PROGRAM BOND -! -! Main program to calculate the bond length of NaCl. -! Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - INTEGER :: ISTEP - REAL :: DL,X0,DX -! - A0 = 1090.0 - R0 = 0.33 - EE2 = 14.4 - DL = 1.0E-06 - X0 = 2.0 - DX = 0.1 - CALL M_SECANT (DL,X0,DX,ISTEP) - WRITE (6,"(I4,2F16.8)") ISTEP,X0,DX -END PROGRAM BOND -! -SUBROUTINE M_SECANT (DL,X0,DX,ISTEP) -! -! Subroutine for the root of f(x) = dg(x)/dx = 0 with the -! secant method with the search toward the maximum of g(x). -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (OUT) :: ISTEP - REAL, INTENT (IN) :: DL - REAL, INTENT (INOUT) :: X0,DX - REAL :: G0,G1,G2,X1,X2,D,G,GX,F,FX -! - ISTEP = 0 - G0 = GX(X0) - X1 = X0+DX - G1 = GX(X1) - IF(G1.LT.G0) X1 = X0-DX - DO WHILE (ABS(DX).GT.DL) - D = FX(X1)-FX(X0) - DX = -(X1-X0)*FX(X1)/D - X2 = X1+DX - G2 = GX(X2) - IF(G2.LT.G1) X2 = X1-DX - X0 = X1 - X1 = X2 - G1 = G2 - ISTEP = ISTEP+1 - END DO - X0 = X2 -END SUBROUTINE M_SECANT -! -FUNCTION GX(X) RESULT(G) - USE CB - IMPLICIT NONE - REAL :: X,G -! - G = EE2/X-A0*EXP(-X/R0) -END FUNCTION GX -! -FUNCTION FX(X) RESULT(F) - USE CB - IMPLICIT NONE - REAL :: X,F -! - F = EE2/(X*X)-A0*EXP(-X/R0)/R0 -END FUNCTION FX diff --git a/samples/book/two/code2a.f90 b/samples/book/two/code2a.f90 deleted file mode 100644 --- a/samples/book/two/code2a.f90 +++ /dev/null @@ -1,94 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.A !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM INTERPOLATION2 -! -! Main program for the Lagrange interpolation with the -! upward and downward correction method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=5 - REAL :: X,F,DF - REAL, DIMENSION (N) :: XI,FI - DATA XI/0.0,0.5,1.0,1.5,2.0/, & - FI/1.0,0.938470,0.765198,0.511828,0.223891/ -! - X = 0.9 - CALL UPDOWN (N,XI,FI,X,F,DF) - WRITE (6,"(3F16.8)") X,F,DF -END PROGRAM INTERPOLATION2 -! -SUBROUTINE UPDOWN (N,XI,FI,X,F,DF) -! -! Subroutine performing the Lagrange interpolation with the -! upward and downward correction method. F: interpolated -! value. DF: error estimated. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: NMAX=21 - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,I0,J0,IT,K - REAL, INTENT (IN) :: X - REAL, INTENT (OUT) :: F,DF - REAL :: DX,DXT,DT - REAL, INTENT (IN), DIMENSION (N) :: XI,FI - REAL, DIMENSION (NMAX,NMAX) :: DP,DM -! - IF (N.GT.NMAX) STOP 'Dimension of the data set is too large.' - DX = ABS(XI(N)-XI(1)) - DO I = 1, N - DP(I,I) = FI(I) - DM(I,I) = FI(I) - DXT = ABS(X-XI(I)) - IF (DXT.LT.DX) THEN - I0 = I - DX = DXT - END IF - END DO - J0 = I0 -! -! Evaluate correction matrices -! - DO I = 1, N-1 - DO J = 1, N-I - K = J+I - DT =(DP(J,K-1)-DM(J+1,K))/(XI(K)-XI(J)) - DP(J,K) = DT*(XI(K)-X) - DM(J,K) = DT*(XI(J)-X) - END DO - END DO -! -! Update the approximation -! - F = FI(I0) - IT = 0 - IF(X.LT.XI(I0)) IT = 1 - DO I = 1, N-1 - IF ((IT.EQ.1).OR.(J0.EQ.N)) THEN - I0 = I0-1 - DF = DP(I0,J0) - F = F+DF - IT = 0 - IF (J0.EQ.N) IT = 1 - ELSE IF ((IT.EQ.0).OR.(I0.EQ.1)) THEN - J0 = J0+1 - DF = DM(I0,J0) - F = F+DF - IT = 1 - IF (I0.EQ.1) IT = 0 - END IF - END DO - DF = ABS(DF) -END SUBROUTINE UPDOWN diff --git a/samples/book/two/code2b.f90 b/samples/book/two/code2b.f90 deleted file mode 100644 --- a/samples/book/two/code2b.f90 +++ /dev/null @@ -1,49 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.B !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM MILL -! -! Program to fit the Millikan experimental data to a linear curve -! p(x) = a*x+b directly. One can find a and b from partial D/partial -! a = 0 and partial D/partial b = 0 with D = sum (p(x_i)-f(x_i))**2. -! The result is a = (c1*c3-c4*n)/(c1**2-c2*n) and b = (c1*c4-c2*c3) -! /(c1**2-c2*n) with n being the number of points, c1 = sum x_i, c2 -! = sum x_i**2, c3 = sum f(x_i), and c4 = sum x_i*f(x_i). -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER :: N=15 - INTEGER :: I - REAL :: C1,C2,C3,C4,C,A,B - REAL, DIMENSION (N) :: X,F - DATA X /4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0, & - 12.0,13.0,14.0,15.0,16.0,17.0,18.0/ - DATA F /6.558,8.206,9.880,11.50,13.14,14.81,16.40,18.04, & - 19.68,21.32,22.96,24.60,26.24,27.88,29.52/ -! - C1 = 0.0 - C2 = 0.0 - C3 = 0.0 - C4 = 0.0 - DO I = 1, N - C1 = C1+X(I) - C2 = C2+X(I)*X(I) - C3 = C3+F(I) - C4 = C4+F(I)*X(I) - END DO - C = C1*C1-C2*N - A = (C1*C3-C4*N)/C - B = (C1*C4-C2*C3)/C - WRITE (6, "('The fundamental charge is 'F6.4,'+-'F6.4)") A,ABS(B) -END PROGRAM MILL diff --git a/samples/booku/eight/code81.f90 b/samples/booku/eight/code81.f90 deleted file mode 100644 --- a/samples/booku/eight/code81.f90 +++ /dev/null @@ -1,68 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 8.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM GALERKIN -! -! This program solves the one-dimensional Poisson equation with the -! Galerkin method as described in the text. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=99 - INTEGER :: I - REAL :: XL,H,E,B0,B1,XIM,XI,XIP - REAL, unit(p) :: PI - REAL, unit(d) :: D - REAL, DIMENSION (N) :: B,A,Y,W,U -! - PI = 4.0*ATAN(1.0) - XL = 1.0 - H = XL/(N+1) - D = 2.0/H - E = -1.0/H - B0 = PI/H - B1 = 1.0/H -! -! Find the elements in L and U -! - W(1) = D - U(1) = E/D - DO I = 2, N - W(I) = D-E*U(I-1) - U(I) = E/W(I) - END DO -! -! Assign the array B -! - DO I = 1, N - XIM = H*(I-1) - XI = H*I - XIP = H*(I+1) - B(I) = B0*COS(PI*XI)*(XIM+XIP-2.0*XI) & - +B1*(2.0*SIN(PI*XI)-SIN(PI*XIM)-SIN(PI*XIP)) - END DO -! -! Find the solution -! - Y(1) = B(1)/W(1) - DO I = 2, N - Y(I) = (B(I)-E*Y(I-1))/W(I) - END DO -! - A(N) = Y(N) - DO I = N-1,1,-1 - A(I) = Y(I)-U(I)*A(I+1) - END DO -! - WRITE (6,"(2F16.8)") (I*H,A(I), I=1,N) -END PROGRAM GALERKIN diff --git a/samples/booku/five/code51.f90 b/samples/booku/five/code51.f90 deleted file mode 100644 --- a/samples/booku/five/code51.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM DFT_EXAMPLE -! -! Example of the discrete Fourier transform with function f(x) = -! x(1-x) in [0,1]. The inverse transform is also performed for -! comparison. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=128 - INTEGER, PARAMETER :: M=8 - INTEGER :: I - REAL :: F0,H,X - REAL, DIMENSION (N) :: FR,FI,GR,GI -! - F0 = 1.0/SQRT(FLOAT(N)) - H = 1.0/(N-1) -! - DO I = 1, N - X = H*(I-1) - FR(I) = X*(1.0-X) - FI(I) = 0.0 - END DO -! - CALL DFT (FR,FI,GR,GI,N) - DO I = 1, N - GR(I) = F0*GR(I) - GI(I) = F0*GI(I) - END DO -! -! Perform inverse Fourier transform -! - DO I = 1, N - GI(I) = -GI(I) - END DO - CALL DFT (GR,GI,FR,FI,N) - DO I = 1, N - FR(I) = F0*FR(I) - FI(I) = -F0*FI(I) - END DO - WRITE (6,"(2F16.8)") (H*(I-1),FR(I),I=1,N,M) - WRITE (6,"(2F16.8)") H*(N-1),FR(N) -END PROGRAM DFT_EXAMPLE -! -SUBROUTINE DFT (FR,FI,GR,GI,N) -! -! Subroutine to perform the discrete Fourier transform with -! FR and FI as the real and imaginary parts of the input and -! GR and GI as the corresponding output. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J - REAL :: PI,X,Q - REAL, INTENT (IN), DIMENSION (N) :: FR,FI - REAL, INTENT (OUT), DIMENSION (N) :: GR,GI -! - PI = 4.0*ATAN(1.0) - X = 2*PI/N -! - DO I = 1, N - GR(I) = 0.0 - GI(I) = 0.0 - DO J = 1, N - Q = X*(J-1)*(I-1) - GR(I) = GR(I)+FR(J)*COS(Q)+FI(J)*SIN(Q) - GI(I) = GI(I)+FI(J)*COS(Q)-FR(J)*SIN(Q) - END DO - END DO -END SUBROUTINE DFT diff --git a/samples/booku/five/code52.f90 b/samples/booku/five/code52.f90 deleted file mode 100644 --- a/samples/booku/five/code52.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - SUBROUTINE FFT (AR,AI,N,M) -! -! An example of the fast Fourier transform subroutine with N = 2**M. -! AR and AI are the real and imaginary part of data in the input and -! corresponding Fourier coefficients in the output. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: N1,N2,I,J,K,L,L1,L2 - REAL, unit(1) :: PI - REAL :: A2,Q,U,V - REAL, unit(a) :: A1 - REAL, INTENT (INOUT), DIMENSION (N) :: AR,AI -! - PI = 4.0*ATAN(1.0) - N2 = N/2 -! - N1 = 2**M - IF(N1.NE.N) STOP 'Indices do not match' -! -! Rearrange the data to the bit reversed order -! - L = 1 - DO K = 1, N-1 - IF (K.LT.L) THEN - A1 = AR(L) - A2 = AI(L) - AR(L) = AR(K) - AR(K) = A1 - AI(L) = AI(K) - AI(K) = A2 - END IF - J = N2 - DO WHILE (J.LT.L) - L = L-J - J = J/2 - END DO - L = L+J - END DO -! -! Perform additions at all levels with reordered data -! - L2 = 1 - DO L = 1, M - Q = 0.0 - L1 = L2 - L2 = 2*L1 - DO K = 1, L1 - U = COS(Q) - V = -SIN(Q) - Q = Q + PI/L1 - DO J = K, N, L2 - I = J + L1 - A1 = AR(I)*U-AI(I)*V - A2 = AR(I)*V+AI(I)*U - AR(I) = AR(J)-A1 - AR(J) = AR(J)+A1 - AI(I) = AI(J)-A2 - AI(J) = AI(J)+A2 - END DO - END DO - END DO -END SUBROUTINE FFT diff --git a/samples/booku/five/code53.f90 b/samples/booku/five/code53.f90 deleted file mode 100644 --- a/samples/booku/five/code53.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE FFT2D (FR,FI,N1,N2,M1,M2) -! -! Subroutine for the two-dimensional fast Fourier transform -! with N=N1*N2 and N1=2**M1 and N2=2**M2. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N1,N2,M1,M2 - INTEGER :: I,J - REAL, INTENT (INOUT), DIMENSION (N1,N2) :: FR,FI -! -! Transformation on the second index -! - DO I = 1, N1 - CALL FFT (FR(I,1),FI(I,1),N2,M2) - END DO -! -! Transformation on the first index -! - DO J = 1, N2 - CALL FFT (FR(1,J),FI(1,J),N1,M1) - END DO -END SUBROUTINE FFT2D -! - SUBROUTINE FFT (AR,AI,N,M) -! -! An example of the fast Fourier transform subroutine with N = 2**M. -! AR and AI are the real and imaginary part of data in the input and -! corresponding Fourier coefficients in the output. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER :: N1,N2,I,J,K,L,L1,L2 - REAL, unit(1) :: PI - REAL, unit(a) :: A1 - REAL :: A2,Q,U,V - REAL, INTENT (INOUT), DIMENSION (N) :: AR,AI -! - PI = 4.0*ATAN(1.0) - N2 = N/2 -! - N1 = 2**M - IF(N1.NE.N) STOP 'Indices do not match' -! -! Rearrange the data to the bit reversed order -! - L = 1 - DO K = 1, N-1 - IF (K.LT.L) THEN - A1 = AR(L) - A2 = AI(L) - AR(L) = AR(K) - AR(K) = A1 - AI(L) = AI(K) - AI(K) = A2 - END IF - J = N2 - DO WHILE (J.LT.L) - L = L-J - J = J/2 - END DO - L = L+J - END DO -! -! Perform additions at all levels with reordered data -! - L2 = 1 - DO L = 1, M - Q = 0.0 - L1 = L2 - L2 = 2*L1 - DO K = 1, L1 - U = COS(Q) - V = -SIN(Q) - Q = Q + PI/L1 - DO J = K, N, L2 - I = J + L1 - A1 = AR(I)*U-AI(I)*V - A2 = AR(I)*V+AI(I)*U - AR(I) = AR(J)-A1 - AR(J) = AR(J)+A1 - AI(I) = AI(J)-A2 - AI(J) = AI(J)+A2 - END DO - END DO - END DO -END SUBROUTINE FFT diff --git a/samples/booku/five/code54.f90 b/samples/booku/five/code54.f90 deleted file mode 100644 --- a/samples/booku/five/code54.f90 +++ /dev/null @@ -1,31 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE LGND (LMAX,X,P) -! -! Subroutine to generate Legendre polynomials P_L(X) -! for L = 0,1,...,LMAX with given X. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: LMAX - INTEGER, unit(l) :: L - REAL, INTENT (IN) :: X - REAL, INTENT (OUT), DIMENSION (0:LMAX) :: P -! - P(0) = 1.0 - P(1) = X - DO L = 1, LMAX-1 - P(L+1) = ((2.0*L+1)*X*P(L)-L*P(L-1))/(L+1) - END DO -END SUBROUTINE LGND diff --git a/samples/booku/five/code55.f90 b/samples/booku/five/code55.f90 deleted file mode 100644 --- a/samples/booku/five/code55.f90 +++ /dev/null @@ -1,64 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 5.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE BSSL (BJ,BY,N,X) -! -! Subroutine to generate J_n(x) and Y_n(x) with given x and -! up to N=NMAX-NTEL. -! - INTEGER, PARAMETER, unit(nm) :: NMAX=30 - INTEGER, PARAMETER, unit(nt) :: NTEL=5 - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K - REAL, INTENT (IN) :: X - REAL :: SUM1 - REAL, unit(p) :: PI - REAL, unit(g) :: GAMMA - REAL, unit(s) :: SUM - REAL, INTENT (OUT), DIMENSION (0:N) :: BJ,BY - REAL, DIMENSION (0:NMAX) :: B1 -! - PI = 4.0*ATAN(1.0) - GAMMA = 0.5772156649 -! - B1(NMAX) = 0.0 - B1(NMAX-1) = 1.0 -! -! Generating J_n(x) -! - SUM = 0.0 - DO I = NMAX-1, 1, -1 - B1(I-1) = 2*I*B1(I)/X-B1(I+1) - IF (MOD(I,2).EQ.0) SUM = SUM+2.0*B1(I) - END DO - SUM = SUM+B1(0) -! - DO I = 0, N - BJ(I) = B1(I)/SUM - END DO -! -! Generating Y_n(x) starts here -! - SUM1 = 0.0 - DO K = 1, NMAX/2 - SUM1 = SUM1+(-1)**K*B1(2*K)/K - END DO -! - SUM1 = -4.0*SUM1/(PI*SUM) - BY(0) = 2.0*(ALOG(X/2.0)+GAMMA)*BJ(0)/PI+SUM1 - BY(1) = (BJ(1)*BY(0)-2.0/(PI*X))/BJ(0) - DO I = 1, N-1 - BY(I+1) = 2*I*BY(I)/X-BY(I-1) - END DO -END SUBROUTINE BSSL diff --git a/samples/booku/four/code41.f90 b/samples/booku/four/code41.f90 deleted file mode 100644 --- a/samples/booku/four/code41.f90 +++ /dev/null @@ -1,83 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - INTEGER :: J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, unit(1/p) :: C1 - REAL :: PI1,PJ - REAL, unit(p) :: PI - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/booku/four/code42.f90 b/samples/booku/four/code42.f90 deleted file mode 100644 --- a/samples/booku/four/code42.f90 +++ /dev/null @@ -1,116 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE DTRM (A,N,D,INDX) -! -! Subroutine for evaluating the determinant of a matrix using -! the partial-pivoting Gaussian elimination scheme. -! Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,MSGN - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, INTENT (OUT) :: D - REAL, INTENT (INOUT), DIMENSION (N,N) :: A -! - CALL ELGS(A,N,INDX) -! - D = 1.0 - DO I = 1, N - D = D*A(INDX(I),I) - END DO -! - MSGN = 1 - DO I = 1, N - DO WHILE (I.NE.INDX(I)) - MSGN = -MSGN - J = INDX(I) - INDX(I) = INDX(J) - INDX(J) = J - END DO - END DO - D = MSGN*D -END SUBROUTINE DTRM -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - INTEGER :: J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, unit(1/p) :: C1 - REAL :: PI1,PJ - REAL, unit(p) :: PI - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/booku/four/code44.f90 b/samples/booku/four/code44.f90 deleted file mode 100644 --- a/samples/booku/four/code44.f90 +++ /dev/null @@ -1,127 +0,0 @@ -! Updated 10/24/2001. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE MIGS (A,N,X,INDX) -! -! Subroutine to invert matrix A(N,N) with the inverse stored -! in X(N,N) in the output. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I,J,K - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, INTENT (IN), DIMENSION (N,N):: A - REAL, INTENT (OUT), DIMENSION (N,N):: X - REAL, DIMENSION (N,N) :: B -! - DO I = 1, N - DO J = 1, N - B(I,J) = 0.0 - END DO - END DO - DO I = 1, N - B(I,I) = 1.0 - END DO -! - CALL ELGS (A,N,INDX) -! - DO I = 1, N-1 - DO J = I+1, N - DO K = 1, N - B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K) - END DO - END DO - END DO -! - DO I = 1, N - X(N,I) = B(INDX(N),I)/A(INDX(N),N) - DO J = N-1, 1, -1 - X(J,I) = B(INDX(J),I) - DO K = J+1, N - X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I) - END DO - X(J,I) = X(J,I)/A(INDX(J),J) - END DO - END DO -END SUBROUTINE MIGS -! -SUBROUTINE ELGS (A,N,INDX) -! -! Subroutine to perform the partial-pivoting Gaussian elimination. -! A(N,N) is the original matrix in the input and transformed matrix -! plus the pivoting element ratios below the diagonal in the output. -! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - INTEGER :: J,K,ITMP - INTEGER, INTENT (OUT), DIMENSION (N) :: INDX - REAL, unit(p) :: PI - REAL :: PI1,PJ - REAL, unit(1/p) :: C1 - REAL, INTENT (INOUT), DIMENSION (N,N) :: A - REAL, DIMENSION (N) :: C -! -! Initialize the index -! - DO I = 1, N - INDX(I) = I - END DO -! -! Find the rescaling factors, one from each row -! - DO I = 1, N - C1= 0.0 - DO J = 1, N - C1 = AMAX1(C1,ABS(A(I,J))) - END DO - C(I) = C1 - END DO -! -! Search the pivoting (largest) element from each column -! - DO J = 1, N-1 - PI1 = 0.0 - DO I = J, N - PI = ABS(A(INDX(I),J))/C(INDX(I)) - IF (PI.GT.PI1) THEN - PI1 = PI - K = I - ENDIF - END DO -! -! Interchange the rows via INDX(N) to record pivoting order -! - ITMP = INDX(J) - INDX(J) = INDX(K) - INDX(K) = ITMP - DO I = J+1, N - PJ = A(INDX(I),J)/A(INDX(J),J) -! -! Record pivoting ratios below the diagonal -! - A(INDX(I),J) = PJ -! -! Modify other elements accordingly -! - DO K = J+1, N - A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) - END DO - END DO - END DO -! -END SUBROUTINE ELGS diff --git a/samples/booku/four/code45.f90 b/samples/booku/four/code45.f90 deleted file mode 100644 --- a/samples/booku/four/code45.f90 +++ /dev/null @@ -1,37 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE TDPL(A,B,N,X,P) -! -! Subroutine to generate determinant polynomial P_N(X). -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(I) :: I - REAL, INTENT (IN) :: X - REAL :: P0 - REAL, INTENT (IN), DIMENSION (N) :: A,B - REAL, INTENT (OUT), DIMENSION (N) :: P -! - P0 = 1.0 - IF (N.LT.1) STOP 'The dimension is less than 1.' - P(1) = A(1)-X - IF (N.GE.2) P(2) = (A(2)-X)*P(1)-B(1)*B(1)*P0 - IF (N.GE.3) THEN - DO I = 2, N-1 - P(I+1) = (A(I+1)-X)*P(I)-B(I)*B(I)*P(I-1) - END DO - END IF -END SUBROUTINE TDPL diff --git a/samples/booku/four/code46.f90 b/samples/booku/four/code46.f90 deleted file mode 100644 --- a/samples/booku/four/code46.f90 +++ /dev/null @@ -1,86 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.6 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CSEED - INTEGER, unit(i) :: ISEED -END MODULE CSEED -! -SUBROUTINE RMSG (N,XS,A) -! -! Subroutine for generating a random matrix in the Gaussian -! orthogonal ensemble with XS as the standard deviation of -! the off-diagonal elements. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - INTEGER :: J - REAL, INTENT (IN) :: XS - REAL :: G1,G2 - REAL, INTENT (OUT), DIMENSION (N,N) :: A -! - DO I = 1, N - CALL GRNF (G1,G2) - A(I,I) = SQRT(2.0)*G1*XS - END DO -! - DO I = 1, N - DO J = I+1, N - CALL GRNF(G1,G2) - A(I,J) = G1*XS - A(J,I) = A(I,J) - END DO - END DO -END SUBROUTINE RMSG -! -SUBROUTINE GRNF (X,Y) -! -! Two Gaussian random numbers generated from two uniform random -! numbers. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - REAL, INTENT (OUT) :: X,Y - REAL :: PI,R1,R2,R,RANF -! - PI = 4.0*ATAN(1.0) - R1 = -ALOG(1.0-RANF()) - R2 = 2.0*PI*RANF() - R1 = SQRT(2.0*R1) - X = R1*COS(R2) - Y = R1*SIN(R2) -END SUBROUTINE GRNF -! -FUNCTION RANF() RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: IH,IL,IT,IC,IQ - INTEGER, unit(r) :: IR - INTEGER, unit(a) :: IA - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - R = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/booku/one/code11.f90 b/samples/booku/one/code11.f90 deleted file mode 100644 --- a/samples/booku/one/code11.f90 +++ /dev/null @@ -1,51 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 1.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ONE_D_MOTION -! -! Program for the motion of a particle subject to an external -! force f(x) = -x. We have divided the total time 2*pi into -! 10000 intervals with an equal time step. The position and -! velocity of the particle are written out at every 500 steps. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=10001 - INTEGER, PARAMETER, unit(i) :: IN=500 - INTEGER :: I - REAL :: PI - REAL, unit(s) :: DT - REAL, DIMENSION (N):: T,X - real, dimension (N), unit (m/s) :: V -! -! Assign constants, initial position, and initial velocity -! - PI = 4.0*ATAN(1.0) - DT = 2.0*PI/FLOAT(N-1) - X(1) = 0.0 - T(1) = 0.0 - V(1) = 1.0 -! -! Recursion for position and velocity at later time -! - DO I = 1, N-1 - T(I+1) = DT*I - X(I+1) = X(I)+V(I)*DT ! u(x) = u(v * dt) - V(I+1) = V(I)-X(I)*DT ! u(v) = u(x * dt) - END DO -! -! Write the position and velocity every 500 steps -! - WRITE (6,"(3F16.8)") (T(I),X(I),V(I),I=1,N,IN) -END PROGRAM ONE_D_MOTION diff --git a/samples/booku/seven/code71.f90 b/samples/booku/seven/code71.f90 deleted file mode 100644 --- a/samples/booku/seven/code71.f90 +++ /dev/null @@ -1,57 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 7.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM COMET -! -! Program for the time-dependent position of Halley's comet -! with the velocity version of the Verlet algorithm. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=20001 - INTEGER, PARAMETER, unit(np) :: NP=10000 - INTEGER, PARAMETER, unit(ni) :: NI =200 - INTEGER :: I - REAL, unit(h) :: H - REAL, unit(k) :: KAPPA - REAL, DIMENSION (N), unit(x) :: X - REAL, DIMENSION (N) :: Y,VX,VY,GX,GY,T,R -! -! Initialization of the problem -! - H = 1.0/NP - KAPPA = 39.478428 - T(1) = 0.0 - X(1) = 1.966843 - Y(1) = 0.0 - R(1) = X(1) - GX(1) = -KAPPA*X(1)/R(1)**3 - GY(1) = 0.0 - VX(1) = 0.0 - VY(1) = 0.815795 -! -! Verlet algorithm for the position and velocity -! - DO I = 1, N-1 - T(I+1) = I*H - X(I+1) = X(I)+H*VX(I)+H*H*GX(I)/2.0 - Y(I+1) = Y(I)+H*VY(I)+H*H*GY(I)/2.0 - R(I+1) = SQRT(X(I+1)*X(I+1)+Y(I+1)*Y(I+1)) - GX(I+1) = -KAPPA*X(I+1)/R(I+1)**3 - GY(I+1) = -KAPPA*Y(I+1)/R(I+1)**3 - VX(I+1) = VX(I)+H*(GX(I+1)+GX(I))/2.0 - VY(I+1) = VY(I)+H*(GY(I+1)+GY(I))/2.0 - END DO - WRITE (6,"(2F16.8)") (T(I),R(I), I=1,N,NI) -END PROGRAM COMET diff --git a/samples/booku/seven/code72.f90 b/samples/booku/seven/code72.f90 deleted file mode 100644 --- a/samples/booku/seven/code72.f90 +++ /dev/null @@ -1,95 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 7.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CSEED - INTEGER, unit(i) :: ISEED -END MODULE CSEED -! -SUBROUTINE MXWL (N,M,T,V) -! -! This subroutine assigns velocities according to the Maxwell distribution. -! N is the total number of velocity components and M is the total number of -! degrees of freedom. T is the system temperature in the reduced units. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N,M - INTEGER, unit(i) :: I - REAL, INTENT (IN) :: T - REAL :: V1,V2,EK,VS - REAL, INTENT (OUT), DIMENSION (N) :: V -! -! Assign a Gaussian distribution to each velocity component -! - DO I = 1, N-1, 2 - CALL GRNF (V1,V2) - V(I) = V1 - V(I+1) = V2 - END DO -! -! Scale the velocity to satisfy the partition theorem -! - EK = 0.0 - DO I = 1, N - EK = EK+V(I)*V(I) - END DO - VS = SQRT(EK/(M*T)) - DO I = 1, N - V(I) = V(I)/VS - END DO -END SUBROUTINE MXWL -! -SUBROUTINE GRNF (X,Y) -! -! Two Gaussian random numbers generated from two uniform random -! numbers. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - REAL, INTENT (OUT) :: X,Y - REAL :: R ! RANF - REAL, unit(p) :: PI - REAL, unit(1) :: R1 - REAL, unit(rb) :: R2 -! - PI = 4.0*ATAN(1.0) - R1 = -ALOG(1.0-RANF()) - R2 = 2.0*PI*RANF() - R1 = SQRT(2.0*R1) - X = R1*COS(R2) - Y = R1*SIN(R2) -END SUBROUTINE GRNF -! -FUNCTION RANF() !RESULT (R) -! -! Uniform random number generator x(n+1) = a*x(n) mod c with -! a=7**5 and c = 2**(31)-1. Copyright (c) Tao Pang 1997. -! - USE CSEED - IMPLICIT NONE - INTEGER :: IH,IL,IT,IC,IQ - INTEGER, unit(r) :: IR - INTEGER, unit(a) :: IA - DATA IA/16807/,IC/2147483647/,IQ/127773/,IR/2836/ - !REAL :: R -! - IH = ISEED/IQ - IL = MOD(ISEED,IQ) - IT = IA*IL-IR*IH - IF(IT.GT.0) THEN - ISEED = IT - ELSE - ISEED = IC+IT - END IF - RANF = ISEED/FLOAT(IC) -END FUNCTION RANF diff --git a/samples/booku/six/code61.f90 b/samples/booku/six/code61.f90 deleted file mode 100644 --- a/samples/booku/six/code61.f90 +++ /dev/null @@ -1,73 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM BENCH -! -! This program solves the problem of a person sitting on a -! bench as described in the text. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=99 - INTEGER :: I - REAL, unit(x) :: XL - REAL :: H,H2,Y0,X0,F0,D,E,Ee0,XD - REAL, unit(g) :: G - REAL, unit(r) :: RHO - REAL, DIMENSION (N):: B,X,Y,W,U -! - XL = 3.0 - H = XL/(N+1) - H2 = H*H - Y0 = 1.0E09*0.03**3*0.20/3.0 - X0 = 0.25 - RHO = 3.0 - G = 9.8 - F0 = 200.0 - D = 2.0 - E =-1.0 - Ee0 = 1.0/EXP(1.0) -! -! Find elements in L and U -! - W(1) = D - U(1) = E/D - DO I = 2, N - W(I) = D-E*U(I-1) - U(I) = E/W(I) - END DO -! -! Assign the array B -! - DO I = 1, N - XD = H*I - B(I) = -H2*RHO*G - IF (ABS(XD-XL/2.0).LT.X0) THEN - B(I) = B(I)-H2*F0*(EXP(-((XD-XL/2)/X0)**2)-Ee0) - END IF - B(I) = B(I)/Y0 - END DO -! -! Find the solution of the curvature -! - Y(1) = B(1)/W(1) - DO I = 2, N - Y(I) = (B(I)+Y(I-1))/W(I) - END DO -! - X(N) = Y(N) - DO I = N-1,1,-1 - X(I) = Y(I)-U(I)*X(I+1) - END DO - WRITE(6,"(2F20.10)") (H*I,100*X(I),I=1,N) -END PROGRAM BENCH diff --git a/samples/booku/six/code62.f90 b/samples/booku/six/code62.f90 deleted file mode 100644 --- a/samples/booku/six/code62.f90 +++ /dev/null @@ -1,34 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE RLXN (FN,DN,S,N,P,H) -! -! Subroutine performing one iteration of Relaxation for the one-dimensional -! stationary diffusion equation. DN is the diffusion coefficient shifted -! half step towards x=0. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - REAL, INTENT (IN) :: H,P - REAL :: H2,Q - REAL, INTENT (IN), DIMENSION (N) :: DN,S - REAL, INTENT (INOUT), DIMENSION (N) :: FN -! - H2 = H*H - Q = 1.0-P - DO I = 2, N-1 - FN(I) = Q*FN(I)+P*(DN(I+1)*FN(I+1)+DN(I)*FN(I-1)+H2*S(I))/(DN(I+1)+DN(I)) - END DO -END SUBROUTINE RLXN diff --git a/samples/booku/six/code63.f90 b/samples/booku/six/code63.f90 deleted file mode 100644 --- a/samples/booku/six/code63.f90 +++ /dev/null @@ -1,103 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM G_WATER -! -! This program solves the groundwater dynamics problem in the -! rectangular geometry through the relaxation method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(1) :: NX=101 - INTEGER, PARAMETER, unit(1) :: NY=51 - INTEGER, PARAMETER :: ISKX=10,ISKY=5 - INTEGER, PARAMETER, unit(i) :: ITMX=5 - INTEGER :: I,J,ISTP - REAL :: PI,A0,B0,H0,CH,SX,SY,HX,HY,P,X,Y - REAL, DIMENSION (NX,NY) :: PHI,CK,SN -! - PI = 4.0*ATAN(1.0) - A0 = 1.0 - B0 = -0.04 - H0 = 200.0 - CH = -20.0 - SX = 1000.0 - SY = 500.0 - HX = SX/(NX-1) - HY = SY/(NY-1) - P = 0.5 -! -! Set up boundary conditions and initial guess of the solution -! - DO I = 1, NX - X = (I-1)*HX - DO J = 1, NY - Y = (J-1)*HY - SN(I,J) = 0.0 - CK(I,J) = A0+B0*Y - PHI(I,J) = H0+CH*COS(PI*X/SX)*Y/SY - END DO - END DO -! - DO ISTP = 1, ITMX -! -! Ensure the boundary conditions by the 4-point formula -! - DO J = 1, NY - PHI(1,J) = (4.0*PHI(2,J)-PHI(3,J))/3.0 - PHI(NX,J) = (4.0*PHI(NX-1,J)-PHI(NX-2,J))/3.0 - END DO -! - CALL RX2D (PHI,CK,SN,NX,NY,P,HX,HY) - END DO -! - DO I = 1, NX, ISKX - X = (I-1)*HX - DO J = 1, NY, ISKY - Y = (J-1)*HY - WRITE (6,"(3F16.8)") X,Y,PHI(I,J) - END DO - END DO -END PROGRAM G_WATER -! -SUBROUTINE RX2D (FN,DN,S,NX,NY,P,HX,HY) -! -! Subroutine performing one iteration of the relaxation for -! the two-dimensional Poisson equation. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: NX,NY - INTEGER :: I,J - REAL, INTENT (IN) :: HX,HY,P - REAL :: HX2,A,B,Q,CIP,CIM,CJP,CJM - REAL, INTENT (IN), DIMENSION (NX,NY) :: DN,S - REAL, INTENT (INOUT), DIMENSION (NX,NY) :: FN -! - HX2 = HX*HX - A = HX2/(HY*HY) - B = 1.0/(4.0*(1.0+A)) - Q = 1.0-P -! - DO I = 2, NX-1 - DO J = 2, NY-1 - CIP = B*(DN(I+1,J)/DN(I,J)+1.0) - CIM = B*(DN(I-1,J)/DN(I,J)+1.0) - CJP = A*B*(DN(I,J+1)/DN(I,J)+1.0) - CJM = A*B*(DN(I,J-1)/DN(I,J)+1.0) - FN(I,J) = Q*FN(I,J)+P*(CIP*FN(I+1,J)+CIM*FN(I-1,J) & - +CJP*FN(I,J+1)+CJM*FN(I,J-1)+HX2*S(I,J)) - END DO - END DO -END SUBROUTINE RX2D diff --git a/samples/booku/six/code64.f90 b/samples/booku/six/code64.f90 deleted file mode 100644 --- a/samples/booku/six/code64.f90 +++ /dev/null @@ -1,125 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 6.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM N_T_FIELD -! -! This program solves the time dependent temperature field -! around a nuclear waste rod in a two-dimensional model. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(m1) :: M1=1001 - INTEGER, PARAMETER, unit(m) :: M=2001 - INTEGER, PARAMETER :: N=19 - INTEGER :: I,J - REAL :: TC,RB,H,H2,S0,CS,B0,C0,R,T - real, unit(h) :: HT - REAL, unit(x) :: XK - REAL, unit(r) :: RA - REAL, unit(t) :: T0 - REAL, unit(a) :: A0 - REAL, DIMENSION (N) :: A,B,C,Y,G,W,V,U - REAL, DIMENSION (M,N) :: S - REAL, DIMENSION (M,N+1) :: X -! - HT = 1.0/(M1-1) - TC = 1.0 - XK = 3153.6 - RA = 25.0 - RB = 100.0 - H = RB/(N+1) - H2 = H*H - T0 = 10.0 - S0 = HT*XK*T0/RA**2 - CS = HT*XK/H2 -! - DO I = 1, M - DO J = 1, N+1 - X(I,J) = 0.0 - END DO - END DO -! - DO I = 1, N - R = H*I - A(I) = 2.0*(1.0+CS)*R - B(I) = -(1.0+0.5/I)*CS*R - C(I) = -(1.0-0.5/I)*CS*R - IF (R.LT.RA) THEN - S(1,I) = S0*R - ELSE - S(1,I) = 0.0 - END IF - END DO -! -! Assign the source of the radiation heat -! - DO I = 2, M - T = HT*(I-1) - DO J = 1, N - R = H*J - IF (R.LT.RA) THEN - S(I,J) = R*S0/EXP(T/TC) - ELSE - S(I,J) = 0.0 - END IF - END DO - END DO -! - DO I = 2, M -! -! Find the values from the last time step -! - A0 = 2.0*(1.0-CS)*H - B0 = (1.0+0.5)*CS*H - C0 = (1.0-0.5)*CS*H - G(1) = A0*X(I-1,1)+B0*X(I-1,2) & - +C0*(4.0*X(I-1,1)-X(I-1,2))/3.0+S(I-1,1)+S(I,1) - DO J = 2, N - R = J*H - A0 = 2.0*(1.0-CS)*R - B0 = (1.0+0.5/J)*CS*R - C0 = (1.0-0.5/J)*CS*R - G(J) = A0*X(I-1,J)+B0*X(I-1,J+1)+C0*X(I-1,J-1)+(S(I-1,J)+S(I,J)) - END DO -! -! Find the elements in L and U -! - W(1) = A(1) - V(1) = C(1) - U(1) = B(1)/W(1) - DO J = 2, N - V(J) = C(J) - W(J) = A(J)-V(J-1)*U(J-1) - U(J) = B(J)/W(J) - END DO -! -! Find the solution of the temperature -! - Y(1) = G(1)/W(1) - DO J = 2, N - Y(J) = (G(J)-V(J-1)*Y(J-1))/W(J) - END DO -! - X(I,N) = Y(N) - DO J = N-1,1,-1 - X(I,J) = Y(J)-U(J)*X(I,J+1) - END DO - END DO -! - I = M - DO J = 1, N+1 - R = J*H - WRITE (6,"(2F16.8)") R,X(I,J) - END DO -END PROGRAM N_T_FIELD diff --git a/samples/booku/three/code31.f90 b/samples/booku/three/code31.f90 deleted file mode 100644 --- a/samples/booku/three/code31.f90 +++ /dev/null @@ -1,49 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM ONE_D_MOTION2 -! -! Simplest predictor-corector algorithm applied to a particle in one -! dimension under an elastic force. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=101 - INTEGER, PARAMETER, unit(i) :: IN=5 - INTEGER :: I - REAL, unit(pi) :: PI - REAL :: DT - REAL, DIMENSION (N) :: T,X - REAL, DIMENSION (N), unit(v) :: V -! - PI = 4.0*ATAN(1.0) - DT =2.0*PI/100 - X(1)=0.0 - T(1)=0.0 - V(1)=1.0 -! - DO I = 1, N-1 - T(I+1) = I*DT -! -! Predictor for position and velocity -! - X(I+1) = X(I)+V(I)*DT - V(I+1) = V(I)-X(I)*DT -! -! Corrector for position and velocity -! - X(I+1) = X(I)+(V(I)+V(I+1))*DT/2.0 - V(I+1) = V(I)-(X(I)+X(I+1))*DT/2.0 - END DO - WRITE(6,"(3F16.8)") (T(I),X(I),V(I),I=1,N,IN) -END PROGRAM ONE_D_MOTION2 diff --git a/samples/booku/three/code32.f90 b/samples/booku/three/code32.f90 deleted file mode 100644 --- a/samples/booku/three/code32.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.12 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE CB - REAL, unit (q) :: Q - REAL, unit (1) :: B - REAL, unit (w) :: W -END MODULE CB -! -PROGRAM PENDULUM -! -! Main Program for a driven pendulum under damping solved with -! the fourth-order Runge-Kutta algorithm. Parameters: Q, B, -! and W (omega_0). Copyright (c) Tao Pang 1997. -! - USE CB - IMPLICIT NONE - INTEGER, PARAMETER :: N=1000,M=1 - INTEGER, PARAMETER, unit(l) :: L=100 - INTEGER :: I - REAL :: PI,H,T,Y1,Y2,G1,G1F,G2,G2F - REAL :: DK11,DK21,DK12,DK22,DK13,DK23,DK14,DK24 - REAL, DIMENSION (2,N) :: Y -! - PI = 4.0*ATAN(1.0) - H = 3.0*PI/L - Q = 0.5 - B = 0.9 - W = 2.0/3.0 - Y(1,1) = 0.0 - Y(2,1) = 2.0 -! -! Using the Runge-Kutta algorithm to integrate the equation -! - DO I = 1, N-1 - T = H*I - Y1 = Y(1,I) - Y2 = Y(2,I) - DK11 = H*G1F(Y1,Y2,T) - DK21 = H*G2F(Y1,Y2,T) - DK12 = H*G1F((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK22 = H*G2F((Y1+DK11/2.0),(Y2+DK21/2.0),(T+H/2.0)) - DK13 = H*G1F((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK23 = H*G2F((Y1+DK12/2.0),(Y2+DK22/2.0),(T+H/2.0)) - DK14 = H*G1F((Y1+DK13),(Y2+DK23),(T+H)) - DK24 = H*G2F((Y1+DK13),(Y2+DK23),(T+H)) - Y(1,I+1) = Y(1,I)+(DK11+2.0*(DK12+DK13)+DK14)/6.0 - Y(2,I+1) = Y(2,I)+(DK21+2.0*(DK22+DK23)+DK24)/6.0 -! -! Bring theta back to the region [-pi,pi] -! - Y(1,I+1) = Y(1,I+1)-2.0*PI*NINT(Y(1,I+1)/(2.0*PI)) - END DO - WRITE (6,"(2F16.8)") (Y(1,I),Y(2,I),I=1,N,M) -END PROGRAM PENDULUM -! -FUNCTION G1F (Y1,Y2,T) RESULT (G1) - USE CB - IMPLICIT NONE - REAL :: Y1,Y2,T,G1 -! - G1 = Y2 -END FUNCTION G1F -! -FUNCTION G2F (Y1,Y2,T) RESULT (G2) - USE CB - IMPLICIT NONE - REAL :: Y1,Y2,T,G2 -! - G2 = -Q*Y2-SIN(Y1)+B*COS(W*T) -END FUNCTION G2F diff --git a/samples/booku/three/code34.f90 b/samples/booku/three/code34.f90 deleted file mode 100644 --- a/samples/booku/three/code34.f90 +++ /dev/null @@ -1,81 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM S_L_LEGENDRE -! -! Main program for solving the Legendre equation with the simplest -! algorithm for the Sturm-Liouville equation and the bisection method -! for the root search. Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=501 - INTEGER :: ISTEP - REAL :: DL,H,AK,BK,DK,EK,F0,F1 - REAL, DIMENSION (N) :: U -! -! Initialization of the problem -! - DL = 1.0E-06 - H = 2.0/(N-1) - AK = 0.5 - BK = 1.5 - DK = 0.5 - EK = AK - U(1) = -1.0 - U(2) = -1.0+H - ISTEP = 0 - CALL SMPL (N,H,EK,U) - F0 = U(N)-1.0 -! -! Bisection method for the root -! - DO WHILE (ABS(DK).GT.DL) - EK = (AK+BK)/2.0 - CALL SMPL (N,H,EK,U) - F1 = U(N)-1.0 - IF ((F0*F1).LT.0) THEN - BK = EK - DK = BK-AK - ELSE - AK = EK - DK = BK-AK - F0 = F1 - END IF - ISTEP = ISTEP+1 - END DO -! - WRITE (6,"(I4,3F16.8)") ISTEP,EK,DK,F1 -END PROGRAM S_L_LEGENDRE -! -SUBROUTINE SMPL (N,H,EK,U) -! -! The simplest algorithm for the Sturm-Liouville equation. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H,EK - REAL :: H2,Q,X,P,P1 - REAL, INTENT (OUT), DIMENSION (N) :: U -! - H2 = 2.0*H*H - Q = EK*(1.0+EK) - DO I = 2, N-1 - X = (I-1)*H-1.0 - P = 2.0*(1.0-X*X) - P1 = -2.0*X*H - U(I+1) = ((2.0*P-H2*Q)*U(I)+(P1-P)*U(I-1))/(P1+P) - END DO -END SUBROUTINE SMPL diff --git a/samples/booku/three/code3a.f90 b/samples/booku/three/code3a.f90 deleted file mode 100644 --- a/samples/booku/three/code3a.f90 +++ /dev/null @@ -1,39 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.A !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE NMRV (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.77)-(3.80) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - REAL, INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (OUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*((Q(I-1)-Q(I+1))/2.0+Q(I)) - C1 = 2.0-G*(Q(I+1)+Q(I-1)+8.0*Q(I)) - C2 = 1.0+G*((Q(I+1)-Q(I-1))/2.0+Q(I)) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV diff --git a/samples/booku/three/code3b.f90 b/samples/booku/three/code3b.f90 deleted file mode 100644 --- a/samples/booku/three/code3b.f90 +++ /dev/null @@ -1,39 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.B !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE NMRV2 (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.82)-(3.85) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER, unit(i) :: I - REAL,INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (INOUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*Q(I-1) - C1 = 2.0-10.0*G*Q(I) - C2 = 1.0+G*Q(I+1) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV2 diff --git a/samples/booku/three/code3c.f90 b/samples/booku/three/code3c.f90 deleted file mode 100644 --- a/samples/booku/three/code3c.f90 +++ /dev/null @@ -1,97 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 3.C !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM WAVE -! -! Program for the eigenvalue problem with a combination of the -! bisection method and the Numerov algorithm for u" = -k**2*u -! with boundary conditions u(0)=u(1)=0. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(1) :: N=101 - INTEGER :: I - INTEGER, unit(i) :: ISTEP - REAL, unit(dl) :: DL - REAL :: BK,DK,EK,F0,F1 - REAL, unit(h) :: H - REAL, unit(ak) :: AK - REAL, DIMENSION (N) :: Q,S,U -! -! Initialization of the problem -! - DL = 1.0E-06 - H = 1.0/(N-1) - AK = 2.0 - BK = 4.0 - DK = 1.0 - EK = AK - U(1) = 0.0 - U(2) = 0.01 - ISTEP = 0 -! - DO I = 1,N - S(I) = 0.0 - Q(I) = EK*EK - END DO - CALL NMRV (N,H,Q,S,U) - F0 = U(N) -! -! Bisection method for the root -! - DO WHILE (ABS(DK).GT.DL) - EK = (AK+BK)/2.0 - DO I = 1,N - Q(I) = EK*EK - END DO - CALL NMRV (N,H,Q,S,U) - F1 = U(N) - IF ((F0*F1).LT.0) THEN - BK = EK - DK = BK-AK - ELSE - AK = EK - DK = BK-AK - F0 = F1 - END IF - ISTEP = ISTEP+1 - END DO - WRITE (6,"(I4,3F16.8)") ISTEP,EK,DK,F1 -END PROGRAM WAVE -! -SUBROUTINE NMRV (N,H,Q,S,U) -! -! The Numerov algorithm for the equation u"(x)+q(x)u(x)=s(x) -! as given in Eqs. (3.77)-(3.80) in the book. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, INTENT (IN) :: N - INTEGER :: I - REAL, INTENT (IN) :: H - REAL :: G,C0,C1,C2,D,UTMP - REAL, INTENT (IN), DIMENSION (N) :: Q,S - REAL, INTENT (INOUT), DIMENSION (N) :: U -! - G = H*H/12.0 -! - DO I = 2, N-1 - C0 = 1.0+G*((Q(I-1)-Q(I+1))/2.0+Q(I)) - C1 = 2.0-G*(Q(I+1)+Q(I-1)+8.0*Q(I)) - C2 = 1.0+G*((Q(I+1)-Q(I-1))/2.0+Q(I)) - D = G*(S(I+1)+S(I-1)+10.0*S(I)) - UTMP = C1*U(I)-C0*U(I-1)+D - U(I+1) = UTMP/C2 - END DO -END SUBROUTINE NMRV diff --git a/samples/booku/twelve/code121.f90 b/samples/booku/twelve/code121.f90 deleted file mode 100644 --- a/samples/booku/twelve/code121.f90 +++ /dev/null @@ -1,20 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.1 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -SUBROUTINE RPHI_TO_XY (R,PHI,X,Y) - IMPLICIT NONE - REAL, INTENT (IN) :: R,PHI - REAL, INTENT (OUT) :: X,Y - X = R*COS(PHI); Y = R*SIN(PHI) ! Assign x and y -END SUBROUTINE RPHI_TO_XY diff --git a/samples/booku/twelve/code123.f90 b/samples/booku/twelve/code123.f90 deleted file mode 100644 --- a/samples/booku/twelve/code123.f90 +++ /dev/null @@ -1,57 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.3 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -MODULE ORDER_AN_ARRAY - PRIVATE EXCHANGE -! - CONTAINS -! - SUBROUTINE REARRANGE (A) - IMPLICIT NONE - REAL, INTENT(INOUT) :: A(:) - LOGICAL, ALLOCATABLE, unit(1) :: MASK(:) - INTEGER :: I - INTEGER, unit(1) :: N - INTEGER, DIMENSION(1) :: K - N = SIZE (A) - ALLOCATE (MASK(N)) - MASK = .TRUE. - DO I = 0, N-1 - MASK(N-I) = .FALSE. - K = MAXLOC(A,MASK) - CALL EXCHANGE(A(K(1)),A(N-I)) - END DO - END SUBROUTINE REARRANGE -! - SUBROUTINE EXCHANGE (X,Y) - IMPLICIT NONE - REAL, INTENT(INOUT):: X,Y - REAL TX - TX = X; X = Y; Y = TX - END SUBROUTINE EXCHANGE -! -END MODULE ORDER_AN_ARRAY -! -PROGRAM RANDOM_ARRAY_ORDERED - USE ORDER_AN_ARRAY -! - IMPLICIT NONE - INTEGER, PARAMETER :: N = 100 - REAL, DIMENSION(N) :: A - INTEGER :: I -! - CALL RANDOM_NUMBER (A) - CALL REARRANGE (A) - WRITE(6, "(F10.8)") (A(I),I=1,N) -END PROGRAM RANDOM_ARRAY_ORDERED diff --git a/samples/booku/twelve/code124.f90 b/samples/booku/twelve/code124.f90 deleted file mode 100644 --- a/samples/booku/twelve/code124.f90 +++ /dev/null @@ -1,80 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.4 !!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is part of the book, "An Introduction to ! -! Computational Physics," written by Tao Pang and published and ! -! copyrighted by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM LAPLACE_2D -! -! Example program for the 2D Laplace equation as defined -! in the text. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(nx) :: NX=101 - INTEGER, PARAMETER, unit(ny) :: NY=101 - INTEGER I, J, IMAX - REAL, DIMENSION (NX,NY) :: BOUND,U,UTMP, DU - REAL, DIMENSION (NX,NY), unit(f) ::FIELD - REAL :: TL,Q,P,A,B - LOGICAL, DIMENSION (NX,NY), unit(m) :: MASK -! - TL = 1.0E-08 - A = 1.0/(NY-1) - B = 1.0/((NY-1)**2) - P = 0.5 - Q = 1.0 - P -! -! Align the data accordingly -! -!HPF$ DISTRIBUTE U(BLOCK,BLOCK) -! -!HPF$ ALIGN BOUND(:,:) WITH U(:,:) -!HPF$ ALIGN FIELD(:,:) WITH U(:,:) -!HPF$ ALIGN UTMP(:,:) WITH U(:,:) -!HPF$ ALIGN MASK(:,:) WITH U(:,:) -! - MASK = .FALSE. - MASK(2:NX-1,2:NY-1) = .TRUE. -! - BOUND = 0.0 - FIELD = 0.0 - WHERE (MASK) - FIELD = 0.25 - ELSEWHERE - BOUND = 0.25 - END WHERE -! -! Assign the initial value for iteration -! - FORALL (I=1:NX,J=1:NY) U(I,J) = A*(J-1)*(NX-I)/(NX-1) & - +B*(J-1)**2*(I-1)/(NX-1) -! -! The main iteration loop -! - DO I = 1, IMAX - UTMP = FIELD*( CSHIFT(U,SHIFT= 1,DIM=1) & - + CSHIFT(U,SHIFT= 1,DIM=2) & - + CSHIFT(U,SHIFT=-1,DIM=1) & - + CSHIFT(U,SHIFT=-1,DIM=2) ) & - + BOUND - DU = U - UTMP - U = Q*U + P*UTMP - DU = MAXVAL(ABS(U - UTMP)) - IF (DU.LE.TL) EXIT - END DO - IF (I.NE.IMAX) THEN - PRINT*, 'The number of iteration is ', I, & -' and the largest error is ', DU - PRINT*, 'The solution is ', U - ELSE - PRINT*, 'The required convergence is not reached yet' - END IF -END PROGRAM LAPLACE_2D diff --git a/samples/booku/twelve/code125.f90.save b/samples/booku/twelve/code125.f90.save deleted file mode 100644 --- a/samples/booku/twelve/code125.f90.save +++ /dev/null @@ -1,42 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 12.5 !!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM TALK_0_TO_1 - INCLUDE 'mpif.h' - INTEGER :: IRANK,IPROC,ITAG,ISEND,IRECV,IERR,IM,ID,IFINISH - INTEGER, DIMENSION (MPI_STATUS_SIZE) :: ISTAT - CHARACTER*40 :: HELLO -! - ITAG = 730 - ID = 40 - ISEND = 0 - IRECV = 1 - CALL MPI_INIT (IERR) - CALL MPI_COMM_RANK (MPI_COMM_WORLD,IRANK,IERR) - CALL MPI_COMM_SIZE (MPI_COMM_WORLD,IPROC,IERR) - PRINT*, IRANK, IPROC - CALL MPI_BARRIER (MPI_COMM_WORLD,IERR) - IF (IRANK.EQ.ISEND) THEN - HELLO = 'I am process 0, who are you ?' - IM = 29 - CALL MPI_SEND (HELLO,IM,MPI_CHARACTER,IRECV, & - ITAG,MPI_COMM_WORLD,IERR) - PRINT*, 'I sent the message: ', HELLO - ELSE IF (IRANK.EQ.IRECV) THEN - CALL MPI_RECV (HELLO,ID,MPI_CHARACTER,ISEND, & - ITAG,MPI_COMM_WORLD,ISTAT,IERR) - PRINT*, 'I got your message which is: ', HELLO - END IF - CALL MPI_FINALIZE(IFINISH) -END PROGRAM TALK_0_TO_1 diff --git a/samples/booku/two/code21.f90 b/samples/booku/two/code21.f90 deleted file mode 100644 --- a/samples/booku/two/code21.f90 +++ /dev/null @@ -1,64 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 2.1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Please Note: ! -! ! -! (1) This computer program is written by Tao Pang in conjunction with ! -! his book, "An Introduction to Computational Physics," published ! -! by Cambridge University Press in 1997. ! -! ! -! (2) No warranties, express or implied, are made for this program. ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -PROGRAM INTERPOLATION -! -! Main program for the Lagrange interpolation with the Aitken method. -! Copyright (c) Tao Pang 1997. -! - IMPLICIT NONE - INTEGER, PARAMETER, unit(n) :: N=5 - REAL :: F,DF - real, unit(1) :: X - REAL, DIMENSION (N) :: XI,FI - DATA XI/0.0,0.5,1.0,1.5,2.0/, & - FI/1.0,0.938470,0.765198,0.511828,0.223891/ -! - X = 0.9 - CALL AITKEN (N,XI,FI,X,F,DF) - WRITE (6,"(3F16.8)") X,F,DF -END PROGRAM INTERPOLATION -! -SUBROUTINE AITKEN (N,XI,FI,X,F,DF) -! -! Subroutine performing the Lagrange interpolation with the -! Aitken method. F: interpolated value. DF: error estimated. -! Copyright (c) Tao Pang 1997. -! - INTEGER, PARAMETER, unit(n) :: NMAX=21 - INTEGER, INTENT (IN) :: N - INTEGER :: I,J - REAL, INTENT (IN) :: X - REAL, INTENT (OUT) :: F,DF - REAL :: X1,X2,F1,F2 - REAL, INTENT (IN), DIMENSION (N):: XI,FI - REAL, DIMENSION (NMAX):: FT -! - IF (N.GT.NMAX) STOP 'Dimension of the data is too large.' - DO I = 1, N - FT(I) = FI(I) - END DO -! - DO I = 1, N-1 - DO J = 1, N-I - X1 = XI(J) - X2 = XI(J+I) - F1 = FT(J) - F2 = FT(J+1) - FT(J) = (X-X1)/(X2-X1)*F2+(X-X2)/(X1-X2)*F1 - END DO - END DO - F = FT(1) - DF = (ABS(F-F1)+ABS(F-F2))/2.0 -END SUBROUTINE AITKEN diff --git a/samples/booku/two/code21.f90.html b/samples/booku/two/code21.f90.html deleted file mode 100644 --- a/samples/booku/two/code21.f90.html +++ /dev/null @@ -1,1 +0,0 @@ -
program INTERPOLATION
   implicit none
   integer, parameter , unit(n) :: N = 5
   real :: F,DF
   real, unit(x) :: X
   real, dimension (N) :: XI,FI
   data /XI/0.0,0.5,1.0,1.5,2.0
/FI/1.0,0.938470,0.765198,0.511828,0.223891
   X = 0.9
   call AITKEN(N,XI,FI,X,F,DF)
   write (number = 6,'"(3F16.8)"') X,F,DF
end program INTERPOLATION
subroutine AITKEN(N,XI,FI,X,F,DF)
   integer, parameter , unit(n) :: NMAX = 21
   integer, intent(in)  :: N
   integer :: I,J
   real, intent(in)  :: X
   real, intent(out)  :: F,DF
   real :: X1,X2,F1,F2
   real, intent(in) , dimension (N) :: XI,FI
   real, dimension (NMAX) :: FT
   if (N>NMAX) then
      stop 'Dimension of the data is too large.'
   end if
   do I = 1, N, 1
      FT(I) = FI(I)
   end do
   do I = 1, N-1, 1
      do J = 1, N-I, 1
         X1 = XI(J)
         X2 = XI(J+I)
         F1 = FT(J)
         F2 = FT(J+1)
         FT(J) = ((X-X1)/(X2-X1))*F2+((X-X2)/(X1-X2))*F1
      end do
   end do
   F = FT(1)
   DF = (ABS(F-F1)+ABS(F-F2))/2.0
end subroutine AITKEN

diff --git a/samples/booku/two/code210.f90 b/samples/booku/two/code210.f90
deleted file mode 100644
--- a/samples/booku/two/code210.f90
+++ /dev/null
@@ -1,188 +0,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!   Program 2.10   !!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!                                                                       !
-! Please Note:                                                          !
-!                                                                       !
-! (1) This computer program is written by Tao Pang in conjunction with  !
-!     his book, "An Introduction to Computational Physics," published   !
-!     by Cambridge University Press in 1997.                            !
-!                                                                       !
-! (2) No warranties, express or implied, are made for this program.     !
-!                                                                       !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-MODULE CB
-  REAL,  unit(b) :: B
-  REAL, unit(e) :: E
-  REAL, unit(a) :: A
-END MODULE CB
-!
-PROGRAM SCATTERING
-!
-! This is the main program for the scattering problem.
-! Copyright (c) Tao Pang 1997.
-!
-  USE CB
-  IMPLICIT NONE
-  INTEGER, PARAMETER, unit(1) :: M=21
-  INTEGER, PARAMETER :: N=10001
-  INTEGER I,J,ISTEP
-  REAL :: DL,B0,DB,DX,X0,X,DX0,F,FX,FB,FBX,G1,G2,RU,RUTH,SI
-  REAL, DIMENSION (N) :: FI
-  REAL, DIMENSION (M) :: THETA,SIG,SIG1
-!
-  DL = 1.E-06
-  B0 = 0.01
-  DB = 0.5
-  DX = 0.01
-  E  = 1.0
-  A  = 100.0
-  DO I = 1, M
-    B  = B0+(I-1)*DB
-!
-! Calculate the first term of theta
-!
-    DO J = 1, N
-      X = B+DX*J
-      FI(J) = 1.0/(X*X*SQRT(FBX(X)))
-    END DO
-    CALL SIMP(N,DX,FI,G1)
-!
-! Find r_m from 1-b*b/(r*r)-U/E=0
-!
-    X0  = B
-    DX0 = DX
-    CALL SECANT (DL,X0,DX0,ISTEP)
-!
-! Calculate the second term of theta
-!
-    DO J = 1, N
-      X = X0+DX*J
-      FI(J) = 1.0/(X*X*SQRT(FX(X)))
-    END DO
-    CALL SIMP (N,DX,FI,G2)
-    THETA(I) = 2.0*B*(G1-G2)
-    END DO
-!
-! Calculate d_theta/d_b
-!
-    CALL THREE (M,DB,THETA,SIG,SIG1)
-!
-! Put the cross section in log form with the exact result of
-! the Coulomb scattering (RUTH)
-!
-    DO I = M, 1, -1
-      B      = B0+(I-1)*DB
-      SIG(I) = B/ABS(SIG(I))/SIN(THETA(I))
-      RUTH   = 1.0/SIN(THETA(I)/2.0)**4/16.0
-      SI     = ALOG(SIG(I))
-      RU     = ALOG(RUTH)
-      WRITE (6,"(3F16.8)") THETA(I),SI,RU
-    END DO
-END PROGRAM SCATTERING
-!
-SUBROUTINE SIMP (N,H,FI,S)
-!
-! Subroutine for integration over f(x) with the Simpson rule.  FI:
-! integrand f(x); H: interval; S: integral.  Copyright (c) Tao Pang 1997.
-!
-  IMPLICIT NONE
-  INTEGER, INTENT (IN) :: N
-  INTEGER :: I
-  REAL, INTENT (IN) :: H
-  REAL :: S0,S1,S2
-  REAL, INTENT (OUT) :: S
-  REAL, INTENT (IN), DIMENSION (N) :: FI
-!
-  S  = 0.0
-  S0 = 0.0
-  S1 = 0.0
-  S2 = 0.0
-  DO I = 2, N-1, 2
-    S1 = S1+FI(I-1)
-    S0 = S0+FI(I)
-    S2 = S2+FI(I+1)
-  END DO
-  S = H*(S1+4.0*S0+S2)/3.0
-!
-! If N is even, add the last slice separately
-!
-  IF (MOD(N,2).EQ.0) S = S &
-     +H*(5.0*FI(N)+8.0*FI(N-1)-FI(N-2))/12.0
-END SUBROUTINE SIMP
-!
-SUBROUTINE SECANT (DL,X0,DX,ISTEP)
-!
-! Subroutine for the root of f(x)=0 with the secant method.
-! Copyright (c) Tao Pang 1997.
-!
-  IMPLICIT NONE
-  INTEGER, INTENT (INOUT) :: ISTEP
-  REAL, INTENT (INOUT) :: X0,DX
-  REAL :: X1,X2,D,F,FX
-  REAL, INTENT (IN) :: DL
-!
-  ISTEP = 0
-  X1 = X0+DX
-  DO WHILE (ABS(DX).GT.DL)
-    D  = FX(X1)-FX(X0)
-    X2 = X1-FX(X1)*(X1-X0)/D
-    X0 = X1
-    X1 = X2
-    DX = X1-X0
-    ISTEP = ISTEP+1
-  END DO
-END SUBROUTINE SECANT
-!
-SUBROUTINE THREE (N,H,FI,F1,F2)
-!
-! Subroutine for 1st and 2nd order derivatives with the three-point
-! formulas. Extrapolations are made at the boundaries.  FI: input
-! f(x); H: interval; F1: f'; and F2: f".  Copyright (c) Tao Pang 1997.
-!
-  IMPLICIT NONE
-  INTEGER, INTENT (IN) :: N
-  INTEGER :: I
-  REAL, INTENT (IN) :: H
-  REAL, INTENT (IN), DIMENSION (N) :: FI
-  REAL, INTENT (OUT), DIMENSION (N) :: F1,F2
-!
-! f' and f" from three-point formulas
-!
-  DO I = 2, N-1
-    F1(I) = (FI(I+1)-FI(I-1))/(2.*H)
-    F2(I) = (FI(I+1)-2.0*FI(I)+FI(I-1))/(H*H)
-  END DO
-!
-! Linear extrapolation for the boundary points
-!
-  F1(1) = 2.0*F1(2)-F1(3)
-  F1(N) = 2.0*F1(N-1)-F1(N-2)
-  F2(1) = 2.0*F2(2)-F2(3)
-  F2(N) = 2.0*F2(N-1)-F2(N-2)
-END SUBROUTINE THREE
-!
-FUNCTION FX(X) RESULT (F)
-  USE CB
-  IMPLICIT NONE
-  REAL :: X,F,U,UX
-!
-  F = 1.0-B*B/(X*X)-UX(X)/E
-END FUNCTION FX
-!
-FUNCTION FBX(X) RESULT (FB)
-  USE CB
-  IMPLICIT NONE
-  REAL :: X,FB
-!
-    FB = 1.0-B*B/(X*X)
-END FUNCTION FBX
-! 
-FUNCTION UX(X) RESULT (U)
-  USE CB
-  IMPLICIT NONE
-  REAL :: X,U
-!
-  U = 1.0/X*EXP(-X/A)
-END FUNCTION UX
diff --git a/samples/booku/two/code210.f90.html b/samples/booku/two/code210.f90.html
deleted file mode 100644
--- a/samples/booku/two/code210.f90.html
+++ /dev/null
@@ -1,1 +0,0 @@
-
module CB
   real, unit(b) :: B
   real, unit(e) :: E
   real, unit(a) :: A
end module CB
program SCATTERING
   use CB
   implicit none
   integer, parameter , unit(m) :: M = 21
   integer, parameter  :: N = 10001
   integer :: I,J,ISTEP
   real :: DL,B0,DB,DX,X0,X,DX0,F,FX,FB,FBX,G1,G2,RU,RUTH,SI
   real, dimension (N) :: FI
   real, dimension (M) :: THETA,SIG,SIG1
   DL = 1.E-06
   B0 = 0.01
   DB = 0.5
   DX = 0.01
   E = 1.0
   A = 100.0
   do I = 1, M, 1
      B = B0+(I-1)*DB
      do J = 1, N, 1
         X = B+DX*J
         FI(J) = 1.0/((X*X)*sqrt(FBX(X)))
      end do
      call SIMP(N,DX,FI,G1)
      X0 = B
      DX0 = DX
      call SECANT(DL,X0,DX0,ISTEP)
      do J = 1, N, 1
         X = X0+DX*J
         FI(J) = 1.0/((X*X)*sqrt(FX(X)))
      end do
      call SIMP(N,DX,FI,G2)
      THETA(I) = (2.0*B)*(G1-G2)
   end do
   call THREE(M,DB,THETA,SIG,SIG1)
   do I = M, 1, (-1)
      B = B0+(I-1)*DB
      SIG(I) = (B/ABS(SIG(I)))/SIN(THETA(I))
      RUTH = (1.0/SIN(THETA(I)/2.0)**4)/16.0
      SI = ALOG(SIG(I))
      RU = ALOG(RUTH)
      write (number = 6,'"(3F16.8)"') THETA(I),SI,RU
   end do
end program SCATTERING
subroutine SIMP(N,H,FI,S)
   implicit none
   integer, intent(in)  :: N
   integer :: I
   real, intent(in)  :: H
   real :: S0,S1,S2
   real, intent(out)  :: S
   real, intent(in) , dimension (N) :: FI
   S = 0.0
   S0 = 0.0
   S1 = 0.0
   S2 = 0.0
   do I = 2, N-1, 2
      S1 = S1+FI(I-1)
      S0 = S0+FI(I)
      S2 = S2+FI(I+1)
   end do
   S = (H*((S1+4.0*S0)+S2))/3.0
   if (MOD(N,2)==0) then