      program  ampscheby

c****************************************************************
c**
c**   FILE NAME: diffcheby.f
c**
c**   DATE WRITTEN: //97
c**
c**   PROGRAMMER: Scott Hensley
c**
c**   FUNCTIONAL DESCRIPTION: This program will correct the a file by a
c**   chebyshev fit to a correction set of data.
c**
c**   ROUTINES CALLED:
c**
c**   NOTES:
c**
c**   UPDATE LOG:
c**
c**   Date Changed        Reason Changed                  CR # and Version #
c**   ------------       ----------------                 -----------------
c**
c*****************************************************************

      implicit none

c     INPUT VARIABLES:

c     OUTPUT VARIABLES:

c     LOCAL VARIABLES:
      character*100 a_data,a_out,a_corr,a_string
      real*4 r_val,r_xmax,r_xmin,r_cfit(75),r_j,r_data(2*4000), r_cnt(4000)
      integer i_samples,i_deg,i,j,i_ss,i_es,i_sl,i_el,i_skl,iargc

c     COMMON BLOCKS:
      real*4 r_xch(4000),r_ych(4000)
      integer i_npts
      common /fred/ r_xch,r_ych,i_npts

c     EQUIVALENCE STATEMENTS:

c     DATA STATEMENTS:

C     FUNCTION STATEMENTS:
      real*4 chebev,func

c     PROCESSING STEPS:

      write(6,*) ' '
      write(6,*) ' << Amplitude Chebyshev >> '
      write(6,*) ' '

      if(iargc() .lt. 9)then
         write(6,*) 'Usage: ampfcheby data_file i_samples ss es sl el skl deg out_file'
         write(6,*) ' '
         stop
      endif

      call getarg(1,a_data)
      call getarg(2,a_string)
      read(a_string,*) i_samples
      call getarg(3,a_string)
      read(a_string,*) i_ss
      call getarg(4,a_string)
      read(a_string,*) i_es
      call getarg(5,a_string)
      read(a_string,*) i_sl
      call getarg(6,a_string)
      read(a_string,*) i_el
      call getarg(7,a_string)
      read(a_string,*) i_skl
      call getarg(8,a_string)
      read(a_string,*) i_deg
      call getarg(9,a_out)

      open(11,file=a_data,form='unformatted',access='direct',recl=4*i_samples)
      open(13,file=a_out,form='unformatted',access='direct',recl=4*i_samples)

c     read in data a do chebyshev fit to data

      r_xmin = i_ss
      r_xmax = i_es
      i_deg = 60
      i_npts = 0
      do i=1,4000
         r_cnt(i) = 0
         r_ych(i) = 0
      end do

      do i=i_sl,i_el,i_skl

         read(11,rec=i) (r_data(j),j=1,i_samples)
         i_npts = i_npts + 1

         do j=i_ss,i_es
            r_xch(j) = j
            if(r_data(j) .gt. 1.0)then
               r_cnt(j) = r_cnt(j) + 1
               r_ych(j) = r_ych(j) + r_data(j)
            endif
         enddo

      enddo

      do j=i_ss,i_es
         r_ych(j) = r_ych(j)/max(1.,r_cnt(j))
         write(19,*) j, r_ych(j)
      enddo
      do i=1,i_ss - 1
         r_xch(i) = i
         r_ych(i) = r_ych(i_ss)
      enddo
      i_ss = 1
      do i=i_es+1,i_samples
         r_xch(i) = i
         r_ych(i) = r_ych(i_es)
      enddo
      i_es = i_samples

      i_npts = i_es - i_ss + 1
      r_xmin = .9999
      r_xmax = i_samples
      call chebft(r_xmin,r_xmax,r_cfit,i_deg)

      do i=i_ss,i_es            ! 1,i_npts
         r_val =  chebev(r_xmin,r_xmax,r_cfit,i_deg,r_xch(i))
         write(18,'(3(e11.4,x))') r_xch(i),r_val,r_ych(i)
      enddo

      i=1
      do while(1 .eq. 1)

         read(11,rec=i,err=998) (r_data(j),j=1,i_samples)

         do j=1,i_samples
            r_j = float(j)
            r_val =  chebev(r_xmin,r_xmax,r_cfit,i_deg,r_j)
            if(r_val .ge. 1.0)then
               r_data(j) = r_data(j)/r_val
            endif
         enddo

         write(13,rec=i) (r_data(j),j=1,i_samples)

         i = i + 1

         if(mod(i,250) .eq. 0)then
            write(6,*) 'At line: ',i
         endif

      enddo
 998  continue

      end

