      Module mba3d_refine
C
      use mba3d_auxSE
      use mba3d_cmpE
      use mba3d_error
      use mba3d_makQ
      use mba3d_utils
C
      contains
C
C ================================================================
      Subroutine initializeRefinement(
C ================================================================
     &      nP, nE, XYP, IPE,
     &      MapMtr, Ref2MapMtr)
C ================================================================
C   Fill mapping matrix for each tetrahedron to make it equilateral
C   Fill reference array to MapMtr
C ================================================================
      Real*8  XYP(3, *), MapMtr(3, 3, *)
      Integer IPE(4, *), Ref2MapMtr(*)

C Local
      Real*8  AA(3,3), A(3,3), B(3,3), XYPet(3,4)
      Integer IPIV(3), info

c Equilateral tet
      XYPet(1,1) = 0d0
      XYPet(2,1) = 0d0
      XYPet(3,1) = 0d0
      XYPet(1,2) = 2*dsqrt(2d0)/3
      XYPet(2,2) = 0d0
      XYPet(3,2) = -4d0/3
      XYPet(1,3) = -dsqrt(2d0)/3
      XYPet(2,3) =  dsqrt(6d0)/3
      XYPet(3,3) = -4d0/3
      XYPet(1,4) = -dsqrt(2d0)/3
      XYPet(2,4) = -dsqrt(6d0)/3
      XYPet(3,4) = -4d0/3

c Find map Ortotet to Equitet
      Do i=1,3
         Do j=1,3
            AA(i,j) = XYPet(i,j+1) - XYPet(i,1)
         End do
      End do

c Loop over tets
      Do n = 1, nE
c ...  find map  Ortotet to Tet
         Do i=1,3
            Do j=1,3
               A(i,j) = XYP(i, IPE(j+1, n)) - XYP(i, IPE(1, n))
            End do
         End do

c ...  find map Tet to Ortotet
         Do i=1,3
            Do j=1,3
               B(i,j) = 0d0
            End do
            B(i,i) = 1d0
         End do

         Call dgesv(3, 3, A, 3, IPIV, B, 3, info)
         If (info.ne.0) Call errMes(1001,'InitializeRefinement',
     &                              'error in dgesv')

c ...  find map Tet to Equitet
         Do i=1,3
            Do j=1,3
               MapMtr(i,j,n) = 0d0
               Do k=1,3
                  MapMtr(i,j,n) = MapMtr(i,j,n) + AA(i,k)*B(k,j)
               End do
            End do
         End do

         Ref2MapMtr(n) = n
      End do

      Return
      End Subroutine initializeRefinement

C ================================================================
C This routine may be called ONLY after initializeRefinement
C ================================================================
      Subroutine uniformRefinement(
C ================================================================
     &      nP, MaxP, nF, MaxF, nE, MaxE,
     &      XYP, IPF, IPE, lbF, lbE,
     &      MapMtr, Ref2MapMtr,
     &      iW, MaxWi)
C ================================================================
C    MapMtr - data array of length 9*nEcoarse
C    Ref2MapMtr - data array (lengths on input and output are 9*nE)
C    iW(*) - working array of size MaxWi which is at least
C            nP + 14 * nE
C ================================================================
      Real*8  XYP(3, *), MapMtr(9, *)
      Integer IPE(4, *), IPF(3, *), lbF(*), lbE(*), Ref2MapMtr(*)

      Integer iW(*)

C (Local variables)
      Integer IPEs(4)
      Real*8  XYPt(3, 4), Qt, minQt(3)

      Logical flagE
      Integer refCrnr(4,4), refOct(4,4,3), loop(4)

C ================================================================
      DATA   refOct /4,5,6,1, 2,3,6,1, 1,3,5,6, 1,2,4,6,
     &               1,3,2,5, 3,6,2,5, 6,4,2,5, 4,1,2,5,
     &               1,2,3,4, 2,6,3,4, 6,5,3,4, 5,1,3,4/
      DATA   refCrnr/1,2,3,1, 1,4,5,2, 2,4,6,3, 3,5,6,4/
      DATA   loop/1, 2, 3, 1/

C ================================================================
      inEP = 1
      iIEP = inEP + nP
      iIRE = iIEP + 4 * nE
      iIPE = iIRE + 6 * nE
      iEnd = iIPE + 4 * nE

      Call listE2R(nP, nR, nE, IPE, iW(iIRE), iW(inEP), iW(iIEP))

      nPo = nP
      nFo = nF
      nEo = nE

      nP = nPo + nR
      nF = 4 * nFo
      nE = 8 * nEo

      If(nP.GT.MaxP) Call errMes(1003, 'uniformRefinement',
     &                          'local parameter MaxP is small')
      If(nF.GT.MaxF) Call errMes(1004, 'uniformRefinement',
     &                          'local parameter MaxF is small')
      If(nE.GT.MaxE) Call errMes(1006, 'uniformRefinement',
     &                          'local parameter MaxE is small')

c ... mapping P -> E
      Call backReferences(nPo, nEo, 4, 4, IPE, iW(inEP), iW(iIEP))
      k = 0
      Do n = 1, nEo
         Do i = 1, 4
            k = k + 1
            iW(iIPE + k - 1) = IPE(i, n)
         End do
      End do

c ... splitting elements
      kR = 0
      Do n = 1, nEo
         Do i1 = 1, 3
            Do i2 = i1 + 1, 4
               iP1 = IPE(i1, n)
               iP2 = IPE(i2, n)

               kR = kR + 1
               iR = iW(iIRE + kR - 1)

               Do i = 1, 3
                  XYP(i, nPo + iR) = (XYP(i, iP1) + XYP(i, iP2)) / 2
               End do
            End do
         End do

         Do i = 1, 4
            IPEs(i) = IPE(i, n)
         End do

c ... find optimal splitting of inner octahedron (ii=1,2,3)
         Do ii = 1, 3
          minQt(ii)=1d0
          Do i = 1, 4
            Do k = 1, 4
               j = nPo + iW(iIRE + 6 * n + refOct(k,i,ii) - 7)
               jj= Ref2MapMtr(n)
               if (jj.lt.0) jj = -jj
               call FixedMap(XYP(1, j), MapMtr(1, jj), XYPt(1, k))
            End do
            call calREG(XYPt(1,1),XYPt(1,2),XYPt(1,3),XYPt(1,4), Qt)
            minQt(ii) = min( Qt, minQt(ii) )
          End do
         End do
         If (minQt(1).ge.minQt(2).and.minQt(1).ge.minQt(3)) Then
             ii = 1
         Else if (minQt(2).ge.minQt(1).and.minQt(2).ge.minQt(3)) Then
             ii = 2
         Else if (minQt(3).ge.minQt(1).and.minQt(3).ge.minQt(2)) Then
             ii = 3
         End if

c ... apply optimal splitting
         Do i = 1, 4
            iE = (i + 3) * nEo + n
            Do k = 1, 4
               IPE(k, iE) = nPo + iW(iIRE + 6 * n + refOct(k,i,ii) - 7)
            End do
            lbE(iE) = lbE(n)
            Ref2MapMtr(iE) = Ref2MapMtr(n)

            iE = (4 - i) * nEo + n
            Do k = 1, 3
               IPE(k, iE) = nPo + iW(iIRE + 6 * n + refCrnr(k, i) - 7)
            End do
            IPE(4, iE) = IPEs(i)
            lbE(iE) = lbE(n)
            Ref2MapMtr(iE) = Ref2MapMtr(n)
         End do
      End do

c ... splitting faces
      Do n = 1, nFo
         iP1 = IPF(1, n)
         iP2 = IPF(2, n)
         iP3 = IPF(3, n)

         flagE = cmpE(iP1, iP2, iP3, iW(iIEP), iW(inEP), 0, iE)

         jF = 3 * nFo + n

         k = 0
         Do i1 = 1, 3
            Do 10 i2 = i1 + 1, 4
               k = k + 1
               iP1 = iW(iIPE + 4 * iE + i1 - 5)
               iP2 = iW(iIPE + 4 * iE + i2 - 5)

               Do j1 = 1, 3
                  j2 = loop(j1 + 1)

                  jP1 = IPF(j1, n)
                  jP2 = IPF(j2, n)

                  If(check22(iP1, iP2, jP1, jP2)) Then
                     IPF(j1, jF) = nPo + iW(iIRE + 6 * iE + k - 7)
                     Goto 10
                  End if
               End do
  10        Continue
         End do
         lbF(jF) = lbF(n)

         Do i1 = 1, 3
            iF = (3 - i1) * nFo + n

            i2 = loop(i1 + 1)
            i3 = loop(i2 + 1)

            IPF(1, iF) = IPF(i1, n)
            IPF(2, iF) = IPF(i1, jF)
            IPF(3, iF) = IPF(i3, jF)
            lbF(iF) = lbF(n)
         End do
      End do

      Return
      End Subroutine uniformRefinement

C ================================================================
C This routine may be called ONLY after initializeRefinement
C ================================================================
      Subroutine localRefinement(
C ================================================================
     &      nP, MaxP, nF, MaxF, nE, MaxE,
     &      XYP, IPF, IPE, lbF, lbE,
     &      MapMtr, Ref2MapMtr, SplitFlag,
     &      iW, MaxWi)
C ================================================================
C  Routine refines uniformly elements marked by SplitFlag.
C  SplitFlag=.true. is ignored in case of negative sign of Ref2MapMtr.
C  Ref2MapMtr is assigned  negative sign at an element if it was split non-uniformly.
C
C  Remarks:
C    MapMtr - data array of length 9*nEcoarse
C    Ref2MapMtr - data array (lengths on input and output are 9*nE)
C    iW(*) - working array of size MaxWi which is at least
C            nP + 14 * nE + 3*nR + 4*min(MaxF,4*nF)
C ================================================================
      Real*8  XYP(3, *), MapMtr(9, *)
      Integer IPE(4, *), IPF(3, *), lbF(*), lbE(*), Ref2MapMtr(*)
      Logical SplitFlag(*)

      Integer iW(*)

C (Local variables)
      Integer IPEs(6)
      Real*8  XYPt(3, 4), Qt, minQt(3)

      Logical flagE
      Integer refCrnr(4,4), refOct(4,4,3), loop(4),
     &        facedge(3,4), facount(4), medge(6), opposite(3)

