!Program read_60L-SD
 program read_60l_sd
        
!     Description:
!       
!     Read a sampled database of ECMWF profiles (see documentation)
!     The temperature, water vapour and ozone profiles are then 
!     extrapolated/interpolated to a given pressure grid
!     The grid here is the 43-level RTTOV grid.
!     To change it, just modify NLEVELS and XPRES.
!       
!     WARNING! The real profile is above surface pressure.
!              The extrapolation below creates information where
!              there is none and may provide unrealistic profiles.
!       
!     Method:
!     Simple
!       
!     Owner:
!     Frederic Chevallier
!       
!     History:
!     Version      Date        Comment
!     1            10/08/1999  Frederic Chevallier. ECMWF
!     2            16/08/1999  Marco Matricardi.    ECMWF
!                              radiances for IASI.
!     3            24/09/1999  Frederic Chevallier. ECMWF
!                              Clean up for SAF delivery
!     4            19/04/2001  Frederic Chevallier. ECMWF
!                              Fortran 90
!       
!     Code description:
!       Language:              Fortran 90.
!       Software Standards:    "European Standards for Writing and Documenting
!                              Exchangeable Fortran 90 code".
        
 implicit none
        
! Program arguments:
        
!   Local parameters:
 integer, parameter :: idim=50000
 integer, parameter :: klev=60
 integer, parameter :: nlevels=43
 integer, parameter :: xlev=klev+nlevels
 integer, parameter :: nslay = 4
 real, parameter :: mdry = 28.964 !molecular weight of dry air (g/mole)
 real, parameter :: mh2o = 18.    !molecular weight of H2O (g/mole)
 real, parameter :: mo3  = 48.    !molecular weight of O3  (g/mole)
        
!   Local arrays:
 real(kind=8)       :: arx(xlev)
 real(kind=8)       :: ary(xlev)
 real(kind=8)       :: aryint(nlevels)
 real(kind=8)       :: pap(klev)
 real(kind=8)       :: paph(klev+1)
 real(kind=8)       :: pres(klev)
 real(kind=8)       :: presfin(xlev)
 real(kind=8)       :: istl(nslay), stl(nslay), swvl(nslay)
 real(kind=4)       :: sistl(nslay), sstl(nslay), sswvl(nslay)
 real(kind=4)       :: stt(klev), swv(klev), so3(klev)
 real(kind=4)       :: sw(klev), scc(klev), sclw(klev), sciw(klev)
 real(kind=8)       :: tt(klev), wv(klev), o3(klev)
 real(kind=8)       :: w(klev), cc(klev), clw(klev), ciw(klev)
 real(kind=8)       :: wvs(xlev)
 real(kind=8)       :: wvvmfin(xlev)
 real(kind=8)       :: wvmmfin(xlev)
 real(kind=8)       :: wvmmextr(xlev)
 real(kind=8)       :: wvmm(klev+1)
 real(kind=8)       :: wvvmint(nlevels)
 real(kind=8)       :: wvmmint(nlevels)
 real(kind=8)       :: wvint(nlevels)
 real(kind=8)       :: o3vm(klev+1)
 real(kind=8)       :: o3vmfin(xlev)
 real(kind=8)       :: o3mmint(nlevels)
 real(kind=8)       :: o3vmint(nlevels)
 real(kind=8)       :: o3int(nlevels)
 real(kind=8)       :: xpres(nlevels)
 real(kind=8)       :: textr(nlevels)
 real(kind=8)       :: tfin(xlev)
 real(kind=8)       :: tint(nlevels)
 real(kind=8)       :: as(5,xlev)
   
