text:
      PROGRAM FCCE01
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  This program provides a demonstration of setting up a color table
C  and specifying colors for the GKS primitives: lines, markers, text,
C  and filled areas.
C
C  Corrdinate data for polyline and polymarker draws.
C
       DIMENSION X1(5),X2(5),Y(5)
       DATA X1/0.15, 0.35, 0.35, 0.15, 0.15/
       DATA X2/0.65, 0.85, 0.85, 0.65, 0.65/
       DATA Y /0.45, 0.45, 0.65, 0.65, 0.45/
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Set up the color table for the CGM workstation:
C
C    Index  Color
C    -----  -----
C      0    Black (background color)
C      1    White (foreground color)
C      2    Red
C      3    Green
C      4    Yellow
C      5    Cyan
C
      CALL GSCR(IWKID, 0, 0.0, 0.0, 0.0)
      CALL GSCR(IWKID, 1, 1.0, 1.0, 1.0)
      CALL GSCR(IWKID, 2, 1.0, 0.0, 0.0)
      CALL GSCR(IWKID, 3, 0.0, 1.0, 0.0)
      CALL GSCR(IWKID, 4, 1.0, 1.0, 0.0)
      CALL GSCR(IWKID, 5, 0.0, 1.0, 1.0)
C
C  Draw a green rectangle.
C
      CALL GSPLCI(3)
      CALL GPL(5,X1,Y)
C
C  Draw an asterisk scaled by 4. in the foreground color.
C
      CALL GSMKSC(4.)
      CALL GPM(1,.5,.25)
C
C  Draw a text string in yellow.
C
      CALL GSTXCI(4)
      CALL GTX(0.5,0.5,'Text')
C
C  Draw a filled rectangle in cyan.
C
      CALL GSFACI(5)
      CALL GSFAIS(1)
      CALL GFA(5,X2,Y)
C
C  Draw a red asterisk.
C
      CALL GSPMCI(2)
      CALL GPM(1,.5,.75)
C
C Advance the frame.
C
      CALL FRAME
C
C  Terminate the picture, deactivate and close the CGM workstation,
C  close GKS.
C
      CALL GDAWK(IWKID)
      CALL GCLWK(IWKID)
      CALL GCLKS
C
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
!-----------------------------------------------------------------------
!
! Header with common subroutine
!
      include 't320-basis-f.h'
