SUBROUTINE

Eine SUBROUTINE ist ein Unterprogramm, das von der Struktur dem Hauptprogramm ähnlich ist (viele Anweisungen können durchgeführt werden, es gibt Eingabe- und Ausgabeparameter, Werte können auch über COMMON - Blöcke übergeben werden);
Unterprogramme können dazu dienen Programme leichter lesbar zu machen, sie können Programmierarbeit ersparen, indem man gleiche Abschnitte eines Programms nicht mehrmals kodieren muß und sie können für ähnliche Aufgaben mit unterschiedlichen Aktualparametern aufgerufen werden.
Die Form einer SUBROUTINE ist:

SUBROUTINE sub_name [(formalparameterliste)]
  [deklarationen]
  [anweisungen]
  [CONTAINS
   interne unterprogramme]
END [SUBROUTINE [sub_name]]

Jede FUNCTION und SUBROUTINE kann wieder selbst- und vordefinierte Funktionen und Unterprogramme aufrufen und sie kann interne Subroutinen enthalten.

PROGRAM up_test
!-------------------------------------------------------------------------------
!------------- testet die Uebergabe eines Funktionsnamens, ..  -----------------
!-------------------------------------------------------------------------------
 IMPLICIT NONE
 REAL, INTRINSIC   :: SQRT
 REAL, EXTERNAL    :: sqr
 INTEGER, EXTERNAL :: root
 INTEGER           :: n, neu

 CALL eingabe (n)                  ! n hier Aktualparameter
 neu = root(n,SQRT)
 write (*,*) n, neu
 neu = root(n,sqr)
 write (*,*) n, neu
END PROGRAM up_test

SUBROUTINE eingabe (n)            ! n hier Formalparameter!
 WRITE (*,'(A)',ADVANCE='NO') 'geben Sie eine Integerzahl ein: '
 READ (*,*,IOSTAT=io) n
 IF (io /= 0) STOP 'Fehlerhafte Eingabe'
 RETURN
END

FUNCTION root (m, fkt)
 IMPLICIT NONE
 INTEGER :: m, root
 REAL :: fkt
 root = fkt(REAL(m))
END FUNCTION

REAL FUNCTION sqr(x) RESULT (func_res)
 REAL, INTENT(IN) :: x
 func_res = x*x
END FUNCTION sqr
!-------------------------------------------------------------------------------

Dieses Programm liefert:

 
geben Sie eine Integerzahl ein: 5
 5 2
 5 25

Ein weiteres Beispiel, das sowohl die Verwendung von Unterprogrammen als auch CHARACTER-Manipulationen veranschaulichen soll:

PROGRAM WORDS
  IMPLICIT NONE
  CHARACTER (LEN = 80) :: text
  INTEGER :: end_of_word

  WRITE (*,'(A)') 'Type in text: '
  READ "(A)", text
  PRINT *, "Input data TEXT:", TRIM(text)

! Blanking out the punctuation,
! compressing the multiple blanks,
! and ensuring that the first character is a letter
! are pre-editing tasks to simplify the job.
  CALL blank_punct (text, 1)
  CALL compress_bb (text)
  text = ADJUSTL (text)

! Print all the words.
! Each word is followed by exactly one blank.
  DO ! until all words are printed
    IF (LEN_TRIM (text) == 0) EXIT
    end_of_word = INDEX (text, " ") - 1
    WRITE (*,'(a)') text (1 : end_of_word)

! Discard word just printed
    text = text (end_of_word + 2 :)
  END DO
END PROGRAM WORDS

SUBROUTINE compress_bb (text)
! Removes double blanks, except at right end
  IMPLICIT NONE
  CHARACTER (LEN = *), INTENT (INOUT) :: text
  INTEGER :: i

  DO
    i = INDEX (TRIM (text), "  ")  ! TRIM(TEXT) schneidet TEXT nach dem letzten
    IF (i == 0) EXIT               ! Zeichen ungleich ' ' ab.
    TEXT (i :) = text (i+1 :)
  END DO
END SUBROUTINE compress_bb

SUBROUTINE blank_punct (text, mode)
! Blank out punctuation
! Retain only letters and blanks

  IMPLICIT NONE
  CHARACTER (LEN = *), INTENT (INOUT) :: text
  CHARACTER (LEN = *), PARAMETER :: letter_or_b  =  &
       "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz "
  INTEGER :: i
  INTEGER :: mode

! Replace any character that is not a blank or letter with a blank
  IF (mode == 1) THEN
    DO i = 1, LEN_TRIM (text)         ! bestimmt Laenge von TEXT bis zum letzten
                                      ! Zeichen ungleich ' '.
      IF (INDEX (letter_or_b, text (i : i)) == 0) THEN
        text  (i : i) = " "           ! INDEX(S,SS) gibt die 1.Position zurueck,
      END IF                          ! ab der SS in S enthalten ist.
    END DO                            ! (0 falls nicht enthalten)
  ELSE                                ! INDEX(S,SS,:TRUE.) liefert letzte Pos.
    DO
      I = VERIFY (text, letter_or_b)  ! findet das erste Zeichen in TEXT, das
      IF (I == 0) EXIT                ! nicht in LETTER_OR_B ist;
      TEXT (i : i) = " "              ! mit VERIFY (T,L,.TRUE.) wuerde die Pos.
    END DO                            ! des letzten Auftretens eines Zeichens
  END IF                              ! von T, das nicht in L ist, ausgegeben
END SUBROUTINE blank_punct