Intel® Fortran Compiler
Build applications that can scale for the future with optimized code designed for Intel® Xeon® and compatible processors.

Array of Linked list

Heo__Jun-Yeong
1,663 Views

Hi, I want to build array of linked list, which will be used as temporary sparse matrix storage,

in case when the number of row of matrix is known, but the number of elements in each row is unknown.

So, I want to make array of linked list, whose size is the number of row of matrix,

and store the matrix by filling the colume as linked list.

below is my temporary version.

program test
    implicit none
    type :: pointCSR
        integer :: icol
        ! complex(8) :: cval    -> will be added later
        type(pointCSR), pointer :: p
    end type
    type(pointCSR), dimension(:), pointer  :: head, tail
    type(pointCSR), pointer :: ptr
 
    integer :: nrow = 3
    integer :: i, istat
    integer :: n1, n2
    logical, dimension(nrow) :: lswt

    allocatae(head(nrow), tail(nrow))
    tail(1:nrow) => head(1:nrow)
    do i = 1, 3
          nullify(tail(i)%p)
    end do
    lswt(:) = .true.

    open(1, file='input.dat')
    do 
           read(1, '(2(I))', iostat=istat) n1, n2
          if (istat.ne.0) exit
 
          if (lswt(n1)) then
              lswt(n1) = .false.
              tail(n1)%icol = n2
          else
              allocate(tail(n1)%p)
              tail(n1) => tail(n1)%p
              nullify(tail(n1)%p)
              tail(n1)%icol = n2
          end if
    end do
    close(1)

    !print results
    do i = 1, nrow
          print*, 'row: ', i
          ptr => head(i)
          do 
                  if (.not.associated(ptr)) exit
                  print*, ptr%icol
                  ptr => ptr%p
           dnd do
     end do
end program test

 

when I compile the upper program the error message comes out:

error #8524: The syntax of this data pointer assignment is incorrect: either 'bound spec' or 'bound remapping' is expected in this context.   [N1]
                tail(n1) => tail(n1)%p
---------------------^

I don't know why and how to fix the code...

Also, I need code for successfully deallocating the array of linked list in order to prevent memory leak...

If you find error, or have better idea, please let me know.

0 Kudos
1 Solution
JVanB
Valued Contributor II
1,663 Views

Well, I looked over your code and there were a few things I noticed:

  1. Use of hardwired KIND numbers like COMPLEX(8) CVAL
  2. Use of hardwired unit numbers like OPEN(1,FILE='csriinput.dat')
  3. Duplication of information already stored in Fortran 'fat' pointers
  4. Bare pointers in tree-type data structures

the rest

The first 3 bullet points above are easily fixed, but the fourth needs some explanation. Fortran pointers aren't first-class data objects in the sense that you can't point at them, only their target, not to mention that you can't have arrays of them, only pointers to arrays. In tree-type data structures (I don't know if that is the right terminology, I just mean data structures which contain pointers to structures of the same type) you need pointers that are first-class data objects and the lack of them means you end up with all sorts of special cases to deal with that make code difficult to maintain.

The solution is to wrap the pointers that point at structures of the same type in their own structure that contains only the pointer. The enclosing structure then is a first-class data object and the code simplifies quite a bit. Here is llarray.f90

! llarray.f90
module M
   implicit none
!   integer, parameter :: dp = kind([double precision ::])
   type PTRllnode
      type(llnode), pointer :: p => NULL()
   end type PTRllnode
   type llnode
      integer col
!      complex(dp) payload
      type(PTRllnode) next
   end type llnode
end module M

program Q
   use M
   implicit none
   type(PTRllnode), pointer :: p
   type(PTRllnode), allocatable, target :: heads(:)
   integer nrow
   integer row
   integer col
   integer iunit, istat
