      SUBROUTINE vacuum(rmnc, rmns, zmns, zmnc, xm, xn, rcurr, zcurr,
     1   plascur, rbtor, wint, ns, ivac_skip, ivac, mnmax, ier_flag,
     2   lscreen)
      USE vacmod
      USE vparams, ONLY: nthreed, zero, one, mu0
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: ns, ivac_skip, ivac, mnmax, ier_flag
      REAL(rprec) :: plascur, rbtor
      REAL(rprec), DIMENSION(mnmax), INTENT(in) ::
     1   rmnc, rmns, zmns, zmnc, xm, xn
      REAL(rprec), DIMENSION(nv), INTENT(in) :: rcurr, zcurr
      REAL(rprec), DIMENSION(*), INTENT(in) :: wint
      LOGICAL :: lscreen
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: mn, n, n1, m, i
      REAL(rprec), DIMENSION(:), POINTER :: potcos, potsin
      REAL(rprec), ALLOCATABLE :: bsubu(:), bsubv(:), potu(:), potv(:)
      REAL(rprec), ALLOCATABLE :: amatrix(:)
      REAL(rprec):: dn2, dm2, cosmn, sinmn, huv, hvv,
     1    det, bsupu, bsupv, bsubuvac, fac
C-----------------------------------------------
!
!     THIS ROUTINE COMPUTES .5 * B**2 ON THE VACUUM / PLASMA SURFACE
!     BASED ON THE PROGRAM BY P. MERKEL [J. Comp. Phys. 66, 83 (1986)]
!     AND MODIFIED BY W. I. VAN RIJ AND S. P. HIRSHMAN (1987)

!     THE USER MUST SUPPLY THE FILE << MGRID >> WHICH INCLUDES THE MAGNETIC
!     FIELD DATA TO BE READ BY THE SUBROUTINE BECOIL
!     THE "VACUUM.INC" FILE IS DEFINED IN VMEC.UNIX
!
!
      IF (.not.ALLOCATED(potvac)) STOP 'POTVAC not ALLOCATED in VACCUM'

      ALLOCATE (amatrix(mnpd2*mnpd2), bsubu(nuv2), bsubv(nuv2),
     1    potu(nuv2), potv(nuv2), stat = i)
      IF (i .ne. 0) STOP 'Allocation error in vacuum'

      potsin => potvac(1:mnpd)
      potcos => potvac(1+mnpd:)

      ALLOCATE (bexu(nuv2), bexv(nuv2), bexn(nuv2),
     1     bexni(nuv2), r1b(nuv), rub(nuv2), rvb(nuv2),
     2     z1b(nuv), zub(nuv2), zvb(nuv2), auu(nuv2), auv(nuv2),
     3     avv(nuv2), snr(nuv2), snv(nuv2), snz(nuv2), drv(nuv2),
     4     guu_b(nuv2), guv_b(nuv2), gvv_b(nuv2), rzb2(nuv),
     5     rcosuv(nuv), rsinuv(nuv), stat=i)
      IF (i .ne. 0) STOP 'Allocation error in vacuum'

!
!       INDEX OF LOCAL VARIABLES
!
!       rmnc,rmns,zmns,zmnc:     Surface Fourier coefficients (m,n) of R,Z
!       xm,xn:     m, n values corresponding to rc,zs array
!       rcurr,zcurr:
!                  Position of magnetic axis (toroidal current filament)
!       bsqvac:    B**2/2 at the vacuum INTERFACE
!       plascur:   net toroidal current
!       mnmax:     number of R, Z modes in Fourier series of R,Z
!       ivac_skip: regulates whether full (=0) or incremental (>0)
!                 update of matrix elements is necessary
!
!
!       compute and store mean magnetic fields (due to
!       toroidal plasma current and EXTERNAL tf-coils)
!       note: these are fixed for a constant current iteration
!
!       bfield = rbtor*grad(zeta) + plascur*grad("theta") - grad(potential)
!
!       where "theta" is computed using Biot-Savart law for filaments
!       Here, the potential term is needed to satisfy B dot dS = 0 and has the form:
!
!       potential = SUM potsin*SIN(mu - nv) + potcos*COS(mu - nv)
!

      IF (.not. ALLOCATED(tanu)) CALL precal
      CALL surface (rmnc, rmns, zmns, zmnc, xm, xn, mnmax)
      CALL bextern (rcurr, zcurr, plascur, rbtor, wint, ns)
!
!     Determine scalar magnetic potential POTVAC
!
      CALL scalpot (potvac, amatrix, wint, ns, ivac_skip)
      CALL solver (amatrix, potvac, mnpd2)
!
!       compute tangential covariant (sub u,v) and contravariant
!       (super u,v) magnetic field components on the plasma surface
!
      potu(:nuv2) = zero;  potv(:nuv2) = zero

      mn = 0
      DO n = -nf, nf
         dn2 = -(n*nfper)
         n1 = ABS(n)
         DO m = 0, mf
            mn = mn + 1
            dm2 = m
            DO i = 1, nuv2
               cosmn = cosu1(i,m)*cosv1(i,n1) + csign(n)*
     1                 sinu1(i,m)*sinv1(i,n1)
               potu(i) = potu(i) + dm2*potsin(mn)*cosmn
               potv(i) = potv(i) + dn2*potsin(mn)*cosmn
            END DO
            IF (.not.lasym) CYCLE
            DO i = 1, nuv2
               sinmn = sinu1(i,m)*cosv1(i,n1) - csign(n)*
     1                 cosu1(i,m)*sinv1(i,n1)
               potu(i) = potu(i) - dm2*potcos(mn)*sinmn
               potv(i) = potv(i) - dn2*potcos(mn)*sinmn
            END DO
         END DO
      END DO

      DO i = 1, nuv2
         bsubu(i) = potu(i) + bexu(i)                     !Covariant components
         bsubv(i) = potv(i) + bexv(i)
         huv = p5*guv_b(i)*(nfper)
         hvv = gvv_b(i)*(nfper*nfper)
         det = one/(guu_b(i)*hvv-huv*huv)
         bsupu = (hvv*bsubu(i)-huv*bsubv(i))*det          !Contravariant components
         bsupv = ((-huv*bsubu(i))+guu_b(i)*bsubv(i))*det
         bpolvac(i) = p5*bsubu(i)*bsupu                   !.5*|Bvac-u|**2
         bsqvac(i) = bpolvac(i) + p5*bsubv(i)*bsupv       !.5*|Bvac|**2
         brv(i) = rub(i)*bsupu + rvb(i)*bsupv
         bphiv(i) = r1b(i)*bsupv
         bzv(i) = zub(i)*bsupu + zvb(i)*bsupv
      END DO

!
!       PRINT OUT VACUUM PARAMETERS
!
      IF (ivac .eq. 0) THEN
         ivac = ivac + 1
         IF (lscreen) WRITE (*, 200) nfper, mf, nf, nu, nv
         WRITE (nthreed, 200) nfper, mf, nf, nu, nv
  200    FORMAT(/,2x,'In VACUUM, np =',i3,2x,'mf =',i3,2x,'nf =',i3,
     1      ' nu =',i3,2x,'nv = ',i4)
         bsubuvac = SUM(bsubu(:nuv2)*wint(ns:ns*nuv2:ns))*signgs*pi2    !-plasma current/pi2
         bsubvvac = SUM(bsubv(:nuv2)*wint(ns:ns*nuv2:ns))
         fac = 1.e-6_dp/mu0
         IF (lscreen )WRITE (*,1000) bsubuvac*fac,
     1       plascur*fac, bsubvvac, rbtor
         WRITE (nthreed, 1000) bsubuvac*fac, plascur*fac,
     1       bsubvvac, rbtor
 1000    FORMAT(2x,'2*pi * a * -BPOL(vac) = ',1p,e10.2,
     1      ' TOROIDAL CURRENT = ',e10.2,/,2x,'R * BTOR(vac) = ',
     2      e10.2,' R-BTOR = ',e10.2)
         IF (rbtor*bsubvvac .lt. zero) ier_flag = 7
         IF (ABS((plascur - bsubuvac)/rbtor) .gt. 1.e-2_dp)
     1      ier_flag = 10
      ENDIF

      IF (ALLOCATED(bexu))
     1    DEALLOCATE (bexu, bexv, bexn, bexni, r1b, rub, rvb, z1b, zub,
     2    zvb, auu, auv, avv, snr, snv, snz, drv, guu_b, guv_b, gvv_b,
     3    rzb2, rcosuv, rsinuv, stat=i)
      IF (i .ne. 0) STOP 'Deallocation error in vacuum'

      DEALLOCATE (amatrix, bsubu, bsubv, potu, potv, stat = i)

      END SUBROUTINE vacuum


      double precision function vol(s,n)
c     volume of massless phase space including all (2*pi)'s
      implicit none
      include 'constants.f'
      double precision s
      integer n,fac
      vol=twopi**(4-3*n)*(pi/two)**(n-1)*s**(n-2)
      vol=vol/dfloat(fac(n-1)*fac(n-2))
c      if (n .eq. 6) vol=vol/(5d0*4d0*3d0*2d0)/(4d0*3d0*2d0)
c      if (n .eq. 5) vol=vol/(4d0*3d0*2d0)    /(3d0*2d0)
c      if (n .eq. 4) vol=vol/(3d0*2d0)        /(2d0)
c      if (n .eq. 3) vol=vol/(2d0)            /(1d0)
      return
      end

      integer function fac(n)
      integer j,n
      j=1
      fac=1
 10   continue
      if (j .le. n) then
      fac=fac*j
      j=j+1
      else
      return
      endif
      go to 10
      end


module global_variables
  implicit none

! Mathematical parameters
  real(8),parameter :: pi = 4d0*atan(1d0)

! Physical constants
  real(8),parameter :: c_light = 137.035999139d0
  real(8),parameter :: a_B = 0.52917721067d0
  real(8),parameter :: eV = 27.2116d0

! Grit parameters
  integer,parameter :: NL = -2000, NR = 2000, NM = 300
  integer,parameter :: Nt = 30000
  real(8),parameter :: Hx = 10d0/a_B, dt = 0.02d0
  real(8) :: Lx(NL:NR)

! Fields and materials
  real(8) :: Azc(NL:NR),Azc_new(NL:NR),Azc_old(NL:NR)
  real(8) :: chi(NM),sigma(NM)
  real(8) :: tpulse = 10d0/0.02418d0 ,omega = 1.55d0/eV, I0 = 1d12
  real(8) :: f0 = 5.338d-9*sqrt(I0)
end module global_variables
!===============================================================================
program main
  use global_variables
  implicit none

  call initialization

end program main
!===============================================================================
subroutine initialize
  use global_variables
  implicit none
  integer :: ix

! Grid initialization
  do ix = NL,NR
     Lx(ix) = Hx*(dble(ix)-0.5d0)
  end do

! Material initialization
  chi = 4d0
  sigma = 0d0