!   Local scalars:
 real(kind=8)       :: spres
 real(kind=8)       :: const
 real(kind=8)       :: rh
 real(kind=8)       :: cvl, cvh, tvl, tvh, ci
 real(kind=8)       :: asn, rsn, tsn, sd, sr, al, oro
 real(kind=8)       :: psurf, q2m, st, rlsm, rlon, rlat, u10, v10, t2m
 real(kind=8)       :: gradt, gradq, grado
 real(kind=4)       :: scvl, scvh, stvl, stvh, sci
 real(kind=4)       :: sasn, srsn, stsn, ssd, ssr, sal, soro
 real(kind=4)       :: spsurf, sq2m, sst, srlsm, srlon, srlat, su10, sv10, st2m
 integer            :: jdat
 integer            :: iyyyy, iyyyymm, iyyyymmdd
 integer            :: iyear, imonth, iday, itime
 integer            :: levbot, levtop
 integer            :: iatm,jlev,i,index
 integer            :: nprof
   
! End of program arguments
        
!-----End of header-----------------------------------------------------
        
!-----Pressure grid to whom the atmospheric profile will be interpolated
 data xpres       /.1,.29,.69,1.42,2.611,4.407,6.95,10.37,14.81, &
 20.4,27.26,35.51,45.29,56.73,69.97,85.18,102.05,122.04, &
 143.84,167.95,194.36,222.94,253.71,286.6,321.5,358.28, &
 396.81,436.95,478.54,521.46,565.54,610.6,656.43,702.73, &
 749.12,795.09,839.95,882.8,922.46,957.44,985.88,1005.43,1013.25/
        
!-----------------------------------------------------------------------
!-----Open input file---------------------------------------------------
 open(1,file='60L_SDr.dat',form='unformatted')
        
!-----Begin loop on profiles
 iatmloop : do iatm = 1,idim
   read(1,end=50) &
     jdat, &                         ! date (yyyymmddhh)
     srlon, &                        ! longitude (deg)
     srlat, &                        ! latitude (deg)
     srlsm, &                        ! land/see mask (1=land, 0=sea)
     sst, &                          ! surface skin temperature (K)
     spsurf, &                       ! surface pressure (hPa)
     su10, &                         ! 10-meter u wind (m/s)
     sv10, &                         ! 10-meter v wind (m/s)
     st2m, &                         ! 2-meter temperature (K)
     sq2m, &                         ! 2-meter specific humidity (kg/kg)
     (stt(jlev),jlev = 1,klev), &    ! temperature (K)
     (swv(jlev),jlev = 1,klev), &    ! specific humidity (kg/kg)
     (so3(jlev),jlev = 1,klev), &    ! specific ozone (kg/kg)
     (scc(jlev),jlev = 1,klev), &    ! cloud cover
     (sclw(jlev),jlev = 1,klev), &   ! cloud liquid water content (kg/kg)
     (sciw(jlev),jlev = 1,klev), &   ! cloud ice water content (kg/kg)
     (sw(jlev),jlev = 1,klev), &     ! vertical velocity (Pa/s)
     scvl, &                         ! low vegetation cover
     scvh, &                         ! high vegetation cover
     stvl, &                         ! type of low vegetation 
     stvh, &                         ! type of high vegetation 
     sci, &                          ! ice cover
     sasn, &                         ! snow albedo (0-1)
     srsn, &                         ! snow density (kg/m3)
     stsn, &                         ! snow temperature (K)
     ssd, &                          ! snow depth (m)
     ssr, &                          ! surface roughness (m)
     sal, &                          ! surface albedo (0-1)
     (sistl(jlev),jlev = 1,nslay), & ! layer ice temp. (K)  (top to bottom)
     (sstl(jlev),jlev = 1,nslay), &  ! layer soil temp. (K) (top to bottom)
     (sswvl(jlev),jlev = 1,nslay),&  ! layer soil volumetric water (m3/m3) (top to bottom)
     soro                            ! surface geometric height (m)
   
!  if (abs(srlat) > 40. .or. srlsm > 0.) cycle iatmloop 