!   complex(dp) payload

   open(newunit=iunit,file='csriinput.txt',status='old')
   read(iunit,*) nrow
   allocate(heads(nrow))
   do
      read(iunit,*,iostat=istat) row,col !,payload
      if(istat /= 0 .OR. row < lbound(heads,1) .OR. row > ubound(heads,1)) exit
      p => heads(row)
      do while(associated(p%p))
         p => p%p%next
      end do
      allocate(p%p)
      p%p%col = col
!      p%p%payload = payload
   end do

   do row = lbound(heads,1),ubound(heads,1)
      print '(*(g0))', 'row: ',row
      p => heads(row)
      do while(associated(p%p))
         print '(*(g0))', '   col: ',p%p%col
         p => p%p%next
      end do
   end do
end program Q

And the input file, csriinput.txt

3
1 2
1 3
3 1
3 3

And the program output:

row: 1
   col: 2
   col: 3
row: 2
row: 3
   col: 1
   col: 3

I also used initializers so that all the pointers came out nullified from the start.

View solution in original post

0 Kudos
13 Replies
Steve_Lionel
Honored Contributor III
1,663 Views

Fortran does not have the concept of an array of pointers. tail is a pointer that points to an array. One way to approach this is to make tail an array of a derived type containing a pointer. But I don't think that's the solution you're looking for.

I haven't yet figured out what you are trying to do with 

              allocate(tail(n1)%p)
              tail(n1) => tail(n1)%p
              nullify(tail(n1)%p)
              tail(n1)%icol = n2

Don't you want the p of the current tail to point to the newly allocated one? You'd maybe want something that has the effect of:

current_tail%p => tail(n1)%p

As you have it now, tail is an array of pointCSR items. I often find it helpful to sketch out diagrams on paper of what I want structures and pointers to look like before and after an operation.

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear Steve

My code is based on the fortran book I read.

In that book, the basic algorithm of linked list is like below

program linked list
    implicit none
    type :: rlist
        real :: v
        type(rlist), pointer :: p
    end type rlist

    type(rlist), pointer :: head, tail
    integer :: istat
    real :: tmp

    open(1, file='input.dat')
    do 
        read(1,*,iostat=istat) tmp
        if (istat.ne.0) exit

        if (.not.associated(head)) then	! no values in list
            allocate(head)		! allocate new value
            tail => head		! tail points to new value
            nullify(tail%p)		! nullify p in new value
            tail%v = tmp		! store number
        else				! values already in list
            allocate(tail%p)		! allocate new value
            tail=>tail%p		! tail points to new value
            nullify(tail%p)		! nullify p in new value
            tail%v = tmp		! store number
        end if
    end do
    close(1)
end program

So, I just simply wanted to make that algorithm in array form like below..

listarray.png

but maybe this form is impossible in fortran and I can't figure out about it anyway...

0 Kudos
mecej4
Honored Contributor III
1,663 Views

I am not sure what you want to do, but are you aware of the CSR (compressed sparse row), CSC (compressed sparse column) and COO (row-column-value triplet array) sparse matrix storage schemes? MKL uses CSR, and you can see a description of these schemes at https://en.wikipedia.org/wiki/Sparse_matrix . Usually, in these schemes arrays are used, but you could use linked lists instead.

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear mecej4

Yes, I'm thinking of CSR format.

What I'm working on is numerical modeling of wave equations( elastic, acoustic, electromagentic)

When I'm trying to use FEM and solve matrix equation by PARDISO, the main problem is constructing CSR arrays.

This is because I don't know how many components will be in system matrix, so I can't allocate CSR arrays(ja, a).

