TYPE [[,PRIVATE | ,PUBLIC] ::] typname [PRIVATE] [SEQUENCE] typkomponenten_definition(en) END TYPE [typname]Wenn die Typdefinitionsanweisung in einem MODULE steht und somit global bekannt sein kann, können die Schlüsselworte PRIVATE oder PUBLIC angegeben werden. Default-Wert ist PUBLIC, d.h. dieser benutzerdefinierte Datentyp ist allen Programmkomponenten, die das MODULE mit einer USE -Anweisung zugänglich gemacht haben, bekannt.
Die Definition eines Datenobjekts mit benutzerdefinertem Datentyp erfolgt dann durch
TYPE (typname) [[, attribute] ::] namens_listeAls attribute kommen dabei ALLOCATABLE, DIMENSION, ... in Frage
Es gibt auch die Möglichkeit Strukturkonstante zu verwenden, sie haben die
Form
typname (liste)
wobei die in liste angeführten (konstanten oder variablen) Ausdrücke
in der entsprechenden Reihenfolge den Komponenten der Struktur (und damit
des Typs) zugeordnet werden.
Einzelne Komponenten der Struktur werden (ähnlich wie bei objektorientierter
Programmierung) über ihren "Namen" in der Struktur angesprochen:
variablen_name%komponenten_name
Sollten benutzerdefinierte Datentypen mit Unterprogrammen verwendet werden, so ist es günstig, ein MODULE zu schreiben, in dem die Datentypen definiert sind: sie sind dann in allen Unterprogrammen, in dem das MODULE mit USE eingebunden ist, definiert.
MODULE Kugeln ! globale Daten unter 'Kugeln' IMPLICIT NONE TYPE Punkt_2D ! Typdefinition: REAL, DIMENSION(2) :: x ! 1-dimensionaler Vektor der Laenge 2 END TYPE Punkt_2D TYPE Punkt_3D ! Typdefinition: REAL, DIMENSION(3) :: x ! 1-dimensionaler Vektor der Laenge 3 END TYPE TYPE kugel ! Typdefinition: REAL :: r ! 1 REAL-Zahl und TYPE(Punkt_3D) :: M ! eine Variable vom Typ Punkt_3D END TYPE TYPE kreis ! Typdefinition: TYPE(Punkt_2D) :: M ! eine Variable vom Typ Punkt_2D REAL :: r ! und eine REAL-Zahl END TYPE kreis END MODULE
Bei der Übersetzung des Programms wird ein File kugeln.mod angelegt, auf den dann von anderen Programmen aus mit USE zugegriffen werden kann:
PROGRAM typ_test
USE Kugeln ! USE musz an erster Stelle stehen !
IMPLICIT NONE ! verwende die Definitionen in 'Kugeln'
INTEGER :: i
TYPE (Kugel) :: Sphere ! eine Variable vom Typ Kugel
TYPE (Kreis) :: Circle, schnitt ! eine Variable und eine Funktion vom
! Typ Kreis
CALL eingabe (Sphere) ! lies Kugelwerte ein
Circle = null (Sphere) ! berechne den Schnittkreis mit xy-Ebene
CALL ausgabe (Circle) ! gib Schnittkreis aus
END PROGRAM
Und genauso kann man es auch in Unterprogrammen einbinden:
SUBROUTINE eingabe (Kug) USE Kugeln, ONLY: Kugel ! verwende nur den Typ Kugel aus Kugeln IMPLICIT NONE TYPE (Kugel) :: Kug ! Formalparameter vom Typ Kugel INTEGER :: i WRITE (*,'(A)') 'Geben Sie eine Kugel ein:' WRITE (*,'(A)',ADVANCE='NO') 'Mittelpunkt: ' READ (*,*) (Kug%M%x(i), i=1,3) ! lies die Mittelpunktskoordinaten WRITE (*,'(A)',ADVANCE='NO') 'Radius: ' READ (*,*) Kug%r ! lies den Radius END
FUNCTION null (Sph)
USE Kugeln ! verwende Definitionen aus Kugeln
IMPLICIT NONE
INTEGER :: i
TYPE (Kugel) :: Sph ! Formalparameter vom Typ Kugel
TYPE (Kreis) :: null ! FUNCTION sei vom Typ Kreis
IF (Sph%M%x(3) > Sph%r) THEN ! wenn z-Wert des Kugelmittelpunktes
null%r = Sph%r - Sph%M%x(3) ! * groesser als Radius, dann gibt es
ELSE IF (Sph%M%x(3) == Sph%r) THEN ! keinen Schnittkreis
null%r = 0.0 ! * wenn gleich Radius, dann gibt es
DO i = 1, 2 ! einen Beruehrpunkt
null%M%x(i) = Sph%M%x(i)
ENDDO
ELSE ! * sonst gibt es einen Schnittkreis
DO i = 1,2
null%M%x(i) = Sph%M%x(i)
ENDDO
null%r = SQRT(Sph%r**2. - Sph%M%x(3)**2.)
ENDIF
END FUNCTION
SUBROUTINE ausgabe (Circ)
USE Kugeln, ONLY: Kreis ! verwende nur die Kreise
IMPLICIT NONE
TYPE (Kreis) :: Circ ! Formalparameter vom Typ Kreis
IF (Circ%r < 0.0) THEN
WRITE (*,*) 'Kugel liegt ueber der xy-Ebene'
ELSE IF (Circ%r == 0.0) THEN
WRITE (*,*) 'Kugel beruehrt die xy-Ebene'
ELSE
WRITE (*,*) 'Kugel hat einen Schnittkreis mit xy-Ebene:'
WRITE (*,*) 'Mittelpunkt und Radius: ', Circ
ENDIF
END SUBROUTINE
Das läßt sich dann natürlich z.B. mit MODULE PROCEDUREn und überladenen Operatoren erweitern:
MODULE Kugeln
...
INTERFACE OPERATOR (==) ! Neudefinition von ==: falls == mit 2 Parametern
MODULE PROCEDURE same_circ ! vom Typ Kreis (siehe Def. same_circ) aufgerufen
END INTERFACE ! wird, dann wird die Fkt. same_circ aufgerufen
CONTAINS ! Module-Unterprogramme - sind dann ebenfalls global bekannt
LOGICAL FUNCTION same_circ (Kreis1, Kreis2)
TYPE (Kreis), INTENT(IN) :: Kreis1, Kreis2
same_circ = .FALSE.
IF ((Kreis1%M%x(1) == Kreis2%M%x(1)) .AND. &
(Kreis1%M%x(2) == Kreis2%M%x(2)) .AND. &
(Kreis1%r == Kreis2%r)) same_circ = .TRUE.
END FUNCTION
END MODULE
PROGRAM typ_test
USE Kugeln ! USE musz an erster Stelle stehen !
IMPLICIT NONE
INTEGER :: i, schnitt, mode
TYPE (Kugel) :: Sphere(2) ! 1-dim. Feld der Laenge 2 vom Typ Kugel
TYPE (Kreis) :: Circle1, Circle2, null
DO i = 1, 2
CALL eingabe (Sphere(i))
ENDDO
Circle1 = null (Sphere(1))
Circle2 = null (Sphere(2))
CALL ausgabe (Circle1)
CALL ausgabe (Circle2)
IF (Circle1 == Circle2) THEN
WRITE (*,*) 'die beiden Kreise decken sich!'
ELSE
mode = schnitt (Circle1, Circle2)
IF (mode < -2) THEN
WRITE (*,*) 'kleinerer Kreis liegt im groesseren'
ELSE
WRITE (*,'(A,I1,A)') 'Diese Kreise haben ', ABS(mode), ' Schnittpunkte'
ENDIF
ENDIF
END PROGRAM
INTEGER FUNCTION schnitt (Circ1, Circ2)
USE Kugeln
IMPLICIT NONE
TYPE (Kreis) :: Circ1, Circ2
REAL :: abst, radien_min, radien_sum
abst = abstand(Circ1%M,Circ2%M)
radien_sum = Circ1%r+Circ2%r
radien_min = ABS(Circ1%r-Circ2%r)
IF (abst < radien_min) THEN ! abst + rk < rg
schnitt = -3 ! kleiner im groszen Kreis
ELSE IF (abst == radien_min) THEN
schnitt = -1 ! Kreise beruehren sich innen
ELSE IF (abst == radien_sum) THEN
schnitt = 1 ! Kreise beruehren sich von auszen
ELSE IF (abst < radien_sum) THEN
schnitt = 2 ! 2 Schnittpunkte
ELSE
schnitt = 0 ! kein Schnittpunkt
ENDIF
CONTAINS
REAL FUNCTION abstand (Punkt1, Punkt2)
USE Kugeln
IMPLICIT NONE
TYPE(Punkt_2D) :: Punkt1, Punkt2
abstand = SQRT((Punkt1%x(1)-Punkt2%x(1))**2 + (Punkt1%x(2)-Punkt2%x(2))**2)
END FUNCTION
END FUNCTION