! Field initialization
  Azc = 0d0; Azc_old = 0d0
  do ix = NL,NR

     tt = -Lx(ix)/c_light - 5d0*Hx/c_light - 0.5d0*tpulse
     if(abs(tt) < 0.5d0*tpulse) then
        Azc(ix) = - f0/omega*cos(omega*tt)*cos(pi*tt/tpulse)**2
     end if
     tt = -Lx(ix)/c_light - 5d0*Hx/c_light - 0.5d0*tpulse + dt
     if(abs(tt) < 0.5d0*tpulse) then
        Azc_old(ix) = - f0/omega*cos(omega*tt)*cos(pi*tt/tpulse)**2
     end if
  end do

  return
end subroutine initialize
!===============================================================================
!===============================================================================
!===============================================================================
!===============================================================================


!THIS MODULE IS USED TO PREDEFINE ALL COMMON VARIABLES INSTEAD OF USE COMMON BLOCKS in *.inc files
!_____________________________________________________________________________________________
!VARIABLE NAME      UNIT            PROPERTY      MEANS
!NL                  --                        I4                  THE NUMBERS OF SOIL LAYERS
!ROOTC                  kg C/ha            array,R4      Root carbon in soil layers
!ROOTN                  kg N/ha            array, R4      Root NITROGEN in soil layers
!RDCL                  kg C/ha            array, R4      Root DEATH CARBON LOSS in soil layers
!RDNL                  kg N/ha            array, R4      Root DEATH NITROGEN LOSS in soil layers
!RDENSITY            cm/ha/m            array, R4      Root LENGTH DENSITY in soil layers
!NROOTC                  kg C/ha            R4                  New carbon allocated to root
!NROOTN                  kg N/ha            R4                  New nitrogen allocated to root
!MAXD                  cm                  R4                  The maximum rooting depth of a variety
!SWCX                  --                  arry, R4      Soil water contents in layers
!SNH4X                  kg N/ha            array, R4      soil NH4-N contents in layers
!SNO3X                  kg N/ha            array, R4      Soil NO3-N content in layers
!STX                  oC                  array, R4      Soil temperature in layers
!SANDX                  %                  array, R4      Soil sand contents in layers
!CLAYX                  %                  array, R4      Clay content in layers
!BDX                  Mg/m3            array, R4      Soil bulk density in layers
!IROOTD                  m                  R4                  Initial root depth at sowing depth for direct-seeding
!                                                                  or transplanting depth
!ROPTT                  oC                  R4                  Optimum temperature for root growth
!RMINT                  oC                  R4                  Minimum temperature for root growth
!RTBS                  oC                  R4          The lowest temperature for root to survive
!SROOTL                  cm/g C            R4                  Special root length
!RCNL                  --                  R4                  The C:N ratio of death root (lowest root C:N ratio)
!SDEP                  cm                  R4                  The depth of soil layers
!KST                  cm/d            R4, ARRAY      SATURATED HYDRAULIC CONDUCTIVITY
!TKL                  m                  R4,ARRAY      The thickness of EACH SOIL LAYER
!TKLT                  m                  R4                  TOTAL THICKNESS OF ALL SOIL LAYERS
!WCL                  --                  R4,ARRAY      SOIL WATER CONTENT IN EACH LAYER
!WCLI                  --                  R4,ARRAY      INITIAL WATER CONTENT OF SOIL LAYER
!WCLINT                  --                  R4                  INTERPOLATION TABLE FOR WATER CONTENT FOR SOIL LAYERS
!WCLQT                  --                  R4,ARRAY      ACTUAL SOIL WATER CONTENT OF EACH SOIL LAYER
!WCFC                  --                  R4,ARRAY      The soil field capacity
!WCST                  --          R4,ARRAY      The soil saturated water content
!WCSTRP                  --                  R4, ARRAY      SATURATED WATER CONTENT OF RIPENED SOIL
!WCWP                  --          R4,ARRAY    The soil wilting point
!WCAD                  --                  R4,ARRAY      The air dry soil water content
!VGA                  /cm                  R4,ARRAY      van GENUCHTEN ALPHA PARAMETER
!VGL                  --                  R4,ARRAY      van GENUCHTEN LAMBDA PARAMETER
!VGN                  --                  R4,ARRAY      van GENUCHTEN n PARAMETER
!VGR                  --                  R4,ARRAY      van GENUCHTEN RESIDUAL WATER CONTENT
!PN                        --                  R4,ARRAY      PARAMETER n IN POWER FUNCTION FOR HYDRAULIC CONDUCTIVITY
!SWITKH                  --                  LOGICAL            HYDRAULIC CONDUCTIVITY SWITCH
!DVS                  --                  R4                  DEVELOPMENT STAG
!RRCC                  kg C/ha/t      R4,ARRAY      ROOT CARBON CHANGE RATE PER TIME STEP
!RRNC                  kg N/ha/t      R4,ARRAY      ROOT NITROGEN CHANGE RATE PER TIME STEP
!ROOTNC				kg N/kg ROOT DM								THE N TO C RATIO OF ROOT
!RRDNL                  kg N/ha/t      R4,ARRAY      ROOT DEATH NITROGEN LOSS RATE PER TIME STEP
!RRDCL                  kg C/ha/t      R4,ARRAY      ROOT DEATH CARBON LOSS RATE PER TIME STEP
!RRDENSIT            cm/ha/t            R4,ARRAY      ROOT LENGTH DENSITY CHANGE RATE PER TIME STEP
!MAXNO                  --                  R4                  THE POINT OF ROOTING CLUSTER
!REFFECD            m                  I4                  THE ROOT DEPTH ABOVE WHICH THE ROOT IS MORE 95% OF TOTAL
!cCO2                  PPM                  R4                  THE REFERENCE ATMOSPHERIC [CO2]
!cKNF                  --                  R4                  REFERENCE EXTINCTION COEFFICIENT OF LIGHT IN CANOPY
!cNFLV                  --                  R4          REFERENCE EXTINCTION COEFFICIENT OF NITROGEN IN CANOPY
!cREDFT                  --                  R4                  REFERENCE DIRECT RADIATION FRACTION
!ILZMAX                  --                  I4                  INITIAL MAX GROUND WATER LAYERS
!IZWTB                  d,m                  I4                  INITIAL TABLE WITH GROUNDWATER TABLE DEPTH AS FUNCTION OF DAY NUMBER
!ZWA                  cm                  R4                  DEPTH THAT GROUNDWATER RECEDES IN CASE OF NO RECHARGE
!ZWB                  --                  R4                  SENSITIVITY FACTOR OF RECHARGE OF GROUNDWATER TABLE
!MAXGW                  cm                  R4                  MAXIMUM GROUNDWATER TABLE DEPTH
!MINGW                  cm                  R4                  MINIMUM GROUNDWATER TABLE DEPTH
!ZWTBI                  cm                  R4                  INITIAL DEPTH OF GRUNDWATER TABLE BELOW SOIL SURFACE
!ZWTB                  d,m                  R4                  TABLE WITH GROUNDAWATER TABLE DEPTH AS FUNCTION OF DAY NUMBER
!DVS                                    R4                  DEVELOPMENT STAGE
!DELT                  d                  R4                  SIMULATING TIME STEP
!SODT                  --                  R4                  THE TOLERANCE OF SOIL OXGENY DEFICIENCY (0 TO 1)
!IUNITD                  --                  I4                  Unit that can be used for input files (-)           C/IN *
!IUNITL                  --                  I4                  Unit for log file messages (-)                      C/IN *
!FILEI2                  --                  C*                  Name of input file no. 2 (-)                        C/IN *
!OUTPUT                  --                  L4                  Flag to indicate if output should be done (-)        C/I *
!DOY                  d                  R4                  Day number (January 1 = 1) (d)                        I  *
!YEAR                  y                  R4                  Year number
!DELT                  d                  R4                  Time step of integration (d)                          T  *
!TIME                  d                  R4                  Time of simulation (d)                                T  *
!CROPSTA            --                  I4                  Crop stage (-)                                        I  *
!ESTAB                  --                  C*                  Mode of establishment (-)                             I  *
!RAIN                  mm/d            R4                  Daily amount of rainfall (mm d-1)                     I  *
!EVSC                  mm/d            R4                  Potential soil evaporation rate (mm d-1)              I  *
!TRWL                  mm/d            R4,Array      Actual transpiration rate/layer (mm d-1)     I  *
!TRW                  mm/d            R4                  Actual transpiration rate (mm d-1)                    I  *
!IR                        mm/d            R4                  Amount of daily irrigation (mm d-1)                   I  *
!ZRTMS                  m                  R4                  Maximum rooting depth of soil profile (m)             O  *
!TKLP                  m                  R4,Array      Layer thicknesses (m)                        O  *
!WL0                  mm                  R4                  Depth of ponded water (mm)                            O  *
!MSKPA                  kPa                  R4,Array      Soil water tension/soil layer (kPa)          O  *
!IFLAG                                    I4
!ISTAT1                                    I4
!ISTAT2                                    I4
!ISTN                                    I4
!ANGA                                    R4
!ANGB                                    R4
!ELEV                                    R4
!LAT                                    R4
!LONG                                    R4
!RDD                                    R4
!TMMN                                    R4
!TMMX                                    R4
!VP                                          R4
!WN                                          R4
!WTRMES                                    L4
!WTRTER                                    L4
!WTRDIR                                    C80
!CNTR                                    C7
!WSTAT                                    C6
!DUMMY                                    C1
!IUNITR                                    I4
!IUNITD                                    I4
!IUNITO                                    I4
!IUNITL                                    I4
!IUNITC                                    I4
!FILEON                                    C128
!FILEOL                                    C128
!FILEIC                                    C128
!FILEIR                                    C128
!FILEIT                                    C128
!FILEI1                                    C128
!FILEI2                                    C128
!FILEI3                                    C128
!FILEI4                                    C128
!FILEI5                                    C128
!INOD                                    I4
!IOD                                    I4
!IMNOD                                    I4
!IOBSD                                    I4,ARRAY            WITH IMNOD DEMINSIONS
!TRC                  mm/d            R4                  potential transpiration rate of crop              I  !
!
!TRWL                  mm/d            R4                  Actual transpiration rate per layer               I  !                                                                 *
!________________________________________________________________________________________________________________

!MODULE VARIABLES
!=================================================================================================================
!Global variables:: Because of the use of POINTER for global variables, the local variable which has same name would
!					not be affects for their values and references
!=================================================================================================================
!1. Soil Parameters: All array have dimension 0 for surface residue or pond, broadcast fertilizer also goes into it
!-----------------------------------------------------------------------------------------------------------------

!	INTEGER SL
!	REAL CLAYX(0:10), SANDX(0:10), SILTX(0:10), BD(0:10), LAYT(0:10), SDEP(0:10)
!	REAL SPH(0:10), SCEC(0:10), SNH4X(0:10), SNO3X(0:10), SNH3X(0:10), UREA(0:10)
!	REAL PLOWL1, SOC(0:10), SON(0:10)

!	  REAL RRCC(10),RRNC(10), RRDCL(10), RRDNL(10),RRDENSIT(10)
!      REAL ROOTN(10),ROOTC(10), RDCL(10), RDNL(10), RDENSITY(10)
!      REAL NROOTC, NROOTN, MAXD, RCNL, SROOTL, theRootC
!      REAL IROOTD, ROPTT, RMINT, RTBS, MAXDEP, SODT
!      REAL REFFECD, REFCD_O, ROOTNC
 !END MODULE VARIABLES

 module public_module
