Criteria pattern further - still incomplete

structural/criteria/criteria_main.f90

@@ -0,0 +1,32 @@
+program criteria_main
+	use criteria_module
+	implicit none
+	type(person), allocatable :: persons(:)
+	class(criteria), allocatable :: cmale	
+	class(criteria), allocatable :: cfemale	
+	class(criteria), allocatable :: csingle
+	class(criteria), allocatable :: cand
+	class(criteria), allocatable :: cor	
+
+	allocate(persons(6))
+	persons(1) = person('Robert', 'm', 's')
+	persons(2) = person('John', 'm', 'm')
+	persons(3) = person('Laura', 'f', 'm')	
+	persons(4) = person('Diana', 'f', 's')	
+	persons(5) = person('Mike', 'm', 's')	
+	persons(6) = person('Bobby', 'm', 's')	
+
+	allocate(cmale, source=malecriteria())
+	allocate(cfemale, source=femalecriteria())
+	allocate(csingle, source=singlecriteria())
+	allocate(cand, source=andcriteria(cmale, null()))
+!	allocate(cor, source=orcriteria(csingle, cfemale))
+
+!	deallocate(persons)
+!	deallocate(cmale)
+!	deallocate(cfemale)
+!	deallocate(csingle)
+!	deallocate(cand)
+!	deallocate(cor)
+
+end program criteria_main

structural/criteria/criteria_module.f90

@@ -28,6 +28,30 @@ end subroutine meetCriteriaInterface
 		procedure :: meetCriteria => meetMaleCriteria
 	end type maleCriteria
 
+	type, extends(criteria) :: femaleCriteria
+	contains
+		procedure :: meetCriteria => meetFemaleCriteria
+	end type femaleCriteria
+
+	type, extends(criteria) :: singleCriteria
+	contains
+		procedure :: meetCriteria => meetSingleCriteria
+	end type singleCriteria
+
+	type, extends(criteria) :: AndCriteria
+		class(criteria), allocatable :: c1
+		class(criteria), allocatable :: c2
+	contains
+		procedure :: meetCriteria => meetAndCriteria
+	end type AndCriteria
+
+	type, extends(criteria) :: OrCriteria
+		class(criteria), allocatable :: c1
+		class(criteria), allocatable :: c2
+	contains
+		procedure :: meetCriteria => meetOrCriteria
+	end type OrCriteria
+
 contains
 
 	subroutine meetMaleCriteria(this, personArray, outPersonArray)
@@ -42,4 +66,66 @@ subroutine meetMaleCriteria(this, personArray, outPersonArray)
 		enddo
 	end subroutine meetMaleCriteria
 
+	subroutine meetFemaleCriteria(this, personArray, outPersonArray)
+		class(femaleCriteria), intent(in) :: this
+		type(person), dimension (:), allocatable, intent(inout) :: personArray(:)
+		type(person), dimension (:), allocatable, intent(inout) :: outPersonArray(:)
+		integer :: j
+		do j=1,size(personArray)
+			if (personArray(j)%gender .EQ. 'f') then
+				outPersonArray(j) = personArray(j)
+			end if
+		enddo
+	end subroutine meetFemaleCriteria
+
+	subroutine meetSingleCriteria(this, personArray, outPersonArray)
+		class(singleCriteria), intent(in) :: this
+		type(person), dimension (:), allocatable, intent(inout) :: personArray(:)
+		type(person), dimension (:), allocatable, intent(inout) :: outPersonArray(:)
+		integer :: j
+		do j=1,size(personArray)
+			if (personArray(j)%maritalstatus .EQ. 's') then
+				outPersonArray(j) = personArray(j)
+			end if
+		enddo
+	end subroutine meetSingleCriteria
+
+	subroutine meetAndCriteria(this, personArray, outPersonArray)
+		class(AndCriteria), intent(in) :: this
+		type(person), dimension (:), allocatable, intent(inout) :: personArray(:)
+		type(person), dimension (:), allocatable, intent(inout) :: outPersonArray(:)
+		type(person), dimension (:), allocatable :: tempPersonArray(:)
+		call this%c1%meetCriteria(personArray, tempPersonArray)
+		call this%c1%meetCriteria(temppersonArray, outPersonArray)
+	end subroutine meetAndCriteria
+
+	subroutine meetOrCriteria(this, personArray, outPersonArray)
+		class(OrCriteria), intent(in) :: this
+		type(person), dimension (:), allocatable, intent(inout) :: personArray(:)
+		type(person), dimension (:), allocatable, intent(inout) :: outPersonArray(:)
+		type(person), dimension (:), allocatable :: tempPersonArray1(:)
+		type(person), dimension (:), allocatable :: tempPersonArray2(:)
+		integer :: i, j
+		logical :: found = .false.
+		call this%c1%meetCriteria(personArray, tempPersonArray1)
+		call this%c1%meetCriteria(personArray, tempPersonArray2)
+
+		do i = 1, size(tempPersonArray1), 1
+			outPersonArray(i) = tempPersonArray1(i)
+		end do
+
+		do i = 1, size(tempPersonArray2), 1
+			found = .false.
+			do j=1, size(outPersonArray), 1
+				if (outPersonArray(j)%name==tempPersonArray2(i)%name) then
+					found = .true.
+					exit
+				endif
+			end do
+			if (found .eqv. .true.) then
+				outpersonArray(size(outpersonArray)+1) = tempPersonArray2(i)
+			endif
+		end do
+	end subroutine meetOrCriteria
+
 end module criteria_module