Absoft Fortran Coding Examples

Circle:

MODULE Circle_Operations
IMPLICIT NONE
CONTAINS
FUNCTION Area(radius)
REAL :: Area
REAL, INTENT(IN) :: Radius
Area = Radius**2 * 3.14159
END FUNCTION Area
FUNCTION Circumference(radius)
REAL :: Circumference
REAL, INTENT(IN) :: Radius
Circumference = Radius * 2 * 3.14159
END FUNCTION Circumference
END MODULE Circle_Operations

PROGRAM Circle
USE Circle_Operations
IMPLICIT NONE
REAL :: r=5.0
PRINT *,"Area=",Area(r)
PRINT *,"Circumference=",Circumference(r)
END PROGRAM Circle

Un-Optimized Output:

#      2        A = A*B+C
movq -16(%rbp),%rdx                         # C.base
movss 0(%rdx),%xmm1                       #
movq -32(%rbp),%rsi                         # A.base
movss 0(%rsi),%xmm2                        #
movq -24(%rbp),%rdi                         # B.base
movss 0(%rdi),%xmm0                       #
mulss %xmm2,%xmm0                        #
addss %xmm1,%xmm0                        #
movq -32(%rbp),%rax                        # A.base
movss %xmm0,0(%rax)                      #

Optimized Output:

#       2         a = a*b+c
movss 0(%rdi),%xmm0                              # [0] id:8 A+0x0
mulss 0(%rsi),%xmm0                                # [3]
addss 0(%rdx),%xmm0                              # [9]
movss %xmm0,0(%rdi)                              # [15] id:8 A+0x0

KIND(x)                                            x is a numeric
                                                      expression
SELECTED_INT_KIND(x)                       x is an integer                                                       expression
SELECTED_REAL_KIND(p,r)                   p and r are integer
                                                      expressions

INTEGER, PARAMETER :: I1=SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: I2=SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: I4=SELECTED_INT_KIND(9)
INTEGER, PARAMETER :: I8=SELECTED_INT_KIND(18)
INTEGER(KIND=I1) :: I, J, K
INTEGER(KIND=I2) :: M(10), N
INTEGER(I4) :: Int4
INTEGER(I8) :: Large
INTEGER(4) :: iflag
INTEGER(8) :: n_count

INTEGER, PARAMETER :: SP=SELECTED_REAL_KIND(6,37)
INTEGER, PARAMETER :: DP=SELECTED_REAL_KIND(15,307)
INTEGER, PARAMETER :: QP=SELECTED_REAL_KIND(31,307)
REAL(KIND=SP) :: A, B, C
REAL(KIND=SP) :: U, V, W
REAL(KIND=QP) :: O, P, Q
REAL(KIND=KIND(1.0e0)) :: SP_var
REAL(KIND=KIND(1.0d0)) :: DP_var
REAL(SP) :: D, E, F
REAL(SP) :: X, Y, Z
REAL(SP) :: R, S, T
REAL(4) :: Single
REAL(8) :: Double
REAL(16) :: Quad

127_I1                                           127_1
32767_I2                                      32767_2
2147483647_I4                           2147483647_4
9223372036854775807_I8       9223372036854775807_8

1.234_SP
56.789_DP
3.402823E+38_SP
1.797693134862315E+308_DP
1.79769313486231570814527423731730E+308_16

DATA A,B,C,D,E/1.0,1.0,1.0,1.0,1.0/
DATA A,B,C,D,E/5*1.0/

INTEGER M(5), DAYS(7)
DATA M, DAYS/5*0, 1, 2, 3, 4, 5, 6, 7/

CHARACTER*10 Color
DATA Color /"Yellow“/

INTEGER M(10,10),N(10),L(4)
CHARACTER*3 S(5)

DATA (N(I),I=1,10),((M(I,J),J=3,8),I=3,8)/5*1,5*2,36*99/
DATA (L(I),I=1,4) /’ABCD’,’EFGH’,’IJKL’,’MNOP’/
DATA (S(I),I=1,5) /’ABC’,’DEF’,’GHI’,’JKL’,’MNO’/

GOTO s                                      unconditional GOTO
GOTO (s, [,s]…]) e                   computed GOTO
GOTO i [[,] (s [,s]…)]              assigned GOTO

Where s is the label of a statement, e is an integer expression, and i is the symbolic name of an integer variable that has been assigned the label of a statement with the ASSIGN statement.

GOTO 100

[name:] IF (e) THEN
           block
        ELSE [name]
           block
        END IF [name]