!	Purpose:
!	this module is used to store the public values that are used by different
!	sub-models, subroutines and other modules
!	Note:
!	All variables in this module are started with 'P' to indicate public_variables,
!	these variables are update and recalled at thier needed place. If it is array,
!	the lower boundary is 0, the higher boundary is 15. The lower deminsion '0' is used
!	for surface residue or surface ponded water pool.
!
	 type public_variables

!-------------------------------------------------------------------------------------------------------------------
!3. Management Parameters
!-------------------------------------------------------------------------------------------------------------------

!-------------------------------------------------------------------------------------------------------------------
!4. Output Parameters
!-------------------------------------------------------------------------------------------------------------------

!		 REAL STATE(120)			!This variable is used to store state variables which need write into output file

!--------------------------------------------------------------------------------------------------------------------
!5. CONTROL AND MODEL RUNNING PARAMETERS
!--------------------------------------------------------------------------------------------------------------------

		 INTEGER CRUN,  STARTRUN
		 LOGICAL PROOT_NUTRIENT, KILLSOIL, NBALANCE
		 character*10 pond_active
	!	public control parameters
		 integer PYear			!count current year at the end of last run
		 integer Pdoy			!count the days in a year at the end of last run
		 integer Pdae			!count the days afetr emergence
		 integer Pdat			!count the days after transplanting
	!	public soil chemical properties
		 real Pno3(0:15)		!soil NO3 content (kg/ha)
		 real Pnh4(0:15)		!soil NH4 content (kg/ha)
		 real PmineralizedN(0:15) !daily mineralized nitrogen in each soil layer (kh N/ha), negative is immobilized
		 real Purea(0:15)		!soil urea content (kg/ha)
		 real    pond_no3        ! mineral N as nitrate in pond (kg/ha)
		 real    pond_nh4        ! mineral N as ammonium in pond (kg/ha)
		 real    pond_urea       ! urea in pond (kg/ha)
		 real Psoc(0:15)		!soil organic carbon content (kg C/ha)
		 real Pson(0:15)		!soil organic nitrogen content (kg N/ha)
		 real pph(0:15)		!soil and surface(pond) pH
		 real PFOM_type(0:15)	!soil fresh organic residue types in a given day
		 real PFOM_C(0:15)	!soil fresh organic carbon (kg C/ha) in a given day
		 real PFOM_N(0:15)	!soil fresh organic nitrogen (kg N/ha) in a given day, 0 for surface residue
	!	 public soil physical properties
		 integer Pnl				!soil layers
		 real Pdlayer(15)		!Soil layer thickness (mm)
		 real Pbd(15)			!Soil bulk density (g/cm3)
		 real Psand(15)		!soil sand content (fraction)
		 real Pclay(15)		!soil clay content (fraction)
		 real Pkst(15)		!soil saturated water conductivity (cm/h)
		 real Pwcst(15)		!soil saturate water content (cm3/cm3)
		 real Pwcfc(15)		!soil field capacity (cm3/cm3)
		 real Pwcwp(15)		!soil wilting point (cm3/cm3)
		 real Pwcad(15)		!soil air drying water content (cm3/cm3)
		 real PplowDepth		!plow pan depth (m)
		 real Psoiltx(0:15)	!soil temperature (oC)
		 real Pwl0			!surface water level (mm)
		 real Pswc(0:15)		!soil water content (cm3/cm3)
		 real Pwflux(0:15)	!soil water flux (cm/day), it quantify the net changes in a given layer
		 REAL PTRWL(15)	!soil water uptake for quantify the interaction of water and nitrogen in nutrient uptake
		 real Prunoff			!soil surface runoff (mm/day)
		 real Pdrain			!soil drainage (mm/day)
		 REAL Pirrig			!IRRIGATION AMOUNT (MM)
	!	 public plant variable
		 real Plai			!daily green leaf area index
		 integer PResNum			!number of residue, maximum for 10
		 character(16) PResName(15)	!Residue name
		 Integer PResType(15)	!Residue type associate with each residue
		 real PResC(0:15,15)	!daily plant little fall carbon (kg C/ha), '0' use for above ground, 1 to 15 used for root
		 						!second deminsion is corresponding residues
		 real PResN(0:15,15)	!daily plant little fall nitrogen (kg N/ha), '0' use for above ground, 1 to 15 used for root
		 real         dlt_res_c_biom(15)    ! carbon from residues to biomass
		 real         dlt_res_c_hum(15)     ! carbon from residues to humic
		 real ProotD			!daily plant root depth of 95% concentration (m)
		 real PRootAD			!daily plant root actual depth (m)
		 real ProotDen(15)	!daily root total length (cm)
		 real PSROOTL			!special root length cm/g C
     real PRMINT			!minimum temperature for root growth
     real PROPTT			!optimum temperature of root growth
     real PRTBS			!minimim temperature for root to survive
     real PRCNL			!lowest root nitrogen content (residue root N content)
		 real PMAXD			!MAXIMUM ROOTING DEPTH (CM)
		 real PSODT            !TOLERANCE OF OXYGEN DEFICIENCY
	!	 Public climate variable
		 real PmaxT			!daily maximum air temperature (oC)
		 real PminT			!daily minimum air temperature
		 real PRad			!daily radiation (Mj/day)
		 real PRain			!daily precipitation (mm)
		 real PPressur		!daily vapor pressure (KPa)
		 real Pwind			!daily average wind speed (m/s)
		 real PETp			!potential evapotranspiration (mm/day)
		 real PETa			!actual evapotranspiration (mm/day)
		 real Pevap			!Actual evaporation from surface (mm/day)
		 real Ptrans			!Actual transpiration from plant (mm/day)
		 REAL PDt			!The temperature differences between canopy and air (oC)
		 REAL PRdn			!The daily net radiation (MJ/day)
		 REAL PLAALA        !The adjustment on phenology base, maximu, optimal sue to elevation, latitude
		 LOGICAL ISPHENAD   !The PHENOLOGY ADJUSTMENT only be used for large spatial scale modeling
		 CHARACTER*256 OPSTRING    !USE IT TO HOLD THE OUTPUT VARIABLE IN OP.DAT
	 end type public_variables
	 !following TYPE will be used in the rotation in a given soil
	 type temporary_soil_information
	!	public soil chemical properties
		 real Xsno3(0:15)		!soil NO3 content (kg/ha)
		 real Xsnh4(0:15)		!soil NH4 content (kg/ha)
		 real Xurea(0:15)		!soil urea content (kg/ha)
		 real Xpond_no3        ! mineral N as nitrate in pond (kg/ha)
		 real Xpond_nh4        ! mineral N as ammonium in pond (kg/ha)
		 real Xpond_urea       ! urea in pond (kg/ha)
		 real Xsoc(0:15)		!soil organic carbon content (kg C/ha)
		 real Xson(0:15)		!soil organic nitrogen content (kg N/ha)
		 real Xph(0:15)		!soil and surface(pond) pH
		 real XFOM_type(0:15)	!soil fresh organic residue types in a given day
		 real XFOM_C(0:15)	!soil fresh organic carbon (kg C/ha) in a given day
		 real XFOM_N(0:15)	!soil fresh organic nitrogen (kg N/ha) in a given day, 0 for surface residue
	!	 public soil physical properties
		 integer Xnl				!soil layers
		 real Xdlayer(15)		!Soil layer thickness (mm)
		 real Xbd(15)			!Soil bulk density (g/cm3)
		 real Xsand(15)		!soil sand content (fraction)
		 real Xclay(15)		!soil clay content (fraction)
		 real Xkst(15)		!soil saturated water conductivity (cm/h)
		 real Xwcst(15)		!soil saturate water content (cm3/cm3)
		 real Xwcfc(15)		!soil field capacity (cm3/cm3)
		 real Xwcwp(15)		!soil wilting point (cm3/cm3)
		 real Xwcad(15)		!soil air drying water content (cm3/cm3)
		 real XplowDepth		!plow pan depth (m)
		 real Xsoilt(0:15)	!soil temperature (oC)
		 real Xwl0			!surface water level (mm)
		 real Xswc(0:15)		!soil water content (cm3/cm3)
		 integer XResNum			!number of residue, maximum for 10
		 character(16) XResName(15)	!Residue name
		 Integer XResType(15)	!Residue type associate with each residue
		 real XResC(0:15,15)	!daily plant little fall carbon (kg C/ha), '0' use for above ground, 1 to 15 used for root
		 						!second deminsion is corresponding residues
		 real XResN(0:15,15)	!daily plant little fall nitrogen (kg N/ha), '0' use for above ground, 1 to 15 used for root
		 real Xdlt_res_c_biom(15)    ! carbon from residues to biomass
		 real Xdlt_res_c_hum(15)     ! carbon from residues to humic

	 end type temporary_soil_information
!	common /InstancePointers/ pv
!	save InstancePointers
	 type(public_variables),pointer::pv
	 type(temporary_soil_information), pointer::tsi
!	 SAVE         !&#@TAOLI
end module public_module

module GP
!      common block for communication with input routine
   real cCO2, cKNF, cNFLV, cREDFT, cAMaxSLN, cMinSLN
end module GP

module GWT
   INTEGER    ILZMAX, IZWTB
   PARAMETER (ILZMAX=400)
   REAL       ZWA, ZWB, MAXGW, MINGW, ZWTBI,ZWTB(ILZMAX)
end module GWT

module HYDCON
   REAL KST(10), WCAD(10), WCSTRP(10)
end module HYDCON

module NUCHT
   REAL  VGA(10), VGL(10), VGN(10), VGR(10)
end module NUCHT

module power
   REAL PN(10)
end module power

MODULE SPAW
	REAL SPAWA(10), SPAWB(10)
END MODULE SPAW

module swit
  INTEGER SWITKH
end module swit

MODULE CROP_N
   REAL xFNLV, xNFLV
END MODULE CROP_N


      SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA,
     $                   B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK,
     $                   LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC,
     $                   DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK,
     $                   DWORK, LDWORK, BWORK, LBWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of an H-infinity optimal n-state
