Advanced Fortran 90

Timothy H. Kaiser,Ph.D.

Golden Energy Computing Organization
tkaiser@mines.edu
http://inside.mines.edu/~tkaiser/fortran/f90.html
Written: Summer 1997 Revised: Summer 2016


 
 

Introduction


 
 

Who am I?


 
 

The mind of the language writers
What were they thinking?



 
 

Why Fortran?

"I don't know what the technical characteristics of
the standard language for scientific and engineering
computation in the year 2000 will be... but I know it
will be called Fortran." John Backus



 
 

Justification of topics


 

Classification of topics


 

Listing of topics covered

  1. Listing of topics covered
  2. Format for our talk
  3. What is a Genetic Algorithm
  4. Simple algorithm for a GA
  5. Our example problem
  6. Start of real Fortran 90 discussion
  7. Comparing a FORTRAN 77 routine to a Fortran 90 routine
  8. Obsolescent features
  9. New source Form (and related things)
  10. New data declaration method
  11. Kind facility
  12. Modules
  13. Module functions and subroutines
  14. Allocatable arrays (the basics)
  15. Passing arrays to subroutines
  16. Interface for passing arrays
  17. Optional arguments and intent
  18. Derived data types
  19. Using defined types
  20. User defined operators
  21. Recursive functions introduction
  22. Fortran 90 recursive functions
  23. Pointers
  24. Function and subroutine overloading
  25. Fortran Minval and Minloc routines
  26. Pointer assignment
  27. More pointer usage, association and nullify
  28. Pointer usage to reference an array
  29. Data assignment with structures
  30. Using the user defined operator
  31. Passing arrays with a given arbitrary lower bounds
  32. Using pointers to access sections of arrays
  33. Allocating an array inside a subroutine
  34. Our fitness function
  35. Linked lists
  36. Linked list usage
  37. Our map representation
  38. Non advancing and character I/O
  39. Date and time functions
  40. Internal I/O
  41. Inquire function
  42. Namelist
  43. Vector valued functions
  44. Complete source for recent discussions
  45. Some array specific intrinsic functions
  46. The rest of our GA
  47. Compiler Information
  48. Fortan 95
  49. Summary
  50. References

 

Format for our talk


 

What is a Genetic Algorithm


 

Simple algorithm for a GA



 

Our example problem


 

Start of real Fortran 90 discussion


 

A preview: Comparing a FORTRAN 77 routine to a Fortran 90 routine


function ran1(idum)  
        real ran1 
        integer idum   
        real r(97)  
        parameter ( m1=259200,ia1=7141,ic1=54773)  
        parameter ( m2=134456,ia2=8121,ic2=28411)  
        parameter ( m3=243000,ia3=4561,ic3=51349)  
        integer j  
        integer iff,ix1,ix2,ix3  
        data iff /0/  
        if (idum<0.or.iff.eq.0)then  
            rm1=1.0/m1  
            rm2=1.0/m2  
            iff=1  
            ix1=mod(ic1-idum,m1)  
            ix1=mod(ia1*ix1+ic1,m1)  
            ix2=mod(ix1,m2)  
            ix1=mod(ia1*ix1+ic1,m1)  
            ix3=mod(ix1,m3)  
            do 11 j=1,97  
                ix1=mod(ia1*ix1+ic1,m1)  
                ix2=mod(ia2*ix2+ic2,m2)  
                r(j)=(real(ix1)+real(ix2)*rm2)*rm1  
 11           continue  
            idum=1  
        endif  
        ix1=mod(ia1*ix1+ic1,m1)  
        ix2=mod(ia2*ix2+ic2,m2)  
        ix3=mod(ia3*ix3+ic3,m3)  
        j=1+(97*ix3)/m3  
        if(j>97.or.j<1)then  
            write(*,*)' error in ran1 j=',j  
            stop  
        endif  
        ran1=r(j)  
        r(j)=(real(ix1)+real(ix2)*rm2)*rm1  
        return  
     end