(I know the number of rows of matrix, but I don't know the number of components will be in each row)

What I think as a solution is store informations by using linked list since it does not need to be allocated in advance,

it can count the number of components while storing informations, sorting is also possible while inserting informations.

Then, the arrays for CSR format can be allocated and filled in from the data stored in linked list.

However, if I perform that process by using single linked list, the sorting process can be very inefficient.

So, I'm trying to make the number of rows of linked lists.

0 Kudos
mecej4
Honored Contributor III
1,663 Views

You can make two passes over your mesh. In the first pass, you simply keep counters for the number of non-zero entries in each row. You do only enough of the FEM element calculation to know that the value is not zero -- the actual non-zero value is not needed yet.

Once you have processed the whole mesh, you know the number of entries in each row; in other words, the entries in the IA (row pointer) array. Allocate the JA(1:nnz), V(1:nnz) arrays (column number, value) for the CSR representation.

Make a second pass over the mesh. This time, compute the element contributions completely, and fill in the JA and V array entries.

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear mecej4

Since I'll use edge-based FEM in tetralhedral element and the mesh is generated by using mesh generator,

I think the problem is a little bit more complex.

In edge-based FEM, the number of components in each row is associated with the number of elements which share common edge.

Since the mesh is tetrahedron, the number of elements is irregular and it requires very inefficient loop to find the elements.

This is what I want to avoid.

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear Steve

I think I've found the solution!

New code is like below.

program test
    implicit none
    type :: pointCSR
        integer  :: v
        type(pointCSR), pointer :: p
    end type pointCSR

    type :: arrpointCSR
        logical :: switch
        type(pointCSR), pointer :: p
    end type arrpointCSR

    type(pointCSR), pointer :: ptr
    type(arrpointCSR), dimension(:), allocatable :: heads
    integer :: nrow = 3
    integer :: i, istat
    integer :: n1, n2

    allocate(heads(nrow))
    heads(:)%switch = .False.

    open(1, file='csriinput.dat')
    do 
        read(1,*,iostat=istat) n1, n2
        if (istat.ne.0) exit
    
        if (.not.heads(n1)%swt) then
            allocate(ptr)
            ptr%v = n2
            nullify(ptr%p)
            heads(n1)%p => ptr
            heads(n1)%swt = .True.
       else
            ptr => heads(n1)%p
            do
                if (associated(ptr%p)) then
                    ptr => ptr%p
                else
                    allocate(ptr%p)
                    ptr => ptr%p
                    ptr%v = n2
                    nullify(ptr%p)
                    exit
                end if
            end do
        end if
    end do
    close(1)

    ! print results
    do i = 1, nrow
        print*, 'row: ', i
        ptr => heads(i)%p
        do 
            if (.not.associated(ptr)) exit
            print*, ptr%v
            ptr => ptr%p
        end do
    end do
end program test

This code seems good and the result is fine.

But if you have better ideas, it'll be very grateful to leave comments about the code.

0 Kudos
andrew_4619
Honored Contributor II
1,663 Views

What I might do is allocate your storage array at a first guess size. And then start populating the array. If I get to a point where the array is full I allocate a larger temp array (maybe x2), copy to the tmp array and the do a MOVE_ALLOC which dellocates the tmp array and replaces the original array with the temp array. The move_alloc avoids copying the data twice, there is only one copy operation. If you want an exactly full array you need a move_alloc at the end to an array of exactly the correct size.

 

 

0 Kudos
JVanB
Valued Contributor II
1,664 Views

Well, I looked over your code and there were a few things I noticed:

  1. Use of hardwired KIND numbers like COMPLEX(8) CVAL
  2. Use of hardwired unit numbers like OPEN(1,FILE='csriinput.dat')
  3. Duplication of information already stored in Fortran 'fat' pointers
  4. Bare pointers in tree-type data structures

the rest

The first 3 bullet points above are easily fixed, but the fourth needs some explanation. Fortran pointers aren't first-class data objects in the sense that you can't point at them, only their target, not to mention that you can't have arrays of them, only pointers to arrays. In tree-type data structures (I don't know if that is the right terminology, I just mean data structures which contain pointers to structures of the same type) you need pointers that are first-class data objects and the lack of them means you end up with all sorts of special cases to deal with that make code difficult to maintain.

The solution is to wrap the pointers that point at structures of the same type in their own structure that contains only the pointer. The enclosing structure then is a first-class data object and the code simplifies quite a bit. Here is llarray.f90

! llarray.f90
module M
   implicit none