C     controller
C
C              | AK | BK |
C          K = |----|----|,
C              | CK | DK |
C
C     using modified Glover's and Doyle's 1988 formulas, for the system
C
C              | A  | B1  B2  |   | A | B |
C          P = |----|---------| = |---|---|
C              | C1 | D11 D12 |   | C | D |
C              | C2 | D21 D22 |
C
C     and for the estimated minimal possible value of gamma with respect
C     to GTOL, where B2 has as column size the number of control inputs
C     (NCON) and C2 has as row size the number of measurements (NMEAS)
C     being provided to the controller, and then to compute the matrices
C     of the closed-loop system
C
C              | AC | BC |
C          G = |----|----|,
C              | CC | DC |
C
C     if the stabilizing controller exists.
C
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) D12 is full column rank and D21 is full row rank,
C
C     (A3) | A-j*omega*I  B2  | has full column rank for all omega,
C          |    C1        D12 |
C
C     (A4) | A-j*omega*I  B1  |  has full row rank for all omega.
C          |    C2        D21 |
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     JOB     (input) INTEGER
C             Indicates the strategy for reducing the GAMMA value, as
C             follows:
C             = 1: Use bisection method for decreasing GAMMA from GAMMA
C                  to GAMMAMIN until the closed-loop system leaves
C                  stability.
C             = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA
C                  for which the closed-loop system retains stability.
C             = 3: First bisection, then scanning.
C             = 4: Find suboptimal controller only.
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     GAMMA   (input/output) DOUBLE PRECISION
C             The initial value of gamma on input. It is assumed that
C             gamma is sufficiently large so that the controller is
C             admissible. GAMMA >= 0.
C             On output it contains the minimal estimated gamma.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading N-by-N part of this array contains the
C             controller state matrix AK.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             controller input matrix BK.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading NCON-by-N part of this array contains the
C             controller output matrix CK.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.
C             LDCK >= max(1,NCON).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
C             The leading NCON-by-NMEAS part of this array contains the
C             controller input/output matrix DK.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.
C             LDDK >= max(1,NCON).
C
C     AC      (output) DOUBLE PRECISION array, dimension (LDAC,2*N)
C             The leading 2*N-by-2*N part of this array contains the
C             closed-loop system state matrix AC.
C
C     LDAC    INTEGER
C             The leading dimension of the array AC.
C             LDAC >= max(1,2*N).
C
C     BC      (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON)
C             The leading 2*N-by-(M-NCON) part of this array contains
C             the closed-loop system input matrix BC.
C
C     LDBC    INTEGER
C             The leading dimension of the array BC.
C             LDBC >= max(1,2*N).
C
C     CC      (output) DOUBLE PRECISION array, dimension (LDCC,2*N)
C             The leading (NP-NMEAS)-by-2*N part of this array contains
C             the closed-loop system output matrix CC.
C
C     LDCC    INTEGER
C             The leading dimension of the array CC.
C             LDCC >= max(1,NP-NMEAS).
C
C     DC      (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON)
C             The leading (NP-NMEAS)-by-(M-NCON) part of this array
C             contains the closed-loop system input/output matrix DC.
C
C     LDDC    INTEGER
C             The leading dimension of the array DC.
C             LDDC >= max(1,NP-NMEAS).
C
C     RCOND   (output) DOUBLE PRECISION array, dimension (4)
C                      For the last successful step:
C             RCOND(1) contains the reciprocal condition number of the
C                      control transformation matrix;
C             RCOND(2) contains the reciprocal condition number of the
C                      measurement transformation matrix;
C             RCOND(3) contains an estimate of the reciprocal condition
C                      number of the X-Riccati equation;
C             RCOND(4) contains an estimate of the reciprocal condition
C                      number of the Y-Riccati equation.
C
C     Tolerances
C
C     GTOL    DOUBLE PRECISION
C             Tolerance used for controlling the accuracy of GAMMA
C             and its distance to the estimated minimal possible
C             value of GAMMA.
C             If GTOL <= 0, then a default value equal to sqrt(EPS)
C             is used, where EPS is the relative machine precision.
C
C     ACTOL   DOUBLE PRECISION
C             Upper bound for the poles of the closed-loop system
C             used for determining if it is stable.
C             ACTOL <= 0 for stable systems.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)),
C             where
C             LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2;
C             LW2 = max( ( N + NP1 + 1 )*( N + M2 ) +
C                          max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ),
C                        ( N + NP2 )*( N + M1 + 1 ) +
C                          max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ),
C                        M2 + NP1*NP1 + max( NP1*max( N, M1 ),
C                                            3*M2 + NP1, 5*M2 ),
C                        NP2 + M1*M1 +  max( max( N, NP1 )*M1,
C                                            3*NP2 + M1, 5*NP2 ) );
C             LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ),
C                                      6*min( ND1, M1 ) ),
C                        NP1*ND2 + max( 4*min( NP1, ND2 ) +
C                                                        max( NP1,ND2 ),
C                                       6*min( NP1, ND2 ) ) );
C             LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP;
C             LW5 = 2*N*N + M*N + N*NP;
C             LW6 = max( M*M   + max( 2*M1, 3*N*N +
C                                     max( N*M, 10*N*N + 12*N + 5 ) ),
C                        NP*NP + max( 2*NP1, 3*N*N +
C                                     max( N*NP, 10*N*N + 12*N + 5 ) ));
C             LW7 = M2*NP2 + NP2*NP2 + M2*M2 +
C                   max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ),
C                        ND2*ND2 + max( 2*ND2, ND2*M2 ), 3*N,
C                        N*( 2*NP2 + M2 ) +
C                        max( 2*N*M2, M2*NP2 +
C                                     max( M2*M2 + 3*M2, NP2*( 2*NP2 +
C                                          M2 + max( NP2, N ) ) ) ) );
C             M1  = M   - M2, NP1 = NP - NP2,
C             ND1 = NP1 - M2, ND2 = M1 - NP2.
C             For good performance, LDWORK must generally be larger.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C
C     LBWORK  INTEGER
C             The dimension of the array BWORK.  LBWORK >= 2*N.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrix | A-j*omega*I  B2  | had not full
C                                 |    C1        D12 |
C                   column rank in respect to the tolerance EPS;
C             = 2:  if the matrix | A-j*omega*I  B1  |  had not full row
C                                 |    C2        D21 |
C                   rank in respect to the tolerance EPS;
C             = 3:  if the matrix D12 had not full column rank in
C                   respect to the tolerance SQRT(EPS);
C             = 4:  if the matrix D21 had not full row rank in respect
C                   to the tolerance SQRT(EPS);
C             = 5:  if the singular value decomposition (SVD) algorithm
C                   did not converge (when computing the SVD of one of
C                   the matrices |A   B2 |, |A   B1 |, D12 or D21);
C                                |C1  D12|  |C2  D21|
C             = 6:  if the controller is not admissible (too small value
C                   of gamma);
C             = 7:  if the X-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties);
C             = 8:  if the Y-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties);
C             = 9:  if the determinant of Im2 + Tu*D11HAT*Ty*D22 is
C                   zero [3];
C             = 10: if there are numerical problems when estimating
C                   singular values of D1111, D1112, D1111', D1121';
C             = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22
C                   are singular to working precision;
C             = 12: if a stabilizing controller cannot be found.
C
C     METHOD
C
C     The routine implements the Glover's and Doyle's 1988 formulas [1],
C     [2], modified to improve the efficiency as described in [3].
C
C     JOB = 1: It tries with a decreasing value of GAMMA, starting with
C     the given, and with the newly obtained controller estimates of the
C     closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL)
C     the iterations can be continued until the given tolerance between
C     GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the
C     next step GAMMA is increased. The step in the all next iterations
C     is step = step/2. The closed-loop system is obtained by the
C     formulas given in [2].
C
C     JOB = 2: The same as for JOB = 1, but with non-varying step till
C     GAMMA = 0, step = max(0.1, GTOL).
C
C     JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker
C     procedure.
C
C     JOB = 4: Suboptimal controller for current GAMMA only.
C
C     REFERENCES
C
C     [1] Glover, K. and Doyle, J.C.
C         State-space formulae for all stabilizing controllers that
C         satisfy an Hinf norm bound and relations to risk sensitivity.
C         Systems and Control Letters, vol. 11, pp. 167-172, 1988.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, MA, 1995.
C
C     [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
C         Fortran 77 routines for Hinf and H2 design of continuous-time
C         linear control systems.
C         Rep. 98-14, Department of Engineering, Leicester University,
C         Leicester, U.K., 1998.
C
C     NUMERICAL ASPECTS
C
C     The accuracy of the result depends on the condition numbers of the
C     input and output transformations and on the condition numbers of
C     the two Riccati equations, as given by the values of RCOND(1),
C     RCOND(2), RCOND(3) and RCOND(4), respectively.
C     This approach by estimating the closed-loop system and checking
C     its poles seems to be reliable.
C
C     CONTRIBUTORS
C
C     A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov,
C     July 2003.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H-infinity optimal control, robust
C     control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, P1, THOUS
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                     P1 = 0.1D+0, THOUS = 1.0D+3 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC,
     $                   LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK,
     $                   LIWORK, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   ACTOL, GAMMA, GTOL
C     ..
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ),
     $                   B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ),
     $                   C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ),
     $                   DWORK( * ), RCOND( 4 )
C     ..
C     .. Local Scalars ..
      INTEGER            I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1,
     $                   IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY,
     $                   IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5,
     $                   LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE,
     $                   NP1, NP11, NP2
      DOUBLE PRECISION   GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG,
     $                   TOL2
C     ..
C     .. External Functions ..
      LOGICAL            SELECT
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD,
     $                   SB10RD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode and test input parameters.
C
      M1   = M - NCON
      M2   = NCON
      NP1  = NP - NMEAS
      NP2  = NMEAS
      NP11 = NP1 - M2
      M11  = M1 - NP2
C
      INFO = 0
      IF ( JOB.LT.1 .OR. JOB.GT.4 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( NP.LT.0 ) THEN
         INFO = -4
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -5
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -6
      ELSE IF( GAMMA.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -15
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -19
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -21
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -23
      ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN
         INFO = -25
      ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN
         INFO = -27
      ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN
         INFO = -29
      ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN
         INFO = -31
      ELSE
C
C        Compute workspace.
C
         LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2
         LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) +
     $                MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ),
     $              ( N + NP2 )*( N + M1 + 1 ) +
     $                MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ),
     $              M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1,
     $                                  5*M2 ),
     $              NP2 + M1*M1 +  MAX( MAX( N, NP1 )*M1, 3*NP2 + M1,
     $                                  5*NP2 ) )
         LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ),
     $                             6*MIN( NP11, M1 ) ),
     $              NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ),
     $                             6*MIN( NP1, M11 ) ) )
         LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP
         LW5 = 2*N*N + M*N + N*NP
         LW6 = MAX( M*M   + MAX( 2*M1, 3*N*N +
     $                           MAX( N*M, 10*N*N + 12*N + 5 ) ),
     $              NP*NP + MAX( 2*NP1, 3*N*N +
     $                           MAX( N*NP, 10*N*N + 12*N + 5 ) ) )
         LW7 = M2*NP2 + NP2*NP2 + M2*M2 +
     $         MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ),
     $              M11*M11 + MAX( 2*M11, M11*M2 ), 3*N,
     $              N*( 2*NP2 + M2 ) +
     $              MAX( 2*N*M2, M2*NP2 +
     $                           MAX( M2*M2 + 3*M2, NP2*( 2*NP2 +
     $                                M2 + MAX( NP2, N ) ) ) ) )
         MINWRK = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) )
         IF( LDWORK.LT.MINWRK ) THEN
            INFO = -38
         ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ),
     $                           N*N ) ) THEN
            INFO = -36
         ELSE IF( LBWORK.LT.2*N ) THEN
            INFO = -40
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB10AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
         RCOND( 1 ) = ONE
         RCOND( 2 ) = ONE
         RCOND( 3 ) = ONE
         RCOND( 4 ) = ONE
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
      MODE = JOB
      IF ( MODE.GT.2 )
     $   MODE = 1
      GTOLL = GTOL
      IF( GTOLL.LE.ZERO ) THEN
C
C        Set the default value of the tolerance for GAMMA.
C
         GTOLL = SQRT( DLAMCH( 'Epsilon' ) )
      END IF