c*********************************************************************************

      real*4 function func(x)

      real*4 x,r_f,r_omf
      integer i_loc

      real*4 r_xch(4000),r_ych(4000)
      integer i_npts
      common /fred/ r_xch,r_ych,i_npts

      call hunt(r_xch,i_npts,x,i_loc)
      i_loc = min(max(1,i_loc),i_npts-1)

      r_f = (x - r_xch(i_loc))/(r_xch(i_loc+1)-r_xch(i_loc))
      r_omf = 1.d0 - r_f

      if(r_f .gt. 1 .or. r_f .lt. 0)then
         func = r_ych(i_loc)
         return
      endif

      func = r_omf*r_ych(i_loc) + r_f*r_ych(i_loc+1)

      end

      SUBROUTINE chebft(a,b,c,n)
      INTEGER n,NMAX
      REAL a,b,c(*),func,PI
      EXTERNAL func
      PARAMETER (NMAX=75, PI=3.141592653589793d0)
      INTEGER j,k
      REAL bma,bpa,fac,y,f(NMAX)
      DOUBLE PRECISION sum

      bma=0.5*(b-a)
      bpa=0.5*(b+a)
      do 11 k=1,n
        y=cos(PI*(k-0.5)/n)
        f(k)=func(y*bma+bpa)
11    continue

      fac=2./n
      do 13 j=1,n
        sum=0.d0
        do 12 k=1,n
          sum=sum+f(k)*cos((PI*(j-1))*((k-0.5d0)/n))
12      continue
        c(j)=fac*sum
13    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software $23#1yR.3Z9.

      FUNCTION chebev(a,b,c,m,x)
      INTEGER m
      REAL chebev,a,b,x,c(m)
      INTEGER j
      REAL d,dd,sv,y,y2
      if ((x-a)*(x-b).gt.0.) pause 'x not in range in chebev'
      d=0.
      dd=0.
      y=(2.*x-a-b)/(b-a)
      y2=2.*y
      do 11 j=m,2,-1
        sv=d
        d=y2*d-dd+c(j)
        dd=sv
11    continue
      chebev=y*d-dd+0.5*c(1)
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software $23#1yR.3Z9.

      SUBROUTINE hunt(xx,n,x,jlo)
      INTEGER jlo,n
      REAL x,xx(n)
      INTEGER inc,jhi,jm
      LOGICAL ascnd
      ascnd=xx(n).gt.xx(1)
      if(jlo.le.0.or.jlo.gt.n)then
        jlo=0
        jhi=n+1
        goto 3
      endif
      inc=1
      if(x.ge.xx(jlo).eqv.ascnd)then
1       jhi=jlo+inc
        if(jhi.gt.n)then
          jhi=n+1
        else if(x.ge.xx(jhi).eqv.ascnd)then
          jlo=jhi
          inc=inc+inc
          goto 1
        endif
      else
        jhi=jlo
2       jlo=jhi-inc
        if(jlo.lt.1)then
          jlo=0
        else if(x.lt.xx(jlo).eqv.ascnd)then
          jhi=jlo
          inc=inc+inc
          goto 2
        endif
      endif
3     if(jhi-jlo.eq.1)return
      jm=(jhi+jlo)/2
      if(x.gt.xx(jm).eqv.ascnd)then
        jlo=jm
      else
        jhi=jm
      endif
      goto 3
      END