!   integer, parameter :: dp = kind([double precision ::])
   type PTRllnode
      type(llnode), pointer :: p => NULL()
   end type PTRllnode
   type llnode
      integer col
!      complex(dp) payload
      type(PTRllnode) next
   end type llnode
end module M

program Q
   use M
   implicit none
   type(PTRllnode), pointer :: p
   type(PTRllnode), allocatable, target :: heads(:)
   integer nrow
   integer row
   integer col
   integer iunit, istat
!   complex(dp) payload

   open(newunit=iunit,file='csriinput.txt',status='old')
   read(iunit,*) nrow
   allocate(heads(nrow))
   do
      read(iunit,*,iostat=istat) row,col !,payload
      if(istat /= 0 .OR. row < lbound(heads,1) .OR. row > ubound(heads,1)) exit
      p => heads(row)
      do while(associated(p%p))
         p => p%p%next
      end do
      allocate(p%p)
      p%p%col = col
!      p%p%payload = payload
   end do

   do row = lbound(heads,1),ubound(heads,1)
      print '(*(g0))', 'row: ',row
      p => heads(row)
      do while(associated(p%p))
         print '(*(g0))', '   col: ',p%p%col
         p => p%p%next
      end do
   end do
end program Q

And the input file, csriinput.txt

3
1 2
1 3
3 1
3 3

And the program output:

row: 1
   col: 2
   col: 3
row: 2
row: 3
   col: 1
   col: 3

I also used initializers so that all the pointers came out nullified from the start.

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear Repeat Offender

I'm not sure about myself that I perfectly understood your explanations about first class data objects and tree-type data structures.

So, If it does not disturb you, may I ask some more questions about them?

Be rid of my special case (array of linked lists) and go to the basic linked list case, the simple form to make linked list is:

program linkedlist
    implicit none
    type :: list
        integer :: v
        ...
        type(list), pointer :: next
    end type list
    type(list), pointer :: ptr
    type(list), pointer :: head
    ...
end program

If I understand clear, the upper formula has some internal problems. The right form is:

program linkedlist2
    implicit none
    type :: ptrlist
        type(list), pointer :: p => null()
    end type ptrlist
    type :: list
        integer :: v
        ....
        type(ptrlist) :: next  ! Does 'type(list), pointer :: next' is also not possible?
    end type list
    type(ptrlist), pointer :: ptr
    type(ptrlist), target :: head
    ....
end program

Am I right? I can't make sure that the upper formula is generally better than the first simple formula or just appropriate for my array of linked list case.

0 Kudos
mecej4
Honored Contributor III
1,663 Views

The important idea that RO conveyed is that in Fortran, in contrast to, say, C, "pointer" is an attribute, not a type. Or, to use terms from grammar, "pointer" is an adjective, not a noun. Therefore, you cannot have an array of pointers in Fortran, in contrast to C, where you certainly can. You can have a set of sharp knives, but you cannot have a set of sharps (unless you are a seamster, to whom "sharp" is a kind of sewing needle).

The second difference is that when the name of a variable with the pointer attribute is used in an expression, etc., no special symbol is used to specify that dereferencing is to be done. In C, on the other hand, if p is a pointer to a certain variable v, *p is the value of the target. Thus, instead of the C code

   p = &v; *p = expression;

in Fortran we do

   p => v; p = expression

Given these differences, what RO does is to show how to accomplish something that is prohibited (given his title, that is his duty!), i.e., create an array of lightly clad pointers.

0 Kudos
JVanB
Valued Contributor II
1,663 Views

I was trying to make also the point that tree-type data structures are easier to work with if they don't have naked pointers. Here is an example where module M1 has naked pointers and module M2 has pointers wrapped in structures. Note that module M2 is a lot simpler because many special cases have been removed. I first saw this technique in IIRC Walt Brainerd's book and I was very impressed with it.