C
C     Workspace usage 1.
C
      IWC  = 1 + N*M
      IWD  = IWC + NP*N
      IWTU = IWD + NP*M
      IWTY = IWTU + M2*M2
      IWRK = IWTY + NP2*NP2
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
C
      CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP )
C
      CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP )
C
C     Transform the system so that D12 and D21 satisfy the formulas
C     in the computation of the Hinf optimal controller.
C     Workspace:  need   LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4),
C                 prefer larger,
C                 where
C             LW1  = N*M + NP*N + NP*M + M2*M2 + NP2*NP2
C             LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)),
C             LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)),
C             LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2),
C             LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2),
C             with M1 = M - M2 and NP1 = NP - NP2.
C             Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is
C             LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1).
C
      TOL2 = -ONE
C
      CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N,
     $             DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ),
     $             M2, DWORK( IWTY ), NP2, RCOND, TOL2, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
C
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
C
      IF ( INFO2.NE.0 ) THEN
         INFO = INFO2
         RETURN
      END IF
C
C     Workspace usage 2.
C
      IWD1 = IWRK
      IWS1 = IWD1 + NP11*M1
C
C     Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']).
C     Workspace:  need   LW1 + MAX(1, LWS1, LWS2),
C                 prefer larger,
C                 where
C     LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1))
C     LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11))
C
      INFO2 = 0
      INFO3 = 0
C
      IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN
         IWRK = IWS1 + MIN( NP11, M1 )
         CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1),
     $                NP11 )
         CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11,
     $                DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
         LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 )
      ELSE
         DWORK(IWS1) = ZERO
      END IF
C
      IWS2 = IWD1 + NP1*M11
      IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN
         IWRK = IWS2 + MIN( NP1, M11 )
         CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1),
     $                NP1 )
         CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2),
     $                DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, INFO3 )
         LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 )
      ELSE
         DWORK(IWS2) = ZERO
      END IF
C
      GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) )
C
      IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN
         INFO = 10
         RETURN
      ELSE IF ( GAMMA.LE.GAMAMN ) THEN
         INFO = 6
         RETURN
      END IF
C
C     Workspace usage 3.
C
      IWX  = IWD1
      IWY  = IWX + N*N
      IWF  = IWY + N*N
      IWH  = IWF + M*N
      IWRK = IWH + N*NP
      IWAC = IWD1
      IWWR = IWAC + 4*N*N
      IWWI = IWWR + 2*N
      IWRE = IWWI + 2*N
C
C     Prepare some auxiliary variables for the gamma iteration.
C
      STEPG  = GAMMA - GAMAMN
      GAMABS = GAMMA
      GAMAMX = GAMMA
      INF = 0
C
C     ###############################################################
C
C     Begin the gamma iteration.
C
   10 CONTINUE
         STEPG = STEPG/TWO
C
C        Try to compute the state feedback and output injection
C        matrices for the current GAMMA.
C
         CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N,
     $                DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ),
     $                M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ),
     $                N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1,
     $                BWORK, INFO2 )
C
         IF ( INFO2.NE.0 ) GOTO 30
C
C        Try to compute the Hinf suboptimal (yet) controller.
C
         CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N,
     $                DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ),
     $                M, DWORK( IWH ), N, DWORK( IWTU ), M2,
     $                DWORK( IWTY ), NP2, DWORK( IWX ), N, DWORK( IWY ),
     $                N, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, IWORK,
     $                DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
C
         IF ( INFO2.NE.0 ) GOTO 30
C
C        Compute the closed-loop system.
C        Workspace: need   LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP;
C                   prefer larger.
C
         CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D,
     $                LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC,
     $                LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK,
     $                DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 )
C
         IF ( INFO2.NE.0 ) GOTO 30
C
         LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 )
C
C        Compute the poles of the closed-loop system.
C        Workspace:  need   LW1 + 4*N*N + 4*N + max(1,6*N);
C                    prefer larger.
C
         CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N )
C
         CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK,
     $               DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1,
     $               DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 )
C
         LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 )
C
C        Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda),
C        for I=0,2*N-1.
C
         MINEAC = -THOUS
C
         DO 20 I = 0, 2*N - 1
            MINEAC = MAX( MINEAC, DWORK(IWWR+I) )
   20    CONTINUE
C
C        Check if the closed-loop system is stable.
C
   30    IF ( MODE.EQ.1 ) THEN
            IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN
               GAMABS = GAMMA
               GAMMA  = GAMMA - STEPG
               INF = 1
            ELSE
               GAMMA = MIN( GAMMA + STEPG, GAMAMX )
            END IF
         ELSE IF ( MODE.EQ.2 ) THEN
            IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN
               GAMABS = GAMMA
               INF = 1
            END IF
            GAMMA = GAMMA - MAX( P1, GTOLL )
         END IF
C
C        More iterations?
C
         IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN
            MODE  = 2
            GAMMA = GAMABS
         END IF
C
         IF ( JOB.NE.4 .AND.
     $        ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR.
     $          MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN
            GOTO 10
         END IF
C
C     ###############################################################
C
C     End of the gamma iteration - Return if no stabilizing controller
C     was found.
C
      IF ( INF.EQ.0 ) THEN
         INFO = 12
         RETURN
      END IF
C
C     Now compute the state feedback and output injection matrices
C     using GAMABS.
C
      GAMMA = GAMABS
C
C     Integer workspace:  need   max(2*max(N,M-NCON,NP-NMEAS),N*N).
C     Workspace: need   LW1P +
C                       max(1,M*M + max(2*M1,3*N*N +
C                                       max(N*M,10*N*N+12*N+5)),
C                           NP*NP + max(2*NP1,3*N*N +
C                                       max(N*NP,10*N*N+12*N+5)));
C                prefer larger,
C             where LW1P = LW1 + 2*N*N + M*N + N*NP.
C             An upper bound of the second term after LW1P is
C             max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))).
C
      CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N,
     $             DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ),
     $             M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ),
     $             N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1,
     $             BWORK, INFO2 )
C
      LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF ( INFO2.GT.0 ) THEN
         INFO = INFO2 + 5
         RETURN
      END IF
C
C     Compute the Hinf optimal controller.
C     Integer workspace:  need   max(2*(max(NP,M)-M2-NP2,M2,N),NP2).
C     Workspace: need   LW1P +
C                       max(1, M2*NP2 + NP2*NP2 + M2*M2 +
C                           max(D1*D1 + max(2*D1, (D1+D2)*NP2),
C                               D2*D2 + max(2*D2, D2*M2), 3*N,
C                               N*(2*NP2 + M2) +
C                               max(2*N*M2, M2*NP2 +
C                                           max(M2*M2+3*M2, NP2*(2*NP2+
C                                                  M2+max(NP2,N))))))
C                       where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11;
C                prefer larger.
C             An upper bound of the second term after LW1P is
C             max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))).
C
      CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N,
     $             DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ),
     $             M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ),
     $             NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK,
     $             LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
C
      LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 )
C
      IF( INFO2.EQ.1 ) THEN
         INFO = 6
         RETURN
      ELSE IF( INFO2.EQ.2 ) THEN
         INFO = 9
         RETURN
      END IF
C
C     Integer workspace:  need   2*max(NCON,NMEAS).
C     Workspace: need   2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP;
C                prefer larger.
C
      CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D,
     $             LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC,
     $             LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK,
     $             LDWORK, INFO2 )
C
      IF( INFO2.GT.0 ) THEN
         INFO = 11
         RETURN
      END IF
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10AD ***
      END


	subroutine chand (xphi,xmuv,xmus,xtau
     s			,xrray)
!*
!Description: routine used to compute the intrinsic reflectance of a pure
! molecular atmosphere.

!Input parameters:

!	float xphi:  relative azimuth angle: difference between the sun azimuth
!  	and the sensor azimuth (in degree)

!	float xmuv:  cosine of the view zenith angle (unitless).

!	float xmus:  cosine of the sun zenith angle (unitless).

!	float xtau:  optical depth of the molecules (unitless).

!Output Parameters:

!	float xrray:  intrinsic atmospheric reflectance in case of
!	pure molecular scattering.

!Revision History:
!$LOG: CHAND.f,v1.0$

!Original version: Wed Dec 13 09:33:38 EST 1995
!E. VERMOTE (eric@kratmos.gsfc.nasa.gov)

!Developer Header:

!DEVELOPPERS:  Eric F Vermote, eric@kratmos.gsfc.nasa.gov, 301-286-6232

!References and Credits:

!Design Notes: this is a 6S routine.
!END****************************************************************************
*/
c input parameters: xphi,xmus,xmuv,xtau
c xphi: azimuthal difference between sun and observation (xphi=0,
c in backscattering) and expressed in degree (0.:360.)
c xmus: cosine of the sun zenith angle
c xmuv: cosine of the observation zenith angle
c xtau: molecular optical depth
c output parameter: xrray : molecular reflectance (0.:1.)
c constant : xdep: depolarization factor (0.0279)
	real xdep,pl(10)
	real fs0,fs1,fs2
	real as0(10),as1(2),as2(2)
        real xphi,xmus,fac,xmuv,xtau,xrray,pi,phios,xcosf1,xcosf2
        real xcosf3,xbeta2,xfd,xph1,xph2,xph3,xitm, xp1, xp2, xp3
        real cfonc1,cfonc2,cfonc3,xlntau,xitot1,xitot2,xitot3
        integer i
	data (as0(i),i=1,10) /.33243832,-6.777104e-02,.16285370
     s	,1.577425e-03,-.30924818,-1.240906e-02,-.10324388
     s	,3.241678e-02,.11493334,-3.503695e-02/
	data (as1(i),i=1,2) /.19666292, -5.439061e-02/
	data (as2(i),i=1,2) /.14545937,-2.910845e-02/
	pi=3.1415927
	fac=pi/180.
	phios=180.-xphi
	xcosf1=1.
	xcosf2=cos(phios*fac)
	xcosf3=cos(2*phios*fac)
	xbeta2=0.5
	xdep=0.0279
	xfd=xdep/(2-xdep)
	xfd=(1-xfd)/(1+2*xfd)
	xph1=1+(3*xmus*xmus-1)*(3*xmuv*xmuv-1)*xfd/8.
	xph2=-xmus*xmuv*sqrt(1-xmus*xmus)*sqrt(1-xmuv*xmuv)
	xph2=xph2*xfd*xbeta2*1.5
	xph3=(1-xmus*xmus)*(1-xmuv*xmuv)
	xph3=xph3*xfd*xbeta2*0.375
	xitm=(1-exp(-xtau*(1/xmus+1/xmuv)))*xmus/(4*(xmus+xmuv))
	xp1=xph1*xitm
	xp2=xph2*xitm
	xp3=xph3*xitm
	xitm=(1-exp(-xtau/xmus))*(1-exp(-xtau/xmuv))
	cfonc1=xph1*xitm
	cfonc2=xph2*xitm
	cfonc3=xph3*xitm
	xlntau=log(xtau)
	pl(1)=1.
	pl(2)=xlntau
	pl(3)=xmus+xmuv
	pl(4)=xlntau*pl(3)
	pl(5)=xmus*xmuv
	pl(6)=xlntau*pl(5)
	pl(7)=xmus*xmus+xmuv*xmuv
	pl(8)=xlntau*pl(7)
	pl(9)=xmus*xmus*xmuv*xmuv
	pl(10)=xlntau*pl(9)
	fs0=0.
	do i=1,10
	fs0=fs0+pl(i)*as0(i)
	enddo
	fs1=pl(1)*as1(1)+pl(2)*as1(2)
	fs2=pl(1)*as2(1)+pl(2)*as2(2)
	xitot1=xp1+cfonc1*fs0*xmus
	xitot2=xp2+cfonc2*fs1*xmus
	xitot3=xp3+cfonc3*fs2*xmus
	xrray=xitot1*xcosf1
	xrray=xrray+xitot2*xcosf2*2
	xrray=xrray+xitot3*xcosf3*2
	xrray=xrray/xmus
	return
	end


