Sie sind hier: Fortran > Collectionmodul in Fortran

Collectionmodul in Fortran

Dienstag 11. Dezember 2007 von
Simon Praetorius
In Java existiert seit einiger Zeit eine Klasse Collection, die verschiedene verkettete Liste, Bäume und Mengen als "dynamischen Datentyp" bereitstellt. In Fortran wird von Haus aus kein solches Modul mitgeliefert. Allerdings ist eine einfache Implementierung solcher Listen nicht allzu schwer. Da bei einigen Algorithmen eine beliebige Anzahl an Daten gespeichert werden soll und die Anzahl oft auch nicht bekannt ist oder abgeschätzt werden kann, habe ich einige Module für solche "Collections" in Fortran implementiert und in einem gemeinsamen Modul durch Interfaces zusammengefasst. Eine Dokumentation zu diesen Modulen findet sich hier.

Zunächst wird für die Elemente, die in der Liste gespeichert werden sollen ein Modul geschrieben, das den type content implementiert. Dazu werden einige Operatoren auf diesem Datentyp definiert und Funktionen zum Einlesen und Ausgeben solcher Typen angegeben:
fortran Code
  • module contmod
  • implicit none
  •  
  • private
  • public :: length, content, setContent, read, put, &
  • & getX, setX, getY, setY, &
  • & operator(==), operator(<), operator(<=), &
  • & operator(/=), operator(>), operator(>=), &
  • & equal, notequal, less, lessequal, greater, &
  • & greaterequal
  •  
  • integer, parameter :: length = 2
  •  
  • type content
  • real(kind=8) :: x
  • real(kind=8),dimension(length) :: y
  • end type content
  •  
  • interface operator (==)
  • module procedure equal
  • end interface
  •  
  • interface operator (/=)
  • module procedure notequal
  • end interface
  •  
  • interface operator (<)
  • module procedure less
  • end interface
  •  
  • interface operator (<=)
  • module procedure lessequal
  • end interface
  •  
  • interface operator (>)
  • module procedure greater
  • end interface
  •  
  • interface operator (>=)
  • module procedure greaterequal
  • end interface
  •  
  • contains
  •  
  • function setContent(x,y)
  • real(kind=8),intent(in) :: x
  • real(kind=8),dimension(:),intent(in) :: y
  • type(content) :: setContent
  •  
  • setContent = content(x,y)
  • end function setContent
  •  
  • subroutine read(obj)
  • type(content), intent(out) :: obj
  • write(*,*) ' x:'
  • read (*,*) obj%x
  • write(*,*) ' y:'
  • read (*,*) obj%y
  • end subroutine read
  •  
  • subroutine print(obj)
  • type(content), intent(in) :: obj
  • write(*,"(A)", advance="no") '('
  • write(*,"(F7.3)", advance="no") obj%x
  • write(*,"(A)", advance="no") ' | '
  • write(*,"(F7.3)", advance="no") obj%y
  • write(*,"(A)") ')'
  • end subroutine print
  •  
  • subroutine put(obj)
  • type(content), intent(in) :: obj
  • write(*,*) (obj%x),', ',(obj%y),';'
  • end subroutine put
  •  
  • function getX(obj)
  • real(kind=8) :: getX
  • type(content), intent(in) :: obj
  • getX = obj%x
  • end function getX
  •  
  • function getY(obj)
  • real(kind=8),dimension(length) :: getY
  • type(content), intent(in) :: obj
  • getY = obj%y
  • end function getY
  •  
  • subroutine setX(obj, newX)
  • type(content), intent(inout) :: obj
  • real(kind=8), intent(in) :: newX
  • obj%x = newX
  • end subroutine setX
  •  
  • subroutine setY(obj, newY)
  • type(content), intent(inout) :: obj
  • real(kind=8),dimension(:), intent(in) :: newY
  • obj%y = newY
  • end subroutine setY
  •  
  • function equal(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: equal
  • equal = (obj1%x == obj2%x) .and. all(obj1%y == obj2%y)
  • end function equal
  •  
  • function notequal(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: notequal
  • notequal = (obj1%x /= obj2%x) .or. any(obj1%y /= obj2%y)
  • end function notequal
  •  
  • function less(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: less
  • less = (obj1%x < obj2%x) .and. all(obj1%y < obj2%y)
  • end function less
  •  
  • function lessequal(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: lessequal
  • lessequal = (obj1%x <= obj2%x) .and. all(obj1%y <= obj2%y)
  • end function lessequal
  •  
  • function greater(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: greater
  • greater = (obj1%x > obj2%x) .and. all(obj1%y > obj2%y)
  • end function greater
  •  
  • function greaterequal(obj1, obj2)
  • type(content), intent(in) :: obj1, obj2
  • logical :: greaterequal
  • greaterequal = (obj1%x >= obj2%x) .and. all(obj1%y >= obj2%y)
  • end function greaterequal
  •  
  • end module contmod
Dann habe ich 2 "Zusammenstellungen" implementiert (bzw. nur die Collection "List" implementiert und "Stack" aus einer Univorlesung übernommen). In dem Modul listmod.f95 habe ich zudem eine besondere Form von Kommentaren eingeführt. Sie ähneln denen aus Javadoc und ich bin gerade dabei einen Parser für solche Kommentare zu schreiben, der aus einem einzulesenden Fortranmodul eine Dokumentation erstellt. Aber auch so werden die Kommentare sicher hilfreich für's Verständnis einzelner Codeteile sein.
fortran Code
  • !**
  • !* listmod.f95
  • !*
  • !* @author Simon Praetorius
  • !* @version 0.1
  • !* @since 22. November 2007, 22:46
  • !**
  • module listmod
  • use contmod
  •  
  • implicit none
  •  
  • private
  • public :: list, listelem, remove, contains, initList, &
  • & emptyList, addToList, addAllToList, indexOf, &
  • & lastIndexOf, get, getFirst, getLast, removeElem, &
  • & removeAllElems, removePos, iterator, current, next, &
  • & hasNext, reset, toArray, traverseList, writeList, &
  • & clearList, dumpList
  •  
  • type list
  • private
  • type(listelem), pointer :: top
  • type(listelem), pointer :: bottom
  • integer :: length
  • end type list
  •  
  • type :: listelem
  • private
  • type(content) :: data
  • type(listelem), pointer :: next => null()
  • integer :: pos
  • end type listelem
  •  
  • interface remove
  • module procedure removeElem
  • module procedure removePos
  • end interface remove
  •  
  • interface contains
  • module procedure containsElem
  • end interface contains
  •  
  • contains
  •  
  • !**
  • !* Initialisiert eine List, d.h. setzt die Zeiger auf null() und die Lnge auf 0
  • !*
  • !* @param l Liste, die initialisiert werden soll
  • !**
  • subroutine initList(l)
  • type(list), intent(out) :: l
  • nullify (l%top)
  • nullify (l%bottom)
  • l%length = 0
  • end subroutine initList
  •  
  • !**
  • !* Prft, ob eine List leer ist.
  • !*
  • !* @param l die zu berprfende Liste
  • !* @return .true. wenn die Liste leer ist, sonst .false.
  • !**
  • function emptyList(l)
  • type(list), intent(in) :: l
  • logical :: emptyList
  • emptyList = .not. associated(l%top)
  • end function emptyList
  •  
  • !**
  • !* Fgt ein Element an das Ende einer List
  • !*
  • !* @param l Liste, an die das Element angehangen werden soll
  • !* @param elem Element, das an die Liste angehangen wird
  • !**
  • subroutine addToList(l, elem)
  • type(list), intent(inout) :: l
  • type(content), intent(in) :: elem
  • type(listelem), pointer :: ptr
  • integer :: error
  • allocate(ptr, stat = error)
  • if(error == 0) then
  • ptr%data = elem
  • ptr%pos = l%length+1
  • if(emptyList(l)) then
  • l%bottom => ptr
  • else
  • l%top%next => ptr
  • endif
  • l%top => ptr
  • l%length = l%length + 1
  • else
  • write(*,*) Speicherzuweisung'
  • end if
  • end subroutin
  • end if
  • end subroutine addToList
  •  
  • us der Liste l2 an die Liste l. Ist l2 leer, wird kein Element hinzugefgt.
  • !*
  • !* @param l Liste, an die di
  • !*
  • die die Elemente angehangen werden sollen
  • !* @param l2 Liste de
  • !* @param l2 Liste der Elemente, die an l angehangen werden sollen
  • oList(l, l2)
  • type(list), intent(i
  • type(list), intent(inout) :: l
  • type(list), intent(in) :: l2
  • type(listelem), pointer :: ptr, it
  • type(content) :: data
  • integer :: error
  •  
  • if(.not.emptyList(l2)) then
  • call iterator(l2,it)
  • do
  • allocate(ptr, stat = error)
  • if(error == 0) then
  • data = current(it)
  • ptr%data = data
  • ptr%pos = l%length+1
  • if(emptyList(l)) then
  • l%bottom => ptr
  • else
  • l%top%next => ptr
  • endif
  • l%top => ptr
  • l%length = l%length +1
  • call next(it)
  • else
  • write(*,*) Speicherzuweisung'
  • exit
  • endif
  • i
  • exit
  • endif
  • if(.not.hasNext(it)) exit
  • end do
  • endif
  • end subroutine addAllToList
  •  
  • des ersten Elements der Liste zurck, das mit dem bergebenen Element bereinstimmt.
  • !* Wenn es kein solches Element in d
  • !* Wenn es kein solches Element in der Liste gibt, wird -1 zurckgegeben
  • n der gesucht werden soll
  • !* @param elem Elemen
  • !* @param elem Element, von dem der Index bestimmt werden soll
  • rsten Auftretens des Elements in der Liste, oder -1, wenn dieses Element nicht in der Liste enthalten ist
  • !**
  • function indexOf(
  • !**
  • function indexOf(l, elem)
  • type(list), intent(in) :: l
  • type(content), intent(in) :: elem
  • integer :: indexOf
  • type(listelem), pointer :: it
  •  
  • indexOf = -1
  • call iterator(l,it)
  • do
  • if(current(it) == elem) then
  • indexOf = it%pos
  • exit
  • endif
  • if(.not.hasNext(it)) exit
  • end do
  •  
  • end function
  •  
  • des letzten Elements der Liste zurck, das mit dem bergebenen Element bereinstimmt.
  • !* Wenn es kein solches Element in d
  • !* Wenn es kein solches Element in der Liste gibt, wird -1 zurckgegeben
  • n der gesucht werden soll
  • !* @param elem Elemen
  • !* @param elem Element, von dem der Index bestimmt werden soll
  • etzten Auftretens des Elements in der Liste, oder -1, wenn dieses Element nicht in der Liste enthalten ist
  • !**
  • function lastInde
  • !**
  • function lastIndexOf(l, elem)
  • type(list), intent(in) :: l
  • type(content), intent(in) :: elem
  • integer :: lastIndexOf
  • type(listelem), pointer :: it
  •  
  • lastIndexOf = -1
  • call iterator(l,it)
  • do
  • if(current(it) == elem) then
  • lastIndexOf = it%pos
  • endif
  • if(.not.hasNext(it)) exit
  • end do
  •  
  • end function
  •  
  • ne Element in der Liste enthalten ist.
  • !* Dazu werden alle Elemente der
  • !* Dazu werden alle Elemente der Liste mit dem Element elem verglichen und bei Elementgleichheit .true. zurckgegeben-
  • gesucht werden soll
  • !* @param elem Element, na
  • !* @param elem Element, nach dem gesucht werden soll
  • Element enthalten ist, sonst .false.
  • !**
  • function containsElem(
  • !**
  • function containsElem(l, elem)
  • type(list), intent(in) :: l
  • type(content), intent(in) :: elem
  • logical :: containsElem
  • type(listelem), pointer :: it
  •  
  • containsElem = .false.
  • call iterator(l,it)
  • do
  • if(current(it) == elem) then
  • containsElem = .true.
  • exit
  • endif
  • if(.not.hasNext(it)) exit
  • end do
  •  
  • end function containsElem
  •  
  • Liste mit dem gegebenen Index zurck.
  • !*
  • !* @param l List, in der ges
  • !*
  • !* @param l List, in der gesucht werden soll
  • ments, das zurck gegeben werden soll
  • !* @return Element mit dem gege
  • !* @return Element mit dem gegebenen Index aus der Liste
  • ype(list), intent(in) :: l
  • integer, intent(in) :: po
  • integer, intent(in) :: pos
  • type(content) :: get
  • type(listelem), pointer :: ptr
  •  
  • if(emptyList(l)) then
  • write(*,*) eturn
  • endif
  •  
  • if(pos > l%length .or. pos<1) then
  • write(*,*) 'ERROR: Zugriff auf ein ElemERROR: Zugriff auf ein Elemet außerhalb des Listenbereichs nicht mögli1) then
  • get = l%bottom%data
  • reen
  • get = l%bottom%data
  • return
  • elseif(pos==l%length) then
  • get = l%top%data
  • return
  • endif
  •  
  • ptr => l%bottomwhile(associated(ptr))
  • if(ptr%pos == pos) then
  • ))
  • if(ptr%pos == pos) then
  • get = ptr%data
  • return
  • endif
  • ptr => ptr%next
  • end do
  • end function getnt einer Liste zurck
  • !*
  • !* @param l List, in der gesck
  • !*
  • !* @param l List, in der gesucht werden solg der Liste
  • !**
  • function getFirst(l) rte
  • !**
  • function getFirst(l) result(elem)
  • type(list), intent(in) :: l
  • type(content) :: elem
  •  
  • elem = get(l,1)
  • end function getFirstent einer Liste zurck
  • !*
  • !* @param l List, in der gesck
  • !*
  • !* @param l List, in der gesucht werden solder Liste
  • !**
  • function getLast(l) rete
  • !**
  • function getLast(l) result(elem)
  • type(list), intent(in) :: l
  • type(content) :: elem
  •  
  • elem = get(l,l%length)
  • end function getLast aus der Liste und nummeriert alle Elemente,
  • !* die in der Liste nach de,
  • !* die in der Liste nach dem entfernten Element stehen, wieder ne gesucht werden soll
  • !* @param elem Element, dall
  • !* @param elem Element, das gelscht werden sollem)
  • type(list), intent(inout) ::m)
  • type(list), intent(inout) :: s
  • type(content), intent(in) :: elem
  • type(listelem), pointer :: ptr, start_ptr, hilfs_ptr
  • integer :: i, err_code
  •  
  • ptr => s%bottom
  • start_ptr => s%top
  •  
  • if(ptr%data == elem) thenottom => ptr%next
  • deallocate(ptr, stat = err_codxt
  • deallocate(ptr, stat = err_code)
  • start_ptr => s%bottom
  • s%length = s%length - 1
  • elseiste lschen
  • do while(associated(ptr%next))hen
  • do while(associated(ptr%next))
  • if(ptr%next%data == elem) then
  • hilfs_ptr => ptr%next
  • ptr%next => ptr%next%next
  • deallocate(hilfs_ptr, stat = err_code)
  • if(associated(start_ptr,s%top)) then; start_ptr => ptr; endif
  • s%length = s%length - 1
  • endif
  • ptr => ptr%next
  • end do
  • endif
  • start_ptr
  • if(associated(ptr,s%bottom))tr
  • if(associated(ptr,s%bottom)) then
  • i = 1
  • else
  • i = ptr%pos
  • endif
  •  
  • do while(associated(ptr))
  • ptr%pos = i
  • i = i+1
  • ptr=>ptr%next
  • end do
  •  
  • end subroutine removeElemeiner Liste l2 aus der Liste l und nummeriert alle Elemente,
  • !* die in der Liste l nach dee,
  • !* die in der Liste l nach dem ersten entfernten Element stehen, wieder nesucht werden soll
  • !* @param l2 Liste mit Elemenll
  • !* @param l2 Liste mit Elementen, die in der Liste l gelscht werden sollel2)
  • type(list), intent(inout) :: l
  • 2)
  • type(list), intent(inout) :: l
  • type(list), intent(in) :: l2
  • type(listelem), pointer :: it, it2, start_ptr, hilfs_ptr
  • integer :: i, err_code
  •  
  • start_ptr => l%top
  • call iterator(l,it)
  • call iterator(l2,it2)
  •  
  • do
  • if(current(it) == current(it2)) then
  • tom => it%next
  • start_ptr => l%bottom
  • l%lengtxt
  • start_ptr => l%bottom
  • l%length = l%length - 1
  • endif
  • call next(it2)
  • if(.not.hasNext(it2)) exit
  • end do
  •  
  • list1: do
  • call reset(l2, it2)
  • list2: do
  • if(it%next%data == current(it2)) then
  • hilfs_ptr => it%next
  • it%next => it%next%next
  • deallocate(hilfs_ptr, stat = err_code)
  • if(associated(start_ptr,l%top) .and. .not. associated(start_ptr, l%bottom)) then
  • start_ptr => it
  • endif
  • l%length = l%length - 1
  • endif
  • call next(it2)
  • if(.not.hasNext(it2)) exit list2
  • end do list2
  • call next(it)
  • if(.not.hasNext(it)) exit list1
  • end do list1
  • t(l, it)
  • it => start_ptr
  • if(associated(t)
  • it => start_ptr
  • if(associated(it,l%bottom)) then
  • i = 1
  • else
  • i = it%pos
  • endif
  •  
  • do
  • it%pos = i
  • i = i + 1
  • call next(it)
  • if(.not.hasNext(it)) exit
  • end do
  •  
  • end subroutine removeAllElemsem gegebenen Index aus der Liste l und nummeriert alle Elemente,
  • !* die in der Liste nach dem ente,
  • !* die in der Liste nach dem entfernten Element stehen, wieder neht werden soll
  • !* @param pos Index des Elementsll
  • !* @param pos Index des Elements, das gelscht werden solpe(list), intent(inout) :: s
  • integer, intent(in) :: pos
  • type s
  • integer, intent(in) :: pos
  • type(listelem), pointer :: ptr, start_ptr, hilfs_ptr
  • integer :: i, err_code
  •  
  • ptr => s%bottom
  • start_ptr => s%top
  •  
  • if(pos == 1) then=> ptr%next
  • deallocate(ptr, stat = err_code)
  • sxt
  • deallocate(ptr, stat = err_code)
  • start_ptr => s%bottom
  • s%length = s%length - 1
  • elseschen
  • do while(associated(ptr%next))
  • ifhen
  • do while(associated(ptr%next))
  • if(ptr%next%pos == pos) then
  • hilfs_ptr => ptr%next
  • ptr%next => ptr%next%next
  • deallocate(hilfs_ptr, stat = err_code)
  • if(associated(start_ptr,s%top)) then; start_ptr => ptr; endif
  • s%length = s%length - 1
  • exit
  • endif
  • ptr => ptr%next
  • end do
  • endif
  • _ptr
  • if(associated(ptr,s%bottom)) then
  • tr
  • if(associated(ptr,s%bottom)) then
  • i = 1
  • else
  • i = ptr%pos
  • endif
  •  
  • do while(associated(ptr))
  • ptr%pos = i
  • i = i+1
  • ptr=>ptr%next
  • end do
  •  
  • end subroutine removePoslemente aus der Liste
  • !*
  • !* @param l List, die iteriert werdente
  • !*
  • !* @param l List, die iteriert werden sol der Iterator bergeben werden soll
  • !**
  • subroutine iterator(l, it)
  • type(lisll
  • !**
  • subroutine iterator(l, it)
  • type(list), intent(in) :: l
  • type(listelem), pointer, intent(out) :: it
  • it => l%bottom
  • end subroutine iteratoren Element des Iterators
  • !*
  • !* @param it Zeiger auf Iteratorrs
  • !*
  • !* @param it Zeiger auf Iteratolem), pointer, intent(in) :: it
  • type(content) :: current
  •  
  • if(assoit
  • type(content) :: current
  •  
  • if(associated(it)) then
  • current = it%data
  • else
  • write(*,*f
  • end function current
  •  
  • !**
  • !* Iteriert des Iterator um eine Position
  • !*
  • !* @param it Zeiger auf Iterator
  • !**
  • subroutine next(iterate)
  • type(listelem), pointer, intent(inout) :: iterate
  •  
  • if(associated(iterate)) then
  • iterate => iterate%next
  • else
  • write(*,*) ' Iterator not active '
  • stop
  • endif ' Iterator not activ
  • !**
  • !* Prft, ob der Iterator noch ein Element weitergerckt werden kann
  • !*
  • !* @param it Zeiger auf Iterator
  • !* @return .true. wenn der Iterator noch um ein Element weitergerckt werden kann, sonst .false.
  • !**
  • function hasNext(iterate)
  • type(listelem), intent(in) :: iterate
  • logical :: hasNext
  •  
  • hasNext = associated(iterate%next)
  • end function hasNext
  •  
  • !**
  • !* Setzt den Iterator auf die Startposition zurck
  • !*
  • !* @param l Liste, ber die iteriert wird
  • !* @param it Zeiger auf Iterator
  • !**
  • subroutine reset(l, iterate)
  • type(list), intent(in) :: l
  • type(listelem), pointer, intent(out) :: iterate
  • if(associated(l%bottom)) then
  • iterate => l%bottom
  • else
  • write(*,*) ' List not initialisized'
  • endif
  • end subroutine reset
  •  
  • !**
  • !* ' List not initialisiz* Transformiert eine Liste in ein Feld
  • !*
  • !* @param l Liste, die transformiert werden soll
  • !* @param array Zeiger auf ein Feld.. dieses wird in der Subroutine mit der bentigten Lnge allociert
  • !**
  • subroutine toArray(l, array)
  • type(list), intent(in) :: l
  • type(content), dimension(:), pointer, intent(out) :: array
  • type(listelem), pointer :: ptr
  • integer :: i
  •  
  • allocate(array(l%length))
  •  
  • ptr => l%bottom
  • i = 1
  • do while(associated(ptr))
  • array(i) = ptr%data
  • ptr => ptr%next
  • i = i+1
  • end do
  • end subroutine toArray
  •  
  • !**
  • !* Wenndet eine Subroutine auf jedes Element der Liste an
  • !*
  • !* @param l Liste, die durchlaufen wird
  • !* @param task Subroutine, die auf jedes Element angewendet wird
  • !**
  • subroutine traverseList(l, task)
  • type(list), intent(in) :: l
  • type(listelem), pointer :: ptr
  •  
  • interface
  • subroutine task (data)
  • use contmod, only: content
  • type(content) :: data
  • end subroutine task
  • end interface
  •  
  • ptr => l%bottom
  • do while(associated(ptr))
  • call task(ptr%data)
  • ptr => ptr%next
  • end do
  • end subroutine traverseList
  •  
  • !**
  • !* Schreibt die Liste komplett vom Anfang bis Ende in ein definierted Aufgabegert (z.B. Standardausgabe, Datei)
  • !*
  • !* @param l Liste, die durchlaufen wird
  • !**
  • subroutine writeList(l)
  • type(list), intent(in) :: l
  • type(listelem), pointer :: ptr
  •  
  • ptr => l%bottom
  • do while(associated(ptr))
  • call put(ptr%data)
  • ptr => ptr%next
  • end do
  •  
  • end subroutine writeList
  •  
  • !**
  • !* Lscht alle Elemente der Liste
  • !*
  • !* @param l Liste, die durchlaufen wird
  • !**
  • subroutine clearList(l)
  • type(list), intent(inout) :: l
  • type(listelem), pointer :: ptr
  • integer :: err_code
  • do while(associated(l%bottom))
  • ptr => l%bottom
  • l%bottom => ptr%next
  • deallocate(ptr, stat = err_code)
  • if(err_code /= 0) then
  • write(*,*) ' deallocation failed, inconsistent memory!'
  • ' deallocation failed, inconsistent memo--------------->>> exit !
  • end if
  • end do
  • end subroutine cle !
  • end if
  • end do
  • end subroutine clearListste in die standardausgabe und lscht diese Elemente anschlieend
  • !*
  • !* @param l Liste, die durchlaufen wnd
  • !*
  • !* @param l Liste, die durchlaufen wirt), intent(inout) :: l
  • type(listelem), pointer :: ptr
  • l
  • type(listelem), pointer :: ptr
  • integer :: error
  • do while(associated(l%bottom) )
  • ptr => l%bottom
  • l%bottom => ptr%next
  • call put(ptr%data)
  • deallocate(ptr, stat = error)
  • if(error /= 0) then
  • write(*,*memory!'
  • exit ! >----------------------!'
  • exit ! >----------------------------------->>> exiubroutine dumpList
  •  
  • end module listmodst
  •  
  • end module listmod
fortran Code
  • module stackmod
  • use contmod ! imports type content and basic operations on it !
  •  
  • implicit none
  •  
  • private
  • public :: stack, stackelem, initStack, emptyStack, &
  • & addToStack, pop, getTopOfStack, &
  • & traverseStack, writeStack, clearStack, &
  • & dumpStack
  •  
  • type stack
  • private
  • type(stackelem), pointer :: top
  • end type stack
  •  
  • type :: stackelem
  • private
  • type(content) :: data
  • type(stackelem), pointer :: succ
  • end type stackelem
  •  
  • contains
  •  
  • ! initializes stack to a defined state (empty) !
  • subroutine initStack(s)
  • type(stack), intent(out) :: s
  • nullify (s%top)
  • end subroutine initStack
  •  
  • ! tests if stack is currently empty !
  • function emptyStack(s)
  • type(stack), intent(in) :: s
  • logical :: emptyStack
  • emptyStack = .not. associated(s%top)
  • end function emptyStack
  •  
  • ! adds new top element to stack !
  • subroutine addToStack(s, elem)
  • type(stack), intent(inout) :: s
  • type(content), intent(in) :: elem
  • type(stackelem), pointer :: ptr
  • integer :: err_code
  • allocate (ptr, stat = err_code)
  • if ( err_code == 0 ) then
  • ptr%data = elem
  • ptr%succ => s%top
  • s%top => ptr
  • else
  • write(*,*) ' allocation failed, probably out of memory!'
  • end if
  • end subroutine addToStack
  •  
  • ! removes top element from stack and returns its content !
  • ! via the second argument elem, if present !
  • subroutine pop(s, elem)
  • type(stack), intent(inout) :: s
  • type(content), intent(out), optional :: elem
  • type(stackelem), pointer :: ptr
  • integer :: err_code
  • if ( .not. emptyStack(s) ) then
  • ptr => s%top
  • if ( present(elem) ) elem = ptr%data
  • s%top => ptr%succ
  • deallocate (ptr, stat = err_code)
  • if ( err_code /= 0 ) &
  • & write(*,*) ' deallocation failed, inconsistent memory!'
  • else
  • write(*,*) ' cannot pop from empty stack!'
  • end if
  • end subroutine pop
  •  
  • ! returns content of top element !
  • function getTopOfStack(s)
  • type(stack), intent(in) :: s
  • type(content) :: getTopOfStack
  • if ( .not. emptyStack(s) ) then
  • getTopOfStack = s%top%data
  • else !!! output in a function can be a problem !!!
  • write(*,*) ' cannot get top of empty stack!'
  • end if
  • end function getTopOfStack
  •  
  • ! traverses complete stack from top to bottom, !
  • ! performing a specified task on each element !
  • subroutine traverseStack(s, task)
  • type(stack), intent(in) :: s
  • type(stackelem), pointer :: ptr
  •  
  • interface ! no host association in interface blocks !
  • subroutine task (data)
  • use contmod ! type content needs to be imported !
  • type(content) :: data
  • end subroutine task
  • end interface
  •  
  • ptr => s%top
  • do while ( associated(ptr) )
  • call task(ptr%data)
  • ptr => ptr%succ
  • end do
  • end subroutine traverseStack
  •  
  • ! writes complete stack from top to bottom !
  • subroutine writeStack(s)
  • type(stack), intent(in) :: s
  • type(stackelem), pointer :: ptr
  •  
  • ptr => s%top
  • do while ( associated(ptr) )
  • call put(ptr%data)
  • ptr => ptr%succ
  • end do
  •  
  • end subroutine writeStack
  •  
  • ! deletes complete stack !
  • subroutine clearStack(s)
  • type(stack), intent(inout) :: s
  • type(stackelem), pointer :: ptr
  • integer :: err_code
  • do while ( associated(s%top) )
  • ptr => s%top
  • s%top => ptr%succ
  • deallocate (ptr, stat = err_code)
  • if ( err_code /= 0 ) then
  • write(*,*) ' deallocation failed, inconsistent memory!'
  • exit ! >----------------------------------->>> exit !
  • end if
  • end do
  • end subroutine clearStack
  •  
  • ! dumps (writes and deletes) complete stack !
  • subroutine dumpStack(s)
  • type(stack), intent(inout) :: s
  • type(stackelem), pointer :: ptr
  • integer :: err_code
  • do while ( associated(s%top) )
  • ptr => s%top
  • s%top => ptr%succ
  • call put(ptr%data)
  • deallocate (ptr, stat = err_code)
  • if ( err_code /= 0 ) then
  • write(*,*) ' deallocation failed, inconsistent memory!'
  • exit ! >----------------------------------->>> exit !
  • end if
  • end do
  • write(*,*)
  • end subroutine dumpStack
  •  
  • end module stackmod
In einem weiteren Modul werden die beiden Collections zusammengefasst und entsprechende Interfaces angegeben, um gemeinsame Funktionen über ein und den selben Namen aufrufen zu können:
fortran Code
  • module collections
  • use stackmod
  • use listmod
  •  
  • public
  •  
  • interface init
  • module procedure initList
  • module procedure initStack
  • end interface init
  •  
  • interface add
  • module procedure addToList
  • module procedure addToStack
  • end interface add
  •  
  • interface addAll
  • module procedure addAllToList
  • end interface addAll
  •  
  • interface isEmpty
  • module procedure emptyList
  • module procedure emptyStack
  • end interface isEmpty
  •  
  • interface clear
  • module procedure clearList
  • module procedure clearStack
  • end interface clear
  •  
  • interface write
  • module procedure writeList
  • module procedure writeStack
  • end interface write
  •  
  • interface traverse
  • module procedure traverseList
  • module procedure traverseStack
  • end interface traverse
  •  
  • interface dump
  • module procedure dumpList
  • module procedure dumpStack
  • end interface dump
  •  
  • end module
Besucher: 16128 | Permalink | Kategorie: Fortran
Tags: ,

Kommentar hinzufügen

Dieses Feld bitten nicht ausfüllen: