        program main
        include 'mpif.h'
        integer count, errcnt, size, rank, ierr, i
        integer comm
        logical fnderr
        integer max_size
        integer world_rank
        parameter (max_size=100)
        integer intin(max_size), intout(max_size), intsol(max_size)
        real    realin(max_size), realout(max_size), realsol(max_size)
        double precision dblein(max_size), dbleout(max_size),
     *                   dblesol(max_size)
        complex cplxin(max_size), cplxout(max_size), cplxsol(max_size)
        logical login(max_size), logout(max_size), logsol(max_size)
C
C
C
C       Declare work areas
C
        call MPI_INIT( ierr )

        errcnt = 0
        comm = MPI_COMM_WORLD
        call MPI_COMM_RANK( comm, rank, ierr )
        world_rank = rank
        call MPI_COMM_SIZE( comm, size, ierr )
        count = 10

C Test sum
        if (world_rank .eq. 0) print *, ' MPI_SUM'

       fnderr = .false.
       do 23000 i=1,count
        intin(i) = i
        intsol(i) = i*size
        intout(i) = 0
23000   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_SUM, comm, ierr )
              do 23001 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23001   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_SUM'
        endif

       fnderr = .false.
       do 23002 i=1,count
        realin(i) = i
        realsol(i) = i*size
        realout(i) = 0
23002   continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_SUM, comm, ierr )
              do 23003 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23003   continue
        if (fnderr) then
          print *, 'Error for type MPI_REAL and op MPI_SUM'
        endif

       fnderr = .false.
       do 23004 i=1,count
        dblein(i) = i
        dblesol(i) = i*size
        dbleout(i) = 0
23004   continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr )
              do 23005 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23005   continue
        if (fnderr) then
          print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_SUM'
        endif

       fnderr = .false.
       do 23006 i=1,count
        cplxin(i) = i
        cplxsol(i) = i*size
        cplxout(i) = 0
23006   continue
       call MPI_Allreduce( cplxin, cplxout, count,
     *      MPI_COMPLEX, MPI_SUM, comm, ierr )
              do 23007 i=1,count
        if (cplxout(i).ne.cplxsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23007   continue
        if (fnderr) then
          print *, 'Error for type MPI_COMPLEX and op MPI_SUM'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_SUM'
        endif
        errcnt = 0

C Test product
        if (world_rank .eq. 0) print *, ' MPI_PROD'

       fnderr = .false.
       do 23008 i=1,count
        intin(i) = i
        intsol(i) = (i)**(size)
        intout(i) = 0
23008   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_PROD, comm, ierr )
              do 23009 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23009   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_PROD'
        endif

       fnderr = .false.
       do 23010 i=1,count
        realin(i) = i
        realsol(i) = (i)**(size)
        realout(i) = 0
23010   continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_PROD, comm, ierr )
              do 23011 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23011   continue
        if (fnderr) then
          print *, 'Error for type MPI_REAL and op MPI_PROD'
        endif

       fnderr = .false.
       do 23012 i=1,count
        dblein(i) = i
        dblesol(i) = (i)**(size)
        dbleout(i) = 0
23012   continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_PROD, comm, ierr )
              do 23013 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23013   continue
        if (fnderr) then
          print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_PROD'
        endif

       fnderr = .false.
       do 23014 i=1,count
        cplxin(i) = i
        cplxsol(i) = (i)**(size)
        cplxout(i) = 0
23014   continue
       call MPI_Allreduce( cplxin, cplxout, count,
     *      MPI_COMPLEX, MPI_PROD, comm, ierr )
              do 23015 i=1,count
        if (cplxout(i).ne.cplxsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23015   continue
        if (fnderr) then
          print *, 'Error for type MPI_COMPLEX and op MPI_PROD'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_PROD'
        endif
        errcnt = 0

C  Test max
        if (world_rank .eq. 0) print *, ' MPI_MAX'

       fnderr = .false.
       do 23016 i=1,count
        intin(i) = (rank + i)
        intsol(i) = (size - 1 + i)
        intout(i) = 0
23016   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_MAX, comm, ierr )
              do 23017 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23017   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_MAX'
        endif

       fnderr = .false.
       do 23018 i=1,count
        realin(i) = (rank + i)
        realsol(i) = (size - 1 + i)
        realout(i) = 0
23018   continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_MAX, comm, ierr )
              do 23019 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23019   continue
        if (fnderr) then
          print *, 'Error for type MPI_REAL and op MPI_MAX'
        endif

       fnderr = .false.
       do 23020 i=1,count
        dblein(i) = (rank + i)
        dblesol(i) = (size - 1 + i)
        dbleout(i) = 0
23020   continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr )
              do 23021 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23021   continue
        if (fnderr) then
          print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_MAX'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_MAX'
        endif
        errcnt = 0

C Test min
        if (world_rank .eq. 0) print *, ' MPI_MIN'

       fnderr = .false.
       do 23022 i=1,count
        intin(i) = (rank + i)
        intsol(i) = i
        intout(i) = 0
23022   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_MIN, comm, ierr )
              do 23023 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23023   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_MIN'
        endif

       fnderr = .false.
       do 23024 i=1,count
        realin(i) = (rank + i)
        realsol(i) = i
        realout(i) = 0
23024   continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_MIN, comm, ierr )
              do 23025 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23025   continue
        if (fnderr) then
          print *, 'Error for type MPI_REAL and op MPI_MIN'
        endif

       fnderr = .false.
       do 23026 i=1,count
        dblein(i) = (rank + i)
        dblesol(i) = i
        dbleout(i) = 0
23026   continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_MIN, comm, ierr )
              do 23027 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23027   continue
        if (fnderr) then
          print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_MIN'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_MIN'
        endif
        errcnt = 0

C Test LOR
        if (world_rank .eq. 0) print *, ' MPI_LOR'

       fnderr = .false.
       do 23028 i=1,count
        login(i) = (mod(rank,2) .eq. 1)
        logsol(i) = (size .gt. 1)
        logout(i) = .FALSE.
23028   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LOR, comm, ierr )
              do 23029 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23029   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LOR'
        endif

        if (errcnt .gt. 0) then
           print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_LOR(0)'
        endif
        errcnt = 0

       fnderr = .false.
       do 23030 i=1,count
        login(i) = .false.
        logsol(i) = .false.
        logout(i) = .FALSE.
23030   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LOR, comm, ierr )
              do 23031 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23031   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LOR'
        endif

        if (errcnt .gt. 0) then
           print *, 'Found ', errcnt, ' errors on ', rank,
     *              ' for MPI_LOR(1)'
        endif
        errcnt = 0

C Test LXOR
        if (world_rank .eq. 0) print *, ' MPI_LXOR'

       fnderr = .false.
       do 23032 i=1,count
        login(i) = (rank .eq. 1)
        logsol(i) = (size .gt. 1)
        logout(i) = .FALSE.
23032   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23033 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23033   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ',errcnt,' errors on ', rank, ' for MPI_LXOR'
        endif
        errcnt = 0

       fnderr = .false.
       do 23034 i=1,count
        login(i) = .false.
        logsol(i) = .false.
        logout(i) = .FALSE.
23034   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23035 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23035   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ',errcnt,' errors on ',rank,' for MPI_LXOR(0)'
        endif
        errcnt = 0

       fnderr = .false.
       do 23036 i=1,count
        login(i) = .true.
        logsol(i) = mod(size,2) .ne. 0
        logout(i) = .FALSE.
23036   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23037 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23037   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ',errcnt,' errors on ',rank,' for MPI_LXOR(1-0)'
        endif
        errcnt = 0

C Test LAND
        if (world_rank .eq. 0) print *, ' MPI_LAND'

       fnderr = .false.
       do 23038 i=1,count
        login(i) = (mod(rank,2) .eq. 1)
        logsol(i) = .false.
        logout(i) = .FALSE.
23038   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LAND, comm, ierr )
              do 23039 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23039   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LAND'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_LAND'
        endif
        errcnt = 0

       fnderr = .false.
       do 23040 i=1,count
        login(i) = .true.
        logsol(i) = .true.
        logout(i) = .FALSE.
23040   continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LAND, comm, ierr )
              do 23041 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23041   continue
        if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LAND'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ',errcnt,' errors on ',rank,
     *      ' for MPI_LAND(true)'
        endif
        errcnt = 0

C Test BOR
        if (world_rank .eq. 0) print *, ' MPI_BOR'
        if (size .lt. 3) then

       fnderr = .false.
       do 23042 i=1,count
        intin(i) = mod(rank,4)
        intsol(i) = size - 1
        intout(i) = 0
23042   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BOR, comm, ierr )
              do 23043 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23043   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BOR'
        endif

        else

       fnderr = .false.
       do 23044 i=1,count
        intin(i) = mod(rank,4)
        intsol(i) = 3
        intout(i) = 0
23044   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BOR, comm, ierr )
              do 23045 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23045   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BOR'
        endif

        endif
        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *           ' for MPI_BOR(1)'
        endif
        errcnt = 0

C Test BAND
        if (world_rank .eq. 0) print *, ' MPI_BAND'
C See bottom for function definitions

       fnderr = .false.
       do 23046 i=1,count
        intin(i) = ibxandval(rank,size,i)
        intsol(i) = i
        intout(i) = 0
23046   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BAND, comm, ierr )
              do 23047 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23047   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BAND'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_BAND(1)'
        endif
        errcnt = 0

       fnderr = .false.
       do 23048 i=1,count
        intin(i) = ibxandval1(rank,size,i)
        intsol(i) = 0
        intout(i) = 0
23048   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BAND, comm, ierr )
              do 23049 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23049   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BAND'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_BAND(0)'
        endif
        errcnt = 0

C Test BXOR
        if (world_rank .eq. 0) print *, ' MPI_BXOR'
C See below for function definitions

       fnderr = .false.
       do 23050 i=1,count
        intin(i) = ibxorval1(rank)
        intsol(i) = ibxorsol1(size)
        intout(i) = 0
23050   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23051 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23051   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_BXOR(1)'
        endif
        errcnt = 0

       fnderr = .false.
       do 23052 i=1,count
        intin(i) = 0
        intsol(i) = 0
        intout(i) = 0