! tesll.f90
module M
   implicit none
   private
   type, public :: MyType
      integer key
      contains
         procedure GreaterOrEqual
         generic :: operator(>=) => GreaterOrEqual
         procedure Assign
         procedure Construct
         generic :: assignment(=) => Assign, Construct
   end type MyType
   enum, bind(C)
      enumerator :: &
         OpInsertAtHead = 1, &
         OpInsertInOrder = 2, &
         OpInsertATail = 3, &
         OpDelete = 4, &
         OpDeleteInOrder = 6, &
         OpFind = 7, &
         OpFindInOrder = 8, &
         OpPrintForward = -1, &
         OpPrintReverse = -2, &
         OpDestroy = -3
   end enum
   public :: OpInsertAtHead, OpInsertInOrder, OpInsertATail, &
      OpDelete, OpDeleteInOrder, OpFind, OpFindInOrder, &
      OpPrintForward, OpPrintReverse, OpDestroy
   contains
      function GreaterOrEqual(this,that)
         logical GreaterOrEqual
         class(MyType), intent(in) :: this
         type(MyType), intent(in) :: that
         GreaterOrEqual = this%key >= that%key
      end function GreaterOrEqual
      subroutine Assign(this,that)
         class(MyType), intent(out) :: this
         type(MyType), intent(in) :: that
         this%key = that%key
      end subroutine Assign
      subroutine Construct(this,value)
         class(MyType), intent(out) :: this
         integer, intent(in) :: value
         this%key = value
      end subroutine Construct
end module M

