Initial commit

dataassim/math/nonlinsystems/bookkeeping.f

@@ -0,0 +1,66 @@
+      subroutine bookkeeping(nunknowns,xvar,fequ,
+     &   icall,iflargest)
+      implicit none
+      include 'nslasystem.h'
+      integer nunknowns,icall,iflargest
+      double precision xvar(nunknowns),fequ(nunknowns)
+      integer iGuCall,i,j,k
+      parameter(iGuCall=49)
+!--------------------------------------------------------------------------
+      iflargest=1
+      do j=2,nunknowns
+        if(dabs(fequ(j)).gt.dabs(fequ(iflargest)))
+     &     iflargest=j
+      enddo
+      if(numeval.eq.maxeval)goto 100
+      if(numeval.eq.0.or.icall.eq.iGuCall)then
+        numeval=numeval+1
+        flargest(numeval)=dabs(fequ(iflargest))
+        do i=1,nunknowns
+          xevaluated(numeval,i)=xvar(i)
+          fevaluated(numeval,i)=fequ(i)
+        enddo
+        return
+      endif
+100   do i=1,numeval
+        k=0
+        do j=1,nunknowns
+          if(dabs(xvar(j)-xevaluated(i,j)).gt.
+     &           1.0d-5*dabs(xvar(j)))k=1
+        enddo
+        if(k.eq.0)goto 500
+      enddo
+      if(numeval.lt.maxeval)then
+        numeval=numeval+1
+        flargest(numeval)=dabs(fequ(iflargest))
+        do i=1,nunknowns
+          xevaluated(numeval,i)=xvar(i)
+          fevaluated(numeval,i)=fequ(i)
+        enddo
+        return
+      endif
+! replace a point
+      j=1
+      do i=2,numeval
+        if(flargest(j).lt.flargest(i))then
+          j=i
+        endif
+      enddo
+      if(dabs(fequ(iflargest)).lt.flargest(j))then
+        flargest(j)=dabs(fequ(iflargest))
+        do i=1,nunknowns
+          xevaluated(j,i)=xvar(i)
+          fevaluated(j,i)=fequ(i)
+        enddo
+      endif
+      return
+! too close to the existing point i
+500   if(dabs(fequ(iflargest)).lt.flargest(i))then
+        flargest(i)=dabs(fequ(iflargest))
+        do j=1,nunknowns
+          xevaluated(i,j)=xvar(j)
+          fevaluated(i,j)=fequ(j)
+        enddo
+      endif
+      return
+      end