MODULE  INTEGER_SETS
!  This  module  is  intended  to  illustrate  use  of  the  module  facility
!  to  define  a  new  data  type,  along  with  suitable  operators.

INTEGER,  PARAMETER  ::  MAX_SET_CARD  =  200

TYPE  SET  !  Define  SET  data  type
  PRIVATE
  INTEGER  CARD
  INTEGER  ELEMENT  (MAX_SET_CARD)
END  TYPE  SET

INTERFACE  OPERATOR  (.IN.)
  MODULE  PROCEDURE  ELEMENT
END  INTERFACE

INTERFACE  OPERATOR  (<=)
  MODULE  PROCEDURE  SUBSET
END  INTERFACE

INTERFACE  OPERATOR  (+)
  MODULE  PROCEDURE  UNION
END  INTERFACE

INTERFACE  OPERATOR  (-)
  MODULE  PROCEDURE  DIFFERENCE
END  INTERFACE

INTERFACE  OPERATOR  (*)
  MODULE  PROCEDURE  INTERSECTION
END  INTERFACE

CONTAINS

INTEGER  FUNCTION  CARDINALITY  (A)  !  Returns  cardinality  of  set  A
  TYPE  (SET)  A
  CARDINALITY  =  A  %  CARD
END  FUNCTION  CARDINALITY

LOGICAL  FUNCTION  ELEMENT  (X,  A)  !  Determines  if
  INTEGER  X  !  element  X  is  in  set  A
  TYPE  (SET)  A
  INTENT (IN) X, A
  ELEMENT  =  ANY  (A  %  ELEMENT  (1  :  A  %  CARD)  .EQ.  X)
END  FUNCTION  ELEMENT

FUNCTION  UNION  (A,  B)  !  Union  of  sets  A  and  B
  TYPE  (SET)  A,  B,  UNION
  INTENT (IN) A, B
  INTEGER  J
  UNION  =  A
  DO  J  =  1,  B  %  CARD
  IF  (.NOT.  (B  %  ELEMENT  (J)  .IN.  A))  THEN
  IF  (UNION  %  CARD  <  MAX_SET_CARD)  THEN
  UNION  %  CARD  =  UNION  %  CARD  +  1
  UNION  %  ELEMENT  (UNION  %  CARD)  =  &
  B  %  ELEMENT  (J)
  ELSE
  !  Maximum  set  size  exceeded  .  .  .
  END  IF
  END  IF
  END  DO
END  FUNCTION  UNION

FUNCTION  DIFFERENCE  (A,  B)  !  Difference  of  sets  A  and  B
  TYPE  (SET)  A,  B,  DIFFERENCE
  INTENT (IN) A, B
  INTEGER  J,  X
  DIFFERENCE  %  CARD  =  0  !  The  empty  set
  DO  J  =  1,  A  %  CARD
  X  =  A  %  ELEMENT  (J)
  IF  (.NOT.  (X  .IN.  B))  DIFFERENCE  =  DIFFERENCE  +  SET  (1,  X)
  END  DO
END  FUNCTION  DIFFERENCE

FUNCTION  INTERSECTION  (A,  B)  !  Intersection  of  sets  A  and  B
  TYPE  (SET)  A,  B,  INTERSECTION
  INTENT (IN) A, B
  INTERSECTION  =  A  -  (A  -  B)
END  FUNCTION  INTERSECTION

LOGICAL  FUNCTION  SUBSET  (A,  B)  !  Determines  if  set  A  is
  TYPE  (SET)  A,  B  !  a  subset  of  set  B
  INTENT (IN) A, B
  INTEGER  I
  SUBSET  =  A  %  CARD  <=  B  %  CARD
  IF  (.NOT.  SUBSET)  RETURN  !  For  efficiency
  DO  I  =  1,  A  %  CARD
  SUBSET  =  SUBSET  .AND.  (A  %  ELEMENT  (I)  .IN.  B)
  END  DO
END  FUNCTION  SUBSET

TYPE  (SET)  FUNCTION  SETF  (V)  !  Transfer  function  between  a  vector
  INTEGER  V  (:)  !  of  elements  and  a  set  of  elements
  INTEGER  J  !  removing  duplicate  elements
  SETF  %  CARD  =  0
  DO  J  =  1,  SIZE  (V)
  IF  (.NOT.  (V  (J)  .IN.  SETF))  THEN
  IF  (SETF  %  CARD  <  MAX_SET_CARD)  THEN
  SETF  %  CARD  =  SETF  %  CARD  +  1
  SETF  %  ELEMENT  (SETF  %  CARD)  =  V  (J)
  ELSE
  !  Maximum  set  size  exceeded  .  .  .
  END  IF
  END  IF
  END  DO
END  FUNCTION  SETF

FUNCTION  VECTOR  (A)  !  Transfer  the  values  of  set  A
  TYPE  (SET)  A  !  into  a  vector  in  ascending  order
  INTEGER,  POINTER  ::  VECTOR  (:)
  INTEGER  I,  J,  K
  ALLOCATE  (VECTOR  (A  %  CARD))
  VECTOR  =  A  %  ELEMENT  (1  :  A  %  CARD)
  DO  I  =  1,  A  %  CARD  -  1  !  Use  a  better  sort  if
  DO  J  =  I  +  1,  A  %  CARD  !  A  %  CARD  is  large
  IF  (VECTOR  (I)  >  VECTOR  (J))  THEN
  K  =  VECTOR  (J);  VECTOR  (J)  =  VECTOR  (I);  VECTOR  (I)  =  K
  END  IF
  END  DO
  END  DO
END  FUNCTION  VECTOR

END  MODULE  INTEGER_SETS