If the logical expression is .TRUE., the first block of
statements is executed, otherwise the second block of
statements is executed.

Outer: DO
           FLAG = .FALSE.
Inner: DO I=1, N-1
           IF (A(I) < A(I+1)) CYCLE Inner
           TEMP = A(I)
           A(I) = A(I+1)
           A(I+1) = TEMP
           FLAG = .TRUE.
      END DO Inner
      IF (.NOT. FLAG) EXIT Outer
END DO Outer

CHARACTER :: Ch
LOGICAL :: Numeric, Alpha, Punctuation

SELECT CASE (Ch)
CASE ('A':'Z', 'a':'z')
    Alpha = .TRUE.
CASE ('0':'9')
    Numeric = .TRUE.
CASE DEFAULT
    Punctuation = .TRUE.
END SELECT

END Statement:
Every program unit must have an END statement which
terminates the range of an individual program unit within a
source file. A source file itself may contain more than one
program unit. An END statement is executable. If
encountered in a main program it terminates execution; if
encountered in a subroutine or function subprogram it has the
effect of a RETURN statement.

END

STOP Statement:
Normally, program executions ends when the END statement
of the main program is reached. Another way to terminate
program execution is with the STOP statement.

STOP [s]

The optional string s may be a CHARACTER constant or string
of five or fewer digits and is output to standard out.

IMPLICIT NONE
INTEGER :: I
REAL :: Tire, Mile, Revs, RPM, t

Tire = 22.0 * 3.14159           ! inches per 1 revolution
Mile = 12.0 * 5280.0            ! inches in 1 mile
Revs = Mile/Tire                    ! revolutions per mile

DO I = 10, 100, 10
       t = I/60.0                        ! miles per minute
       RPM = Revs * t              ! revolutions per minute
       print *, i, RPM
END DO

END

Your Output Will Be:

10 152.789
20 305.578
30 458.367
40 611.155
50 763.944
60 916.733
70 1069.52
80 1222.31
90 1375.10
100 1527.89

The general form of the READ statement can take two forms:

READ f, [iolist]
READ (cilist) [iolist]

Where cilist is the control information list. The cilist
contains a unit specifier and optionally specifiers for format,
error, end-of-file, end-of-record, name list, record, advance,
and size.

The WRITE statement provides the Fortran mechanism for
transferring output to external sources. The general form of
the WRITE statement is:

WRITE (cilist) [iolist]

Where cilist is the control information list.

The OPEN statement is be used to connect to an existing file,
create a file, or modify an existing file connection.

OPEN ([UNIT=] u [,olist])

In addition to ERR and IOSTAT, olist may contain specifiers
to indicate the name of the file, the type and form of the
connection, and the position at open.

The CLOSE statement is used to disconnect a unit from an
external file:

CLOSE ([UNIT=] u [,clist])

clist may contain IOSTAT, ERR, and STATUS specifiers.
The STATUS specifier is a character expression that must be
equal to either "KEEP" or "DELETE".

The INQUIRE is used to obtain information about the
properties of files or units. The form of the INQUIRE
statement is:

INQUIRE ([UNIT=] u, ilist)
INQUIRE (FILE= f, ilist)
INQUIRE (IOLENGTH= i) output-list

In addition to ERR and IOSTAT, ilist may contain specifiers
to indicate the name of the file, the type and form of the
connection.

INQUIRE Statement Specifiers:

EXIST= logical variable
OPENED= logical variable
NUMBER= integer variable
NAMED= logical variable
NAME= character variable
ACCESS= character variable
SEQUENTIAL= character variable
DIRECT= character variable
FORM= character variable
FORMATTED= character variable
UNFORMATTED = character variable
RECL= integer variable
NEXTREC= integer variable
BLANK= character variable
POSITION= character variable
ACTION= character variable
READ= character variable
WRITE= character variable
READWRITE= character variable
DELIM= character variable
PAD= character variable

Additional I/O statements include:

        REWIND     ([UNIT=]     u     [,alist])
        BACKSPACE     ([UNIT=]     u     [,alist])
        ENDFILE     ([UNIT=]     u     [,alist])

alist may contain IOSTAT and ERR specifiers.

INTEGER I; REAL X (8); CHARACTER (11) P; COMPLEX Z; LOGICAL G
NAMELIST / TODAY / G, I, P, Z, X
READ (*, NML = TODAY)

The input data records are:
&TODAY I = 12345, X(1) = 12345, X(3:4) = 2*1.5, I=6, ! comment
P = "ISN'T_BOB'S", Z = (123,0)/