!-----Switch to double precision
   rlon = srlon
   rlat = srlat
   rlsm = srlsm
   st = sst
   psurf = spsurf
   u10 = su10
   v10 = sv10
   t2m = st2m
   q2m = sq2m
   tt(1:klev) = stt(1:klev)
   wv(1:klev) = swv(1:klev)
   o3(1:klev) = so3(1:klev)
   cc(1:klev) = scc(1:klev)
   clw(1:klev) = sclw(1:klev)
   ciw(1:klev) = sciw(1:klev)
   w(1:klev) = sw(1:klev)
   cvl = scvl
   cvh = scvh
   tvl = stvl
   tvh = stvh
   ci = sci
   asn = sasn
   rsn = srsn
   tsn = stsn
   sd = ssd
   sr = ssr
   al = sal
   do jlev = 1,nslay
     istl(jlev) = sistl(jlev)
     stl(jlev) = sstl(jlev)
     swvl(jlev) = sswvl(jlev)
   enddo
   oro = soro
!
   iyyyymmdd = jdat/100
   itime = jdat - iyyyymmdd*100
   iyyyymm = iyyyymmdd/100
   iday = iyyyymmdd - iyyyymm*100
   iyyyy = iyyyymm/100
   imonth = iyyyymm - iyyyy*100
   iyear = iyyyy
   
   spres = psurf*100.
   call ec_p60l(spres,pap,paph)
   pres(:)=pap(:)/100

!-----Unit conversion---------------------------------------------------
        
 do jlev = 1,klev
        
!-----Specific humidity(kg/kg) > Mass mixing ratio (g/g)----------------
    wvmm(jlev)= (wv(jlev)/(1-wv(jlev)))
        
!-----Specific ozone(kg/kg) > Volume mixing ratio (ppmv)----------------
    o3vm(jlev)= o3(jlev)/( (1-o3(jlev))*mo3/ mdry + o3(jlev) ) * 1e+06
        
 enddo
        
 wvmm(klev+1)= q2m/(1-q2m)
        
!-----------------------------------------------------------------------
 presfin(1:klev)=pres(1:klev)
 tfin(1:klev)=tt(1:klev)
 tfin(klev+1)=t2m
 wvmmfin(1:klev+1)=wvmm(1:klev+1)
 o3vmfin(klev+1)=o3vm(klev)
 o3vmfin(1:klev)=o3vm(1:klev)
!-----------------------------------------------------------------------
        
 levbot=0
 do i=1,nlevels
   if(xpres(i) > psurf ) then
     levbot=i
     exit
   endif
 enddo
   
 index = klev
 if (levbot /= 0 ) then
        
!-----Extrapolates temperature below surface pressure-------------------
        
   const= 287./1005.
   do i=levbot,nlevels
!----- => adiabatic heating
!    textr(i)=t2m * (xpres(i)/psurf)**const
!----- => constant profile
     textr(i)=t2m
   enddo
   
   index=nlevels-levbot+1
   index=index+klev+1
   tfin((klev+2):index)= textr(levbot:nlevels)
   
   presfin((klev+1))=psurf
   presfin((klev+2):index)=xpres(levbot:nlevels)
   
!-----Extrapolates water vapour below surface pressure------------------
!----- => constant relative humidity
        
   call supsat (tfin(klev+1),wvs(klev+1),psurf)
   rh=wvmm(klev+1)*1000/wvs(klev+1)
        
   do i=levbot,nlevels
     call supsat (textr(i),wvs(i),xpres(i))
     wvmmextr(i)=rh*wvs(i)/ 1000
   enddo
        
   wvmmfin((klev+2):index)=wvmmextr(levbot:nlevels)
   
!-----Extrapolates ozone below surface pressure------------------------
!----- => constant profile
        
   o3vmfin((klev+2):index)=o3vm(klev)
        
 endif
        
!-----------------------------------------------------------------------
        
 do i=1,index
   wvvmfin(i) = wvmmfin(i) / ( mh2o/mdry + wvmmfin(i)) * 1e+06
 enddo
        