C ================================================================

      DATA   refOct /4,5,6,1, 2,3,6,1, 1,3,5,6, 1,2,4,6,
     &               1,3,2,5, 3,6,2,5, 6,4,2,5, 4,1,2,5,
     &               1,2,3,4, 2,6,3,4, 6,5,3,4, 5,1,3,4/
      DATA   refCrnr/1,2,3,1, 1,4,5,2, 2,4,6,3, 3,5,6,4/
      DATA   loop/1, 2, 3, 1/
      DATA   facedge/1,2,4, 2,3,6, 1,3,5, 4,5,6/

C ================================================================
      iIRE = 1
      iIPE = iIRE + 6 * nE
      inEP = iIPE + 4 * nE
      iIEP = inEP + nP
      iEnd = iIEP + 4 * nE

      Call listE2R(nP, nR, nE, IPE, iW(iIRE), iW(inEP), iW(iIEP))

      ilbR   = iEnd
      iendsR = ilbR + nR
      iIPF   = iendsR + 2*nR
      iEnd   = iIPF + 4*min(MaxF,4*nF)

      If(iEnd.GT.MaxWi) Call errMes(1001, 'localRefinement',
     &                             'not enough working memory')

      nPo = nP
      nFo = nF
      nEo = nE

c ... mark new points on edges
      Do n = 1, nR
         iW(ilbR + n - 1) = 0
      End do

c ... mark mother edges
      Do n = 1, nE
         If( SplitFlag(n).and.Ref2MapMtr(n).GT.0 ) Then
            Do i = 1, 6
               iRt = iW(iIRE + 6 * (n-1) + i - 1)
               iW(ilbR + iRt - 1) = 1
            End do
         End if
      End do

c ... count mother edges
      mR = 0
      Do iRt = 1, nR
         If(iW(ilbR + iRt - 1).GT.0) Then
            nP = nP + 1
            mR = mR + 1
            iW(ilbR + iRt - 1) = mR
         End if
      End do

c ... assign father nodes to mother edges
      Do n = 1, nE
         k = 0
         Do i1 = 1, 3
            Do i2 = i1 + 1, 4
               iP1 = IPE(i1, n)
               iP2 = IPE(i2, n)

               k = k + 1
               iRt = iW(iIRE + 6 * (n-1) + k - 1)
               iRc = iW(ilbR + iRt - 1)
               If(iRc.GT.0) Then
                  iW(iendsR + (iRc - 1)*2)      = iP1
                  iW(iendsR + (iRc - 1)*2 + 1)  = iP2
               End if
            End do
         End do
      End do

c ... add more points so that each face have 0, 1, or 3 new points
      Do n = 1, nEo
         k = 0

c        count new points for faces of each tet
         Do j1 = 1, 4
            facount(j1) = 0
         End do

         Do i1 = 1, 3
            Do i2 = i1 + 1, 4  ! loop over edges
               k = k + 1
               iRt = iW(iIRE + 6 * (n-1) + k - 1)
               iRc = iW(ilbR + iRt - 1)

               If(iRc.GT.0) Then
c                 Loop over faces (j1) having k-th edge
                  Do j1 = 1, 4
                     Do j2 = 1, 3
                        If(facedge(j2,j1).eq.k) Then
                           facount(j1) = facount(j1) + 1
                        End if
                     End do
                  End do
               End if
            End do
         End do

c        Add new point to faces with 2 new points
         k = 0
         Do i1 = 1, 3
            Do i2 = i1 + 1, 4 ! loop over edges
               k = k + 1
               iRt = iW(iIRE + 6 * (n-1) + k - 1)
               iRc = iW(ilbR + iRt - 1)

               If(iRc.EQ.0) Then
c                 Loop over faces (j1) having k-th edge
                  Do j1 = 1, 4
                     Do j2 = 1, 3
                        If(facedge(j2,j1).eq.k.and.facount(j1).eq.2)Then
c                        add extra mother edges
                           nP = nP + 1
                           mR = mR + 1
                           iW(ilbR + iRt - 1) = mR
                           If (k.eq.1) Then
                               iP1 = IPE(1,n)
                               iP2 = IPE(2,n)
                           Else If (k.eq.2) Then
                               iP1 = IPE(1,n)
                               iP2 = IPE(3,n)
                           Else If (k.eq.3) Then
                               iP1 = IPE(1,n)
                               iP2 = IPE(4,n)
                           Else If (k.eq.4) Then
                               iP1 = IPE(2,n)
                               iP2 = IPE(3,n)
                           Else If (k.eq.5) Then
                               iP1 = IPE(2,n)
                               iP2 = IPE(4,n)
                           Else If (k.eq.6) Then
                               iP1 = IPE(3,n)
                               iP2 = IPE(4,n)
                           End if

                           iW(iendsR + (mR - 1)*2)     = iP1
                           iW(iendsR + (mR - 1)*2 + 1) = iP2
                           facount(j1) = 3

                           Do k1 = 1, 4
                              Do k2 = 1, 3
                                If(facedge(k2,k1).eq.k.and.k1.ne.j1)Then
                                   facount(k1) = facount(k1) + 1
                                End if
                              End do
                           End do
                           Goto 1
                        End if
                     End do
                  End do
               End if

1              Continue
            End do
         End do
      End do

c ... check for faces with 2 new points
      Do n = 1, nEo
         k = 0

c        count new points for faces of each tet
         Do j1 = 1, 4
            facount(j1) = 0
         End do

         Do i1 = 1, 3
            Do i2 = i1 + 1, 4
               k = k + 1
               iRt = iW(iIRE + 6 * (n-1) + k - 1)
               iRc = iW(ilbR + iRt - 1)

               If(iRc.GT.0) Then
c                 Loop over faces (j1) having k-th edge
                  Do j1 = 1, 4
                     Do j2 = 1, 3
                        If(facedge(j2,j1).eq.k) Then
                           facount(j1) = facount(j1) + 1
                        End if
                     End do
                  End do
               End if
            End do
         End do

         Do j1 = 1, 4
            If(facount(j1).eq.2) Call errMes(1002, 'localRefinement',
     &                          'facount=2')
c If this error happen, it implies that algorithm for removing situation
c with 2 new points at a face has to be refined!
         End do
      End do

      If(nP.GT.MaxP) Call errMes(1003, 'localRefinement',
     &                          'local parameter MaxP is small')

c ... create new points, the point number is nPo plus the edge number
      Do iRt = 1, nR
         iRc = iW(ilbR + iRt - 1)
         If(iRc.GT.0) Then
            iPt = nPo + iRc
            iP1 = iW(iendsR + (iRc - 1)*2)
            iP2 = iW(iendsR + (iRc - 1)*2 + 1)
            Do i = 1, 3
               XYP(i, iPt) = (XYP(i, iP1) + XYP(i, iP2)) / 2
            End do
         End if
      End do

c ... mapping P -> E
      Call backReferences(nPo, nEo, 4, 4, IPE, iW(inEP), iW(iIEP))
      k = 0
      Do n = 1, nEo
         Do i = 1, 4
            k = k + 1
            iW(iIPE + k - 1) = IPE(i, n)
         End do
      End do

c ... splitting elements
      Do n = 1, nEo
c        count new points
         newP = 0
         Do i = 1, 6
            iRt = iW(iIRE + 6 * (n-1) + i - 1)
            iRc = iW(ilbR + iRt - 1)
            If (iRc.GT.0) Then
                newP = newP + 1
                medge(newP) = iRc ! index of mother edge
            End if
         End do

         Do i = 1, 4
            IPEs(i) = IPE(i, n)
         End do
         IPEs(5) = lbE(n)
         IPEs(6) = Ref2MapMtr(n)

         If(newP.EQ.1) Then
c           tet is split into 2 tets,n and nE+1. iP1,iP2 are endpoints of mother edge
            nE = nE + 1
            If(nE.GT.MaxE) Call errMes(1006, 'localRefinement',
     &                                'local parameter MaxE is small')
            Do k = 1, 4
               IPE(k, nE) = IPEs(k)
            End do

            lbE(n)  = IPEs(5)
            lbE(nE) = IPEs(5)
            Ref2MapMtr(n)  = -iabs( IPEs(6) )
            Ref2MapMtr(nE) = -iabs( IPEs(6) )
            iP1 = iW(iendsR + (medge(1) - 1)*2)
            iP2 = iW(iendsR + (medge(1) - 1)*2+1)

            Do i = 1, 4
               If (iP2.eq.IPE(i, nE)) IPE(i, nE) = nPo + medge(1)
               If (iP1.eq.IPE(i, n )) IPE(i, n ) = nPo + medge(1)
            End do

         Else If(newP.EQ.2) Then
c           tet is split into 4 tets, n, nE+1,nE+2,nE+3.
            nE = nE + 3
            If(nE.GT.MaxE) Call errMes(1006, 'localRefinement',
     &                                'local parameter MaxE is small')
            Do k = 1, 4
               IPE(k, nE-2) = IPEs(k)
               IPE(k, nE-1) = IPEs(k)
               IPE(k, nE  ) = IPEs(k)
            End do
            lbE(n)    = IPEs(5)
            lbE(nE-2) = IPEs(5)
            lbE(nE-1) = IPEs(5)
            lbE(nE  ) = IPEs(5)
            Ref2MapMtr(n)    = -iabs( IPEs(6) )
            Ref2MapMtr(nE-2) = -iabs( IPEs(6) )
            Ref2MapMtr(nE-1) = -iabs( IPEs(6) )
            Ref2MapMtr(nE  ) = -iabs( IPEs(6) )
c           iP1,iP2,IP3,iP4 are endpoints of mother edge
            iP1 = iW(iendsR + (medge(1) - 1)*2)
            iP2 = iW(iendsR + (medge(1) - 1)*2+1)
            iP3 = iW(iendsR + (medge(2) - 1)*2)
            iP4 = iW(iendsR + (medge(2) - 1)*2+1)

            Do i = 1, 4
               If (iP2.eq.IPE(i, n ))   IPE(i, n   ) = nPo + medge(1)
               If (iP4.eq.IPE(i, n ))   IPE(i, n   ) = nPo + medge(2)
               If (iP2.eq.IPE(i, nE-2)) IPE(i, nE-2) = nPo + medge(1)
               If (iP3.eq.IPE(i, nE-2)) IPE(i, nE-2) = nPo + medge(2)
               If (iP1.eq.IPE(i, nE-1)) IPE(i, nE-1) = nPo + medge(1)
               If (iP4.eq.IPE(i, nE-1)) IPE(i, nE-1) = nPo + medge(2)
               If (iP1.eq.IPE(i, nE  )) IPE(i, nE  ) = nPo + medge(1)
               If (iP3.eq.IPE(i, nE  )) IPE(i, nE  ) = nPo + medge(2)
            End do

         Else If(newP.EQ.3) Then