23052   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23053 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23053   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_BXOR(0)'
        endif
        errcnt = 0

C Assumes -1 == all bits set

       fnderr = .false.
       do 23054 i=1,count
        intin(i) = (-1)
        if (mod(size,2) .eq. 0) then
            intsol(i) = 0
        else
            intsol(i) = -1
        endif
        intout(i) = 0
23054   continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23055 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23055   continue
        if (fnderr) then
          print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_BXOR(1-0)'
        endif
        errcnt = 0

C Test Maxloc
        if (world_rank .eq. 0) print *, ' MPI_MAXLOC'

        fnderr = .false.
        do 23056 i=1, count
           intin(2*i-1) = (rank + i)
           intin(2*i)   = rank
           intsol(2*i-1) = (size - 1 + i)
           intsol(2*i) = (size-1)
           intout(2*i-1) = 0
           intout(2*i)   = 0
23056   continue
                call MPI_Allreduce( intin, intout, count,
     *      MPI_2INTEGER, MPI_MAXLOC, comm, ierr )
        do 23057 i=1, count
        if (intout(2*i-1) .ne. intsol(2*i-1) .or.
     *      intout(2*i) .ne. intsol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23057   continue
        if (fnderr) then
        print *, 'Error for type MPI_2INTEGER and op MPI_MAXLOC'
        endif

        fnderr = .false.
        do 23058 i=1, count
           realin(2*i-1) = (rank + i)
           realin(2*i)   = rank
           realsol(2*i-1) = (size - 1 + i)
           realsol(2*i) = (size-1)
           realout(2*i-1) = 0
           realout(2*i)   = 0
23058   continue
                call MPI_Allreduce( realin, realout, count,
     *      MPI_2REAL, MPI_MAXLOC, comm, ierr )
        do 23059 i=1, count
        if (realout(2*i-1) .ne. realsol(2*i-1) .or.
     *      realout(2*i) .ne. realsol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23059   continue
        if (fnderr) then
        print *, 'Error for type MPI_2REAL and op MPI_MAXLOC'
        endif

        fnderr = .false.
        do 23060 i=1, count
           dblein(2*i-1) = (rank + i)
           dblein(2*i)   = rank
           dblesol(2*i-1) = (size - 1 + i)
           dblesol(2*i) = (size-1)
           dbleout(2*i-1) = 0
           dbleout(2*i)   = 0
23060   continue
                call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_2DOUBLE_PRECISION, MPI_MAXLOC, comm, ierr )
        do 23061 i=1, count
        if (dbleout(2*i-1) .ne. dblesol(2*i-1) .or.
     *      dbleout(2*i) .ne. dblesol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23061   continue
        if (fnderr) then
           print *,
     *     'Error for type MPI_2DOUBLE_PRECISION and op MPI_MAXLOC'

        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_MAXLOC'
        endif
        errcnt = 0

C Test minloc
        if (world_rank .eq. 0) print *, ' MPI_MINLOC'

        fnderr = .false.
        do 23062 i=1, count
           intin(2*i-1) = (rank + i)
           intin(2*i)   = rank
           intsol(2*i-1) = i
           intsol(2*i) = 0
           intout(2*i-1) = 0
           intout(2*i)   = 0
23062   continue
                call MPI_Allreduce( intin, intout, count,
     *      MPI_2INTEGER, MPI_MINLOC, comm, ierr )
        do 23063 i=1, count
        if (intout(2*i-1) .ne. intsol(2*i-1) .or.
     *      intout(2*i) .ne. intsol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23063   continue
        if (fnderr) then
        print *, 'Error for type MPI_2INTEGER and op MPI_MINLOC'
        endif

        fnderr = .false.
        do 23064 i=1, count
           realin(2*i-1) = (rank + i)
           realin(2*i)   = rank
           realsol(2*i-1) = i
           realsol(2*i) = 0
           realout(2*i-1) = 0
           realout(2*i)   = 0
23064   continue
                call MPI_Allreduce( realin, realout, count,
     *      MPI_2REAL, MPI_MINLOC, comm, ierr )
        do 23065 i=1, count
        if (realout(2*i-1) .ne. realsol(2*i-1) .or.
     *      realout(2*i) .ne. realsol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23065   continue
        if (fnderr) then
        print *, 'Error for type MPI_2REAL and op MPI_MINLOC'
        endif

        fnderr = .false.
        do 23066 i=1, count
           dblein(2*i-1) = (rank + i)
           dblein(2*i)   = rank
           dblesol(2*i-1) = i
           dblesol(2*i) = 0
           dbleout(2*i-1) = 0
           dbleout(2*i)   = 0
23066   continue
                call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_2DOUBLE_PRECISION, MPI_MINLOC, comm, ierr )
        do 23067 i=1, count
        if (dbleout(2*i-1) .ne. dblesol(2*i-1) .or.
     *      dbleout(2*i) .ne. dblesol(2*i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23067   continue
        if (fnderr) then
           print *,
     *      'Error for type MPI_2DOUBLE_PRECISION and op MPI_MINLOC'
        endif

        if (errcnt .gt. 0) then
        print *, 'Found ', errcnt, ' errors on ', rank,
     *          ' for MPI_MINLOC'
        endif
        errcnt = 0

        call MPI_Finalize( ierr )
        end

        integer function ibxorval1( ir )
        ibxorval1 = 0
        if (ir .eq. 1) ibxorval1 = 16+32+64+128
        return
        end

        integer function ibxorsol1( is )
        ibxorsol1 = 0
        if (is .gt. 1) ibxorsol1 = 16+32+64+128
        return
        end

C
C       Assumes -1 == all bits set
        integer function ibxandval( ir, is, i )
        integer ir, is, i
        ibxandval = -1
        if (ir .eq. is - 1) ibxandval = i
        return
        end
C
        integer function ibxandval1( ir, is, i )
        integer ir, is, i
        ibxandval1 = 0
        if (ir .eq. is - 1) ibxandval1 = i
        return
        end


module parameters
  implicit none
  !parameters to be used in the project

  !kind-related parameters
  INTEGER, PARAMETER :: rk=selected_real_kind(20,100), ik=selected_int_kind(38)
  INTEGER, PARAMETER :: MAXBUFF=200

  !Gravitational constant
  REAL(rk), PARAMETER :: G= 6.67430*10.0**(-11) !m^3 kg^(-1) s^(-2)

end module parameters


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program conv_exp

      ! Test convolution of two DLR expansions for Green's functions
      ! which are each a single exponential. Compare result with
      ! analytically-known convolution.

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      ! Input parameters

      lambda = 1000.0d0   ! DLR high energy cutoff
      eps = 1.0d-14       ! DLR error tolerance

      ntst = 10000        ! # imaginary time test points
      beta = 1000.0d0     ! Inverse temperature

      ! Main test subroutine

      call conv_exp_main(lambda,eps,ntst,beta)

      end program conv_exp

      subroutine conv_exp_main(lambda,eps,ntst,beta)

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      integer i,j,r
      integer, allocatable :: it2cfp(:)
      real *8 one,gtrue,gtest,errl2,errlinf,gmax,gl2
      real *8, allocatable :: ttst(:),it2cf(:,:),dlrit(:),dlrrf(:)
      real *8, allocatable :: g1(:),g2(:),g3(:)

      real *8, allocatable :: phi(:,:),gmat(:,:)

      one = 1.0d0

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Sample G1 and G2 at imaginary time nodes

      allocate(g1(r),g2(r),g3(r))

      do i=1,r

        call gfun1(beta,dlrit(i),g1(i))
        call gfun2(beta,dlrit(i),g2(i))

      enddo

      ! Get convolution tensor

      allocate(phi(r*r,r))

      call dlr_convtens(beta,-1,r,dlrrf,dlrit,it2cf,it2cfp,phi)

      ! Get matrix of convolution by G1

      allocate(gmat(r,r))

      call dlr_convmat(r,it2cf,it2cfp,phi,g1,gmat)

      ! Apply matrix to G2 to obtain convolution G3

      g3 = matmul(gmat,g2)

      ! Get DLR coefficients of G3

      call dlr_it2cf(r,it2cf,it2cfp,g3,g3)

      ! Get test points in relative format

      allocate(ttst(ntst))

      call eqpts_rel(ntst,ttst)

      ! Measure L^inf and L^2 errors of convolution

      errlinf = 0*one
      errl2 = 0*one
      gmax = 0*one
      gl2 = 0*one

      do i=1,ntst

        ! Evaluate true convolution

        call gfun3(beta,ttst(i),gtrue)

        ! Evaluate DLR

        call dlr_it_eval(r,dlrrf,g3,ttst(i),gtest)

        ! Update L^inf and L^2 errors, norms

        errlinf = max(errlinf,abs(gtrue-gtest))
        errl2 = errl2 + (gtrue-gtest)**2

        gmax = max(gmax,abs(gtrue))
        gl2 = gl2 + gtrue**2

      enddo

      errl2 = sqrt((ttst(2)-ttst(1))*errl2)
      gl2 = sqrt((ttst(2)-ttst(1))*gl2)

      write(6,*) ''
      write(6,*) 'DLR rank = ',r
      write(6,*) 'Abs L^inf err = ',errlinf
      write(6,*) 'Abs L^2 err   = ',errl2
      write(6,*) 'Rel L^inf err = ',errlinf/gmax
      write(6,*) 'Rel L^2 err   = ',errl2/gl2
      write(6,*) ''

      ! Return failed status if error is not sufficiently small

      if (errlinf.gt.1.0d-13) then
        call exit(1)
      endif

      end subroutine conv_exp_main

      subroutine gfun1(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1

      a1 = 0.804d0

      g = kfunf_rel(t,beta*a1)

      end subroutine gfun1

      subroutine gfun2(beta,t,g)

      ! Evaluate single exponential Green's function

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a2

      a2 = -0.443d0

      g = kfunf_rel(t,beta*a2)

      end subroutine gfun2

      subroutine gfun3(beta,t,g)

      ! Evaluate Green's function corresponding to convolution of two
      ! single exponentials

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1,a2

      a1 = 0.804d0
      a2 = -0.443d0

      g = (kfunf_rel(t,beta*a2)-kfunf_rel(t,beta*a1))/(a1-a2)

      end subroutine gfun3


module one_dimensional_FT
    use constants, only: real12, zero, cmplx_zero, fatal_error_from_call
    use greensroutines, only: greensfunc, copy_gf_slice
    use, intrinsic :: iso_c_binding
    implicit none
    include 'fftw3.f03'
    include 'fftw3q.f03'
    private
    public oneD_FT_initplan, oneD_FT_killplan, oneD_fft, forward_fft, backward_fft, &
        & init_oneDplan, oneDwork_in, oneDwork_out, oneD_plan_forward, oneD_plan_backward
    protected init_oneDplan, oneDwork_in, oneDwork_out, oneD_plan_forward, oneD_plan_backward
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   useful public constants defining FFT direction
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    integer, parameter :: forward_fft = 1
    !# use as type_flag to call a forward fft
    integer, parameter :: backward_fft = -1
    !# use as type_flag to call a backward fft
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   private variables and pointers for interoprability with C FFT routines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    type(c_ptr) :: oneD_plan_forward
    !stores information for forward one D FFT plan
    type(c_ptr) :: oneD_plan_backward
    !stores information for backward one D FFT plan
    complex(C_FLOAT128_COMPLEX), allocatable :: oneDwork_in(:)
    complex(C_FLOAT128_COMPLEX), allocatable :: oneDwork_out(:)
    logical :: init_oneDplan = .false.

contains

    subroutine oneD_FT_initplan(line, ierr)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Sets up FFTW parameters for computations.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Error codes: ierr = 0 -- Routine executed successfully;
!#              ierr = 1 -- FFT parameters already set;
!#              ierr = 2-4 -- Null pointers for forward, backward or both FFTs
!#                       - a big problem!
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        complex(real12), intent(in) :: line(:)
        integer, intent(out) :: ierr
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! routine variables
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        integer :: x_size, y_size, z_size

        ierr = 0
        call check_input()
        if (ierr /= 0) return

        x_size = size(line, 1)

        allocate (oneDwork_in(x_size))
        allocate (oneDwork_out(x_size))

        ! note ctype array ordering
        oneD_plan_forward = fftwq_plan_dft_1d(x_size, oneDwork_in, oneDwork_out, FFTW_FORWARD, FFTW_ESTIMATE)

        oneD_plan_backward = fftwq_plan_dft_1d(x_size, oneDwork_in, oneDwork_out, FFTW_BACKWARD, FFTW_ESTIMATE)

        call check_plans()
        if (ierr /= 0) return
        init_oneDplan = .true.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    contains
!------------------------------------------------------------------------------
        subroutine check_input()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            if (init_oneDplan) ierr = 1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        end subroutine check_input
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
        subroutine check_plans()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            if (c_associated(oneD_plan_forward, c_null_ptr)) then
                ierr = 2
            else if (c_associated(oneD_plan_backward, c_null_ptr)) then
                ierr = 3
            else if ((c_associated(oneD_plan_forward, c_null_ptr)) .and. (c_associated(oneD_plan_backward, c_null_ptr))) then
                ierr = 4
            end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        end subroutine check_plans
!------------------------------------------------------------------------------
    end subroutine oneD_FT_initplan

    subroutine oneD_FT_killplan(ierr)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Cleans up after all FFTs are done
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Error codes : ierr = 0 -- no problems;
!#               ierr = 1 -- FFT settings haven't been initialised.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        integer, intent(out)   :: ierr
        !# error code
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ierr = 0
        call check_input()
        if (ierr /= 0) return

        call fftwq_destroy_plan(oneD_plan_forward)
        call fftwq_destroy_plan(oneD_plan_backward)

        deallocate (oneDwork_in, oneDwork_out)

        init_oneDplan = .false.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    contains
!------------------------------------------------------------------------------
        subroutine check_input()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            if (.not. (init_oneDplan)) ierr = 1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        end subroutine check_input
!------------------------------------------------------------------------------
    end subroutine oneD_FT_killplan

    subroutine oneD_fft(transform, type_flag, ierr)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# FFT of the array transform, output to transform
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!# Error codes : ierr = 0 -- no problems;
!#               ierr = 1 -- FFT plan not initialised;
!#               ierr = 2 -- type_flag has invalid value;
!#               ierr = 3 -- array size doesn't match initialised settings.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        type(greensfunc), intent(inout) :: transform(:)
        !# Green's function to be FFTed
        integer, intent(in) :: type_flag !must be -1 or +1
        !# set to **forward_fft** or **backward_fft** when calling subroutine
        integer, intent(out) :: ierr
        !# error code
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! routine variables
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        integer, parameter :: forward_trans = 1, backward_trans = -1
        integer :: x_size, n_omega
        integer :: ix, iom
        real(real12) :: volume
        type(c_ptr) :: transform_type

        ierr = 0
        call check_input()
        if (ierr /= 0) return

        x_size = size(transform, 1)
        volume = real(x_size, real12)
        n_omega = size(transform(1)%GF, 1)
        call check_work_array_bounds()
        if (ierr /= 0) return

        if (type_flag == backward_trans) then
            transform_type = oneD_plan_backward
        else if (type_flag == forward_trans) then
            transform_type = oneD_plan_forward
        end if

        do iom = 1, n_omega
            call copy_gf_slice(oneDwork_in, transform, iom)
            call fftwq_execute_dft(transform_type, oneDwork_in, oneDwork_out)
            !scale backwards transformation
            if (type_flag == backward_trans) oneDwork_out = oneDwork_out/volume
            call copy_gf_slice(transform, oneDwork_out, iom)
        end do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    contains
!------------------------------------------------------------------------------
        subroutine check_input()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            if (.not. (init_oneDplan)) then
                ierr = 1
            else if ((type_flag /= backward_trans) &
                     .and. (type_flag /= forward_trans)) then
                ierr = 2
            end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        end subroutine check_input
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
        subroutine check_work_array_bounds()
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            if ((x_size /= size(oneDwork_in, 1)) .or. (x_size /= size(oneDwork_out, 1))) &
                then
                ierr = 3
            end if
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        end subroutine check_work_array_bounds
!------------------------------------------------------------------------------
    end subroutine oneD_fft

end module one_dimensional_FT


c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine csbf(n,p,r,fb,fn,fh)
c     ================================================================
c
c     ****************************************************************
c     spherical bessel and neuman functions
c     ****************************************************************
c
      implicit none
c
      integer     n
      integer     l
c
      real*8      r
c
      complex*16  fb(0:n)
      complex*16  fn(0:n)
      complex*16  fh(0:n)
      complex*16  p
      complex*16  x1
      complex*16  x2
      complex*16  sqrtm1
c
      parameter (sqrtm1=(0.d0,1.d0))
c
      x1=r*p
      x2=x1*x1
c
      fb(0)= sin(x1)/x1
      fb(1)= sin(x1)/x2 - cos(x1)/x1
      fn(0)=-cos(x1)/x1
      fn(1)=-cos(x1)/x2 - sin(x1)/x1
      fh(0)=fb(0)+sqrtm1*fn(0)
      fh(1)=fb(1)+sqrtm1*fn(1)
c
      do l=2,n
        fb(l)=(2*l-1)*fb(l-1)/x1-fb(l-2)
      end do
      do l=2,n
        fn(l)=(2*l-1)*fn(l-1)/x1-fn(l-2)
      end do
      do l=2,n
        fh(l)=fb(l)+sqrtm1*fn(l)
      end do
c
      return
      end


include "interpolate.f90"
!----------------------------------------
subroutine kin(u, v, ke, ds2, order, l, m, n)

  ! compute the kinetic energy of the component associated with
  ! the direction of the last entry (the one contiguous in memory)
  !
  ! algo: "square first, average then"
  ! compute ke at velocity point (say U) and average at T-point (cell center)
  !
  ! convention u[k, j, i] is the velocity on the right face of the cell [k, j, i]
  !
  !
  ! ds2 is the diagonal metric term 1/dx**2 or 1/dy**2 or 1/dz**2

  implicit none

  integer, intent(in):: l, m, n, order
  real*8 :: ds2
  real*8, dimension(l, m, n), intent(in) :: u, v
  real*8, dimension(l, m, n), intent(inout) :: ke

  !f2py intent(inplace):: u, v, ke

  real*8 :: u2, u22, cff, cff2, UU, up, um
  real*8,dimension(n) :: zke, kem
  real*8,dimension(0:n-1) :: kep
  integer:: i, j, k
  real*8::c1,c2,c3, b1, b2, b3, b4, b5, d1, e1,e2

  ! second order
  d1 = 0.5
  ! third order
  c1 = -1./6.
  c2 =  5./6.
  c3 =  2./6.
  ! fourth order
  e1 = -1./12
  e2 = 7./12.
  ! fifth order
  b1 = 2./60.
  b2 = -13./60.
  b3 = 47./60.
  b4 = 27./60.
  b5 = -3./60.

  cff2 = 0.5*ds2

  do k = 1, l
     do j = 1, m
        !zke(0) = 0.
        do i = 1, n
           zke(i) = u(k, j, i)*v(k, j, i)*cff2
        enddo
        !
        call interpolate(zke, kep, kem, order, n)
        !
        if (mod(order, 2).eq.0) then
           do i = 1, n
              ke(k,j,i) = ke(k,j,i)+kem(i)
           enddo
        else
           UU = 0.5*(v(k,j,1)+0)
           do i = 1, n
              if (UU.gt.0) then
                 ke(k,j,i) = ke(k,j,i)+kep(i-1)
              else
                 ke(k,j,i) = ke(k,j,i)+kem(i)
              endif
              if (i.lt.n)UU = 0.5*(v(k,j,i+1)+v(k,j,i))
           enddo
        endif
     enddo
  enddo
end subroutine kin


*=======================================================================
* Single Precision Complex Fast Fourier Transform
*
*  A subroutine to compute the discrete Fourier transform by the fastest
* available algorithm for any length input series.
*
* Reference:
*        Ferguson, W., (1979),   A Simple Derivation of Glassmans's
*          General N Fast Fourier Transform, MRC Tech. Summ. Rept. 2029,
*          Math. Res. Cent. U. of Wisconsin, Madison, Wis.
*
*  REFERENCES
*  ----------
*
* Routines called:
* SPCPFT
*
* Functions called:
* MOD
* FLOAT
*
* VAX extensions:
* DO WHILE
*=======================================================================

      SUBROUTINE SPCFFT(U,N,ISIGN,WORK,INTERP)

* VARIABLES
* ---------

      IMPLICIT NONE

      LOGICAL*1
     |  INU      ! Flag for calling SUBROUTINE SPCPFT( arguments ).
     | ,SCALE    ! .TRUE.=inverse transform -- .FALSE.=forward transform

      INTEGER*4
     |  A        ! After    \
     | ,B        ! Before    >  Factors of N.
     | ,C        ! Current  /
     | ,N        ! Length of the array to be transformed.
     | ,I        ! DO loop index.
     | ,ISIGN    ! sign of transform

      REAL*4
     |  INTERP   ! interpolation factor

      COMPLEX*8
     |  U(*)            !  Vector to be transformed
     | ,WORK(*)         !  Working storage.

*     Initialize parameters.

      A = 1
      B = N
      C = 1

      INU = .TRUE.

      IF (ISIGN.EQ.1) THEN

         SCALE = .TRUE.

      ELSE IF (ISIGN.EQ.-1) THEN

         SCALE = .FALSE.

      END IF

* Calculate Fourier transform by means of Glassman's algorithm

      DO WHILE ( B .GT. 1 )

         A = C * A

* Start of routine to get factors of N

         C = 2

* Increment C until it is an integer factor of B

         DO WHILE ( MOD(B,C) .NE. 0 )

                  C = C + 1

         END DO

* Calculate largest factor of B

         B = B / C

* Call Glassman's Fast Fourier Transform routine

         IF ( INU ) THEN

            CALL SPCPFT (A,B,C,U,WORK,ISIGN)

          ELSE

            CALL SPCPFT (A,B,C,WORK,U,ISIGN)

         END IF

* Set flag to swap input & output arrays to SPCPFT

         INU = ( .NOT. INU )

      END DO

* If odd number of calls to SPCPFT swap WORK into U

      IF ( .NOT. INU ) THEN

         DO I = 1, N
            U(I) = WORK(I)
         END DO

      END IF

* Scale the output for inverse Fourier transforms.

      IF ( SCALE ) THEN

         DO I = 1, N
            U(I) = U(I) / (N/INTERP)
         END DO

      END IF

* TERMINATION
* -----------

      RETURN
      END

*=======================================================================
* Single Precision Complex Prime Factor Transform
*
*  REFERENCES
*  ----------
*
* Calling routines:
* SPCFFT
*
* Subroutines called:
* -none-
*
* Functions called:
* CMLPX
* COS
* SIN
* FLOAT
*=======================================================================

      SUBROUTINE SPCPFT( A, B, C, UIN, UOUT, ISIGN )

* VARIABLES
* ---------

      IMPLICIT NONE

      INTEGER*4
     |  ISIGN           !  ISIGN of the Fourier transform.
     | ,A               !  After   \
     | ,B               !  Before   >  Factors of N.
     | ,C               !  Current /
     | ,IA              !  \
     | ,IB              !   \  DO loop indicies.
     | ,IC              !   /
     | ,JCR             !  /
     | ,JC              !  Dummy index.

      REAL*8
     |  ANGLE

      COMPLEX*8
     |  UIN(B,C,A)      !  Input vector.
     | ,UOUT(B,A,C)     !  Output vector.
     | ,DELTA           !  Fourier transform kernel.
     | ,OMEGA           !  Multiples of exp( i TWOPI ).
     | ,SUM             !  Dummy register for addition for UOUT(B,A,C)

* ALGORITHM
* ---------

* Initialize run time parameters.

      ANGLE =6.28318530717958 / FLOAT( A * C )
      OMEGA = CMPLX( 1.0, 0.0 )

* Check the ISIGN of the transform.

      IF( ISIGN .EQ. 1 ) THEN

         DELTA = CMPLX( DCOS(ANGLE), DSIN(ANGLE) )

      ELSE

         DELTA = CMPLX( DCOS(ANGLE), -DSIN(ANGLE) )

      END IF

* Do the computations.

      DO IC = 1, C

         DO IA = 1, A

            DO IB = 1, B

               SUM = UIN( IB, C, IA )

               DO JCR = 2, C

                  JC = C + 1 - JCR
                  SUM = UIN( IB, JC, IA ) + OMEGA * SUM

               END DO

               UOUT( IB, IA, IC ) = SUM

            END DO

            OMEGA = DELTA * OMEGA

         END DO

      END DO

* TERMINATION
* -----------

      RETURN
      END

#ifdef FFT_TEST

      program test

      implicit none

      integer*4 nmax
      parameter( nmax=10000 )

      complex*8 input(nmax)
      complex*8 scratch(nmax)

      real*4 a , b

      integer*4 i
      integer*4 n

      n = 0
 1000 format( 2e25.15 )
      do i=1, nmax

         read( 5 ,1000 ,end=10 ) input(i)
         n = n + 1

      end do

   10 continue

      call spcfft( input ,n ,0 ,scratch ,1.0 )

      do i=1 ,n

         write( 6 ,1000 ) real(input(i)) ,imag(input(i))

      end do

      call spcfft( input ,n ,1 ,scratch ,1.0 )

      do i=1 ,n

         write( 6 ,1000 ) real(input(i)) ,imag(input(i))

      end do

      end

#endif
#ifdef TEST

      program test

      implicit none

      real*4 data_in(10000)
      real*4 data_out(10000)

      integer*4 i
      integer*4 m
      integer*4 n

      read( 5 ,* ) m ,n

      do i=1,m
         read( 5 ,* ,end=10 ) data_in(i)
      end do

   10 continue

      write( 6 ,* ) '#input'
      do i=1 ,m
         write( 6 ,'(2f25.10)' ) real(i-1)/(m) ,data_in(i)
      end do

      call resample( data_in ,m ,data_out ,n )

      write( 6 ,* ) '#output'
      do i=1 ,n
         write( 6 ,'(2f25.10)' ) real(i-1)/(n) ,data_out(i)
      end do

      end

#endif


!*******************************************************************
!                                                                  *
      SUBROUTINE NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,INN,AA)
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2  J2/2  J3/2 |                                        *
!     |  L1/2  L2/2  L3/2 |                                        *
!     |  K1/2  K2/2  K3/2 |                                        *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             March    1995  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      USE nine0_I
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1, J2, J3, L1, L2, L3, K1, K2, K3
      INTEGER, INTENT(IN)  :: I
      INTEGER, INTENT(OUT) :: INN
      REAL(DOUBLE)  :: AA
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: N1, N2, N3, N4, N5, N6, MAX_, MIN_, IX
      REAL(DOUBLE) :: S1, S2, S3, X
!-----------------------------------------------
      IF (I == 1) THEN
         INN = 0
         IF (ITTK(J1,J2,J3) == 0) RETURN
         IF (ITTK(L1,L2,L3) == 0) RETURN
         IF (ITTK(K1,K2,K3) == 0) RETURN
         IF (ITTK(J1,L1,K1) == 0) RETURN
         IF (ITTK(J2,L2,K2) == 0) RETURN
         IF (ITTK(J3,L3,K3) == 0) RETURN
         INN = 1
         RETURN
      ENDIF
      IF (J1*J2*J3*L1*L2*L3*K1*K2*K3 == 0) THEN
         INN = 1
         CALL NINE0 (J1, J2, J3, L1, L2, L3, K1, K2, K3, AA)
      ELSE
         N1 = IABS(J1 - K3)
         N2 = IABS(L3 - J2)
         N3 = IABS(L1 - K2)
         N4 = IABS(J2 - L3)
         N5 = IABS(K2 - L1)
         N6 = IABS(J1 - K3)
         MAX_ = MAX0(N1,N2,N3,N4,N5,N6)
         N1 = J1 + K3
         N2 = L3 + J2
         N3 = J2 + L3
         N4 = K2 + L1
         N5 = J1 + K3
         N6 = L1 + K2
         MIN_ = MIN0(N1,N2,N3,N4,N5,N6)
         INN = 1
         AA = ZERO
         DO IX = MAX_, MIN_, 2
            CALL SIXJ (J1, J2, J3, L3, K3, IX, 0, S1)
            CALL SIXJ (L1, L2, L3, J2, IX, K2, 0, S2)
            CALL SIXJ (K1, K2, K3, IX, J1, L1, 0, S3)
            X = S1*S2*S3*DBLE(IX + 1)
            IF (MOD(IX,2) /= 0) X = -X
            AA = X + AA
         END DO
      ENDIF
      RETURN
      END SUBROUTINE NINE


!##############################################################################
!# Tutorial 006e: Create Laplace with different cubature formulas.
!##############################################################################

module tutorial006e

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation
  use derivatives
  use stdoperators

  use matrixio

  implicit none
  private

  public :: start_tutorial006e

contains

  ! ***************************************************************************

  subroutine start_tutorial006e

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation
    type(t_matrixScalar) :: rmatrix
    type(t_scalarCubatureInfo), target :: rcubatureInfo_TRZ
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G1
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G2
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G3
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G4
    type(t_scalarCubatureInfo), target :: rcubatureInfo_G5
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006e")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a CSR-matrix for the above
    ! discretisation.
    ! =================================

    ! Create the matrix structure
    call bilf_createMatrixStructure (rdiscretisation,LSYSSC_MATRIX9,rmatrix)

    ! Allocate memory for the content.
    call lsyssc_allocEmptyMatrix (rmatrix)

    ! =================================
    ! Create a set of cubature structures
    ! that represent different cubature
    ! formulas.
    ! =================================

    ! Trapezoidal rule and Gauss formulas up to Gauss 5x5.
    ! Using the trapezoidal rule will give a 5-point stencil as known from FD.
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_TRZ,CUB_GEN_AUTO_TRZ)
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G1 ,CUB_GEN_AUTO_G1)
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G2 ,CUB_GEN_AUTO_G2)
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G3 ,CUB_GEN_AUTO_G3)
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G4 ,CUB_GEN_AUTO_G4)
    call spdiscr_createDefCubStructure (rdiscretisation,rcubatureInfo_G5 ,CUB_GEN_AUTO_G5)

    ! =================================
    ! Discretise Laplace matrix, output to text files.
    ! =================================
    call output_line ("Writing matrices to text files...")

    ! -------------------------------------------
    ! Discretise the Laplace matrix. Trapezoidal rule.
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_TRZ)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_trz.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_trz.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Gauss 1x1.
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_G1)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_g1.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_g1.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Gauss 2x2
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_G2)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_g2.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_g2.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Gauss 3x3.
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_G3)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_g3.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_g3.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Gauss 4x4.
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_G4)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_g4.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_g4.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Gauss 5x5.
    call lsyssc_clearMatrix (rmatrix)
    call stdop_assembleLaplaceMatrix (rmatrix,rcubatureInfo=rcubatureInfo_G5)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006e_g5.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006e_g5.txt", "(E15.5)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrix
    call lsyssc_releaseMatrix (rmatrix)

    ! Release the cubature formula structures.
    call spdiscr_releaseCubStructure (rcubatureInfo_TRZ)
    call spdiscr_releaseCubStructure (rcubatureInfo_G1)
    call spdiscr_releaseCubStructure (rcubatureInfo_G2)
    call spdiscr_releaseCubStructure (rcubatureInfo_G3)
    call spdiscr_releaseCubStructure (rcubatureInfo_G4)
    call spdiscr_releaseCubStructure (rcubatureInfo_G5)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