!-----Extrapolates profile above highest declared level-----------------
!----- => linear extrapolation -----------------------------------------
        
 levtop = 1
 do jlev=1,index
   if(xpres(jlev) >= pres(1) ) exit
   levtop = levtop + 1
 enddo
        
 if (levtop /= 1) then
   gradt = (tfin(1) - tfin(2)) / (presfin(1)-presfin(2))
   gradq = (wvvmfin(1) - wvvmfin(2)) / (presfin(1)-presfin(2))
   grado = (o3vmfin(1) - o3vmfin(2)) / (presfin(1)-presfin(2))
   do jlev=index, 1, -1
     tfin(jlev+levtop-1) = tfin(jlev)
     wvvmfin(jlev+levtop-1) = wvvmfin(jlev)
     o3vmfin(jlev+levtop-1) = o3vmfin(jlev)
     presfin(jlev+levtop-1) = presfin(jlev)
   enddo
   index = index + levtop-1
   do jlev=1,levtop-1
     presfin(jlev) = xpres(jlev)
     tfin(jlev) = tfin(levtop) + gradt * (presfin(jlev) - presfin(levtop))
     wvvmfin(jlev) = wvvmfin(levtop) + gradq * (presfin(jlev) - presfin(levtop))
     o3vmfin(jlev) = o3vmfin(levtop) + grado * (presfin(jlev) - presfin(levtop))
   enddo
 endif
        
!-----Interpolates to given pressure grid-------------------------------
        
 arx(1:index)=presfin(1:index)
        
 ary(1:index)=tfin(1:index)
 call spline(arx,ary,xpres,aryint,as,index,nlevels,1)
 tint(:)=aryint(:)
        
 ary(1:index)=wvvmfin(1:index)
 call spline(arx,ary,xpres,aryint,as,index,nlevels,1)
 wvvmint(:)=aryint(:)

 ary(1:index)=o3vmfin(1:index)
 call spline(arx,ary,xpres,aryint,as,index,nlevels,1)
 o3vmint(:)=aryint(:)
!-----Spline interpolation may exceptionnally give negative values------
!----- => correction
 do i=1,nlevels
   wvvmint(i) = max( wvvmint(i), 0.01 )
   o3vmint(i) = max( o3vmint(i), 0.001 )
 enddo
        
        
!-----Unit conversions
 do jlev = 1,nlevels
!-----Volume mixing ratio (ppmv) > Mass mixing ratio (g/g)
    wvmmint(jlev)= mh2o/mdry * wvvmint(jlev) / (1.e+06-wvvmint(jlev))
    o3mmint(jlev)= mo3 /mdry * o3vmint(jlev) / (1.e+06-o3vmint(jlev)) 
!-----Mass mixing ratio (g/g)    > Specific humidity (kg/kg)
    wvint(jlev)= wvmmint(jlev) / ( 1+wvmmint(jlev) )
    o3int(jlev)= o3mmint(jlev) / ( 1+o3mmint(jlev) )
 enddo
        
!-----Exploitation of the profile---------------------------------------
!-----At this stage of the IATM loop, the following arrays are ---------
!-----       available on the XPRES grid : -----------------------------
!-----       - XPRES   in hPa              -----------------------------
!-----       - TINT    in K                -----------------------------
!-----       - WVINT   in kg/kg            -----------------------------
!-----       - WVMMINT in g/g              -----------------------------
!-----       - WVVMINT in ppmv             -----------------------------
!-----       - O3INT   in kg/kg            -----------------------------
!-----       - O3MMINT in g/g              -----------------------------
!-----       - O3VMINT in ppmv             -----------------------------
        
 do i=1,nlevels
   write(11,'(4e12.4)')xpres(i),tint(i),wvmmint(i),o3mmint(i)
 enddo
 write(11,'(80x)')
        
!-----------------------------------------------------------------------
        
!-----End loop on profiles
 enddo iatmloop
        
50    nprof = iatm - 1
 print*,'this dataset is made of ',nprof,' ecmwf model profiles'
 close(1)
        
 nprof = iatm - 1
        
 stop
 end program read_60l_sd
        
 subroutine ec_p60l(spres,pap,paph)
        
