New changes from l2g

w

dataassim/math/othersupmath/supmath.f

@@ -1,3 +1,54 @@
+      subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
+      implicit none
+      integer n,imin,imax,i
+      double precision x(n),xmin,xmax
+      imin=1
+      xmin=x(1)
+      imax=1
+      xmax=x(1)
+      do i=2,n
+        if(x(i).lt.xmin)then
+          imin=i
+          xmin=x(i)
+        endif
+        if(x(i).gt.xmax)then
+          imax=i
+          xmax=x(i)
+        endif
+      enddo
+      return
+      end
+
+      double precision function fdotsec(idotsec)
+      implicit none
+      integer idotsec,i,k,j(100),n
+      k=idotsec
+      i=1
+10    j(i)=mod(k,10)
+      k=k/10
+      if(k.gt.0)then
+        i=i+1
+        goto 10
+      endif
+      fdotsec=0.0d0
+      do k=1,i
+        n=10**(i-k+1)
+        fdotsec=fdotsec+dble(j(k))/dble(n)
+      enddo
+      return
+      end
+
+      integer function isitnaninf(x)
+!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
+      implicit none
+      double precision x
+      isitnaninf=1
+      if((x+1.0d0).gt.x)isitnaninf=0
+      if((x+1.0d0).lt.x)isitnaninf=1
+      if((x+1.0d0).eq.x)isitnaninf=1
+      return
+      end
+
       subroutine sort_shell(n,a,iorder)
 !sort array a with the Shell method (from smallest to largest).
 !iorder records the original position of each member.
@@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0
       cubicroot=root2
       return
       end
+
+      subroutine getcubicroot(p,q,r,root1,root2,root3)
+c
+      implicit double precision(a-h,l,o-z)
+      
+c: x^3+p*x^2+q*x+r=0
+      root1=-9999.0d0
+      root2=-9999.0d0
+      root3=-9999.0d0
+
+      capq=(p*p-3.0d0*q)/9.0d0
+      capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
+      if (capr*capr .lt. capq*capq*capq) then
+        rtta=dacos(capr/(dsqrt(capq*capq*capq)))
+        root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
+        
+        root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
+     &        dsqrt(3.0d0))-p/3.0d0
+        root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
+     &        dsqrt(3.0d0))-p/3.0d0
+      else
+        capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
+     &       capq*capq*capq))**(1.0d0/3.0d0)
+        if (dabs(capa) .lt. 1.0d-6) then
+          capb=0.0
+        else
+          capb=capq/capa
+        end if
+        root2 =(capa+capb)-p/3.0d0
+      end if
+      cubicroot=root2
+      return
+      end
+
+
 c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
       subroutine quadraticroots(a,b,c,root1,root2)
       implicit none
@@ -531,7 +617,31 @@ c####################################################################
       do j=1,nsamp
         std=std+(xvar(j)-fmean)*(xvar(j)-fmean)       
       enddo
-      std=dsqrt(std/dble(nsamp-1))
+      std=dsqrt(std/dble(nsamp-1))
+      end
+
+      subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
+      implicit none
+      integer nsamp0,nsamp,j
+      double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
+      nsamp=0
+      do j=1,nsamp0
+        if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
+          nsamp=nsamp+1
+          xvar(nsamp)=xvar0(j)
+        endif
+      enddo
+      fmean=0.0d0
+      do j=1,nsamp
+        fmean=fmean+xvar(j)
+      enddo
+      fmean=fmean/dble(nsamp)
+      std=0.0d0
+      do j=1,nsamp
+        std=std+(xvar(j)-fmean)*(xvar(j)-fmean)       
+      enddo
+      std=dsqrt(std/dble(nsamp-1))
+      cv=std/fmean
       end
 c#######################################################################
       subroutine reinitialization(x0min,x0likely,