module ran_mod   
contains
   
     function ran1(idum)  
        use numz  
        implicit none  !note after use statement  
        real(b8) ran1  
        integer, intent(inout), optional :: idum  
        real(b8) r(97),rm1,rm2  
        integer, parameter :: m1=259200,ia1=7141,ic1=54773  
        integer, parameter :: m2=134456,ia2=8121,ic2=28411  
        integer, parameter :: m3=243000,ia3=4561,ic3=51349  
        integer j  
        integer iff,ix1,ix2,ix3  
        data iff /0/  
        save ! corrects a bug in the original routine 
        if(present(idum))then 
          if (idum<0.or.iff.eq.0)then  
            rm1=1.0_b8/m1  
            rm2=1.0_b8/m2  
            iff=1  
            ix1=mod(ic1-idum,m1)  
            ix1=mod(ia1*ix1+ic1,m1)  
            ix2=mod(ix1,m2)  
            ix1=mod(ia1*ix1+ic1,m1)  
            ix3=mod(ix1,m3)  
            do j=1,97  
                ix1=mod(ia1*ix1+ic1,m1)  
                ix2=mod(ia2*ix2+ic2,m2)  
                r(j)=(real(ix1,b8)+real(ix2,b8)*rm2)*rm1  
            enddo 
            idum=1  
          endif  
        endif  
        ix1=mod(ia1*ix1+ic1,m1)  
        ix2=mod(ia2*ix2+ic2,m2)  
        ix3=mod(ia3*ix3+ic3,m3)  
        j=1+(97*ix3)/m3  
        if(j>97.or.j<1)then  
            write(*,*)' error in ran1 j=',j  
            stop  
        endif  
        ran1=r(j)  
        r(j)=(real(ix1,b8)+real(ix2,b8)*rm2)*rm1  
        return  
     end function ran1  
 

 

Obsolescent features

The following are available in Fortran 90. On the other hand, the concept "obsolescence" is introduced. This means that some constructs may be removed in the future.


 

New source form (and related things)

!23456789 
program darwin 
     real a(10), b(10), c(10), d(10), e(10), x, y 
     integer odd(5),even(5) 
     write(*,*)"starting ",&  ! this line is continued by using "&" 
               "darwin"       ! this line in a continued from above 
     x=1; y=2; write(*,*)x,y  ! multiple statement per line -- rarely a good idea 
     do i=1,10    ! statement lable is not required for do 
        e(i)=i 
     enddo 
     odd= (/ 1,3,5,7,9 /)  ! array assignment 
     even=(/ 2,4,6,8,10 /) ! array assignment 
     a=1          ! array assignment, every element of a = 1 
     b=2 
     c=a+b+e      ! element by element assignment 
     c(odd)=c(even)-1  ! can use arrays of indices on both sides
     d=sin(c)     ! element by element application of intrinsics 
     write(*,*)d 
     write(*,*)abs(d)  ! many intrinsic functions are generic 
 a_do_loop : do i=1,10 
               write(*,*)i,c(i),d(i) 
             enddo a_do_loop 
     do 
        if(c(10) < 0.0 ) exit 
        c(10)=c(10)-1 
     enddo 
     write(*,*)c(10) 
     do while (c(9) > 0) 
        c(9)=c(9)-1 
     enddo 
     write(*,*)c(9) 
end program 

 

New data declaration method

    integer,parameter :: in2 = 14 
    real, parameter :: pi = 3.141592653589793239 
    real, save, dimension(10) :: cpu_times,wall_times 
!****    the old way of doing the same    ****! 
!****    real cpu_times(10),wall_times(10) ****! 
!****    save cpu_times, wall_times        ****! 




 

Kind facility

Digits of precision for machine and data type

Machine/Data Type Real Double Precision
IBM (SP) 6 15
Cray (T90) 15 33
Cray (T3E) 15 15

********* or *********

  sp001 % cat darwin.f 
program darwin 
! e has at least 4 significant digits 
  real(selected_real_kind(4))e 
! b8 will be used to define reals with 14 digits 
  integer, parameter:: b8 = selected_real_kind(14) 
  real(b8), parameter :: pi = 3.141592653589793239_b8 ! note usage of _b8 
                                                      ! with  a constant 
                                                      ! to force precision 
 e= 2.71828182845904523536 
  write(*,*)"starting ",&  ! this line is continued by using "&" 
            "darwin"       ! this line in a continuation from above 
  write(*,*)"pi has ",precision(pi)," digits precision ",pi 
  write(*,*)"e has   ",precision(e)," digits precision ",e 
end program  
  sp001  % darwin 
 starting darwin 
 pi has  15  digits precision  3.14159265358979312 
 e has    6  digits precision  2.718281746 
sp001 % 


 

Modules


module numz 
  integer,parameter:: b8 = selected_real_kind(14) 
  real(b8),parameter :: pi = 3.141592653589793239_b8 
  integergene_size 
end module 

 program darwin   
    use numz  
    implicit none    ! now part of the standard, put it after the use statements 
   write(*,*)"pi has ",precision(pi),"
digits precision ",pi   
   call set_size()   
   write(*,*)"gene_size=",gene_size   
 end program   

subroutine set_size  
  use numz  
  gene_size=10  
end subroutine
 

  pi has  15  digits precision  3.14159265358979312  
  gene_size=10 


 

Module functions and subroutines