C  (C) Copr. 1986-92 Numerical Recipes Software $23#1yR.3Z9.


      SUBROUTINEFOURN1(DATA,DL,DM,ISIGN)
      IMPLICITNONE
      CHARACTERID_X*(36)
      DATAID_X/'!@(#) four2.f    23/08/91 v3.01 >'/
      REALDATA(*)
      INTEGERDL,DM,ISIGN
      REAL*8WR,WI,WPR,WPI,WTEMP,THETA
      integeri1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2
      integerip1,ip2,ip3,itot,k1,k2,n,nprev,nrem,ntot
      realfac,tempi,tempr
      if(isign.eq.0)return
      NTOT=DL*DM
      if(isign.gt.0)then
      fac=1.0/float(ntot)
      DO102itot=1,2*ntot
      data(itot)=fac*data(itot)
  102 CONTINUE
      endif
      NPREV=1
      N=DL
      DO18IDIM=1,2
      NREM=NTOT/(N*NPREV)
      IP1=2*NPREV
      IP2=IP1*N
      IP3=IP2*NREM
      I2REV=1
      DO14I2=1,IP2,IP1
      IF(I2.LT.I2REV)THEN
      DO13I1=I2,I2+IP1-2,2
      DO12I3=I1,IP3,IP2
      I3REV=I2REV+I3-I2
      TEMPR=DATA(I3)
      TEMPI=DATA(I3+1)
      DATA(I3)=DATA(I3REV)
      DATA(I3+1)=DATA(I3REV+1)
      DATA(I3REV)=TEMPR
      DATA(I3REV+1)=TEMPI
   12 CONTINUE
   13 CONTINUE
      ENDIF
      IBIT=IP2/2
    1 IF((IBIT.GE.IP1).AND.(I2REV.GT.IBIT))THEN
      I2REV=I2REV-IBIT
      IBIT=IBIT/2
      GOTO1
      ENDIF
      I2REV=I2REV+IBIT
   14 CONTINUE
      IFP1=IP1
    2 IF(IFP1.LT.IP2)THEN
      IFP2=2*IFP1
      THETA=ISIGN*6.28318530717959D0/(IFP2/IP1)
      WPR=-2.D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      WR=1.D0
      WI=0.D0
      DO17I3=1,IFP1,IP1
      DO16I1=I3,I3+IP1-2,2
      DO15I2=I1,IP3,IFP2
      K1=I2
      K2=K1+IFP1
      TEMPR=SNGL(WR)*DATA(K2)-SNGL(WI)*DATA(K2+1)
      TEMPI=SNGL(WR)*DATA(K2+1)+SNGL(WI)*DATA(K2)
      DATA(K2)=DATA(K1)-TEMPR
      DATA(K2+1)=DATA(K1+1)-TEMPI
      DATA(K1)=DATA(K1)+TEMPR
      DATA(K1+1)=DATA(K1+1)+TEMPI
   15 CONTINUE
   16 CONTINUE
      WTEMP=WR
      WR=WR*WPR-WI*WPI+WR
      WI=WI*WPR+WTEMP*WPI+WI
   17 CONTINUE
      IFP1=IFP2
      GOTO2
      ENDIF
      NPREV=N*NPREV
      N=DM
   18 CONTINUE
      RETURN
      END


C     This File is Automatically generated by ALOHA
C     The process calculated in this file is:
C     ProjM(2,1)
C
      SUBROUTINE FFS1_1(F2, S3, COUP, M1, W1,F1)
      IMPLICIT NONE
      COMPLEX*16 CI
      PARAMETER (CI=(0D0,1D0))
      COMPLEX*16 F2(*)
      COMPLEX*16 S3(*)
      REAL*8 P1(0:3)
      REAL*8 M1
      REAL*8 W1
      COMPLEX*16 F1(6)
      COMPLEX*16 DENOM
      COMPLEX*16 COUP
      F1(1) = +F2(1)+S3(1)
      F1(2) = +F2(2)+S3(2)
      P1(0) = -DBLE(F1(1))
      P1(1) = -DBLE(F1(2))
      P1(2) = -DIMAG(F1(2))
      P1(3) = -DIMAG(F1(1))
      DENOM = COUP/(P1(0)**2-P1(1)**2-P1(2)**2-P1(3)**2 - M1 * (M1 -CI
     $ * W1))
      F1(3)= DENOM*CI * F2(3)*S3(3)*M1
      F1(4)= DENOM*CI * F2(4)*S3(3)*M1
      F1(5)= DENOM*CI * S3(3)*(F2(3)*(P1(3)-P1(0))+F2(4)*(P1(1)+CI
     $ *(P1(2))))
      F1(6)= DENOM*(-CI )* S3(3)*(F2(3)*(+CI*(P1(2))-P1(1))+F2(4)
     $ *(P1(0)+P1(3)))
      END