!     Description:
!     Computes the 60-level vertical pressure grid
!       associated to the input surface pressure
!     All pressures are in Pa
        
 implicit none
 integer, parameter    :: nlev=60
 integer               :: jk
 real(kind=8)          :: spres
 real(kind=8)          :: aam(nlev+1), bbm(nlev+1)
 real(kind=8)          :: pap(nlev), paph(nlev+1)
        
 data aam / &
      0.000000,    20.000000,    38.425343, &
     63.647804,    95.636963,   134.483307, &
    180.584351,   234.779053,   298.495789, &
    373.971924,   464.618134,   575.651001, &
    713.218079,   883.660522,  1094.834717, &
   1356.474609,  1680.640259,  2082.273926, &
   2579.888672,  3196.421631,  3960.291504, &
   4906.708496,  6018.019531,  7306.631348, &
   8765.053711, 10376.126953, 12077.446289, &
  13775.325195, 15379.805664, 16819.474609, &
  18045.183594, 19027.695313, 19755.109375, &
  20222.205078, 20429.863281, 20384.480469, &
  20097.402344, 19584.330078, 18864.750000, &
  17961.357422, 16899.468750, 15706.447266, &
  14411.124023, 13043.218750, 11632.758789, &
  10209.500977,  8802.356445,  7438.803223, &
   6144.314941,  4941.778320,  3850.913330, &
   2887.696533,  2063.779785,  1385.912598, &
    855.361755,   467.333588,   210.393890, &
     65.889244,     7.367743,     0.000000, &
      0.000000 &
          /

 data bbm / &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000000000, 0.0000000000, 0.0000000000, &
  0.0000758235, 0.0004613950, 0.0018151561, &
  0.0050811190, 0.0111429105, 0.0206778757, &
  0.0341211632, 0.0516904071, 0.0735338330, &
  0.0996746942, 0.1300225109, 0.1643843204, &
  0.2024759352, 0.2439331412, 0.2883229554, &
  0.3351548910, 0.3838921487, 0.4339629412, &
  0.4847715795, 0.5357099175, 0.5861684084, &
  0.6355474591, 0.6832686067, 0.7287858129, &
  0.7715966105, 0.8112534285, 0.8473749161, &
  0.8796569109, 0.9078838825, 0.9319403172, &
  0.9518215060, 0.9676452279, 0.9796627164, &
  0.9882701039, 0.9940194488, 0.9976301193, &
  1.0000000000 &
          /
   
 do jk=1,nlev+1
   paph(jk)=aam(jk)+bbm(jk)*spres
 end do
 do jk=1,nlev
   pap(jk)=0.5*(paph(jk)+paph(jk+1))
 end do
   
 return
 end subroutine ec_p60l
        
!     Check water vapour for super-saturation
 subroutine supsat(temp,wv,pres)
        
!     Description:
!     Computes water vapour super-saturation mixing ratio
!       
!     Method:
!       
!     Owner:
!     Marco Matricardi
!       
!     History:
!     Version      Date       Comment
!     1            16-8-1999  Marco Matricardi. ECMWF
!       
!     Code description:
!       Language:              Fortran 90.
!       Software Standards:    "European Standards for Writing and Documenting
!                              Exchangeable Fortran 90 code".
!       
        
        
 implicit none
        
        
!     Subroutine arguments:
        
!       Scalar arguments with intent in:
 real(kind=8),   intent(in) :: temp
 real(kind=8),   intent(in) :: pres
        
!       Scalar arguments with intent out:
 real(kind=8),   intent(out):: wv
        
!     End of subroutine arguments
        
!       Local scalars
 real(kind=8)   :: satlim
 real(kind=8)   :: htol
 real(kind=8)   :: svp
        
!-----End of header-----------------------------------------------------
 data satlim /1./
 data htol   /0./
        
        
 wv=svp(temp)*satlim
 wv=622.*wv/(pres-wv)+htol
        
 return
 end subroutine supsat
        
!     Saturated vapour pressure im mb
 function svp(temp)
        