module M1
   use M, T => MyType
   implicit none
   private
   public sub
   type ListNode
      type(T) key
      type(ListNode), pointer :: next => NULL()
   end type ListNode
   contains
      subroutine InsertAtHead(head,value)
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor
         allocate(cursor)
         cursor%next => head
         cursor%key = value
         head => cursor
      end subroutine InsertAtHead
      subroutine InsertInOrder(head,value)
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor
         if(.NOT.associated(head)) then
            call InsertAtHead(head,value)
         else if(head%key >= value) then
            if(.NOT.value >= head%key) then
               call InsertAtHead(head,value)
            end if
         else
            cursor => head
            do while(associated(cursor%next))
               if(cursor%next%key >= value) then
                  if(.NOT.value >= cursor%next%key) then
                     call InsertAtHead(cursor%next,value)
                  end if
                  return
               end if
               cursor => cursor%next
            end do
            allocate(cursor%next)
            cursor%next%key = value
         end if
      end subroutine InsertInOrder
      subroutine InsertAtTail(head,value)
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor
         if(.NOT.associated(head)) then
            allocate(head)
            head%key = value
         else
            cursor => head
            do
               if(cursor%key >= value) then
                  if(value >= cursor%key) then
                     return
                  end if
               end if
               if(.NOT.associated(cursor%next)) exit
               cursor => cursor%next
            end do
            allocate(cursor%next)
            cursor%next%key = value
         end if
      end subroutine InsertAtTail
      subroutine Delete(head,value)
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor, temp
         if(.NOT.associated(head)) then
            return
         else if(value >= head%key .AND. head%key >= value) then
            cursor => head
            head => head%next
            deallocate(cursor)
         else
            cursor => head
            do while(associated(cursor%next))
               if(value >= cursor%next%key .AND. cursor%next%key >= value) then
                  temp => cursor%next
                  cursor%next => cursor%next%next
                  deallocate(temp)
                  return
               end if
               cursor => cursor%next
            end do
         end if
      end subroutine Delete
      subroutine DeleteInOrder(head,value)
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor, temp
         if(.NOT.associated(head)) then
            return
         else if(head%key >= value) then
            if(value >= head%key) then
               cursor => head
               head => head%next
               deallocate(cursor)
            end if
         else
            cursor => head
            do while(associated(cursor%next))
               if(cursor%next%key >= value) then
                  if(value >= cursor%next%key) then
                     temp => cursor%next
                     cursor%next => cursor%next%next
                     deallocate(temp)
                  end if
                  return
               end if
               cursor => cursor%next
            end do
         end if
      end subroutine DeleteInOrder
      function Find(head,value)
         logical Find
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor
         if(.NOT.associated(head)) then
            Find = .FALSE.
         else
            cursor => head
            do while(associated(cursor))
               if(value >= cursor%key .AND. cursor%key >= value) then
                  Find = .TRUE.
                  return
               end if
               cursor => cursor%next
            end do
            Find = .FALSE.
         end if
      end function Find
      function FindInOrder(head,value)
         logical FindInOrder
         type(ListNode), pointer :: head
         type(T), intent(in) :: value
         type(ListNode), pointer :: cursor
         if(.NOT.associated(head)) then
            FindInOrder = .FALSE.
         else
            cursor => head
            do while(associated(cursor))
               if(cursor%key >= value) then
                  FindInOrder = value >= cursor%key
                  return
               end if
               cursor => cursor%next
            end do
            FindInOrder = .FALSE.
         end if
      end function FindInOrder
      subroutine PrintForward(head)
         type(ListNode), pointer :: head
         type(ListNode), pointer :: cursor
         cursor => head
         do while(associated(cursor))
            write(*,*) cursor%key
            cursor => cursor%next
         end do
      end subroutine PrintForward
      recursive subroutine PrintReverse(head)
         type(ListNode), pointer :: head
         if(associated(head)) then
            call PrintReverse(head%next)
            write(*,*) head%key
         end if
      end subroutine PrintReverse
      subroutine Destroy(head)
         type(ListNode), pointer :: head
         type(ListNode), pointer :: cursor
         do while(associated(head))
            cursor => head
            head => head%next
            deallocate(cursor)
         end do
      end subroutine Destroy
      subroutine sub(filename)
         character(*), intent(in) :: filename
         integer iunit
         integer op, value, i
         type(ListNode), pointer :: head => NULL()
         open(newunit=iunit,file=filename,status='old')
         do
            read(iunit,*,end=10) op,(value,i=1,merge(1,0,op >= 0))
            select case(op)
               case(OpInsertAtHead)
                  call InsertAtHead(head,T(value))
               case(OpInsertInOrder)
                  call InsertInOrder(head,T(value))
               case(OpInsertATail)
                  call InsertAtTail(head,T(value))
               case(OpDelete)
                  call Delete(head,T(value))
               case(OpDeleteInOrder)
                  call DeleteInOrder(head,T(value))
               case(OpFind)
                  write(*,'(*(g0))') 'Value: ',value,' was', &
                     trim(merge('    ',' NOT',Find(head,T(value)))),' found'
               case(OpFindInOrder)
                  write(*,'(*(g0))') 'Value: ',value,' was', &
                     trim(merge('    ',' NOT',FindInOrder(head,T(value)))),' found'
               case(OpPrintForward)
                  write(*,'(a)') 'Printing list forward'
                  call PrintForward(head)
               case(OpPrintReverse)
                  write(*,'(a)') 'Printing list backward'
                  call PrintReverse(head)
               case(OpDestroy)
                  call Destroy(head)
               case default
                  write(*,'(*(g0))') 'Unrecognized op: ',op
                  exit
            end select
         end do
      10 continue
         close(iunit)
      end subroutine sub
end module M1