module ran_mod 
! module contains three functions 
! ran1 returns a uniform random number between 0-1 
! spread returns random number between min - max 
! normal returns a normal distribution 
contains
    function ran1()  !returns random number between 0 - 1 
        use numz 
        implicit none 
        real(b8) ran1,x 
        call random_number(x) ! built in fortran 90 random number function 
        ran1=x 
    end function ran1     
    function spread(min,max)  !returns random number between min - max 
        use numz 
        implicit none 
        real(b8) spread 
        real(b8) min,max 
        spread=(max - min) * ran1() + min 
    end function spread     
    function normal(mean,sigma) !returns a normal distribution 
        use numz 
        implicit none 
        real(b8) normal,tmp 
        real(b8) mean,sigma 
        integer flag 
        real(b8) fac,gsave,rsq,r1,r2 
        save flag,gsave 
        data flag /0/ 
        if (flag.eq.0) then 
        rsq=2.0_b8 
            do while(rsq.ge.1.0_b8.or.rsq.eq.0.0_b8) ! new from for do 
                r1=2.0_b8*ran1()-1.0_b8 
                r2=2.0_b8*ran1()-1.0_b8 
                rsq=r1*r1+r2*r2 
            enddo 
            fac=sqrt(-2.0_b8*log(rsq)/rsq) 
            gsave=r1*fac 
            tmp=r2*fac 
            flag=1 
        else 
            tmp=gsave 
            flag=0 
        endif 
        normal=tmp*sigma+mean 
        return 
    end function normal end module ran_mod 



 

Exersize 1: Write a program that returns 10 uniform random numbers.

 

Allocatable arrays (the basics)

module numz 
  integer, parameter:: b8 = selected_real_kind(14) 
  integer gene_size,num_genes 
  integer,allocatable :: a_gene(:),many_genes(:,:) 
end module 
program darwin 
    use numz 
    implicit none 
    integer ierr 
    call set_size() 
    allocate(a_gene(gene_size),stat=ierr) !stat= allows for an error code return 
    if(ierr /= 0)write(*,*)"allocation error"  ! /= is .ne. 
    allocate(many_genes(gene_size,num_genes),stat=ierr)  !2d array 
    if(ierr /= 0)write(*,*)"allocation error" 
    write(*,*)lbound(a_gene),ubound(a_gene) ! get lower and upper bound 
                                            ! for the array 
    write(*,*)size(many_genes),size(many_genes,1) !get total size and size 
                                                  !along 1st dimension 
    deallocate(many_genes) ! free the space for the array and matrix 
    deallocate(a_gene) 
    allocate(a_gene(0:gene_size)) ! now allocate starting at 0 instead of 1 
    write(*,*)allocated(many_genes),allocated(a_gene) ! shows if allocated 
    write(*,*)lbound(a_gene),ubound(a_gene) 
end program 
  subroutine set_size 
    use numz 
    write(*,*)'enter gene size:' 
    read(*,*)gene_size 
    write(*,*)'enter number of genes:' 
    read(*,*)num_genes 
end subroutine set_size 


    enter gene size: 
10 
 enter number of genes: 
20 
           1          10 
         200          10 
 F T 
           0          10 


Passing arrays to subroutines

subroutine arrays(an_explicit_shape_array,& 
                  i                      ,& !note we pass all bounds except the last 
                  an_assumed_size_array  ,& 
                  an_assumed_shape_array) 
! Explicit shape 
    integer, dimension(8,8)::an_explicit_shape_array 
! Assumed size 
    integer, dimension(i,*)::an_assumed_size_array 
! Assumed Shape 
    integer, dimension(:,:)::an_assumed_shape_array 
    write(*,*)sum(an_explicit_shape_array) 
    write(*,*)lbound(an_assumed_size_array) ! why does sum not work here? 
    write(*,*)sum(an_assumed_shape_array) 
end subroutine 

 

Interface for passing arrays

  module numz 
    integer, parameter:: b8 = selected_real_kind(14) 
    integer,allocatable :: a_gene(:),many_genes(:,:) 
end module module face 
    interface fitness 
        function fitness(vector)  
        use numz 
        implicit none 
        real(b8) fitness 
        integer, dimension(:) ::  vector  
        end function fitness 
    end interface 
end module program darwin 
    use numz 
    use face  
    implicit none 
    integer i 
    integer vect(10) ! just a regular array 
    allocate(a_gene(10));allocate(many_genes(3,10)) 
    a_gene=1  !sets every element of a_gene to 1 
    write(*,*)fitness(a_gene) 
    vect=8 
    write(*,*)fitness(vect) ! also works with regular arrays 
    many_genes=3  !sets every element to 3 
    many_genes(1,:)=a_gene  !sets column 1 to a_gene 
    many_genes(2,:)=2*many_genes(1,:) 
    do i=1,3 
        write(*,*)fitness(many_genes(i,:)) 
    enddo 
    write(*,*)fitness(many_genes(:,1))  !go along other dimension 