C     This File is Automatically generated by ALOHA
C     The process calculated in this file is:
C     ProjM(2,1)
C
      SUBROUTINE FFS1_2_1(F2, S3, COUP1, COUP2, M1, W1,F1)
      IMPLICIT NONE
      COMPLEX*16 CI
      PARAMETER (CI=(0D0,1D0))
      COMPLEX*16 F2(*)
      COMPLEX*16 S3(*)
      REAL*8 P1(0:3)
      REAL*8 M1
      REAL*8 W1
      COMPLEX*16 F1(6)
      COMPLEX*16 COUP1
      COMPLEX*16 DENOM
      COMPLEX*16 COUP2
      INTEGER*4 I
      COMPLEX*16 FTMP(6)
      CALL FFS1_1(F2,S3,COUP1,M1,W1,F1)
      CALL FFS2_1(F2,S3,COUP2,M1,W1,FTMP)
      DO I = 3, 6
        F1(I) = F1(I) + FTMP(I)
      ENDDO
      END


module minpack
implicit none

interface

    double precision function dpmpar(i)
    integer i
    end function

    double precision function enorm(n,x)
    integer n
    double precision x(n)
    end function

    !> The purpose of `hybrd` is to find a zero of a system of N non-
    !>  linear functions in N variables by a modification of the Powell
    !>  hybrid method.  The user must provide a subroutine which calcu-
    !>  lates the functions.  The Jacobian is then calculated by a for-
    !>  ward-difference approximation.
    subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, &
                         mode,factor,nprint,info,nfev,fjac,ldfjac, &
                         r,lr,qtf,wa1,wa2,wa3,wa4)
        integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr
        double precision xtol,epsfcn,factor
        double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),qtf(n), &
                         wa1(n),wa2(n),wa3(n),wa4(n)
        interface
            subroutine fcn(n,x,fvec,iflag)
                integer n,iflag
                double precision x(n),fvec(n)
            end subroutine fcn
        end interface
    end subroutine hybrd

    !> The purpose of `hybrd1` is to find a zero of a system of
    !>  n nonlinear functions in n variables by a modification
    !>  of the powell hybrid method.
    subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa)
        integer n,info,lwa
        double precision tol
        double precision x(n),fvec(n),wa(lwa)
        interface
            subroutine fcn(n,x,fvec,iflag)
                integer n,iflag
                double precision x(n),fvec(n)
            end subroutine fcn
        end interface
    end subroutine hybrd1

    subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,lwa)
    integer m,n,ldfjac,info,lwa
    integer ipvt(n)
    double precision tol
    double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa)
    interface
        subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag)
        implicit none
        integer, intent(in) :: m,n,ldfjac,iflag
        double precision, intent(in) :: x(n)
        double precision, intent(out) :: fvec(m),fjac(ldfjac,n)
        end subroutine
    end interface
    end subroutine

    subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)
    integer m,n,info,lwa
    integer iwa(n)
    double precision tol
    double precision x(n),fvec(m),wa(lwa)
    interface
        subroutine fcn(m,n,x,fvec,iflag)
        implicit none
        integer, intent(in) :: m,n,iflag
        double precision, intent(in) :: x(n)
        double precision, intent(out) :: fvec(m)
        end subroutine
    end interface
    end subroutine

    subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err)
    integer m,n,ldfjac,mode
    double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m),err(m)
    end subroutine

end interface

contains

end module


      DOUBLE PRECISION FUNCTION gam1(a)
