subroutine get_alphas(Q, Y, sigma, n_alphas, alphas)

    implicit none

    double precision, dimension(:,:), intent(in) :: Q
    double precision, dimension(:), intent(in):: Y
    integer, intent(in):: n_alphas
    double precision, intent(in):: sigma

    double precision, dimension(n_alphas), intent(out) :: alphas

    double precision, allocatable, dimension(:,:) :: b

    integer :: m, n, nrhs, lda, ldb, info
    integer :: na
    integer :: i, j

    integer :: lwork
    double precision, dimension(:), allocatable :: work
    double precision, dimension(:,:), allocatable :: K

    write (*,*) size(Q, dim=1)
    write (*,*) size(Q, dim=2)

    na = size(Q, dim=1)

    allocate(K(na,na))

    do i = 1, na
        do j = 1, na
            K(j,i) = exp(-sum(abs(Q(j,:) - Q(i,:)))/sigma)
        enddo
    enddo

    m = size(K, dim=1)
    n = size(K, dim=2)

    nrhs = 1
    lda = m
    ldb = max(m,n)

    allocate(b(ldb,1))
    b = 0.0d0
    b(:m,1) = y(:m)

    lwork = (min(m,n) + max(m,n)) * 10
    allocate(work(lwork))

    call dgels("N", m, n, nrhs, K, lda, b, ldb, work, lwork, info)

    alphas(:n) = b(:n,1)

    deallocate(work)
    deallocate(b)

end subroutine get_alphas

subroutine write_input(Q, Y, sigma)

    implicit none

    double precision, dimension(:,:), intent(in) :: Q
    double precision, dimension(:), intent(in):: Y
    double precision, intent(in):: sigma

    integer :: rep_size
    integer :: n_molecules

    integer :: i

    n_molecules = size(Q, dim=1)
    rep_size = size(Q, dim=2)

    open(unit = 9, file = "parameters.fout", form="formatted")

    write (9,*) sigma, rep_size, n_molecules
    write (9,*) Y(:n_molecules)
    close(9)

    open(unit = 9, file = "representations.fout", form="formatted")

    do i=1, n_molecules

        write(9,*) Q(i,:rep_size)

    enddo

    close(9)

end subroutine write_input


        subroutine cleanrec(ix,n,nchp1,ich,scale,ixout,ixplt,pscale
     1  ,nmad,iuscale)

c       point cleaning routine; uses running meadians to look for
c       large isolated glitches (e.g. parity errors); input is nchp1
c       channels of data (first channel is assumed to be record number)
c       stored in array ix; the number of points to be cleaned is n
c       (this is also the length of the running median window) the
c       points to be cleaned should have (n-1)/2 adjacent points on either
c       side: the first record to be cleaned should be ix(.,1) - i.e. in
c       the call to this routine if records k to k+n-1 in array ixx are
c       to be cleaned (here ix is array in calling program) then the
c       first argument in the call statement should be ixx(1,k));  scale
c       is input and is used to find the minimum deviation from the median
c       required for a point to be considered bad (algorithm will adjust
c       scale if the median absolute deviation (mad) is larger); the output
c       is (1) ixout - array of n cleaned records; (2) xplt  -  2 x nchp1 array
c       for plotting - for each channel the two points are the meadian
c       minus and plus one mad (first channel is median record number)

c       if iuscale = 0 works as described above; if not the mad is replaced
c       by the ith order statistic of the absolute deviations; for use with
c       cleaning of first differences use iuscale = n-1

        parameter (nmax =20)

c       nmax is maximum n which can be used with routine; nmad (multiplied
c       times maximum of scale or mad) is maximum deviation allowed before
c       point is fixed

        integer ix(nchp1,*),ixout(nchp1,n),iwrk1(nmax),iwrk2(nmax)
     1       ,ixplt(2)
        real scale(nchp1),pscale(nchp1)

        nmed = (n+1)/2
        nmed1 = nmed - 1
        if(iuscale.eq.0) iuscale = nmed

c       copy data into array iwrk1, sort and check

           do 10 j = 1,n
10         iwrk1(j) =  ix(ich,j)

        call isort(iwrk1,n)

        med = iwrk1(nmed)

           do 15 j = 1,n
15         iwrk2(j) = iabs(iwrk1(j) - med)

        call isort(iwrk2,n)

        mad = iwrk2(iuscale)
        maxd = iwrk2(n)
        madmax = max(mad,nmad)

c       compute plotting coordinates

        pmad = pscale(ich)*mad*2.
        ixplt(1) = med
        ixplt(2) = pmad

        if(maxd.le.madmax) then

c       maximum deviation is small enough to consisder all points ok;
c       compute outputs for this channel

           do 20 j = 1,n
20         ixout(ich,j) = ix(ich,j)

           go to 100
           end if

c       else need to check each point; first center point

        rscale = max(scale(ich),float(mad))*nmad
        itemp = ix(ich,nmed)-med
        if(iabs(itemp).gt.rscale) then
c     fix point

        iii = isign(1,itemp)
        ixout(ich,nmed) = (iwrk1(nmed)+iwrk1(nmed-iii))/2
cpin    print*, 'point fixed; ch. = ',ich,'rec. =',ix(1,nmed)
cpin    print*,'rscale',rscale,'deviation = ',itemp
cpin    print*,'iwrk2',iwrk2

       else
           ixout(ich,nmed) = ix(ich,nmed)
       end if

c       now do other points

        do 50 l =1,nmed1
           l1 = 1-l
           l2 = n-l
              do 30 j = l1,l2
30            iwrk1(j+l) = ix(ich,j)

           itemp = iwrk1(nmed)
           call isort(iwrk1,n)

           med = iwrk1(nmed)

              do 35 j = 1,n
35            iwrk2(j) = iabs(iwrk1(j) - med)

           call isort(iwrk2,n)

           mad = iwrk2(iuscale)

           rscale = max(scale(ich),float(mad))*nmad
           itemp = itemp-med
           if(iabs(itemp).gt.rscale) then

c     fix point

              iii = isign(1,itemp)
cpin          print*, 'point fixed; ch. = ',ich,'rec.=',ix(1,nmed-l)
cpin          print*,'rscale',rscale,'deviation = ',itemp
cpin          print*,'iwrk2',iwrk2

              ixout(ich,nmed-l) = (iwrk1(nmed)+iwrk1(nmed-iii))/2
          else
              ixout(ich,nmed-l) = ix(ich,nmed-l)
          end if

           l1 = 1+l
           l2 = n+l
              do 40 j = l1,l2
40            iwrk1(j-l) = ix(ich,j)

           itemp = iwrk1(nmed)
           call isort(iwrk1,n)

           med = iwrk1(nmed)

              do 45 j = 1,n
45            iwrk2(j) = iabs(iwrk1(j) - med)

           call isort(iwrk2,n)

           mad = iwrk2(iuscale)

           rscale = max(scale(ich),float(mad))*nmad
           itemp = itemp-med
           if(iabs(itemp).gt.rscale) then

c     fix point

cpin          print*, 'point fixed; ch. = ',ich,'rec.=',ix(1,nmed+l)
cpin          print*,'rscale',rscale,'deviation = ',itemp
cpin          print*,'iwrk2',iwrk2

              iii = isign(1,itemp)
              ixout(ich,nmed+l) = (iwrk1(nmed)+iwrk1(nmed-iii))/2
          else
              ixout(ich,nmed+l) = ix(ich,nmed+l)
          end if
50      continue

100     continue

        return
        end


program demo_dnum0
use M_calculator, only : dnum0
implicit none
doubleprecision :: x,y,z
   X=DNUM0('20/3.4')
   Y=DNUM0('CI = 10 * sin(3.1416/4)')
   Z=DNUM0('CI')
   write(*,*)x,y,z
end program demo_dnum0