module M2
   use M, T => MyType
   implicit none
   private
   public sub
   type PtrNode
      type(ListNode), pointer :: p => NULL()
   end type PtrNode
   type ListNode
      type(T) key
      type(PtrNode) next
   end type ListNode
   contains
      subroutine InsertAtHead(head,value)
         type(PtrNode) :: head
         type(T), intent(in) :: value
         type(PtrNode) :: cursor
         allocate(cursor%p)
         cursor%p%next = head
         cursor%p%key = value
         head = cursor
      end subroutine InsertAtHead
      subroutine InsertInOrder(head,value)
         type(PtrNode), target :: head
         type(T), intent(in) :: value
         type(PtrNode), pointer :: cursor
         cursor => head
         do while(associated(cursor%p))
            if(cursor%p%key >= value) then
               if(.NOT.value >= cursor%p%key) then
                  call InsertAtHead(cursor,value)
               end if
               return
            end if
            cursor => cursor%p%next
         end do
         allocate(cursor%p)
         cursor%p%key = value
      end subroutine InsertInOrder
      subroutine InsertAtTail(head,value)
         type(PtrNode), target :: head
         type(T), intent(in) :: value
         type(PtrNode), pointer :: cursor
         cursor => head
         do while(associated(cursor%p))
            if(cursor%p%key >= value) then
               if(value >= cursor%p%key) then
                  return
               end if
            end if
            cursor => cursor%p%next
         end do
         allocate(cursor%p)
         cursor%p%key = value
      end subroutine InsertAtTail
      subroutine Delete(head,value)
         type(PtrNode), target :: head
         type(T), intent(in) :: value
         type(PtrNode), pointer :: cursor
         type(PtrNode) temp
         cursor => head
         do while(associated(cursor%p))
            if(cursor%p%key >= value) then
               if(value >= cursor%p%key) then
                  temp = cursor
                  cursor = cursor%p%next
                  deallocate(temp%p)
                  return
               end if
            end if
            cursor => cursor%p%next
         end do
      end subroutine Delete
      subroutine DeleteInOrder(head,value)
         type(PtrNode), target :: head
         type(T), intent(in) :: value
         type(PtrNode), pointer :: cursor
         type(PtrNode) temp
         cursor => head
         do while(associated(cursor%p))
            if(cursor%p%key >= value) then
               if(value >= cursor%p%key) then
                  temp = cursor
                  cursor = cursor%p%next
                  deallocate(temp%p)
               end if
               return
            end if
            cursor => cursor%p%next
         end do
      end subroutine DeleteInOrder
      function Find(head,value)
         logical Find
         type(PtrNode) :: head
         type(T), intent(in) :: value
         type(PtrNode) :: cursor
         cursor = head
         do while(associated(cursor%p))
            if(value >= cursor%p%key .AND. cursor%p%key >= value) then
               Find = .TRUE.
               return
            end if
            cursor = cursor%p%next
         end do
         Find = .FALSE.
      end function Find
      function FindInOrder(head,value)
         logical FindInOrder
         type(PtrNode) :: head
         type(T), intent(in) :: value
         type(PtrNode) :: cursor
         cursor = head
         do while(associated(cursor%p))
            if(cursor%p%key >= value) then
               if(value >= cursor%p%key) then
                  FindInOrder = .TRUE.
               end if
               return
            end if
            cursor = cursor%p%next
         end do
         FindInOrder = .FALSE.
      end function FindInOrder
      subroutine PrintForward(head)
         type(PtrNode) :: head
         type(PtrNode) :: cursor
         cursor = head
         do while(associated(cursor%p))
            write(*,*) cursor%p%key
            cursor = cursor%p%next
         end do
      end subroutine PrintForward
      recursive subroutine PrintReverse(head)
         type(PtrNode) :: head
         if(associated(head%p)) then
            call PrintReverse(head%p%next)
            write(*,*) head%p%key
         end if
      end subroutine PrintReverse
      subroutine Destroy(head)
         type(PtrNode) :: head
         type(PtrNode) :: cursor
         do while(associated(head%p))
            cursor = head
            head = head%p%next
            deallocate(cursor%p)
         end do
      end subroutine Destroy
      subroutine sub(filename)
         character(*), intent(in) :: filename
         integer iunit
         integer op, value, i
         type(PtrNode) :: head
         open(newunit=iunit,file=filename,status='old')
         do
            read(iunit,*,end=10) op,(value,i=1,merge(1,0,op >= 0))
            select case(op)
               case(OpInsertAtHead)
                  call InsertAtHead(head,T(value))
               case(OpInsertInOrder)
                  call InsertInOrder(head,T(value))
               case(OpInsertATail)
                  call InsertAtTail(head,T(value))
               case(OpDelete)
                  call Delete(head,T(value))
               case(OpDeleteInOrder)
                  call DeleteInOrder(head,T(value))
               case(OpFind)
                  write(*,'(*(g0))') 'Value: ',value,' was', &
                     trim(merge('    ',' NOT',Find(head,T(value)))),' found'
               case(OpFindInOrder)
                  write(*,'(*(g0))') 'Value: ',value,' was', &
                     trim(merge('    ',' NOT',FindInOrder(head,T(value)))),' found'
               case(OpPrintForward)
                  write(*,'(a)') 'Printing list forward'
                  call PrintForward(head)
               case(OpPrintReverse)
                  write(*,'(a)') 'Printing list backward'
                  call PrintReverse(head)
               case(OpDestroy)
                  call Destroy(head)
               case default
                  write(*,'(*(g0))') 'Unrecognized op: ',op
                  exit
            end select
         end do
      10 continue
         close(iunit)
      end subroutine sub