C     ------------------------------------------------------------------
C     COMPUTATION OF 1/GAMMA(A+1) - 1  FOR -0.5 .LE. A .LE. 1.5
C     ------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION bot,d,s1,s2,t,top,w
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION p(7),q(5),r(9)
C     ..
C     .. Data statements ..
C     -------------------
C     -------------------
C     -------------------
C     -------------------
      DATA p(1)/.577215664901533D+00/,p(2)/-.409078193005776D+00/,
     +     p(3)/-.230975380857675D+00/,p(4)/.597275330452234D-01/,
     +     p(5)/.766968181649490D-02/,p(6)/-.514889771323592D-02/,
     +     p(7)/.589597428611429D-03/
      DATA q(1)/.100000000000000D+01/,q(2)/.427569613095214D+00/,
     +     q(3)/.158451672430138D+00/,q(4)/.261132021441447D-01/,
     +     q(5)/.423244297896961D-02/
      DATA r(1)/-.422784335098468D+00/,r(2)/-.771330383816272D+00/,
     +     r(3)/-.244757765222226D+00/,r(4)/.118378989872749D+00/,
     +     r(5)/.930357293360349D-03/,r(6)/-.118290993445146D-01/,
     +     r(7)/.223047661158249D-02/,r(8)/.266505979058923D-03/,
     +     r(9)/-.132674909766242D-03/
      DATA s1/.273076135303957D+00/,s2/.559398236957378D-01/
C     ..
C     .. Executable Statements ..
C     -------------------
      t = a
      d = a - 0.5D0
      IF (d.GT.0.0D0) t = d - 0.5D0
      if (t .lt. 0) then
         goto 40
      elseif (t .eq. 0) then
         goto 10
      else
         goto 20
      endif
C
   10 gam1 = 0.0D0
      RETURN
C
   20 top = (((((p(7)*t+p(6))*t+p(5))*t+p(4))*t+p(3))*t+p(2))*t + p(1)
      bot = (((q(5)*t+q(4))*t+q(3))*t+q(2))*t + 1.0D0
      w = top/bot
      IF (d.GT.0.0D0) GO TO 30
      gam1 = a*w
      RETURN

   30 gam1 = (t/a)* ((w-0.5D0)-0.5D0)
      RETURN
C
   40 top = (((((((r(9)*t+r(8))*t+r(7))*t+r(6))*t+r(5))*t+r(4))*t+r(3))*
     +      t+r(2))*t + r(1)
      bot = (s2*t+s1)*t + 1.0D0
      w = top/bot
      IF (d.GT.0.0D0) GO TO 50
      gam1 = a* ((w+0.5D0)+0.5D0)
      RETURN

   50 gam1 = t*w/a
      RETURN

      END


      SUBROUTINE SFCDIF (ZLM,Z0,THZ0,THLM,SFCSPD,CZIL,AKMS,AKHS)

      IMPLICIT NONE

c  NOTE: Potential temperatures at 1-st soil layer, THZ0, and 1-st
c        atmospheric layer, THLM, should be calculated before calling this
c        subroutine:  THZ0=TSOIL1 * (1.0+0.61*q2)
c                     THLM=(SFCTMP + (0.0098*ZLM)) * (1.0+0.61*q2)
c  ZLM - HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES
c        if wind speed measured at different hight than temperature,
c        it should be adjusted to temperature hight
c  Z0  - roughness coefficient of the surface
c  SFCSPD - wind speed, m/s
c  CZIL - Zilitinkevich parameter(from REDPRM subroutine)
c
C ----------------------------------------------------------------------
C SUBROUTINE SFCDIF
C ----------------------------------------------------------------------
C CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS:
c  momentum coefficient (drage coefficient), AKMS, (CM in main program)
c  heat exchange coefficient, AKHS, (CH in main program)
C SEE CHEN ET AL (1997, BLM)
C ----------------------------------------------------------------------

      REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW
      REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, SQVISC
      REAL RIC, RRIC, FHNEU, RFC, RFAC, ZZ, PSLMU, PSLMS, PSLHU, PSLHS
      REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM
      REAL SFCSPD, CZIL, AKMS, AKHS, ZILFC, ZU, ZT, RDZ, CXCH
      REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT
      REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4
      REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, RLMA

      INTEGER ITRMX, ILECH, ITR

      PARAMETER
     &     (WWST=1.2,WWST2=WWST*WWST,G=9.8,VKRM=0.40,EXCM=0.001
     &     ,BETA=1./270.,BTG=BETA*G,ELFC=VKRM*BTG
     &     ,WOLD=.15,WNEW=1.-WOLD,ITRMX=05,PIHF=3.14159265/2.)

C ----------------------------------------------------------------------
      PARAMETER
     &     (EPSU2=1.E-4,EPSUST=0.07,EPSIT=1.E-4,EPSA=1.E-8
     &     ,ZTMIN=-5.,ZTMAX=1.,HPBL=1000.0
     &     ,SQVISC=258.2)
