Define a base user class to support ADTs, sorting etc.

[rweed]

I implement a user base class to support some of the Abstract Data Types (lists etc) and sorting codes I've implemented. It contains no data but defines dummy procedures for things I need to do to support sorting , generic lists etc. mainly relational operators (> < >= <= == assighment etc) and a print method. I implement this as a concrete (non-abstract) class to avoid having to overide all the methods as would be required with an abstract class with deferred abstract interfaces for the procedures since I might not need all of the procedures defined in the concrete class in the extended class. I think we will need something similar to this (or maybe a God or World class ala java that all classes are derived from) to support user defined types.

[milancurcic]

I like the idea. Can you show the prototype? How would this class and module be called?

[rweed]

OK. the entire module (again sorry about the length) follows. Again, I implement this as a concrete and not an abstract class because an abstract class with deferred interfaces obligates the user to implement all of the methods in the extended class. If someone can suggest a better approach please let me know. I wrote this about 5 years ago when compilers where still gagging on some of the OO features so there might be a better way to do this. However, this works so I've not seen any need to change it. I can post a use case where I extend the user type into a point class to store coordinates of nodes in a FEM mesh and then use quickSort to sort the points based on distance from the origin

*** userType.F90 ****

!  Copyright (C) 2015-2019 Richard Weed.
!  All rights reserved.
  
!  Redistribution and use in source and binary forms, with or without 
!  modification, are permitted provided that the following conditions are met:
  
!  1. Redistributions of source code, in whole or in part, must retain the  
!  above copyright notice, this list of conditions and the following 
!  disclaimer.
  
!  2. Redistributions in binary form, in whole or in part, must reproduce the 
!  above copyright notice, this list of conditions and the following disclaimer 
!  in the documentation and/or other materials provided with the distribution.
  
!  3. The names of the contributors may not be used to endorse or promote from 
!  products derived from this software without specific prior written 
!  permission.

!  4. Redistributions of this software, in whole or in part, in any form, 
!  must be freely available and licensed under this original License. The 
!  U.S. Government may add additional restrictions to their modified and 
!  redistributed software as required by Law. However, these restrictions 
!  do not apply to the original software distribution.
 
!  5. Redistribution of this source code, including any modifications, may 
!  not be intentionally obfuscated.
  
!  6. Other code may make use of this software, in whole or in part, without 
!  restriction, provided that it does not apply any restriction to this 
!  software other than outlined above.
  
!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
!  IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
!  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!  PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS AND
!  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
!  EXEMPLARARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
!  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 
!  OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 
!  WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 
!  OTHERWISE), ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
!  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module userClass

! Defines an base container class for creating user defined types to be
! used with generic ADT routines. It is intended that this base class
! be extended and should not be used directly. We implement this as a
! concrete class instead of an abstract one to allow users to override 
! only the type bound procedures they will use in their applications. An
! abstract interface forces users to implement all of the procedures.  

! Written by: Richard Weed, Ph.D.
!             Missississippi State University
!             Center for Advanced Vehicular Systems

! Version No. : 1

! Revision History : Initial version - December 2014

  Implicit NONE

! Define a User class that can be used to create other
! classes. Its primary use is in createing ADT lists
! but can also be used in any case where unlimited
! polymorphic dummy arguments are used to create
! a generic routine that mixes both intrinsic and
! user defined data types.

  Type :: User_t

  Contains

    Procedure :: isUserEQ
    Procedure :: isUserGT
    Procedure :: isUserLT
    Procedure :: isUserGTE
    Procedure :: isUserLTE
    Procedure :: isUserNE
    Procedure :: printUserValue
    Procedure :: assignValue 
    Generic :: OPERATOR(==)  => isUserEQ 
    Generic :: OPERATOR(/=)  => isUserNE 
    Generic :: OPERATOR(<)   => isUserLT 
    Generic :: OPERATOR(>)   => isUserGT 
    Generic :: OPERATOR(<=)  => isUserLTE 
    Generic :: OPERATOR(>=)  => isUserGTE 
    Generic :: ASSIGNMENT(=) => assignValue
    Generic :: printValue    => printUserValue
  End Type

  Type :: UserPtr_t

    Class(User_t), Pointer :: userptr

  End Type

CONTAINS

  Logical Function isUserEQ(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this
    Class(*),      Intent(IN) :: value

    isUserEQ = .FALSE.

    Select Type(r=>this)

      Class Is(User_t)
        Select Type(p=>value)
          Class Is(User_t)
            Print *,' ** User_t isUserEQ not overridden'
      End Select 

    End Select

  End Function isUserEQ

  Logical Function isUserGT(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this
    Class(*),      Intent(IN) :: value

    isUserGT = .FALSE.

    Select Type(r=>this)

      Class Is(User_t)
        Select Type(p=>value)
          Class Is(User_t)
            Print *,' ** User_t isUserGT not overridden'
        End Select 

     End Select

  End Function isUserGT

  Logical Function isUserLT(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this
    Class(*),      Intent(IN) :: value

    isUserLT = .FALSE.

    Select Type(r=>this)

     Class Is(User_t)
       Select Type(p=>value)
         Class Is(User_t)
           Print *,' ** User_t isUserLT not overridden'
        End Select 

     End Select

  End Function isUserLT

  Logical Function isUserGTE(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this

    Class(*),      Intent(IN) :: value

    isUserGTE = .FALSE.

    Select Type(r=>this)

     Class Is(User_t)
       Select Type(p=>value)
         Class Is(User_t)
           Print *,' ** User_t isUserGTE not overridden'
       End Select 

     End Select

  End Function isUserGTE

  Logical Function isUserLTE(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this
    Class(*),      Intent(IN) :: value

    isUserLTE = .FALSE.
 
    Select Type(r=>this)

      Class Is(User_t)
        Select Type(p=>value)
          Class Is(User_t)
            Print *,' ** User_t isUserLTE not overridden'
      End Select 

    End Select

  End Function isUserLTE

  Logical Function isUserNE(this, value)

    Implicit NONE

    Class(User_t), Intent(IN) :: this
    Class(*),      Intent(IN) :: value

    isUserNE = .FALSE.

    Select Type(r=>this)

      Class Is(User_t)
       Select Type(p=>value)
          Class Is(User_t)
            Print *,' ** User_t isUserNE not overridden'
        End Select 

    End Select

  End Function isUserNE

  Subroutine printUserValue(this, iunit)

    Implicit NONE

    Class(User_t), Intent(IN), TARGET   :: this
    Integer,       Intent(IN), OPTIONAL :: iunit

     Select Type(r=>this)

      Class Is(User_t)
        If (PRESENT(iunit)) Then
          Print *,' ** User_t printUserValue not overridden for iunit ', iunit
        Else 
          Print *,' ** User_t printUserValue not overridden '
        EndIf
     End Select 

  End Subroutine printUserValue

  Subroutine assignValue(this, that)

    Implicit NONE
 
    Class(User_t), Intent(INOUT) :: this
    Class(User_t), Intent(IN)    :: that

    Select Type(r=>this)

      Class Is(User_t)
        Select Type(p=>that)
          Class Is(User_t)
            Print *,' ** User_t assignValue not overridden'
        End Select

    End Select

  End Subroutine assignValue

End Module userClass