Initial commit

2016-02-03 18:52:05 +00:00
commit d40505e161
507 changed files with 91383 additions and 0 deletions
@@ -0,0 +1,69 @@
+      SUBROUTINE lnsrch(n,xold,fold,g,p,x,f,stpmax,check,func)
+      INTEGER n
+      LOGICAL check
+      REAL f,fold,stpmax,g(n),p(n),x(n),xold(n),func,ALF,TOLX
+      PARAMETER (ALF=1.e-4,TOLX=1.e-7)
+      EXTERNAL func
+CU    USES func
+      INTEGER i
+      REAL a,alam,alam2,alamin,b,disc,f2,fold2,rhs1,rhs2,slope,sum,temp,
+     *test,tmplam
+      check=.false.
+      sum=0.
+      do 11 i=1,n
+        sum=sum+p(i)*p(i)
+11    continue
+      sum=sqrt(sum)
+      if(sum.gt.stpmax)then
+        do 12 i=1,n
+          p(i)=p(i)*stpmax/sum
+12      continue
+      endif
+      slope=0.
+      do 13 i=1,n
+        slope=slope+g(i)*p(i)
+13    continue
+      test=0.
+      do 14 i=1,n
+        temp=abs(p(i))/max(abs(xold(i)),1.)
+        if(temp.gt.test)test=temp
+14    continue
+      alamin=TOLX/test
+      alam=1.
+1     continue
+        do 15 i=1,n
+          x(i)=xold(i)+alam*p(i)
+15      continue
+        f=func(x)
+        if(alam.lt.alamin)then
+          do 16 i=1,n
+            x(i)=xold(i)
+16        continue
+          check=.true.
+          return
+        else if(f.le.fold+ALF*alam*slope)then
+          return
+        else
+          if(alam.eq.1.)then
+            tmplam=-slope/(2.*(f-fold-slope))
+          else
+            rhs1=f-fold-alam*slope
+            rhs2=f2-fold2-alam2*slope
+            a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
+            b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
+            if(a.eq.0.)then
+              tmplam=-slope/(2.*b)
+            else
+              disc=b*b-3.*a*slope
+              if(disc.lt.0.) pause 'roundoff problem in lnsrch'
+              tmplam=(-b+sqrt(disc))/(3.*a)
+            endif
+            if(tmplam.gt..5*alam)tmplam=.5*alam
+          endif
+        endif
+        alam2=alam
+        f2=f
+        fold2=fold
+        alam=max(tmplam,.1*alam)
+      goto 1
+      END