C ----------------------------------------------------------------------
      PARAMETER
     &     (RIC=0.183,RRIC=1.0/RIC,FHNEU=0.8,RFC=0.191
     &     ,RFAC=RIC/(FHNEU*RFC*RFC))

C ----------------------------------------------------------------------
C NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS
C ----------------------------------------------------------------------
C LECH'S SURFACE FUNCTIONS
C ----------------------------------------------------------------------
      PSLMU(ZZ)=-0.96*log(1.0-4.5*ZZ)
      PSLMS(ZZ)=ZZ*RRIC-2.076*(1.-1./(ZZ+1.))
      PSLHU(ZZ)=-0.96*log(1.0-4.5*ZZ)
      PSLHS(ZZ)=ZZ*RFAC-2.076*(1.-1./(ZZ+1.))

C ----------------------------------------------------------------------
C PAULSON'S SURFACE FUNCTIONS
C ----------------------------------------------------------------------
      PSPMU(XX)=-2.*log((XX+1.)*0.5)-log((XX*XX+1.)*0.5)+2.*ATAN(XX)
     &     -PIHF
      PSPMS(YY)=5.*YY
      PSPHU(XX)=-2.*log((XX*XX+1.)*0.5)
      PSPHS(YY)=5.*YY

C ----------------------------------------------------------------------
C THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND
C OVER SOLID SURFACE (LAND, SEA-ICE).
C ----------------------------------------------------------------------
      ILECH=0

C ----------------------------------------------------------------------
C     ZTFC: RATIO OF ZOH/ZOM  LESS OR EQUAL THAN 1
C     C......ZTFC=0.1
C     CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT
C ----------------------------------------------------------------------
      ZILFC=-CZIL*VKRM*SQVISC

C ----------------------------------------------------------------------
      ZU=Z0
C     C.......ZT=Z0*ZTFC
      RDZ=1./ZLM
      CXCH=EXCM*RDZ
      DTHV=THLM-THZ0
      DU2=MAX(SFCSPD*SFCSPD,EPSU2)

C ----------------------------------------------------------------------
C BELJARS CORRECTION OF USTAR
C ----------------------------------------------------------------------
      BTGH=BTG*HPBL
ccc   If statements to avoid TANGENT LINEAR problems near zero
      IF (BTGH*AKHS*DTHV .NE. 0.0) THEN
         WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.)
      ELSE
         WSTAR2=0.0
      ENDIF
      USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST)

C ----------------------------------------------------------------------
C ZILITINKEVITCH APPROACH FOR ZT
C ----------------------------------------------------------------------
      ZT=EXP(ZILFC*SQRT(USTAR*Z0))*Z0
      !added by Shugong to as a temperatory fix
      if(ZT<1e-6) ZT=1e-6
C ----------------------------------------------------------------------
      ZSLU=ZLM+ZU
      ZSLT=ZLM+ZT
C
      RLOGU=log(ZSLU/ZU)
      RLOGT=log(ZSLT/ZT)
C
      RLMO=ELFC*AKHS*DTHV/USTAR**3

      DO ITR=1,ITRMX
C ----------------------------------------------------------------------
C 1./MONIN-OBUKKHOV LENGTH-SCALE
C ----------------------------------------------------------------------
         ZETALT=MAX(ZSLT*RLMO,ZTMIN)
         RLMO=ZETALT/ZSLT
         ZETALU=ZSLU*RLMO
         ZETAU=ZU*RLMO
         ZETAT=ZT*RLMO

         IF(ILECH.EQ.0) THEN
            IF(RLMO.LT.0.)THEN
               XLU4=1.-16.*ZETALU
               XLT4=1.-16.*ZETALT
               XU4 =1.-16.*ZETAU
               XT4 =1.-16.*ZETAT
               XLU=SQRT(SQRT(XLU4))
               XLT=SQRT(SQRT(XLT4))
               XU =SQRT(SQRT(XU4))
               XT =SQRT(SQRT(XT4))
               PSMZ=PSPMU(XU)
               SIMM=PSPMU(XLU)-PSMZ+RLOGU
               PSHZ=PSPHU(XT)
               SIMH=PSPHU(XLT)-PSHZ+RLOGT
            ELSE
               ZETALU=MIN(ZETALU,ZTMAX)
               ZETALT=MIN(ZETALT,ZTMAX)
               PSMZ=PSPMS(ZETAU)
               SIMM=PSPMS(ZETALU)-PSMZ+RLOGU
               PSHZ=PSPHS(ZETAT)
               SIMH=PSPHS(ZETALT)-PSHZ+RLOGT
            ENDIF
         ELSE
