Using 3rd party libraries in Fortran

Sometimes I see myself in need of a 3rd party library written in C. With Fortran it is not a problem at all because they work together flawlessly. You only need to pay attention to the functions signature in C and translate them to Fortran 77 using the %VAL and %REF auxiliary constructors (Even though this works for Fortran 90+ too, I'd recommend you to use the standard iso_c_binding module than what's described here).

For example, the C function

void foo(int);

would be called in Fortran with %VAL to pass the argument by value like below

call foo(%VAL(123))

Now, if you have pointer arguments in C like this:

void bar(int*);

you must use %REF in Fortran to pass the argument by reference

call bar(%REF(i))

You must pay special attention to strings in C. They have to end by a NULL char everytime. For example, calling the function void say_happy_holidays(char*); in Fortran would be something like

call say_happy_holidays(%REF('Happy Holidays!' // CHAR(0)))

So, concatenates a NULL char everytime you call a C function with char* argument.

At last, but not least, if you have a pointer return value in C like void* createObject(); you have to use integer*4 (or integer*8 for 64-bit machines) because Fortran 77 doesn't have pointers. Something like below:

integer*8 object
object = createObject()

To show you how all of this can be done I've translated to Fortran the "firework.c" demo from the library pdcurses - http://pdcurses.sourceforge.net/ (or ncurses in *nix world). This library enables the construction of Text User Interfaces (TUI) and have capabilities of simulating menus, windows, animations, colors etc.

To compile it with Force you will need to download pdc34dllw.zip, extract it to a known location and configure the 3 things marked on the screenshot below. The first one is to disable the analyzer checking "Ignore Analyzer errors". Second, in "Additional Parameters -> Compiler -> Options" write down -fno-underscoring (this will disable the underscore suffix on external functions and enables linking to C libraries) and -L followed by the path to the location you extracted pdc34dllw.zip (where pdcurses.lib and pdcurses.dll is). Finally, in "Libraries" write -lpdcurses to link with pdcurses.lib.

To compile it by hand you can open the command prompt in the same path as firework.f, pdcurses.lib and pdcurses.dll are. Call the g77, gfortran or g95 compiler like below:

C:\some path\g77.exe firework.f -L. -lpdcurses -fno-underscoring -o firework.exe


Happy holidays to everyone!

      !> This is a translation to Fortran of firework.c demo from pdcurses library version 3.4
      !! @ref http://pdcurses.sourceforge.net/
      
      subroutine get_color()
      implicitnone
      integer A_BOLD,A_NORMAL,A_COLOR,n,bold,attrset,r,
     &  PDC_COLOR_SHIFT,COLOR_PAIR,x,IAND,ISHFT
      parameter(A_BOLD=X'00800000',A_NORMAL=0,
     &  PDC_COLOR_SHIFT=24,A_COLOR=-16777216)
      external attrset
      COLOR_PAIR(x)=IAND(ISHFT(x,PDC_COLOR_SHIFT),A_COLOR)

        n = RAND() * 2
        if(MOD(n,2).eq.1)then
          bold = A_BOLD
        else
          bold = A_NORMAL
        endif
        n = RAND() * 8
        r = attrset(%VAL(COLOR_PAIR(MOD(n,8)) + bold))
      end

      subroutine explode(row,col)
      implicitnone
      integer row,col
      integer r,erase,mvaddstr
      external erase,mvaddstr

        r = erase()
        r = mvaddstr(%VAL(row),%VAL(col),%REF('-'//CHAR(0)))
        call myrefresh()

        col = col - 1

        call get_color()
        r = mvaddstr(%VAL(row-1),%VAL(col),%REF(' - '//CHAR(0)))
        r = mvaddstr(%VAL(row)  ,%VAL(col),%REF('-+-'//CHAR(0)))
        r = mvaddstr(%VAL(row+1),%VAL(col),%REF(' - '//CHAR(0)))
        call myrefresh()

        col = col - 1

        call get_color()
        r = mvaddstr(%VAL(row - 2),%VAL(col),%REF(' --- '//CHAR(0)))
        r = mvaddstr(%VAL(row - 1),%VAL(col),%REF('-+++-'//CHAR(0)))
        r = mvaddstr(%VAL(row),    %VAL(col),%REF('-+#+-'//CHAR(0)))
        r = mvaddstr(%VAL(row + 1),%VAL(col),%REF('-+++-'//CHAR(0)))
        r = mvaddstr(%VAL(row + 2),%VAL(col),%REF(' --- '//CHAR(0)))
        call myrefresh()

        call get_color()
        r = mvaddstr(%VAL(row - 2),%VAL(col),%REF(' +++ '//CHAR(0)))
        r = mvaddstr(%VAL(row - 1),%VAL(col),%REF('++#++'//CHAR(0)))
        r = mvaddstr(%VAL(row),    %VAL(col),%REF('+# #+'//CHAR(0)))
        r = mvaddstr(%VAL(row + 1),%VAL(col),%REF('++#++'//CHAR(0)))
        r = mvaddstr(%VAL(row + 2),%VAL(col),%REF(' +++ '//CHAR(0)))
        call myrefresh()

        call get_color()
        r = mvaddstr(%VAL(row - 2),%VAL(col),%REF('  #  '//CHAR(0)))
        r = mvaddstr(%VAL(row - 1),%VAL(col),%REF('## ##'//CHAR(0)))
        r = mvaddstr(%VAL(row),    %VAL(col),%REF('#   #'//CHAR(0)))
        r = mvaddstr(%VAL(row + 1),%VAL(col),%REF('## ##'//CHAR(0)))
        r = mvaddstr(%VAL(row + 2),%VAL(col),%REF('  #  '//CHAR(0)))
        call myrefresh()

        call get_color()
        r = mvaddstr(%VAL(row - 2),%VAL(col),%REF(' # # '//CHAR(0)))
        r = mvaddstr(%VAL(row - 1),%VAL(col),%REF('#   #'//CHAR(0)))
        r = mvaddstr(%VAL(row),    %VAL(col),%REF('     '//CHAR(0)))
        r = mvaddstr(%VAL(row + 1),%VAL(col),%REF('#   #'//CHAR(0)))
        r = mvaddstr(%VAL(row + 2),%VAL(col),%REF(' # # '//CHAR(0)))
        call myrefresh()
      end

      subroutine myrefresh()
      implicitnone
      integer LINES,COLS,DELAYSIZE
      common /LINES/LINES
      common /COLS/COLS
      parameter(DELAYSIZE=200)
      integer r,napms,move,refresh
      external napms,move,refresh

        r = napms(%VAL(DELAYSIZE))
        r = move(%VAL(LINES-1),%VAL(COLS-1))
        r = refresh()

      end

      program firework
      implicitnone
      integer*2 COLOR_BLACK,COLOR_RED,COLOR_BLUE,COLOR_GREEN,COLOR_CYAN,
     &  COLOR_MAGENTA,COLOR_YELLOW,COLOR_WHITE
      parameter(COLOR_BLACK=0,COLOR_RED=4,COLOR_GREEN=2,COLOR_BLUE=1,
     &  COLOR_CYAN=COLOR_BLUE+COLOR_GREEN,
     &  COLOR_MAGENTA=COLOR_RED+COLOR_BLUE,
     &  COLOR_YELLOW=COLOR_RED+COLOR_GREEN,
     &  COLOR_WHITE=7)
      integer*2 color_table(0:7)
      data color_table/COLOR_RED, COLOR_BLUE, COLOR_GREEN, COLOR_CYAN,
     &  COLOR_RED, COLOR_MAGENTA, COLOR_YELLOW, COLOR_WHITE/
      integer LINES,COLS
      common /LINES/LINES
      common /COLS/COLS
      integer TRUE,ERR,A_NORMAL
      parameter(TRUE=1,ERR=-1,A_NORMAL=0)
      integer i,start,end,row,diff,flag,direction,MOD,n
      integer r,nodelay,noecho,start_color,init_pair,getch,getmaxy,
     &  getmaxx,endwin,attrset,mvaddstr,erase,wgetch,curs_set
      logical has_colors
      integer*8 initscr,stdscr,newwin,win
      external initscr,nodelay,noecho,has_colors,start_color,init_pair,
     &  getch,getmaxy,getmaxx,endwin,newwin,attrset,mvaddstr,erase,
     &  wgetch,curs_set
      character trail*(2)

        stdscr = initscr()
        r = nodelay(%VAL(stdscr), %VAL(TRUE))
        r = noecho()
        r = curs_set(%VAL(0))

        win = newwin(%VAL(0),%VAL(0),%VAL(0),%VAL(0))
        LINES = getmaxy(%VAL(win))
        COLS = getmaxx(%VAL(win))

        if(has_colors()) r = start_color()

        do i=0,8
          r = init_pair(%VAL(i),%VAL(color_table(i)),
     &      %VAL(COLOR_BLACK))
        enddo

        call SRAND(TIME())
        flag = 0

        dowhile(wgetch(%VAL(stdscr)).eq.ERR)
          do
            n = RAND() * (COLS-3)
            start = MOD(n, COLS-3)
            n = RAND() * (COLS-3)
            end = MOD(n, COLS-3)
            if(start.lt.2) start = 2
            if(end.lt.2) end = 2
            if(start.gt.end)then
              direction = -1
            else
              direction = 1
            endif
            diff = ABS(start-end)
            if(diff.ge.2.and.diff.lt.(LINES - 2)) exit
          enddo

          r = attrset(%VAL(A_NORMAL))

          do row=0,diff
            if(direction.lt.0)then
              trail = CHAR(92) // CHAR(0)
            else
              trail = '/' // CHAR(0)
            endif
            r = mvaddstr(%VAL(LINES-row),
     &        %VAL(row*direction+start), %REF(trail))

            if(flag.ne.0)then
              call myrefresh()
              r = erase()
              flag = 0
            endif
            flag = flag + 1
          enddo

          if(flag.ne.0)then
            call myrefresh()
            flag = 0
          endif
          flag = flag + 1

          call explode(LINES-row, diff*direction+start)
          r = erase()
          call myrefresh()
        enddo

        r = endwin()

      end

F⃗ = m.a⃗ - Challenge #2 [Easy]

Another challenge coming from Reddit Daily Programmer: http://www.reddit.com/r/dailyprogrammer/comments/pjbj8/easy_challenge_2/. This one was really easy. Is's a simple program that computes one of the terms from the formula: F=m.a - Force equals Mass by Acceleration. As always, I have made a presentation menu and used key codes from ASCII table to get user choices.

      !> Transform a character from lowercase to uppercase
      !! Clears the 6th bit of a character to make it uppercase
      !! @param[in] c Character to transform
      !! @return Returns the uppercase character
      character function up_case(c)
      implicit none
      character c
        if(c.ge.'a'.and.c.le.'z')then
          up_case = CHAR(IBCLR(ICHAR(c), 5))
        else
          up_case = c
        endif
      end

      !> Asks for force
      !! @param[out] mass Mass
      double precision function input_force()
      implicit none
        print '(A$)','Enter the force: '
        read *,input_force
      end

      !> Asks for mass
      !! @param[out] mass Mass
      double precision function input_mass()
      implicit none
        print '(A$)','Enter the mass: '
        read *,input_mass
      end

      !> Asks for acceleration
      !! @param[out] accel Acceleration
      double precision function input_accel()
      implicit none
        print '(A$)','Enter the acceleration: '
        read *,input_accel
      end

      !> http://www.reddit.com/r/dailyprogrammer/comments/pjbj8/easy_challenge_2/
      program easy_2
      implicit none
      character key, up_case
      integer*1 key_code
      ! Key codes
      integer*1 FORCE, MASS, ACCEL, QUIT
      parameter(FORCE=X'46',MASS=X'4D',ACCEL=X'41',QUIT=X'51')
      double precision f, m, a, input_force, input_mass, input_accel

      print *,'This program will compute one of the terms from F=M.A'
      do

        print '(A)', 'F. Force;'
        print '(A)', 'M. Mass;'
        print '(A)', 'A. Acceleration;'
        print '(A)', 'Q. Quit.'

        print '(A$)','Select an option (FMAQ): '
        read *, key

        key = up_case(key)
        key_code = ICHAR(key)

        select case (key_code)
        case (FORCE)
          m = input_mass()
          a = input_accel()
          f =  m * a
          print *,'The force is: ', f
        case (MASS)
          f = input_force()
          a = input_accel()
          m =  f / a
          print *,'The mass is: ', m
        case (ACCEL)
          m = input_mass()
          f = input_force()
          a =  f / m
          print *,'The acceleration is: ', a
        case (QUIT)
          exit
        case default
          print '(A,A)', key, ' is not a valid option!'
        end select

      enddo

      print '(A$)','Press ENTER to exit.'
      read *
      end




Guess Game - Challenge #1 [Difficult]

The difficult challenge #1 from Reddit Daily Programmer channel wasn't so difficult as it says (http://www.reddit.com/r/dailyprogrammer/comments/pii6j/difficult_challenge_1/). It was pretty straightforward to write it. Like the other ones, I've written it compatible with both Fortran 77 and Fortran 90/95 (gfortran and g95).

The challenge itself is to write a game where the computer have to guess the number you thought between 1 and 100.

As a side note, the Random Number Generator initialization with SRAND and TIME intrinsic functions is really important to generate true random numbers. Finally, I've written a tricky function to get the maximum integer. I'm using the intrinsic function ISHFT to clear the high bit from -1 (all bits set). Take a look at the max_int() function below.

      !> Transform a character from lowercase to uppercase
      !! Clears the 6th bit of a character to make it uppercase
      !! @param[in] c Character to transform
      !! @return Returns the uppercase character
      character function up_case(c)
      implicit none
      character c
        if(c.ge.'a'.and.c.le.'z')then
          up_case = CHAR(IBCLR(ICHAR(c), 5))
        else
          up_case = c
        endif
      end

      !> Max signed integer
      !! @return Returns max signed integer
      integer function max_int()
      implicit none
      intrinsic ISHFT
        max_int = -1
        max_int = ISHFT(max_int, -1)
      end
      
      !> Choose a random number between lower and higher bound exclusively
      !! @param[in] lower Exclusive lower bound
      !! @param[in] lower Exclusive higher bound
      !! @return Returns a random number between lower and higher exclusively
      integer function exclusive_rand(lower,higher)
      implicit none
      integer higher,lower,range,number,max_int
      intrinsic MOD,RAND
        range = higher - lower - 1
        number = RAND() * max_int()
        exclusive_rand = MOD(number,range)+1+lower
      end

      !> http://www.reddit.com/r/dailyprogrammer/comments/pii6j/difficult_challenge_1/
      program difficult_challenge_1
      implicit none
      intrinsic TIME,SRAND,ICHAR
      integer guess,higher_guess,lower_guess,count,exclusive_rand
      character key
      integer*1 key_code
      integer*1 YES, HIGHER, LOWER
      parameter(YES=X'59',HIGHER=X'48',LOWER=X'4C')
      character up_case
      integer LOWER_BOUND,HIGHER_BOUND
      parameter(LOWER_BOUND=1,HIGHER_BOUND=100)

      print '(A$)','This is a game where I (the computer) will try and'
      print '(A)',' guess a number you choose.'
      print '("Please choose a number between ",I4,$)',LOWER_BOUND
      print '(" and ",I4)',HIGHER_BOUND
      print '(A)','Once you have chosen a number, press ENTER.'
      read *
      
      ! initializes the random number generator
      call SRAND(TIME())
      
      count = 1
      lower_guess = LOWER_BOUND-1
      higher_guess = HIGHER_BOUND+1
      guess = exclusive_rand(lower_guess,higher_guess)
      
      do
        print '("Is your number ",I3,"?",$)',guess
        print '(A$)',' [Yes (y), Higher (h), Lower (l)]'
        read *,key
        
        key = up_case(key)
        key_code = ICHAR(key)

        select case (key_code)
        case (YES)
          print '(A,I3,A$)','Yippee! It took me ',count,' tries to'
          print '(A,I3,A)',' guess your number, which was ',guess,'.'
          exit
        case (HIGHER)
          lower_guess = guess
        case (LOWER)
          higher_guess = guess
        case default
          print '(A,A)', key, ' is not a valid option!'
          cycle
        end select

        guess = exclusive_rand(lower_guess,higher_guess)
        count = count + 1
      enddo
      

      print '(A$)','Press ENTER to exit.'
      read *
      end




Events Database - Challenge #1 [Intermediate]

This is the intermediate challenge number #1 from Reddit Daily Programmer: http://www.reddit.com/r/dailyprogrammer/comments/pihtx/intermediate_challenge_1/. The program main objective is to organize events by hour. I thought that one would be easy, but because Fortran 77 doesn't have something easy like dynamic memory allocation, I was forced to use file access to persist data. That way I can resize and shrink the number of records dynamically. At least, its a good resource on how to use files in Fortran.

      !> Program global constants
      blockdata globals
        implicit none
        integer RECORD_SIZE
        character*(9) RECORD_COUNT_FMT,RECORD_FMT
        common /RECORD_COUNT_FMT/RECORD_COUNT_FMT
        common /RECORD_FMT/RECORD_FMT
        common /RECORD_SIZE/RECORD_SIZE
        data RECORD_SIZE/30/
        data RECORD_COUNT_FMT/'(I10,20X)'/
        data RECORD_FMT/'(A20,I10)'/
      end

      !> Transform a character from lowercase to uppercase
      !! Clears the 6th bit of a character to make it uppercase
      !! @param[in] c Character to transform
      !! @return Returns the uppercase character
      character function up_case(c)
      implicit none
      character c
        if(c.ge.'a'.and.c.le.'z')then
          up_case = CHAR(IBCLR(ICHAR(c), 5))
        else
          up_case = c
        endif
      end
      
      !> Checks if returned status code from a read/write is end-of-file
      !! @param[in] status IOSTAT status
      !! @return Returns if the status is end-of-file
      logical function is_eof(status)
      implicit none
      integer status
        is_eof = status.lt.0
      end

      !> Checks if returned status code from a read/write is an error
      !! @param[in] status IOSTAT status
      !! @return Returns if the status is an error
      logical function is_error(status)
      implicit none
      integer status
        is_error = status.gt.0
      end
      
      !> Checks if returned status code from a read/write is ok
      !! @param[in] status IOSTAT status
      !! @return Returns if the status is ok
      logical function is_ok(status)
      implicit none
      integer status
        is_ok = status.eq.0
      end

      !> Reads the number of records from database
      !! @return Returns true if no error
      logical function db_read_record_count()
      implicit none
        integer unit,record_count,status
        common /database/ unit,record_count
        logical db_write_record_count,is_eof,is_error,is_ok
        character*(9) FMT
        common /RECORD_COUNT_FMT/FMT
        
        read(unit,FMT,IOSTAT=status,REC=1) record_count

        if(is_eof(status)) then
          record_count=0
          if(.not.db_write_record_count()) then
            print *,'FATAL ERROR: cannot access database'
            stop
          endif
          status = 0
        endif
        
        db_read_record_count = is_ok(status)
        if (is_error(status)) then
          print *,'FATAL ERROR: cannot read record count from database'
          stop
        endif
      end

      !> Writes the number of records to database
      !! @return Returns true if no error
      logical function db_write_record_count()
      implicit none
        integer unit,record_count,status
        common /database/ unit, record_count
        logical is_ok,is_error
        character*(9) FMT
        common /RECORD_COUNT_FMT/ FMT
        
        write(unit,FMT,IOSTAT=status,REC=1) record_count
        db_write_record_count = is_ok(status)
        if (is_error(status)) then
          print *,'ERROR writing record count to database'
          return
        endif
      end

      !> Reads the record data from database
      !! @param[out] name The name
      !! @param[out] hour The hour
      !! @param[in] position The position to read the record
      !! @return Returns true if no error
      logical function db_read_record(name, hour, position)
      implicit none
        character*(*) name
        integer hour,position,status,unit,record_count
        common /database/ unit, record_count
        logical is_ok,is_error
        character*(9) FMT
        common /RECORD_FMT/FMT

        read(unit,FMT,IOSTAT=status,REC=position + 1) name, hour
        db_read_record = is_ok(status)
        if (is_error(status)) then
          print *,'ERROR reading record ',position,' from database'
          return
        endif
      end

      !> Writes the record data to database
      !! @param[in] name The name
      !! @param[in] hour The hour
      !! @param[in] position The position to write the record
      !! @return Returns true if no error
      logical function db_write_record(name, hour, position)
      implicit none
        character*(*) name
        integer hour,position,unit,record_count,status
        common /database/ unit, record_count
        logical is_ok,is_error
        character*(9) FMT
        common /RECORD_FMT/FMT

        write(unit,FMT,IOSTAT=status,REC=position + 1) name,hour
        db_write_record = is_ok(status)
        if (is_error(status)) then
          print *,'ERROR writing record ',position,' to database'
          return
        endif
      end
      
      !> Lists all records
      subroutine do_list()
      implicit none
        integer unit,record_count
        common /database/ unit, record_count
        character*(100) name_buffer
        integer hour
        logical db_read_record
        integer position

        do position=1,record_count
          if(.not.db_read_record(name_buffer, hour, position))return
          print '(I3,A,A20,A,I10)',
     _      position, '. ', name_buffer, ' -> ', hour
        enddo
        
        print *,'Records read: ', record_count
      end

      !> Asks user the record data
      !! @param[out] name The name
      !! @param[out] hour The hour
      subroutine input_record(name, hour)
      implicit none
        character*(*) name
        integer hour

        print '(A$)', 'Event name: '
        read *,name

        do
          print '(A$)', 'Event hour: '
          read *,hour
          if(hour.ge.0.and.hour.le.24) exit
          print *, 'ERROR: Invalid hour'
        enddo
      end

      !> Asks user a record position
      !! @param[out] position Record position
      !! @return Returns if the position is valid
      logical function input_position(position)
      implicit none
        integer unit
        integer record_count
        common /database/ unit, record_count
        integer position
        
        print '(A$)', 'Enter record #: '
        read *,position

        input_position = position.ge.1.and.position.le.record_count
        if(.not.input_position)then
          print *, 'ERROR: invalid record #'
        endif
      end

      !> Asks user and commits record data
      !! @param[in] position The record's position
      !! @return Returns true if no error
      logical function asks_and_write_user_input(position)
      implicit none
        integer position
        character*(100) name_buffer
        integer hour
        logical db_write_record

        call input_record(name_buffer, hour)

        asks_and_write_user_input = db_write_record(name_buffer, hour,
     _    position)
      end

      !> Adds a new record at the end of database
      subroutine do_add()
      implicit none
        integer unit,record_count
        common /database/ unit, record_count
        logical asks_and_write_user_input, db_write_record_count
        
        if(.not.asks_and_write_user_input(record_count + 1)) then
          print *,'ERROR writing record to database'
          return
        endif
        
        record_count = record_count + 1
        if(.not.db_write_record_count()) return
      end

      !> Edits a record
      subroutine do_edit()
      implicit none
        integer unit
        integer record_count
        common /database/ unit, record_count
        integer position
        logical asks_and_write_user_input, input_position

        if(.not.input_position(position)) return
        
        if(.not.asks_and_write_user_input(position)) then
          print *,'ERROR writing record to database'
          return
        endif
      end

      !> Deletes a record
      subroutine do_delete()
      implicit none
        integer unit,record_count
        common /database/ unit, record_count
        integer position,i
        character*(100) name_buffer
        integer hour
        logical db_read_record,db_write_record,db_write_record_count
        logical input_position

        if(.not.input_position(position)) return

        do i=position, record_count - 1
          if(.not.db_read_record(name_buffer, hour, position + 1))return
          if(.not.db_write_record(name_buffer, hour, position)) return
        enddo
        
        name_buffer=' '
        hour=-1
        if(.not.db_write_record(name_buffer, hour, record_count)) return

        record_count = record_count - 1
        if(.not.db_write_record_count()) return
      end

      !> Opens the database
      subroutine db_open()
      implicit none

        character*(*) DATABASE_FILE
        parameter(DATABASE_FILE='Challenge_1_Intermediate.db')
        integer unit,record_count
        common /database/ unit, record_count
        logical db_read_record_count
        data unit/10/
        integer RECORD_SIZE
        common /RECORD_SIZE/RECORD_SIZE
        open(unit, FILE=DATABASE_FILE, ACCESS='DIRECT',
     _    FORM='FORMATTED', RECL=RECORD_SIZE)
        if(.not.db_read_record_count()) stop
      end

      !> Closes the database
      subroutine db_close()
      implicit none

        integer unit
        integer record_count
        common /database/ unit, record_count
        close(unit)

      end

      !> http://www.reddit.com/r/dailyprogrammer/comments/pihtx/intermediate_challenge_1/
      program intermediate_1
      implicit none
      character key, up_case
      integer*1 key_code
      integer*1 LIST, ADD, EDIT, DEL, QUIT
      parameter(LIST=X'4C',ADD=X'41',EDIT=X'45',DEL=X'44',QUIT=X'51')

      call db_open()
      
      do

        print '(A)', 'L. List events;'
        print '(A)', 'A. Add event;'
        print '(A)', 'E. Edit event;'
        print '(A)', 'D. Delete events;'
        print '(A)', 'Q. Quit.'

        print '(A$)','Select an option (LAEDQ): '
        read *, key

        key = up_case(key)
        key_code = ICHAR(key)

        select case (key_code)
        case (LIST)
          call do_list()
        case (ADD)
          call do_add()
        case (EDIT)
          call do_edit()
        case (DEL)
          call do_delete()
        case (QUIT)
          exit
        case default
          print '(A,A)', key, ' is not a valid option!'
        end select

      enddo
      
      call db_close()

      print '(A$)','Press ENTER to exit.'
      read *
      end




Input/Output - Challenge #1 [Easy]

Here we go. This is the Challenge #1 [Easy] from Reddit Daily Programmer in Fortran 77: http://www.reddit.com/r/dailyprogrammer/comments/pih8x/easy_challenge_1/.

The note here is the function ADJUSTL that g77 doesn't implement. I've written my own.

      !> Remove left spaces from string as the intrinsic function
      !! @param[in] str String to remove left spaces
      !! @return Returns the string without left spaces
      character*(*) function adjustl(str)
      implicit none
      character*(*) str
        integer i
        adjustl = ' '
        do i=1,LEN(str)
          if(str(i:i).ne.' ') then
            adjustl = str(i:)
            exit
          endif
        enddo
      end

      !> Formats the output to an unit
      !! @param[in] unit Unit number to write
      !! @param[in] name Asked name
      !! @param[in] age Asked age
      !! @param[in] login Asked login
      subroutine output(unit,name,age,login)
      implicit none
      integer unit,age
      character*(*) name,login
        intrinsic LEN_TRIM
        character*10 ageStr,adjustl
        ! formats integer to string
        write(ageStr, '(I10)') age
        ageStr = adjustl(ageStr)
      
        write(unit, '(2A$)')'Your name is ', name(:LEN_TRIM(name))
        write(unit, '(3A$)')', you are ', ageStr(:LEN_TRIM(ageStr)),
     _    ' years old'
        write(unit, '(2A)')', and your username is ',
     _    login(:LEN_TRIM(login))
      end

      !> Formats output to the screen
      !! @param[in] name Asked name
      !! @param[in] age Asked age
      !! @param[in] login Asked login
      subroutine output_to_screen(name,age,login)
      implicit none
      integer age
      character*(*) name, login
        integer SCREEN
        parameter(SCREEN=6)

        call output(SCREEN, name, age, login)
        
      end
      
      !> Formats output to a file
      !! @param[in] filename Filename to output for
      !! @param[in] name Asked name
      !! @param[in] age Asked age
      !! @param[in] login Asked login
      subroutine output_to_file(filename,name,age,login)
      implicit none
      integer age
      character*(*) filename, name, login
        integer file
        parameter(file=10)

        open(file, FILE=filename)
        call output(file, name, age, login)
        close(file)
        
      end
      
      !> http://www.reddit.com/r/dailyprogrammer/comments/pih8x/easy_challenge_1/
      program easy_1
      implicit none
      
        character*20 name
        integer age
        character*20 login

        print '(A$)','What is your name? '
        read *,name
        print '(A$)','How old are you? '
        read *,age
        print '(A$)','What is your Reddit username? '
        read *,login

        call output_to_screen(name, age, login)
        call output_to_file('Challenge_1_Easy.txt', name, age, login)

        print '(A$)','Press ENTER to exit.'
        read *

      end

Reddit Daily Programmer Challenges in Fortran

After long time I'm back again. The good news is that I've started writing in Fortran the challenges from Daily Programmer Reddit channel: http://www.reddit.com/r/dailyprogrammer. It's a good source of problems to write in Fortran and show you how Fortran works by examples.

I'll try to sticky the challenges with Fortran 77 and made them compatible with g95 and gfortran also.

In the meantime, I'm going to write them in Perl, Python, Haskell and LISP to teach myself these languages.

Next post will be the easy challenge #1, after that, the intermediate challenge #1, the hard #1, easy #2 and go on.