c           tet is split into 4 tets, n, nE+1,nE+2,nE+3.
            nE = nE + 3
            If(nE.GT.MaxE) Call errMes(1006, 'localRefinement',
     &                                'local parameter MaxE is small')
            Do i = 1, 3
               iP1 = iW(iendsR + (medge(i)-1)*2)
               iP2 = iW(iendsR + (medge(i)-1)*2+1)
               Do k = 1, 4
                  If(iP1.eq.IPEs(k).or.iP2.eq.IPEs(k)) IPEs(k)=0
               End do
               jP1 = iW(iendsR + (medge(loop(i+1))-1)*2)
               jP2 = iW(iendsR + (medge(loop(i+1))-1)*2+1)
               If (iP1.eq.jP1.or.iP1.eq.jP2) opposite(i) = iP1
               If (iP2.eq.jP1.or.iP2.eq.jP2) opposite(i) = iP2
            End do

            Do k = 1, 4
               If (IPEs(k).ne.0) iP0 = IPEs(k)
            End do

            IPE(1, n) = iP0
            IPE(2, n) = nPo + medge(1)
            IPE(3, n) = nPo + medge(2)
            IPE(4, n) = nPo + medge(3)
            lbE(n)    = IPEs(5)
            Ref2MapMtr(n) = -iabs( IPEs(6) )
            Do k = 1, 3
               IPE(1, nE-k+1) = iP0
               IPE(2, nE-k+1) = nPo + medge(k)
               IPE(3, nE-k+1) = nPo + medge(loop(k+1))
               IPE(4, nE-k+1) = opposite(k)
               lbE(nE-k+1) = IPEs(5)
               Ref2MapMtr(nE-k+1)    = -iabs( IPEs(6) )
            End do

         Else If(newP.EQ.4) Then
              Call errMes(1004, 'localRefinement',
     &                          'four new points in tet')
         Else If(newP.EQ.5) Then
              Call errMes(1005, 'localRefinement',
     &                          'five new points in tet')
         Else If(newP.EQ.6) Then
c ... find optimal splitting of inner octahedron (ii=1,2,3)
            Do ii = 1, 3
             minQt(ii)=1d0
             Do i = 1, 4
               Do k = 1, 4
                  iRt = iW(iIRE + 6 * n + refOct(k,i,ii) - 7)
                  iRc = iW(ilbR + iRt - 1)
                  j = nPo + iRc
                  jj= Ref2MapMtr(n)
                  if (jj.lt.0) jj = -jj
                  call FixedMap(XYP(1, j), MapMtr(1, jj), XYPt(1, k))
               End do
               call calREG(XYPt(1,1),XYPt(1,2),XYPt(1,3),XYPt(1,4), Qt)
               minQt(ii) = min( Qt, minQt(ii) )
             End do
            End do
            If (minQt(1).ge.minQt(2).and.minQt(1).ge.minQt(3)) Then
                ii = 1
            Else if (minQt(2).ge.minQt(1).and.minQt(2).ge.minQt(3)) Then
                ii = 2
            Else if (minQt(3).ge.minQt(1).and.minQt(3).ge.minQt(2)) Then
                ii = 3
            End if
c ... apply optimal splitting
            Do i = 1, 4
               nE = nE + 1
c  ...  interior tet
               If(nE.GT.MaxE) Call errMes(1006, 'localRefinement',
     &                                'local parameter MaxE is small')
               Do k = 1, 4
                  iRt = iW(iIRE + 6 * n + refOct(k,i,ii) - 7)
                  iRc = iW(ilbR + iRt - 1)
                  IPE(k, nE) = nPo + iRc
               End do
               lbE(nE) = IPEs(5)
               Ref2MapMtr(nE) = IPEs(6)

c  ...  vertex-based tet (i<4) or original tet (i=4)
               If(i.EQ.4) Then
                  iE = n
               Else
                  nE = nE + 1
                  If(nE.GT.MaxE) Call errMes(1006, 'localRefinement',
     &                                'local parameter MaxE is small')
                  iE = nE
               End if

               Do k = 1, 3
                  iRt = iW(iIRE + 6 * n + refCrnr(k, i) - 7)
                  iRc = iW(ilbR + iRt - 1)
                  IPE(k, iE) = nPo + iRc
               End do
               IPE(4, iE) = IPEs(i)
               lbE(iE) = IPEs(5)
               Ref2MapMtr(iE) = IPEs(6)
            End do
         End if
      End do

c ... splitting faces
      nF = 0
      Do n = 1, nFo
         iP1 = IPF(1, n)
         iP2 = IPF(2, n)
         iP3 = IPF(3, n)

         flagE = cmpE(iP1, iP2, iP3, iW(iIEP), iW(inEP), 0, iE)

c        count new points at face and fill medge
         newP = 0
         Do i = 1, 6
            iRt = iW(iIRE + 6 * (iE-1) + i - 1)
            iRc = iW(ilbR + iRt - 1)
            If (iRc.GT.0) Then
                jP1 = iW(iendsR + (iRc-1)*2)
                jP2 = iW(iendsR + (iRc-1)*2+1)
                If (check13(jP1,iP1,iP2,iP3).and.
     &              check13(jP2,iP1,iP2,iP3)) Then
                    newP = newP + 1
                    medge(newP) = iRc
                End if
            End if
         End do

         If(newP.EQ.0) Then
            nF = nF + 1
            If(nF.GT.MaxF) Call errMes(1007, 'localRefinement',
     &                                'local parameter MaxF is small')
            iW(iIPF + (nF-1)*4  ) = iP1
            iW(iIPF + (nF-1)*4+1) = iP2
            iW(iIPF + (nF-1)*4+2) = iP3
            iW(iIPF + (nF-1)*4+3) = lbF(n)

         Else If(newP.EQ.1) Then
            nF = nF + 2
            If(nF.GT.MaxF) Call errMes(1007, 'localRefinement',
     &                                'local parameter MaxF is small')
            jP1 = iW(iendsR + (medge(1)-1)*2)
            jP2 = iW(iendsR + (medge(1)-1)*2+1)
            If(check22(iP1, iP2, jP1, jP2)) Then
               iPa = iP3
               iPb = iP1
               iPc = iP2
            End if
            If(check22(iP1, iP3, jP1, jP2)) Then
               iPa = iP2
               iPb = iP1
               iPc = iP3
            End if
            If(check22(iP2, iP3, jP1, jP2)) Then
               iPa = iP1
               iPb = iP2
               iPc = iP3
            End if
            iW(iIPF + (nF-2)*4  ) = iPa
            iW(iIPF + (nF-2)*4+1) = iPb
            iW(iIPF + (nF-2)*4+2) = nPo + medge(1)
            iW(iIPF + (nF-2)*4+3) = lbF(n)
            iW(iIPF + (nF-1)*4  ) = iPa
            iW(iIPF + (nF-1)*4+1) = iPc
            iW(iIPF + (nF-1)*4+2) = nPo + medge(1)
            iW(iIPF + (nF-1)*4+3) = lbF(n)

         Else If(newP.EQ.3) Then
c ... define opposite
            Do i = 1, 3
               iP1 = iW(iendsR + (medge(i)-1)*2)
               iP2 = iW(iendsR + (medge(i)-1)*2+1)
               jP1 = iW(iendsR + (medge(loop(i+1))-1)*2)
               jP2 = iW(iendsR + (medge(loop(i+1))-1)*2+1)
               If (iP1.eq.jP1.or.iP1.eq.jP2) opposite(i) = iP1
               If (iP2.eq.jP1.or.iP2.eq.jP2) opposite(i) = iP2
            End do
c ...
            nF = nF + 4
            If(nF.GT.MaxF) Call errMes(1007, 'localRefinement',
     &                                'local parameter MaxF is small')
c           interior triangle
            iPa = nPo + medge(1)
            iPb = nPo + medge(2)
            iPc = nPo + medge(3)
            iW(iIPF + (nF-4)*4  ) = iPa
            iW(iIPF + (nF-4)*4+1) = iPb
            iW(iIPF + (nF-4)*4+2) = iPc
            iW(iIPF + (nF-4)*4+3) = lbF(n)
            Do k = 1, 3 ! corner triangles
               iW(iIPF + (nF-k)*4  ) = opposite(k)
               iW(iIPF + (nF-k)*4+1) = nPo + medge(k)
               iW(iIPF + (nF-k)*4+2) = nPo + medge(loop(k+1))
               iW(iIPF + (nF-k)*4+3) = lbF(n)
            End do
         Else
            Call errMes(1008, 'localRefinement',
     &                  'newP for face  is wrong')
         End if
      End do

      Do n = 1, nF
         IPF(1,n) = iW(iIPF + (n-1)*4  )
         IPF(2,n) = iW(iIPF + (n-1)*4+1)
         IPF(3,n) = iW(iIPF + (n-1)*4+2)
         lbF(  n) = iW(iIPF + (n-1)*4+3)
      End do

      Return
      End Subroutine localRefinement

C ================================================================
      Subroutine calREG(xy1, xy2, xy3, xy4, qE)
C ================================================================
C Computing regularity quality of tetrahedron {xy1, ..., xy4}
C ================================================================
      Real*8 xy1(3), xy2(3), xy3(3), xy4(3)
      Real*8 qE

C group (Local variables)
      Real*8 Pk, Vk, volume
      Real*8 x1, y1, z1