!!!!write(*,*)fitness(many_genes)!!!!does not work 
end program 
function fitness(vector) 
    use numz 
    implicit none 
    real(b8) fitness 
    integer, dimension(:)::  vector ! must match interface 
    fitness=sum(vector) 
end function 


 

Exersize 2: Run this program using the "does not work line". Why? Using intrinsic functions make it work?
Exersize 3: Prove that f90 does not "pass by address".

 

Optional arguments and intent

integer :: my_seed

becomes

integer, optional :: my_seed
! ran1 returns a uniform random number between 0-1 
! the seed is optional and used to reset the generator 
contains 
   function ran1(my_seed) 
      use numz 
      implicit none 
      real(b8) ran1,r 
      integer, optional ,intent(in) :: my_seed  ! optional argument not changed in the routine 
      integer,allocatable :: seed(:) 
      integer the_size,j 
      if(present(my_seed))then            ! use the seed if present 
          call random_seed(size=the_size) ! how big is the intrisic seed? 
          allocate(seed(the_size))        ! allocate space for seed 
          do j=1,the_size                 ! create the seed 
             seed(j)=abs(my_seed)+(j-1)   ! abs is generic 
          enddo 
          call random_seed(put=seed)      ! assign the seed 
          deallocate(seed)                ! deallocate space 
      endif 
      call random_number(r) 
      ran1=r 
  end function ran1 
end module program darwin 
    use numz 
    use ran_mod          ! interface required if we have 
                         ! optional or intent arguments 
    real(b8) x,y 
    x=ran1(my_seed=12345) ! we can specify the name of the argument 
    y=ran1() 
    write(*,*)x,y 
    x=ran1(12345)         ! with only one optional argument we don't need to 
    y=ran1() 
    write(*,*)x,y 
end program 


 

Derived data types

module galapagos 
    use numz 
    type thefit !the name of the type 
      sequence  ! sequence forces the data elements 
                ! to be next to each other in memory 
                ! where might this be useful? 
      real(b8) val   ! our result from the fitness function 
      integer index  ! the index into our collection of genes 
    end type thefit 
end module

 

Using defined types

program darwin 
    use numz 
    use galapagos ! the module that contains the type definition 
    use face      ! contains various interfaces  
 implicit none 
! define an allocatable array of the data type 
! than contains an index and a real value  
    type (thefit),allocatable ,target  :: results(:) 
! create a single instance of the data type 
    type (thefit) best 
    integer,allocatable :: genes(:,:) ! our genes for the genetic algorithm 
    integer j 
    integer num_genes,gene_size 
    num_genes=10 
    gene_size=10 
    allocate(results(num_genes))         ! allocate the data type  
                                         ! to hold fitness and index  
    allocate(genes(num_genes,gene_size)) ! allocate our collection of genes  
    call init_genes(genes)               ! starting data 
    write(*,'("input")' ) ! we can put format in write statement 
    do j=1,num_genes 
       results(j)%index =j 
       results(j)%val =fitness(genes(j,:)) ! just a dummy routine for now 
       write(*,"(f10.8,i4)")results(j)%val,results(j)%index  
    enddo 
end program 



 

User defined operators

module sort_mod 
!defining the interfaces 
  interface operator (.lt.)  ! overloads standard .lt. 
    module procedure theless ! the function that does it 
  end interface   interface operator (.gt.)   ! overloads standard .gt. 
    module procedure thegreat ! the function that does it 
  end interface   interface operator (.ge.)  ! overloads standard .ge. 
    module procedure thetest ! the function that does it 
  end interface   interface operator (.converged.)  ! new operator 
    module procedure index_test     ! the function that does it 
  end interface 
  contains      ! our module will contain 
              ! the required functions 
    function theless(a,b) ! overloads < for the type (thefit) 
    use galapagos 
    implicit none 
    type(thefit), intent (in) :: a,b 
    logical theless           ! what we return 
    if(a%val < b%val)then     ! this is where we do the test 
        theless=.true. 
    else 
        theless=.false. 
    endif 
    return 
  end function theless   function thegreat(a,b) ! overloads > for the type (thefit) 
    use galapagos 
    implicit none 
    type(thefit), intent (in) :: a,b 
    logical thegreat 
    if(a%val > b%val)then 
        thegreat=.true. 
    else 
        thegreat=.false. 
    endif 
    return 
  end function thegreat 
  function thetest(a,b)   ! overloads >= for the type (thefit) 
    use galapagos 
    implicit none 
    type(thefit), intent (in) :: a,b 
    logical thetest 
    if(a%val >= b%val)then 
        thetest=.true. 
    else 
        thetest=.false. 
    endif 
    return 