c     program DRSRANG
c>> 2001-05-22 DRSRANG  Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSRANG  Krogh Added external statement.
c>> 1994-10-19 DRSRANG  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSRANG  Lawson  Initial Code.
c--S replaces "?": DR?RANG, ?RANG, ?STAT1, ?STAT2
c     Demonstration driver for SRANG.  Generates random numbers
c     from the Gaussian distribution.
c     ------------------------------------------------------------------
      integer NCELLS
      parameter(NCELLS = 12+2)
      external SRANG
      real                 SRANG, STATS(5), Y1, Y2, YTAB(1), ZERO
      integer  I, IHIST(NCELLS), N
c
      parameter(ZERO = 0.0E0)
      data       N / 10000/
      data  Y1, Y2 / -3.0E0, +3.0E0/
c     ------------------------------------------------------------------
      STATS(1) = ZERO
      do 20 I=1,N
c                          GET RANDOM NUMBER
         YTAB(1) = SRANG()
c
c                          Accumulate statistics and histogram.
c
        call SSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Gaussian random numbers from SRANG'
      call SSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


      PROGRAM MAIN

C     RESULT REPORTING
C     CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(F18.15)"
      CHARACTER(LEN=*), PARAMETER  :: FMT1 = "(E12.6)"

C     ----------------------------------------------
C     Variables and data for FCUL_A
C     ----------------------------------------------
      DOUBLE PRECISION FCUL_A, F

