Initial commit

2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
@@ -0,0 +1,144 @@
+
+      subroutine samplingscheme(sampfunc,nparams,msamp,
+     &  bestguess,guessconfid0,bmax,bmin,params,ysamp)
+!
+! This subroutine conducts samples from a given function using both random and
+! systematic strategies. In the random strategy, sampled points randomly scatter 
+! around the bestguess point. The closeness to the bestguess depends on the confidence
+! on the bestguess. For any given parameter, the width of the last interval is 
+! guessconfid0 X the width of the first interval. In the systematic strategy, two values 
+! for each parameter are determined with the new bestguess after
+! the random sampling in the middle. The two determined values of all parameters
+! are systematically combined to form new additional sampling points. 
+!
+! After the two sampling strategies, the latest best guess is the first point in params.
+
+      
+      implicit none
+      integer nparams,msamp
+      double precision bestguess(nparams),guessconfid0,
+     &    bmax(nparams),bmin(nparams),params(nparams,msamp),
+     &    ysamp(msamp),guessconfid
+      integer i,nright,nleft,ibest,msamptemp
+      double precision accum,x1,delta,j,ybest,temp
+      
+      external sampfunc
+      
+      guessconfid=dmax1(1.0d0,guessconfid0)
+      
+      do i=1,nparams
+        if(bestguess(i).lt.bmin(i).or.bestguess(i).gt.
+     &    bmax(i))then
+          write(*,*)'best guess out of bounds, sampling stops'
+          stop
+        endif
+      enddo
+      msamptemp=msamp-1-2*nparams
+      
+      if(msamptemp.lt.0)then
+        write(*,*)'sampling number must be larger than',
+     &      (1+2*nparams)
+        stop
+      endif
+      if(msamptemp.gt.0)then
+        if(msamptemp.ge.3)then
+          if(mod(msamptemp,2).eq.0)then
+            nright=msamptemp/2
+            nleft=msamptemp/2
+          else
+            nright=msamptemp/2+1
+            nleft=msamptemp/2
+          endif
+          do i=1,nparams
+!first divide the right        
+            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
+              accum=accum+x1+dble(j-1)*delta
+              params(i,j)=accum+bestguess(i)
+            enddo
+!
+!then divide the left
+            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
+              accum=accum+x1+dble(j-1)*delta
+              params(i,j+nright)=bestguess(i)-accum
+            enddo      
+          enddo
+        else
+          if(msamptemp.eq.1)then
+            do i=1,nparams
+! arbitrarily take one value
+              params(i,1)=bestguess(i)+(bmax(i)-bestguess(i))
+     &                    *0.339354235d0
+            enddo
+          endif
+          if(msamptemp.eq.2)then
+            do i=1,nparams
+! arbitrarily take two values              
+              params(i,1)=bestguess(i)+(bmax(i)-bestguess(i))
+     &                    *0.339354235d0
+              params(i,2)=bestguess(i)-(bestguess(i)-bmin(i))
+     &                    *0.339354235d0
+            enddo
+          endif
+        endif
+        call randpermut_dim_samp(msamptemp,nparams,
+     &        params(1:nparams,1:msamptemp))
+      endif
+      msamptemp=msamptemp+1
+      do i=1,nparams
+        params(i,msamptemp)=bestguess(i)
+      enddo
+      do i=1,msamptemp
+        call sampfunc(nparams,params(1:nparams,i:i),ysamp(i))
+      enddo
+      
+      ibest=1
+      ybest=ysamp(ibest)
+      do i=2,msamptemp
+        if(ysamp(i).lt.ybest)then
+          ibest=i
+          ybest=ysamp(i)
+        endif
+      enddo
+      
+      do i=1,nparams
+        msamptemp=msamptemp+1
+        params(i,msamptemp)=params(i,ibest)+
+     &       (bmax(i)-params(i,ibest))/(1.0d0+guessconfid)
+        msamptemp=msamptemp+1
+        params(i,msamptemp)=params(i,ibest)-
+     &       (params(i,ibest)-bmin(i))/(1.0d0+guessconfid)
+        do j=1,i-1
+          params(j,msamptemp-1)=params(j,ibest)
+          params(j,msamptemp)=params(j,ibest)
+        enddo
+        do j=i+1,nparams
+          params(j,msamptemp-1)=params(j,ibest)
+          params(j,msamptemp)=params(j,ibest)
+        enddo
+      enddo
+      do i=msamptemp-2*nparams+1,msamptemp
+        call sampfunc(nparams,params(1:nparams,i:i),ysamp(i))
+        if(ysamp(i).lt.ybest)then
+          ibest=i
+          ybest=ysamp(i)
+        endif
+      enddo
+      do i=1,nparams
+        temp=params(i,1)
+        params(i,1)=params(i,ibest)
+        params(i,ibest)=temp
+      enddo
+      temp=ysamp(1)
+      ysamp(1)=ysamp(ibest)
+      ysamp(ibest)=temp
+      
+      return
+      end