end function thetest 
  function index_test(a,b) ! defines a new operation for the type (thefit) 
    use galapagos 
    implicit none 
    type(thefit), intent (in) :: a,b 
    logical index_test 
    if(a%index > b%index)then   ! check the index value for a difference 
        index_test=.true. 
    else 
        index_test=.false. 
    endif 
    return 
end function index_test 

 

Recursive functions introduction

Algorithm of searching for minimum of an array

    function findmin(array) 
        is size of array 1? 
           min in the array is first element 
        else 
           find minimum in left half of array using findmin function 
           find minimum in right half of array using findmin function 
           global minimum is min of left and right half 
    end function 
    

 

Fortran 90 recursive functions

recursive function realmin(ain) result (themin) 
! recursive and result are required for recursive functions 
    use numz 
    implicit none 
    real(b8) themin,t1,t2 
    integer n,right 
    real(b8) ,dimension(:) :: ain 
    n=size(ain) 
    if(n == 1)then 
       themin=ain(1) ! if the size is 1 return value 
    return 
    else 
      right=n/2 
      t1=realmin(ain(1:right))   ! find min in left half 
      t2=realmin(ain(right+1:n)) ! find min in right half 
      themin=min(t1,t2)          ! find min of the two sides 
     endif 
end function 
 
!this routine works with the data structure thefit not reals 
recursive function typemin(ain) result (themin) 
    use numz 
 use sort_mod 
 use galapagos 
 implicit none 
 real(b8) themin,t1,t2 
 integer n,right 
    type (thefit) ,dimension(:) :: ain ! this line is different 
 n=size(ain) 
 if(n == 1)then 
     themin=ain(1)%val  ! this line is different 
  return 
 else 
  right=n/2 
  t1=typemin(ain(1:right)) 
  t2=typemin(ain(right+1:n)) 
  themin=min(t1,t2) 
 endif 
end function 

 

Pointers

recursive function pntmin(ain) result (themin) ! return a pointer 
 use numz 
 use galapagos 
 use sort_mod ! contains the < operator for thefit type 
 implicit none 
 type (thefit),pointer:: themin,t1,t2 
 integer n,right 
    type (thefit) ,dimension(:),target :: ain 
 n=size(ain) 
 if(n == 1)then 
     themin=>ain(1) !this is how we do pointer assignment 
  return 
 else 
  right=n/2 
  t1=>pntmin(ain(1:right)) 
  t2=>pntmin(ain(right+1:n)) 
  if(t1 < t2)then; themin=>t1; else; themin=>t2; endif 
 endif 
end function 


 

Exercise 4: Carefully write a recursive N! program.
 

Function and subroutine overloading

! note we have two functions within the same interface 
! this is how we indicate function overloading 
! both functions are called "findmin" in the main program 
interface findmin  
! the first is called with an array of reals as input 
        recursive function realmin(ain) result (themin) 
          use numz 
       real(b8) themin 
          real(b8) ,dimension(:) :: ain 
        end function ! the second is called with a array of data structures as input 
     recursive function typemin(ain) result (themin) 
          use numz 
    use galapagos 
       real(b8) themin 
          type (thefit) ,dimension(:) :: ain 
     end function 
    end interface 
program darwin 
    use numz 
    use ran_mod 
    use galapagos ! the module that contains the type definition 
    use face      ! contains various interfaces 
    use sort_mod  ! more about this later it 
                  ! contains our sorting routine 
      ! and a few other tricks 
    implicit none 

! create an allocatable array of the data type 
! than contains an index and a real value 
    type (thefit),allocatable ,target :: results(:) 
! create a single instance of the data type 
    type (thefit) best 
! pointers to our type 
    type (thefit) ,pointer :: worst,tmp 
    integer,allocatable :: genes(:,:) ! our genes for the ga 
    integer j 
    integer num_genes,gene_size 
    real(b8) x 
    real(b8),allocatable :: z(:) 
    real(b8),pointer :: xyz(:) ! we'll talk about this next 
    num_genes=10 
    gene_size=10 
    allocate(results(num_genes))         ! allocate the data type to 
    allocate(genes(num_genes,gene_size)) ! hold our collection of genes 
    call init_genes(genes)               ! starting data 
    write(*,'("input")') 
    do j=1,num_genes 
       results(j)%index=j 
       results(j)%val=fitness(genes(j,:)) ! just a dummy routine 
       write(*,"(f10.8,i4)")results(j)%val,results(j)%index 
    enddo     allocate(z(size(results))) 
    z=results(:)%val ! copy our results to a real array ! use a recursive subroutine operating on the real array 
    write(*,*)"the lowest fitness: ",findmin(z) 
! use a recursive subroutine operating on the data structure 
    write(*,*)"the lowest fitness: ",findmin(results) 
end program


 

Fortran Minval and Minloc routines