C     F = FCUL_A(30.67166667D0, 2075D0, 300.15D0, 15D0)

C     REPORT RESULTS
      PRINT *, '----------------------------------------'
      PRINT *, '> FCUL_A Results:'
      PRINT *, '----------------------------------------'
      WRITE(*, FMT1) DABS(FCUL_A(30.67166667D0, 2075D0, 300.15D0, 15D0)
     . -3.800243667312344087D0)

C     ALL DONE
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   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.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!> \brief This module contains procedures for computing various statistical correlation coefficients.
!> \author Amir Shahmoradi

module CorrCoef_mod

    use Constants_mod, only: RK, IK
    use Err_mod, only: Err_type
    implicit none

    character(*), parameter :: MODULE_NAME = "@CorrCoef_mod"

    type :: CorrCoefSpearman_type
        integer(IK)             :: ndata
        real(RK), allocatable   :: Data1(:), Data2(:)
        real(RK)                :: rho, rhoProb, dStarStar, dStarStarSignif, dStarStarProb
        type(Err_type)          :: Err
    contains
        procedure, nopass :: get => getCorrCoefSpearman
    end type CorrCoefSpearman_type

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Return the Spearman correlation coefficient of the two input data arrays.
    !>
    !> @param[in] ndata             :   The length of the two input data arrays.
    !> @param[in] Data1             :   The input data array of size `(1:ndata)`.
    !> @param[in] Data2             :   The input data array of size `(1:ndata)`.
    !> @param[out] rho              :   The Spearman rank correlation coefficient.
    !> @param[out] rhoProb          :   The two-sided significance level of the deviation of `rho` from zero.
    !> @param[out] dStarStar        :   The sum-squared difference of ranks of the two data vectors.
    !> @param[out] dStarStarSignif  :   The number of standard deviations by which `dStarStar` deviates from its null-hypothesis expected value.
    !> @param[out] dStarStarProb    :   The two-sided significance level of the deviation represented by `dStarStarSignif`.
    !> @param[out] Err              :   An object of [Err_type](@ref err_mod::err_type) class, indicating whether an error has occurred.
    !>
    !> \remark
    !> A small value of either `dStarStarProb` or `rhoProb` indicates a significant correlation.
    subroutine getCorrCoefSpearman(ndata,Data1,Data2,rho,rhoProb,dStarStar,dStarStarSignif,dStarStarProb,Err)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: getCorrCoefSpearman