I                           6
X(1)                     12345.0
X(2)                     unchanged
X(3)                     1.5
X(4)                     1.5
X(5)–X(8)              unchanged
P                          ISN'T_BOB'S
Z                          (123.0,0.0)
G                          unchanged

REAL, DIMENSION(10) :: A, B(10,10)
REAL A(10), B(10,10)

REAL A, B
DIMENSION A(10), B(10,10)

The elements of A are A(1), A(2), A(3),…, A(10).
The elements of B are B(1,1), B(2,1), B(3,1), B(4,1), B(5,1), B(1,2), B(2,2), B(3,2), B(4,2),... B(10,10).

The number of elements of an array is called its size. The size of A is 10 and the size of B is 100 (10 x 10).

An automatic array is an explicit shape array in a subprogram
that takes its dimension bounds and hence its shape from
non-constant expressions. Such an array is local to the
subprogram and is allocated on entry:

SUBROUTINE SWAP(A, B)
REAL, DIMENSION(:)              :: A, B
REAL, DIMENSION(SIZE(A))     :: WORK
WORK = A
A = B
B = WORK
END SUBROUTINE SWAP

KIND(x)                                            x is a numeric
                                                      expression
SELECTED_INT_KIND(x)                       x is an integer                                                       expression
SELECTED_REAL_KIND(p,r)                   p and r are integer
                                                      expressions

     REAL, DIMENSION(5,2) :: A
     A(:,1) = (/1.,2.,3.,4.,5./)
     A(:,2) = (/6.,7.,8.,9.,10./)
     PRINT *,A((/1,3,5/),1)
     PRINT *,A((/1,3,5/),2)
     END
1.00000 3.00000 5.00000
6.00000 8.00000 10.0000

A typical application of a module is to define numeric kinds:

MODULE NUMERIC_KINDS
     INTEGER, PARAMETER :: I1=SELECTED_INT_KIND(2)
     INTEGER, PARAMETER :: I2=SELECTED_INT_KIND(4)
     INTEGER, PARAMETER :: I4=SELECTED_INT_KIND(9)
     INTEGER, PARAMETER :: I8=SELECTED_INT_KIND(18)
     INTEGER, PARAMETER :: SP=SELECTED_REAL_KIND(6,37)
     INTEGER, PARAMETER :: DP=SELECTED_REAL_KIND(15,307)
     INTEGER, PARAMETER :: QP=SELECTED_REAL_KIND(31,307)
END MODULE NUMERIC_KINDS