!==========================================================================
elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct)
! =========================================================================
!
!  Calculates the following two partial derivatives of potential temperature
!  (the regular potential temperature whose reference sea pressure is 0 dbar)
!  (1) pt_SA, the derivative with respect to Absolute Salinity at
!       constant Conservative Temperature, and
!  (2) pt_CT, the derivative with respect to Conservative Temperature at
!       constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!
!  pt_SA =  The derivative of potential temperature with respect to
!           Absolute Salinity at constant Conservative Temperature.
!                                                               [ K/(g/kg)]
!  pt_CT =  The derivative of potential temperature with respect to
!           Conservative Temperature at constant Absolute Salinity.
!           pt_CT is dimensionless.                            [ unitless ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_t0

use gsw_mod_toolbox, only : gsw_gibbs, gsw_pt_from_ct

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct
real (r8), intent(out), optional :: pt_sa, pt_ct

real (r8) :: abs_pt, ct_pt, ct_sa, pt

integer, parameter :: n0=0, n1=1, n2=2
real (r8), parameter :: pr0 = 0.0_r8

pt = gsw_pt_from_ct(sa,ct)
abs_pt = (gsw_t0 + pt)

ct_pt = -(abs_pt*gsw_gibbs(n0,n2,n0,sa,pt,pr0))/gsw_cp0

if (present(pt_sa)) then

    ct_sa = (gsw_gibbs(n1,n0,n0,sa,pt,pr0) -&
                abs_pt*gsw_gibbs(n1,n1,n0,sa,pt,pr0))/gsw_cp0

    pt_sa = -ct_sa/ct_pt

end if

if (present(pt_ct)) pt_ct = 1.0_r8/ct_pt

return
end subroutine

!--------------------------------------------------------------------------


      subroutine jacobian
#     include "basics.inc"
      common
C
      nx3 = 2
      ny3 = 2
      nz3 = 2
      if (ndim.eq.2) nz3=1
c
      call zwgll(z3,w3,nx3)
      call dgll (dxm3,dxmt3,
c

      NXY3  = NX3*NY3
      NYZ3  = NY3*NZ3
      NXYZ3 = NX3*NY3*NZ3
      NTOT3 = NXYZ3*NELT
      NXYZ1 = NX1*NY1*NZ1
      NTOT1 = NXYZ1*NELT
C
C
C     Compute isoparametric partials.
C
      IF (NDIM.EQ.2) THEN
C
C     Two-dimensional case
C
      DO 200 ie=1,NELT
C
C     Use the appropriate derivative- and interpolation operator in
C     the y-direction (= radial direction if axisymmetric).
C
      IF (IFAXIS) THEN
         NY33   = NY3*NY3
         IF (IFRZER(ie)) THEN
            CALL COPY (DYTM3,DATM3,NY33)
         ELSE
            CALL COPY (DYTM3,DCTM3,NY33)
         ENDIF
      ENDIF
C
      CALL MXM(DXM3,NX3,XM3(1,1,1,ie),NX3,XRM3(1,1,1,ie),NY3)
      CALL MXM(DXM3,NX3,YM3(1,1,1,ie),NX3,YRM3(1,1,1,ie),NY3)
      CALL MXM(XM3(1,1,1,ie),NX3,DYTM3,NY3,XSM3(1,1,1,ie),NY3)
      CALL MXM(YM3(1,1,1,ie),NX3,DYTM3,NY3,YSM3(1,1,1,ie),NY3)
C
 200  CONTINUE
C
      CALL RZERO   (JACM3,NTOT3)
      CALL ADDCOL3 (JACM3,XRM3,YSM3,NTOT3)
      CALL SUBCOL3 (JACM3,XSM3,YRM3,NTOT3)
C
      ELSE
C
C     Three-dimensional case
C
      DO 300 ie=1,NELT
C
      CALL MXM(DXM3,NX3,XM3(1,1,1,ie),NX3,XRM3(1,1,1,ie),NYZ3)
      CALL MXM(DXM3,NX3,YM3(1,1,1,ie),NX3,YRM3(1,1,1,ie),NYZ3)
      CALL MXM(DXM3,NX3,ZM3(1,1,1,ie),NX3,ZRM3(1,1,1,ie),NYZ3)
C
      DO 310 IZ=1,NZ3
      CALL MXM(XM3(1,1,IZ,ie),NX3,DYTM3,NY3,XSM3(1,1,IZ,ie),NY3)
      CALL MXM(YM3(1,1,IZ,ie),NX3,DYTM3,NY3,YSM3(1,1,IZ,ie),NY3)
      CALL MXM(ZM3(1,1,IZ,ie),NX3,DYTM3,NY3,ZSM3(1,1,IZ,ie),NY3)
 310  CONTINUE
C
      CALL MXM(XM3(1,1,1,ie),NXY3,DZTM3,NZ3,XTM3(1,1,1,ie),NZ3)
      CALL MXM(YM3(1,1,1,ie),NXY3,DZTM3,NZ3,YTM3(1,1,1,ie),NZ3)
      CALL MXM(ZM3(1,1,1,ie),NXY3,DZTM3,NZ3,ZTM3(1,1,1,ie),NZ3)
C
 300  CONTINUE
C
      CALL RZERO   (JACM3,NTOT3)
      CALL ADDCOL4 (JACM3,XRM3,YSM3,ZTM3,NTOT3)
      CALL ADDCOL4 (JACM3,XTM3,YRM3,ZSM3,NTOT3)
      CALL ADDCOL4 (JACM3,XSM3,YTM3,ZRM3,NTOT3)
      CALL SUBCOL4 (JACM3,XRM3,YTM3,ZSM3,NTOT3)
      CALL SUBCOL4 (JACM3,XSM3,YRM3,ZTM3,NTOT3)
      CALL SUBCOL4 (JACM3,XTM3,YSM3,ZRM3,NTOT3)
C
      ENDIF
C
      DO 400 ie=1,NELT
         CALL CHKJAC(JACM3(1,1,1,ie),NXYZ3,ie,xm3,ym3,zm3,ndim)
 400  CONTINUE
C
      RETURN
      END


      subroutine frzng(hour)
c
c     +++PURPOSE+++
c     This function is responsible for extending the frost depth
c
c     The purpose of this program is to extend the frost depth with
c     excess heat flow when the heat flow through the frozen layer
c     system is greater than heat flow from the thermal conductivity
c     of the unfrozen soil.  The excess heat flow is balanced by the
c     heat of fusion released by freezing water.
c
c     Author(s):  Shuhui Dun, WSU
c     Date: 02/22/2008
c     Verified by: Joan Wu, WSU
c
c
c     +++ARGUMENT DECLARATIONS+++
      integer  hour
c
c     +++ARGUMENT DEFINITIONS+++
c     hour   - The hour of the day that we are calculating.
c
c     +++PARAMETERS+++
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pmxpln.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
c
c     +++COMMON BLOCKS+++
c
      include  'cstruc.inc'
c       read:  iplane
      include 'cupdate.inc'
c       read:  sdate
      include  'cwint.inc'
c       read:  snodpt(iplane),tfrdp(mxplan),tthawd(mxplan),frdp(mxplan),
c              thdp(mxplan),densg(mxplan)
c
      include 'cflgfs.inc'
c     fine layer for frost simulation
c
      include 'cpfrst.inc'
c
      include 'csaxp.inc'
c     Saxton and Ralwls model coefficients
c
      include 'cwater.inc'
c     read: dg(i,iplane)
c
      include 'ccons.inc'
c     read: bdcons, bulk density
c
c     +++LOCAL VARIABLES+++
c
      integer  layerN,flyerN,tpbtfg,lyblwk,flblwk,varfg,
     1         fgfzft,wklyn,wkflyn,i,j,varfst,varstp
      real     htreq,ceh2o,lhfh2o,incr,frzeng,fztime,flfzt,
     1         frzftp,wtPkpa,wtpm, kunsat,qwater,frzdp,ofrzdp
      real     smoist,sdepth,vardp,varsm,varthk,varsmc,vardm,
     1         varwtp, varkus,mdfzdp,eratio,tmpvr1,tmpvr2,
     1         kufzfl,oslfsd, varegt,varul,nwfrzt,
     1         qouttp,pfrzw,vartemp,varfdp

c
c     +++LOCAL DEFINITIONS+++
c     htreq  - Heat (energy), required to freeze soil of current finer layer (J/m^2).
c     ceh2o  - Coefficient of expansion for water (unitless).
c     lhfh2o - Latent heat of fusion of water (J/m^3).
c     incr   - Depth that the frost formed in a fine layer(m).
c     frzeng - engery flux to freeze the soil
c     flfzt - time needed to freeze a fine layer
c     fztime - total freezing time used
c     eratio - ratio to the requied energy for freezing soil current layer
c
c     frzftp - water potential at frozen front in meter
c     wtPkps - water potential of a soil layer in kpa.
c     wtpm   - water potential in meter.
c     kunsat - unsaturated hydraulic conductivity m/s.
c     qwater - water flux
c
c     smoist - limit for minimum soil moisture (from David Hall)
c     sdepth - limit for minimum depth value (from David Hall)
c
c     layerN - soil layer number
c     flyerN - finer soil layer number
c     tpbtfg - a flag for  start point or ending point is required,
c              0 for starting point and 1 for ending point.
c
c     fgfzft - flag for what type of water redistribution,
c              0 for no frozen front, 1 for around frozen front,
c              2 for unfrozen layers with frozen front in the soil profile
c
c     wklyn : soil layer number where freezing or thawing front is (working)
c     wkflyn: finer layer number of the working position
c     lyblwk - the soil layer of the finer layer right below the working finer layer
c     flblwk - the finer soil layer below the working layer
c
c     frzdp  - depth of the frozen front
c     ofrzdp  - depth of the frozen front before update
c
c     vardp  - depth variable
c     varsm  - soil moisture variable
c     varfg  - frost flag varaible
c     varthk - thickness variable
c     varsmc - variable for maximum water flow rate an adjecent layer can supply
c
c     mdfzdp - frost thickness between current frozen front and next unfrozen layer
c     kufzfl - Thermal conductivity of a fine layer unfrozen soil (W/m C).
c
c     +++DATA INITIALIZATIONS+++
c     Phase change expention coefficient, water to ice
      data   ceh2o/1.1/
c     Latent heat of fusion of ice in J/m3
      data   lhfh2o/3.35e08/

c     +++END SPECIFICATIONS+++
c
c
c     Do loop
      fztime = 0.
      flfzt = 0.
      incr = 0
      vardm = 0.0
c
c     When there is thawed water ponding on soil surface
      if(watpdg(iplane).gt.1e-5) then
         vardm = dg(1,iplane)/nfine(1)/kftill
cd       Modified by S. Dun, April 09, 2009
cd         qouttp = surtmp(hour) / (dmfrsn + vardm)
         qouttp = -surtmp(hour) / (dmfrsn + vardm)
cd       end modifying
         htreq = lhfh2o * watpdg(iplane)
c
         if (htreq .gt. qouttp*3600) then
c           water could be frozen by the energy
            pfrzw = qouttp*3600 / lhfh2o
            fztime = 3600

          else
             fztime = htreq/qouttp
             pfrzw = watpdg(iplane)
           endif
           slsic(1,1,iplane) = slsic(1,1,iplane) + pfrzw
           watpdg(iplane) = watpdg(iplane)- pfrzw
      endif
c
c     Starting point of the frost extention
      if (frzflg.eq.1) then
c     bottom freezing
         frzdp = frdp(iplane)
         if ((frzdp-solthk(nsl(iplane),iplane)).gt.-0.0001) return
         wklyn = LNfrst
         wkflyn = FLNfrs
      elseif (frzflg.eq.2) then
c     top freezing and bottom thawing
         if (thdp(iplane) .gt. 0.001) then
            frzdp = dg(1,iplane)/nfine(1)/2.
            wklyn = 1
            wkflyn = 1
         else
            frzdp = tfrdp(iplane)
            call locate(frzdp,layern,flyern,0)
             wklyn = layern
             wkflyn = flyern
         endif
      endif
c
c     Do loop
c
c     To first freeze water infiltrated in the frost zone abovove the frozen front
cd      if ((wklyn.ne.1) .or. (wkflyn.ne.1)) then
        if(frdp(iplane).lt. 1.0e-5) then
c
        do 10 i = 1, wklyn
           if (i .eq.wklyn) then
              varstp = wkflyn
           else
              varstp = nfine(i)
           endif
c
           do 20 j = 1, varstp
           if (nwfrzz(i, iplane) .gt. 1e-5) then
              varul = ul(i,iplane)/dg(i,iplane)*slfsd(j,i, iplane)
c
              if (slsic(j, i, iplane) .lt. varul) then
                   varegt = 3600. - fztime
c
                   call frznw(i,j,varegt,nwfrzt,hour)
c
                   fztime = fztime + nwfrzt
                   if(fztime.ge.3600.) return
              endif
           endif
20         continue
c
10      continue
c
      endif
c
c     a flag for the first time in the following loop
      varfst = 0
c     initate the varible for the thickness of the sandwitched frozen layer
      mdfzdp = 0.
c
c     There are 3600 seconds in a hour
c    ***************************************************
      do while (fztime.lt.3600.)
c     Loop till no more energy availabe to freeze the soil
c
c     Heat flux from soil surface needs to be re-estimated
c     when frozen front moved down one or many fine layers.
      if (varfst .ne. 0) then
c
          wklyn = lyblwk
          wkflyn = flblwk
c
c         Check if current layer is frozen
30        varfg = fgfrst(wkflyn, wklyn, iplane)
c
          if((varfg .ne. 0).and.(nwfrzz(wklyn,iplane).gt. 1e-5)) then
c             freeze the infiltrated water in the frozen zone
              varul = ul(wklyn,iplane)/dg(wklyn,iplane)
     1                            *slfsd(wkflyn, wklyn, iplane)
              if (slsic(wkflyn, wklyn, iplane) .lt. varul) then
                  varegt = 3600. - fztime
                  call frznw(wklyn,wkflyn,varegt,nwfrzt,hour)
                  fztime = fztime + nwfrzt
                  if(fztime.ge.3600.) return
              endif
          endif
c
          if(varfg .eq. 1) then
c         a complete frozen
c
               mdfzdp = mdfzdp + dg(wklyn, iplane)/nfine(wklyn)
c
               wkflyn = wkflyn + 1
              if (wkflyn .gt. nfine(wklyn)) then
                  wklyn = wklyn + 1
                  wkflyn = 1
              endif
c
              goto 30
c
           elseif (varfg .eq. 2) then
c          partialy frozen, frost at top
              mdfzdp = mdfzdp + slfsd(wkflyn, wklyn, iplane)
c
           endif
c
          ofrzdp = frzdp
          frzdp = frzdp + incr + mdfzdp
          if ((frzdp-solthk(nsl(iplane),iplane)).gt.-0.0001) return
c
          if (ofrzdp.le.tilld(iplane)) then
c         freezing front was in the tillage layer
              if (frzdp.le.tilld(iplane)) then
c             freezing front is still in the tillage layer
                   qoutdm = qoutdm + (incr + mdfzdp)/kftill
              else
c             freezing front moved below the tillage layer
                   vardp = (tilld(iplane) - frzdp)
                   qoutdm = qoutdm + vardp/kftill
     1                 + (incr + mdfzdp - vardp)/kfutil
              endif
          else
c         freezing front was in the untilled zone
              qoutdm = qoutdm + (incr + mdfzdp)/kfutil
          endif
c
      endif
c
c     Thermal conductance of dry surface soil is important
cd      if ((wkflyn .eq. 1).and.(wklyn.eq.1)) then
      if (frdp(iplane) .lt. 0.001) then
          tmpvr1 = slsw(wkflyn, wklyn, iplane)
          tmpvr2 = 0.5096 + 7.4493 * tmpvr1 - 8.7484 * tmpvr1 ** 2
          kufzfl = tmpvr2 * (0.0014139*bdcons(wklyn,iplane) - 1.0588)
     1             *ksoilf
          if(kufzfl.lt.0.0) kufzfl = 1.75
c
c         The value 10 is for 10 finer layers in each soil layer
c         the value of 2 is for half thickness of a fine layer
          if (kufzfl.gt.0)
     1       vardm = dg(wklyn,iplane)/nfine(wklyn)/4./kufzfl
      else
          vardm = 0.0
      endif
c
c     Thermal conductivity above first frost layer
c         ktopf = thickness /qoutdm
c
c      Thermal gradient of the layer:
c         surtmp(hour)/ (thickness
c
c      Heat flux from above
       qhtout = surtmp(hour) / (qoutdm + vardm)
c
       if ((qhtout+qdry).gt.0.) return
c
c
c     ************************************************
c     *** Water migration caused by freezing front ***
c     ************************************************
c
c       "When water in the soil freezes, the water in the unfrozen soil
c     below is depleted, therefore the hydraulic conductivity of the
c     soil is depleted" George Benoit, July 1992.
c
c    Layer numbers of the fine layer below the freezing layer
      flblwk = wkflyn + 1
      if (flblwk .gt. nfine(wklyn)) then
          lyblwk = wklyn + 1
          flblwk = 1
      else
          lyblwk = wklyn
      endif
c
c     Check if the soil below is unfrozen
      if (lyblwk.gt.nsl(iplane)) then
        varfg = 1
      else
        varfg = fgfrst(flblwk, lyblwk, iplane)
      endif
c
c     qwet condition
c     ---------------------------------------------------------
      if (varfg .ne. 0) then
c     The layer below is frozen, no soil water migration
         qwet = 0.0
         qwater = 0.0
c
      else
c     The layer below is not frozen on top
c
c ----- Calculate QWET, heat of fusion released by freezing water that
c       migrates to, the freezing front.
c ----- L * K w [P / Z uf] part of eqn 3.8.4.
c
cd    Based on the discussion with Kunio Watanabe, Associate Professor, Mie University, Japan
c      in January 2008 when he was visiting WSU.
c      Soil freezing depression point usually is in a range of -0.01C to -0.25C.
c      Using generalized form of Clausius-Clapeyron equation, the pressure potentional
c      at frozen front should be in the range of -20 m to - 160 m.
c      Here, we select to use -100 m.
c      dP/dT = L/(T*deltaV), L=3.34E+5 J/kg, T=273K, deltaV=-9.05E-5m3/kg, dP/dT=-13.1MP/C
c
cd      frzftp = -50
      frzftp = 0.0
c
c     Estimate the water potential of the soil layer below the frozen front
c     using Saxton and Rawls, 2006
c
      varsm = slsw(flblwk, lyblwk, iplane)
c
      call saxfun(lyblwk,varsm,varwtp, varkus)
      wtpm = varwtp
      kunsat = varkus

c     Heat release rate by freezing water migrated to the frozen front
c     Because we are using the maximum hydraulic gradient to estimate
c     soil water migration rate. Therefore we divided by 2. for assuming
c     migration rate slows dowm due to water depletion in the adjecent layer.
c
      if ((frzftp . lt. wtpm).and. (frdp(iplane).gt.0.001)) then
          qwater = kunsat *(wtpm - frzftp)/2.0
     1                     /(dg(lyblwk,iplane)/nfine(lyblwk))
c         Hopefully, it would not use up all soil water in the next layer.
c         Limt the water flux rate to the adjecent layer can supply in an hour
c         if soil water could depelete to its wilting point soil water content.
          varsmc = (varsm - thetdr(lyblwk,iplane))
     1             *(dg(lyblwk,iplane)/nfine(lyblwk)) / 3600
c
          if (varsmc .lt. 0.0) then
              varsmc = 0.0
          endif
c
          if(qwater.gt.varsmc) then
                 qwater = varsmc
          endif
c
          qwet=lhfh2o * qwater

      else
          qwet = 0.0
          qwater = 0.0
      endif
c
      endif
c     End qwet condition
c     -----------------------------------------------
c
c     Freezing energy
      if (frzflg.eq.1) then
c     bottom freezing
         frzeng = qdry + qhtout
      elseif (frzflg.eq.2) then
c     top freezing and bottom thawing
         frzeng = qhtout
      endif
c     -----------------------------------------------
c
c     unfrozen layer thickness in a fine layer
      varthk = dg(wklyn,iplane)/nfine(wklyn)
      eratio = 0.0
c
      if ((frzeng + qwet).ge.0.0) then
c     Engery would first be used to freeze the migration soil water
c
c         limit water flow rate to freezing rate
          qwet = -frzeng
          qwater = qwet/lhfh2o
          incr = 0.0
c         no more energy
          flfzt = 3600.-fztime
          eratio = 0.0
          amtfrz(iplane) = amtfrz(iplane) + qwater *flfzt
c          Write(6,*) 'frost heave', sdate, hour
c
      else
c     Engery is avaiable to freeze the water in current layer
c
           varfg = fgfrst(wkflyn, wklyn, iplane)
c
           if (varfg.ne.0) then
c          the layer is partially frozen
                varthk = varthk - slfsd(wkflyn,wklyn,iplane)
           endif
c          The unit of htreq is J/m2
           htreq = lhfh2o * slsw(wkflyn,wklyn,iplane) * varthk
c
c

c          The calculation frzeng*3600 convert energy flux frzeng in W/m2 to J/m2.
c          There are 3600 s in an hour.
c
           if (((frzeng + qwet)*(3600.-fztime) + htreq) .gt. 0.0) then
c          The energy is only enough to freeze current layer
               eratio = -(frzeng + qwet) * (3600. - fztime)/htreq
               incr = eratio * varthk
c              no more energy
               flfzt = 3600. - fztime
           else
               flfzt = - htreq/(frzeng + qwet)
c
               if(flfzt.lt. 1.0) flfzt =1.0
c              in order to go for next layer, a value of 1 second is assigned for freezing time
c              when the unfrozen thickness is too small to keep the program go to next layer
c
               incr = varthk
               eratio = 1.
           endif
      endif
c     Before updating fine layer frost varaibles,
c     initate the variable for the thickness of the sandwitched frozen layer
      varfg = fgfrst(wkflyn, wklyn, iplane)
      if (varfg.eq.3) then
          mdfzdp = slfsd(wkflyn, wklyn, iplane)
      else
          mdfzdp = 0.
      endif
c
c     Update fine layer frost variables
cd      if (incr .lt. 0.001) incr = 0.0
      if((slfsd(wkflyn,wklyn,iplane).lt.0.001).and.
     1    (incr .lt. 0.001)) incr = 0.0
      if ((varthk - incr).lt.0.001) incr = varthk
c
      if (incr .eq. varthk) then
c     Whole layer is frozen
           fgfrst(wkflyn, wklyn, iplane) = 1
c
      elseif (incr .eq. 0.0) then
           if((qwater* flfzt .gt. 0.0).or.(eratio.gt.0.0)) then
c          Frost heave eratio = 0
c          Otherwise enery is not enough to freeze more than 1mm soil
c          then the frost flag would not change.
               fgfrst(wkflyn, wklyn, iplane) = 2
           endif
      else
c          Partially frozen
           fgfrst(wkflyn, wklyn, iplane) = 2
      endif
c
c     frost depth in a fine layer
      oslfsd = slfsd(wkflyn, wklyn, iplane)
      slfsd(wkflyn, wklyn, iplane) = slfsd(wkflyn,wklyn,iplane) + incr
c
      if (slfsd(wkflyn, wklyn, iplane) .gt.
     1        (dg(wklyn,iplane)/nfine(wklyn))) then
            incr = dg(wklyn,iplane)/nfine(wklyn) - oslfsd
            slfsd(wkflyn, wklyn, iplane) = dg(wklyn,iplane)/nfine(wklyn)
      endif
c
c     the amount of water in ice form (m)
      if ((incr.eq. 0.0).and.(eratio.gt.0.0)) then
           slsic(wkflyn, wklyn, iplane) = slsic(wkflyn, wklyn, iplane)
     1          + qwater* flfzt
     1          + slsw(wkflyn,wklyn,iplane) * eratio * varthk
           slsw(wkflyn,wklyn,iplane) = slsw(wkflyn,wklyn,iplane)
     1          * (1.0 - eratio)
cd         Added by S. Dun, May 19, 2009
c          unfrozen soil water content would not drop below wilting point of the soil
c          varfdp is the thickness of a finer layer
           varfdp = dg(wklyn,iplane)/nfine(wklyn)
c
           vartemp = slsw(wkflyn,wklyn,iplane)- thetdr(wklyn,iplane)
           if (vartemp .lt. 0.0) then
               slsw(wkflyn,wklyn,iplane) = thetdr(wklyn,iplane)
               slsic(wkflyn, wklyn, iplane) =
     1              slsic(wkflyn, wklyn, iplane) + vartemp*
     1              (varfdp- slfsd(wkflyn, wklyn, iplane))
               if (slsic(wkflyn, wklyn, iplane).lt. 0.0) then
                   slsic(wkflyn, wklyn, iplane) = 0.0
               endif
           endif
cd         end adding
cd         Modified by S. Dun, May 08, 2009
c          ice content would not exceed soil porosity
           vartemp = slsic(wkflyn, wklyn, iplane)/0.5
           if (vartemp .gt. (varfdp - 0.0001)) then
c             completely frozen
              fgfrst(wkflyn, wklyn, iplane) = 1
              slsw(flblwk,lyblwk,iplane) = slsw(flblwk,lyblwk,iplane)
     1             + slsw(wkflyn,wklyn,iplane)*
     1             (varfdp - slfsd(wkflyn,wklyn,iplane))/
     1             (dg(lyblwk,iplane)/nfine(lyblwk))
              slfsd(wkflyn, wklyn, iplane)= varfdp
           elseif ((vartemp.gt.0.001).and.
     1             (vartemp .gt. slfsd(wkflyn, wklyn, iplane))) then
              slsw(wkflyn,wklyn,iplane)= slsw(wkflyn,wklyn,iplane)*
     1               (varfdp- slfsd(wkflyn, wklyn, iplane))
     1                /(varfdp-vartemp)
              slfsd(wkflyn, wklyn, iplane) = vartemp
           endif
cd         End modifying
      else
           slsic(wkflyn, wklyn, iplane) = slsic(wkflyn, wklyn, iplane)
     1          + qwater* flfzt + slsw(wkflyn,wklyn,iplane) * incr
      endif
c
c     liquid soil water content in current fine layer would not change.
c
c     Water redistribution around frozen front
      if (qwet .gt. 0.0) then
c         fgfzft - flag for what type of water redistribution,
c         0 for no frozen front,
c         1 for around frozen front,
c         2 for unfrozen layers with frozen front in the soil profile
          call watdst(qwater, flfzt, 1)
      endif
c
c     Total freezing time
      fztime = fztime + flfzt
c
c     Update the flag for first time in the loop
      varfst = 1
      if (lyblwk.gt.nsl(iplane)) return
c
      Enddo
c     End of the do loop
c     *************************************************************
c
cd        write(62, 1000) sdate, hour, year, qdy, qhtout,qwet
1000    format(1x, 3i6, 3e12.2)
c
      return
      end


       SUBROUTINE W3FA11 (EPS,JCAP)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA11         COMPUTES COEFFICIENTS FOR USE IN W3FA12
C   AUTHOR: SELA,JOE         ORG: W342       DATE: 80-10-28
C
C ABSTRACT:  SUBROUTINE COMPUTES DOUBLE PRECISION  COEFFICIENTS
C   USED IN GENERATING  LEGENDRE POLYNOMIALS IN SUBR. W3FA12.
C   ON A CRAY DOUBLE PRECISION IS CHANGED TO REAL, DSQRT TO SQRT.
C
C PROGRAM HISTORY LOG:
C   80-10-28  JOE SELA
C   84-06-01  R.E.JONES   CHANGE TO IBM VS FORTRAN
C   93-04-12  R.E.JONES   CHANGES FOR CRAY, DOUBLE PRECISION TO REAL
C
C USAGE:  CALL W3FA11 (EPS,JCAP)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     JCAP   ARG LIST  ZONAL WAVE NUMBER THIRTY, ETC.
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     EPS   ARG LIST   REAL COEFFICIENTS USED IN
C                      COMPUTING LEGENDRE POLYNOMIALS.
C                      DIMENSION OF EPS IS (JCAP+2)*(JCAP+1)
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     SQRT                                                    SYSTEM
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN 77
C   MACHINE:  CRAY Y-MP8/864
C
C***
C
       REAL  EPS(*)
       REAL  A
C
       SAVE
C
         JCAP1 = JCAP + 1
         JCAP2 = JCAP + 2
C
         DO 100 LL = 1,JCAP1
           L = LL - 1
           JLE = (LL-1) * JCAP2
C
         DO 100 INDE = 2,JCAP2
           N = L + INDE - 1
           A=(N*N-L*L)/(4.0*N*N-1.0)
           EPS(JLE+INDE) = SQRT(A)
 100     CONTINUE
C
         DO 200 LL = 1,JCAP1
           JLE = (LL-1) * JCAP2
           EPS(JLE+1) = 0.0
 200     CONTINUE
C
         RETURN
       END


PROGRAM TestPressure

  USE KindModule, ONLY: &
    DP
  USE EquationOfStateModule, ONLY: &
    InitializeEquationOfState, &
    FinalizeEquationOfState,   &
    ComputePressureFromSpecificInternalEnergy
  USE EquationOfStateModule_TABLE, ONLY: &
    Min_D, &
    Max_D, &
    Min_T, &
    Max_T, &
    Min_Y, &
    Max_Y
  USE UnitsModule, ONLY: &
    Gram, Centimeter, Erg

  IMPLICIT NONE

  INTEGER  :: i
  INTEGER, PARAMETER :: N = 1000

  REAL(DP) :: rhoMin, rhoMax, drho, rho(N)
  REAL(DP) :: epsMin, epsMax, deps, eps(N)
  REAL(DP) :: YeMin , YeMax , dYe , Ye(N)
  REAL(DP) :: p(N)

  CALL InitializeEquationOfState &
         ( EquationOfState_Option &
             = 'TABLE', &
           EquationOfStateTableName_Option &
             = 'wl-EOS-SFHo-25-50-100.h5' )

rho(1) = 9.314925e13_DP * ( Gram / Centimeter**3 )
eps(1) = 5.465183e19_DP * ( Erg / Gram )
Ye (1) = 0.442_DP

rho(2) = 9.266702e13_DP * ( Gram / Centimeter**3 )
eps(2) = 5.299234e19_DP * ( Erg / Gram )
Ye (2) = 0.442_DP

    CALL ComputePressureFromSpecificInternalEnergy &
           ( rho(1), eps(1), Ye(1), p(1) )
    PRINT '(A,ES14.6E3)', 'p(1) = ', p(1) / ( Erg / Centimeter**3 )

    CALL ComputePressureFromSpecificInternalEnergy &
           ( rho(2), eps(2), Ye(2), p(2) )
    PRINT '(A,ES14.6E3)', 'p(2) = ', p(2) / ( Erg / Centimeter**3 )
stop

  rhoMin = 9.0e13_DP * ( Gram / Centimeter**3 )
  rhoMax = 1.0e14_DP * ( Gram / Centimeter**3 )
  drho   = ( rhoMax - rhoMin ) / DBLE( N )

  epsMin = 5.0e19_DP * ( Erg / Gram )
  epsMax = 6.0e19_DP * ( Erg / Gram )
  deps   = ( epsMax - epsMin ) / DBLE( N )

  YeMin  = 0.4_DP
  YeMax  = 0.5_DP
  dYe    = ( YeMax - YeMin ) / DBLE( N )

  rho(1) = rhoMin
  eps(1) = epsMin
  Ye (1) = YeMin

  DO i = 2, N

    rho(i) = rho(i-1) + drho
    eps(i) = eps(i-1) + deps
    Ye (i) = Ye (i-1) + dYe

  END DO

  DO i = 1, N

    CALL ComputePressureFromSpecificInternalEnergy &
           ( rho(i), eps(i), Ye(i), p(i) )

    PRINT '(A,ES14.6E3)', 'p(i) = ', p(i) / ( Erg / Centimeter**3 )

  END DO

  CALL FinalizeEquationOfState

END PROGRAM TestPressure


	subroutine e_solve(s,t,p,e,n,k,s0,t0,p0,sns,tns,pns,iter)
ccc
ccc
ccc
ccc	DESCRIPTION :	Find the zero of the e function using a
ccc			bisection method
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		s(n)		array of cast salinities
ccc			t(n)		array of cast in situ temperatures
ccc			p(n)		array of cast pressures
ccc			e(n)		array of cast e values
ccc			n		length of cast
ccc			k		interval (k-1,k) contains the zero
ccc			s0		the bottle salinity
ccc			t0		the bottle in situ temperature
ccc			p0		the bottle pressure
ccc
ccc	OUTPUT :	sns		salinity of the neutral surface
ccc					intersection with the cast
ccc			tns		in situ temperature of the intersection
ccc			pns		pressure of the intersection
ccc
ccc
ccc	UNITS :		salinities	psu (IPSS-78)
ccc			temperatures	degrees C (IPTS-68)
ccc			pressures	db
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	June 1993
ccc
ccc	REVISION :	1.1		30/6/93
ccc
ccc
ccc
	implicit double precision (a-h,o-z)

	dimension s(n),t(n),p(n),e(n)

	data n2/2/

	pl = p(k-1)
	el = e(k-1)
	pu = p(k)
	eu = e(k)

	iter = 0
	isuccess = 0

	do while(isuccess.eq.0)

	  iter = iter+1

	  pm = (pl+pu)/2

	  call stp_interp(s(k-1),t(k-1),p(k-1),n2,sm,tm,pm)

	  call sig_vals(s0,t0,p0,sm,tm,pm,sigl,sigu)
	  em = sigu-sigl

	  if(el*em.lt.0.) then
	    pu = pm
	    eu = em
	  elseif(em*eu.lt.0.) then
	    pl = pm
	    el = em
	  elseif(em.eq.0.) then
	    sns = sm
	    tns = tm
	    pns = pm
	    isuccess = 1
	  end if

	  if(isuccess.eq.0) then
	    if(abs(em).le.5.d-5.and.abs(pu-pl).le.5.d-3) then
	      sns = sm
	      tns = tm
	      pns = pm
	      isuccess = 1
	    elseif(iter.le.20) then
	      isuccess = 0
	    else
	      print *, 'WARNING 1 in e-solve.f'
	      print *, iter,'  em',abs(em),'  dp',pl,pu,abs(pu-pl)
	      sns = -99.0
	      tns = -99.0
	      pns = -99.0
	      isuccess = 1
	    end if
	  end if

	end do

	return

	end


!
!     ------------------------------------------------------------------
!     I N P R O D
!     ------------------------------------------------------------------
!
      REAL(KIND(0.0D0)) FUNCTION INPROD (A, B, NDIM)
!      CALCULATE SCALAR PRODUCT BETWEEN TO VECTORS A,B
!************************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:08:49   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: NDIM
      REAL(DOUBLE), INTENT(IN) :: A(*)
      REAL(DOUBLE), INTENT(IN) :: B(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
!-----------------------------------------------
!
      INPROD = DOT_PRODUCT(A(:NDIM),B(:NDIM))
!
      RETURN
      END FUNCTION INPROD


      real function shdist(x)
c
c     + + + PURPOSE + + +
c
c     Function SHDIST computes the shear stress distribution
c     if the depth to the non-erodible layer is zero.
c
c     Called from: SR DCAP
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real x
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     x -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (x.ge.0.02) then
        shdist = exp(0.12692-0.51634*alog(x)-0.40825*alog(x)**2-0.03442*
     1      alog(x)**3)
        return
      end if
c
      shdist = 0.13 * x / 0.02
c
      return
      end


      subroutine runY_0000(k,l,Xtwiddle,Gtwiddle,Shat4zz,N0)
      implicit none
C---  Expression for D0000 obtained from 5.50, following the comment after
C     5.50 on how to add adding additional "00" pairs
C---  Calculates D0000
C---  Small terms of order Xtwiddle(0,k)*D00i,Xtwiddle(0,0)*D00ii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat4zz(np,z1max,-2:0)

      do ep=-2,0
         Dv(dd0000+N0,ep) =
     .    -(-(Gtwiddle(k,1)*Shat4zz(1,l,ep)
     .    +Gtwiddle(k,2)*Shat4zz(2,l,ep)
     .    +Gtwiddle(k,3)*Shat4zz(3,l,ep)
     .    +Xtwiddle(k,0)*Dv(dzzi(l)+N0,ep)
     .    -Xtwiddle(0,0)*Dv(dzzii(z2(k,l))+N0,ep)
     .        ))/(2d0*Gtwiddle(k,l))

      enddo

      return
      end


      program fem
c
      implicit real*8 (a-h,o-z)
      common/mat1/a(1800,600),b(1800),t(1800),x(1800),y(1800),det,nm(4)
      common/mat2/dpdx(4),dpdy(4),bfn(4,9),dbfc(4,9),dbfe(4,9),xx,yy,
     $     ajac
      common/mat3/gapt(3),wo(3),tf(2,3),dtf(2,3),nint1,nlc,nuc,iband
      common/mat4/axis,bxis,xfact,yfact,c1,c2,c3
      common/mat5/nnx,nny,nxel,nyel,nntol,nodtol,nrhs
c
c *** open input output files
c
      open(1,file='input')
      open(2,file='output')
      open(61,file='xc.m')
      open(62,file='yc.m')
      open(63,file='sol.m')
c
c *** read input data
c
      read(1,*)nxel,nyel
      read(1,*)niter,error
      read(1,*)c1,c2,c3
      read(1,*)axis,bxis,xfact,yfact
c
c *** calculate various parameters
c
      nrhs=1
      nint1=3

      nnx=nxel+1
      nny=nyel+1
      nuc=nnx+1
      nlc=nnx+1
      iband=2*nlc+1
      nodtol=nnx*nny
      nntol=nxel*nyel
c
c *** Set Gauss Quadrature properties
c
      gapt(1)=0.77459666241483d0
      gapt(2)=0.d0
      gapt(3)=-0.77459666241483d0

      wo(1)=0.555555555555556d0
      wo(2)=0.888888888888889d0
      wo(3)=0.555555555555556d0
c
c *** Choose initial guess
c
      do 15 i=1,nodtol
         t(i)=0.5d0
 15   continue
c
c *** print input data and initial guess - OUTPUT
c
      write(2,1)nntol,nodtol,nxel,nyel,nnx,nny
      write(2,2)niter,error,c1,c2,c3
      write(2,3)axis,bxis,xfact,yfact,nuc,nlc,iband,nint1
      write(2,*)(gapt(i),wo(i),i=1,nint1)
c
c *** initialize bilinear basis functions - call the FIRST PART of
c *** the subroutine BASIS which loads in the values of the basis functions
c *** at the gauss point positions in the UNIT ELEMENT
c
      l=0
      do 100 i=1,nint1
         do 100 j=1,nint1
            l=l+1
            call basis(1,l,gapt(i),gapt(j))
 100  continue
c
c *** initialize linear basis functions - use for boundary integrals
c *** in subroutine BOUND for flux conditions
c
      do 200 i=1,nint1
         tf(1,i)=0.5d0*(1.d0-gapt(i))
         tf(2,i)=0.5d0*(1.d0+gapt(i))
         dtf(1,i)=-0.5d0
         dtf(2,i)=0.5d0
 200  continue
c
c *** calculate the mesh points - see routine for comments
c
      call mesh

c**************************************************************************
c *** newton iteration loop - MAIN CODE LOOP (for steady state)
c**************************************************************************

      iter=0
 300  continue
      iter=iter+1
      write(2,6)iter
c
c *** form the JACOBIAN matrix a and RESIDUAL vector b
c
      call domi
c
c *** insert boundary conditions
c
      call bound
c
c *** solve the system of linear equations - DO NOT CHANGE
c
      call band
c
c *** update the SOLUTION vector t and check convergence
c *** Compute the L2 and Linf norms of the update vector to determine
c *** whether convergence has been reached - criterion is ERROR
c *** If convergence is not achieved and # of NR iterations > ITER, also exit
c
      sum=0.d0
      error1=0.d0
      do 400 i=1,nodtol
         t(i)=t(i)-b(i)
         sum=sum+b(i)*b(i)
         error1=max(dabs(b(i)),error1)
 400  continue

      write(2,7)sum,error1,det
      if(sum.le.error)go to 500
      if(iter.lt.niter)go to 300
      write(2,8)
      go to 600
 500  continue
      write(2,9)
 600  continue
c
c *** Once the code gets here - WE ARE DONE (converged or not)
c *** print results to output files
c
      write(2,10)
      write(2,5)(t(i),i=1,nodtol)
c
c *** print results to output files - MATLAB FORMAT
c *** The output is: (i)   X vector
c ***                (ii)  Y vector
c ***                (iii) Solution vector
c

      do 1000 i=1,nodtol
         write(61,*) x(i)
         write(62,*) y(i)
         write(63,*) t(i)
 1000 continue
c
c *** Formatting Statements for Output Files
c

 1    format(/,1x,'____________________________________________',//,1x,
     1     '    input data ',//,1x,
     2     '____________________________________________',//,1x,
     3     'nntol =',i5,5x,'nodtol =',i5,//,1x,'nxel =',i5,5x,
     4     'nyel =',i5,//,1x,'nnx =',i5,5x,'nny =',i5,/)
 2    format(/,1x,'total number of iterations (niter) =',i5,//,1x,
     1     'error bounds (error) =',e15.8,//,1x,'c1 =',f12.6,5x,'c2 =',
     2     f12.6,//,1x,'c3 =',f12.6,/)
 3    format(/,1x,'axis =',f12.6,5x,'bxis =',f12.6,//,1x,
     1     'xfact =',f12.6,5x,'yfact =',f12.6,//,1x,
     2     'nuc =',i5,5x,'nlc ',i5,5x,'iband =',i5,5x,//,1x,
     3     'number of integration points =',i5,/)
 5    format(/,5(1x,f12.6,2x))
 6    format(/,1x,'newtons iteration number (iter) =',i5,/)
 7    format(/,1x,'sum =',e15.8,2x,'error1 =',e15.8,2x,'det =',
     1     e15.8,/)
 8    format(/,1x,'iterations has not converged',/)
 9    format(/,1x,'---- iterations has converged ----',/)
 10   format(/,1x,'--------------------------------------------',//,10x,
     1     'results',//,1x,
     2    '____________________________________________',/)
 444  format(12e15.7)
      end

c****************************************************************************
c******                      END OF MAIN CODE                           *****
c****************************************************************************

c******************************************
c *** Subroutine - Evaluate BASIS FUNCTIONS
c******************************************

      subroutine basis(itype,ig,c,e)
      implicit real*8 (a-h,o-z)
      common/mat1/a(1800,600),b(1800),t(1800),x(1800),y(1800),det,nm(4)
      common/mat2/dpdx(4),dpdy(4),bfn(4,9),dbfc(4,9),dbfe(4,9),xx,yy,
     $     ajac
      go to(1,2),itype
c
c *** if ITYPE = 1 then goto line 1 (just below), otherwise go to line 2
c
 1    continue
c
c *** calculate basis functions and partial dervatives
c *** at a given c,e in transformed coordinates
c
      bfn(1,ig)=(1.d0-c)*(1.d0-e)/4.d0
      bfn(2,ig)=(1.d0+c)*(1.d0-e)/4.d0
      bfn(3,ig)=(1.d0-c)*(1.d0+e)/4.d0
      bfn(4,ig)=(1.d0+c)*(1.d0+e)/4.d0
      dbfc(1,ig)=-(1.d0-e)/4.d0
      dbfc(2,ig)=(1.d0-e)/4.d0
      dbfc(3,ig)=-(1.d0+e)/4.d0
      dbfc(4,ig)=(1.d0+e)/4.d0
      dbfe(1,ig)=-(1.d0-c)/4.d0
      dbfe(2,ig)=-(1.d0+c)/4.d0
      dbfe(3,ig)=(1.d0-c)/4.d0
      dbfe(4,ig)=(1.d0+c)/4.d0
      return
c
c *** When ITYPE = 2 jump straight to this point
c
 2    continue
c
c *** calculate partial dervatives of transformation
c *** at a point c,e in nelem
c
      xx=0.d0
      yy=0.d0
      dxdc=0.d0
      dxde=0.d0
      dydc=0.d0
      dyde=0.d0
      do 3 i=1,4
         xx=xx+bfn(i,ig)*x(nm(i))
         yy=yy+bfn(i,ig)*y(nm(i))
         dxdc=dxdc+dbfc(i,ig)*x(nm(i))
         dxde=dxde+dbfe(i,ig)*x(nm(i))
         dydc=dydc+dbfc(i,ig)*y(nm(i))
         dyde=dyde+dbfe(i,ig)*y(nm(i))
 3    continue
c
c *** calculate jacobian of transformation from UNIT to REAL element
c
      cjac=dxdc*dyde-dxde*dydc
      ajac=abs(cjac)
c
c *** calculate dervatives of basis functions in x,y coordinates
c
      do 4 i=1,4
         dpdx(i)=(dbfc(i,ig)*dyde-dbfe(i,ig)*dydc)/cjac
         dpdy(i)=(dbfe(i,ig)*dxdc-dbfc(i,ig)*dxde)/cjac
 4    continue
      return
      end

c**********************************************
c *** Subroutine - Evaluate MESH POINTS ON GRID
c**********************************************

      subroutine mesh
      implicit real*8 (a-h,o-z)
      common/mat1/a(1800,600),b(1800),t(1800),x(1800),y(1800),det,nm(4)
      common/mat4/axis,bxis,xfact,yfact,c1,c2,c3
      common/mat5/nnx,nny,nxel,nyel,nntol,nodtol,nrhs
c
c *** evaluate the mesh points at each ij node
c *** Origin is at (0,0)
c *** AXIS, BXIS = are the X and Y lengths
c *** XFACT, YFACT are refinement parameters - set to 1 for uniform grid
c
      do 20 i=1,nnx
         do 20 j=1,nny
            x(nnum(i,j))=axis*(dfloat(i-1)/dfloat(nxel))**xfact
            y(nnum(i,j))=bxis*(dfloat(j-1)/dfloat(nyel))**yfact
 20   continue

      return
      end

c**********************************************************
c *** FUNCTION - GIVEN (i,j Index, find single global index
c**********************************************************

      integer function nnum(i,j)
      implicit real*8 (a-h,o-z)
      common/mat5/nnx,nny,nxel,nyel,nntol,nodtol,nrhs
c
c *** calculate the node number of node i,j in element nelem
c
      nnum=(j-1)*(nxel+1)+i
      return
      end

c*************************************************
c *** Subroutine - ASSEMBLE JACOBIAN AND RESIDUALS
c*************************************************

      subroutine domi

      implicit real*8 (a-h,o-z)

      common/mat1/a(1800,600),b(1800),t(1800),x(1800),y(1800),det,nm(4)
      common/mat2/dpdx(4),dpdy(4),bfn(4,9),dbfc(4,9),dbfe(4,9),xx,yy,
     $     ajac
      common/mat3/gapt(3),wo(3),tf(2,3),dtf(2,3),nint1,nlc,nuc,iband
      common/mat5/nnx,nny,nxel,nyel,nntol,nodtol,nrhs

      dimension temp(4,4),temp1(4)
c
c *** initialize the jacobian matrix a and residuals vector b
c
      do 20 i=1,nodtol
         b(i)=0.d0
         do 10 j=1,iband
            a(i,j)=0.d0
 10      continue
 20   continue
c
c *** iterate over elements in domain - LEVEL 1
c
      jtally=0
      ifact=0
      do 100 nelem=1,nntol
c
c *** find the node numbers of element # NELEM
c
         jtally=jtally+1
         if(jtally .lt. nxel+1) go to 30
         jtally=1
         ifact=ifact+1
 30      continue
         nm(1)=ifact*(nxel+1)+jtally
         nm(2)=nm(1)+1
         nm(3)=(ifact+1)*(nxel+1)+jtally
         nm(4)=nm(3)+1
c
c *** initialize working matrices TEMP (elemental Jacobian) and
c *** TEMP1 (elemental Residual) for element integration
c
         do 40 iw=1,4
            temp1(iw)=0.d0
            do 40 jw=1,4
               temp(iw,jw)=0.d0
 40      continue
c
c *** iterate over each gauss point in element - LEVEL 2
c
         kk=0
         do 60 i=1,nint1
            do 60 j=1,nint1
               kk=kk+1
c
c *** calculate dervatives of basis functions and transformation
c *** jacobian at the gaussian points in x,y coordinates
c
               call basis(2,kk,c,e)
               wet=wo(i)*wo(j)*ajac
c
c *** calculate dependent variable and partial dervatives at
c *** the gaussian integration points
c
               dtdx=0.d0
               dtdy=0.d0
               do 51 ii=1,4
                  dtdx=dtdx+t(nm(ii))*dpdx(ii)
                  dtdy=dtdy+t(nm(ii))*dpdy(ii)
 51            continue
c
c *** iterate over weighting functions - LEVEL 3
c
               do 60 iw=1,4
                  bifn=bfn(iw,kk)
                  dpix=dpdx(iw)
                  dpiy=dpdy(iw)
                  ti=dpix*dtdx+dpiy*dtdy
c
c *** form the working residual vector in nelem
c
                  temp1(iw)=temp1(iw)+ti*wet
c
c *** iterate over each node - LEVEL 4
c
                  do 60 jw=1,4
                     dpjy=dpdy(jw)
                     dpjx=dpdx(jw)
                     ti=dpix*dpjx+dpiy*dpjy
c
c *** form the working jacobian matrix in element
c
                     temp(iw,jw)=temp(iw,jw)+ti*wet
 60      continue
c
c *** store the ELEMENTAL integration matrix and vector in the global
c *** matrix a and vector b
c
         do 90 i=1,4
            irow=nm(i)
            b(irow)=b(irow)+temp1(i)
            do 90 j=1,4
               icol=nm(j)
               iloc=icol-irow+nlc+1
               a(irow,iloc)=a(irow,iloc)+temp(i,j)
 90      continue
c
c *** Finish loop over elements (LEVEL 1)
c
 100  continue

      return
      end

c*************************************************
c *** Subroutine - IMPOSE BOUNDARY CONDITIONS
c*************************************************

      subroutine bound
      implicit real*8 (a-h,o-z)
      common/mat1/a(1800,600),b(1800),t(1800),x(1800),y(1800),det,nm(4)
      common/mat3/gapt(3),wo(3),tf(2,3),dtf(2,3),nint1,nlc,nuc,iband
      common/mat4/axis,bxis,xfact,yfact,c1,c2,c3
      common/mat5/nnx,nny,nxel,nyel,nntol,nodtol,nrhs

      dimension p(2,2),r(2),n(2)

c***********************************************************************
c *** Insert NATURAL BC at the boundary x=1 (RIGHT)
c***********************************************************************

c$$$      do 40 ii=1,nyel
c$$$c
c$$$c *** find the node numbers of element ii *****
c$$$c
c$$$         n(1)=nnum(nnx,ii)
c$$$         n(2)=nnum(nnx,ii+1)
c$$$         ajacy=0.5d0*(y(n(2))-y(n(1)))
c$$$c
c$$$c *** intialize working areas p and r *****
c$$$c
c$$$         do 10 i=1,2
c$$$            r(i)=0.d0
c$$$            do 10 j=1,2
c$$$               p(i,j)=0.d0
c$$$ 10      continue
c$$$c
c$$$c *** iterate over guassian points *****
c$$$c
c$$$         do 20 ig=1,nint1
c$$$            funt=t(n(1))*tf(1,ig)+t(n(2))*tf(2,ig)
c$$$c
c$$$c *** iterate over each node *****
c$$$c
c$$$            do 20 i=1,2
c$$$               r(i)=r(i)+wo(ig)*tf(i,ig)*ajacy*(funt-c3)
c$$$c
c$$$c *** iterate over each weighting function *****
c$$$c
c$$$               do 20 j=1,2
c$$$                  p(i,j)=p(i,j)+wo(ig)*tf(i,ig)*tf(j,ig)*ajacy
c$$$ 20      continue
c$$$c
c$$$c *** store boundary conditions in global matrix *****
c$$$c
c$$$         do 30 i=1,2
c$$$            irow=n(i)
c$$$            b(irow)=b(irow)+r(i)
c$$$            do 30 j=1,2
c$$$               iloc=n(j)-irow+nlc+1
c$$$               a(irow,iloc)=a(irow,iloc)+p(i,j)
c$$$ 30      continue
c$$$ 40   continue

c*********************************************************************
c *** Insert NATURAL BC at the boundary Y=1 (TOP)
c*********************************************************************

c$$$      do 400 ii=1,nxel
c$$$c
c$$$c *** find the node numbers of element ii *****
c$$$c
c$$$         n(1)=nnum(ii,nny)
c$$$         n(2)=nnum(ii+1,nny)
c$$$         ajacy=0.5d0*(x(n(2))-x(n(1)))
c$$$c
c$$$c *** intialize working areas p and r *****
c$$$c
c$$$         do 100 i=1,2
c$$$            r(i)=0.d0
c$$$            do 100 j=1,2
c$$$               p(i,j)=0.d0
c$$$ 100     continue
c$$$c
c$$$c *** iterate over guassian points *****
c$$$c
c$$$         do 200 ig=1,nint1
c$$$            funt=t(n(1))*tf(1,ig)+t(n(2))*tf(2,ig)
c$$$            xx=x(n(1))*tf(1,ig)+x(n(2))*tf(2,ig)
c$$$c
c$$$c *** iterate over each node *****
c$$$c
c$$$            do 200 i=1,2
c$$$               r(i)=r(i)+wo(ig)*tf(i,ig)*ajacy*(funt-c3)
c$$$c
c$$$c *** iterate over each weighting function *****
c$$$c
c$$$               do 200 j=1,2
c$$$                  p(i,j)=p(i,j)+wo(ig)*tf(i,ig)*tf(j,ig)*ajacy
c$$$ 200     continue
c$$$c
c$$$c *** store boundary conditions in global matrix *****
c$$$c
c$$$         do 300 i=1,2
c$$$            irow=n(i)
c$$$            b(irow)=b(irow)+r(i)
c$$$            do 300 j=1,2
c$$$               iloc=n(j)-irow+nlc+1
c$$$               a(irow,iloc)=a(irow,iloc)+p(i,j)
c$$$ 300     continue
c$$$ 400  continue

c**********************************************************************
c *** Insert ESSENTIAL  BC at the boundary Y=0 (BOTTOM)
c**********************************************************************

      irow=nnum(1,1)
      b(irow)=t(irow)-c2
      do 120 icol=1,iband
         a(irow,icol)=0.d0
 120  continue
      a(irow,nlc+1)=1.d0

      do 140 ii=1,nxel
         irow=nnum(ii+1,1)
         b(irow)=t(irow)-c2
         do 130 icol=1,iband
            a(irow,icol)=0.d0
 130     continue
         a(irow,nlc+1)=1.d0
 140  continue

c**********************************************************************
c *** Insert ESSENTIAL BC (=0) at the boundary Y=1 (TOP)
c**********************************************************************

      irow=nnum(1,nny)
      b(irow)=t(irow)-0.d0
      do 220 icol=1,iband
         a(irow,icol)=0.d0
 220  continue
      a(irow,nlc+1)=1.d0

      do 240 ii=1,nxel
         irow=nnum(ii+1,nny)
         b(irow)=t(irow)-0.d0
         do 230 icol=1,iband
            a(irow,icol)=0.d0
 230     continue
         a(irow,nlc+1)=1.d0
 240  continue

      return
      end

c**********************************************************************
c *** SUBROUTINE - BAND SOLVER (DO NOT TOUCH THIS!!!!!!!!!)
c**********************************************************************

      subroutine band
      implicit real*8 (a-h,o-z)
c
c------------------------------------------------------------------------
c
      common/mat1/c(1800,600),v(1800,1),t1(1800),t2(1800),t3(1800)
     &     ,det,n4(4)
      common/mat3/gapt(3),wo(3),tf(2,3),dtf(2,3),nint1,nlc,nuc,iband
      common/mat5/nnx,nny,nxel,nyel,nntol,nod,nvarg
c
c------------------------------------------------------------------------
c
      mc=nod
      nc=iband
      nv=nvarg
c
c     ***** initialize det  *****
c
      eps=1.0d-15
      icount=0
      det=1.d0
c
c	*** prepare the matrix c for processing by shifting undefined   ***
c	*** elements out of the upper-left-hand corner and inserting    ***
c	*** zeros in the lower right-hand-corner                        ***
c
      nc1=nc+1
      lr=nc1/2
      mr=lr-1
      ii=mc+1
      do 60 ir=1,mr
         ii=ii-1
         nr=lr-ir
         jj=nc1
         do 40 jr=1,nr
            do 20 jc=2,nc
               p=c(ir,jc)
               k=jc-1
               c(ir,k)=p
 20         continue
            c(ir,nc)=0.d0
            jj=jj-1
            c(ii,jj)=0.d0
 40      continue
 60   continue
c
c	*** use row operations to eleminate the lower triangular part of a ***
c	*** apply these same operations to the right-hand-sides            ***
c
      do 400 ic=1,mc
         ipiv=ic
         piv=c(ic,1)
         pivmax=dabs(piv)
         kr=ic+1
         if(kr.gt.lr)go to 140
c
c	***** find the largest possible pivot in the current column.
c
         do 120	ir=kr,lr
            pivmag=dabs(c(ir,1))
            if(pivmax.ge.pivmag)go to 120
            ipiv=ir
            pivmax=pivmag
 120     continue
         piv=c(ipiv,1)
c
c	***** check the pivot magnitude *******
c
 140     continue
         if(pivmax.ge.eps)go to 150
c
c	**** a nonzero pivot smaller than eps has been found ****
c
c        print*,' zero pivot ', piv
         return
c
c	**** if necessary , swap row ipiv with row ic ****
c
 150     continue
         if(ipiv.eq.ic)go to 200
         det=-det
         do 160 jc=1,nc
            t=c(ic,jc)
            c(ic,jc)=c(ipiv,jc)
            c(ipiv,jc)=t
 160     continue
         do 180 jv=1,nv
            t=v(ic,jv)
            v(ic,jv)=v(ipiv,jv)
            v(ipiv,jv)=t
 180     continue
c
c	***** update the determinant value *****
c
 200     continue
         if(dabs(det).ge.1.0d+25)icount=icount+1
         if(dabs(det).ge.1.0d+25)det=det/dabs(det)
         det=det*piv
c
c	***** normalize the pivot row *****
c
         theta=1./piv
         do 220 jc=2,nc
            c(ic,jc)=c(ic,jc)*theta
 220     continue
         do 240 jv=1,nv
            v(ic,jv)=v(ic,jv)*theta
 240     continue
c
c	*** eliminate the lower triangular elements in the current column ***
c
         if(kr.gt.lr)go to 400
         do 380 ir=kr,lr
            t=c(ir,1)
            do 230 jc=2,nc
               k=jc-1
               c(ir,k)=c(ir,jc)-t*c(ic,jc)
 230        continue
            c(ir,nc)=0.d0
            do 360 jv=1,nv
               v(ir,jv)=v(ir,jv)-t*v(ic,jv)
 360        continue
 380     continue
         if(lr.eq.mc)go to 400
         lr=lr+1
 400  continue
c
c	***** triangularization is complete *****
c
c
c	***** back-substitute to compute the solution vector(s) ******
c
      kr=2
      lc=mc-1
      do 480 ic=1,lc
         iv=mc-ic
         do 460 jv=1,nv
            ii=iv
            do 440 jc=2,kr
               ii=ii+1
               v(iv,jv)=v(iv,jv)-c(iv,jc)*v(ii,jv)
 440        continue
 460     continue
         if(kr.eq.nc) go to 480
         kr=kr+1
 480  continue
c
c	****** the matrix equation is solved ******
c
      return
      end


************************************************************************
*
*     Function DLOGAM                        Called by: MVUEPHI
*
*
*
C     ALGORITHM ACM 291, COMM. ACM. (1966) VOL. 9, P. 686
C
C     EVALUATES NATURAL LOGARITHM OF GAMMA(X) FOR X GREATER THAN ZERO
*     This code does not test for (X .LE. 0.D0) as it shouldn't ever
*     happen
C
C     FORTRAN TRANSLATION PRESENTED IN PIKE, C.M., AND HILL, I.D., 1985,
C     LOGARITHM OF THE GAMMA FUNCTION, IN GRIFFITHS, P., AND HILL, I.D.,
C     1985, APPLIED STATISTICS ALGORITHMS: LONDON, ROYAL STATISTICAL
C     SOCIETY
*
*
************************************************************************
      DOUBLE PRECISION FUNCTION DLOGAM(X)
*
*     subroutine arg
*
      DOUBLE PRECISION X
*
*     local vars
*
      DOUBLE PRECISION A1,A2,A3,A4,A5,F,Y,Z,ZLOG
*
*     constants for DLOG(2 PI)/2, 1/1680, 1/1260, 1/360, AND 1/12
*
      DATA A1,A2,A3,A4,A5 / 0.918938533204673D0, 0.000595238095238D0,
     &                      0.000793650793651D0, 0.002777777777778D0,
     &                      0.083333333333333D0 /

      ZLOG(F) = DLOG(F)

      Y = X
      F = 0.D0
      IF (Y.LT.7.D0) THEN
         F = Y
 10      Y = Y+1.D0
         IF (Y.LT.7.D0) THEN
            F = F*Y
            GOTO 10
         ENDIF
         F = -ZLOG(F)
      ENDIF
      Z = 1.D0/(Y*Y)

      DLOGAM = F+(Y-0.5D0)*ZLOG(Y)-Y+A1 +(((-A2*Z+A3)*Z-A4)*Z+A5)/Y

      RETURN
      END


!----------------------------------------------------------------------*
!  SUBROUTINE PHENOL                                                   *
!  Purpose: This subroutine calculates the rate of phenological        *
!           development of the crop based on photoperiod and           *
!           temperature.                                               *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! DVS     R4  Development stage of the crop (-)                     I  *
! DVRJ    R4  Development rate juvenile ((oCd)-1)                   I  *
! DVRI    R4  Development rate, photoperiod-sensitive phase         I  *
!             ((oCd)-1)                                                *
! DVRP    R4  Development rate, PI phase ((oCd)-1)                  I  *
! DVRR    R4  Development rate, reproductive phase ((oCd)-1)        I  *
! HU      R4  Heat units (oCd d-1)                                  I  *
! DAYL    R4  Astronomic daylength (base = 0 degrees) (h)           I  *
! MOPP    R4  Maximum optimum photoperiod (h)                       I  *
! PPSE    R4  Photoperiod sensitivity (h-1)                         I  *
! TS      R4  Temperature sum (oCd)                                 I  *
! SHCKD   R4  Delay parameter in phenology ((oCd)(oCd)-1)           I  *
! CROPSTA I4  Crop stage (-)                                        I  *
! DVR     R4  Development rate of the crop (d-1)                    O  *
! TSHCKD  R4  Transpl. shock for phenol. development (oCd)          O  *
!                                                                      *
!  FILE usage : none                                                   *
!----------------------------------------------------------------------*
      SUBROUTINE OR_PHENOL(ESTAB,DVS,DVRJ,DVRI,DVRP,DVRR,HU,DAYL,MOPP,PPSE, &
                        TS,SHCKD,CROPSTA,DVR,TSHCKD)

      IMPLICIT NONE
!-----Formal parameters
      REAL    DVS, DVRJ , DVRI, DVRP, DVRR, HU, DAYL, MOPP, PPSE
      REAL    TS , SHCKD, DVR , TSHCKD
	  CHARACTER (*) ESTAB
      INTEGER CROPSTA
!-----Local parameters
      REAL    DL, TSTR, PPFAC
      SAVE

      IF (DVS.GE.0..AND.DVS.LT.0.40) DVR = DVRJ*HU
      IF (DVS.GE.0.40.AND.DVS.LT.0.65) THEN
         DL = DAYL+0.9
         IF (DL.LT.MOPP) THEN
            PPFAC = 1.
         ELSE
            PPFAC = 1.-(DL-MOPP)*PPSE
         END IF
         PPFAC = MIN(1.,MAX(0.,PPFAC))
         DVR   = DVRI*HU*PPFAC

      END IF
      IF (DVS.GE.0.65.AND.DVS.LT.1.00) DVR = DVRP*HU
      IF (DVS.GE.1.00)                 DVR = DVRR*HU

      IF (CROPSTA .EQ. 3) THEN
        TSTR = TS
      ELSEIF(CROPSTA .LT. 3) THEN
        TSTR = 0.0
      END IF
      TSHCKD = SHCKD*TSTR
      IF (CROPSTA .GT. 3 .AND.TS.LT.(TSTR+TSHCKD)) DVR = 0.

      RETURN
      END


C From: VEGA::SANDER       "Chris Sander"  9-JUL-1987 23:21
C To:   HOLM
C Subj: U3B -  I have other routines that go with it + for testing

      SUBROUTINE U3B(W,X,Y,N,MODE,RMS,U,T,IER)
C.... this version copied July 1986. DO NOT REDISTRIBUTE.
C.... If you want this routine, ask Wolfgang Kabsch !!
C**** CALCULATES A BEST ROTATION & TRANSLATION BETWEEN TWO VECTOR SETS
C**** SUCH THAT U*X+T IS THE CLOSEST APPROXIMATION TO Y.
C**** THE CALCULATED BEST SUPERPOSITION MAY NOT BE UNIQUE AS INDICATED
C**** BY A RESULT VALUE IER=-1. HOWEVER IT IS GARANTIED THAT WITHIN
C**** NUMERICAL TOLERANCES NO OTHER SUPERPOSITION EXISTS GIVING A
C**** SMALLER VALUE FOR RMS.
C**** THIS VERSION OF THE ALGORITHM IS OPTIMIZED FOR THREE-DIMENSIONAL
C**** REAL VECTOR SPACE.
C**** USE OF THIS ROUTINE IS RESTRICTED TO NON-PROFIT ACADEMIC
C**** APPLICATIONS.
C**** PLEASE REPORT ERRORS TO
C**** PROGRAMMER:  W.KABSCH   MAX-PLANCK-INSTITUTE FOR MEDICAL RESEARCH
C        JAHNSTRASSE 29, 6900 HEIDELBERG, FRG.
C**** REFERENCES:  W.KABSCH   ACTA CRYST.(1978).A34,827-828
C           W.KABSCH ACTA CRYST.(1976).A32,922-923
C
C  W    - W(M) IS WEIGHT FOR ATOM PAIR  # M           (GIVEN)
C  X    - X(I,M) ARE COORDINATES OF ATOM # M IN SET X       (GIVEN)
C  Y    - Y(I,M) ARE COORDINATES OF ATOM # M IN SET Y       (GIVEN)
C  N    - N IS NUMBER OF ATOM PAIRS             (GIVEN)
C  MODE  - 0:CALCULATE RMS ONLY              (GIVEN)
C      1:CALCULATE RMS,U,T   (TAKES LONGER)
C  RMS   - SUM OF W*(UX+T-Y)**2 OVER ALL ATOM PAIRS        (RESULT)
C  U    - U(I,J) IS   ROTATION  MATRIX FOR BEST SUPERPOSITION  (RESULT)
C  T    - T(I)   IS TRANSLATION VECTOR FOR BEST SUPERPOSITION  (RESULT)
C  IER   - 0: A UNIQUE OPTIMAL SUPERPOSITION HAS BEEN DETERMINED(RESULT)
C     -1: SUPERPOSITION IS NOT UNIQUE BUT OPTIMAL
C     -2: NO RESULT OBTAINED BECAUSE OF NEGATIVE WEIGHTS W
C      OR ALL WEIGHTS EQUAL TO ZERO.
C
C-----------------------------------------------------------------------
      INTEGER    IP(9),IP2312(4),I,J,K,L,M1,M,IER,MODE
      REAL      W(N),X(3,N),Y(3,N),U(3,3),T(3),RMS,SIGMA
	REAL*8 H,G,D, SQRTH,CTH,STH, SS(6), A(3,3),
     1		SS1, SS2, SS3, SS4, SS5, SS6, P
      REAL*8     R(3,3),XC(3),YC(3),WC,B(3,3),E0,
     1 E(3),E1,E2,E3,SPUR,DET,COF,TOL,
     2 RR(6),RR1,RR2,RR3,RR4,RR5,RR6,
     3 ZERO,ONE,TWO,THREE,SQRT3
      EQUIVALENCE (RR1,RR(1)),(RR2,RR(2)),(RR3,RR(3)),
     1        (RR4,RR(4)),(RR5,RR(5)),(RR6,RR(6)),
     2        (SS1,SS(1)),(SS2,SS(2)),(SS3,SS(3)),
     3        (SS4,SS(4)),(SS5,SS(5)),(SS6,SS(6)),
     4        (E1,E(1)),(E2,E(2)),(E3,E(3))
      DATA SQRT3,TOL/1.73205080756888D+00, 1.0D-2/
      DATA ZERO,ONE,TWO,THREE/0.0D+00, 1.0D+00, 2.0D+00, 3.0D+00/
      DATA IP/1,2,4,  2,3,5,  4,5,6/
      DATA IP2312/2,3,1,2/

      WC=ZERO
      RMS=0.0
      E0=ZERO
      DO 1 I=1,3
      XC(I)=ZERO
      YC(I)=ZERO
      T(I)=0.0
      DO 1 J=1,3
      D=ZERO
      IF (I.EQ.J)D=ONE
      U(I,J)=D
      A(I,J)=D
1     R(I,J)=ZERO
      IER=-1
      IF (N.LT.1)RETURN
C**** DETERMINE CENTROIDS OF BOTH VECTOR SETS X AND Y
      IER=-2
      DO 2 M=1,N
      IF (W(M).LT.0.0)RETURN
      WC=WC+W(M)
      DO 2 I=1,3
      XC(I)=XC(I)+W(M)*X(I,M)
2     YC(I)=YC(I)+W(M)*Y(I,M)
      IF (WC.LE.ZERO)RETURN
      DO 3 I=1,3
      XC(I)=XC(I)/WC
3     YC(I)=YC(I)/WC
C**** DETERMINE CORRELATION MATRIX R BETWEEN VECTOR SETS Y AND X
      DO 4 M=1,N
      DO 4 I=1,3
      E0=E0+W(M)*((X(I,M)-XC(I))**2+(Y(I,M)-YC(I))**2)
      D=W(M)*(Y(I,M)-YC(I))
      DO 4 J=1,3
4     R(I,J)=R(I,J)+D*(X(J,M)-XC(J))
C**** CALCULATE DETERMINANT OF R(I,J)
      DET=R(1,1)*(R(2,2)*R(3,3)-R(2,3)*R(3,2))
     1   -R(1,2)*(R(2,1)*R(3,3)-R(2,3)*R(3,1))
     2   +R(1,3)*(R(2,1)*R(3,2)-R(2,2)*R(3,1))
      SIGMA=DET
C**** FORM UPPER TRIANGLE OF TRANSPOSED(R)*R
      M=0
      DO 5 J=1,3
      DO 5 I=1,J
      M=M+1
5     RR(M)=R(1,I)*R(1,J)+R(2,I)*R(2,J)+R(3,I)*R(3,J)
C***************** EIGENVALUES *****************************************
C**** FORM CHARACTERISTIC CUBIC  X**3-3*SPUR*X**2+3*COF*X-DET=0
      SPUR=(RR1+RR3+RR6)/THREE
      COF=(RR3*RR6-RR5*RR5+RR1*RR6-RR4*RR4+RR1*RR3-RR2*RR2)/THREE
      DET=DET*DET
      DO 6 I=1,3
6     E(I)=SPUR
      IF (SPUR.LE.ZERO)GO TO 40
C**** REDUCE CUBIC TO STANDARD FORM Y**3-3HY+2G=0 BY PUTTING X=Y+SPUR
      D=SPUR*SPUR
      H=D-COF
      G=(SPUR*COF-DET)/TWO-SPUR*H
C**** SOLVE CUBIC. ROOTS ARE E1,E2,E3 IN DECREASING ORDER
      IF (H.LE.ZERO)GO TO 8
      SQRTH=SQRT(H)
C	WRITE(*,*) H,G,SPUR, COF, DET
C	IF (ABS(G).LT.1E12) GO TO 7
C	WRITE(*,*) 'KUKKUU'
C	D=H*H/G-G/H
C	D=D*G*H
C	GO TO 9
7      D=H*H*H-G*G
9      IF (D.LT.ZERO)D=ZERO
c	the result of atan2 is undefined if both arguments are zero !
      D=ATAN2(SQRT(D),-G)/THREE
      CTH=SQRTH*COS(D)
      STH=SQRTH*SQRT3*SIN(D)
      E1=SPUR+CTH+CTH
      E2=SPUR-CTH+STH
      E3=SPUR-CTH-STH
      IF (MODE)10,50,10
C.....HANDLE SPECIAL CASE OF 3 IDENTICAL ROOTS
8     IF (MODE)30,50,30
C**************** EIGENVECTORS *****************************************
10    DO 15 L=1,3,2
      D=E(L)
      SS1=(D-RR3)*(D-RR6)-RR5*RR5
      SS2=(D-RR6)*RR2+RR4*RR5
      SS3=(D-RR1)*(D-RR6)-RR4*RR4
      SS4=(D-RR3)*RR4+RR2*RR5
      SS5=(D-RR1)*RR5+RR2*RR4
      SS6=(D-RR1)*(D-RR3)-RR2*RR2
      J=1
      IF (ABS(SS1).GE.ABS(SS3))GO TO 12
      J=2
      IF (ABS(SS3).GE.ABS(SS6))GO TO 13
11    J=3
      GO TO 13
12    IF (ABS(SS1).LT.ABS(SS6))GO TO 11
13    D=ZERO
      J=3*(J-1)
      DO 14 I=1,3
      K=IP(I+J)
      A(I,L)=SS(K)
14    D=D+SS(K)*SS(K)
      IF (D.GT.ZERO)D=ONE/SQRT(D)
      DO 15 I=1,3
15    A(I,L)=A(I,L)*D
      D=A(1,1)*A(1,3)+A(2,1)*A(2,3)+A(3,1)*A(3,3)
      M1=3
      M=1
      IF ((E1-E2).GT.(E2-E3))GO TO 16
      M1=1
      M=3
16    P=ZERO
      DO 17 I=1,3
      A(I,M1)=A(I,M1)-D*A(I,M)
17    P=P+A(I,M1)**2
      IF (P.LE.TOL)GO TO 19
      P=ONE/SQRT(P)
      DO 18 I=1,3
18    A(I,M1)=A(I,M1)*P
      GO TO 21
19    P=ONE
      DO 20 I=1,3
      IF (P.LT.ABS(A(I,M)))GO TO 20
      P=ABS(A(I,M))
      J=I
20    CONTINUE
      K=IP2312(J)
      L=IP2312(J+1)
      P=SQRT(A(K,M)**2+A(L,M)**2)
      IF (P.LE.TOL)GO TO 40
      A(J,M1)=ZERO
      A(K,M1)=-A(L,M)/P
      A(L,M1)= A(K,M)/P
21    A(1,2)=A(2,3)*A(3,1)-A(2,1)*A(3,3)
      A(2,2)=A(3,3)*A(1,1)-A(3,1)*A(1,3)
      A(3,2)=A(1,3)*A(2,1)-A(1,1)*A(2,3)
C****************** ROTATION MATRIX ************************************
30    DO 32 L=1,2
      D=ZERO
      DO 31 I=1,3
      B(I,L)=R(I,1)*A(1,L)+R(I,2)*A(2,L)+R(I,3)*A(3,L)
31    D=D+B(I,L)**2
      IF (D.GT.ZERO)D=ONE/SQRT(D)
      DO 32 I=1,3
32    B(I,L)=B(I,L)*D
      D=B(1,1)*B(1,2)+B(2,1)*B(2,2)+B(3,1)*B(3,2)
      P=ZERO
      DO 33 I=1,3
      B(I,2)=B(I,2)-D*B(I,1)
33    P=P+B(I,2)**2
      IF (P.LE.TOL)GO TO 35
      P=ONE/SQRT(P)
      DO 34 I=1,3
34    B(I,2)=B(I,2)*P
      GO TO 37
35    P=ONE
      DO 36 I=1,3
      IF (P.LT.DABS(B(I,1)))GO TO 36
      P=DABS(B(I,1))
      J=I
36    CONTINUE
      K=IP2312(J)
      L=IP2312(J+1)
      P=DSQRT(B(K,1)**2+B(L,1)**2)
      IF (P.LE.TOL)GO TO 40
      B(J,2)=ZERO
      B(K,2)=-B(L,1)/P
      B(L,2)= B(K,1)/P
37    B(1,3)=B(2,1)*B(3,2)-B(2,2)*B(3,1)
      B(2,3)=B(3,1)*B(1,2)-B(3,2)*B(1,1)
      B(3,3)=B(1,1)*B(2,2)-B(1,2)*B(2,1)
      DO 39 I=1,3
      DO 39 J=1,3
39    U(I,J)=B(I,1)*A(J,1)+B(I,2)*A(J,2)+B(I,3)*A(J,3)
C****************** TRANSLATION VECTOR *********************************
40    DO 41 I=1,3
41    T(I)=YC(I)-U(I,1)*XC(1)-U(I,2)*XC(2)-U(I,3)*XC(3)
C********************** RMS ERROR **************************************
50    DO 51 I=1,3
      IF (E(I).LT.ZERO)E(I)=ZERO
51    E(I)=DSQRT(E(I))
      IER=0
      IF (E2.LE.(E1*1.0D-05))IER=-1
      D=E3
      IF (SIGMA.GE.0.0)GO TO 52
      D=-D
      IF ((E2-E3).LE.(E1*1.0D-05))IER=-1
52    D=D+E2+E1
      RMS=E0-D-D
      IF (RMS.LT.0.0)RMS=0.0

      RETURN
      END
C.....END U3B...........................................................