**********************************************************************
**********************************************************************
      subroutine setmult(lensdata,lensmax,nlens,cell,cellmax,ncell,i1
     &	,i2)
*
* calculates quadrupole and higher moments for every cell that contains
* more than one lens;  called once, after the set-up of all lenses
*
* input :
*         lensdata(3,.)            data of lenses
*         lensmax                  maximal number of lenses
*         ncell                  actual number of this cell
*         cell(14,.)                data of cells
*         cellmax                  maximal number of cells
*         nlens                    total number of lenses
*         i1                       position of first lens in this cell
*         i2                       position of last lens in this cell
*
* output: cell(5,k),cell(6,k)   quadrupole terms of cell #k
*         cell(7,k),cell(8,k)   octopole   terms of cell #k
*         cell(9,k),cell(10,k)   16-pole    terms of cell #k
*         cell(11,k),cell(12,k)   32-pole  terms of cell #k
*         cell(13,k),cell(14,k)   64-pole  terms of cell #k
*
* called in:
*           setcell
*
* use of subroutines:
*           none
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      integer cellmax,lensmax,nlens,ncell,debug,i1,i2,ii
      double precision cell(14,cellmax),lensdata(3,lensmax),xdum,xdum2
     &,xdum3,xdum4,xdum5,xdum6,ydum,ydum2,ydum3,ydum4,ydum5,ydum6
      common/test/debug
*
* initialize:
*
      do ii = 5,14
         cell(ii,ncell) = 0.0
      enddo
*
* calculate multipole moments for this cell
*
      do ii = i1,i2
         xdum  = lensdata(1,ii) - cell(1,ncell)
         ydum  = lensdata(2,ii) - cell(2,ncell)
         xdum2 = xdum *xdum
         ydum2 = ydum *ydum
         xdum3 = xdum *xdum2
         ydum3 = ydum *ydum2
         xdum4 = xdum2*xdum2
         ydum4 = ydum2*ydum2
         xdum5 = xdum2*xdum3
         ydum5 = ydum2*ydum3
         xdum6 = xdum3*xdum3
         ydum6 = ydum3*ydum3
*
*    quadrupole terms:
*
         cell(5, ncell) = cell(5, ncell)
     &      + lensdata(3,ii)*( xdum2 - ydum2 )
         cell(6, ncell) = cell(6, ncell)
     &      + lensdata(3,ii)*2 * xdum*ydum
*
*    octopole terms:
*
         cell(7, ncell) = cell(7, ncell)
     &      + lensdata(3,ii)*( xdum3 - 3*xdum*ydum2 )
         cell(8, ncell) = cell(8, ncell)
     &      + lensdata(3,ii)*( 3*xdum2*ydum - ydum3 )
*
*    16-pole terms:
*
         cell(9, ncell) = cell(9, ncell)
     &      + lensdata(3,ii)*( xdum4 - 6*xdum2*ydum2 + ydum4 )
         cell(10,ncell) = cell(10,ncell)
     &      + lensdata(3,ii)*4 * ( xdum3*ydum - xdum*ydum3 )
*
*    32-pole terms:
*
         cell(11,ncell) = cell(11,ncell)
     &      + lensdata(3,ii)*(xdum5-10*xdum3*ydum2+5*xdum*ydum4)
         cell(12,ncell) = cell(12,ncell)
     &      + lensdata(3,ii)*(5*xdum4*ydum-10*xdum2*ydum3+ydum5)
*
*    64-pole terms:
*
         cell(13,ncell) = cell(13,ncell)
     &      + lensdata(3,ii)*(xdum6-15*xdum4*ydum2+15*xdum2*ydum4-ydum6)
         cell(14,ncell) = cell(14,ncell)
     &      + lensdata(3,ii)*(6*xdum5*ydum-20*xdum3*ydum3+6*xdum*ydum5)
      enddo
*
      return
      end


  subroutine Zm_setup( &
        nsmax,                          &
        k,             maxlay,          m,             &
        mmax,          maxstr,          maxleg,        &
        gmu,           weightCabRam,    wl_Ray,        &
        wl_Cab,        wl_Ram,          Zm_Ray_min,    &
        Zm_Ray_plus,   Zm_Cab_min,      Zm_Cab_plus,   &
        Zm_Ram_min,    Zm_Ram_plus,     Zm_CabRam_min, &
        Zm_CabRam_plus)

!--------------------------------------------------------------------
!
! Subroutine:
!    Zm_setup
!
! Purpose:
!    Calculate phasefunction coefficients Zm
!    for each wavenumber n,
!    for each layer k,
!    and each Fourier moment m
!
!--------------------------------------------------------------------
!
! Phasefunction is written as
!
!                      mmax
!    phasefunction Z =  SUm  Zm * cos[ m* (phiV-phi0) ]
!                       m=0
! where
!              mmax
!    Zm_min  =  SUm  wlm * plm(-mu_out) * plm(+mu_in)
!               l=m
! and
!              mmax
!    Zm_plus =  SUm  wlm * plm(+mu_out) * plm(+mu_in)
!               l=m
! Generate wlm from phasefunction coefficents Wl using
!
!    wlm = [2-delta(0,m)] * [(l-m)!/(l+m)!] * Wl
!
! See e.g. Eqs.(3.1.11b), (3.1.13) in K.N.liou -
! "Radiation and Cloud Processes in the Atmosphere" (1992)
!
! Remember that wlm_Ray and wlm_Cab are a function of wavenumber
!
!--------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
     nsmax,   &  !nr of wavenrs emerging light
     k,       &  !layer index
     maxlay,  &  !nr of layers
     m,       &  !Fourier moment index
     mmax,    &  !maximum Fourier moment
     maxleg,  &  !Maximum Legendre moment (molecular scatt.=2)
     maxstr      !nr of streams

! Gaussian quadrature
  real(kind=dp),intent(in)::gmu(maxstr)

! weight for eff.Cab+Ram mix
  real(kind=dp),intent(in)::weightCabRam(maxlay,0:nsmax)

  integer::i1,i2,lg

! wavenr index of emerging light
  integer::ns

  real(kind=dp)::d0m,two_d0m

! functions
  real(kind=dp),external::faculty,plm

  real(kind=dp),dimension(0:maxleg),intent(in):: &
     wl_Ray, &
     wl_Cab, &
     wl_Ram

  real(kind=dp):: &
     wlm_Ray, &
     wlm_Cab, &
     wlm_Ram

! phase matrices, depend on n, m
  real(kind=dp),intent(out)::     &
     Zm_Ray_min(maxstr,maxstr),   &
     Zm_Cab_min(maxstr,maxstr),   &
     Zm_Ram_min(maxstr,maxstr),   &
     Zm_Ray_plus(maxstr,maxstr),  &
     Zm_Cab_plus(maxstr,maxstr),  &
     Zm_Ram_plus(maxstr,maxstr)

! mixture of Cab and Ram, depends on n, m, k, mix for each ns
  real(kind=dp),intent(out)::               &
     Zm_CabRam_min(0:nsmax,maxstr,maxstr),  &
     Zm_CabRam_plus(0:nsmax,maxstr,maxstr)

  d0m = 0.d0
  if(m.eq.0) d0m = 1.d0
  two_d0m = 2.d0-d0m

  do i2=1,maxstr
     do i1=1,maxstr

        Zm_Ray_min(i1,i2)  = 0.d0
        Zm_Ray_plus(i1,i2) = 0.d0
        Zm_Cab_min(i1,i2)  = 0.d0
        Zm_Cab_plus(i1,i2) = 0.d0
        Zm_Ram_min(i1,i2)  = 0.d0
        Zm_Ram_plus(i1,i2) = 0.d0
        do ns=0,nsmax
           Zm_CabRam_min(ns,i1,i2)  = 0.d0
           Zm_CabRam_plus(ns,i1,i2) = 0.d0
        enddo

        do lg=m,mmax

           wlm_Ray = two_d0m *                      &
                      faculty(lg-m)/faculty(lg+m) * &
                       wl_Ray(lg)
           wlm_Cab = two_d0m *                      &
                      faculty(lg-m)/faculty(lg+m) * &
                       wl_Cab(lg)
           wlm_Ram = two_d0m *                      &
                      faculty(lg-m)/faculty(lg+m) * &
                       wl_Ram(lg)

           Zm_Ray_min( i1,i2) = Zm_Ray_min(i1,i2) +    &
                                 wlm_Ray *             &
                                  plm(lg,m,-gmu(i1)) * &
                                   plm(lg,m, gmu(i2))
           Zm_Cab_min( i1,i2) = Zm_Cab_min(i1,i2) +    &
                                 wlm_Cab *             &
                                  plm(lg,m,-gmu(i1)) * &
                                   plm(lg,m, gmu(i2))
           Zm_Ram_min( i1,i2) = Zm_Ram_min(i1,i2) +    &
                                 wlm_Ram *             &
                                  plm(lg,m,-gmu(i1)) * &
                                   plm(lg,m, gmu(i2))

           Zm_Ray_plus(i1,i2) = Zm_Ray_plus(i1,i2) +   &
                                 wlm_Ray *             &
                                  plm(lg,m, gmu(i1)) * &
                                   plm(lg,m,gmu(i2))

           Zm_Cab_plus(i1,i2) = Zm_Cab_plus(i1,i2) +   &
                                 wlm_Cab *             &
                                  plm(lg,m,gmu(i1)) *  &
                                   plm(lg,m,gmu(i2))

           Zm_Ram_plus(i1,i2) = Zm_Ram_plus(i1,i2) +   &
                                 wlm_Ram *             &
                                  plm(lg,m,gmu(i1)) *  &
                                   plm(lg,m,gmu(i2))

        enddo

        do ns=0,nsmax

           if(weightCabRam(k,ns).ne.1.d0)then
              Zm_CabRam_min(ns,i1,i2) =                           &
                       weightCabRam(k,ns)  * Zm_Cab_min(i1,i2) +  &
                 (1.d0-weightCabRam(k,ns)) * Zm_Ram_min(i1,i2)

              Zm_CabRam_plus(ns,i1,i2) =                        &
                       weightCabRam(k,ns)  * Zm_Cab_plus(i1,i2) + &
                 (1.d0-weightCabRam(k,ns)) * Zm_Ram_plus(i1,i2)

            else !keep Cabannes value

               Zm_CabRam_min( ns,i1,i2) = Zm_Cab_min(i1,i2)
               Zm_CabRam_plus(ns,i1,i2) = Zm_Cab_plus(i1,i2)

            endif

         enddo

     enddo

  enddo

  return
  end subroutine Zm_setup