C ----------------------------------------------------------------------
C LECH'S FUNCTIONS
C ----------------------------------------------------------------------
            IF(RLMO.LT.0.)THEN
               PSMZ=PSLMU(ZETAU)
               SIMM=PSLMU(ZETALU)-PSMZ+RLOGU
               PSHZ=PSLHU(ZETAT)
               SIMH=PSLHU(ZETALT)-PSHZ+RLOGT
            ELSE
               ZETALU=MIN(ZETALU,ZTMAX)
               ZETALT=MIN(ZETALT,ZTMAX)

               PSMZ=PSLMS(ZETAU)
               SIMM=PSLMS(ZETALU)-PSMZ+RLOGU
               PSHZ=PSLHS(ZETAT)
               SIMH=PSLHS(ZETALT)-PSHZ+RLOGT
            ENDIF
         ENDIF
C ----------------------------------------------------------------------
C BELJAARS CORRECTION FOR USTAR
C ----------------------------------------------------------------------
         USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST)

C ----------------------------------------------------------------------
C ZILITINKEVITCH FIX FOR ZT
C ----------------------------------------------------------------------
         ZT=EXP(ZILFC*SQRT(USTAR*Z0))*Z0
         !added by Shugong to as a temperatory fix
         if(ZT<1e-6) ZT=1e-6

         ZSLT=ZLM+ZT
         RLOGT=log(ZSLT/ZT)
C-----------------------------------------------------------------------
         USTARK=USTAR*VKRM
         AKMS=MAX(USTARK/SIMM,CXCH)
         AKHS=MAX(USTARK/SIMH,CXCH)
C-----------------------------------------------------------------------
C IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO
C-----------------------------------------------------------------------
         IF (BTGH*AKHS*DTHV .NE. 0.0) THEN
            WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.)
         ELSE
            WSTAR2=0.0
         ENDIF
         RLMN=ELFC*AKHS*DTHV/USTAR**3
C-----------------------------------------------------------------------
         RLMA=RLMO*WOLD+RLMN*WNEW
C-----------------------------------------------------------------------
C     IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT)    GO TO 110
C-----------------------------------------------------------------------
         RLMO=RLMA
C-----------------------------------------------------------------------

      END DO

C ----------------------------------------------------------------------
C END SUBROUTINE SFCDIF
C ----------------------------------------------------------------------
      RETURN
      END


        subroutine augment(e, l, xj, phi, v, nr, r, dl)
        implicit real*8 (a-h, o-z)
        parameter (nrmax = 4000)
        dimension phi(nrmax), phi2(nrmax), v(nrmax), r(nrmax)
        c = 137.038d0
        cc = c * c
        c2 = cc + cc
        xkappa = -1
        if (dabs(xj) .gt. dfloat(l) + 0.25d0) xkappa = -l-1
        if (dabs(xj) .lt. dfloat(l) - 0.25d0) xkappa =  l
        do j = 4, nr - 3
          if (phi(j) .ne. 0.d0) then                                     // ***
            g0 =  phi(j)                                                 // ***
            ga = (phi(j + 1) - phi(j - 1))                               // ***
            gb = (phi(j + 2) - phi(j - 2)) / 2.d0                        // ***
            gc = (phi(j + 3) - phi(j - 3)) / 3.d0                        // ***
            gg = ((1.5d0 * ga - 0.6d0 * gb + 0.1d0 * gc)                 // ***
     1            / (2.d0 * dl) + xkappa * g0) / r(j)                    // ***
            f0 = c * gg / (e - v(j) + c2)                                // ***
            phi2(j) = dsqrt(g0 * g0 + f0 * f0)                           // ***
            if (g0 .lt. 0.d0) phi2(j) = -phi2(j)                         // ***
          else
            phi2(j) = phi(j)                                             // ***
          endif
         enddo