#endif
        use Constants_mod, only: IK, RK, SQRT2, SPR
        use Statistics_mod, only: getBetaCDF
        use Sort_mod, only: sortAscending

        implicit none

        integer(IK)     , intent(in)    :: ndata
        real(RK)        , intent(in)    :: Data1(ndata), Data2(ndata)
        real(RK)        , intent(out)   :: rho, rhoProb
        real(RK)        , intent(out)   :: dStarStar, dStarStarSignif, dStarStarProb
        type(Err_type)  , intent(out)   :: Err

        character(*)    , parameter     :: PROCEDURE_NAME = MODULE_NAME//"@getCorrCoefSpearman"
        real(RK)                        :: aved,df,en,en3n,fac,sf,sg,t,vard
        real(RK)                        :: WorkSpace1(ndata), WorkSpace2(ndata)

        WorkSpace1 = Data1
        WorkSpace2 = Data2
        call sortAscending(ndata,WorkSpace1,WorkSpace2,Err)
        if (Err%occurred) then
        ! LCOV_EXCL_START
            Err%msg = PROCEDURE_NAME//Err%msg
            return
        end if
        ! LCOV_EXCL_STOP
        call crank(ndata,WorkSpace1,sf)

        call sortAscending(ndata,WorkSpace2,WorkSpace1,Err)
        if (Err%occurred) then
        ! LCOV_EXCL_START
            Err%msg = PROCEDURE_NAME//Err%msg
            return
        end if
        ! LCOV_EXCL_STOP
        call crank(ndata,WorkSpace2,sg)

        WorkSpace1 = WorkSpace1 - WorkSpace2
        dStarStar = dot_product(WorkSpace1,WorkSpace1)
        en = ndata
        en3n = en**3-en
        aved = en3n/6.0_RK-(sf+sg)/12.0_RK
        fac = (1.0_RK-sf/en3n)*(1.0_RK-sg/en3n)
        vard = ((en-1.0_RK)*en**2*(en+1.0_RK)**2/36.0_RK)*fac
        dStarStarSignif = (dStarStar-aved)/sqrt(vard)
        dStarStarProb = erfc( real( abs(dStarStarSignif)/SQRT2 , kind=SPR ) )
        rho = (1.0_RK-(6.0_RK/en3n)*(dStarStar+(sf+sg)/12.0_RK))/sqrt(fac)
        fac = (1.0_RK+rho)*(1.0_RK-rho)
        if (fac > 0.0) then
            t = rho*sqrt((en-2.0_RK)/fac)
            df = en-2.0_RK
            rhoProb = getBetaCDF(0.5_RK*df,0.5_RK,df/(df+t**2))
        else
            rhoProb = 0.0
        end if

    contains

        subroutine crank(ndata,Array,s)
            use Constants_mod, only: IK, RK
            use Misc_mod, only : arth, copyArray
            implicit none
            integer(IK), intent(in) :: ndata
            real(RK), intent(out) :: s
            real(RK), intent(inout) :: Array(ndata)
            integer(IK) :: i,ndum,nties
            integer(IK) :: Tstart(ndata), Tend(ndata), Tie(ndata), Idx(ndata)
            Idx = arth(1,1,ndata)
            Tie = merge(1,0,Array == eoshift(Array,-1))
            Tie(1) = 0
            Array = Idx(:)
            if (all(Tie == 0)) then
                s = 0.0
                return
            end if
            call copyArray( pack(Idx,Tie<eoshift(Tie,1)), Tstart, nties, ndum )
            Tend(1:nties) = pack(Idx(:),Tie(:)>eoshift(Tie(:),1))
            do i = 1,nties
                Array(Tstart(i):Tend(i)) = (Tstart(i)+Tend(i))/2.0_RK
            end do
            Tend(1:nties) = Tend(1:nties)-Tstart(1:nties)+1
            s = sum(Tend(1:nties)**3-Tend(1:nties))
        end subroutine crank

    end subroutine getCorrCoefSpearman

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module CorrCoef_mod ! LCOV_EXCL_LINE


program main
  use geo3x3
  implicit none
  real pos(4)

  print *, geo3x3_encode(35.65858, 139.745433, 14)

  pos = geo3x3_decode("E9139659937288")
  print *, pos(1), pos(2), pos(3), pos(4)
end


!! GLWH Dec 2020
!! <summary>This program reads in a POSCAR-like file and finds the
!! number of operations in the spacegroup.</summary>
!! The input file should be the three lattice vectors (one in each row)
!! then the number of atoms on the next line
!! then the atomic type (integer) followed by three floats (for the position)
PROGRAM symdriver
use num_types

use symmetry
implicit none

real(dp) LV(3,3)
integer nAt, nSG, nLPG, i
character(len=128) filename
real(dp), allocatable    :: d(:,:)
real(dp), allocatable    :: rots(:,:,:), shifts(:,:)
real(dp), pointer        :: pg(:,:,:)
integer, allocatable     :: aTyp(:)

call getarg(1,filename)
if (filename=="") then; filename = "symcheck.str"; endif

