Initial commit

dataassim/math/othersupmath/gridsampling.f

@@ -0,0 +1,128 @@
+      subroutine gridsampling(sampfunc,ihowsamp,nparams,
+     &  msect0,bestguess,yatguess,guessconfid0,bmax,bmin)
+      implicit none
+!
+      integer nparams,msect0,ihowsamp
+      double precision bestguess(nparams),guessconfid0,
+     &  bmax(nparams),bmin(nparams),params(nparams,msect0+1),
+     &  guessconfid,yatguess,beta(nparams),fatbeta
+      integer i,nright,nleft,j,k,n,msect,m
+      double precision accum,x1,delta,eps
+
+      logical resetran2
+      common /ran2reset/resetran2
+
+      parameter(eps=1.0d-9)
+      external sampfunc
+!
+      resetran2=.true.
+!
+      msect=msect0
+!      call sampfunc(nparams,bestguess,yatguess)
+!assume calculation already done for initial guess
+      guessconfid=dmax1(1.0d0,guessconfid0)
+      j=0
+      do i=1,nparams
+        if(bestguess(i).lt.bmin(i).or.bestguess(i).gt.
+     &    bmax(i))then
+          j=1
+          if(bestguess(i).lt.bmin(i))then
+            bestguess(i)=bmin(i)
+          else
+            bestguess(i)=bmax(i)
+          endif
+        endif
+      enddo
+      if(j.eq.1)call sampfunc(nparams,bestguess,yatguess)
+      do i=1,nparams
+        if(dabs(bmax(i)-bestguess(i)).lt.eps)then
+          nright=0
+          nleft=msect+1
+        else
+          if(dabs(bestguess(i)-bmin(i)).lt.eps)then
+            nright=msect+1
+            nleft=0
+          else
+            if(mod(msect,2).eq.0)then
+              nright=msect/2+1
+              nleft=msect/2+1
+            else
+              nright=msect/2+1+1
+              nleft=msect/2+1
+            endif
+          endif
+        endif
+!first divide the right
+        if(nright.gt.0)then
+          x1=2.0d0*(bmax(i)-bestguess(i))/
+     &      (dble(nright)*(guessconfid+1.0d0))
+          delta=x1*(guessconfid-1.0d0)/dble(nright-1)
+          accum=0.0d0
+          do j=1,nright-1
+            accum=accum+x1+dble(j-1)*delta
+            params(i,j)=accum+bestguess(i)
+          enddo
+        endif
+!then divide the left
+        if(nleft.gt.0)then
+          x1=2.0d0*(bestguess(i)-bmin(i))/
+     &      (dble(nleft)*(guessconfid+1.0d0))
+          delta=x1*(guessconfid-1.0d0)/dble(nleft-1)
+          accum=0.0d0
+          do j=1,nleft-1
+            accum=accum+x1+dble(j-1)*delta
+            if(nright.eq.0)then
+              params(i,j)=bestguess(i)-accum
+            else
+              params(i,j+nright-1)=bestguess(i)-accum
+            endif
+          enddo      
+        endif
+      enddo
+      do i=1,nparams
+        params(i,msect+1)=bestguess(i)
+      enddo
+      msect=msect+1
+      if(ihowsamp.eq.1)then
+!Using random permutation
+        call randpermut_dim_samp(msect,nparams,
+     &    params(1:nparams,1:msect))
+        do i=1,msect
+          call sampfunc(nparams,params(1:nparams,i:i),fatbeta)
+          if(fatbeta.lt.yatguess)then
+            yatguess=fatbeta
+            do j=1,nparams
+              bestguess(j)=params(j,i)
+            enddo
+          endif
+        enddo
+      endif
+      if(ihowsamp.eq.2)then
+!uniform grid sampling          
+        do i=1,msect**nparams
+          do j=1,nparams
+!the size of the larger repeated unit is msect**(nparams-j+1)
+            k=i/(msect**(nparams-j+1))
+            n=mod(i,(msect**(nparams-j+1)))
+            if(n.eq.0)k=k-1
+!k is the number of repeated units before i (not include the unit i is in)
+            k=i-k*(msect**(nparams-j+1))
+!now k is the position in the larger repeated unit
+!
+!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect
+            m=(msect**(nparams-j+1))/msect
+            n=k/m
+            if(mod(k,m).ne.0)n=n+1
+            beta(j)=params(j,n)
+          enddo
+          call sampfunc(nparams,beta,fatbeta)
+          if(fatbeta.lt.yatguess)then
+            yatguess=fatbeta
+            do j=1,nparams
+              bestguess(j)=beta(j)
+            enddo
+          endif
+        enddo
+      endif
+      return
+      end subroutine gridsampling