C ================================================================
      Pk = 0D0
      Do n = 1, 6
         If(n.EQ.1) Then
            x1 = xy1(1) - xy4(1)
            y1 = xy1(2) - xy4(2)
            z1 = xy1(3) - xy4(3)
         Else If(n.EQ.2) Then
            x1 = xy2(1) - xy4(1)
            y1 = xy2(2) - xy4(2)
            z1 = xy2(3) - xy4(3)
         Else If(n.EQ.3) Then
            x1 = xy3(1) - xy4(1)
            y1 = xy3(2) - xy4(2)
            z1 = xy3(3) - xy4(3)
         Else If(n.EQ.4) Then
            x1 = xy1(1) - xy3(1)
            y1 = xy1(2) - xy3(2)
            z1 = xy1(3) - xy3(3)
         Else If(n.EQ.5) Then
            x1 = xy2(1) - xy3(1)
            y1 = xy2(2) - xy3(2)
            z1 = xy2(3) - xy3(3)
         Else If(n.EQ.6) Then
            x1 = xy1(1) - xy2(1)
            y1 = xy1(2) - xy2(2)
            z1 = xy1(3) - xy2(3)
         End if
         Pk = Pk + dsqrt(x1 * x1 +  y1 * y1 + z1 * z1)
      End do

      volume = calVol(xy1, xy2, xy3, xy4)
      Vk = dabs(volume)

      qE = 1832.8208D0 * Vk / (Pk ** 3)

      Return
      End Subroutine calREG

      Subroutine FixedMap(XYP, MapMatrix, XYPt)
      Implicit none
      Real*8   XYP(3), MapMatrix(3,3), XYPt(3)

      Integer i,j

      do i=1,3
       XYPt(i) = 0d0
       do j=1,3
          XYPt(i) = XYPt(i) + MapMatrix(i,j)*XYP(j)
       end do
      end do

      return
      end Subroutine FixedMap
C
      End Module mba3d_refine


subroutine total_energy_TD
  use global_variables
  implicit none
  complex(8) :: zCt(NK*NB)
  integer :: icell, icell2, aion, bion, ik
  real(8) :: la_full,x

  la_full = lattice_a*dble(NK)

  E_elec = 0d0
  do ik = 1,NK
    zCt = matmul(zH_mat(:,:),zpsi_Ct(:,ik))
    E_elec = E_elec + 2d0*sum(conjg(zpsi_Ct(:,ik))*zCt(:))
  end do

  E_ii = 0d0
  do icell = 1,NK; do aion=1,Nion
    do icell2 = 1,NK; do bion=1,Nion
      if(icell2 == icell .and. aion == bion)cycle
      x = Rion(aion) + dble(icell-1)*lattice_a &
        - (Rion(bion) + dble(icell2-1)*lattice_a) &
        + Uion(icell,aion) - Uion(icell2,bion)

      E_ii = E_ii + Zion(aion)*Zion(bion)*( &
        int_pot_ii(x) + int_pot_ii(x + la_full) + int_pot_ii(x - la_full) )
    end do; end do
  end do; end do
  E_ii = 0.5d0*E_ii

  Ekin_ion=0d0
  Vion = 0.5d0*(Uion_new-Uion_old)/dt
  do aion = 1,Nion
    do icell = 1,NK
      Ekin_ion = Ekin_ion + 0.5d0*Mion(aion)*Vion(icell,aion)**2
    end do
  end do

  E_tot = E_elec + E_ii + Ekin_ion

  return