open(33,file=filename,status="old")
read(33,*) (LV(:,i),i=1,3)
! Count the number of atoms and types
read(33,*) nAt
allocate(aTyp(nAt),d(3,nAt))
do i = 1,nAt
  read(33,*) aTyp(i), d(:,i)
enddo
call get_lattice_pointGroup(LV, pg)
call get_spacegroup(LV, aTyp, d, rots, shifts, .false.)
close(33)

nSG=size(rots,3); nLPG=size(pg,3)
write(*,'(i3,2x,"(Number of spacegroup operations)")') nSG
write(*,'(i3,2x,"(Number of lattice PG operations)")') nLPG
END PROGRAM symdriver


!> \file test_phizero.f90
!! \BRIEF Fortran 90 program to test phizero routine in gasx.f90
PROGRAM test_phizero

   USE msingledouble
   USE gasx

   IMPLICIT NONE

   INTEGER, PARAMETER :: n = 1

!  Output variables:
   REAL(kind=r8), DIMENSION(1) :: phi0_cfc11, phi0_cfc12, phi0_sf6, phi0_co2, phi0_n2o

!  Input variables
   REAL(kind=rx), DIMENSION(1) :: temp, sal

!  Input at standard T and S
!  temp(1)   = 25.0
!  sal(1)    = 35.0

   temp(1)   = 4.0
   sal(1)    = 34.0

!  Call
   call phizero('cfc11', temp, sal, n, phi0_cfc11)
   call phizero('cfc12', temp, sal, n, phi0_cfc12)
   call phizero('sf6',   temp, sal, n, phi0_sf6)
   call phizero('co2',   temp, sal, n, phi0_co2)
   call phizero('n2o',   temp, sal, n, phi0_n2o)

   write (*,*) "phi0_cfc11 = ", phi0_cfc11
   write (*,*) "phi0_cfc12 = ", phi0_cfc12
   write (*,*) "phi0_sf6   = ", phi0_sf6
   write (*,*) "phi0_co2   = ", phi0_co2
   write (*,*) "phi0_n2o   = ", phi0_n2o

   write (*, *) ' '
   write (*,*) 'Results above should be 2.136063e-2, 5.370289e-3, 3.560764e-4, 5.517209e-2, 4.080887e-2, respectively:'
   write (*,*) '-> these values are essentially the same as in the papers from Warner & Weiss (1985), Bullister et al. (2002), and'
   write (*,*) '   Weiss & Price (1980), after correcting for density (using 1.028).'

   STOP
END PROGRAM test_phizero


module brent
    ! from https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.html
  contains

function glomin ( a, b, c, m, machep, e, t, f, x )

!*****************************************************************************80
!
!! GLOMIN seeks a global minimum of a function F(X) in an interval [A,B].
!
!  Discussion:
!
!    This function assumes that F(X) is twice continuously differentiable
!    over [A,B] and that F''(X) <= M for all X in [A,B].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 April 2008
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization Without Derivatives,
!    Dover, 2002,
!    ISBN: 0-486-41998-3,
!    LC: QA402.5.B74.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!    It must be the case that A < B.
!
!    Input, real ( kind = 8 ) C, an initial guess for the global
!    minimizer.  If no good guess is known, C = A or B is acceptable.
!
!    Input, real ( kind = 8 ) M, the bound on the second derivative.
!
!    Input, real ( kind = 8 ) MACHEP, an estimate for the relative machine
!    precision.
!
!    Input, real ( kind = 8 ) E, a positive tolerance, a bound for the
!    absolute error in the evaluation of F(X) for any X in [A,B].
!
!    Input, real ( kind = 8 ) T, a positive error tolerance.
!
!    Input, external real ( kind = 8 ) F, the name of a user-supplied
!    function, of the form "FUNCTION F ( X )", which evaluates the
!    function whose global minimum is being sought.
!
!    Output, real ( kind = 8 ) X, the estimated value of the abscissa
!    for which F attains its global minimum value in [A,B].
!
!    Output, real ( kind = 8 ) GLOMIN, the value F(X).
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) a0
  real ( kind = 8 ) a2
  real ( kind = 8 ) a3
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) d0
  real ( kind = 8 ) d1
  real ( kind = 8 ) d2
  real ( kind = 8 ) e
  real ( kind = 8 ) f
  real ( kind = 8 ) glomin
  real ( kind = 8 ) h
  integer ( kind = 4 ) k
  real ( kind = 8 ) m
  real ( kind = 8 ) m2
  real ( kind = 8 ) machep
  real ( kind = 8 ) p
  real ( kind = 8 ) q
  real ( kind = 8 ) qs
  real ( kind = 8 ) r
  real ( kind = 8 ) s
  real ( kind = 8 ) sc
  real ( kind = 8 ) t
  real ( kind = 8 ) x
  real ( kind = 8 ) y
  real ( kind = 8 ) y0
  real ( kind = 8 ) y1
  real ( kind = 8 ) y2
  real ( kind = 8 ) y3
  real ( kind = 8 ) yb
  real ( kind = 8 ) z0
  real ( kind = 8 ) z1
  real ( kind = 8 ) z2

  a0 = b
  x = a0
  a2 = a
  y0 = f ( b )
  yb = y0
  y2 = f ( a )
  y = y2

  if ( y0 < y ) then
    y = y0
  else
    x = a
  end if

  if ( m <= 0.0D+00 .or. b <= a ) then
    glomin = y
    return
  end if

  m2 = 0.5D+00 * ( 1.0D+00 + 16.0D+00 * machep ) * m

  if ( c <= a .or. b <= c ) then
    sc = 0.5D+00 * ( a + b )
  else
    sc = c
  end if

  y1 = f ( sc )
  k = 3
  d0 = a2 - sc
  h = 9.0D+00 / 11.0D+00

  if ( y1 < y ) then
    x = sc
    y = y1
  end if

  do

    d1 = a2 - a0
    d2 = sc - a0
    z2 = b - a2
    z0 = y2 - y1
    z1 = y2 - y0
    r = d1 * d1 * z0 - d0 * d0 * z1
    p = r
    qs = 2.0D+00 * ( d0 * z1 - d1 * z0 )
    q = qs

    if ( k < 1000000 .or. y2 <= y ) then

      do

        if ( q * ( r * ( yb - y2 ) + z2 * q * ( ( y2 - y ) + t ) ) < &
          z2 * m2 * r * ( z2 * q - r ) ) then
          a3 = a2 + r / q
          y3 = f ( a3 )

          if ( y3 < y ) then
            x = a3
            y = y3
          end if
        end if

        k = mod ( 1611 * k, 1048576 )
        q = 1.0D+00
        r = ( b - a ) * 0.00001D+00 * real ( k, kind = 8 )

        if ( z2 <= r ) then
          exit
        end if

      end do

    else

      k = mod ( 1611 * k, 1048576 )
      q = 1.0D+00
      r = ( b - a ) * 0.00001D+00 * real ( k, kind = 8 )

      do while ( r < z2 )

        if ( q * ( r * ( yb - y2 ) + z2 * q * ( ( y2 - y ) + t ) ) < &
          z2 * m2 * r * ( z2 * q - r ) ) then
          a3 = a2 + r / q
          y3 = f ( a3 )

          if ( y3 < y ) then
            x = a3
            y = y3
          end if
        end if

        k = mod ( 1611 * k, 1048576 )
        q = 1.0D+00
        r = ( b - a ) * 0.00001D+00 * real ( k, kind = 8 )

      end do

    end if

    r = m2 * d0 * d1 * d2
    s = sqrt ( ( ( y2 - y ) + t ) / m2 )
    h = 0.5D+00 * ( 1.0D+00 + h )
    p = h * ( p + 2.0D+00 * r * s )
    q = q + 0.5D+00 * qs
    r = - 0.5D+00 * ( d0 + ( z0 + 2.01D+00 * e ) / ( d0 * m2 ) )

    if ( r < s .or. d0 < 0.0D+00 ) then
      r = a2 + s
    else
      r = a2 + r
    end if

    if ( 0.0D+00 < p * q ) then
      a3 = a2 + p / q
    else
      a3 = r
    end if

    do

      a3 = max ( a3, r )

      if ( b <= a3 ) then
        a3 = b
        y3 = yb
      else
        y3 = f ( a3 )
      end if

      if ( y3 < y ) then
        x = a3
        y = y3
      end if

      d0 = a3 - a2

      if ( a3 <= r ) then
        exit
      end if

      p = 2.0D+00 * ( y2 - y3 ) / ( m * d0 )

      if ( ( 1.0D+00 + 9.0D+00 * machep ) * d0 <= abs ( p ) ) then
        exit
      end if

      if ( 0.5D+00 * m2 * ( d0 * d0 + p * p ) <= &
        ( y2 - y ) + ( y3 - y ) + 2.0D+00 * t ) then
        exit
      end if

      a3 = 0.5D+00 * ( a2 + a3 )
      h = 0.9D+00 * h

    end do

    if ( b <= a3 ) then
      exit
    end if

    a0 = sc
    sc = a2
    a2 = a3
    y0 = y1
    y1 = y2
    y2 = y3

  end do

  glomin = y

  return
end
function local_min ( a, b, eps, t, f, x )