Input and output data transfer is either formatted or
unformatted. The type of data transfer is established with the FORM= specifier when the file is opened.

       FORM="FORMATTED"
       FORM="UNFORMATTED"
       FORM="BINARY"
       OPEN(1, FILE="TEST", FORM="UNFORMATTED”,...)

REAL ECHO(128, 10000)

OPEN (17, FILE=“SEISMIC.DAT”, ACCESS=“DIRECT”, RECL=512)

DO I=1, 10000
     READ (17, REC=I) ECHO(1,I)
END DO

REAL, DIMENSION(5,5) :: a = RESHAPE((/(i,i=1,25)/),(/5,5/))
PRINT "(5f6.2)", ((a(i,j), j=1,5), i=1,5)
END
      1.00 6.00 11.00 16.00 21.00
      2.00 7.00 12.00 17.00 22.00
      3.00 8.00 13.00 18.00 23.00
      4.00 9.00 14.00 19.00 24.00
      5.00 10.00 15.00 20.00 25.00

SUBROUTINE SWAP(A, B)
CHARACTER(LEN=*) :: A, B
CHARACTER(LEN=LEN(A)) :: TEMP
TEMP = A
A = B
B = TEMP
RETURN
END

        (/1, 2, 3, 1, 2, 3, 1, 2, 3/)
or:
        (/ ((i, i=1,3), j=1,3) /)

        (/0, 1, 0, 1, 0, 1, 0, 1, 0, 1/)
or:
        (/ (0,1, i=1,5) /)
        
        INTEGER, DIMENSION(10) :: M, N
        M = (/ (0,1, i=1,5) /)
        N = (/ (M+1) /)

Two arrays of the same shape are said to be conformable.
Array assignments can only be performed when both the left
and right hand sides are conformable. The RESHAPE function
is available to change the shape of an array.
     
     REAL, DIMENSION(2,3) :: a
     REAL, DIMENSION(3,2) :: b

     a = (/1.,2.,3.,4.,5.,6./)   <---  produces an error
     b = a                           <---  produces an error

     a = RESHAPE((/1.,2.,3.,4.,5.,6./), (/2,3/))
     b = RESHAPE(a, (/3,2/))

A function may return an array. However, whenever such a
function is referenced, it must always have an explicit
interface.

       FUNCTION VADD(a, r)
       REAL, DIMENSION(:) :: a
       REAL r
       REAL, DIMENSION(SIZE(a)) :: VADD
       VADD = a+COS(r)
       RETURN
       END

The WHERE statement allows an array operation to be
performed conditionally. This is called a masked assignment.

        WHERE (expr) assignment-statement
        [name:] WHERE (expr)
                where-body
        [ELSEWHERE (expr)[name]
                where-body]
        [ELSEWHERE [name]
                where-body]
         END WHERE [name]

The FORALL statement is used to perform array assignments,
possibly masked, on an element by element basis.

FORALL (trp_spec [,trp_spec]... [,mask_expr] )assign_stmt

[name:] FORALL (trpl_spec [,trp_spec]... [,mask_expr] )assign_stmt
                  forall_body_construct
                  END FORALL [name]
trp_spec is a triplet specification of an index variable
normally used as an array element index.

             index = subscript : subscript [: stride]

integer, dimension(5,5) :: m = reshape((/(i,i=1,25)/),(/5,5/))
call sub(m(2:4,1::2),3,3)
call sub(m(1::2,2:4),3,3)
end

subroutine sub(m,nx,ny)
integer, dimension(nx,ny) :: m
print *,m
end

        2 3 4 12 13 14 22 23 24
        6 8 10 11 13 15 16 18 20

Derived types have declaration statements, initialization syntax, and assignment statements.

        TYPE(DATE) :: DateA, DateB
        TYPE(DATE) :: DateC = DATE(5,12,2001)

        DateA%Month = 7
        DateA%Day = 12
        DateA%Year = 2002

        DateC = DATE(5,12,2001)
        DateB = DateA

    MODULE DATES
       TYPE DATE
           INTEGER Month, Day, Year
    END TYPE DATE

    CONTAINS
        LOGICAL FUNCTION DatesEqual(A, B)
        TYPE(DATE) A, B
            IF ((A%Month == B%Month) .AND. &
                (A%Day == B%Day) .AND. &
                (A%Year == B%Year)) THEN
            DatesEqual = .TRUE.
          ELSE
            DatesEqual = .FALSE.
          ENDIF
        END FUNCTION DatesEqual
     END MODULE DATES

MODULE DATES
    TYPE DATE; INTEGER Month, Day, Year; END TYPE DATE

INTERFACE OPERATOR(==)
    MODULE PROCEDURE DatesEqual
END INTERFACE

PRIVATE DatesEqual

CONTAINS
   LOGICAL FUNCTION DatesEqual(A, B)
       TYPE(DATE), INTENT(IN) :: A, B
        IF ((A%Month == B%Month) .AND. &
            (A%Day == B%Day) .AND. &
            (A%Year == B%Year)) THEN
           DatesEqual = .TRUE.
        ELSE
            DatesEqual = .FALSE.
        ENDIF
    END FUNCTION DatesEqual
END MODULE DATES

     PROGRAM MAIN
     USE strings
     CHARACTER(LEN=10) :: S1, S2
     CHARACTER(LEN=20) :: R1, R2
     S1 = "ABCDE"
     S2 = "FGHIJ"
     R1 = S1//S2
     R2 = S1 .CONCAT. S2
     PRINT "(A/A)", R1, R2
     END PROGRAM MAIN

     ABCDE     FGHIJ
     ABCDEFGHIJ

     PROGRAM Main
     USE DATES
     TYPE(DATE), DIMENSION(2) :: A

     A(1)%Month = 2
     A(1)%Day = 10
     A(1)%Year = 2002

     A(2) = DATE(2, 11, 2002)

     IF (A(1) == A(2)) PRINT *,"Equal"

     END PROGRAM Main

     PRIVATE DateToInteger

     CONTAINS
          INTEGER FUNCTION DateToInteger(A)
          TYPE(DATE), INTENT(IN) :: A
          DateToInteger =           A%Year*10000+A%Month*100+A%Day
      END FUNCTION DateToInteger
      ...
      LOGICAL FUNCTION DatesLT(A, B)
          TYPE(DATE), INTENT(IN) :: A, B
          DatesLT = .FALSE.
          IF (DateToInteger(A) < DateToInteger(B)) DatesLT =           .TRUE.
      END FUNCTION DatesLT

     INTERFACE LOGB
        FUNCTION SP_LOGB(X)
           REAL(KIND(1.0E0)) :: SP_LOGB, X
        END FUNCTION SP_LOGB
        FUNCTION DP_LOGB(X)
           REAL(KIND(1.0D0)) :: DP_LOGB, X
        END FUNCTION DP_LOGB
     END INTERFACE LOGB

The function N! = Nx(N-1)…2x1 lends itself to recursive
programming.

INTEGER RECURSIVE FUNCTION Factorial(n) RESULT(r)
       IF (n == 1) THEN
           r = 1
       ELSE
           r = n*Factorial(n-1)
       END IF
END FUNCTION Factorial

A powerful use of pointers is to create linked lists.
      TYPE Style
          INTEGER index
          REAL value
          TYPE(Style), POINTER :: next
      END TYPE Style

      TYPE(Style), POINTER :: Head, Current, Next

      ALLOCATE(Head)
      Head = Style(1, 0.0, NULL())

A function can return a pointer.

integer, dimension(10) :: m = (/123, 87, 55, 203, 88, 908, 13, 792, 66, 118/)
integer, dimension(:), pointer :: p

p => pick(m, 100)
print *,p

contains

function pick(m, limit)
     integer, dimension(:), pointer :: pick
     integer, dimension(:) :: m
     j = 0; do i=1,size(m); if (m(i) >= limit) j = j+1; end do
     allocate (pick(j))
     j = 0; do i=1,size(m); if (m(i) >= limit) then; j = j+1;      pick(j) = m(i); end if; end do
end function pick

end

      123 203 908 792 118

REAL, PARAMETER, PRIVATE :: PI=3.1415926535

PRIVATE :: SP_LOGB, DP_LOGB

TYPE SEMAPHORE
     PRIVATE
     REAL, DIMENSION(), POINTER :: ACCESS
     LOGICAL STATE
END TYPE SEMAPHORE

Variables and arrays that are declared locally in subprogramsare allocated dynamically when the subprogram is invoked. When the subprogram executes a RETURN or END statement, these items are deallocated and lose their definition status. The SAVE attribute/statement is used to retain the definition status of these items.

                REAL, SAVE :: A
                SAVE A
                SAVE

Fortran passes the lengths of strings by value as additional arguments at the end of the formal argument list. C programs can be constructed to take advantage of this.

      CALL CFUN('string')

      void cfun(char *string, int length)

   or:

      (void) FFUN(char_array, strlen(char_array));

      SUBROUTINE FFUN(string)
      CHARACTER(LEN=*) string

The following example demonstrates a sequence to exercise program control over detection of an exception.

subroutine safe_divide(a, b, c, fail)
use IEEE_EXCEPTIONS
real a, b, c
logical fail
type(IEEE_STATUS_TYPE) status
! save the current floating-point environment, turn halting for
! divide-by-zero off, and clear any previous divide-by-zero flag
call IEEE_GET_STATUS(status)
call IEEE_SET_HALTING_MODE(IEEE_DIVIDE_BY_ZERO, .false.)
call IEEE_SET_FLAG(IEEE_DIVIDE_BY_ZERO, .false.)
! perform the operation
c = a/b
! determine if a failure occurred and restore the floating-point environment
call IEEE_GET_FLAG(IEEE_DIVIDE_BY_ZERO, fail)
call IEEE_SET_STATUS(status)
end subroutine safe_divide

The Unix library contains functions for determining the
number of command line arguments and returning the nth
argument from the command line.

     character(len=32) :: arg(16)
     n = iargc()
     do i=1,n
         call getarg(i, arg(i))
     end do

The LAPACK routine DGESV performs Gaussian elimination
on a general dense matrix.

INTEGER, PARAMETER :: LDA=100, LDB=100, N=50, NRHS=50
INTEGER INFO, IPIV(N)
REAL(KIND(1.0D0)), DIMENSION(LDA,N) :: A
REAL(KIND(1.0D0)), DIMENSION(LDB,NRHS) :: B
...
CALL DGESV(N, NRHS, A, LDA, IPIV, B, LDB, INFO)

Array indexing in loops:

1.      do i=1,n            ! column indexing
           do j=1,n
              a(i,j) = a(i,j) + b(i,j)*c(i,j)
           end do
         end do

2.      do j=1,n            ! row indexing
           do i=1,n
               a(i,j) = a(i,j) + b(i,j)*c(i,j)
           end do
        end do

3.     a = a+b*c

The runtimes for the three code sections above are:
       
     unoptimized               optimized
1.    4.74 seconds               0.20 seconds
2.    0.70 seconds               0.20 seconds
3.    0.49 seconds               0.20 seconds