!     Description:
!     Calculates saturated vapour pressure in mb given temperature in K.
!     Value corresponds to SVP over water for temperatures grater than 5 DEG,
!     to SVP over ice for temperatures less that 8 DEG., and to transitional
!     values between.
!       
!     Method:
!     This is the formula used by MET.O.11 AND MET.O.2B.
!       
!     Owner:
!     Marco Matricardi
!       
!     History:
!     Version      Date       Comment
!     1            16-8-1999  Marco Matricardi. ECMWF
!       
!     Code description:
!       Language:              Fortran 90.
!       Software Standards:    "European Standards for Writing and Documenting
!                              Exchangeable Fortran 90 code".
!       
        
        
 implicit none
        
!     Function arguments:
        
!       Scalar arguments with intent in:
 real(kind=8),   intent(in)    ::  temp
        
!     End of function arguments
        
        
!       Local arrays:
 real(kind=8)        ::  estab(156)
        
!       Local scalars:
 real(kind=8)        ::  tt
 real(kind=8)        ::  e0
 real(kind=8)        ::  e1
 real(kind=8)        ::  svp
 integer             ::  ind
 integer             ::  t0
   
!-----End of header-----------------------------------------------------
        
 data  estab(1:60) / &
 9.672e-5,1.160e-4,1.388e-4,1.658e-4,1.977e-4,2.353e-4, &
 2.796e-4,3.316e-4,3.925e-4,4.638e-4,5.472e-4,6.444e-4, &
 7.577e-4,8.894e-4,1.042e-3,1.220e-3,1.425e-3,1.662e-3, &
 1.936e-3,2.252e-3,2.615e-3,3.032e-3,3.511e-3,4.060e-3, &
 4.688e-3,5.406e-3,6.225e-3,7.159e-3,8.223e-3,9.432e-3, &
 1.080e-2,1.236e-2,1.413e-2,1.612e-2,1.838e-2,2.092e-2, &
 2.380e-2,2.703e-2,3.067e-2,3.476e-2,3.935e-2,4.449e-2, &
 5.026e-2,5.671e-2,6.393e-2,7.198e-2,8.097e-2,9.098e-2, &
 1.021e-1,1.145e-1,1.283e-1,1.436e-1,1.606e-1,1.794e-1, &
 2.002e-1,2.233e-1,2.488e-1,2.769e-1,3.079e-1,3.421e-1/ 
   
 data  estab(61:120) / &
 3.798e-1,4.213e-1,4.669e-1,5.170e-1,5.720e-1,6.323e-1, &
 6.985e-1,7.709e-1,8.502e-1,9.370e-1,   1.032,   1.135, &
 1.248,   1.371,   1.506,   1.652,   1.811,   1.984, &
 2.172,   2.376,   2.597,   2.889,   3.097,   3.522, &
 3.8619,  4.2148,  4.5451,  4.8981,  5.2753,   5.678, &
 6.1078,  6.5662,  7.0547,  7.5753,  8.1294,  8.7192, &
 9.3465,  10.013,  10.722,  11.474,  12.272,  13.119, &
 14.017,  14.969,  15.977,  17.044,  18.173,  19.367, &
 20.630,  21.964,  23.373,  24.861,  26.430,  28.086, &
 29.831,  31.671,  33.608,  35.649,  37.796,  40.055/
   
 data  estab(121:156) / &
 42.430,  44.927,  47.551,  50.307,  53.200,  56.236, &
 59.422,  62.762,  66.264,  69.934,  73.777,  77.803, &
 82.015,  86.423,  91.034,  95.855,  100.89,  106.16, &
 111.66,  117.40,  123.40,  129.65,  136.17,  142.98, &
 150.07,  157.46,  165.16,  173.18,  181.53,  190.22, &
 199.26,  208.67,  218.45,  228.61,  239.18,  250.16/
   
        
 tt=temp-183.15             ! 183.15 = 273.15 - 90
 if (tt.le.0.) then
   svp=estab(1)
 else
   ind=int(tt)+1
   ind=min(ind,155)
   t0=ind-1
   e0=estab(ind)
   e1=estab(ind+1)
   svp=e0+(tt-t0)*(e1-e0)
 endif
        
 return
 end function svp
        
 subroutine spline(xi,yi,xo,yo,as,ni,no,ii)
        