end module M2

program P
   use M1, only: sub1 => sub
   use M2, only: sub2 => sub
   implicit none
   write(*,'(a)') 'Testing version 1'
   call sub1('testll.txt')
   write(*,'(a)') 'Testing version 2'
   call sub2('testll.txt')
end program P

Here is a sample input file, testll.txt:

-3 Destroy empty list
4 10 Delete from empty list
-1 Print empty list forward
-2 Print empty list backwards
7 1 Find in empty list
1 5 Prepend 5 to empty list
1 4 Prepend 4
1 1 Prepend 1
3 6 Append 6
3 7 Append 7
3 10 Append 10
3 6 Append duplicate
-1 Print list forward
7 1 Find first value
7 6 Find middle value
7 10 Find last value
7 11 Find absent value
4 11 Delete absent element
4 1 Delete first element
4 6 Delete from middle
4 10 Delete last element
-2 Print backwards
-3 Destroy list
3 7 Append 7 to empty list
3 6 Append 6
-1 Print forward
4 7 Delete first element
4 6 Delete final element
-1 Print empty list forward
8 1 Find in empty list
2 4 Insert 4 in order
2 1 Insert 1 in order
2 6 Insert 6 in order
2 10 Insert 10 in order
2 5 Insert 5 in order
2 8 Insert 8 in order
2 6 Insert duplicate
-1 Print forward
8 1 Find first value
8 6 Find middle value
8 10 Find last value
8 11 Find absent value
6 7 Delete absent element
6 1 Delete first element
6 6 Delete middle element
6 10 Delete last element
-1 Print forward
-3 Clean up
-4 Exit

And output with ifort:

Testing version 1
Printing list forward
Printing list backward
Value: 1 was NOT found
Printing list forward
           1
           4
           5
           6
           7
          10
Value: 1 was found
Value: 6 was found
Value: 10 was found
Value: 11 was NOT found
Printing list backward
           7
           5
           4
Printing list forward
           7
           6
Printing list forward
Value: 1 was NOT found
Printing list forward
           1
           4
           5
           6
           8
          10
Value: 1 was found
Value: 6 was found
Value: 10 was found
Value: 11 was NOT found
Printing list forward
           4
           5
           8
Unrecognized op: -4
Testing version 2
Printing list forward
Printing list backward
Value: 1 was NOT found
Printing list forward
           1
           4
           5
           6
           7
          10
Value: 1 was found
Value: 6 was found
Value: 10 was found
Value: 11 was NOT found
Printing list backward
           7
           5
           4
Printing list forward
           7
           6
Printing list forward
Value: 1 was NOT found
Printing list forward
           1
           4
           5
           6
           8
          10
Value: 1 was found
Value: 6 was found
Value: 10 was found
Value: 11 was NOT found
Printing list forward
           4
           5
           8
Unrecognized op: -4

 

0 Kudos
Heo__Jun-Yeong
1,663 Views

Dear Repeat Offender

Yeah, I got it. Now I can see the difference bewteen two types of declaration of tree-type structures clearly.

The technique you recommended is very impressive and interesting and I think the final version of my code will be excellent

Thank you very very much :)

0 Kudos
Reply