!*****************************************************************************80
!
!! LOCAL_MIN seeks a local minimum of a function F(X) in an interval [A,B].
!
!  Discussion:
!
!    If the function F is defined on the interval (A,B), then local_min
!    finds an approximation X to the point at which F attatains its minimum
!    (or the appropriate limit point), and returns the value of F at X.
!
!    T and EPS define a tolerance TOL = EPS * abs ( X ) + T.
!    F is never evaluated at two points closer than TOL.
!
!    If F is delta-unimodal for some delta less than TOL, the X approximates
!    the global minimum of F with an error less than 3*TOL.
!
!    If F is not delta-unimodal, then X may approximate a local, but
!    perhaps non-global, minimum.
!
!    The method used is a combination of golden section search and
!    successive parabolic interpolation.  Convergence is never much slower
!    than that for a Fibonacci search.  If F has a continuous second
!    derivative which is positive at the minimum (which is not at A or
!    B), then, ignoring rounding errors, convergence is superlinear, and
!    usually of the order of about 1.3247.
!
!    Thanks to Jonathan Eggleston for pointing out a correction to the
!    golden section step, 01 July 2013.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    01 July 2013
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization Without Derivatives,
!    Dover, 2002,
!    ISBN: 0-486-41998-3,
!    LC: QA402.5.B74.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the interval.
!
!    Input, real ( kind = 8 ) EPS, a positive relative error tolerance.
!    EPS should be no smaller than twice the relative machine precision,
!    and preferably not much less than the square root of the relative
!    machine precision.
!
!    Input, real ( kind = 8 ) T, a positive absolute error tolerance.
!
!    Input, external real ( kind = 8 ) F, the name of a user-supplied
!    function, of the form "FUNCTION F ( X )", which evaluates the
!    function whose local minimum is being sought.
!
!    Output, real ( kind = 8 ) X, the estimated value of an abscissa
!    for which F attains a local minimum value in [A,B].
!
!    Output, real ( kind = 8 ) LOCAL_MIN, the value F(X).
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) d
  real ( kind = 8 ) e
  real ( kind = 8 ) eps
  real ( kind = 8 ) f
  real ( kind = 8 ) fu
  real ( kind = 8 ) fv
  real ( kind = 8 ) fw
  real ( kind = 8 ) fx
  real ( kind = 8 ) local_min
  real ( kind = 8 ) m
  real ( kind = 8 ) p
  real ( kind = 8 ) q
  real ( kind = 8 ) r
  real ( kind = 8 ) sa
  real ( kind = 8 ) sb
  real ( kind = 8 ) t
  real ( kind = 8 ) t2
  real ( kind = 8 ) tol
  real ( kind = 8 ) u
  real ( kind = 8 ) v
  real ( kind = 8 ) w
  real ( kind = 8 ) x
!
!  C is the square of the inverse of the golden ratio.
!
  c = 0.5D+00 * ( 3.0D+00 - sqrt ( 5.0D+00 ) )

  sa = a
  sb = b
  x = sa + c * ( b - a )
  w = x
  v = w
  e = 0.0D+00
  fx = f ( x )
  fw = fx
  fv = fw

  do

    m = 0.5D+00 * ( sa + sb )
    tol = eps * abs ( x ) + t
    t2 = 2.0D+00 * tol
!
!  Check the stopping criterion.
!
    if ( abs ( x - m ) <= t2 - 0.5D+00 * ( sb - sa ) ) then
      exit
    end if
!
!  Fit a parabola.
!
    r = 0.0D+00
    q = r
    p = q

    if ( tol < abs ( e ) ) then

      r = ( x - w ) * ( fx - fv )
      q = ( x - v ) * ( fx - fw )
      p = ( x - v ) * q - ( x - w ) * r
      q = 2.0D+00 * ( q - r )

      if ( 0.0D+00 < q ) then
        p = - p
      end if

      q = abs ( q )

      r = e
      e = d

    end if

    if ( abs ( p ) < abs ( 0.5D+00 * q * r ) .and. &
         q * ( sa - x ) < p .and. &
         p < q * ( sb - x ) ) then
!
!  Take the parabolic interpolation step.
!
      d = p / q
      u = x + d
!
!  F must not be evaluated too close to A or B.
!
      if ( ( u - sa ) < t2 .or. ( sb - u ) < t2 ) then

        if ( x < m ) then
          d = tol
        else
          d = - tol
        end if

      end if
!
!  A golden-section step.
!
    else

      if ( x < m ) then
        e = sb - x
      else
        e = sa - x
      end if

      d = c * e

    end if
!
!  F must not be evaluated too close to X.
!
    if ( tol <= abs ( d ) ) then
      u = x + d
    else if ( 0.0D+00 < d ) then
      u = x + tol
    else
      u = x - tol
    end if

    fu = f ( u )
!
!  Update A, B, V, W, and X.
!
    if ( fu <= fx ) then

      if ( u < x ) then
        sb = x
      else
        sa = x
      end if

      v = w
      fv = fw
      w = x
      fw = fx
      x = u
      fx = fu

    else

      if ( u < x ) then
        sa = u
      else
        sb = u
      end if

      if ( fu <= fw .or. w == x ) then
        v = w
        fv = fw
        w = u
        fw = fu
      else if ( fu <= fv .or. v == x .or. v == w ) then
        v = u
        fv = fu
      end if

    end if

  end do

  local_min = fx

  return
end
subroutine local_min_rc ( a, b, arg, status, value )

!*****************************************************************************80
!
!! LOCAL_MIN_RC seeks a minimizer of a scalar function of a scalar variable.
!
!  Discussion:
!
!    This routine seeks an approximation to the point where a function
!    F attains a minimum on the interval (A,B).
!
!    The method used is a combination of golden section search and
!    successive parabolic interpolation.  Convergence is never much
!    slower than that for a Fibonacci search.  If F has a continuous
!    second derivative which is positive at the minimum (which is not
!    at A or B), then convergence is superlinear, and usually of the
!    order of about 1.324...
!
!    The routine is a revised version of the Brent local minimization
!    algorithm, using reverse communication.
!
!    It is worth stating explicitly that this routine will NOT be
!    able to detect a minimizer that occurs at either initial endpoint
!    A or B.  If this is a concern to the user, then the user must
!    either ensure that the initial interval is larger, or to check
!    the function value at the returned minimizer against the values
!    at either endpoint.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 October 2004
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization Without Derivatives,
!    Dover, 2002,
!    ISBN: 0-486-41998-3,
!    LC: QA402.5.B74.
!
!    David Kahaner, Cleve Moler, Steven Nash,
!    Numerical Methods and Software,
!    Prentice Hall, 1989,
!    ISBN: 0-13-627258-4,
!    LC: TA345.K34.
!
!  Parameters
!
!    Input/output, real ( kind = 8 ) A, B.  On input, the left and right
!    endpoints of the initial interval.  On output, the lower and upper
!    bounds for an interval containing the minimizer.  It is required
!    that A < B.
!
!    Output, real ( kind = 8 ) ARG, the currently considered point.  The user
!    does not need to initialize this value.  On return with STATUS positive,
!    the user is requested to evaluate the function at ARG, and return
!    the value in VALUE.  On return with STATUS zero, ARG is the routine's
!    estimate for the function minimizer.
!
!    Input/output, integer ( kind = 4 ) STATUS, used to communicate between
!    the user and the routine.  The user only sets STATUS to zero on the first
!    call, to indicate that this is a startup call.  The routine returns STATUS
!    positive to request that the function be evaluated at ARG, or returns
!    STATUS as 0, to indicate that the iteration is complete and that
!    ARG is the estimated minimizer.
!
!    Input, real ( kind = 8 ) VALUE, the function value at ARG, as requested
!    by the routine on the previous call.
!
!  Local parameters:
!
!    C is the squared inverse of the golden ratio.
!
!    EPS is the square root of the relative machine precision.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) arg
  real ( kind = 8 ) b
  real ( kind = 8 ), save :: c
  real ( kind = 8 ), save :: d
  real ( kind = 8 ), save :: e
  real ( kind = 8 ), save :: eps
  real ( kind = 8 ), save :: fu
  real ( kind = 8 ), save :: fv
  real ( kind = 8 ), save :: fw
  real ( kind = 8 ), save :: fx
  real ( kind = 8 ), save :: midpoint
  real ( kind = 8 ), save :: p
  real ( kind = 8 ), save :: q
  real ( kind = 8 ), save :: r
  integer ( kind = 4 ) status
  real ( kind = 8 ), save :: tol
  real ( kind = 8 ), save :: tol1
  real ( kind = 8 ), save :: tol2
  real ( kind = 8 ), save :: u
  real ( kind = 8 ), save :: v
  real ( kind = 8 ) value
  real ( kind = 8 ), save :: w
  real ( kind = 8 ), save :: x