!     SPLINE, VERSION OF 17 JUL 81
        
 implicit none
 integer                      :: ni, no, ii
 real(kind=8)                 :: xi(ni)
 real(kind=8)                 :: yi(ni)
 real(kind=8)                 :: xo(no)
 real(kind=8)                 :: yo(no)
 real(kind=8)                 :: as(5,ni)
   
 integer                      :: nim1, i, j, k, l, m
 real(kind=8)                 :: xm, xn, xx
 real(kind=8)                 :: c(4)
   
 if(ii.eq.1) call cubist(ni,xi,yi,as)
 nim1=ni-1
 m=1
 do 150 j=1,no
   xx=xo(j)
   do 100 i=m,nim1
     l=i
     xm=xi(i)
     xn=xi(i+1)
     if(xx.eq.xm) go to 120
     if(xx.eq.xn) go to 110
     if(xx.gt.xm.and.xx.lt.xn) go to 130
 100 continue
 110 l=l+1
 120 yo(j)=yi(l)
     m=l
     go to 150
 130 do 140 k=1,4
 140 c(k)=as(k,l)
     yo(j)=c(1)+xx*(c(2)+xx*(c(3)+xx*c(4)))
     m=l
 150 continue
 return
 end
        
 subroutine cubist(n,x,y,as)
        
!     CUBIST, VERSION OF 17 JUL 81
!     CALLED BY 'SPLINE'
!     CUBIC SPLINE GENERATOR BY W.HIBBARD, MOD'D BY H.WOOLF.  SECOND DERIV.
!     NOT CONTINUOUS. THE DEGREES OF FREEDOM GAINED ARE USED IN AN
!     ATTEMPT TO AVOID  OSCILLATIONS.
!     FIT TO THE POINTS (X(I),Y(I)) I=1,...,N .
        
 implicit none
 integer                      :: n
 real(kind=8)                 :: x(n),y(n),as(5,n)
        
 integer                      :: m,i
 real(kind=8)                 :: t, w, z, s, u, v
 real(kind=8)                 :: zs, zq, ws, wq
 real(kind=8)                 :: aa, ba, ca, da
   
 m=n-1
 do 150 i=1,m
   if(i .eq. 1) go to 110
   t=(y(i+1)-y(i-1))/(x(i+1)-x(i-1))
   go to 120
 110 w=(y(2)+y(3))/2.0
   z=(x(2)+x(3))/2.0
   t=(w-y(1))/(z-x(1))
   t=2.0*(y(2)-y(1))/(x(2)-x(1))-t
 120 if(i .eq. m) go to 130
   s=(y(i+2)-y(i))/(x(i+2)-x(i))
   go to 140
 130 w=(y(n-1)+y(n-2))/2.0
   z=(x(n-1)+x(n-2))/2.0
   s=(y(n)-w)/(x(n)-z)
   s=2.0*(y(n)-y(n-1))/(x(n)-x(n-1))-s
  140 u=y(i+1)
   v=y(i)
   w=(x(i+1)+x(i))/2.0
   z=(x(i+1)-x(i))/2.0
   zs=z*z
   zq=z*zs
   ws=w*w
   wq=w*ws
   aa=.5*(u+v)-.25*z*(s-t)
   ba=.75*(u-v)/z-.25*(s+t)
   ca=.25*(s-t)/z
   da=.25*(s+t)/zs-.25*(u-v)/zq
   as(1,i)=aa-ba*w+ca*ws-da*wq
   as(2,i)=ba-2.0*ca*w+3.0*da*ws
   as(3,i)=ca-3.0*da*w
   as(4,i)=da
 150 as(5,i)=0.
 return
 end