c Alternative
c saves 3 '/' out of 5, 1 '*' out of 8, 1 '+' and one reference to phi(j)
c        dlover = 0.75d0 / dl
c        ec2 = e + c2
c        do j = 4, nr - 3
c          if (phi(j) .ne. 0.d0) then
c            g0 =  phi(j)
c            ga = (phi(j + 1) - phi(j - 1))
c            gb = (phi(j + 2) - phi(j - 2)) * 0.20d0
c            gc = (phi(j + 3) - phi(j - 3)) * 0.0125d0
c            gg = ((ga - gb + gc) * dlover + xkappa * g0) / r(j)
c            f0 = c * gg / (ec2 - v(j))
c            phi2(j) = dsqrt(g0 * g0 + f0 * f0)
c            if (g0 .lt. 0.d0) phi2(j) = -phi2(j)
c          else
c            phi2(j) = 0.0d0
c          endif
c        enddo

        do j = 1, 3
          phi2(j) = phi(j) * phi(4) / phi2(4)
        enddo
        do j = 1,  nr
          phi(j) = phi2(j)                                               // ***
        enddo
        return
        end


      subroutine potran(i,vd,r,nr,zion,a,b,c)
c
c ***********************************************************
c *                                                         *
c *    This is a plotting routine; the user should adjust   *
c *  for their own needs.  The potential is fitted with a   *
c *  second degree polynomial, which is muliplied with the  *
c *  appropriate functions and then integrated by parts     *
c *  to find the fourier transform.  The result is then     *
c *  printed to the current plot.dat file (unit=3) for      *
c *  later plotting.  A marker(marker fn#) is placed at     *
c *  the end of each set of data.                           *
c *                                                         *
c ***********************************************************
c
      implicit real*8 (a-h,o-z)
c
      parameter (zero=0.0d0,one=1.0d0)
c
      dimension vd(nr),r(nr),a(nr),b(nr),c(nr),vql(100)
c
c  The potential times r is fitted to the polynominal
c  a + bx + cx^2 at every other point.
c
      rm=zero
      vm=2*zion
      do 130 k=2,nr,2
        r0=r(k)
        v0=r0*vd(k)+2*zion
        rp=r(k+1)
        vp=rp*vd(k+1)+2*zion
        d1=1/((rp-rm)*(r0-rm))
        d2=1/((rp-r0)*(rm-r0))
        d3=1/((r0-rp)*(rm-rp))
        a(k)=vm*d1+v0*d2+vp*d3
        b(k)=-vm*(r0+rp)*d1-v0*(rm+rp)*d2-vp*(rm+r0)*d3
        c(k)=vm*r0*rp*d1+v0*rm*rp*d2+vp*rm*r0*d3
        rm=rp
        vm=vp
 130  continue
c
c  Find the fourier transform q^2/4pi/zion*vql. Everything is
c  rescaled  by zion.
c
      do 150 j=1,94
        q=one/4*j
        q2=q*q
        vql(j)=zero
        rm=zero
        do 140 k=2,nr-1,2
          rp=r(k+1)
          vql(j)=vql(j)+(2*a(k)*rp+b(k))/q*sin(q*rp)
     1     -((a(k)*rp+b(k))*rp+c(k)-2*a(k)/q2)*cos(q*rp)
     2     -(2*a(k)*rm+b(k))/q*sin(q*rm)
     3     +((a(k)*rm+b(k))*rm+c(k)-2*a(k)/q2)*cos(q*rm)
          rm=rp
 140    continue
        vql(j)=vql(j)/2/zion-one
 150  continue
c
c  Print out the transforms( really q^2/(4pi*zion)*v(q) ) to
c  the current plot.dat file (unit=3) for latter plotting.
c
      do 170 j=1,48
        write(3,6000)one/4*j,vql(j)
 170  continue
      write(3,6008)i
      return
c
c  format statements
c
 6000 format(1x,f7.4,3x,f10.6)
 6008 format(1x,'marker fn',i1)
c
      end


program example3
  integer, dimension(10) :: a
  integer :: i

  do i = 3, 8
    != stencil readOnce, centered(dim=1, depth=2) :: a
    a(i) = a(i-2) + a(i-1) + a(i) + a(i+2)
  end do
end program example3