! we show two other methods of getting the minimum fitness  
! use the built in f90 routines  on a real array 
    write(*,*)"the lowest fitness: ",minval(z),minloc(z) 


 

Pointer assignment

! use a recursive subroutine operating on the data 
! structure and returning a pointer to the result 
    worst=>pntmin(results) ! note pointer assignment 
! what will this line write? 
 write(*,*)"the lowest fitness: ",worst
 

 

More pointer usage, association and nullify

! This code will print "true" when we find a match, 
! that is the pointers point to the same object 
    do j=1,num_genes 
     tmp=>results(j) 
        write(*,"(f10.8,i4,l3)")results(j)%val,   & 
                                results(j)%index, &
           associated(tmp,worst) 
    enddo 
    nullify(tmp) 


 

Pointer usage to reference an array without copying

module Merge_mod_types 
    use galapagos 
    type(thefit),allocatable :: work(:) ! a "global" work array 
    type(thefit), pointer:: a_pntr(:)   ! this will be the pointer to our input array 
end module Merge_mod_types 
  subroutine Sort(ain, n) 
    use Merge_mod_types 
    implicit none 
    integer n 
    type(thefit), target:: ain(n) 
    allocate(work(n)) 
    nullify(a_pntr) 
    a_pntr=>ain  ! we assign the pointer to our array 
                 ! in RecMergeSort we reference it just like an array 
    call RecMergeSort(1,n) ! very similar to the findmin functions 
    deallocate(work) 
    return 
end subroutine Sort 
! our sort routine is also recursive but 
! also shows a new usage for pointers 
    call sort(results,num_genes) 
    do j=1,num_genes 
       write(*,"(f10.8,i4)")results(j)%val,   & 
                            results(j)%index 
    enddo 

 

Data assignment with structures

! we can copy a whole structure 
! with a single assignment 
    best=results(1) 
    write(*,*)"best result ",best 
    


 

Using the user defined operator

! using the user defined operator to see if best is worst 
! recall that the operator .converged. checks to see if %index matches 
    worst=>pntmin(results) 
    write(*,*)"worst result ",worst 
    write(*,*)"converged=",(best .converged. worst)
    

 

Passing arrays with a given arbitrary lower bounds

    if(allocated(z))deallocate(z) 
    allocate(z(-10:10)) ! a 21 element array 
    do j=-10,10 
       z(j)=j 
    enddo ! pass z and its lower bound 
! in this routine we give the array a specific lower 
! bound and show how to use a pointer to reference 
! different parts of an array using different indices 
  call boink1(z,lbound(z,1)) ! why not just lbound(z) instead of lbound(z,1)? 
                             ! lbound(z) returns a rank 1 array 
     subroutine boink1(a,n) 
     use numz 
     implicit none 
     integer,intent(in) :: n 
     real(b8),dimension(n:):: a ! this is how we set lower bounds in a subroutine 
     write(*,*)lbound(a),ubound(a) 
   end subroutine

Warning: because we are using an assumed shape array we need an interface

Using pointers to access sections of arrays

call boink2(z,lbound(z,1)) 
 
subroutine boink2(a,n) 
use numz 
implicit none 
integer,intent(in) :: n 
real(b8),dimension(n:),target:: a 
real(b8),dimension(:),pointer::b 
b=>a(n:) ! b(1) "points" to a(-10) 
write(*,*)"a(-10) =",a(-10),"b(1) =",b(1) 
b=>a(0:) ! b(1) "points" to a(0) 
write(*,*)"a(-6) =",a(-6),"b(-5) =",b(-5) 
end subroutine

 

Allocating an array inside a subroutine and passing it back

module numz 
    integer, parameter:: b8 = selected_real_kind(14)
end module

program bla
   use numz
   real(b8), dimension(:) ,pointer :: xyz 

   interface boink 
     subroutine boink(a) 
     use numz
     implicit none 
     real(b8), dimension(:), pointer :: a 
     end subroutine 
   end interface 

   nullify(xyz) ! nullify sets a pointer to null 
   write(*,'(l5)')associated(xyz) ! is a pointer null, should be 
   call boink(xyz) 
   write(*,'(l5)',advance="no")associated(xyz) 
   if(associated(xyz))write(*,'(i5)')size(xyz) 
end program  

subroutine boink(a) 
    use numz 
    implicit none 
    real(b8),dimension(:),pointer:: a 
    if(associated(a))deallocate(a) 
    allocate(a(10)) 
end subroutine 



     F
     T
10


 

Our fitness function

Given a fixed number of colors, M, and a description of a map of a collection of N states.
Find a coloring of the map such that no two states that share a boarder have the same coloring.

Example input is a sorted list of 22 western states