!****************************************************************

  function faculty(somenumber)
!-------------------------------------------------------------------
! Function:
!   faculty
!
! Purpose:
!   Calculate N!=N*(N-1)*(N-2)...*1
!   where N! is returned in double precision
!-------------------------------------------------------------------
  implicit none
  integer,parameter::dp=selected_real_kind(8) !double precision
  integer::somenumber,i
  real(kind=dp)::prod,faculty
  if(somenumber.eq.0)then
     faculty = 1.d0
     return
  endif
  prod = 1.d0
  do i=1,somenumber
     prod = prod * dble(i)
  enddo
  faculty = prod
  return
  end function faculty


subroutine pressure(gsqrt, bsq, wint)

      use stel_kinds, only: dp
      use name1, only: nznt
      use scalars, only: ns, hs, dnorm
      use profs, only: vp, mass, pres
      use inputdat, only: gam
      use fsqu, only: wp

      implicit none

      ! TODO: more elegant definition of these BLAS functions
      real(kind=dp) :: ddot

      real(kind=dp), intent(in)  :: gsqrt(ns,nznt)
      real(kind=dp), intent(out) :: bsq  (ns,nznt)
      real(kind=dp), intent(in)  :: wint (ns,nznt)

      integer :: js, lk

      do js = 2, ns
        vp(js) = dnorm*abs(ddot(nznt, gsqrt(js,1), ns, wint(js,1), ns))
      end do

      do js = 2, ns
        pres(js) = mass(js)/vp(js)**gam
      end do

      wp = hs*ddot(ns, vp, 1, pres, 1)

      ! bsq gets a scalar offset of the kinetic pressure on each flux surface
      do js = 2, ns
        do lk = 1, nznt
          bsq(js, lk) = pres(js)
        end do
      end do

      return
end


*DECK DSTEPS
      SUBROUTINE DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K,
     +   KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G,
     +   PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV,
     +   KGI, GI, RPAR, IPAR)
C***BEGIN PROLOGUE  DSTEPS
C***PURPOSE  Integrate a system of first order ordinary differential
C            equations one step.
C***LIBRARY   SLATEC (DEPAC)
C***CATEGORY  I1A1B
C***TYPE      DOUBLE PRECISION (STEPS-S, DSTEPS-D)
C***KEYWORDS  ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE,
C             ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR
C***AUTHOR  Shampine, L. F., (SNLA)
C           Gordon, M. K., (SNLA)
C             MODIFIED BY H.A. WATTS
C***DESCRIPTION
C
C   Written by L. F. Shampine and M. K. Gordon
C
C   Abstract
C
C   Subroutine  DSTEPS  is normally used indirectly through subroutine
C   DDEABM .  Because  DDEABM  suffices for most problems and is much
C   easier to use, using it should be considered before using  DSTEPS
C   alone.
C
C   Subroutine DSTEPS integrates a system of  NEQN  first order ordinary
C   differential equations one step, normally from X to X+H, using a
C   modified divided difference form of the Adams Pece formulas.  Local
C   extrapolation is used to improve absolute stability and accuracy.
C   The code adjusts its order and step size to control the local error
C   per unit step in a generalized sense.  Special devices are included
C   to control roundoff error and to detect when the user is requesting
C   too much accuracy.
C
C   This code is completely explained and documented in the text,
C   Computer Solution of Ordinary Differential Equations, The Initial
C   Value Problem  by L. F. Shampine and M. K. Gordon.
C   Further details on use of this code are available in "Solving
C   Ordinary Differential Equations with ODE, STEP, and INTRP",
C   by L. F. Shampine and M. K. Gordon, SLA-73-1060.
C
C
C   The parameters represent --
C      DF -- subroutine to evaluate derivatives
C      NEQN -- number of equations to be integrated
C      Y(*) -- solution vector at X
C      X -- independent variable
C      H -- appropriate step size for next step.  Normally determined by
C           code
C      EPS -- local error tolerance
C      WT(*) -- vector of weights for error criterion
C      START -- logical variable set .TRUE. for first step,  .FALSE.
C           otherwise
C      HOLD -- step size used for last successful step
C      K -- appropriate order for next step (determined by code)
C      KOLD -- order used for last successful step
C      CRASH -- logical variable set .TRUE. when no step can be taken,
C           .FALSE. otherwise.
C      YP(*) -- derivative of solution vector at  X  after successful
C           step
C      KSTEPS -- counter on attempted steps
C      TWOU -- 2.*U where U is machine unit roundoff quantity
C      FOURU -- 4.*U where U is machine unit roundoff quantity
C      RPAR,IPAR -- parameter arrays which you may choose to use
C            for communication between your program and subroutine F.
C            They are not altered or used by DSTEPS.
C   The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G,
C   W,P,IV and GI are required for the interpolation subroutine SINTRP.
C   The remaining variables and arrays are included in the call list
C   only to eliminate local retention of variables between calls.
C
C   Input to DSTEPS
C
C      First call --
C
C   The user must provide storage in his calling program for all arrays
C   in the call list, namely
C
C     DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
C    1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
C    2  RPAR(*),IPAR(*)
C
C    **Note**
C
C   The user must also declare  START ,  CRASH ,  PHASE1  and  NORND
C   logical variables and  DF  an EXTERNAL subroutine, supply the
C   subroutine  DF(X,Y,YP)  to evaluate
C      DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN))
C   and initialize only the following parameters.
C      NEQN -- number of equations to be integrated
C      Y(*) -- vector of initial values of dependent variables
C      X -- initial value of the independent variable
C      H -- nominal step size indicating direction of integration
C           and maximum size of step.  Must be variable
C      EPS -- local error tolerance per step.  Must be variable
C      WT(*) -- vector of non-zero weights for error criterion
C      START -- .TRUE.
C      YP(*) -- vector of initial derivative values
C      KSTEPS -- set KSTEPS to zero
C      TWOU -- 2.*U where U is machine unit roundoff quantity
C      FOURU -- 4.*U where U is machine unit roundoff quantity
C   Define U to be the machine unit roundoff quantity by calling
C   the function routine  D1MACH,  U = D1MACH(4), or by
C   computing U so that U is the smallest positive number such
C   that 1.0+U .GT. 1.0.
C
C   DSTEPS  requires that the L2 norm of the vector with components
C   LOCAL ERROR(L)/WT(L)  be less than  EPS  for a successful step.  The
C   array  WT  allows the user to specify an error test appropriate
C   for his problem.  For example,
C      WT(L) = 1.0  specifies absolute error,
C            = ABS(Y(L))  error relative to the most recent value of the
C                 L-th component of the solution,
C            = ABS(YP(L))  error relative to the most recent value of
C                 the L-th component of the derivative,
C            = MAX(WT(L),ABS(Y(L)))  error relative to the largest
C                 magnitude of L-th component obtained so far,
C            = ABS(Y(L))*RELERR/EPS + ABSERR/EPS  specifies a mixed
C                 relative-absolute test where  RELERR  is relative
C                 error,  ABSERR  is absolute error and  EPS =
C                 MAX(RELERR,ABSERR) .
C
C      Subsequent calls --
C
C   Subroutine  DSTEPS  is designed so that all information needed to
C   continue the integration, including the step size  H  and the order
C   K , is returned with each step.  With the exception of the step
C   size, the error tolerance, and the weights, none of the parameters
C   should be altered.  The array  WT  must be updated after each step
C   to maintain relative error tests like those above.  Normally the
C   integration is continued just beyond the desired endpoint and the
C   solution interpolated there with subroutine  SINTRP .  If it is
C   impossible to integrate beyond the endpoint, the step size may be
C   reduced to hit the endpoint since the code will not take a step
C   larger than the  H  input.  Changing the direction of integration,
C   i.e., the sign of  H , requires the user set  START = .TRUE. before
C   calling  DSTEPS  again.  This is the only situation in which  START
C   should be altered.
C
C   Output from DSTEPS
C
C      Successful Step --
C
C   The subroutine returns after each successful step with  START  and
C   CRASH  set .FALSE. .  X  represents the independent variable
C   advanced one step of length  HOLD  from its value on input and  Y
C   the solution vector at the new value of  X .  All other parameters
C   represent information corresponding to the new  X  needed to
C   continue the integration.
C
C      Unsuccessful Step --
C
C   When the error tolerance is too small for the machine precision,
C   the subroutine returns without taking a step and  CRASH = .TRUE. .
C   An appropriate step size and error tolerance for continuing are
C   estimated and all other information is restored as upon input
C   before returning.  To continue with the larger tolerance, the user
C   just calls the code again.  A restart is neither required nor
C   desirable.
C
C***REFERENCES  L. F. Shampine and M. K. Gordon, Solving ordinary
C                 differential equations with ODE, STEP, and INTRP,
C                 Report SLA-73-1060, Sandia Laboratories, 1973.
C***ROUTINES CALLED  D1MACH, DHSTRT
C***REVISION HISTORY  (YYMMDD)
C   740101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSTEPS
C
      INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW,
     1      KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2,
     2      NSP1, NSP2
      DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH,
     1      EPS, ERK, ERKM1, ERKM2, ERKP1, ERR,
     2      FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R,
     3      REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1,
     4      TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT,
     5      X, XOLD, Y, YP
      LOGICAL START,CRASH,PHASE1,NORND
      DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12),
     1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10),
     2  RPAR(*),IPAR(*)
      DIMENSION TWO(13),GSTR(13)
      EXTERNAL DF
      SAVE TWO, GSTR
C
      DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8),
     1     TWO(9),TWO(10),TWO(11),TWO(12),TWO(13)
     2     /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0,
     3      512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/
      DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7),
     1     GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13)
     2     /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0,
     3      0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/
C
C       ***     BEGIN BLOCK 0     ***
C   CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE
C   PRECISION.  IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A
C   STARTING STEP SIZE.
C                   ***
C
C   IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE
C
C***FIRST EXECUTABLE STATEMENT  DSTEPS
      CRASH = .TRUE.
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5
      H = SIGN(FOURU*ABS(X),H)
      RETURN
 5    P5EPS = 0.5D0*EPS
C
C   IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE
C
      ROUND = 0.0D0
      DO 10 L = 1,NEQN
 10     ROUND = ROUND + (Y(L)/WT(L))**2
      ROUND = TWOU*SQRT(ROUND)
      IF(P5EPS .GE. ROUND) GO TO 15
      EPS = 2.0D0*ROUND*(1.0D0 + FOURU)
      RETURN
 15   CRASH = .FALSE.
      G(1) = 1.0D0
      G(2) = 0.5D0
      SIG(1) = 1.0D0
      IF(.NOT.START) GO TO 99
C
C   INITIALIZE.  COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP
C
C     CALL DF(X,Y,YP,RPAR,IPAR)
C     SUM = 0.0
      DO 20 L = 1,NEQN
        PHI(L,1) = YP(L)
   20   PHI(L,2) = 0.0D0
C20     SUM = SUM + (YP(L)/WT(L))**2
C     SUM = SQRT(SUM)
C     ABSH = ABS(H)
C     IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM)
C     H = SIGN(MAX(ABSH,FOURU*ABS(X)),H)
C
      U = D1MACH(4)
      BIG = SQRT(D1MACH(2))
      CALL DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG,
     1             PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H)