end subroutine total_energy_TD


      SUBROUTINE ARGCH2(KEY,RA,DEC,IH,AM,ISGN,ID,AMIN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*1 ISGN,IMINUS,IPLUS
      DATA IPLUS,IMINUS /'+','-'/
      DATA RAD/0.0174532925199D0/
C****
C**** KEY .NE. -1 ---- HOURS AND DEGREES TO RADIANS
C**** KEY .EQ. -1 ---- RADIANS TO HOURS AND DEGREES
C****
      IF(KEY.EQ.-1) GO TO 10
      H=IH
      D=ID
      RA=15.D0*(H+AM/6.D1)* RAD
      DEC=(D+AMIN/6.D1)*RAD
      IF(ISGN.EQ.'-') DEC=-DEC
      RETURN
   10 HOURS=RA/RAD/15.D0
      HOURS=DMOD(HOURS,24.D0)
      IH=HOURS
      AM=(HOURS-IH)*6.D1
      AM=AM+1.D-6
      IF(AM.LT.6.D1) GO TO 12
      AM=AM-6.D1
      IH=IH+1
   12 IF(IH.GE.24) IH=IH-24
      IF(DEC) 15,20,20
   15 ISGN=IMINUS
      GO TO 25
   20 ISGN=IPLUS
   25 DEG=DABS(DEC)/RAD
      ID=DEG
      AMIN=(DEG-ID)*6.D1
      RETURN
      END


      SUBROUTINE QUIKVIS5Z(RAAN,SUNPOS,RATARG,DELTIM)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE QUIKVIS PROGRAM. IT COMPUTES THE TIME
C SINCE PERIGEE THAT THE S/C TAKES TO REACH THE POINT IN ITS ORBIT WHEN
C AN EVENT OCCURS AS SPECIFIED BY THE 'KRELTIME' PARAMETER RETRIEVED
C FROM QUIKVIS999.
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C RAAN      1   R*8  I  ORBIT'S RIGHT ASCENSION OF ASCENDING NODE.
C                       IN RADIANS. OTHER ORBITAL ELEMENTS ARS SET VIA
C                       THE RETRIEVAL CALL TO QUIKVIS999.
C
C SUNPOS    3   R*8  I  SUN POSITION AT THE TIME TO WHICH ELEMS IS
C                       REFERENCED.  IN KM.
C
C                       USED FOR KRELTIME=  1, 2. NOT USED OTHERWISE.
C
C RATARG    1   R*8  I  TARGET MERIDIAN. USED FOR KRELTIME= 6. NOT USED
C                       OTHERWISE.
C
C DELTIM    1   R*8  O  POSITIVE DIFFERENCE BETWEEN THE TIME TO WHICH
C                       ELEMS IS REFERENCED AND THE TIME THAT THE EVENT
C                       SPECIFIED BY 'KRELTIME' OCCURS.
C
C***********************************************************************
C
C BY C PETRUZZO/GFSC/742.   2/86.
C       MODIFIED....
C
C***********************************************************************
C
      INCLUDE 'QUIKVIS.INC'
C
      REAL*8 PLANE2(2),SUNPOS(3),ELEMS(6)
C
      IERR = 0
      IF(ERTHMU.EQ.0.D0) ERTHMU = CONST(56)
C
C
C ****************
C *  INITIALIZE  *
C ****************
C
      ELEMS(1) = SMA
      ELEMS(2) = ECC
      ELEMS(3) = ORBINCL
      ELEMS(4) = RAAN    ! FROM ARGUMENT LIST
      ELEMS(5) = ARGP
      ELEMS(6) = 0.D0
C
C    REMINDER: KRELTIME SPECIFIES THE EVENT INVOLVED.
C      =1, S/C ENTERS ORBIT NIGHT
C      =2, S/C ENTERS ORBIT DAY
C      =3, S/C CROSSES THE SUN MERIDIAN
C      =4, S/C CROSSES THE ASCENDING NODE
C      =5, S/C CROSSES THE DESCENDING NODE
C      =6, S/C CROSSES THE TARGET MERIDIAN
C      =7, S/C CROSSES INERTIAL ZERO RIGHT ASCENSION
C
C
C **********************************
C * PASS THROUGH SUNRISE OR SUNSET *
C **********************************
C
      IF(KRELTIME.EQ.1 .OR.   ! SUNSET
     *   KRELTIME.EQ.2)       ! SUNRISE
     *           THEN
        KUMB = 1   ! SHADTA COMPUTES UMBRA ENTRY AND EXIT TRUE ANOMALIES
        CALL SHADTA(ELEMS,SUNPOS,KUMB,-1,UMBIN,UMBOUT,DUM,DUM,
     *          LUERR,IERR)
        IF(IERR.NE.0) THEN
C        FORCE A LOOK AT WHY ERROR OCCURRED. SHOULD NEVER HAPPEN.
          STOP 'QUIKVIS5X. ERROR STOP 2. SEE CODE.'
          END IF
        IF(KUMB.EQ.2) THEN   ! ORBIT NIGHT PASSAGE OCCURS.
          IF(KRELTIME.EQ.1) THEN
            XTA = EQVANG(UMBIN)
          ELSE
            XTA = EQVANG(UMBOUT)
            END IF
        ELSE                 ! NO ORBIT NIGHT PASSAGE. REFER TO ASC NODE
          XTA = -ARGP
          END IF
        IF(ECC.GT.ECCMIN) THEN
          XMA = ANOMLY(-1,XTA,ECC,LUERR,IERR)
        ELSE
          XMA = XTA
          END IF
        DELTIM = XMA/TWOPI * PERIOD
        GO TO 9999
        END IF
C
C
C **********************************************************************
C * CROSS SUN OR TARGET MERIDIAN, OR PASS ASCENDING OR DESCENDING NODE *
C **********************************************************************
C
      IF( KRELTIME.EQ.3 .OR.   ! SUN MERIDIAN
     *    KRELTIME.EQ.4 .OR.   ! ASCENDING NODE
     *    KRELTIME.EQ.5 .OR.   ! DESCENDING NODE
     *    KRELTIME.EQ.6 .OR.   ! TARGET MERIDIAN
     *    KRELTIME.EQ.7)       ! ZERO RIGHT ASCENSION
     *            THEN
C
C      CALL XPLANE TO SEE WHEN THE S/C CROSSES THE MERIDIAN OR
C      EQUATORIAL PLANE.
C
        IF( KRELTIME.EQ.3 .OR. KRELTIME.EQ.6 .OR. KRELTIME.EQ.7 ) THEN
          PLANE2(1) = HALFPI
          IF(KRELTIME.EQ.3) THEN
            CALL XYZSPH(-1,RASUN,DECSUN,DUM,SUNPOS,1.D0)
            PLANE2(2) = RASUN
          ELSE IF(KRELTIME.EQ.6) THEN
            PLANE2(2) = RATARG
          ELSE
            PLANE2(2) = 0.D0
            END IF
          ICROSS = 2
          IF(ELEMS(2).GT.HALFPI) ICROSS = 3
          END IF
C
        IF( KRELTIME.EQ.4 .OR. KRELTIME.EQ.5 ) THEN
          PLANE2(1) = 0.D0
          PLANE2(2) = 0.D0
          IF(KRELTIME.EQ.4) THEN
            ICROSS = 3
          ELSE
            ICROSS = 2
            END IF
          END IF
C
        CALL XPLANE(ERTHMU,ELEMS,0,PLANE2,ICROSS,KCROSS,DT,
     *          LUERR,IERR)
C      ERROR SHOULD NEVER OCCUR.  STOP TO FORCE A LOOK AT WHY.
        IF(IERR.NE.0) STOP 'QUIKVIS5Z. ERROR. STOP 1. SEE CODE.'
C
        IF(IBUG.NE.0) WRITE(LUBUG,1002)
     *     PLANE2(1)*DEGRAD,PLANE2(2)*DEGRAD,ICROSS,
     *     DT/60.D0,KCROSS
 1002   FORMAT(' QUIKVIS5Z DEBUG 1002. PLANE2=',2F8.2,'  ICROSS=',I2/,
     *         '   DT(MIN)=',G13.5,'  KCROSS=',I2)
C
        DELTIM = DT
        GO TO 9999
        END IF
C
C
 9999 CONTINUE
      RETURN
C
C***********************************************************************
C
C
C**** INITIALIZATION CALL. PUT GLOBAL PARAMETER VALUES INTO THIS
C     ROUTINE'S LOCAL VARIABLES.
C
      ENTRY QVINIT5Z
C
      CALL QUIKVIS999(-1,R8DATA,I4DATA,L4DATA)
      RETURN
C
C***********************************************************************
C
      END


! { dg-do run }
!
! PR 41139: [4.5 Regression] a procedure pointer call as actual argument
!
! Original test case by Barron Bichon <barron.bichon@swri.org>
! Modified by Janus Weil <janus@gcc.gnu.org>

PROGRAM test

 PROCEDURE(add), POINTER :: f
 logical :: g

 ! Passing the function works
 g=greater(4.,add(1.,2.))
 if (.not. g) STOP 1

 ! Passing the procedure pointer fails
 f => add
 g=greater(4.,f(1.,2.))
 if (.not. g) STOP 2

CONTAINS

 REAL FUNCTION add(x,y)
   REAL, INTENT(in) :: x,y
   print *,"add:",x,y
   add = x+y
 END FUNCTION add

 LOGICAL FUNCTION greater(x,y)
   REAL, INTENT(in) :: x, y
   greater = (x > y)
 END FUNCTION greater

END PROGRAM test


! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

module work

integer :: P(1000)
real    :: A(1000)

contains
function do_work(arr) result(pri)
  implicit none
  real, dimension(*) :: arr

  real :: pri
  integer :: i, j

  !$omp simd private(j) lastprivate(pri)
  do i = 1, 999
    j = P(i)

    pri = 0.5
    if (mod(j-1, 2) == 0) then
      pri = A(j+1) + arr(i)
    endif
    A(j) = pri * 1.5
    pri = pri + A(j)
  end do

end function do_work

end module work

program simd_8f
  use work
  implicit none
  real :: pri, arr(1000), diff
  integer :: i
  real, parameter :: EPS = 0.005

  do i = 1, 1000
     P(i)   = i
     A(i)   = (i-1) * 1.5
     arr(i) = (i-1) * 1.8
  end do
  pri = do_work(arr)

  diff = pri - 8237.25

  if (diff > EPS .or. -diff > EPS) call abort

end program


!######################################################################
!# MODULE: subprograms
!#
!# AUTHORS:
!#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca>,
!#         Waleed Almutiry <wkmtierie@qu.edu.sa>, and
!#         Rob Deardon <robert.deardon@ucalgary.ca>
!#
!# DESCRIPTION:
!#
!#     Simulates epidemics under spatial and network models with two
!#     disease types: SI and SIR
!#
!# Algorithm based on:
!#
!#     Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
!#     M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).
!#     Inference for individual level models of infectious diseases in large
!#     populations. Statistica Sinica, 20, 239-261.
!#
!#     This program is free software; you can redistribute it and/or
!#     modify it under the terms of the GNU General Public License,
!#     version 2, as published by the Free Software Foundation.
!#
!#     This program is distributed in the hope that it will be useful,
!#     but without any warranty; without even the implied warranty of
!#     merchantability or fitness for a particular purpose. See the GNU
!#     General Public License, version 2, for more details.
!#
!#     A copy of the GNU General Public License, version 2, is available
!#     at http://www.r-project.org/Licenses/GPL-2
!#
!# Part of the R/EpiILM package
!# Contains:
!#            dataxy     .................. subroutine
!#            dataxysir  .................. subroutine
!#            datacon    .................. subroutine
!#            dataconsir .................. subroutine
!######################################################################

    module subprograms
    use, intrinsic :: iso_c_binding
    implicit none
    public :: dataxy, dataxysir, datacon, dataconsir

    contains

!######################################################################

    subroutine dataxy (x, y, n, tmin, tmax, ns, nt, ni, alpha, phi, beta, spark, &
                       & covmatsus, covmattrans, tau) bind(C, name="dataxy_")
    !Epidemic simulation under purely spatial model: SI

    external seedin
    external seedout
    external randomnumber

    integer (C_INT), intent(in)    :: n, tmax, ns, nt, ni, tmin
    real (C_DOUBLE), intent(in)    :: alpha(ns), phi(nt), beta(ni), spark !parameters
    real (C_DOUBLE), intent(in)    :: covmatsus(n,ns), covmattrans(n,nt)               !covariates
    real (C_DOUBLE), intent(in)    :: x(n), y(n)                 !locations
    integer (C_INT), intent(inout) :: tau(n)                     !infection times

    integer (C_INT) :: i, j, t, A
    real (C_DOUBLE) :: u, dx, p
    real (C_DOUBLE) :: Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    if ( ALL( tau == 0 ) )then
    call randomnumber(u)
    A = int(u * n) + 1  !Initialize infectious state
    tau(A) = tmin
    end if

    !Calculate the distance matrix
!    do i = 1, n
!        do j = i, n
!            eu(i,j) = sqrt(((x(i)-x(j))**2)+((y(i)-y(j))**2))
!            eu(j,i) = eu(i,j)
!        end do
!    end do

    Somega = matmul(covmatsus, alpha) !susceptibility function
    Tomega = matmul(covmattrans, phi) !transmissibility function

    !Calculate the probabilities of susceptible being exposed and update tau
    do t = tmin, (tmax - 1)
        do i = 1, n
            if (tau(i)==0) then
              dx = 0.0_c_double
              do j = 1,n
                if ((tau(j) .NE. 0) .and. (tau(j) .LE. t)) then
                  dx = dx + ((sqrt(((x(i)-x(j))**2)+((y(i)-y(j))**2))**(-beta(ni)))*Tomega(j))
                end if
              end do
            p = 1.0_c_double - exp(-((Somega(i) * dx) + spark))
            call randomnumber(u)
            if (p .GT. u) then
              tau(i) = t + 1 !time at which individuals become infected
            end if
            end if
        end do
    end do

    call seedout()
    end subroutine dataxy

!######################################################################

    subroutine dataxysir (n, tmin, tmax, ns, nt, ni, alpha, phi, beta, spark, covmatsus, covmattrans, &
                    & lambda, x, y, tau, remt) bind(C, name="dataxysir_")
    !Epidemic simulation under purely spatial model: SIR

    external seedin
    external seedout
    external randomnumber

    integer (C_INT), intent(in)     :: n, tmax, ns, nt, ni, tmin
    integer (C_INT), intent(inout)  :: lambda(n)                  !infperiod
    real (C_DOUBLE), intent(in)     :: alpha(ns), phi(nt), beta(ni), spark !parameters
    real (C_DOUBLE), intent(in)     :: covmatsus(n,ns), covmattrans(n,nt)               !covariates
    real (C_DOUBLE), intent(in)     :: x(n), y(n)                 !locations
    integer (C_INT), intent(inout)  :: remt(n), tau(n)            !removal time and inftime

    integer (C_INT)          :: i, j, t, A
    real (C_DOUBLE) :: u, dx, p
    real (C_DOUBLE) :: Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    if ( ALL( tau .EQ. 0 ) )then
        call randomnumber(u)
        A = int(u * n) + 1  !Initialize infectious state
        tau(A) = tmin
        remt(A) = tau(A) + lambda(A)
    else
        do i = 1, n
            if (tau(i) .NE. 0) then
                remt(i) = tau(i) + lambda(i)
            else
                 remt(i) = tau(i)
            end if
        end do
   end if

    !Calculate the distance matrix
!    do i = 1, n
!        do j = i, n
!            eu(i,j) = sqrt(((x(i)-x(j))**2)+((y(i)-y(j))**2))
!            eu(j,i) = eu(i,j)
!        end do
!    end do

    Somega = matmul(covmatsus, alpha) !susceptibility function
    Tomega = matmul(covmattrans, phi) !transmissibility function

    !Calculate the probabilities of susceptible being exposed and update tau
    do t = tmin, (tmax - 1)
        do i = 1, n
            if (tau(i)==0) then
              dx = 0.0_c_double
              do j = 1, n
                if ((tau(j) .NE. 0) ) then
                  if ((tau(j) .LE. t) .and. ((tau(j)+lambda(j)) .GT. t)) then
                    dx = dx + ((sqrt(((x(i)-x(j))**2)+((y(i)-y(j))**2))**(-beta(ni)))*Tomega(j))
                  end if
                end if
              end do
            p = 1.0_c_double - exp(-((Somega(i) * dx) + spark))
            call randomnumber(u)
            if (p .GT. u) then
              tau(i) = t + 1  !time at which individuals become infected
              remt(i) = t + 1 + lambda(i)  !time at which individual is removed
            end if
            end if
        end do
    end do

    call seedout()
    end subroutine dataxysir

!######################################################################

    subroutine datacon(n, tmin, tmax, ns, nt, ni, alpha, phi, beta, &
                & spark, covmatsus, covmattrans, network, tau) bind(C, name="datacon_")
    !Epidemic simulation under contact network model: SI

    external seedin
    external seedout
    external randomnumber

    integer (C_INT), intent(in)    :: n, ns, nt, ni, tmax, tmin
    real (C_DOUBLE), intent(in)    :: alpha(ns), phi(nt), beta(ni), spark    !parameters
    real (C_DOUBLE), intent(in)    :: network(n,n,ni), covmatsus(n,ns), covmattrans(n,nt) !network and covariates
    integer (C_INT), intent(inout) :: tau(n)                        !inftime

    integer (C_INT) :: i, j, t, k, A
    real (C_DOUBLE) :: u, dx, p, Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    if ( ALL( tau == 0 ) )then
        call randomnumber(u)
        A = int(u * n) + 1  !Initialize infectious state
        tau(A) = tmin
    end if

    Somega = matmul(covmatsus, alpha) !susceptibility function
    Tomega = matmul(covmattrans, phi) !transmissibility function

    !Calculate the probabilities of susceptible being exposed and update tau
    do t = tmin, (tmax - 1)
        do i = 1, n
            if (tau(i)==0) then
              dx = 0.0_c_double
              do j = 1, n
                if ((tau(j) .NE. 0) .and. (tau(j) .LE. t)) then
                  do k = 1, ni
                    dx = dx + ((beta(k) * network(i,j,k))*Tomega(j))
                  end do
                end if
              end do
            p = 1.0_c_double - exp(-((Somega(i) * dx) + spark))
            call randomnumber(u)
            if (p .GT. u) then
              tau(i) = t + 1  !time at which individuals become infected
            end if
            end if
        end do
    end do

    call seedout()
    end subroutine datacon

!######################################################################

    subroutine dataconsir(n, tmin, tmax, ns, nt, ni, lambda, alpha, phi, beta, &
                & spark, covmatsus, covmattrans, network, tau, remt) bind(C, name="dataconsir_")
    !Epidemic simulation under contact network model: SIR

    external seedin
    external seedout
    external randomnumber

    integer (C_INT), intent(in)     :: n, tmax, ns, nt, ni, tmin
    integer (C_INT), intent(in)     :: lambda(n)                     !infectious period
    real (C_DOUBLE), intent(in)     :: alpha(ns), phi(nt), beta(ni), spark    !parameters
    real (C_DOUBLE), intent(in)     :: network(n,n,ni), covmatsus(n,ns), covmattrans(n,nt) !network and covariates
    integer (C_INT), intent(inout)  :: tau(n)                        !infection times
    integer (C_INT), intent(inout)  :: remt(n)                       !removal time

    integer (C_INT) :: i, j, t, k, A
    real (C_DOUBLE) :: u, dx, p, Somega(n), Tomega(n)

    !initialzing random seed
    call seedin()

    if ( ALL( tau .EQ. 0 ) )then
        call randomnumber(u)
        A = int(u * n) + 1  !Initialize infectious state
        tau(A) = tmin
        remt(A) = tau(A) + lambda(A)
    else
        do i = 1, n
            if (tau(i) .NE. 0) then
                remt(i) = tau(i) + lambda(i)
            else
                remt(i) = tau(i)
            end if
        end do
    end if

    Somega= matmul(covmatsus,alpha) !susceptibility function
    Tomega= matmul(covmattrans,phi) !transmissibility function

    !Calculate the probabilities of susceptible being exposed and update tau
    do t = tmin, (tmax - 1)
        do i = 1, n
            if (tau(i)==0) then
              dx = 0.0_c_double
              do j = 1, n
                if (tau(j) .NE. 0)  then
                  if ((tau(j) .LE. t).and. ((tau(j) + lambda(j)) .GT. t))then
                    do k = 1, ni
                      dx = dx +(( beta(k) * network(i,j,k))*Tomega(j))
                    end do
                  end if
                end if
              end do
            p = 1.0_c_double - exp(-((Somega(i) * dx) + spark))
            call randomnumber(u)
            if (p .GT. u) then
              tau(i) = t + 1 !time at which individuals become infected
              remt(i) = t + 1 + lambda(i) !time at which individual is removed
            end if
            end if
        end do
    end do

    call seedout()
    end subroutine dataconsir

    end module subprograms


      subroutine gcd(i, j, k)
        integer*8 i, j, a, b, c
        a = i
        b = j
        do while (b .ne. 0)
           c = b
           b = mod(a, b)
           a = c
        end do
        k = a
        return
      end


program TestMiller
  use Miller_Rabin
  implicit none

  integer, parameter :: prec = 30
  integer(huge) :: i

  ! this is limited since we're not using a bignum lib
  call do_test( (/ (i, i=1, 29) /) )

contains

  subroutine do_test(a)
    integer(huge), dimension(:), intent(in) :: a

    integer               :: i

    do i = 1, size(a,1)
       print *, a(i), miller_rabin_test(a(i), prec)
    end do

  end subroutine do_test

end program TestMiller


      SUBROUTINE slDJCA (NDP, DJM, IYMDF, J)
*+
*     - - - - - -
*      D J C A
*     - - - - - -
*
*  Modified Julian Date to Gregorian Calendar, expressed
*  in a form convenient for formatting messages (namely
*  rounded to a specified precision, and with the fields
*  stored in a single array)
*
*  Given:
*     NDP      i      number of decimal places of days in fraction
*     DJM      d      modified Julian Date (JD-2400000.5)
*
*  Returned:
*     IYMDF    i(4)   year, month, day, fraction in Gregorian
*                     calendar
*     J        i      status:  nonzero = out of range
*
*  Any date after 4701BC March 1 is accepted.
*
*  NDP should be 4 or less if internal overflows are to be avoided
*  on machines which use 32-bit integers.
*
*  The algorithm is adapted from Hatcher 1984 (QJRAS 25, 53-55).
*
*  Last revision:   22 July 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER NDP
      DOUBLE PRECISION DJM
      INTEGER IYMDF(4),J

      INTEGER NFD
      DOUBLE PRECISION FD,DF,F,D
      INTEGER JD,N4,ND10

*  Validate.
      IF ( DJM.LE.-2395520D0 .OR. DJM.GE.1D9 ) THEN
         J = -1
      ELSE
         J = 0

*     Denominator of fraction.
         NFD = 10**MAX(NDP,0)
         FD = DBLE(NFD)

*     Round date and express in units of fraction.
         DF = ANINT(DJM*FD)

*     Separate day and fraction.
         F = MOD(DF,FD)
         IF (F.LT.0D0) F = F+FD
         D = (DF-F)/FD

*     Express day in Gregorian calendar.
         JD = NINT(D)+2400001

         N4 = 4*(JD+((2*((4*JD-17918)/146097)*3)/4+1)/2-37)
         ND10 = 10*(MOD(N4-237,1461)/4)+5

         IYMDF(1) = N4/1461-4712
         IYMDF(2) = MOD(ND10/306+2,12)+1
         IYMDF(3) = MOD(ND10,306)/10+1
         IYMDF(4) = NINT(F)

      END IF

      END


!This module provides the initial power spectra, parameterized as an expansion in ln k
!
! ln P = ln A_s + (n_s -1)*ln(k/k_0) + n_{run}/2 * ln(k/k_0)^2
!
! so if n_run = 0
!
! P = A_s (k/k_0_scalar)^(n_s-1)
!
!for the scalar spectrum, when an(in) is the in'th spectral index. k_0_scalar
!is a pivot scale, fixed here to 0.05/Mpc (change it below as desired).
!
!This module uses the same inputs an(in), ant(in) and rat(in) as CMBFAST, however here
!rat(in) is used to set the ratio of the initial power spectra, so here
!
!** rat(in) is not the Cl quadrupole ratio ***
!
!in general models the quadrupole ratio depends in a complicated way on the ratio of the initial
!power spectra

!The absolute normalization of the Cls is unimportant here, but the relative ratio
!of the tensor and scalar Cls generated with this module will be correct for general models

!The OutputNormalization parameter controls the final output
!Absolute Cls can be obtained by setting OuputNormalization=outNone, otherwise the overall normalization
!of the power spectra doesn't matter

!This version December 2003 - changed default tensor pivot to 0.05 (consistent with CMBFAST 4.5)

     module InitialPower
     use Precision
     implicit none

     private

      character(LEN=*), parameter :: Power_Name = 'power_tilt'

      integer, parameter :: nnmax= 5
       !Maximum possible number of different power spectra to use

      Type InitialPowerParams

       integer nn  !Must have this variable
      !The actual number of power spectra to use

      !For the default implementation return power spectra based on spectral indices
       real(dl) an(nnmax) !scalar spectral indices
       real(dl) n_run(nnmax) !running of spectral index
       real(dl) ant(nnmax) !tensor spectral indices
       real(dl) rat(nnmax) !ratio of scalar to tensor initial power spectrum amplitudes
       real(dl) k_0_scalar, k_0_tensor
       real(dl) ScalarPowerAmp(nnmax)

      end Type InitialPowerParams

      real(dl) curv  !Curvature contant, set in InitializePowers

      Type(InitialPowerParams) :: P

!Make things visible as neccessary...

      public InitialPowerParams, InitialPower_ReadParams, InitializePowers, ScalarPower, TensorPower
      public nnmax,Power_Descript, Power_Name, SetDefPowerParams
!      public
    contains

       subroutine SetDefPowerParams(AP)
        Type (InitialPowerParams) :: AP

         AP%nn     = 1 !number of initial power spectra
         AP%an     = 1 !scalar spectral index
         AP%n_run   = 0 !running of scalar spectral index
         AP%ant    = 0 !tensor spectra index
         AP%rat    = 1
         AP%k_0_scalar = 0.05
         AP%k_0_tensor = 0.05
         AP%ScalarPowerAmp = 1

       end subroutine SetDefPowerParams

       subroutine InitializePowers(AParamSet,acurv)
         Type (InitialPowerParams) :: AParamSet
         !Called before computing final Cls in cmbmain.f90
         !Could read spectra from disk here, do other processing, etc.

        real(dl) acurv

        if (AParamSet%nn > nnmax) then
           write (*,*) 'To use ',AParamSet%nn,'power spectra you need to increase'
           write (*,*) 'nnmax in power_tilt.f90, currently ',nnmax
        end if
        P = AParamSet

        curv=acurv

!Write implementation specific code here...

       end subroutine InitializePowers

      function ScalarPower(k,in)

       !"in" gives the index of the power to return for this k
       !ScalarPower = const for scale invariant spectrum
       !The normalization is defined so that for adiabatic perturbations the gradient of the 3-Ricci
       !scalar on co-moving hypersurfaces receives power
       ! < |D_a R^{(3)}|^2 > = int dk/k 16 k^6/S^6 (1-3K/k^2)^2 ScalarPower(k)
       !In other words ScalarPower is the power spectrum of the conserved curvature perturbation given by
       !-chi = \Phi + 2/3*\Omega^{-1} \frac{H^{-1}\Phi' - \Psi}{1+w}
       !(w=p/\rho), so < |\chi(x)|^2 > = \int dk/k ScalarPower(k).
       !Near the end of inflation chi is equal to 3/2 Psi.
       !Here nu^2 = (k^2 + curv)/|curv|

       !This power spectrum is also used for isocurvature modes where
       !< |\Delta(x)|^2 > = \int dk/k ScalarPower(k)
       !For the isocurvture velocity mode ScalarPower is the power in the neutrino heat flux.

        real(dl) ScalarPower,k, lnrat
        integer in

          lnrat = log(k/P%k_0_scalar)
          ScalarPower=P%ScalarPowerAmp(in)*exp((P%an(in)-1)*lnrat + P%n_run(in)/2*lnrat**2)

!         ScalarPower = ScalarPower * (1 + 0.1*cos( lnrat*30 ) )

      end function ScalarPower

      function TensorPower(k,in)

       !TensorPower= const for scale invariant spectrum
       !The normalization is defined so that
       ! < h_{ij}(x) h^{ij}(x) > = \sum_nu nu /(nu^2-1) (nu^2-4)/nu^2 TensorPower(k)
       !for a closed model
       ! < h_{ij}(x) h^{ij}(x) > = int d nu /(nu^2+1) (nu^2+4)/nu^2 TensorPower(k)
       !for an open model
       !"in" gives the index of the power spectrum to return
       !Here nu^2 = (k^2 + 3*curv)/|curv|

        real(dl) TensorPower,k
        real(dl), parameter :: PiByTwo=3.14159265d0/2._dl

        integer in

        TensorPower=P%rat(in)*P%ScalarPowerAmp(in)*exp(P%ant(in)*log(k/P%k_0_tensor))
        if (curv < 0) TensorPower=TensorPower*tanh(PiByTwo*sqrt(-k**2/curv-3))

      end function TensorPower

      !Get parameters describing parameterisation (for FITS file)
     function Power_Descript(in, Scal, Tens, Keys, Vals)
         character(LEN=8), intent(out) :: Keys(*)
         real(dl), intent(out) :: Vals(*)
         integer, intent(IN) :: in
         logical, intent(IN) :: Scal, Tens
         integer num, Power_Descript
         num=0
         if (Scal) then
         num=num+1
         Keys(num) = 'n_s'
         Vals(num) = P%an(in)
         num=num+1
         Keys(num) = 'n_run'
         Vals(num) = P%n_run(in)
         num=num+1
         Keys(num) = 's_pivot'
         Vals(num) = P%k_0_scalar
         end if
         if (Tens) then
         num=num+1
         Keys(num) = 'n_t'
         Vals(num) = P%ant(in)
         num=num+1
         Keys(num) = 't_pivot'
         Vals(num) = P%k_0_tensor
         if (Scal) then
           num=num+1
           Keys(num) = 'p_ratio'
           Vals(num) = P%rat(in)
         end if
         end if
         Power_Descript = num

       end  function Power_Descript

       subroutine InitialPower_ReadParams(InitPower, Ini, WantTensors)
          use IniFile
          Type(InitialPowerParams) :: InitPower
          Type(TIniFile) :: Ini
          logical, intent(in) :: WantTensors
          integer i

           InitPower%k_0_scalar = Ini_Read_Double_File(Ini,'pivot_scalar',InitPower%k_0_scalar)
           InitPower%k_0_tensor = Ini_Read_Double_File(Ini,'pivot_tensor',InitPower%k_0_tensor)
           InitPower%nn = Ini_Read_Int('initial_power_num')
           if (InitPower%nn>nnmax) stop 'Too many initial power spectra - increase nnmax in InitialPower'
           InitPower%rat(:) = 1
           do i=1, InitPower%nn

              InitPower%an(i) = Ini_Read_Double_Array_File(Ini,'scalar_spectral_index', i)
              InitPower%n_run(i) = Ini_Read_Double_Array_File(Ini,'scalar_nrun',i,0._dl)

              if (WantTensors) then
                 InitPower%ant(i) = Ini_Read_Double_Array_File(Ini,'tensor_spectral_index',i)
                 InitPower%rat(i) = Ini_Read_Double_Array_File(Ini,'initial_ratio',i)
              end if

              InitPower%ScalarPowerAmp(i) = Ini_Read_Double_Array_File(Ini,'scalar_amp',i,1._dl)
              !Always need this as may want to set tensor amplitude even if scalars not computed
           end do

       end  subroutine InitialPower_ReadParams

     end module InitialPower


program main
  implicit none
  integer,parameter :: natom = 60
  real(8),parameter :: dist0 = 1d0
  real(8) :: rion(3,natom), rion0(3), rion_t(3)
  integer :: iatom,jatom,i
  real(8) :: r, diff_sum
  real(8) :: dist_r(3)
  integer :: dist_i(3)

  do iatom = 1,natom
    do i = 1,3
      call random_number(r)
      rion(i,iatom) = r
    end do
  end do

  rion0(1) = sum(rion(1,:))/natom
  rion0(2) = sum(rion(2,:))/natom
  rion0(3) = sum(rion(3,:))/natom

  rion(1,:) = rion(1,:) - rion0(1)
  rion(2,:) = rion(2,:) - rion0(2)
  rion(3,:) = rion(3,:) - rion0(3)

  do
    diff_sum = 0d0
    do iatom = 1,natom
      dist_r = 1d20
      dist_i = 0
      do jatom = 1,natom
        if(iatom == jatom)cycle
        r = sqrt( sum( (rion(:,iatom) - rion(:,jatom))**2 ))
        if(r < dist_r(1))then
          dist_r(3) = dist_r(2); dist_i(3) = dist_i(2)
          dist_r(2) = dist_r(1); dist_i(2) = dist_i(1)
          dist_r(1) = r        ; dist_i(1) = jatom
        else if(r < dist_r(2))then
          dist_r(3) = dist_r(2); dist_i(3) = dist_i(2)
          dist_r(2) = r        ; dist_i(2) = jatom
        else if(r < dist_r(3))then
          dist_r(3) = r        ; dist_i(3) = jatom
        end if

      end do

        if(abs(dist_r(1)-dist0) > max( abs(dist_r(2)-dist0), abs(dist_r(2)-dist0)))then
          i = 1
        else if (abs(dist_r(2)-dist0) > max( abs(dist_r(1)-dist0), abs(dist_r(3)-dist0)))then
          i = 2
        else
          i = 3
        end if

        diff_sum = diff_sum + sum(abs(dist_r(1:3)-dist0))

        rion(:,iatom) = rion(:,iatom) &
          + dist0*(rion(:,dist_i(i)) - rion(:,iatom))/dist_r(dist_i(i))

    end do
    write(*,*)diff_sum
    if(diff_sum < 1d20)exit

  end do

  rion0(1) = sum(rion(1,:))/natom
  rion0(2) = sum(rion(2,:))/natom
  rion0(3) = sum(rion(3,:))/natom

  rion(1,:) = rion(1,:) - rion0(1)
  rion(2,:) = rion(2,:) - rion0(2)
  rion(3,:) = rion(3,:) - rion0(3)

  open(20,file="c60.xyz")
  do iatom = 1,natom
    write(20,"(I7,2x,999e26.16e3)")iatom,rion(:,iatom)
  end do
  close(20)

end program main


!==============================================================================!
  subroutine Constants_Spalart_Allmaras()
!------------------------------------------------------------------------------!
!   Initializes constants for Spalar-Allmaras and DES turbulence models.       !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Rans_Mod
  use Control_Mod
  use Const_Mod, only: TWO_THIRDS
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  ! call Control_Mod_Turbulence_Model(.true.)
  ! call Control_Mod_Turbulence_Model_Variant(.true.)

  vis % sigma = TWO_THIRDS

  kappa  = 0.41
  c_b1   = 0.1355
  c_b2   = 0.622
  c_v1   = 7.1
  c_w1   = c_b1 / kappa**2 + (1 + c_b2) / vis % sigma
  c_w2   = 0.3
  c_w3   = 2.0

  end subroutine


C **********************************************************
C library of functions used in calculation of currents
C references:
C [1]   arXiv:0911.4436 (hep-ph)  D. Gomez Dumm et al. (tau -> 3pi nu)
C [2]   arXiv:0911.2640 (hep-ph) D. Gomezz Dumm et al. (tau -> KKpi nu)
C [3]   arXiv:0807.4883 (hep-ph) D. R. Boito et al. (tau -> Kpi nu)
C [4]   P. Roig, talk at (tau -> 2 pi nu)
C [5]   arXiv:0803.2039  (hep-ph) E. Arganda et al., Appendix B (tau -> KK nu)
C **********************************************************
      FUNCTION GRHO_RCHT(XS,XMMM)
      IMPLICIT NONE
      REAL               XS
      DOUBLE PRECISION      XMMM
C **********************************************************
C     REAL FUNCTION Gamma Rho ; energy-dependent width of  rho meson
c     in SU(2) limit mpi=mpi0, mk=mk0;
C     formula (14) of REF [1]
C **********************************************************
       include '../parameter.inc'
      include '../funct_declar.inc'

       REAL MMPI_AV2,MMK_2

      MMPI_AV2 = MMPI_AV**2
      MMK_2 = MMK**2

      IF(XS.GE.(4.*MMK_2)) THEN
           GRHO_RCHT=XMMM*XS*((1.-4.*MMPI_AV2/XS)**1.5
     $              +0.5*(1.-4.*MMK_2/XS)**1.5)
     $                  /(96.*PI*FPI_RPT**2)
      ELSE IF((XS.GE.(4.*MMPI_AV2)).AND.(XS.LE.(4.*MMK_2))) THEN
        GRHO_RCHT=XMMM*XS*(1.-4.*MMPI_AV2/XS)**1.5
     $            /(96.*PI*FPI_RPT**2)
      ELSE
        GRHO_RCHT = 0.
      ENDIF

      RETURN

      END

      FUNCTION GRHO1_RCHT(XS,XMMM,XGGG)
      IMPLICIT NONE
      REAL                XS
      DOUBLE PRECISION       XMMM,XGGG
C **********************************************************
C     REAL FUNCTION Gamma Rho1 ; energy-dependent width of  rho1 meson;
c     in SU(2) limit mpi=mpi0; only rho' -> 2pi loop;
C     formula (33) of REF [1]
C **********************************************************
      include '../parameter.inc'
      include '../funct_declar.inc'

       REAL MMPI_AV2
      MMPI_AV2 = MMPI_AV**2

      IF (XS.GE.(4.*MMPI_AV2)) THEN
        GRHO1_RCHT=XGGG*SQRT(XMMM**2/XS)*
     &      ((XS-4.*MMPI_AV2)/(XMMM**2-4.*MMPI_AV2))**1.5
      ELSE
        GRHO1_RCHT = 0.
      ENDIF

      RETURN
      END

      FUNCTION SIGP(SS)
      IMPLICIT NONE
      DOUBLE PRECISION               SS
C***********************************************************
C     DOUBLRE PRECISION FUNCTION
c     of two body phase space threshold: equal mass scalars
C***********************************************************
      REAL TT
      include '../parameter.inc'
      include '../funct_declar.inc'

      TT = 1. - 4.*MMPI_AV**2/SS

      IF (TT.GE.0) THEN
      SIGP = SQRT(TT)
      ELSE
      SIGP = 0.
      ENDIF

      RETURN
      END

      FUNCTION LAMB_RCHT(X1,X2,X3)
      IMPLICIT NONE
      REAL               X1,X2,X3,ARG_RCHT
C***********************************************************
C     REAL FUNCTION LAMDA of three body phase space
C***********************************************************
      include '../funct_declar.inc'

      ARG_RCHT = (X1-X2-X3)**2 - 4.*X3*X2
      IF(ARG_RCHT.GE.0.) THEN
      LAMB_RCHT = ARG_RCHT
      ELSE
      LAMB_RCHT = 0.
      ENDIF

      RETURN
      END

C******************** FUNCTIONS FOR 2 SCALAR MODES ***********************

C****************************************************************
      FUNCTION R0SCAL_3PI(QX,SX)
C****************************************************************
C     Complex Function: R_0 function (Pablo notes)
C     for the scalar contribution for three pion modes
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,SX,delta0_3piscal,xsx,xst
      DOUBLE PRECISION    XM1,XM2,DSX
      include '../funct_declar.inc'
       include '../parameter.inc'
c$$$      a00_3piscal = 0.220
c$$$      b00_3piscal = 0.268/mmpi_av**2
c$$$      c00_3piscal = -0.0139/mmpi_av**4
c$$$      d00_3piscal = -0.00139/mmpi_av**6
c$$$      x00_3piscal = 36.77*mmpi_av**2
c$$$c      MMF0 = 0.98
c$$$
      dsx = sx
      xsx = sx/4.*sigp(dsx)**2
      xst = sqrt(sx)

      if(sx.le.0.7) then
      delta0_3piscal = sigp(dsx)*(a00_3piscal + b00_3piscal*xsx +
     &               c00_3piscal*xsx**2 + d00_3piscal*xsx**3)

      delta0_3piscal = delta0_3piscal*
     &         (4*mmpi_av**2 - x00_3piscal)/(sx-x00_3piscal)
      else if (xst.le.1.21) then
      delta0_3piscal = -10572.0+50658.0*xst-87903.0*xst**2+66886.0*xst**3
     & -18699.0*xst**4
      delta0_3piscal = delta0_3piscal*pi/180.0
      else
      delta0_3piscal = 255.0*pi/180.0
      endif

      delta0_3piscal = atan(delta0_3piscal)

      R0SCAL_3PI = ALPHA0_3PI/QX +
     &          ALPHA1_3PI/QX**2*(SX - MMF0**2)

      R0SCAL_3PI = R0SCAL_3PI*(cos(delta0_3piscal) +
     &              i*sin(delta0_3piscal))

      RETURN
      END

C****************************************************************
      FUNCTION R2SCAL_3PI(QX,SX)
C****************************************************************
C     Complex Function: R_2 function (Pablo notes)
C     for the scalar contribution for three pion modes
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,SX,delta2_3piscal,xsx,xst
      DOUBLE PRECISION    XM1,XM2,DSX
      include '../funct_declar.inc'
       include '../parameter.inc'
c$$$      a02_3piscal = -0.0444
c$$$      b02_3piscal = -0.0857/mmpi_av**2
c$$$      c02_3piscal = -0.00221/mmpi_av**4
c$$$      d02_3piscal = -0.000129/mmpi_av**6
c$$$      x02_3piscal = -21.62*mmpi_av**2
c$$$c      MMF0 = 0.98

      dsx = sx
      xsx = sx/4.*sigp(dsx)**2
      xst = sqrt(sx)

      if(sx.le.0.7) then
      delta2_3piscal = sigp(dsx)*(a02_3piscal + b02_3piscal*xsx +
     &               c02_3piscal*xsx**2 + d02_3piscal*xsx**3)

      delta2_3piscal = delta2_3piscal*
     &         (4*mmpi_av**2 - x02_3piscal)/(sx-x02_3piscal)
      else if(xst.le.1.21) then
      delta2_3piscal = 282.9-1314.9*xst+2153.4*xst**2-1574.5d0*xst**3+
     & 428.06d0*xst**4
      delta2_3piscal = delta2_3piscal*pi/180.0
      else
      delta2_3piscal = -27.0*pi/180.0
      endif

      delta2_3piscal = atan(delta2_3piscal)

      R2SCAL_3PI = GAMMA0_3PI/QX +
     &          GAMMA1_3PI/QX**2*(SX - MMF0**2)

      R2SCAL_3PI = R2SCAL_3PI*(cos(delta2_3piscal) +
     &              i*sin(delta2_3piscal))

      RETURN
      END

C*************************************************************************
C         Functions for sigma contributions
C*************************************************************************
      FUNCTION FFsig(QX,XX)
C **********************************************************
C     Complex Function:
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,XX,mm2
      DOUBLE PRECISION    XM1,XM2,xphi
      include '../funct_declar.inc'
      include '../parameter.inc'

      mm2 = MMPI_AV**2

      xphi = - rsigma**2* LAMB_RCHT(QX,XX,mm2)/(8.*QX)

      FFsig = dexp(xphi)

       RETURN
       END

C*************************************************************************
      FUNCTION BWsig(XM,XG,XQ)
C **********************************************************
C     Complex Function: S-wave Breit-Wigner
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            XQ
      DOUBLE PRECISION    XM,XG,XM2,XXQ,GAMMA
      include '../funct_declar.inc'
      include '../parameter.inc'

      XXQ = XQ
      XM2 = XM**2
      GAMMA = XG*SIGP(XXQ)/SIGP(XM2)
      BWsig = XM*XM/CMPLX(XM*XM-XQ, -XM*GAMMA)

       RETURN
       END

C*************************************************************************
      FUNCTION DECOUL(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb interaction effects of two particles
C                    with mm1 and mm2
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
      betam1m3 = 1.d0 - (mm1 +mm3)**2/ss2
      betam1m3 = dsqrt(betam1m3)

      if(ss2.gt.(mm1+mm3)**2)
     &    decoul = pi/2.d0/betam1m3/ALFINV

       RETURN
       END

C*************************************************************************
      FUNCTION COUL3PART(mm1,mm2,mm3,ss1,ss2,ss3)
C **********************************************************
C     Real Function: Coulomb interaction effects of two particles
C                    with mm1 and mm2
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss3,ss2,ss1
      DOUBLE PRECISION    mm1,mm2,mm3
      include '../funct_declar.inc'
      include '../parameter.inc'

      coul3part = decoul(mm1,mm3,ss2) + decoul(mm2,mm3,ss1)
     &          - decoul(mm1,mm2,ss3)

       coul3part = exp(coul3part)

       RETURN
       END
C*************************************************************************
      FUNCTION fattcoul(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb attraction of two particles
C                    with mm1 and mm3
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
      if(ss2.gt.(mm1+mm3)**2) then
      betam1m3 = 2.*dsqrt(1.d0 - (mm1 +mm3)**2/ss2)
     &            /(1.+ (1.d0 - (mm1 +mm3)**2/ss2))

         fattcoul = 2.*pi/betam1m3/ALFINV
     &               /(1.-exp(-2.*pi/betam1m3/ALFINV))
       else
         fattcoul = 1
          endif

       RETURN
       END

C*************************************************************************
C*************************************************************************
      FUNCTION frepcoul(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb repuslcion of two particles
C                    with mm1 and mm3
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
        if(ss2.gt.(mm1+mm3)**2) then
      betam1m3 = 2.*dsqrt(1.d0 - (mm1 +mm3)**2/ss2)
     &           /(1.+ (1.d0 - (mm1 +mm3)**2/ss2))

         frepcoul = 2.*pi/betam1m3/ALFINV
     &               /(-1.+exp(2.*pi/betam1m3/ALFINV))
       else
         frepcoul = 1
          endif
       RETURN
       END

C*************************************************************************


module random2
  !! A pseudo-random number generator.
  implicit none
  integer,private ::IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV
  real(8),private :: AM,EPS,RNMX
  parameter (IM1=2147483563,IM2=2147483399,AM=1.0/IM1,IMM1=IM1-1,&
  IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,&
  IR2=3791,NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-9,RNMX=1.-EPS)

 type Ran2State
    !! RNG state
    integer :: idum
    integer :: idum2,iv(NTAB),iy
 end type Ran2State

contains

subroutine ran2_reset(s)
  !! Reset ran2 RNG
  type(Ran2State) :: s
  s%idum2=123456789
  s%iv = 0
  s%iy = 0
end subroutine ran2_reset

subroutine ran2_put_seed(s, idum)
  !! Seeds ran2 RNG
  integer, intent(in) :: idum
  type(Ran2State) :: s
  integer :: j,k
  s%idum=max(abs(idum),1)
  s%idum2=s%idum
  do j=NTAB+8,1,-1
     k=s%idum/IQ1
     s%idum=IA1*(s%idum-k*IQ1)-k*IR1
     if (s%idum.lt.0) s%idum=s%idum+IM1
     if (j.le.NTAB) s%iv(j) = s%idum
  enddo
  s%iy = s%iv(1)
end subroutine ran2_put_seed

real(8) function ran2(s)
  !! Returns a random real in [0,1[.
  !! Repeated calls form a random sequence.
  type(Ran2State) :: s

  integer :: j,k
  k=s%idum/IQ1
  s%idum=IA1*(s%idum-k*IQ1)-k*IR1
  if (s%idum.lt.0) s%idum = s%idum+IM1
  k=s%idum2/IQ2
  s%idum2=IA2*(s%idum2-k*IQ2)-k*IR2
  if (s%idum2.lt.0) s%idum2=s%idum2+IM2
  j=1+s%iy/NDIV
  s%iy=s%iv(j)-s%idum2
  s%iv(j)=s%idum
  if(s%iy.lt.1) s%iy=s%iy+IMM1
  ran2=min(AM*s%iy,RNMX)
end function ran2

logical function metropolis(dx,rng)
  !! Accepts or rejects by the metropolis rule.
  !! Returns `.true.` if min(1, exp(-dx)) >= (random number),
  !! .false. otherwise.
  type(Ran2State) :: rng   !! RNG
  real(8),intent(in) :: dx !! can be seen as ΔE/kT
  real(8) :: dump
  if(dx<=0) then
     metropolis=.true.
     return
  endif
  dump=exp(-dx)
  if(ran2(rng)<dump) then
     metropolis=.true.
  else
     metropolis=.false.
  endif
end function metropolis

end module random2