22
ar ok tx la mo xx
az ca nm ut nv xx
ca az nv or xx
co nm ut wy ne ks xx
ia mo ne sd mn xx
id wa or nv ut wy mt xx
ks ne co ok mo xx
la tx ar xx
mn ia sd nd xx
mo ar ok ks ne ia xx
mt wy id nd xx
nd mt sd wy xx
ne sd wy co ks mo ia xx
nm az co ok tx mn xx
nv ca or id ut az xx
ok ks nm tx ar mo xx
or ca wa id xx
sd nd wy ne ia mn xx
tx ok nm la ar xx
ut nv az co wy id xx
wa id or mt xx
wy co mt id ut nd sd ne xx

Our fitness function takes a potential coloring, that is, an integer vector of length N and a returns the number of boarders that have states of the same coloring



 

Linked lists

module list_stuff 
type llist 
integer index ! data 
type(llist),pointer::next ! pointer to the 
! next element 
end type llist 
end module

 

Linked list usage

One way to fill a linked list is to use a recursive function

recursive subroutine insert (item, root) 
use list_stuff 
implicit none 
type(llist), pointer :: root 
integer item 
if (.not. associated(root)) then 
allocate(root) 
nullify(root%next) 
root%index = item 
else 
call insert(item,root%next) 
endif 
end subroutine 


 

Our map representation

    type states 
        character(len=2)name 
        type(llist),pointer:: list 
    end type states 

 

Non advancing and character I/O

character(len=2) a ! we have a character variable of length 2 
read(12,*)nstates ! read the number of states 
allocate(map(nstates)) ! and allocate our map 
do i=1,nstates 
    read(12,"(a2)",advance="no")map(i)%name ! read the name 
    !write(*,*)"state:",map(i)%name 
    nullify(map(i)%list) ! "zero out" our list 
    do 
        read(12,"(1x,a2)",advance="no")a ! read list of states 
        ! without going to the 
        ! next line 
        if(lge(a,"xx") .and. lle(a,"xx"))then ! if state == xx 
        backspace(12) ! go to the next line 
        read(12,"(1x,a2)",end=1)a ! go to the next line 
        exit 
        endif 
        1 continue 
        if(llt(a,map(i)%name))then ! we only add a state to 
        ! our list if its name 
        ! is before ours thus we 
        ! only count boarders 1 time 
        ! what we want put into our linked list is an index 
        ! into our map where we find the bordering state 
        ! thus we do the search here 
        ! any ideas on a better way of doing this search? 
        found=-1 
        do j=1,i-1 
            if(lge(a,map(j)%name) .and. lle(a,map(j)%name))then 
            !write(*,*)a 
            found=j 
            exit 
            endif 
        enddo 
        if(found == -1)then 
            write(*,*)"error" 
            stop 
        endif 
        
        ! found the index of the boarding state insert it into our list 
        ! note we do the insert into the linked list for a particular state 
        call insert(found,map(i)%list) 
        endif 
    enddo 
enddo 


 

Date and time functions

! all arguments are optional 
call date_and_time(date=c_date, &  ! character(len=8) ccyymmdd 
                   time=c_time, &  ! character(len=10) hhmmss.sss 
                   zone=c_zone, &  ! character(len=10) +/-hhmm (time zone) 
                   values=ivalues) ! integer ivalues(8) all of the above 
                   
call system_clock(count=ic,           & ! count of system clock (clicks) 
                  count_rate=icr,     & ! clicks / second 
                  count_max=max_c)      ! max value for count 



 

Internal I/O

character (len=12)tmpstr 
 
