Category : Files from Magazines
Archive   : PJ92.ZIP
Filename : F90EXAMP.FOR

 
Output of file : F90EXAMP.FOR contained in archive : PJ92.ZIP
* The following Fortran 90 code listing fragments are from
* Thomas M. Lahey's article entitled "Fortran 90 is Coming!"

*** LISTING 1
REAL, DIMENSION(:,:), ALLOCATABLE :: temps, pressures
...
n = 16384 ! Try for arrays of 24*8192 elements
10 n = n/2 ! n too big, halve it
ALLOCATE ( temps(24, n), STAT=notice )
IF ( notice .NE. 0 ) GO TO 10 ! temps not allocated
ALLOCATE ( pressures(24, n), STAT=notice )
IF ( notice .NE. 0 ) THEN
DEALLOCATE ( temps ); GO TO 10
ENDIF

! pressures and temps have been allocated 24 by n elements.
IF ( n << 1024 ) THEN
PRINT '(" Only able to allocate"I4," elements")', n
STOP "Quitting"
ENDIF
...


*** LISTING 2

! pntr1 & pntr2 associate only with two-dimensional REAL arrays
COMMON /pointers/ pntr1, pntr2
REAL, POINTER, DIMENSION(:,:) :: pntr1, pntr2

! array1 & array2 are descriptors that "know" they are unallocated
! TARGET is required since they will be associated with a pointer
REAL, TARGET, DIMENSION(:,:) :: array1, array2
...
ALLOCATE ( array1(50,50), array2(70,90) )
pntr1 =>> array1; pntr2 =>> array2 !POINTER ASSIGNMENTs
CALL s ! if s declares COMMON /pointers/, then it can
! access array1 and array2
...


***LISTING 3

FUNCTION elements(string) ! Count words
IMPLICIT NONE; INTEGER i
CHARACTER*(*) string; LOGICAL separator
TYPE inventory
INTEGER nwords, nletters, npunct, nblanks, nelse
END TYPE inventory
TYPE (inventory) elements

! Initialize structure, INTRINSIC TRIM removes trailing blanks
elements%nwords = 0; elements%nletters = 0
elements%npunct = 0; elements%nelse = 0
elements%nblanks = LEN(string) - LEN( TRIM(string) )

IF ( string == '' ) RETURN ! All blanks

separator = .TRUE. ! To count words

block1: DO i = 1, LEN( TRIM(string) ) ! No trailing ' '
SELECT CASE ( string(i:i) )
CASE ( ' ' ) ! Blank
elements%nblanks = elements%nblanks +1
separator = .TRUE.
CASE (a:z, A:Z) ! Letters
elements%nletters = elements%nletters +1
IF ( separator ) THEN ! New word?
nwords = nwords +1 ! Yes
separator = .FALSE.
ENDIF
CASE ( '.', ',', ';' ) ! Punctuation
separator = .TRUE.
elements%npunct = elements%npunct +1
CASE DEFAULT ! All others
elements%nelse = elements%nelse +1
END SELECT
END DO block1
END


***LISTING 4

MODULE ISO_string

! Derived-type dynamic-length CHAR item: POINTER to rank-one array
TYPE string ! User defines DERIVED-TYPE STRINGs
PRIVATE ! Component "chars" unavailable to user
CHARACTER, DIMENSION(:), POINTER :: chars
END TYPE string

INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE ! MODULE SUBROUTINEs defined below
& s_eqs_s, ! CALLed if string = string parsed
& s_eqs_c, ! CALLed if string = char parsed
& c_eqs_s ! CALLed if char = string parsed
END INTERFACE

INTERFACE OPERATOR(//)
MODULE PROCEDURE ! MODULE FUNCTIONs defined later
& s_concat_s, ! Invoked if string // string parsed
& s_concat_c, ! Invoked if string // char parsed
& c_concat_s ! Invoked if char // string parsed
END INTERFACE

! Note: The ISO MODULE defines relational operators
! Note: The ISO MODULE defines its INTRINSIC FUNCTIONs LEN, INDEX
! Note: The ISO MODULE defines type conversions for internal
use
! ... A lot more code!
SUBROUTINE s_eqs_s(st, ss)! Compiler CALLs when
! string = string is parsed
TYPE (string) INTENT(OUT) :: st
TYPE (string) INTENT(IN) :: ss
IF ( .NOT. ASSOCIATED(ss%chars) ) CALL error
IF ( ASSOCIATED(st%chars) ) THEN
IF ( ASSOCIATED(ss%chars, st%chars) ) RETURN
NULLIFY (st%chars)
ENDIF
st%chars = ss%chars
END SUBROUTINE s_eqs_s
! ... A lot more code!
END MODULE ISO_string

! Using the string MODULE
USE string ! The MODULE
TYPE (string) s1, s2 ! MODULE has type definition
...
s1 = 'abc def ' ! Trailing blank preserved,
s_eqs_c
s2 = 'ghi jkl mno'
...
s1 = s2 // s1 ! // is overloaded operator,
compiler
! invokes function s_cat_s(s2,s1)
then
! CALL s_eqs_s(s1,string_temp)
PRINT *, s1 ! Compiler prints structure components
END


***LISTING 5

SUBROUTINE sub
CALL s
PRINT *, i, j ! i & j are known to internals

CONTAINS ! Required, separates host & internals

SUBROUTINE s
i = nj(5); END ! i not declared locally, must be host

FUNCTION nj(k)
j = k+5; END ! j not declared locally, must be host

END SUBROUTINE sub


***LISTING 6

NAMELIST /study_params/ temp, pres, volume
REAL, PARAMETER :: n = 6.02252E23, R = 0.0823
10 PRINT *, 'To terminate, enter both values as 0'
PRINT *, 'If not changing both params end with /, no ,'
PRINT *, 'Input: &study_params temp=value, pres=value/'
IF ( temp .EQ. 0 .AND. pres .EQ. 0 ) STOP 'All done'
READ (*, NML=study_params)
volume = n*R*temp/pres ! Remember: PV = nRT
WRITE (*, NML=study_params) ! Outputs: temp, pres, & volume
GO TO 10
END



  3 Responses to “Category : Files from Magazines
Archive   : PJ92.ZIP
Filename : F90EXAMP.FOR

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/