C
      HOLD = 0.0D0
      K = 1
      KOLD = 0
      KPREV = 0
      START = .FALSE.
      PHASE1 = .TRUE.
      NORND = .TRUE.
      IF(P5EPS .GT. 100.0D0*ROUND) GO TO 99
      NORND = .FALSE.
      DO 25 L = 1,NEQN
 25     PHI(L,15) = 0.0D0
 99   IFAIL = 0
C       ***     END BLOCK 0     ***
C
C       ***     BEGIN BLOCK 1     ***
C   COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP.  AVOID COMPUTING
C   THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED.
C                   ***
C
 100  KP1 = K+1
      KP2 = K+2
      KM1 = K-1
      KM2 = K-2
C
C   NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT
C   ONE.  WHEN K.LT.NS, NO COEFFICIENTS CHANGE
C
      IF(H .NE. HOLD) NS = 0
      IF (NS.LE.KOLD) NS = NS+1
      NSP1 = NS+1
      IF (K .LT. NS) GO TO 199
C
C   COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH
C   ARE CHANGED
C
      BETA(NS) = 1.0D0
      REALNS = NS
      ALPHA(NS) = 1.0D0/REALNS
      TEMP1 = H*REALNS
      SIG(NSP1) = 1.0D0
      IF(K .LT. NSP1) GO TO 110
      DO 105 I = NSP1,K
        IM1 = I-1
        TEMP2 = PSI(IM1)
        PSI(IM1) = TEMP1
        BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2
        TEMP1 = TEMP2 + H
        ALPHA(I) = H/TEMP1
        REALI = I
 105    SIG(I+1) = REALI*ALPHA(I)*SIG(I)
 110  PSI(K) = TEMP1
C
C   COMPUTE COEFFICIENTS G(*)
C
C   INITIALIZE V(*) AND SET W(*).
C
      IF(NS .GT. 1) GO TO 120
      DO 115 IQ = 1,K
        TEMP3 = IQ*(IQ+1)
        V(IQ) = 1.0D0/TEMP3
 115    W(IQ) = V(IQ)
      IVC = 0
      KGI = 0
      IF (K .EQ. 1) GO TO 140
      KGI = 1
      GI(1) = W(2)
      GO TO 140
C
C   IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*)
C
 120  IF(K .LE. KPREV) GO TO 130
      IF (IVC .EQ. 0) GO TO 122
      JV = KP1 - IV(IVC)
      IVC = IVC - 1
      GO TO 123
 122  JV = 1
      TEMP4 = K*KP1
      V(K) = 1.0D0/TEMP4
      W(K) = V(K)
      IF (K .NE. 2) GO TO 123
      KGI = 1
      GI(1) = W(2)
 123  NSM2 = NS-2
      IF(NSM2 .LT. JV) GO TO 130
      DO 125 J = JV,NSM2
        I = K-J
        V(I) = V(I) - ALPHA(J+1)*V(I+1)
 125    W(I) = V(I)
      IF (I .NE. 2) GO TO 130
      KGI = NS - 1
      GI(KGI) = W(2)
C
C   UPDATE V(*) AND SET W(*)
C
 130  LIMIT1 = KP1 - NS
      TEMP5 = ALPHA(NS)
      DO 135 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1)
 135    W(IQ) = V(IQ)
      G(NSP1) = W(1)
      IF (LIMIT1 .EQ. 1) GO TO 137
      KGI = NS
      GI(KGI) = W(2)
 137  W(LIMIT1+1) = V(LIMIT1+1)
      IF (K .GE. KOLD) GO TO 140
      IVC = IVC + 1
      IV(IVC) = LIMIT1 + 2
C
C   COMPUTE THE G(*) IN THE WORK VECTOR W(*)
C
 140  NSP2 = NS + 2
      KPREV = K
      IF(KP1 .LT. NSP2) GO TO 199
      DO 150 I = NSP2,KP1
        LIMIT2 = KP2 - I
        TEMP6 = ALPHA(I-1)
        DO 145 IQ = 1,LIMIT2
 145      W(IQ) = W(IQ) - TEMP6*W(IQ+1)
 150    G(I) = W(1)
 199    CONTINUE
C       ***     END BLOCK 1     ***
C
C       ***     BEGIN BLOCK 2     ***
C   PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED
C   SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K,
C   K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED.
C                   ***
C
C   INCREMENT COUNTER ON ATTEMPTED DSTEPS
C
      KSTEPS = KSTEPS + 1
C
C   CHANGE PHI TO PHI STAR
C
      IF(K .LT. NSP1) GO TO 215
      DO 210 I = NSP1,K
        TEMP1 = BETA(I)
        DO 205 L = 1,NEQN
 205      PHI(L,I) = TEMP1*PHI(L,I)
 210    CONTINUE
C
C   PREDICT SOLUTION AND DIFFERENCES
C
 215  DO 220 L = 1,NEQN
        PHI(L,KP2) = PHI(L,KP1)
        PHI(L,KP1) = 0.0D0
 220    P(L) = 0.0D0
      DO 230 J = 1,K
        I = KP1 - J
        IP1 = I+1
        TEMP2 = G(I)
        DO 225 L = 1,NEQN
          P(L) = P(L) + TEMP2*PHI(L,I)
 225      PHI(L,I) = PHI(L,I) + PHI(L,IP1)
 230    CONTINUE
      IF(NORND) GO TO 240
      DO 235 L = 1,NEQN
        TAU = H*P(L) - PHI(L,15)
        P(L) = Y(L) + TAU
 235    PHI(L,16) = (P(L) - Y(L)) - TAU
      GO TO 250
 240  DO 245 L = 1,NEQN
 245    P(L) = Y(L) + H*P(L)
 250  XOLD = X
      X = X + H
      ABSH = ABS(H)
      CALL DF(X,P,YP,RPAR,IPAR)
C
C   ESTIMATE ERRORS AT ORDERS K,K-1,K-2
C
      ERKM2 = 0.0D0
      ERKM1 = 0.0D0
      ERK = 0.0D0
      DO 265 L = 1,NEQN
        TEMP3 = 1.0D0/WT(L)
        TEMP4 = YP(L) - PHI(L,1)
        IF(KM2)265,260,255
 255    ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2
 260    ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2
 265    ERK = ERK + (TEMP4*TEMP3)**2
      IF(KM2)280,275,270
 270  ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2)
 275  ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1)
 280  TEMP5 = ABSH*SQRT(ERK)
      ERR = TEMP5*(G(K)-G(KP1))
      ERK = TEMP5*SIG(KP1)*GSTR(K)
      KNEW = K
C
C   TEST IF ORDER SHOULD BE LOWERED
C
      IF(KM2)299,290,285
 285  IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      GO TO 299
 290  IF(ERKM1 .LE. 0.5D0*ERK) KNEW = KM1
C
C   TEST IF STEP SUCCESSFUL
C
 299  IF(ERR .LE. EPS) GO TO 400
C       ***     END BLOCK 2     ***
C
C       ***     BEGIN BLOCK 3     ***
C   THE STEP IS UNSUCCESSFUL.  RESTORE  X, PHI(*,*), PSI(*) .
C   IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE.  IF STEP FAILS MORE
C   THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE.  DOUBLE ERROR
C   TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE
C   PRECISION.
C                   ***
C
C   RESTORE X, PHI(*,*) AND PSI(*)
C
      PHASE1 = .FALSE.
      X = XOLD
      DO 310 I = 1,K
        TEMP1 = 1.0D0/BETA(I)
        IP1 = I+1
        DO 305 L = 1,NEQN
 305      PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1))
 310    CONTINUE
      IF(K .LT. 2) GO TO 320
      DO 315 I = 2,K
 315    PSI(I-1) = PSI(I) - H
C
C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP
C   SIZE
C
 320  IFAIL = IFAIL + 1
      TEMP2 = 0.5D0
      IF(IFAIL - 3) 335,330,325
 325  IF(P5EPS .LT. 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK)
 330  KNEW = 1
 335  H = TEMP2*H
      K = KNEW
      NS = 0
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340
      CRASH = .TRUE.
      H = SIGN(FOURU*ABS(X),H)
      EPS = EPS + EPS
      RETURN
 340  GO TO 100
C       ***     END BLOCK 3     ***
C
C       ***     BEGIN BLOCK 4     ***
C   THE STEP IS SUCCESSFUL.  CORRECT THE PREDICTED SOLUTION, EVALUATE
C   THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE
C   DIFFERENCES.  DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP.
C                   ***
 400  KOLD = K
      HOLD = H
C
C   CORRECT AND EVALUATE
C
      TEMP1 = H*G(KP1)
      IF(NORND) GO TO 410
      DO 405 L = 1,NEQN
        TEMP3 = Y(L)
        RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16)
        Y(L) = P(L) + RHO
        PHI(L,15) = (Y(L) - P(L)) - RHO
 405    P(L) = TEMP3
      GO TO 420
 410  DO 415 L = 1,NEQN
        TEMP3 = Y(L)
        Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
 415    P(L) = TEMP3
 420  CALL DF(X,Y,YP,RPAR,IPAR)
C
C   UPDATE DIFFERENCES FOR NEXT STEP
C
      DO 425 L = 1,NEQN
        PHI(L,KP1) = YP(L) - PHI(L,1)
 425    PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2)
      DO 435 I = 1,K
        DO 430 L = 1,NEQN
 430      PHI(L,I) = PHI(L,I) + PHI(L,KP1)
 435    CONTINUE
C
C   ESTIMATE ERROR AT ORDER K+1 UNLESS:
C     IN FIRST PHASE WHEN ALWAYS RAISE ORDER,
C     ALREADY DECIDED TO LOWER ORDER,
C     STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE
C
      ERKP1 = 0.0D0
      IF(KNEW .EQ. KM1  .OR.  K .EQ. 12) PHASE1 = .FALSE.
      IF(PHASE1) GO TO 450
      IF(KNEW .EQ. KM1) GO TO 455
      IF(KP1 .GT. NS) GO TO 460
      DO 440 L = 1,NEQN
 440    ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2
      ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1)
C
C   USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER
C   FOR NEXT STEP
C
      IF(K .GT. 1) GO TO 445
      IF(ERKP1 .GE. 0.5D0*ERK) GO TO 460
      GO TO 450
 445  IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455
      IF(ERKP1 .GE. ERK  .OR.  K .EQ. 12) GO TO 460
C
C   HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE
C   BEEN LOWERED IN BLOCK 2.  THUS ORDER IS TO BE RAISED
C
C   RAISE ORDER
C
 450  K = KP1
      ERK = ERKP1
      GO TO 460
C
C   LOWER ORDER
C
 455  K = KM1
      ERK = ERKM1
C
C   WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP
C
 460  HNEW = H + H
      IF(PHASE1) GO TO 465
      IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465
      HNEW = H
      IF(P5EPS .GE. ERK) GO TO 465
      TEMP2 = K+1
      R = (P5EPS/ERK)**(1.0D0/TEMP2)
      HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R))
      HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H)
 465  H = HNEW
      RETURN
C       ***     END BLOCK 4     ***
      END