write(tmpstr,"(a12)")(c_date(5:8)//c_time(1:4)//".dat") ! // does string concatination 
write(*,*)"name of file= ",tmpstr 
open(14,file=tmpstr) 

name of file= 03271114.dat
! test_vect is an array that we do not know its length until run time 
nstate=9 ! the size of the array 
write(fstr,'("(",i4,"i1,1x,f10.5)")')nstates 
write(*,*)"format= ",fstr 
write(*,fstr)test_vect,fstr

format= ( 9i1,1x,f10.5)

Any other ideas for writing an array when you do not know its length?


integer ht,minut,sec
read(c_time,"(3i2)")hr,minut,sec


 

Inquire function

inquire(iolength=len_real)1.0 
inquire(iolength=len_b8)1.0_b8 
write(*,*)"len_b8 ",len_b8 
write(*,*)"len_real",len_real 
iratio=len_b8/len_real 
select case (iratio) 
    case (1) 
      my_mpi_type=mpi_real 
    case(2) 
      my_mpi_type=mpi_double_precision 
    case default 
      write(*,*)"type undefined" 
      my_mpi_type=0 
end select 


len_b8 2 
len_real 1 



 

Namelist

integer ncolor 
logical force 
namelist /the_input/ncolor,force 
ncolor=4 
force=.true. 
read(13,the_input) 
write(*,the_input) 

On input:

&THE_INPUT NCOLOR=4,FORCE = F / 
Output is
&THE_INPUT 
NCOLOR = 4, 
FORCE = F 
/ 



 

Vector valued functions

function add1(vector,max) result (rtn) 
  integer, dimension(:),intent(in) ::  vector 
  integer,dimension(size(vector)) :: rtn 
  integer max 
  integer len 
  logical carry 
  len=size(vector) 
  rtn=vector 
  i=0 
  carry=.true. 
  do while(carry)         ! just continue until we do not do a carry 
      i=i+1 
   rtn(i)=rtn(i)+1 
   if(rtn(i) .gt. max)then 
       if(i == len)then   ! role over set everything back to 0 
        rtn=0 
    else 
        rtn(i)=0 
       endif 
   else 
       carry=.false. 
   endif 
  enddo 
end function 

Usage

        test_vect=0 
        do 
           test_vect=add1(test_vect,3) 
           result=fitness(test_vect) 
           if(result < 1.0_b8)then 
               write(*,*)test_vect 
               stop 
           endif 
        enddo 


 

Complete source for recent discussions




 
Exersize 5 Modify the program to use the random number generator given earlier.
 

Some array specific intrinsic functions



program matrix 
    real w(10),x(10),mat(10,10) 
    call random_number(w) 
    call random_number(mat) 
    x=matmul(w,mat)   ! regular matrix multiply  USE IT 
    write(*,'("dot(x,x)=",f10.5)'),dot_product(x,x) 
end program  

program allit 
     character(len=10):: f1="(3l1)" 
     character(len=10):: f2="(3i2)" 
     integer b(2,3),c(2,3),one_d(6) 
     logical l(2,3) 
     one_d=(/ 1,3,5 , 2,4,6 /) 
     b=transpose(reshape((/ 1,3,5 , 2,4,6 /),shape=(/3,2/))) 
     C=transpose(reshape((/ 0,3,5 , 7,4,8 /),shape=(/3,2/))) 
     l=(b.ne.c) 
     write(*,f2)((b(i,j),j=1,3),i=1,2) 
     write(*,*) 
     write(*,f2)((c(i,j),j=1,3),i=1,2) 
     write(*,*) 
     write(*,f1)((l(i,j),j=1,3),i=1,2) 
     write(*,*) 
     write(*,f1)all ( b .ne. C ) !is .false. 
     write(*,f1)all ( b .ne. C, DIM=1) !is [.true., .false., .false.] 
     write(*,f1)all ( b .ne. C, DIM=2) !is [.false., .false.] 
end 

 1 3 5 
 2 4 6 

 0 3 5 
 7 4 8 

 TFF 
 TFT 

 F 
 TFF 
 FF 
 
 

 

The rest of our GA



 

Compiler Information

Intel

ifort

ifort man page

.f, .for, .ftn
fixed-format Fortran source; compile
.f90, .f95
free-format Fortran source; compile
-O0, -O1, -O2, -O3, -O4
optimization level
.fpp, .F, .FOR, .FTN, .FPP, .F90
Fortran source file with preprocessor directives
-g
compile for debug
-traceback -notraceback (default)
Add debug information for runtime traceback
-nofree, -free
Source is fixed or free format
-qopenmp
turn on OpenMP

Portland Group (x86)

pgfortran

pgfortran man page

.f, .for, .ftn
fixed-format Fortran source; compile
.f90, .f95, .f03
free-format Fortran source; compile
.cuf
free-format CUDA Fortran source; compile
.CUF
free-format CUDA Fortran source; preprocess, compile
-O0, -O1, -O2, -O3, -O4
optimization level
-g
compile for debug
-traceback (default) -notraceback
Add debug information for runtime traceback
-Mfixed, -Mfree
Source is fixed or free format
-qmp
turn on OpenMP

IBM xlf

xlf90_r

xlf man page

xlf, xlf_r, f77, fort77
Compile FORTRAN 77 source files. _r = thread safe
xlf90, xlf90_r, f90
Compile Fortran 90 source files. _r = thread safe
xlf95, xlf95_r, f95
Compile Fortran 95 source files. _r = thread safe
xlf2003, xlf2003_r,f2003
Compile Fortran 2003 source files. _r = thread safe
xlf2008, xlf2008_r, f2008
Compile Fortran 2008 source files.
.f, .f77, .f90, .f95, .f03, .f08
Fortran source file
.F, .F77, .F90, .F95, .F03, .F08
Fortran source file with preprocessor directives
-qtbtable=full
Add debug information for runtime traceback
-qsmp=omp
turn on OpenMP
-O0, -O1, -O2, -O3, -O4, O5
optimization level
-g , g0, g1,...g9
compile for debug

 

Fortran 95



 

Summary



 

References