!==========================================================================
elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih)
!==========================================================================
!
!  Calculates the ratio of SA to CT changes when ice melts into seawater.
!  It is assumed that a small mass of ice melts into an infinite mass of
!  seawater.  Because of the infinite mass of seawater, the ice will always
!  melt.
!
!  The output, melting_seaice_SA_CT_ratio, is dSA/dCT rather than dCT/dSA.
!  This is done so that when SA = 0, the output, dSA/dCT is zero whereas
!  dCT/dSA would be infinite.
!
!  SA   =  Absolute Salinity of seawater                           [ g/kg ]
!  CT   =  Conservative Temperature of seawater (ITS-90)          [ deg C ]
!  p    =  sea pressure at which the melting occurs                [ dbar ]
!         ( i.e. absolute pressure - 10.1325d0 dbar )
!  t_Ih =  the in-situ temperature of the ice (ITS-90)            [ deg C ]
!
!  melting_ice_SA_CT_ratio = the ratio of SA to CT changes when ice melts
!                            into a large mass of seawater
!                                                          [ g kg^-1 K^-1 ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_enthalpy
use gsw_mod_toolbox, only : gsw_t_freezing_poly, gsw_enthalpy_ice
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p, t_ih

real (r8) :: gsw_melting_ice_sa_ct_ratio_poly

real (r8) :: ctf, h, h_ih, tf, h_hat_sa, h_hat_ct

real (r8), parameter :: saturation_fraction = 0.0_r8

character (*), parameter :: func_name = "gsw_melting_ice_sa_ct_ratio_poly"

ctf = gsw_ct_freezing_poly(sa,p,saturation_fraction)
if (ct .lt. ctf) then
    ! the seawater ct input is below the freezing temperature
    gsw_melting_ice_sa_ct_ratio_poly = gsw_error_code(1,func_name)
    return
end if

tf = gsw_t_freezing_poly(0.0_r8,p,saturation_fraction)
if (t_ih .gt. tf) then
    ! t_ih exceeds the freezing temperature at sa = 0
    gsw_melting_ice_sa_ct_ratio_poly = gsw_error_code(2,func_name)
    return
end if

h = gsw_enthalpy(sa,ct,p)
h_ih = gsw_enthalpy_ice(t_ih,p)
call gsw_enthalpy_first_derivatives(sa,ct,p,h_hat_sa,h_hat_ct)
	! Note that h_hat_CT is equal to cp0*(273.15 + t)/(273.15 + pt0)

gsw_melting_ice_sa_ct_ratio_poly = sa*h_hat_ct/(h - h_ih - sa*h_hat_sa)

return
end function

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


      subroutine QUADINTERP(
     &           phi
     &           ,iphilo0,iphilo1
     &           ,iphihi0,iphihi1
     &           ,nphicomp
     &           ,phistar
     &           ,iphistarlo0,iphistarlo1
     &           ,iphistarhi0,iphistarhi1
     &           ,nphistarcomp
     &           ,iboxlo0,iboxlo1
     &           ,iboxhi0,iboxhi1
     &           ,ihilo
     &           ,h
     &           ,idir
     &           ,scomp
     &           ,ecomp
     &           ,nref
     &           )
      implicit none
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nphicomp
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           0:nphicomp-1)
      integer nphistarcomp
      integer iphistarlo0,iphistarlo1
      integer iphistarhi0,iphistarhi1
      REAL*8 phistar(
     &           iphistarlo0:iphistarhi0,
     &           iphistarlo1:iphistarhi1,
     &           0:nphistarcomp-1)
      integer iboxlo0,iboxlo1
      integer iboxhi0,iboxhi1
      integer ihilo
      REAL*8 h
      integer idir
      integer scomp
      integer ecomp
      integer nref
      integer i0,i1
      integer ii0,ii1
      integer n
      REAL*8 x, pa, pb, ps, a, b, frac, denom, xsquared
      REAL*8  mult, invh
      frac = (2.0d0)/(h*h)
      denom =  nref*nref + 4*nref + 3
      mult = frac/denom
      invh = (1.0d0) / h
      x = (2.0d0) * h
      xsquared = (4.0d0) * h*h
      ii0= ihilo*CHF_ID(0, idir)
      ii1= ihilo*CHF_ID(1, idir)
      do n=scomp,ecomp
      do i1 = iboxlo1,iboxhi1
      do i0 = iboxlo0,iboxhi0
            pa = phi(i0 -2*ii0,i1 -2*ii1,n)
            pb = phi(i0 -ii0,i1 -ii1,n)
            ps = phistar(i0 +ii0,i1 +ii1,n)
            a  = mult*((2.0d0)*ps + (nref+1)*pa - (nref+3)*pb)
            b  = (pb-pa)*invh - a*h
            phi(i0,i1,n) = xsquared*a + b*x + pa
      enddo
      enddo
      enddo
      return
      end
      subroutine PHISTAR(
     &           fPhiStar
     &           ,ifPhiStarlo0,ifPhiStarlo1
     &           ,ifPhiStarhi0,ifPhiStarhi1
     &           ,nfPhiStarcomp
     &           ,iregionlo0,iregionlo1
     &           ,iregionhi0,iregionhi1
     &           ,phic
     &           ,iphiclo0,iphiclo1
     &           ,iphichi0,iphichi1
     &           ,nphiccomp
     &           ,coarslope
     &           ,icoarslopelo0,icoarslopelo1
     &           ,icoarslopehi0,icoarslopehi1
     &           ,ncoarslopecomp
     &           ,coarcurva
     &           ,icoarcurvalo0,icoarcurvalo1
     &           ,icoarcurvahi0,icoarcurvahi1
     &           ,ncoarcurvacomp
     &           ,coarmixed
     &           ,icoarmixedlo0,icoarmixedlo1
     &           ,icoarmixedhi0,icoarmixedhi1
     &           ,ncoarmixedcomp
     &           ,dxf
     &           ,ivar
     &           ,dir
     &           ,sign
     &           ,nRef
     &           )
      implicit none
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nfPhiStarcomp
      integer ifPhiStarlo0,ifPhiStarlo1
      integer ifPhiStarhi0,ifPhiStarhi1
      REAL*8 fPhiStar(
     &           ifPhiStarlo0:ifPhiStarhi0,
     &           ifPhiStarlo1:ifPhiStarhi1,
     &           0:nfPhiStarcomp-1)
      integer iregionlo0,iregionlo1
      integer iregionhi0,iregionhi1
      integer nphiccomp
      integer iphiclo0,iphiclo1
      integer iphichi0,iphichi1
      REAL*8 phic(
     &           iphiclo0:iphichi0,
     &           iphiclo1:iphichi1,
     &           0:nphiccomp-1)
      integer ncoarslopecomp
      integer icoarslopelo0,icoarslopelo1
      integer icoarslopehi0,icoarslopehi1
      REAL*8 coarslope(
     &           icoarslopelo0:icoarslopehi0,
     &           icoarslopelo1:icoarslopehi1,
     &           0:ncoarslopecomp-1)
      integer ncoarcurvacomp
      integer icoarcurvalo0,icoarcurvalo1
      integer icoarcurvahi0,icoarcurvahi1
      REAL*8 coarcurva(
     &           icoarcurvalo0:icoarcurvahi0,
     &           icoarcurvalo1:icoarcurvahi1,
     &           0:ncoarcurvacomp-1)
      integer ncoarmixedcomp
      integer icoarmixedlo0,icoarmixedlo1
      integer icoarmixedhi0,icoarmixedhi1
      REAL*8 coarmixed(
     &           icoarmixedlo0:icoarmixedhi0,
     &           icoarmixedlo1:icoarmixedhi1,
     &           0:ncoarmixedcomp-1)
      REAL*8 dxf
      integer ivar
      integer dir
      integer sign
      integer nRef
      REAL*8 xf1, xc1, xf2, xc2, x1, x2, dxc
      REAL*8 aa, update1, update2, update3
      integer i0,i1
      integer ii0,ii1
      integer ir0,ir1
      integer ic(0:2 -1)
      integer ivf(0:2 -1)
      integer YOU(1:2, 0:2), you1, you2
      data YOU / 1, 2, 0, 2, 0, 1 /
      dxc = nRef * dxf
      you1 = YOU(1,dir)
      you2 = YOU(2,dir)
      ii0= sign*CHF_ID(0, dir)
      ii1= sign*CHF_ID(1, dir)
      do ir1 = iregionlo1,iregionhi1
      do ir0 = iregionlo0,iregionhi0
         ic(0)=ir0/nRef
         ic(1)=ir1/nRef
         ivf(0)=ir0
         ivf(1)=ir1
         i0=ir0+ii0
         i1=ir1+ii1
         xf1 = (ivf(you1)+(0.500d0))*dxf
         xc1 = (  ic(you1)+(0.500d0))*dxc
         xf2 = (ivf(you2)+(0.500d0))*dxf
         xc2 = (  ic(you2)+(0.500d0))*dxc
         x1 = xf1-xc1
         x2 = xf2-xc2
         aa= phic(ic(0),ic(1),ivar)
         update1=x1*coarslope(ic(0),ic(1),you1) +
     &        (0.500d0)*x1*x1*coarcurva(ic(0),ic(1),you1)
         update2=x2*coarslope(ic(0),ic(1),you2) +
     &        (0.500d0)*x2*x2*coarcurva(ic(0),ic(1),you2)
         update3=x1*x2*coarmixed(ic(0),ic(1),0)
         fPhiStar(i0,i1,ivar) = aa+update1+update2+update3
      enddo
      enddo
      return
      end


      subroutine sd_hydsed_init

      use input_file_module
      use sd_channel_module
      use channel_velocity_module
      use maximum_data_module
      use hydrograph_module

      implicit none

      real :: kh
      integer :: idb                  !             |
      integer :: i                    !none         |counter
      real :: aa                      !none         |area/area=1 (used to calculate velocity with
                                      !             |Manning"s equation)
      real :: a                       !m^2          |cross-sectional area of channel
      real :: b                       !m            |bottom width of channel
      real :: d                       !m            |depth of flow
      real :: p                       !m            |wetting perimeter
      real :: chside                  !none         |change in horizontal distance per unit
                                      !             |change in vertical distance on channel side
                                      !             |slopes; always set to 2 (slope=1/2)
      real :: fps                     !none         |change in horizontal distance per unit
                                      !             |change in vertical distance on floodplain side
                                      !             |slopes; always set to 4 (slope=1/4)
      integer :: max                  !             |
      real :: rh                      !m            |hydraulic radius
      real :: qman                    !m^3/s or m/s |flow rate or flow velocity
      real :: tt1                     !km s/m       |time coefficient for specified depth
      real :: tt2                     !km s/m       |time coefficient for bankfull depth
      real :: qq1                     !m^3/s        |flow rate for a specified depth

      do i = 1, sp_ob%chandeg
        icmd = sp_ob1%chandeg + i - 1
        idb = ob(icmd)%props

        sd_ch(i)%order = sd_chd(idb)%order
        sd_ch(i)%chw = sd_chd(idb)%chw
        sd_ch(i)%chd = sd_chd(idb)%chd
        sd_ch(i)%chs = sd_chd(idb)%chs
        sd_ch(i)%chl = sd_chd(idb)%chl
        sd_ch(i)%cherod = sd_chd(idb)%cherod
        sd_ch(i)%cov = sd_chd(idb)%cov
        sd_ch(i)%shear_bnk = sd_chd(idb)%shear_bnk
        sd_ch(i)%hc_len = sd_chd(idb)%hc_ini
        sd_ch(i)%hc_hgt = sd_chd(idb)%hc_hgt

        !! compute headcut parameters
        kh = sd_chd(idb)%hc_kh
        if (kh > 1.e-6) then
          sd_ch(i)%hc_co = .37 * (17.83 + 16.56 * kh - 15. * sd_chd(idb)%hc_cov)
          sd_ch(i)%hc_co = amax1 (0., sd_ch(i)%hc_co)
        else
          sd_ch(i)%hc_co = 0.
        end if

        !! compute travel time coefficients
        aa = 1.
        b = 0.
        d = 0.
        chside = sd_chd(idb)%chss
        fps = 4.
        b = sd_ch(i)%chw - 2. * sd_ch(i)%chd * chside

        !! check IF bottom width (b) is < 0
        if (b <= 0.) then
            b = .5 * sd_ch(i)%chw
            b = Max(0., b)
            chside = (sd_ch(i)%chw - b) / (2. * sd_ch(i)%chd)
        end if
        sd_ch_vel(i)%wid_btm = b
        sd_ch_vel(i)%dep_bf = sd_ch(i)%chd

        !! compute flow and travel time at bankfull depth
        p = b + 2. * sd_ch(i)%chd * Sqrt(chside * chside + 1.)
        a = b * sd_ch(i)%chd + chside * sd_ch(i)%chd * sd_ch(i)%chd
        rh = a / p
        sd_ch_vel(i)%area = a
        sd_ch_vel(i)%vel_bf = Qman(a, rh, sd_chd(idb)%chn, sd_ch(i)%chs)
        sd_ch_vel(i)%velav_bf = Qman(aa, rh, sd_chd(idb)%chn, sd_ch(i)%chs)
        sd_ch_vel(i)%celerity_bf = sd_ch_vel(i)%velav_bf * 5. / 3.
        sd_ch_vel(i)%st_dis = sd_ch(i)%chl / sd_ch_vel(i)%celerity_bf / 3.6
        tt2 = sd_ch(i)%chl * a / sd_ch_vel(i)%vel_bf

        !! compute flow and travel time at 1.2 bankfull depth
        d = 1.2 * sd_ch(i)%chd
        a = a + (sd_ch(i)%chw * sd_ch(i)%chd + fps * (sd_ch(i)%chd - sd_ch(i)%chd) ** 2)
        p = p + 4. * sd_ch(i)%chw + (0.4 * sd_ch(i)%chd * Sqrt(fps * fps + 1.))
        rh = a / p
        qq1 = Qman(a, rh, sd_chd(idb)%chn, sd_ch(i)%chs)
        tt1 = sd_ch(i)%chl * a / qq1

        !! compute flow and travel time at 0.1 bankfull depth
        d = 0.1 * sd_ch(i)%chd
        p = b + 2. * sd_ch(i)%chd * Sqrt(chside * chside + 1.)
        a = b * sd_ch(i)%chd + chside * sd_ch(i)%chd * sd_ch(i)%chd
        rh = a / p
        qq1 = Qman(a, rh, sd_chd(idb)%chn, sd_ch(i)%chs)
        tt1 = sd_ch(i)%chl * a / qq1
        sd_ch_vel(i)%vel_1bf = Qman(aa, rh, sd_chd(idb)%chn, sd_ch(i)%chs)
        sd_ch_vel(i)%celerity_1bf = sd_ch_vel(i)%vel_1bf * 5. / 3.
        sd_ch_vel(i)%stor_dis_1bf = sd_ch(i)%chl / sd_ch_vel(i)%celerity_1bf / 3.6
        end do

      return
      end subroutine sd_hydsed_init


!
!     ------------------------------------------------------------------
!       R M E T R
!     ------------------------------------------------------------------
!
! --- evaluates the angular part of the one-electron transition reduced
!     matrix element. See equations (4) and (5) of paper II.
!
      REAL(KIND(0.0D0)) FUNCTION RMETR (L1, L2)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE EMS_C
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:13:23  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE rme_I
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: L1
      INTEGER  :: L2
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: LL2, L3
      REAL(DOUBLE) :: W
!-----------------------------------------------
      IF (IFL == 1) THEN
!       electric multipole transitions
         RMETR = RME(L1,L2,LAM)
         IF (MOD(L2 - L1 + LAM,4) /= 0) RMETR = -RMETR
      ELSE
!       magnetic multipole transitions
         RMETR = RME(L1,L2,LAM - 1)
         IF (DABS(RMETR) > EPS) THEN
            IF (MOD(L2 - L1 + LAM - 1,4) /= 0) RMETR = -RMETR
            IF (IFL == 3) THEN
               LL2 = L2 + L2
               L3 = LAM + LAM
               CALL SIXJ (2, LL2, LL2, L1 + L1, L3, L3 - 2, 1, W)
               RMETR = -RMETR*W*SQRT(DBLE(L2*(L2 + 1)*(LL2 + 1)*(L3 + 1)))
            ELSE
               RMETR = RMETR*SQRT(HALF*THREE)
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END FUNCTION RMETR


      subroutine UxcCA2(rho1_tmp,rho2_tmp,vxc1,vxc2,uxc1,uxc2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DATA CEX/-1.969490099D0/
      DATA ONE/1.0D0/,HALF/0.5D0/,THALF/1.5D0/
      DATA ZERO/0.0D0/,THRD/0.333333333333333D0/
      DATA TFT/0.75D0/,TWO/2.0D0/
      DATA RC/0.02258D0/,EPS/1.0D-20/
C-----------------------------------------------------------------------

C.
C. KOHN-SHAM EXCHANGE
C. CEPERLEY-ALDER / RPA CORRELATION
C.
cccc The parameters are for the unit of Ryd.
cccc beta11=7/6*beta1, beta22=4/3*beta2
cccc B1=B-A/3, C1=2/3*C, D1=(2*D-C)/3

      DATA PI /3.141592654D0/
      DATA gamma_u,beta1_u,beta2_u /-0.2846d0, 1.0529d0, 0.3334d0/
      DATA gamma_p,beta1_p,beta2_p /-0.1686d0, 1.3981d0, 0.2611d0/
      DATA beta11_u,beta22_u /1.228383333D0,0.4445333333D0/
      DATA beta11_p,beta22_p /1.631116667D0,0.3481333333D0/

      DATA A_u,B_u,C_u,D_u /0.0622d0,-0.096d0,0.0040d0,-0.0232d0/
      DATA B1_u,C1_u,D1_u /-0.116733333d0,0.0026666667d0,-0.0168d0/

      DATA A_p,B_p,C_p,D_p /0.0311d0,-0.0538d0,0.0014d0,-0.0096d0/
      DATA B1_p,C1_p,D1_p /-0.064166667d0,0.00093333d0,
     &                                            -0.006866667d0/

************************************************
      rho1=max(rho1_tmp,1.d-16)
      rho2=max(rho2_tmp,1.d-16)

      rho=rho1+rho2

      RS=(PI*RHO/TFT)**(-THRD)
      IF(RS .GE. ONE) THEN

       ROOTRS=SQRT(RS)
       tmp=1.d0/(1.d0+beta1_u*ROOTRS+beta2_u*RS)
       Ec_u=gamma_u*tmp
       Vc_u=gamma_u*(1.d0+beta11_u*ROOTRS+beta22_u*RS)*tmp**2

       tmp=1.d0/(1.d0+beta1_p*ROOTRS+beta2_p*RS)
       Ec_p=gamma_p*tmp
       Vc_p=gamma_p*(1.d0+beta11_p*ROOTRS+beta22_p*RS)*tmp**2

      ELSE

       XLNRS=LOG(RS)
       Ec_u=A_u*XLNRS+B_u+C_u*RS*XLNRS+D_u*RS
       Vc_u=A_u*XLNRS+B1_u+C1_u*RS*XLNRS+D1_u*RS

       Ec_p=A_p*XLNRS+B_p+C_p*RS*XLNRS+D_p*RS
       Vc_p=A_p*XLNRS+B1_p+C1_p*RS*XLNRS+D1_p*RS

      END IF
*************************************
********* interpolation *************

        x=(rho1-rho2)/rho
        fx=((1.d0+x)**(4.d0/3)+(1.d0-x)**(4.d0/3)-2)/
     &     ((2.d0)**(4.d0/3)-2)
        dfx=((1.d0+x)**(1.d0/3)-(1.d0-x)**(1.d0/3))*
     &      4.d0/3/((2.d0)**(4.d0/3)-2)

        Ec=Ec_u+fx*(Ec_p-Ec_u)

        Vc1=Vc_u+fx*(Vc_p-Vc_u)+(Ec_p-Ec_u)*(1-x)*dfx
        Vc2=Vc_u+fx*(Vc_p-Vc_u)+(Ec_p-Ec_u)*(-1-x)*dfx

*************************************
****  Add the exchange part
***** 1/TWO: change ryd to Hartree

      Vxc1=(CEX*(2*rho1)**THRD+Vc1)/TWO
      Vxc2=(CEX*(2*rho2)**THRD+Vc2)/TWO

      Uxc1=(TFT*CEX*(2*rho1)**THRD+Ec)/TWO
      Uxc2=(TFT*CEX*(2*rho2)**THRD+Ec)/TWO

      RETURN
      END


      SUBROUTINE SLSQP (M,MEQ,LA,N,X,XL,XU,F,C,G,A,ACC,ITER,
     1     IPRINT,IOUT,IFILE,MODE,W,L_W,JW,L_JW,NFUNC,NGRAD,
     2     SLFUNC,SLGRAD)

C   SLSQP       S EQUENTIAL  L EAST  SQ UARES  P ROGRAMMING
C            TO SOLVE GENERAL NONLINEAR OPTIMIZATION PROBLEMS

C***********************************************************************
C*                                                                     *
C*                                                                     *
C*            A NONLINEAR PROGRAMMING METHOD WITH                      *
C*            QUADRATIC  PROGRAMMING  SUBPROBLEMS                      *
C*                                                                     *
C*                                                                     *
C*  THIS SUBROUTINE SOLVES THE GENERAL NONLINEAR PROGRAMMING PROBLEM   *
C*                                                                     *
C*            MINIMIZE    F(X)                                         *
C*                                                                     *
C*            SUBJECT TO  C (X) .EQ. 0  ,  J = 1,...,MEQ               *
C*                         J                                           *
C*                                                                     *
C*                        C (X) .GE. 0  ,  J = MEQ+1,...,M             *
C*                         J                                           *
C*                                                                     *
C*                        XL .LE. X .LE. XU , I = 1,...,N.             *
C*                          I      I       I                           *
C*                                                                     *
C*  THE ALGORITHM IMPLEMENTS THE METHOD OF HAN AND POWELL              *
C*  WITH BFGS-UPDATE OF THE B-MATRIX AND L1-TEST FUNCTION              *
C*  WITHIN THE STEPLENGTH ALGORITHM.                                   *
C*                                                                     *
C*    PARAMETER DESCRIPTION:                                           *
C*    ( * MEANS THIS PARAMETER WILL BE CHANGED DURING CALCULATION )    *
C*                                                                     *
C*    M              IS THE TOTAL NUMBER OF CONSTRAINTS, M .GE. 0      *
C*    MEQ            IS THE NUMBER OF EQUALITY CONSTRAINTS, MEQ .GE. 0 *
C*    LA             SEE A, LA .GE. MAX(M,1)                           *
C*    N              IS THE NUMBER OF VARIBLES, N .GE. 1               *
C*  * X()            X() STORES THE CURRENT ITERATE OF THE N VECTOR X  *
C*                   ON ENTRY X() MUST BE INITIALIZED. ON EXIT X()     *
C*                   STORES THE SOLUTION VECTOR X IF MODE = 0.         *
C*    XL()           XL() STORES AN N VECTOR OF LOWER BOUNDS XL TO X.  *
C*    XU()           XU() STORES AN N VECTOR OF UPPER BOUNDS XU TO X.  *
C*    F              IS THE VALUE OF THE OBJECTIVE FUNCTION.           *
C*    C()            C() STORES THE M VECTOR C OF CONSTRAINTS,         *
C*                   EQUALITY CONSTRAINTS (IF ANY) FIRST.              *
C*                   DIMENSION OF C MUST BE GREATER OR EQUAL LA,       *
C*                   which must be GREATER OR EQUAL MAX(1,M).          *
C*    G()            G() STORES THE N VECTOR G OF PARTIALS OF THE      *
C*                   OBJECTIVE FUNCTION; DIMENSION OF G MUST BE        *
C*                   GREATER OR EQUAL N+1.                             *
C*    A(),LA,M,N     THE LA BY N + 1 ARRAY A() STORES                  *
C*                   THE M BY N MATRIX A OF CONSTRAINT NORMALS.        *
C*                   A() HAS FIRST DIMENSIONING PARAMETER LA,          *
C*                   WHICH MUST BE GREATER OR EQUAL MAX(1,M).          *
C*    F,C,G,A        MUST ALL BE SET BY THE USER BEFORE EACH CALL.     *
C*  * ACC            ABS(ACC) CONTROLS THE FINAL ACCURACY.             *
C*                   IF ACC .LT. ZERO AN EXACT LINESEARCH IS PERFORMED,*
C*                   OTHERWISE AN ARMIJO-TYPE LINESEARCH IS USED.      *
C*  * ITER           PRESCRIBES THE MAXIMUM NUMBER OF ITERATIONS.      *
C*                   ON EXIT ITER INDICATES THE NUMBER OF ITERATIONS.  *
C*  * MODE           MODE CONTROLS CALCULATION:                        *
C*                   REVERSE COMMUNICATION IS USED IN THE SENSE THAT   *
C*                   THE PROGRAM IS INITIALIZED BY MODE = 0; THEN IT IS*
C*                   TO BE CALLED REPEATEDLY BY THE USER UNTIL A RETURN*
C*                   WITH MODE .NE. IABS(1) TAKES PLACE.               *
C*                   IF MODE = -1 GRADIENTS HAVE TO BE CALCULATED,     *
C*                   WHILE WITH MODE = 1 FUNCTIONS HAVE TO BE CALCULATED
C*                   MODE MUST NOT BE CHANGED BETWEEN SUBSEQUENT CALLS *
C*                   OF SQP.                                           *
C*                   EVALUATION MODES:                                 *
C*        MODE = -1: GRADIENT EVALUATION, (G&A)                        *
C*                0: ON ENTRY: INITIALIZATION, (F,G,C&A)               *
C*                   ON EXIT : REQUIRED ACCURACY FOR SOLUTION OBTAINED *
C*                1: FUNCTION EVALUATION, (F&C)                        *
C*                                                                     *
C*                   FAILURE MODES:                                    *
C*                2: NUMBER OF EQUALITY CONTRAINTS LARGER THAN N       *
C*                3: MORE THAN 3*N ITERATIONS IN LSQ SUBPROBLEM        *
C*                4: INEQUALITY CONSTRAINTS INCOMPATIBLE               *
C*                5: SINGULAR MATRIX E IN LSQ SUBPROBLEM               *
C*                6: SINGULAR MATRIX C IN LSQ SUBPROBLEM               *
C*                7: RANK-DEFICIENT EQUALITY CONSTRAINT SUBPROBLEM HFTI*
C*                8: POSITIVE DIRECTIONAL DERIVATIVE FOR LINESEARCH    *
C*                9: MORE THAN ITER ITERATIONS IN SQP                  *
C*             >=10: WORKING SPACE W OR JW TOO SMALL,                  *
C*                   W SHOULD BE ENLARGED TO L_W=MODE/1000             *
C*                   JW SHOULD BE ENLARGED TO L_JW=MODE-1000*L_W       *
C*  * W(), L_W       W() IS A ONE DIMENSIONAL WORKING SPACE,           *
C*                   THE LENGTH L_W OF WHICH SHOULD BE AT LEAST        *
C*                   (3*N1+M)*(N1+1)                        for LSQ    *
C*                  +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ         for LSI    *
C*                  +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1       for LSEI   *
C*                  + N1*N/2 + 2*M + 3*N + 3*N1 + 1         for SLSQPB *
C*                   with MINEQ = M - MEQ + 2*N1  &  N1 = N+1          *
C*        NOTICE:    FOR PROPER DIMENSIONING OF W IT IS RECOMMENDED TO *
C*                   COPY THE FOLLOWING STATEMENTS INTO THE HEAD OF    *
C*                   THE CALLING PROGRAM (AND REMOVE THE COMMENT C)    *
c#######################################################################
C     INTEGER LEN_W, LEN_JW, M, N, N1, MEQ, MINEQ
C     PARAMETER (M=... , MEQ=... , N=...  )
C     PARAMETER (N1= N+1, MINEQ= M-MEQ+N1+N1)
C     PARAMETER (LEN_W=
c    $           (3*N1+M)*(N1+1)
c    $          +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ
c    $          +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1
c    $          +(N+1)*N/2 + 2*M + 3*N + 3*N1 + 1,
c    $           LEN_JW=MINEQ)
C     DOUBLE PRECISION W(LEN_W)
C     INTEGER          JW(LEN_JW)
c#######################################################################
C*                   THE FIRST M+N+N*N1/2 ELEMENTS OF W MUST NOT BE    *
C*                   CHANGED BETWEEN SUBSEQUENT CALLS OF SLSQP.        *
C*                   ON RETURN W(1) ... W(M) CONTAIN THE MULTIPLIERS   *
C*                   ASSOCIATED WITH THE GENERAL CONSTRAINTS, WHILE    *
C*                   W(M+1) ... W(M+N(N+1)/2) STORE THE CHOLESKY FACTOR*
C*                   L*D*L(T) OF THE APPROXIMATE HESSIAN OF THE        *
C*                   LAGRANGIAN COLUMNWISE DENSE AS LOWER TRIANGULAR   *
C*                   UNIT MATRIX L WITH D IN ITS 'DIAGONAL' and        *
C*                   W(M+N(N+1)/2+N+2 ... W(M+N(N+1)/2+N+2+M+2N)       *
C*                   CONTAIN THE MULTIPLIERS ASSOCIATED WITH ALL       *
C*                   ALL CONSTRAINTS OF THE QUADRATIC PROGRAM FINDING  *
C*                   THE SEARCH DIRECTION TO THE SOLUTION X*           *
C*  * JW(), L_JW     JW() IS A ONE DIMENSIONAL INTEGER WORKING SPACE   *
C*                   THE LENGTH L_JW OF WHICH SHOULD BE AT LEAST       *
C*                   MINEQ                                             *
C*                   with MINEQ = M - MEQ + 2*N1  &  N1 = N+1          *
C*                                                                     *
C*  THE USER HAS TO PROVIDE THE FOLLOWING SUBROUTINES:                 *
C*     LDL(N,A,Z,SIG,W) :   UPDATE OF THE LDL'-FACTORIZATION.          *
C*     LINMIN(A,B,F,TOL) :  LINESEARCH ALGORITHM IF EXACT = 1          *
C*     LSQ(M,MEQ,LA,N,NC,C,D,A,B,XL,XU,X,LAMBDA,W,....) :              *
C*                                                                     *
C*        SOLUTION OF THE QUADRATIC PROGRAM                            *
C*                QPSOL IS RECOMMENDED:                                *
C*     PE GILL, W MURRAY, MA SAUNDERS, MH WRIGHT:                      *
C*     USER'S GUIDE FOR SOL/QPSOL:                                     *
C*     A FORTRAN PACKAGE FOR QUADRATIC PROGRAMMING,                    *
C*     TECHNICAL REPORT SOL 83-7, JULY 1983                            *
C*     DEPARTMENT OF OPERATIONS RESEARCH, STANFORD UNIVERSITY          *
C*     STANFORD, CA 94305                                              *
C*     QPSOL IS THE MOST ROBUST AND EFFICIENT QP-SOLVER                *
C*     AS IT ALLOWS WARM STARTS WITH PROPER WORKING SETS               *
C*                                                                     *
C*     IF IT IS NOT AVAILABLE USE LSEI, A CONSTRAINT LINEAR LEAST      *
C*     SQUARES SOLVER IMPLEMENTED USING THE SOFTWARE HFTI, LDP, NNLS   *
C*     FROM C.L. LAWSON, R.J.HANSON: SOLVING LEAST SQUARES PROBLEMS,   *
C*     PRENTICE HALL, ENGLEWOOD CLIFFS, 1974.                          *
C*     LSEI COMES WITH THIS PACKAGE, together with all necessary SR's. *
C*                                                                     *
C*     TOGETHER WITH A COUPLE OF SUBROUTINES FROM BLAS LEVEL 1         *
C*                                                                     *
C*     SQP IS HEAD SUBROUTINE FOR BODY SUBROUTINE SQPBDY               *
C*     IN WHICH THE ALGORITHM HAS BEEN IMPLEMENTED.                    *
C*                                                                     *
C*  IMPLEMENTED BY: DIETER KRAFT, DFVLR OBERPFAFFENHOFEN               *
C*  as described in Dieter Kraft: A Software Package for               *
C*                                Sequential Quadratic Programming     *
C*                                DFVLR-FB 88-28, 1988                 *
C*  which should be referenced if the user publishes results of SLSQP  *
C*                                                                     *
C*  DATE:           APRIL - OCTOBER, 1981.                             *
C*  STATUS:         DECEMBER, 31-ST, 1984.                             *
C*  STATUS:         MARCH   , 21-ST, 1987, REVISED TO FORTAN 77        *
C*  STATUS:         MARCH   , 20-th, 1989, REVISED TO MS-FORTRAN       *
C*  STATUS:         APRIL   , 14-th, 1989, HESSE   in-line coded       *
C*  STATUS:         FEBRUARY, 28-th, 1991, FORTRAN/2 Version 1.04      *
C*                                         accepts Statement Functions *
C*  STATUS:         MARCH   ,  1-st, 1991, tested with SALFORD         *
C*                                         FTN77/386 COMPILER VERS 2.40*
C*                                         in protected mode           *
C*                                                                     *
C***********************************************************************
C*                                                                     *
C*  Copyright 1991: Dieter Kraft, FHM                                  *
C*                                                                     *
C***********************************************************************

      INTEGER IL, IM, IR, IS, ITER, IU, IV, IW, IX, L_W, L_JW,
     1        JW(L_JW), LA, M, MEQ, MINEQ, MODE, N, N1, IPRINT, IOUT,
     2        NFUNC, NGRAD,
     3        IEXACT, INCONS, IRESET, ITERMX, LINE, N2, N3

      DOUBLE PRECISION ACC, A(LA,N+1), C(LA), F, G(N+1),
     *     X(N), XL(N), XU(N), W(L_W),
     *     ALPHA, F0, GS, H1, H2, H3, H4, T, T0, TOL

      EXTERNAL SLFUNC,SLGRAD

      CHARACTER*(*) IFILE

c     dim(W) =         N1*(N1+1) + MEQ*(N1+1) + MINEQ*(N1+1)  for LSQ
c                    +(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ          for LSI
c                    +(N1+MINEQ)*(N1-MEQ) + 2*MEQ + N1        for LSEI
c                    + N1*N/2 + 2*M + 3*N +3*N1 + 1           for SLSQPB
c                      with MINEQ = M - MEQ + 2*N1  &  N1 = N+1

C
C   CHECK LENGTH OF WORKING ARRAYS
C
      N1 = N+1
      MINEQ = M-MEQ+N1+N1
      IL = (3*N1+M)*(N1+1) +
     .(N1-MEQ+1)*(MINEQ+2) + 2*MINEQ +
     .(N1+MINEQ)*(N1-MEQ)  + 2*MEQ +
     .N1*N/2 + 2*M + 3*N + 4*N1 + 1
      IM = MAX(MINEQ, N1-MEQ)
      IF (L_W .LT. IL .OR. L_JW .LT. IM) THEN
          MODE = 1000*MAX(10,IL)
          MODE = MODE+MAX(10,IM)
          RETURN
      ENDIF
C
C   PRINT PARAMETERS
C
      IF(IPRINT.LT.0) GOTO 50
      IF(IPRINT.EQ.0) THEN
		  WRITE(*,1000)
          WRITE(*,1100) ACC,ITER,IPRINT,IOUT
      ENDIF
      IF(IPRINT.GT.0) THEN
		  OPEN(UNIT=IOUT,FILE=IFILE(1:LEN_TRIM(IFILE)),
     *      STATUS='UNKNOWN')
		  WRITE(IOUT,1000)
		  WRITE(IOUT,1100) ACC,ITER,IPRINT,IOUT
	  ENDIF
   50 CONTINUE
C
C   INITIAL COUNTERS
C
      NFUNC=0
      NGRAD=0
C
C   CALL OF SQPBDY
C
    4 CONTINUE
C
C   EVALUATE AND PRINT
C
      IF (MODE.EQ.0.OR.MODE.EQ. 1) THEN
          CALL SLFUNC(M, MEQ, LA, N, F, C, X)
          NFUNC=NFUNC+1
      ENDIF
      IF (IPRINT.LT.0) GOTO 60
      IF (MODE.EQ.0.OR.MODE.EQ. 1) GOTO 55
      IF(IPRINT.EQ.0) THEN
		  WRITE(*,1200) ITER,F
	      DO 10 I=1,N
   10 WRITE (*,1400) X(I)
      ENDIF
      IF(IPRINT.GT.0) THEN
		  WRITE(IOUT,1200) ITER,F
c$$$	      DO 12 I=1,N
c$$$   12 WRITE (IOUT,1400) X(I)
      ENDIF
   55 CONTINUE
   60 CONTINUE
      IF (MODE.EQ.0.OR.MODE.EQ.-1) THEN
         CALL SLGRAD(M, MEQ, LA, N, F, C, G, A, X)
         NGRAD=NGRAD+1
      ENDIF
C
C   PREPARE DATA FOR CALLING SQPBDY  -  INITIAL ADDRESSES IN W
C
      IM = 1
      IL = IM + MAX(1,M)
      IL = IM + LA
      IX = IL + N1*N/2 + 1
      IR = IX + N
      IS = IR + N + N + MAX(1,M)
      IS = IR + N + N + LA
      IU = IS + N1
      IV = IU + N1
      IW = IV + N1
C
      CALL SLSQPB (M,MEQ,LA,N,X,XL,XU,F,C,G,A,ACC,ITER,MODE,
     * W(IR),W(IL),W(IX),W(IM),W(IS),W(IU),W(IV),W(IW),JW,
     * ALPHA,F0,GS,H1,H2,H3,H4,T,T0,TOL,IEXACT,INCONS,IRESET,
     * ITERMX,LINE,N1,N2,N3)
C
      IF (ABS(MODE).EQ.1) GOTO 4
C
    3 CONTINUE

C
C   PRINT FINAL
C
      IF(IPRINT.GT.0) THEN
		  WRITE(IOUT,1450) NFUNC
		  WRITE(IOUT,1460) NGRAD
      ENDIF
C
C   END OF SLSQP
C
      RETURN
C
C     ------------------------------------------------------------------
C                                FORMATS
C     ------------------------------------------------------------------
C
 1000 FORMAT(////,3X,
     1 60H------------------------------------------------------------,
     2 15H---------------,
     3 /,5X,59HSTART OF THE SEQUENTIAL LEAST SQUARES PROGRAMMING ALGORITHM,
     4     /,3X,
     5 60H------------------------------------------------------------,
     6 15H---------------)
 1100 FORMAT(/,5X,11HPARAMETERS:,/,8X,5HACC =,D13.4,/,8X,9HMAXITER =,
     1     I3,/,8X,8HIPRINT =,I4,/,6HIOUT =,I4//)
 1200 FORMAT(5X,6HITER =,I5,5X,5HOBJ =,7E16.8,5X,10HX-VECTOR =)
 1400 FORMAT (3X,7E13.4)
 1450 FORMAT(8X,30HNUMBER OF FUNC-CALLS:  NFUNC =,I4)
 1460 FORMAT(8X,30HNUMBER OF GRAD-CALLS:  NGRAD =,I4)
C
      END


      PROGRAM caltra

C     ********************************************************************
C     *                                                                  *
C     * Calculates trajectories                                          *
C     *                                                                  *
C     *	Heini Wernli	   first version:       April 1993               *
C     * Michael Sprenger   major upgrade:       2008-2009                *
C     *                                                                  *
C     ********************************************************************

      implicit none

c     --------------------------------------------------------------------
c     Declaration of parameters
c     --------------------------------------------------------------------

c     Maximum number of levels for input files
      integer   nlevmax
      parameter	(nlevmax=100)

c     Maximum number of input files (dates, length of trajectories)
      integer   ndatmax
      parameter	(ndatmax=500)

c     Numerical epsilon (for float comparison)
      real      eps
      parameter (eps=0.001)

c     Distance in m between 2 lat circles
      real	deltay
      parameter	(deltay=1.112E5)

c     Numerical method for the integration (0=iterative Euler, 1=Runge-Kutta)
      integer   imethod
      parameter (imethod=1)

c     Number of iterations for iterative Euler scheme
      integer   numit
      parameter (numit=3)

c     Input and output format for trajectories (see iotra.f)
      integer   inpmode
      integer   outmode

c     Filename prefix (typically 'P')
      character*1  prefix
      parameter   (prefix='P')

c     --------------------------------------------------------------------
c     Declaration of variables
c     --------------------------------------------------------------------

c     Input parameters
      integer                                fbflag
      ! Flag for forward/backward mode
      integer                                numdat
      ! Number of input files
      character*11                           dat(ndatmax)
      ! Dates of input files
      real                                   timeinc
      ! Time increment between input files
      real                                   per
      ! Periodicity (=0 if none)
      integer                                ntra
      ! Number of trajectories
      character*80                           cdfname
      ! Name of output files
      real                                   ts
      ! Time step
      real                                   tst,ten
      ! Shift of start and end time relative to first data file
      integer                                deltout
      ! Output time interval (in minutes)
      integer                                jflag
      ! Jump flag (if =1 ground-touching trajectories reenter atmosphere)
      real                                   wfactor
      ! Factor for vertical velocity field
      character*80                           strname
      ! File with start positions
      character*80                           timecheck
      ! Either 'yes' or 'no'

c     Trajectories
      integer                                ncol
      ! Number of columns for insput trajectories
      real,allocatable, dimension (:,:,:) :: trainp
      ! Input start coordinates (ntra,1,ncol)
      real,allocatable, dimension (:,:,:) :: traout
      ! Output trajectories (ntra,ntim,4)
      integer                                reftime(6)      ! Reference date
      character*80                           vars(200)       ! Field names
      real,allocatable, dimension (:)     :: xx0,yy0,pp0
      ! Position of air parcels
      integer,allocatable, dimension (:)  :: leftflag
      ! Flag for domain-leaving
      real                                   xx1,yy1,pp1
      ! Updated position of air parcel
      integer                                leftcount
      ! Number of domain leaving trajectories
      integer                                ntim
      ! Number of output time steps

c     Meteorological fields
      real,allocatable, dimension (:)     :: spt0,spt1       ! Surface pressure
      real,allocatable, dimension (:)     :: uut0,uut1       ! Zonal wind
      real,allocatable, dimension (:)     :: vvt0,vvt1       ! Meridional wind
      real,allocatable, dimension (:)     :: wwt0,wwt1       ! Vertical wind
      real,allocatable, dimension (:)     :: p3t0,p3t1       ! 3d-pressure

c     Grid description
      real                                   pollon,pollat
      ! Longitude/latitude of pole
      real                                   ak(nlevmax)
      ! Vertical layers and levels
      real                                   bk(nlevmax)
      real                                   xmin,xmax
      ! Zonal grid extension
      real                                   ymin,ymax
      ! Meridional grid extension
      integer                                nx,ny,nz        ! Grid dimensions
      real                                   dx,dy
      ! Horizontal grid resolution
      integer                                hem
      ! Flag for hemispheric domain
      real                                   mdv
      ! Missing data value

c     Auxiliary variables
      real                                   delta,rd
      integer	                             itm,iloop,i,j,k,filo,lalo
      integer                                ierr,stat
      integer                                cdfid,fid
      real	                             tstart,time0,time1,time
      real                                   reltpos0,reltpos1
      real                                   xind,yind,pind,pp,sp,stagz
      character*80                           filename,varname
      integer                                reftmp(6)
      character                              ch
      real                                   frac,tload
      integer                                itim
      real                                   lon,lat,rlon,rlat

c     Externals
      real                                   lmtolms        ! Grid rotation
      real                                   phtophs
      real                                   lmstolm
      real                                   phstoph
      external                               lmtolms,phtophs
      external                               lmstolm,phstoph

c     --------------------------------------------------------------------
c     Start of program, Read parameters
c     --------------------------------------------------------------------

c     ---- INPUT PARAMETERS -----------------------------------
c     fbflag = 1 or -1
c     numdat = number of input files
c     timeinc = 1.
c     ts = timestep in seconds
c     jflag = 0 or 1
c     wfactor = 1

c     Write some status information
c     ---- CONSTANT GRID PARAMETERS ---------------------------
c     xmin,xmax,ymin,ymax = grid corners in rotated coordinates
c     dx,dy = 0.11

c     --------------------------------------------------------------------
c     Initialize the trajectory calculation
c     --------------------------------------------------------------------

c     Read start coordinates
c     Rotate coordinates
      do i=1,ntra

         lon = xx0(i)
         lat = yy0(i)

         if ( abs(pollat-90.).gt.eps) then
            rlon = lmtolms(lat,lon,pollat,pollon)
            rlat = phtophs(lat,lon,pollat,pollon)
         else
            rlon = lon
            rlat = lat
         endif

         xx0(i) = rlon
         yy0(i) = rlat

      enddo

c     Set sign of time range
      reftime(6) = fbflag * reftime(6)

C     Save starting positions
      itim = 1
      do i=1,ntra
         traout(i,itim,1) = 0.
         traout(i,itim,2) = xx0(i)
         traout(i,itim,3) = yy0(i)
         traout(i,itim,4) = pp0(i)
      enddo

c     Init the flag and the counter for trajectories leaving the domain
      leftcount=0
      do i=1,ntra
         leftflag(i)=0
      enddo

C     Convert time shifts <tst,ten> from <hh.mm> into fractional time
      call hhmm2frac(tst,frac)
      tst = frac
      call hhmm2frac(ten,frac)
      ten = frac

c     -----------------------------------------------------------------------
c     Loop to calculate trajectories
c     -----------------------------------------------------------------------

c     Read wind fields and vertical grid from first file
      call frac2hhmm(tstart,tload)

c     Loop over all input files (time step is <timeinc>)
      do itm=1,numdat-1

c       Calculate actual and next time
        time0 = tstart+real(itm-1)*timeinc*fbflag
        time1 = time0+timeinc*fbflag

c       Copy old velocities and pressure fields to new ones
        do i=1,nx*ny*nz
           uut0(i)=uut1(i)
           vvt0(i)=vvt1(i)
           wwt0(i)=wwt1(i)
           p3t0(i)=p3t1(i)
        enddo
        do i=1,nx*ny
           spt0(i)=spt1(i)
        enddo

c       Read wind fields and surface pressure at next time
        call frac2hhmm(time1,tload)

C       Determine the first and last loop indices
        if (numdat.eq.2) then
          filo = nint(tst/ts)+1
          lalo = nint((timeinc-ten)/ts)
        elseif ( itm.eq.1 ) then
          filo = nint(tst/ts)+1
          lalo = nint(timeinc/ts)
        else if (itm.eq.numdat-1) then
          filo = 1
          lalo = nint((timeinc-ten)/ts)
        else
          filo = 1
          lalo = nint(timeinc/ts)
        endif

c       Split the interval <timeinc> into computational time steps <ts>
        do iloop=filo,lalo

C      Calculate relative time position in the interval timeinc
c      (0=beginning, 1=end)
          reltpos0 = ((real(iloop)-1.)*ts)/timeinc
          reltpos1 = real(iloop)*ts/timeinc

C         Initialize counter for domain leaving trajectories
          leftcount=0

c         Timestep for all trajectories
          do i=1,ntra

C           Check if trajectory has already left the data domain
            if (leftflag(i).ne.1) then

c             Iterative Euler timestep (x0,y0,p0 -> x1,y1,p1)
              if (imethod.eq.1) then
                 call euler(
     >               xx1,yy1,pp1,leftflag(i),
     >               xx0(i),yy0(i),pp0(i),reltpos0,reltpos1,
     >               ts*3600,numit,jflag,mdv,wfactor,fbflag,
     >               spt0,spt1,p3t0,p3t1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
     >               xmin,ymin,dx,dy,per,hem,nx,ny,nz)

c             Runge-Kutta timestep (x0,y0,p0 -> x1,y1,p1)
              else if (imethod.eq.2) then
                 call runge(
     >               xx1,yy1,pp1,leftflag(i),
     >               xx0(i),yy0(i),pp0(i),reltpos0,reltpos1,
     >               ts*3600,numit,jflag,mdv,wfactor,fbflag,
     >               spt0,spt1,p3t0,p3t1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
     >               xmin,ymin,dx,dy,per,hem,nx,ny,nz)

              endif

c             Update trajectory position, or increase number
c             of trajectories leaving domain
              if (leftflag(i).eq.1) then
                leftcount=leftcount+1
              else
                xx0(i)=xx1
                yy0(i)=yy1
                pp0(i)=pp1
              endif

c          Trajectory has already left data domain (mark as <mdv>)
           else
              xx0(i)=mdv
              yy0(i)=mdv
              pp0(i)=mdv

           endif

          enddo

C         Save positions only every deltout minutes
          delta = aint(iloop*60*ts/deltout)-iloop*60*ts/deltout
          if (abs(delta).lt.eps) then
            time = time0+reltpos1*timeinc*fbflag
            itim = itim + 1
            do i=1,ntra
               call frac2hhmm(time,tload)
               traout(i,itim,1) = tload
               traout(i,itim,2) = xx0(i)
               traout(i,itim,3) = yy0(i)
               traout(i,itim,4) = pp0(i)
            enddo
          endif

        enddo

      enddo

c     *******************************************************************
c     * Time step : either Euler or Runge-Kutta                         *
c     *******************************************************************

C     Time-step from (x0,y0,p0) to (x1,y1,p1)
C
C     (x0,y0,p0) input	coordinates (long,lat,p) for starting point
C     (x1,y1,p1) output	coordinates (long,lat,p) for end point
C     deltat	 input	timestep in seconds
C     numit	 input	number of iterations
C     jump	 input  flag (=1 trajectories don't enter the ground)
C     left	 output	flag (=1 if trajectory leaves data domain)

c     -------------------------------------------------------------------
c     Iterative Euler time step
c     -------------------------------------------------------------------

      subroutine euler(x1,y1,p1,left,x0,y0,p0,reltpos0,reltpos1,
     >                 deltat,numit,jump,mdv,wfactor,fbflag,
     >		       spt0,spt1,p3d0,p3d1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
     >                 xmin,ymin,dx,dy,per,hem,nx,ny,nz)

      implicit none

c     Declaration of subroutine parameters
      integer      nx,ny,nz
      real         x1,y1,p1
      integer      left
      real	   x0,y0,p0
      real         reltpos0,reltpos1
      real   	   deltat
      integer      numit
      integer      jump
      real         wfactor
      integer      fbflag
      real     	   spt0(nx*ny)   ,spt1(nx*ny)
      real         uut0(nx*ny*nz),uut1(nx*ny*nz)
      real 	   vvt0(nx*ny*nz),vvt1(nx*ny*nz)
      real         wwt0(nx*ny*nz),wwt1(nx*ny*nz)
      real         p3d0(nx*ny*nz),p3d1(nx*ny*nz)
      real         xmin,ymin,dx,dy
      real         per
      integer      hem
      real         mdv

c     Numerical and physical constants
      real         deltay
      parameter    (deltay=1.112E5)  ! Distance in m between 2 lat circles
      real         pi
      parameter    (pi=3.1415927)    ! Pi

c     Auxiliary variables
      real         xmax,ymax
      real	   xind,yind,pind
      real	   u0,v0,w0,u1,v1,w1,u,v,w,sp
      integer	   icount
      character    ch

c     Externals
      real         int_index4
      external     int_index4

c     Reset the flag for domain-leaving
      left=0

c     Set the east-north boundary of the domain
      xmax = xmin+real(nx-1)*dx
      ymax = ymin+real(ny-1)*dy

C     Interpolate wind fields to starting position (x0,y0,p0)
      call get_index4 (xind,yind,pind,x0,y0,p0,reltpos0,
     >                 p3d0,p3d1,spt0,spt1,3,
     >                 nx,ny,nz,xmin,ymin,dx,dy,mdv)
      u0 = int_index4(uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
      v0 = int_index4(vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)
      w0 = int_index4(wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos0,mdv)

c     Force the near-surface wind to zero
      if (pind.lt.1.) w0=w0*pind

C     For first iteration take ending position equal to starting position
      x1=x0
      y1=y0
      p1=p0

C     Iterative calculation of new position
      do icount=1,numit

C        Calculate new winds for advection
         call get_index4 (xind,yind,pind,x1,y1,p1,reltpos1,
     >                    p3d0,p3d1,spt0,spt1,3,
     >                    nx,ny,nz,xmin,ymin,dx,dy,mdv)
         u1 = int_index4(uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)
         v1 = int_index4(vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)
         w1 = int_index4(wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos1,mdv)

c        Force the near-surface wind to zero
         if (pind.lt.1.) w1=w1*pind

c        Get the new velocity in between
         u=(u0+u1)/2.
         v=(v0+v1)/2.
         w=(w0+w1)/2.

C        Calculate new positions
         x1 = x0 + fbflag*u*deltat/(deltay*cos(y0*pi/180.))
         y1 = y0 + fbflag*v*deltat/deltay
         p1 = p0 + fbflag*wfactor*w*deltat/100.

c       Handle pole problems (crossing and near pole trajectory)
        if ((hem.eq.1).and.(y1.gt.90.)) then
          y1=180.-y1
          x1=x1+per/2.
        endif
        if ((hem.eq.1).and.(y1.lt.-90.)) then
          y1=-180.-y1
          x1=x1+per/2.
        endif
        if (y1.gt.89.99) then
           y1=89.99
        endif

c       Handle crossings of the dateline
        if ((hem.eq.1).and.(x1.gt.xmin+per-dx)) then
           x1=xmin+amod(x1-xmin,per)
        endif
        if ((hem.eq.1).and.(x1.lt.xmin)) then
           x1=xmin+per+amod(x1-xmin,per)
        endif

C       Interpolate surface pressure to actual position
        call get_index4 (xind,yind,pind,x1,y1,1050.,reltpos1,
     >                   p3d0,p3d1,spt0,spt1,3,
     >                   nx,ny,nz,xmin,ymin,dx,dy,mdv)
        sp = int_index4 (spt0,spt1,nx,ny,1,xind,yind,1.,reltpos1,mdv)

c       Handle trajectories which cross the lower boundary (jump flag)
        if ((jump.eq.1).and.(p1.gt.sp)) p1=sp-10.

C       Check if trajectory leaves data domain
        if ( ( (hem.eq.0).and.(x1.lt.xmin)    ).or.
     >       ( (hem.eq.0).and.(x1.gt.xmax-dx) ).or.
     >         (y1.lt.ymin).or.(y1.gt.ymax).or.(p1.gt.sp) )
     >  then
          left=1
          goto 100
        endif

      enddo

c     Exit point for subroutine
 100  continue

      return

      end

c     -------------------------------------------------------------------
c     Runge-Kutta (4th order) time-step
c     -------------------------------------------------------------------

      subroutine runge(x1,y1,p1,left,x0,y0,p0,reltpos0,reltpos1,
     >                 deltat,numit,jump,mdv,wfactor,fbflag,
     >		       spt0,spt1,p3d0,p3d1,uut0,uut1,vvt0,vvt1,wwt0,wwt1,
     >                 xmin,ymin,dx,dy,per,hem,nx,ny,nz)

      implicit none

c     Declaration of subroutine parameters
      integer      nx,ny,nz
      real         x1,y1,p1
      integer      left
      real	   x0,y0,p0
      real         reltpos0,reltpos1
      real   	   deltat
      integer      numit
      integer      jump
      real         wfactor
      integer      fbflag
      real     	   spt0(nx*ny)   ,spt1(nx*ny)
      real         uut0(nx*ny*nz),uut1(nx*ny*nz)
      real 	   vvt0(nx*ny*nz),vvt1(nx*ny*nz)
      real         wwt0(nx*ny*nz),wwt1(nx*ny*nz)
      real         p3d0(nx*ny*nz),p3d1(nx*ny*nz)
      real         xmin,ymin,dx,dy
      real         per
      integer      hem
      real         mdv

c     Numerical and physical constants
      real         deltay
      parameter    (deltay=1.112E5)  ! Distance in m between 2 lat circles
      real         pi
      parameter    (pi=3.1415927)    ! Pi

c     Auxiliary variables
      real         xmax,ymax
      real	   xind,yind,pind
      real	   u0,v0,w0,u1,v1,w1,u,v,w,sp
      integer	   icount,n
      real         xs,ys,ps,xk(4),yk(4),pk(4)
      real         reltpos

c     Externals
      real         int_index4
      external     int_index4

c     Reset the flag for domain-leaving
      left=0

c     Set the esat-north bounray of the domain
      xmax = xmin+real(nx-1)*dx
      ymax = ymin+real(ny-1)*dy

c     Apply the Runge Kutta scheme
      do n=1,4

c       Get intermediate position and relative time
        if (n.eq.1) then
          xs=0.
          ys=0.
          ps=0.
          reltpos=reltpos0
        else if (n.eq.4) then
          xs=xk(3)
          ys=yk(3)
          ps=pk(3)
          reltpos=reltpos1
        else
          xs=xk(n-1)/2.
          ys=yk(n-1)/2.
          ps=pk(n-1)/2.
          reltpos=(reltpos0+reltpos1)/2.
        endif

C       Calculate new winds for advection
        call get_index4 (xind,yind,pind,x0+xs,y0+ys,p0+ps,reltpos,
     >                   p3d0,p3d1,spt0,spt1,3,
     >                   nx,ny,nz,xmin,ymin,dx,dy,mdv)
        u = int_index4 (uut0,uut1,nx,ny,nz,xind,yind,pind,reltpos,mdv)
        v = int_index4 (vvt0,vvt1,nx,ny,nz,xind,yind,pind,reltpos,mdv)
        w = int_index4 (wwt0,wwt1,nx,ny,nz,xind,yind,pind,reltpos,mdv)

c       Force the near-surface wind to zero
        if (pind.lt.1.) w1=w1*pind

c       Update position and keep them
        xk(n)=fbflag*u*deltat/(deltay*cos(y0*pi/180.))
        yk(n)=fbflag*v*deltat/deltay
        pk(n)=fbflag*w*deltat*wfactor/100.

      enddo

C     Calculate new positions
      x1=x0+(1./6.)*(xk(1)+2.*xk(2)+2.*xk(3)+xk(4))
      y1=y0+(1./6.)*(yk(1)+2.*yk(2)+2.*yk(3)+yk(4))
      p1=p0+(1./6.)*(pk(1)+2.*pk(2)+2.*pk(3)+pk(4))

c     Handle pole problems (crossing and near pole trajectory)
      if ((hem.eq.1).and.(y1.gt.90.)) then
         y1=180.-y1
         x1=x1+per/2.
      endif
      if ((hem.eq.1).and.(y1.lt.-90.)) then
         y1=-180.-y1
         x1=x1+per/2.
      endif
      if (y1.gt.89.99) then
         y1=89.99
      endif

c     Handle crossings of the dateline
      if ((hem.eq.1).and.(x1.gt.xmin+per-dx)) then
         x1=xmin+amod(x1-xmin,per)
      endif
      if ((hem.eq.1).and.(x1.lt.xmin)) then
         x1=xmin+per+amod(x1-xmin,per)
      endif

C     Interpolate surface pressure to actual position
      call get_index4 (xind,yind,pind,x1,y1,1050.,reltpos1,
     >                 p3d0,p3d1,spt0,spt1,3,
     >                 nx,ny,nz,xmin,ymin,dx,dy,mdv)
      sp = int_index4 (spt0,spt1,nx,ny,1,xind,yind,1,reltpos,mdv)

c     Handle trajectories which cross the lower boundary (jump flag)
      if ((jump.eq.1).and.(p1.gt.sp)) p1=sp-10.

C     Check if trajectory leaves data domain
      if ( ( (hem.eq.0).and.(x1.lt.xmin)    ).or.
     >     ( (hem.eq.0).and.(x1.gt.xmax-dx) ).or.
     >       (y1.lt.ymin).or.(y1.gt.ymax).or.(p1.gt.sp) )
     >then
         left=1
         goto 100
      endif

c     Exit point fdor subroutine
 100  continue

      return
      end


      SUBROUTINE beschb(x,gam1,gam2,gampl,gammi)
      INTEGER NUSE1,NUSE2
      DOUBLE PRECISION gam1,gam2,gammi,gampl,x
      PARAMETER (NUSE1=5,NUSE2=5)
CU    USES chebev
      REAL xx,c1(7),c2(8),chebev
      SAVE c1,c2
      DATA c1/-1.142022680371168d0,6.5165112670737d-3,3.087090173086d-4,
     *-3.4706269649d-6,6.9437664d-9,3.67795d-11,-1.356d-13/
      DATA c2/1.843740587300905d0,-7.68528408447867d-2,
     *1.2719271366546d-3,-4.9717367042d-6,-3.31261198d-8,2.423096d-10,
     *-1.702d-13,-1.49d-15/
      xx=8.d0*x*x-1.d0
      gam1=chebev(-1.,1.,c1,NUSE1,xx)
      gam2=chebev(-1.,1.,c2,NUSE2,xx)
      gampl=gam2-x*gam1
      gammi=gam2+x*gam1
      return
      END


       SUBROUTINE FFTINV(A,M)
C COMPUTES AND RETURNS THE INVERSE FFT.  THIS IS BASICALLY THE ONE TAKEN
C FROM OPPENHEIM AND SCHAFER, PAGE 331.
C ARGUMENTS:
C A - THE COMPLEX INPUT ARRAY TO BE TRANSFORMED.  THIS IS ALSO THE OUTPUT!!
C M - THE POWER OF 2 OF THE FFT.  THERE MUST BE 2**M COMPLEX POINTS IN A.
C
      COMPLEX A(1),U,W,T
       DATA PI/3.1415926535/
      N=2**M
      NV2=N/2
      NM1=N-1
      J=1
      DO 7 I=1,NM1
      IF(I.GE.J) GO TO 5
      T=A(J)
      A(J)=A(I)
      A(I)=T
5     K=NV2
6     IF(K.GE.J) GO TO 7
      J=J-K
      K=K/2
      GOTO 6
7     J=J+K
      LE=1
      DO 20 L=1,M
      LE1=LE
      LE=2*LE
      U=(1.,0.)
      B=PI/FLOAT(LE1)
      W=CMPLX(COS(B),-SIN(B))
      DO 20 J=1,LE1
      DO 10 I=J,N,LE
      IP=I+LE1
      T=A(IP)*U
      A(IP)=A(I)-T
10    A(I)=A(I)+T
20    U=U*W
      RETURN
      END


!	PROGRAM TO CALCULATE AN AGE SPECTRUM FROM A GIVEN THERMAL
!		HISTORY. (AGES.F) (SPHERES)

!	R= GAS CONSTANT KCAL/(MOL*K)
!	XLAMBD= DECAY CONSTANT OF POTASSIUM IN 1/MYRS.
!	NUSA=# OF SAMPLES,  TOTIME = TOTAL TIME OF Ar ACCUMULATION
!	C40WD= TOTAL ARGON RADIOGENIC 40Ar PRODUCED POR UNIT VOL. FROM TIME=0.
!	C39WD= FRACTION OF 39Ar AT PRESENT.
!	NEND=TIME AT WHICH THE SYSTEM IS EFFECTIVELY CLOSED, TEMPERATURE
!       IS ASSUME CONSTANT FROM THIS TIME UNTIL PRESENT.
!	STEP= DURATION OF THE TIME STEP, PEND AND TEMIN DEFINE
!	 THE DIFFERENT SEGMENTS OF THE COOLING HISTORY
!	NI=# OF HEATING STEPS
!	TELAB = TEMPERATURE STEP (*K), TILAB= DURATION OF THE HEATING STEP (MIN)
!	NSAMP=# OF DIFFERENT DIFFUSION DOMAIN SIZES
!	D0(J)= FREQUENCY FACTOR (1/SEC)
!	E(J)= ACTIVACTION ENERGY (KCAL/MOL)
!       C(J)= VOLUME FRACION
!	SUBROUTINE GEOSEC CALCULATE THE DISTRIBUTION OF 40Ar AT PRESENT WHICH
!	IS GIVEN BY THE COEFFICIENT XI(N).
!	SUBROUTINE LAB CALCULATE THE RELEASED OF 40Ar and 39Ar AT LAB.
!	FOR EACH DIFFUSION DOMAIN SIZE. (REA40 AND REA39)
!	CURA= CUMULATIVE RATE OF A40 T0 A39 RELEASE.
!	RATE= STEP RATE OF A40 T0 A39 RELEASE
!	DR39 AND DR40 ARE THE STEP RELEASE OF A39 AND A40 RESPECTIVELY.

!=========================================================================

implicit double precision (a-h, o-z)
parameter(nn = 340, nch = 1005, ntp = 100, pi = 3.141592654, &
        xlambd = 0.0005543, R = 1.987d-03, x1 = 1.2d0, x2 = 3.d0, acc = 1.d-5)
dimension r40(ntp), r39(ntp), dr39(ntp)
dimension temp(nch), time(nch)
dimension c(10), tra40(0:ntp), tra39(0:ntp), sra40(ntp)
dimension sra39(ntp), scura(ntp), tilab(ntp), telab(ntp)
dimension E(10), d0(10), tmin(50), tpin(50)
double precision zero, bessj0, bessj1, rtsafe
external zero, bessj0, bessj1, rtsafe
character*9  tab1, yes*1
common /var/ an(nn), xi(nn), b, c40
common /integ/ lc(0:nn), imod

tab1 = char(09)
open(unit = 14, file = 'ages-me.out', status = 'unknown')
open(unit = 15, file = 'agesme.in', status = 'old')
open(unit = 16, file = 'ages-me.dat', status = 'unknown')
open(unit = 17, file = 'temstep.in', status = 'old')
open(unit = 19, file = 'each-me.out', status = 'unknown')
open(unit = 20, file = 'chist-me.dat', status = 'unknown')
open(unit = 21, file = 'agesme.cl', status = 'old')

lc(0) = 0.
!	CALCULATION OF THE COOLING HISTORY

read(15, *)np
do 2 j = 1, np
    read(15, *)tmin(j), tpin(j)
    write(20, 105)tmin(j), tab1, tpin(j)
2    tpin(j) = tpin(j) + 273.

write(20, *) char(38)
dt = 2
dtdt = (tpin(1) - tpin(2)) / (tmin(1) - tmin(2))
call chist(np, tmin, tpin, time, temp, dt, ns, nch)
c40 = 1. - dexp(-xlambd * tmin(1))
c39wd = dexp(-xlambd * tmin(1))

!print *, 'If you want to see the CH?, type ''y'''
!read *, yes
!if (yes.eq.'y')stop

read(21, *) imod
!print *, 'slabs= 1, spheres= 2 , cilinders= 3'
!read *, imod
!print *, 'model =', imod
b = 10.d0 - 2.d0 * imod

!  DEFINITION OF STEP HEATING SCHEDULED AT LAB.

read(17, 110)ni
do 12 j = 1, ni
    read(17, *)telab(j), tilab(j)
    if(telab(j).gt.1373.)goto 11
12    tilab(j) = tilab(j) / 5.256e11
11   ni = j - 1
close(17)

!  DEFINITION OF DISTRIBUTION PARAMETERS

read(15, 110)nsamp
do 14 js = 1, nsamp
    read(15, *)e(js), d0(js), c(js)
     d0(js) = 10.**d0(js)
     d0(js) = d0(js) * (24. * 3600. * 365e06)
14 end do

!14  d0(js) = d0(js) * (24. * 3600. * 365e06)

! CALCULATION OF LC
nsq = 1
nsum = 0
m = 0
do 32 j = 1, nn - 1
    if(nsum.gt.20)then
        nsum = 1
        nsq = nsq * 2
    endif
    m = m + nsq
    if(m.gt.100)nsum = nsum + 1
    lc(j) = m
    if(imod.eq.1)an(j) = ((2 * m - 1) * pi)**2
    if(imod.eq.2)an(j) = (m * pi)**2
    if(imod.eq.3)an(j) = zero(m)**2
32    continue
lc(nn) = lc(nn - 1) + 1
if(imod.eq.3)an(1) = rtsafe(x1, x2, acc)**2

!	CALCULATION OF THE AGE SPECTRUM

do 16 je = 1, nsamp
    if(imod.eq.1)d0(je) = d0(je) / 4.d0

    !	tau=r*550.**2/(e(1)*dtdt)
    !      tc= e(1)/r/dlog(8.7*tau*d0(1))-273.

    call geosec(ns, xlambd, d0(je), E(je), temp, time)
    call lab(d0(je), E(je), r40, r39, telab, tilab, dr39, ni, tab1)

    !	SUMMATION OF THE CONTRIBUTION OF EACH DIFFUSION DOMAIN SIZE.

    do 18 k = 1, ni
        tra40(k) = c(je) * r40(k) + tra40(k)
    18    tra39(k) = c(je) * r39(k) + tra39(k)
16    continue
do 20  j = 1, ni
    sra40(j) = tra40(j) - tra40(j - 1)
    sra39(j) = tra39(j) - tra39(j - 1)
    if (sra40(j).gt.0.and.sra39(j).gt.0)goto  21
    age = 0.
    goto 19
    21    continue
    scura(j) = sra40(j) / sra39(j)
    age = dlog(1. + scura(j) / c39wd) / xlambd
    19    write(16, 130)tra39(j - 1) * 100., tab1, age
    av = (tra39(j - 1) + tra39(j)) * 50.
    write(14, 130)av, tab1, age
    !     write(20,105)age,tab1,tc
20    write(16, 130)tra39(j) * 100., tab1, age
do 22 j = 1, ni
    tra39(j) = 0.
22    tra40(j) = 0.
110    format(i20)
105     format(g20.8, a1, g20.8)
100    format(g20.8)
120    format(1x, 3(f12.6, a1))
130    format(1x, 3(g20.8, a1))
stop
end

subroutine geosec(nend, xlambd, d0, E, temp, time)
    implicit double precision (a-h, o-z)
    parameter(nch = 1005, nn = 340, pi = 3.141592654, R = 1.987d-03)
    dimension time(nend + 4), temp(nend + 4), dzita(nch), d(nch)
    common /var/ an(nn), xi(nn), b, c40
    common /integ/ lc(0:nn), imod

    zit = 0.
    do 10 j = 1, nend
        avtemp = (temp(j + 1) + temp(j)) / 2.
        if(j.eq.1.and.avtemp.lt.800)then
            print *, "WARNING: the sample could had been"
            print *, "retaining argon at ages >", time(1), " Ma"
            print *, "The program assume zero argon concentration"
            print *, "at the initial age:", time(1), " Ma"
        endif
        d(j) = d0 * dexp(-e / r / avtemp)
    10    continue
    dzita(nend + 1) = 0.
    do 20 j = nend, 1, -1
    20    dzita(j) = dzita(j + 1) + dabs(time(j + 1) - time(j)) * d(j)

    !     COMPUTO OF XI(M) - M<80000 --> nn=340
    do 30 mi = 1, nn - 1
        xlogm = dlog(an(mi))
        sum = 0.d0
        do 40 n = 1, nend
            if(d(n).eq.0.)goto 40
            uplus = an(mi) * dzita(n + 1) + xlambd * (time(1) - time(n + 1))
            if (uplus - xlogm.gt.25.)goto 40
            al = an(mi) * d(n) - xlambd
            xal = al * (time(n) - time(n + 1))
            if (dabs(xal).gt.30)then
                camal = 1.d0 / al
            else
                if (dabs(xal).gt.0.001)then
                    camal = (1.d0 - dexp(-xal)) / al
                else
                    camal = (time(n) - time(n + 1)) * (1 - xal / 2 + xal**2 / 6.d0)
                endif
            endif
            sum = sum + d(n) * dexp(-uplus) * camal
        40        continue
        tzita = dzita(1) * an(mi)
        if(tzita.lt.30.)then
            xfact = dexp(-tzita)
        else
            xfact = 0.d0
        endif
        xi(mi) = sum * an(mi) + xfact
    30    continue
    80    continue
    return
end

subroutine lab(d0, e, r40, r39, telab, tilab, dr39, ni, tab1)
    implicit double precision (a-h, o-z)
    parameter(nn = 340, ntp = 200, pi = 3.141592654, xlambd = 0.0005543, &
            R = 1.987d-03)
    dimension r40(ni), zita(ntp), r39(ni), ages(ntp)
    dimension dr39(ni), dr40(ntp), rate(ntp), tilab(ni), telab(ni)
    character*9 tab1
    common /var/ an(nn), xi(nn), b, c40
    common /integ/ lc(0:nn), imod

    c39wd = 1 - c40
    zii = 0.
    do 10 nt = 1, ni
        zita(nt) = zii + d0 * tilab(nt) * dexp(-e / (r * telab(nt)))
    10    zii = zita(nt)

    do 20 j = 1, ni
        r39(j) = 1.
        r40(j) = 0.
        sumck = 0.
        do 20 k = 1, nn - 1
            xmat = 0.d0
            do 22 k1 = lc(k - 1) + 1, lc(k) - 1
                if(imod.eq.1)an2 = ((2 * k1 - 1) * pi)**2
                if(imod.eq.2)an2 = (k1 * pi)**2
                if(imod.eq.3)an2 = zero(k1)**2
                if (zita(j) * an2.gt.100.) then
                    ab = 0.
                else
                    ab = dexp(-zita(j) * an2) / an2
                endif
                xmat = xmat + (1.d0 - (lc(k) - k1) / (lc(k) - lc(k - 1))) * (1. / an2 - ab)
            22        continue
            do 24 k1 = lc(k), lc(k + 1) - 1
                if(imod.eq.1)an2 = ((2 * k1 - 1) * pi)**2
                if(imod.eq.2)an2 = (k1 * pi)**2
                if(imod.eq.3)an2 = zero(k1)**2
                if(imod.eq.3.and.k1.eq.1)an2 = an(1)
                if (zita(j) * an2.gt.100.) then
                    ab = 0.
                else
                    ab = dexp(-zita(j) * an2) / an2
                    r39(j) = r39(j) - b * ab
                endif
                sumck = sumck + b * 1.d0 / an2
                xmat = xmat + (lc(k + 1) - k1) / (lc(k + 1) - lc(k)) * (1. / an2 - ab)
                r40(j) = r40(j) + b * (c40 - 1) * (1. / an2 - ab)
            24        continue
            r40(j) = r40(j) + b * xmat * xi(k)
        20    continue
    rate(1) = r40(1) / r39(1)
    dr39(1) = r39(1)
    dr40(1) = r40(1)
    do 50 j = 2, ni
        dr39(j) = r39(j) - r39(j - 1)
        dr40(j) = r40(j) - r40(j - 1)
        if (dr39(j).gt.0.and.dr40(j).gt.0)goto 70
        ages(j) = 0.
        goto 50
        70   rate(j) = dr40(j) / dr39(j)
        ages(j) = dlog(1. + rate(j) / c39wd) / xlambd
    50    continue
    ages(1) = dlog(1. + rate(1) / c39wd) / xlambd
    rnum = 1. - 1.0e-07
    do 80 j = 1, ni
        if(r39(j).le.rnum)then
            write(19, 140)r39(j) * 100, tab1, ages(j)
        endif
    80    continue
    140    format(1x, 4(f12.4, a1))
    return
end

!	SUBROUTINE TO CALCULATE THE THERMAL HISTORY.
!		 (SUBROUTINE SUBCHIST.F)

subroutine chist(np, tmin, tpin, time, temp, dt, ns, nch)
    implicit double precision (a-h, o-z)
    dimension temp(nch), time(nch)
    dimension tpin(np), tmin(np)
    CHARACTER TAB1*9
    TAB1 = CHAR(09)
    open(unit = 18, file = 'chist.dat')

    !	DEFINITION OF THE TEMPERATURE STEP IN CENTIDEGREE.

    !	CALCULATION OF THE COOLING HISTORY

    ns = 0.
    temp(1) = tpin(1)
    time(1) = tmin(1)
    tem0 = tpin(1)
    do 4 k = 1, np - 1
        nt = dabs(tpin(k) - tpin(k + 1)) / dt + ns
        snt = (tpin(k) - tpin(k + 1))
        if(dabs(snt).lt.dt)then
            temp(nt + 2) = tpin(k + 1)
            time(nt + 2) = tmin(k + 1)
            ns = ns + 1
            tem0 = tpin(k + 1)
            goto 4
        endif
        snt = snt / dabs(tpin(k) - tpin(k + 1))
        do 6 j = ns + 2, nt + 1
            temp(j) = tem0 - snt * dt
            time(j) = age(temp(j), tmin(k), tmin(k + 1), tpin(k), tpin(k + 1))
            tem0 = temp(j)
        6       continue
        ns = nt
        if(dmod(tpin(k) - tpin(k + 1), dt).ne.0.)then
            temp(nt + 2) = tpin(k + 1)
            time(nt + 2) = tmin(k + 1)
            tem0 = temp(nt + 2)
            ns = ns + 1
        endif
        if(ns.gt.nch - 2)stop 'Number of step larger than 1000'
    4    continue

    do 8 jk = 1, ns + 1
        write(18, 100)time(jk), tab1, temp(jk) - 273.
    8    continue
    100     format(g20.8, a1, g20.8)
    return
end

double precision function age(y, a1, a2, t1, t2)
    implicit double precision (a-h, o-z)
    if(y.lt.0.)pause 'temperature less than zero'
    age = a1 + (y - t1) * (a2 - a1) / (t2 - t1)
    return
end

double precision function zero(n)
    implicit double precision (a-h, o-z)
    parameter(pi = 3.14159265)
    den = pi * (4 * n - 1)
    zero = den / 4. + 1. / (2. * den) - 31. / (6 * den**3) + 3779. / (15 * den**5)
    return
end

subroutine funcd(x1, f, df)
    implicit double precision (a-h, o-z)
    f = bessj0(x1)
    df = - bessj1(x1)
    return
end

double precision function bessj0(x)
    implicit double precision (a-h, o-z)
    !      real*8 y,p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
    !     *    s1,s2,s3,s4,s5,s6
    data p1, p2, p3, p4, p5/1.d0, -.1098628627d-2, .2734510407d-4, &
            -.2073370639d-5, .2093887211d-6/, q1, q2, q3, q4, q5/-.1562499995d-1, &
            .1430488765d-3, -.6911147651d-5, .7621095161d-6, -.934945152d-7/
    data r1, r2, r3, r4, r5, r6/57568490574.d0, -13362590354.d0, 651619640.7d0, &
            -11214424.18d0, 77392.33017d0, -184.9052456d0/, &
            s1, s2, s3, s4, s5, s6/57568490411.d0, 1029532985.d0, &
                    9494680.718d0, 59272.64853d0, 267.8532712d0, 1.d0/
    if(dabs(x).lt.8.)then
        y = x**2
        bessj0 = (r1 + y * (r2 + y * (r3 + y * (r4 + y * (r5 + y * r6)))))&
                / (s1 + y * (s2 + y * (s3 + y * (s4 + y * (s5 + y * s6)))))
    else
        ax = dabs(x)
        z = 8. / ax
        y = z**2
        xx = ax - .785398164
        bessj0 = dsqrt(.636619772 / ax) * (dcos(xx) * (p1 + y * (p2 + y * (p3 + y * (p4 + y&
                * p5)))) - z * dsin(xx) * (q1 + y * (q2 + y * (q3 + y * (q4 + y * q5)))))
    endif
    return
end

double precision function bessj1(x)
    implicit double precision (a-h, o-z)
    !      real*8 y,p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
    !     *    s1,s2,s3,s4,s5,s6
    data r1, r2, r3, r4, r5, r6/72362614232.d0, -7895059235.d0, 242396853.1d0&
            , &
            -2972611.439d0, 15704.48260d0, -30.16036606d0/, &
            s1, s2, s3, s4, s5, s6/144725228442.d0, 2300535178.d0, &
                    18583304.74d0, 99447.43394d0, 376.9991397d0, 1.d0/
    data p1, p2, p3, p4, p5/1.d0, .183105d-2, -.3516396496d-4, .2457520174d-5&
            , &
            -.240337019d-6/, q1, q2, q3, q4, q5/.04687499995d0, -.2002690873d-3&
            , &
            .8449199096d-5, -.88228987d-6, .105787412d-6/
    if(dabs(x).lt.8.)then
        y = x**2
        bessj1 = x * (r1 + y * (r2 + y * (r3 + y * (r4 + y * (r5 + y * r6)))))&
                / (s1 + y * (s2 + y * (s3 + y * (s4 + y * (s5 + y * s6)))))
    else
        ax = dabs(x)
        z = 8. / ax
        y = z**2
        xx = ax - 2.356194491
        bessj1 = dsqrt(.636619772 / ax) * (dcos(xx) * (p1 + y * (p2 + y * (p3 + y * (p4 + y&
                * p5)))) - z * dsin(xx) * (q1 + y * (q2 + y * (q3 + y * (q4 + y * q5)))))&
                * dsign(1.d0, x)
    endif
    return
end

double precision function rtsafe(x1, x2, xacc)
    implicit double precision (a-h, o-z)
    parameter (maxit = 100)
    call funcd(x1, fl, df)
    call funcd(x2, fh, df)
    if(fl * fh.ge.0.) pause 'root must be bracketed'
    if(fl.lt.0.)then
        xl = x1
        xh = x2
    else
        xh = x1
        xl = x2
        swap = fl
        fl = fh
        fh = swap
    endif
    rtsafe = .5 * (x1 + x2)
    dxold = dabs(x2 - x1)
    dx = dxold
    call funcd(rtsafe, f, df)
    do 11 j = 1, maxit
        if(((rtsafe - xh) * df - f) * ((rtsafe - xl) * df - f).ge.0.&
                .or. dabs(2. * f).gt.dabs(dxold * df)) then
            dxold = dx
            dx = 0.5 * (xh - xl)
            rtsafe = xl + dx
            if(xl.eq.rtsafe)return
        else
            dxold = dx
            dx = f / df
            temp = rtsafe
            rtsafe = rtsafe - dx
            if(temp.eq.rtsafe)return
        endif
        if(dabs(dx).lt.xacc) return
        call funcd(rtsafe, f, df)
        if(f.lt.0.) then
            xl = rtsafe
            fl = f
        else
            xh = rtsafe
            fh = f
        endif
    11    continue
    pause 'rtsafe exceeding maximum iterations'
    return
end


! File contains dark matter response (dmr) functions roughly corresponding to
! equation (40) in the paper.
!

module dmresponselib

    use constants
    implicit none

    contains

    ! Darkmatter particle response function:
    !   $R_M^{\tau\tau'}(\vec{v}_T^{\perp 2}, \frac{\vec{q}^2}{2m_N^2})$
    !   Eqn. 38
    !
    !   This function comes from "dmformfactor-V6.m: FFfinal[DMmatrix_,J_,T)]".
    !   This is the coef. for $W_M^{\tau\tau'}(y)$.

    ! dmrMJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrPhiPPJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrPhiPPJMJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrPhiTPJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrSigmaPPJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrSigmaPJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrDeltaJ(eft, tau1, tau2, q, v, jchi, muT)
    ! dmrSigmaPJDeltaJ(eft, tau1, tau2, q, v, jchi, muT)

    ! From dmformfactor-V6.m:
    ! (*These response coefficients differ in their definition from those in the paper
    ! because they have c's instead of a's, resulting in an overall factor of
    ! 1/(4mN mchi)^2.  This will show up as an additional factor that we multiply
    ! FF by before printing out StrucFunction, TransitionProbability, and
    ! ResponseNucl *)

    function dmrMJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.
        ! import modules from modules.f90

        implicit none

        ! outputs
        REAL(kind=8) :: dmrMJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        integer, INTENT(IN) :: tau1, tau2
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT

        ! functions called
        !REAL(kind=8) :: Cl

        dmrMJ = 0.25d0*Cl(jchi) &
            * ((eft(tau1,5)*eft(tau2,5)*q*q + eft(tau1,8)*eft(tau2,8)) &
                     * vp2(v,q,muT) &
                + eft(tau1,11)*eft(tau2,11)*q*q) &
            + (eft(tau1,1) + eft(tau1,2)*vp2(v,q,muT)) &
                * (eft(tau2,1) + eft(tau2,2)*vp2(v,q,muT) )

    end function dmrMJ

    function dmrPhiPPJ(eft, tau1, tau2, q, jchi)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrPhiPPJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: jchi
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrPhiPPJ = q*q/(16*mN*mN) * Cl(jchi) * (eft(tau1,12) &
                - eft(tau1,15)*q*q) * (eft(tau2,12) - eft(tau2,15)*q*q) &
            + q**4.0/(4*mN*mN) * eft(tau1,3)*eft(tau2,3)

    end function dmrPhiPPJ

    function dmrPhiPPJMJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrPhiPPJMJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrPhiPPJMJ = q*q/(4*mN) * Cl(jchi) * eft(tau1,11) * ( &
                    eft(tau2,12) - eft(tau2,15)*q*q &
                ) + q*q/(mN)*eft(tau2,3) * ( &
                    eft(tau1,1) + eft(tau1,2) * vp2(v,q,muT))

    end function dmrPhiPPJMJ

    function dmrPhiTPJ(eft, tau1, tau2, q, jchi)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrPhiTPJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: jchi
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrPhiTPJ = q*q/(16*mN*mN)*Cl(jchi) * ( &
                eft(tau1,13)*eft(tau2,13)*q*q &
                + eft(tau1,12)*eft(tau2,12) &
            )

    end function dmrPhiTPJ

    function dmrSigmaPPJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrSigmaPPJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrSigmaPPJ = (1./16) * Cl(jchi) * ( &
                eft(tau1,6)*eft(tau2,6)*q**4 + ( &
                    eft(tau1,13)*eft(tau2,13)*q*q &
                    + eft(tau1,12)*eft(tau2,12) &
                ) * vp2(v,q,muT) &
                + 2*eft(tau1,4)*eft(tau2,6)*q*q &
                + eft(tau1,4)*eft(tau2,4) &
            ) + (1./4)*eft(tau1,10)*eft(tau2,10)*q*q

    end function dmrSigmaPPJ

    function dmrSigmaPJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrSigmaPJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrSigmaPJ = (1./32) * Cl(jchi) * ( &
                2*eft(tau1,9)*eft(tau2,9)*q*q + ( &
                    eft(tau1,15)*eft(tau2,15)*q**4 &
                    + eft(tau1,14)*eft(tau2,14)*q*q &
                    - 2*eft(tau1,12)*eft(tau2,15)*q*q &
                    + eft(tau1,12)*eft(tau2,12) &
                ) * vp2(v,q,muT) &
                + 2*eft(tau1,4)*eft(tau2,4) &
            ) + (1./8) * ( &
                eft(tau1,3)*eft(tau2,3)*q*q &
                + eft(tau1,7)*eft(tau2,7) &
            ) * vp2(v,q,muT)

    end function dmrSigmaPJ

    function dmrDeltaJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.
        implicit none

        ! outputs
        REAL(kind=8) :: dmrDeltaJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrDeltaJ = q*q/(4*mN*mN) * Cl(jchi) * ( &
                eft(tau1,5)*eft(tau2,5)*q*q &
                + eft(tau1,8)*eft(tau2,8) &
            ) + 2*q*q/(mN*mN) * eft(tau1,2)*eft(tau2,2) &
                * vp2(v,q,muT)

    end function dmrDeltaJ

    function dmrSigmaPJDeltaJ(eft, tau1, tau2, q, v, jchi, muT)
        ! O. Gorton 2020.01.

        implicit none

        ! outputs
        REAL(kind=8) :: dmrSigmaPJDeltaJ

        ! inputs
        real(kind=8), allocatable, intent(in) :: eft(:,:)
        REAL(kind=8), INTENT(IN) :: q
        REAL(kind=8), INTENT(IN) :: v
        REAL(kind=8), INTENT(IN) :: jchi, muT
        integer, INTENT(IN) :: tau1, tau2

        ! functions called
        !REAL(kind=8) :: Cl

        dmrSigmaPJDeltaJ = q*q/(4*mN) * Cl(jchi) * ( &
                eft(tau1,4)*eft(tau2,5) - eft(tau1,8)*eft(tau2,9) &
            ) - q*q/(mN)*eft(tau2,2)*eft(tau1,3) * vp2(v,q,muT)

    end function dmrSigmaPJDeltaJ

    function Cl(j)
        ! O. Gorton 2020.01.
        ! Abbreviation for 4j(j+1)/3
        implicit none
        REAL(kind=8), INTENT(IN) :: j
        REAL(kind=8) Cl

        Cl = 4.0 * j * (j + 1) / 3.0

    end function Cl

    function vp2(v,q,muT)
        implicit none
        REAL(kind=8), INTENT(IN) :: v, q, muT
        real(kind=8) :: vp2

        vp2 = v*v - q*q/(4d0*muT*muT)
    end function vp2

end module dmresponselib