!
!  STATUS (INPUT) = 0, startup.
!
  if ( status == 0 ) then

    if ( b <= a ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'LOCAL_MIN_RC - Fatal error!'
      write ( *, '(a)' ) '  A < B is required, but'
      write ( *, '(a,g14.6)' ) '  A = ', a
      write ( *, '(a,g14.6)' ) '  B = ', b
      status = -1
      stop 1
    end if

    c = 0.5D+00 * ( 3.0D+00 - sqrt ( 5.0D+00 ) )

    eps = sqrt ( epsilon ( eps ) )
    tol = epsilon ( tol )

    v = a + c * ( b - a )
    w = v
    x = v
    e = 0.0D+00

    status = 1
    arg = x

    return
!
!  STATUS (INPUT) = 1, return with initial function value of FX.
!
  else if ( status == 1 ) then

    fx = value
    fv = fx
    fw = fx
!
!  STATUS (INPUT) = 2 or more, update the data.
!
  else if ( 2 <= status ) then

    fu = value

    if ( fu <= fx ) then

      if ( x <= u ) then
        a = x
      else
        b = x
      end if

      v = w
      fv = fw
      w = x
      fw = fx
      x = u
      fx = fu

    else

      if ( u < x ) then
        a = u
      else
        b = u
      end if

      if ( fu <= fw .or. w == x ) then
        v = w
        fv = fw
        w = u
        fw = fu
      else if ( fu <= fv .or. v == x .or. v == w ) then
        v = u
        fv = fu
      end if

    end if

  end if
!
!  Take the next step.
!
  midpoint = 0.5D+00 * ( a + b )
  tol1 = eps * abs ( x ) + tol / 3.0D+00
  tol2 = 2.0D+00 * tol1
!
!  If the stopping criterion is satisfied, we can exit.
!
  if ( abs ( x - midpoint ) <= ( tol2 - 0.5D+00 * ( b - a ) ) ) then
    status = 0
    return
  end if
!
!  Is golden-section necessary?
!
  if ( abs ( e ) <= tol1 ) then

    if ( midpoint <= x ) then
      e = a - x
    else
      e = b - x
    end if

    d = c * e
!
!  Consider fitting a parabola.
!
  else

    r = ( x - w ) * ( fx - fv )
    q = ( x - v ) * ( fx - fw )
    p = ( x - v ) * q - ( x - w ) * r
    q = 2.0D+00 * ( q - r )
    if ( 0.0D+00 < q ) then
      p = - p
    end if
    q = abs ( q )
    r = e
    e = d
!
!  Choose a golden-section step if the parabola is not advised.
!
    if ( &
      ( abs ( 0.5D+00 * q * r ) <= abs ( p ) ) .or. &
      ( p <= q * ( a - x ) ) .or. &
      ( q * ( b - x ) <= p ) ) then

      if ( midpoint <= x ) then
        e = a - x
      else
        e = b - x
      end if

      d = c * e
!
!  Choose a parabolic interpolation step.
!
    else

      d = p / q
      u = x + d

      if ( ( u - a ) < tol2 ) then
        d = sign ( tol1, midpoint - x )
      end if

      if ( ( b - u ) < tol2 ) then
        d = sign ( tol1, midpoint - x )
      end if

    end if

  end if
!
!  F must not be evaluated too close to X.
!
  if ( tol1 <= abs ( d ) ) then
    u = x + d
  end if

  if ( abs ( d ) < tol1 ) then
    u = x + sign ( tol1, d )
  end if
!
!  Request value of F(U).
!
  arg = u
  status = status + 1

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end

function zero ( a, b, machep, t, f )

!*****************************************************************************80
!
!! ZERO seeks the root of a function F(X) in an interval [A,B].
!
!  Discussion:
!
!    The interval [A,B] must be a change of sign interval for F.
!    That is, F(A) and F(B) must be of opposite signs.  Then
!    assuming that F is continuous implies the existence of at least
!    one value C between A and B for which F(C) = 0.
!
!    The location of the zero is determined to within an accuracy
!    of 6 * MACHEPS * abs ( C ) + 2 * T.
!
!    Thanks to Thomas Secretin for pointing out a transcription error in the
!    setting of the value of P, 11 February 2013.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 February 2013
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization Without Derivatives,
!    Dover, 2002,
!    ISBN: 0-486-41998-3,
!    LC: QA402.5.B74.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the change of
!    sign interval.
!
!    Input, real ( kind = 8 ) MACHEP, an estimate for the relative machine
!    precision.
!
!    Input, real ( kind = 8 ) T, a positive error tolerance.
!
!    Input, external real ( kind = 8 ) F, the name of a user-supplied
!    function, of the form "FUNCTION F ( X )", which evaluates the
!    function whose zero is being sought.
!
!    Output, real ( kind = 8 ) ZERO, the estimated value of a zero of
!    the function F.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) d
  real ( kind = 8 ) e
  real ( kind = 8 ) f
  real ( kind = 8 ) fa
  real ( kind = 8 ) fb
  real ( kind = 8 ) fc
  real ( kind = 8 ) m
  real ( kind = 8 ) machep
  real ( kind = 8 ) p
  real ( kind = 8 ) q
  real ( kind = 8 ) r
  real ( kind = 8 ) s
  real ( kind = 8 ) sa
  real ( kind = 8 ) sb
  real ( kind = 8 ) t
  real ( kind = 8 ) tol
  real ( kind = 8 ) zero
!
!  Make local copies of A and B.
!
  sa = a
  sb = b
  fa = f ( sa )
  fb = f ( sb )

  c = sa
  fc = fa
  e = sb - sa
  d = e

  do

    if ( abs ( fc ) < abs ( fb ) ) then

      sa = sb
      sb = c
      c = sa
      fa = fb
      fb = fc
      fc = fa

    end if

    tol = 2.0D+00 * machep * abs ( sb ) + t
    m = 0.5D+00 * ( c - sb )

    if ( abs ( m ) <= tol .or. fb == 0.0D+00 ) then
      exit
    end if

    if ( abs ( e ) < tol .or. abs ( fa ) <= abs ( fb ) ) then

      e = m
      d = e

    else

      s = fb / fa

      if ( sa == c ) then

        p = 2.0D+00 * m * s
        q = 1.0D+00 - s

      else

        q = fa / fc
        r = fb / fc
        p = s * ( 2.0D+00 * m * q * ( q - r ) - ( sb - sa ) * ( r - 1.0D+00 ) )
        q = ( q - 1.0D+00 ) * ( r - 1.0D+00 ) * ( s - 1.0D+00 )

      end if

      if ( 0.0D+00 < p ) then
        q = - q
      else
        p = - p
      end if

      s = e
      e = d

      if ( 2.0D+00 * p < 3.0D+00 * m * q - abs ( tol * q ) .and. &
        p < abs ( 0.5D+00 * s * q ) ) then
        d = p / q
      else
        e = m
        d = e
      end if

    end if

    sa = sb
    fa = fb

    if ( tol < abs ( d ) ) then
      sb = sb + d
    else if ( 0.0D+00 < m ) then
      sb = sb + tol
    else
      sb = sb - tol
    end if

    fb = f ( sb )

    if ( ( 0.0D+00 < fb .and. 0.0D+00 < fc ) .or. &
         ( fb <= 0.0D+00 .and. fc <= 0.0D+00 ) ) then
      c = sa
      fc = fa
      e = sb - sa
      d = e
    end if

  end do

  zero = sb

  return
end function zero

subroutine zero_rc ( a, b, t, arg, status, value )

!*****************************************************************************80
!
!! ZERO_RC seeks the root of a function F(X) using reverse communication.
!
!  Discussion:
!
!    The interval [A,B] must be a change of sign interval for F.
!    That is, F(A) and F(B) must be of opposite signs.  Then
!    assuming that F is continuous implies the existence of at least
!    one value C between A and B for which F(C) = 0.
!
!    The location of the zero is determined to within an accuracy
!    of 6 * MACHEPS * abs ( C ) + 2 * T.
!
!    The routine is a revised version of the Brent zero finder
!    algorithm, using reverse communication.
!
!    Thanks to Thomas Secretin for pointing out a transcription error in the
!    setting of the value of P, 11 February 2013.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    11 February 2013
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization Without Derivatives,
!    Dover, 2002,
!    ISBN: 0-486-41998-3,
!    LC: QA402.5.B74.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, the endpoints of the change of
!    sign interval.
!
!    Input, real ( kind = 8 ) T, a positive error tolerance.
!
!    Output, real ( kind = 8 ) ARG, the currently considered point.  The user
!    does not need to initialize this value.  On return with STATUS positive,
!    the user is requested to evaluate the function at ARG, and return
!    the value in VALUE.  On return with STATUS zero, ARG is the routine's
!    estimate for the function's zero.
!
!    Input/output, integer ( kind = 4 ) STATUS, used to communicate between
!    the user and the routine.  The user only sets STATUS to zero on the first
!    call, to indicate that this is a startup call.  The routine returns STATUS
!    positive to request that the function be evaluated at ARG, or returns
!    STATUS as 0, to indicate that the iteration is complete and that
!    ARG is the estimated zero
!
!    Input, real ( kind = 8 ) VALUE, the function value at ARG, as requested
!    by the routine on the previous call.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) arg
  real ( kind = 8 ) b
  real ( kind = 8 ), save :: c
  real ( kind = 8 ), save :: d
  real ( kind = 8 ), save :: e
  real ( kind = 8 ), save :: fa
  real ( kind = 8 ), save :: fb
  real ( kind = 8 ), save :: fc
  real ( kind = 8 ) m
  real ( kind = 8 ), save :: machep
  real ( kind = 8 ) p
  real ( kind = 8 ) q
  real ( kind = 8 ) r
  real ( kind = 8 ) s
  real ( kind = 8 ), save :: sa
  real ( kind = 8 ), save :: sb
  integer ( kind = 4 ) status
  real ( kind = 8 ) t
  real ( kind = 8 ) tol
  real ( kind = 8 ) value
!
!  Input STATUS = 0.
!  Initialize, request F(A).
!
  if ( status == 0 ) then

    machep = epsilon ( a )

    sa = a
    sb = b
    e = sb - sa
    d = e

    status = 1
    arg = a
    return
!
!  Input STATUS = 1.
!  Receive F(A), request F(B).
!
  else if ( status == 1 ) then

    fa = value

    status = 2
    arg = sb
    return
!
!  Input STATUS = 2
!  Receive F(B).
!
  else if ( status == 2 ) then

    fb = value

    if ( 0.0D+00 < fa * fb ) then
      status = -1
      return
    end if

    c = sa
    fc = fa

  else

    fb = value

    if ( ( 0.0D+00 < fb .and. 0.0D+00 < fc ) .or. &
         ( fb <= 0.0D+00 .and. fc <= 0.0D+00 ) ) then
      c = sa
      fc = fa
      e = sb - sa
      d = e
    end if

  end if
!
!  Compute the next point at which a function value is requested.
!
  if ( abs ( fc ) < abs ( fb ) ) then

    sa = sb
    sb = c
    c = sa
    fa = fb
    fb = fc
    fc = fa

  end if

  tol = 2.0D+00 * machep * abs ( sb ) + t
  m = 0.5D+00 * ( c - sb )

  if ( abs ( m ) <= tol .or. fb == 0.0D+00 ) then
    status = 0
    arg = sb
    return
  end if

  if ( abs ( e ) < tol .or. abs ( fa ) <= abs ( fb ) ) then

    e = m
    d = e

  else

    s = fb / fa

    if ( sa == c ) then

      p = 2.0D+00 * m * s
      q = 1.0D+00 - s

    else

      q = fa / fc
      r = fb / fc
      p = s * ( 2.0D+00 * m * q * ( q - r ) - ( sb - sa ) * ( r - 1.0D+00 ) )
      q = ( q - 1.0D+00 ) * ( r - 1.0D+00 ) * ( s - 1.0D+00 )

    end if

    if ( 0.0D+00 < p ) then
      q = - q
    else
      p = - p
    end if

    s = e
    e = d

    if ( 2.0D+00 * p < 3.0D+00 * m * q - abs ( tol * q ) .and. &
      p < abs ( 0.5D+00 * s * q ) ) then
      d = p / q
    else
      e = m
      d = e
    end if

  end if

  sa = sb
  fa = fb

  if ( tol < abs ( d ) ) then
    sb = sb + d
  else if ( 0.0D+00 < m ) then
    sb = sb + tol
  else
    sb = sb - tol
  end if

  arg = sb
  status = status + 1

  return
end

    end module brent