!
! Header with QFunctions
!
      include 't510-operator-f.h'
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i
      integer stridesu(3)
      integer erestrictx,erestrictu,erestrictui
      integer bx,bu
      integer qf_setup,qf_mass
      integer op_setup,op_mass
      integer qdata,x,u,v
      integer nelem,p,q,d
      integer val,row,col,offset
      parameter(nelem=12)
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)
      integer ndofs,nqpts,nx,ny
      parameter(nx=3)
      parameter(ny=2)
      parameter(ndofs=(nx*2+1)*(ny*2+1))
      parameter(nqpts=nelem*q)
      integer indx(nelem*p)
      real*8 arrx(d*ndofs)
      integer*8 voffset,xoffset

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)
      real*8 total

      real*8 hv(ndofs)

      character arg*32

      external setup,mass

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

      do i=0,ndofs-1
        arrx(i+1)=mod(i,(nx*2+1))
        arrx(i+1)=arrx(i+1)*(1.d0/(nx*2.d0))
        val=(i/(nx*2+1))
        arrx(i+1+ndofs)=val*(1.d0/(ny*2.d0))
      enddo
      do i=0,5
        col=mod(i,nx)
        row=i/nx
        offset=col*2+row*(nx*2+1)*2

        indx(i*2*p+1)=2+offset
        indx(i*2*p+2)=9+offset
        indx(i*2*p+3)=16+offset
        indx(i*2*p+4)=1+offset
        indx(i*2*p+5)=8+offset
        indx(i*2*p+6)=0+offset

        indx(i*2*p+7)=14+offset
        indx(i*2*p+8)=7+offset
        indx(i*2*p+9)=0+offset
        indx(i*2*p+10)=15+offset
        indx(i*2*p+11)=8+offset
        indx(i*2*p+12)=16+offset
      enddo

      call ceedelemrestrictioncreate(ceed,nelem,p,d,ndofs,d*ndofs,&
     & ceed_mem_host,ceed_use_pointer,indx,erestrictx,err)

      call ceedelemrestrictioncreate(ceed,nelem,p,1,1,ndofs,ceed_mem_host,&
     & ceed_use_pointer,indx,erestrictu,err)
      stridesu=[1,q,q]
      call ceedelemrestrictioncreatestrided(ceed,nelem,q,1,nqpts,stridesu,&
     & erestrictui,err)

      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,d,p,q,interp,grad,qref,qweight,&
     & bx,err)
      call buildmats(qref,qweight,interp,grad)
      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,&
     & bu,err)

      call ceedqfunctioncreateinterior(ceed,1,setup,&
     &SOURCE_DIR&
     &//'t510-operator.h:setup'//char(0),qf_setup,err)
      call ceedqfunctionaddinput(qf_setup,'_weight',1,ceed_eval_weight,err)
      call ceedqfunctionaddinput(qf_setup,'x',d*d,ceed_eval_grad,err)
      call ceedqfunctionaddoutput(qf_setup,'rho',1,ceed_eval_none,err)

      call ceedqfunctioncreateinterior(ceed,1,mass,&
     &SOURCE_DIR&
     &//'t510-operator.h:mass'//char(0),qf_mass,err)
      call ceedqfunctionaddinput(qf_mass,'rho',1,ceed_eval_none,err)
      call ceedqfunctionaddinput(qf_mass,'u',1,ceed_eval_interp,err)
      call ceedqfunctionaddoutput(qf_mass,'v',1,ceed_eval_interp,err)

      call ceedoperatorcreate(ceed,qf_setup,ceed_qfunction_none,&
     & ceed_qfunction_none,op_setup,err)
      call ceedoperatorcreate(ceed,qf_mass,ceed_qfunction_none,&
     & ceed_qfunction_none,op_mass,err)

      call ceedvectorcreate(ceed,d*ndofs,x,err)
      xoffset=0
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,arrx,xoffset,err)
      call ceedvectorcreate(ceed,nqpts,qdata,err)

      call ceedoperatorsetfield(op_setup,'_weight',ceed_elemrestriction_none,&
     & bx,ceed_vector_none,err)
      call ceedoperatorsetfield(op_setup,'x',erestrictx,bx,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_setup,'rho',erestrictui,&
     & ceed_basis_collocated,ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'rho',erestrictui,&
     & ceed_basis_collocated,qdata,err)
      call ceedoperatorsetfield(op_mass,'u',erestrictu,bu,&
     & ceed_vector_active,err)
      call ceedoperatorsetfield(op_mass,'v',erestrictu,bu,&
     & ceed_vector_active,err)

      call ceedoperatorapply(op_setup,x,qdata,ceed_request_immediate,err)

      call ceedvectorcreate(ceed,ndofs,u,err)
      call ceedvectorsetvalue(u,1.d0,err)
      call ceedvectorcreate(ceed,ndofs,v,err)
      call ceedoperatorapply(op_mass,u,v,ceed_request_immediate,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,hv,voffset,err)
      total=0.
      do i=1,ndofs
        total=total+hv(voffset+i)
      enddo
      if (abs(total-1.)>1.0d-10) then
! LCOV_EXCL_START
        write(*,*) 'Computed Area: ',total,' != True Area: 1.0'
! LCOV_EXCL_STOP
      endif
      call ceedvectorrestorearrayread(v,hv,voffset,err)

      call ceedvectordestroy(qdata,err)
      call ceedvectordestroy(x,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedoperatordestroy(op_mass,err)
      call ceedoperatordestroy(op_setup,err)
      call ceedqfunctiondestroy(qf_mass,err)
      call ceedqfunctiondestroy(qf_setup,err)
      call ceedbasisdestroy(bu,err)
      call ceedbasisdestroy(bx,err)
      call ceedelemrestrictiondestroy(erestrictu,err)
      call ceedelemrestrictiondestroy(erestrictx,err)
      call ceedelemrestrictiondestroy(erestrictui,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------

max_stars_repo_name: AdelekeBankole/libCEED

max_issues_repo_name: AdelekeBankole/libCEED

max_forks_repo_name: AdelekeBankole/libCEED


PROGRAM main

  use mo_kind,       only: i4
  use mo_file_utils, only: find_next_unit, lines_in_file, lif, next_unit
  use mo_ansi_colors, only: color, c_red, c_green

  implicit none

  integer(i4) :: inew, ilines, islines
  logical     :: isgood

  write(*,*) ''
  write(*,*) 'Test mo_file_utils.f90'

  ! find_next_unit
  isgood = .true.
  open(unit=20, file="main.f90", action="read", status="old", form="formatted")
  open(unit=21, file="mo_file_utils.f90", action="read", status="old", form="formatted")
  inew = find_next_unit(20,30)
  if (inew /= 22) isgood =.false.
  inew = find_next_unit(20)
  if (inew /= 22) isgood =.false.
  inew = find_next_unit()
  if (inew /= 22) isgood =.false.

  close(20)
  close(21)

  ! next_unit
  isgood = .true.
  open(unit=20, file="main.f90", action="read", status="old", form="formatted")
  open(unit=21, file="mo_file_utils.f90", action="read", status="old", form="formatted")
  inew = next_unit(20,30)
  if (inew /= 22) isgood =.false.
  inew = next_unit(20)
  if (inew /= 22) isgood =.false.
  inew = next_unit()
  if (inew /= 22) isgood =.false.

  close(20)
  close(21)

  ! lines_in_file
  islines = 71
  ilines = lines_in_file("main.f90")
  if (ilines /= islines) isgood =.false.
  ilines = lines_in_file("main.f90", comment='!')
  if (ilines /= islines-4) isgood =.false.
  ilines = lines_in_file("main.f90", comment='!', noblank=.true.)
  if (ilines /= islines-4-16) isgood =.false.

  ! lif
  islines = 71
  ilines = lif("main.f90")
  if (ilines /= islines) isgood =.false.
  ilines = lif("main.f90", comment='!')
  if (ilines /= islines-4) isgood =.false.
  ilines = lif("main.f90", comment='!', noblank=.true.)
  if (ilines /= islines-4-16) isgood =.false.

  if (isgood) then
     write(*,*) 'mo_file_utils ', color('o.k.', c_green)
  else
     write(*,*) 'mo_file_utils ', color('failed!', c_red)
  endif

end program main


   implicit none

   integer :: i, j, k, img, nimg, ndim
   integer, allocatable :: idx(:)
   real(8), allocatable :: mep_rr(:,:), slen(:), coeff(:,:,:)
   integer :: nw
   real(8) :: ss, ds
   real(8), allocatable :: win_rr(:,:)
   character(1000) :: line
   real(8)         :: rr(100)
   character(2)   :: nn
   character(20)  :: fname
   integer :: len, stat
   character(:), allocatable :: arg
   character(:), allocatable :: datfile, cdim, cidx, cds
   intrinsic :: command_argument_count, get_command_argument

   if (command_argument_count() == 0) then
     write(6,'("USAGE: make_window -dat rpath_xxx.dat -ds ds -ndim num_of_dimension [-idx 1,2,4]")')
     stop
   end if

   ds = -1.0D+00
   do i = 1, command_argument_count()
     call get_command_argument(i, length = len, status = stat)
     if (stat == 0) then
       allocate (character(len) :: arg)
       call get_command_argument(i, arg, status = stat)
       if (stat == 0) then
         if (index(arg,"-dat") > 0) then
           call get_command_argument(i+1, length = len, status = stat)
           allocate (character(len) :: datfile)
           call get_command_argument(i+1, datfile, status = stat)

         else if (index(arg,"-ndim") > 0) then
           call get_command_argument(i+1, length = len, status = stat)
           allocate (character(len) :: cdim)
           call get_command_argument(i+1, cdim, status = stat)
           read(cdim,*) ndim

         else if (index(arg,"-ds") > 0) then
           call get_command_argument(i+1, length = len, status = stat)
           allocate (character(len) :: cds)
           call get_command_argument(i+1, cds, status = stat)
           read(cds,*) ds
         end if
       end if
       deallocate(arg)
     end if
   end do

   ! read MEP data
   open(10,file=datfile,status='old')
   i=0
   do while(.true.)
     read(10,*,end=10)
     i=i+1
   end do
   10 continue
   nimg = i

   !write(6,'(i4)') nimg
   !write(6,'(i4)') ndim

   allocate(mep_rr(ndim,nimg), slen(nimg), coeff(4,nimg-1,ndim))
   allocate(idx(ndim))
   idx=-1
   do i = 1, command_argument_count()
     call get_command_argument(i, length = len, status = stat)
     if (stat == 0) then
       allocate (character(len) :: arg)
       call get_command_argument(i, arg, status = stat)
       if (stat == 0) then
         if (index(arg,"-idx") > 0) then
           call get_command_argument(i+1, length = len, status = stat)
           allocate (character(len) :: cidx)
           call get_command_argument(i+1, cidx, status = stat)
           read(cidx,*,end=20) idx
           20 continue
           ! write(6,*) cidx

         end if
       end if
       deallocate(arg)
     end if
   end do

   if(idx(1) < 0) then
     do i = 1, ndim
       idx(i) = i
     end do
   else if(idx(ndim) < 0) then
      write(6,'("Error: The number of index is less than ndim")')
      stop
   end if
   ! write(6,'(5i3)') idx

   rewind(10)
   do i = 1, nimg
     read(10,'(a)') line
     read(line,*,end=30) rr
     30 continue

     do j = 1, ndim
       mep_rr(j,i) = rr(idx(j)+3)
     end do
   end do
   close(10)

   !do i = 1, nimg
   !  write(6,'(2f12.6)') mep_rr(1,i), mep_rr(3,i)
   !end do

   ! calc path length
   slen(1) = 0.0D+00
   do i = 2, nimg
     ss = 0.0D+00
     do j = 1, ndim
       ss = ss + (mep_rr(j,i) - mep_rr(j,i-1))**2
     end do
     ss = sqrt(ss)
     slen(i) = slen(i-1) + ss
   end do

   write(6,'("Reaction path")')
   write(6,'(i4,f12.4)') (i, slen(i), i=1,nimg)

   ! interpolation
   do i = 1, ndim
     call cubic_spline_coeff(nimg, slen, mep_rr(i,:), coeff(:,:,i))
   end do

   ! generate window
   if (ds < 0.D+00) ds = 0.1D+00

   nw = int(slen(nimg)/ds)
   ds = slen(nimg)/nw
   nw = nw + 1

   write(6,'("US windows")')
   write(6,'("  o Num of Windows = ",i6)') nw
   write(6,'("  o Interval       = ",f6.4)') ds

   allocate(win_rr(ndim,nw))
   do i = 1, nw
     ss = (i-1)*ds
     do j = 1, ndim
       call cubic_spline(nimg, slen, mep_rr(j,:), coeff(:,:,j), ss, win_rr(j,i))
     end do
   end do

   write(6,'("Reaction path (internal)")')
   open(10,file="win_rr.dat",status="unknown")
   do i = 1, nw
     write(10,'(i4,9f8.4)') i, win_rr(:,i)
     write(6,'(i4,9f8.4)') i, win_rr(:,i)
   end do
   close(10)

   end

  !======1=========2=========3=========4=========5=========6=========7=========8
  !
  !  Subroutine    cubic_spline
  !> @brief        natrual cubic spline function
  !! @authors      KY
  !! @param[in]    init    : initialize if true
  !! @param[in]    nn      : size of data
  !! @param[in]    xx(nn)  : x values
  !! @param[in]    yy(nn)  : y values
  !! @param[inout] coeff(4,nn-1) : coefficients of cubic functions
  !! @param[in]    xin     : x value
  !! @param[out]   yout    : y value at xin
  !
  !======1=========2=========3=========4=========5=========6=========7=========8

  subroutine cubic_spline(nn, xx, yy, coeff, xin, yout)

    ! formal arguments
    integer, intent(in)    :: nn
    real(8), intent(in)    :: xx(0:nn-1)
    real(8), intent(in)    :: yy(0:nn-1)
    real(8), intent(inout) :: coeff(0:3,0:nn-2)
    real(8), intent(in)    :: xin
    real(8), intent(out)   :: yout

    ! local arguments
    integer :: i, idx
    real(8) :: dx, dxi

    idx = nn-2
    do i = 1, nn-1
      if(xin < xx(i)) then
        idx = i-1
        exit
      end if
    end do

    dx   = xin - xx(idx)
!    dxi  = 1.0_wp
!    yout = 0.0_wp
    dxi  = 1.0d+00
    yout = 0.0d+00
    do i = 0, 3
       yout = yout + coeff(i,idx)*dxi
       dxi  = dxi * dx
    end do

  end subroutine cubic_spline

  !======1=========2=========3=========4=========5=========6=========7=========8
  !
  !  Subroutine    cubic_spline_coeff
  !> @brief        calculate the coefficients of cubic functions
  !! @authors      KY
  !! @param[in]    nn      : size of data
  !! @param[in]    xx(nn)  : x values
  !! @param[in]    yy(nn)  : y values
  !! @param[out]   coeff(4,nn-1) : coefficients of cubic functions
  !
  !======1=========2=========3=========4=========5=========6=========7=========8

  subroutine cubic_spline_coeff(nn, xx, yy, coeff)

    ! formal arguments
    integer, intent(in) :: nn
    real(8), intent(in) :: xx(0:nn-1)
    real(8), intent(in) :: yy(0:nn-1)
    real(8), intent(out) :: coeff(0:3,0:nn-2)

    ! local arguments
    integer :: i
    real(8) :: hh(0:nn-2), gg(0:nn-2)
    real(8) :: vii(1:nn-2), aii(1:nn-2), aij(1:nn-3), aji(2:nn-2)
    real(8) :: uii(0:nn-1)

    do i = 0, nn-2
      hh(i) = xx(i+1) - xx(i)
      gg(i) = (yy(i+1) - yy(i))/hh(i)
    end do

    do i = 1, nn-2
      vii(i) = 6.0d+00*(gg(i) - gg(i-1))
      aii(i) = 2.0d+00*(hh(i-1) + hh(i))
    end do

    do i = 1, nn-3
      aij(i)   = hh(i)
      aji(i+1) = hh(i)
    end do

    ! forward
    do i = 1, nn-3
      aij(i) = aij(i) / aii(i)
      vii(i) = vii(i) / aii(i)
      aii(i+1) = aii(i+1) - aij(i)*aji(i+1)
      vii(i+1) = vii(i+1) - vii(i)*aji(i+1)
    end do
    vii(nn-2) = vii(nn-2)/aii(nn-2)

    ! backward
    uii(nn-2) = vii(nn-2)
    do i = nn-3, 1, -1
      uii(i) = vii(i+1) - aij(i)*uii(i+1)
    end do
    uii(0)    = 0.0d+00
    uii(nn-1) = 0.0d+00

    ! calc coefficients
    do i = 0, nn-2
      coeff(0,i) = yy(i)
      coeff(1,i) = (yy(i+1) - yy(i))/hh(i) &
                 - hh(i)*(2.0d+00*uii(i) + uii(i+1))/6.0d+00
      coeff(2,i) = uii(i)*0.5d+00
      coeff(3,i) = (uii(i+1) - uii(i))/hh(i)/6.0d+00
    end do

  end subroutine cubic_spline_coeff


text:
clkgen.sv
dut.v
hw_top.sv
memBFM.sv
dutmem0.v
dutmem1.v
dutmem2.v

ext: f

max_stars_repo_name: zhuzhzh/ctba

max_issues_repo_name: zhuzhzh/ctba

max_forks_repo_name: zhuzhzh/ctba


text:
! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! FTObjectLibrary contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
! https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
!
! --- End License

!
!////////////////////////////////////////////////////////////////////////
!
!      StringSetTests.f90
!      Created: March 9, 2020 at 10:20 AM
!      By: David Kopriva
!
!////////////////////////////////////////////////////////////////////////
!
!
!////////////////////////////////////////////////////////////////////////
!
   SUBROUTINE FTStringSetTests
      USE FTStringSetClass
      USE FTAssertions
      IMPLICIT NONE

      TYPE(FTStringSet)          :: set1, set2
      TYPE(FTStringSet), POINTER :: unionSet, intersectionSet, differenceSet
      CHARACTER(LEN=5)           :: s1(5) = ['one  ','two  ','three','four ','five ']
      CHARACTER(LEN=5)           :: s2(5) = ['one  ','two  ','six  ','seven','eight']
      CHARACTER(LEN=5)           :: s3(6) = ['one  ','two  ','three','four ','five ','six  ']
      CHARACTER(LEN=5)           :: unionStrings(8) = ['one  ','two  ','three','four ','five ','six  ','seven','eight']
      CHARACTER(LEN=5)           :: intersectionStrings(2) = ['one  ','two  ']
      CHARACTER(LEN=5)           :: differenceStrings1(3) = ['three','four ','five ']
      CHARACTER(LEN=5)           :: differenceStrings2(3) = ['six  ','seven','eight']
      INTEGER                    :: i
      LOGICAL                    :: test

      CHARACTER(LEN=FTDICT_KWD_STRING_LENGTH) ,DIMENSION(:), POINTER :: keys
!
!     -------------------------------------
!     Test size of set after initialization
!     -------------------------------------
!
      CALL set1 % initWithStrings(strings = s1)
      CALL FTAssertEqual(expectedValue = SIZE(s1),     &
                         actualValue =  set1 % COUNT(), &
                         msg = "First set count")
      CALL FTAssert(test = .NOT.set1 % isEmpty(),msg = 'Test non empty test for empty')
!
!     -------------------------------------------
!     Test size of string array returned from set
!     -------------------------------------------
!
      keys => set1 % strings()
      CALL FTAssertEqual(expectedValue = SIZE(s1),actualValue = SIZE(keys),msg = "Returned strings size count")
!
!     -------------------------------
!     Test all strings are in the set
!     -------------------------------
!
      test = stringIsInArray('one  ',s1)
      CALL FTAssert(test = test,msg = 'StringIsInArray test')
      DO i = 1, SIZE(s1)
         CALL FTAssert(test = stringIsInArray(s1(i),keys),msg = "Set returned strings includes original strings")
         CALL FTAssert(test = set1 % containsString(str = s1(i)),msg = "Set1 contains string of original array")
      END DO
      DEALLOCATE(keys)

      CALL set2 % initWithStrings(strings = s2)
      CALL FTAssertEqual(expectedValue = SIZE(s2),     &
                         actualValue =  set2 % COUNT(), &
                         msg = "Second set count")
!
!     -------------------------
!     Check for FALSE positives
!     -------------------------
!
      CALL FTAssert(test = .NOT.set1 % containsString(str = 'blork'),msg = "Set1 should not contain string")
!
!     --------------------------
!     Check for case sensitivity
!     --------------------------
!
      CALL FTAssert(test = .NOT.set1 % containsString(str = 'ONE'),msg = 'Case sensitivity')
!
!     -------------------------------------------
!     Test size of string array returned from set
!     -------------------------------------------
!
      keys => set2 % strings()
      CALL FTAssertEqual(expectedValue = SIZE(s2),actualValue = SIZE(keys),msg = "Returned strings size count")
!
!     -------------------------------
!     Test all strings are in the set
!     -------------------------------
!
      test = stringIsInArray('eight',s2)
      CALL FTAssert(test = test,msg = 'StringIsInArray test set 2')
      DO i = 1, SIZE(s2)
         CALL FTAssert(test = stringIsInArray(s2(i),keys),msg = "Set returned strings includes original strings")
         CALL FTAssert(test = set2 % containsString(str = s2(i)),msg = "Set2 contains string of original array")
      END DO
      DEALLOCATE(keys)
!
!     ------------------
!     Test union of sets
!     ------------------
!
      unionSet => set1 % unionWithSet(set = set2)
      CALL FTAssertEqual(expectedValue = SIZE(unionStrings),&
                         actualValue =  unionSet % COUNT(), &
                         msg = "union set count")
      DO i = 1, SIZE(unionStrings)
         CALL FTAssert(test = unionSet % containsString(str = unionStrings(i)),msg = "unionSet contains string of original array")
      END DO
      CALL releaseFTStringSet(self = unionSet)
      CALL FTAssert(test = .NOT.ASSOCIATED(unionSet),msg = 'Release of pointer to set')
!
!     ----------------------
!     Test set intersections
!     ----------------------
!
      intersectionSet => set1 % intersectionWithSet(set = set2)
      CALL FTAssert(test = ASSOCIATED(intersectionSet),msg = 'Intersection pointer association')
      CALL FTAssertEqual(expectedValue = SIZE(intersectionStrings), &
                         actualValue = intersectionSet % count(), &
                         msg = 'Intersection size')
      DO i = 1, SIZE(intersectionStrings)
         CALL FTAssert(test = intersectionSet % containsString(str = intersectionStrings(i)),msg = "Set contains intersection")
      END DO
      CALL releaseFTStringSet(self = intersectionSet)
!
!     --------------------------------
!     Test difference between two sets
!     --------------------------------
!
      differenceSet => set1 % setFromDifference(set = set2)
      CALL FTAssert(test = ASSOCIATED(differenceSet),msg = 'Intersection pointer association')
      CALL FTAssertEqual(expectedValue = SIZE(differenceStrings1), &
                         actualValue = differenceSet % count(), &
                         msg = 'Difference set1 size')
      DO i = 1, SIZE(differenceStrings1)
         CALL FTAssert(test = differenceSet % containsString(str = differenceStrings1(i)),msg = "Set 1 contains difference")
      END DO
      CALL releaseFTStringSet(self = differenceSet)

      differenceSet => set2 % setFromDifference(set = set1)
      CALL FTAssert(test = ASSOCIATED(differenceSet),msg = 'Intersection pointer association')
      CALL FTAssertEqual(expectedValue = SIZE(differenceStrings2), &
                         actualValue = differenceSet % count(), &
                         msg = 'Difference set2 size')
      DO i = 1, SIZE(differenceStrings2)
         CALL FTAssert(test = differenceSet % containsString(str = differenceStrings2(i)),msg = "Set 2 contains difference")
      END DO
      CALL releaseFTStringSet(self = differenceSet)
!
!     --------------------
!     Test adding to a set
!     --------------------
!
      CALL set1 % addString(str = 'six')
      CALL FTAssertEqual(expectedValue = SIZE(s3),actualValue = set1 % count(),msg = 'Size of set after add')
      DO i = 1, SIZE(s3)
         CALL FTAssert(test = set1 % containsString(str = s3(i)),msg = "Appended set contains new string")
      END DO
!
!    ========
     CONTAINS
!    ========
      LOGICAL FUNCTION stringIsInArray(str,array)
         IMPLICIT NONE
         CHARACTER(LEN=*)               :: str
         CHARACTER(LEN=*) ,DIMENSION(:) :: array
         INTEGER                        :: i

         stringIsInArray = .FALSE.
         DO i = 1, SIZE(array)
            IF ( TRIM(str) == TRIM(array(i)) )     THEN
               stringIsInArray = .TRUE.
               EXIT
            END IF
         END DO

      END FUNCTION stringIsInArray

   END SUBROUTINE FTStringSetTests

max_stars_repo_name: HigherOrderMethods/FTObjectLibrary

max_issues_repo_name: HigherOrderMethods/FTObjectLibrary

max_forks_repo_name: HigherOrderMethods/FTObjectLibrary