! ******************************************************************************************************************************** !
! sedgem_box_archer1991_sedflx.f90
! David Archer's (1991) sediment diagenesis routines
! ******************************************************************************************************************************** !

MODULE sedgem_box_archer1991_sedflx

  use genie_control
  USE sedgem_lib
  IMPLICIT NONE
  SAVE

  INTEGER,PARAMETER::nzmax     = 10
  INTEGER,PARAMETER::kmax      = 7
  INTEGER,PARAMETER::nzmax_co3 = 30
  INTEGER,PARAMETER::nmax      = 300
  REAL,PARAMETER,DIMENSION(nzmax)::delz = (/0.0,0.5,0.5,1.0,2.0,3.0,3.0,5.0,5.0,5.0/)

CONTAINS

! *************************************************************************************************
! *** sedflx **************************************************************************************
! *************************************************************************************************

! uses a specified calcite concentration to find the
! instantaneous flux from bottom water chemistry
! and the organic carbon rain.  assumes that org
! adjusts quickly.

  function fun_archer1991_sedflx(o2bw,calpc,rainorg,co2,hco3,co3,k1,k2,calsat,db)
    ! result variable
    real::fun_archer1991_sedflx
    ! dummy variables
    REAL,INTENT(IN)::o2bw,calpc,rainorg
    REAL,INTENT(IN)::co2,hco3,co3
    REAL,INTENT(IN)::k1,k2
    REAL,INTENT(IN)::calsat
    REAL,INTENT(IN)::db ! sediment mixing rate, cm2/yr
    ! local variables
    INTEGER::j,l
    REAL::difo2,rc,dissc,dissn,expb,zrct
    real::diftc,difal
    real::ttrorg,ttrcal
    real::ttral,ttrtc
    REAL,DIMENSION(3)::difc
    REAL,DIMENSION(nzmax)::z,o2,orgml,calml,orggg,calgg,form,pore
    REAL,DIMENSION(nzmax,3)::carb,resp_c

    !
    z(1) = 0.
    DO j = 2, kmax
      z(j) = z(j-1) + delz(j)
    END DO
    !
    CALL set_pore(calpc,z,pore)
    !
    expb = 3.0
    ! diffusion coefficient for o2
    difo2 = 12.1e-6
    ! diffusion coefficient for co2
    difc(1) = 10.5e-6
    ! diffusion coefficient for hco3
    difc(2) = 6.4e-6
    ! diffusion coefficient for co3
    difc(3) = 5.2e-6
    ! dissolution rate constant, units of 1/s
    dissc = (par_sed_archer1991_disscpct/100.0) * par_sed_archer1991_dissc ! 1. * 1.1574e-5
    ! dissolution rate order
    dissn = par_sed_archer1991_dissn ! 4.5
    ! organic degradation rate constant, 1/s
    rc = par_sed_archer1991_rc ! 2.E-9
    !
    o2(1) = o2bw
    carb(1,1) = co2
    carb(1,2) = hco3
    carb(1,3) = co3

    CALL pore_2_form(pore,form,expb)

    CALL o2org(rainorg,rc,difo2,db,z,form,pore,o2,zrct,orgml,orggg,resp_c)

    DO l = 2, kmax
      calgg(l) = calpc
    END DO

    CALL sldcon(calml,calgg,100.,pore)

    CALL co3ss(resp_c,dissc,dissn,calsat,k1,k2,difc,form, &
      & pore,calgg,carb,ttrorg,ttrcal,ttral,ttrtc,diftc,difal)

    fun_archer1991_sedflx = ttrcal

  END function fun_archer1991_sedflx

! *************************************************************************************************
! *** o2org ***************************************************************************************
! *************************************************************************************************

  SUBROUTINE o2org(rainorg,rc,difo2,db,z,form,pore,o2,zrct,orgml,orggg,resp_c)

    REAL,INTENT(in)::rainorg
    REAL,INTENT(in)::db
    REAL,INTENT(inout)::rc,difo2,zrct
    REAL,INTENT(inout),DIMENSION(:)::z,form,pore,o2,orgml,orggg
    REAL,INTENT(inout),DIMENSION(:,:)::resp_c

    INTEGER::k,m
    REAL::zup,zdn,sed_cmky,rct_c,rms_c,rct_o2,rms_o2
    REAL,DIMENSION(nzmax)::dopls,domin
    REAL,DIMENSION(nzmax)::dbpls,dbmin

    DO k = 2, kmax
      o2(k) = o2(1)
      orggg(k) = 0.0002
    END DO

    CALL sldcon(orgml,orggg,12.,pore)

    CALL calc_o2_diff(difo2,form,pore,dopls,domin)

    CALL calc_db(db,dbpls,dbmin,z,pore,12.)

    sed_cmky = 1.0

    zrct = z(kmax)

    CALL orgc(rainorg,rc,zrct,dbpls,dbmin,pore,orggg,orgml,z,rct_c,rms_c)

    CALL o2ss(o2,z,orgml,pore,dopls,domin,rc,zrct,rct_o2,rms_o2)

! NOTE: the limit in this do loop was originally 20;
!       it can be increased to improve numerical stability under potenitally-anoxic conditions
    IF(o2(kmax).LT.0) THEN
      zup = 0.
      zdn = z(kmax)
      zrct = (zup + zdn) / 2.
      DO m=1,par_sed_archer1991_iterationmax
        CALL orgc(rainorg,rc,zrct,dbpls,dbmin,pore,orggg,orgml,z,rct_c,rms_c)
        CALL o2ss(o2,z,orgml,pore,dopls,domin,rc,zrct,rct_o2,rms_o2)
        IF( ABS(o2(kmax)).LT. 1.e-7) EXIT
        IF(o2(kmax).LT.0) THEN
          zdn = zrct
          zrct = (zrct + zup) / 2.
        ELSE
          zup = zrct
          zrct = (zrct + zdn) / 2.
        ENDIF
      END DO
    ENDIF

    CALL get_resp(rc,orgml,zrct,z,resp_c)

  END SUBROUTINE o2org

! *************************************************************************************************
! *** get_resp ************************************************************************************
! *************************************************************************************************

  SUBROUTINE get_resp(rc,orgml,zrct,z,resp_c)

    REAL,INTENT(inout)::rc,zrct
    REAL,INTENT(inout),dimension(:)::orgml,z
    REAL,INTENT(inout),dimension(:,:)::resp_c

    INTEGER::i

    DO i = 1, kmax
      IF(z(i).le.zrct) THEN
        resp_c(i,1) = rc * orgml(i)
      ELSEIF(z(i-1).le.zrct) THEN
        resp_c(i,1) = rc * orgml(i) * (zrct-z(i-1))/delz(i)
      ELSEIF(z(i-1).GT.zrct) THEN
        resp_c(i,1) = 0.
      ENDIF
      resp_c(i,2) = 0.
      resp_c(i,3) = 0.
    END DO

  END SUBROUTINE get_resp

! *************************************************************************************************
! *** orgc ****************************************************************************************
! *************************************************************************************************

  SUBROUTINE orgc(rainorg,rc,zrct,dbpls,dbmin,pore,orggg,orgml,z,smrct,rmserr)

    REAL,INTENT(in)::rainorg
    REAL,INTENT(inout)::rc,zrct,smrct,rmserr
    REAL,INTENT(inout),DIMENSION(:)::dbpls,dbmin,pore,orggg,orgml,z

    REAL:: res(nzmax), dres(nzmax,3)
    REAL:: react(nzmax), dreac(nzmax)
    REAL:: a(nzmax,nzmax), b(nzmax,1)

    INTEGER::i,j

    smrct = 0.

! ***  ***

    DO i=2, kmax
      IF(z(i).le.zrct .AND. orggg(i).GT.0) THEN
        react(i) = - rc * orggg(i) * 3.15e7
        dreac(i) = - rc * 3.15e7
      ELSEIF(z(i-1).le.zrct) THEN
        react(i) = - rc * orggg(i) * 3.15e7 * (zrct-z(i-1))/delz(i)
        dreac(i) = - rc * 3.15e7 * (zrct-z(i-1))/delz(i)
      ELSEIF(z(i-1).GT.zrct) THEN
        react(i) = 0.
        dreac(i) = 0.
      ENDIF
    END DO

! ***  ***

    DO i=3, kmax-1
! residual(i)
      res(i) = dbpls(i) * (orggg(i+1) - orggg(i)) - &
        & dbmin(i) * (orggg(i) - orggg(i-1)) + &
        & react(i)
! dr/dx(i+1)
      dres(i,1) = dbpls(i)
! dr/dx(i)
      dres(i,2) = - dbpls(i) - dbmin(i) + dreac(i)
! dr/dx(i-1)
      dres(i,3) = dbmin(i)
    END DO

! ***  ***

    i=2
! residual(2)
    res(i) = dbpls(i) * (orggg(i+1) - orggg(i)) + &
      & react(i) + rainorg * 12. / delz(i) / ( 1 - pore(i) ) / 2.5
! dr/dx(i+1)
    dres(i,1) = dbpls(i)
! dr/dx(i)
    dres(i,2) = - dbpls(i) + dreac(i)
! dr/dx(i-1) (not defined anyway for i=2)
    dres(i,3) = 0.0

! ***  ***

    i = kmax
! residual(kmax)
    res(i) = - dbmin(i) * (orggg(i) - orggg(i-1)) + react(i)
! dr/dx(i+1) (not defined anyway)
    dres(i,1) = 0.0
! dr/dx(i)
    dres(i,2) = - dbmin(i) + dreac(i)
! dr/dx(i-1)
    dres(i,3) = dbmin(i)

! ***  ***

!   zero the arrays
    DO i=1,kmax
      b(i,1) = 0.
      DO j=1,kmax
        a(i,j) = 0.
      END DO
    END DO

! set up the residual array
    DO i=1, kmax-1
      b(i,1) = - res(i+1)
! want res(2) into b(1), res(3) into b(2) etc.
    END DO

! diagonal, dri/dxi
    DO i=1, kmax-1
      a(i,i) = dres(i+1,2)
! want dres(2,2) in a(1,1), dres(3,2) in a(2,2) etc
    END DO

! upper off-diagonal, dri/dxi+1
    DO i=1,kmax-2
      a(i,i+1) = dres(i+1,1)
! want dres(2,1) in a(1,2), dres(3,1) in a(2,3) etc
    END DO

! lower off-diagonal, dri/dxi-1
    DO i=1, kmax-2
      a(i+1,i) = dres(i+2,3)
! want dres(3,3) in a(2,1), dres(4,3) in a(3,2) etc
    END DO

    CALL gaussj(a,kmax-1,b,1)

! update the concentration array
    rmserr = 0
    DO i=1,kmax-1
      orggg(i+1) = orggg(i+1) + b(i,1)
      rmserr = rmserr + res(i+1)**2
    END DO

    CALL sldcon(orgml,orggg,12.,pore)

    DO i=2, kmax
      IF(z(i).le.zrct) THEN
        react(i) = - rc * orggg(i)*3.15e7
      ELSEIF(z(i-1).le.zrct) THEN
        react(i) = - rc * orggg(i)*3.15e7/pore(i) * (zrct-z(i-1))/delz(i)
      ELSEIF(z(i-1).GT.zrct) THEN
        react(i) = 0.
      ENDIF
! units format:
! [ g diss / g sl yr ]
! [ g sl / cm3 sl ]
! [ cm3 sl / cm3 total ]
! [ cm (total) ]
! = [ g diss / cm2 yr ]
      smrct = smrct + react(i) * 2.5 * ( 1 - pore(i) ) * delz(i)
    END DO
! into units of moles / cm2 yr
    smrct = - smrct / 12.

    DO i=3, kmax-1
! residual(i)
      res(i) = dbpls(i) * (orggg(i+1) - orggg(i)) - dbmin(i) * (orggg(i) - orggg(i-1)) + react(i)
    END DO

    i=2
! residual(2)
    res(i) = dbpls(i) * (orggg(i+1) - orggg(i)) + react(i) + &
      & rainorg * 12. / delz(i) / ( 1 - pore(i) ) / 2.5

    i = kmax
! residual(kmax)
    res(i) = - dbmin(i) * (orggg(i) - orggg(i-1)) + react(i)

    rmserr = 0.
    DO i=2, kmax
      rmserr = rmserr + res(i)**2
      IF(orggg(i).GT.1) orggg(i) = 1.
      IF(orggg(i).LT.0) orggg(i) = 0.
    END DO
    rmserr = rmserr**(0.5)

  END SUBROUTINE orgc

! *************************************************************************************************
! *** o2ss ****************************************************************************************
! *************************************************************************************************

  SUBROUTINE o2ss(o2,z,orgml,pore,dopls,domin,rate,zrct,smrct,rmserr)

    REAL,INTENT(inout)::rate,zrct,smrct,rmserr
    REAL,INTENT(inout),DIMENSION(:)::o2,z,orgml,pore,dopls,domin

    REAL:: dfplus(nzmax), dfzero(nzmax), dfmins(nzmax)
    REAL:: a(nzmax,nzmax),b(nzmax,1),r(nzmax)

    INTEGER::j,k

    DO j=2,kmax-1
      r(j) = (   dopls(j)*(o2(j+1)-o2(j)) - domin(j)*(o2(j)-o2(j-1)) )
! units of m / cm2 (total) s
      IF(z(j).le.zrct) THEN
        r(j) = r(j) - 1.3*rate*orgml(j)/pore(j)
      ELSEIF(z(j-1).le.zrct) THEN
        r(j) = r(j) - 1.3*rate*orgml(j)/pore(j) * (zrct-z(j-1))/delz(j)
      ENDIF
! units of m / cm2 (total) s
      dfplus(j) = dopls(j)
      dfzero(j) = -dopls(j) -domin(j)
      dfmins(j) = domin(j)
! appropriate to units of m / cm2 s
    END DO

    j=kmax
    r(j) = ( - domin(j)*(o2(j)-o2(j-1)) )
    IF (z(j).LT.zrct) THEN
      r(j) = r(j) - 1.3*rate*orgml(j)/pore(j)
    ELSEIF(z(j-1).LT.zrct) THEN
      r(j) = r(j) - 1.3*rate*orgml(j) * (zrct-z(j-1))/delz(j)
    ENDIF
    dfplus(j) = 0.
    dfzero(j) = -domin(j)
    dfmins(j) = domin(j)
    DO j=1,kmax-1
      DO k=1,kmax-1
        a(j,k) = 0.
      END DO
    END DO
    DO j=1,kmax-2
      a(j,j+1) = dfplus(j+1)
      a(j,j) = dfzero(j+1)
      a(j+1,j) = dfmins(j+2)
    END DO
    a(kmax-1,kmax-1) = dfzero(kmax) + dfplus(kmax)
    DO j=1,kmax-1
      b(j,1) = - r(j+1)
    END DO

    CALL gaussj(a,kmax-1,b,1)

    smrct = 0.
    DO j=2,kmax
      o2(j) = o2(j) + b(j-1,1)
      IF(z(j).le.zrct) THEN
! units format:
! [ moles O2 / l total second ]
! [ moles O2 / cm3 yr ]
! [ moles O2 / cm2 yr ]
        smrct = smrct - 1.3*rate*orgml(j) * 3.15e7 / 1000. * delz(j)
      ELSEIF(z(j-1).le.zrct) THEN
        smrct = smrct - 1.3*rate*orgml(j) * (zrct-z(j-1))/delz(j) * 3.15e7 / 1000. * delz(j)
      ENDIF
    END DO

! Calculate RMS error
    rmserr = 0.
    DO j = 2, kmax-1
      r(j) = (   dopls(j)*(o2(j+1)-o2(j)) - domin(j)*(o2(j)-o2(j-1)) )
      IF(z(j).le.zrct) THEN
        r(j) = r(j) - 1.3*rate*orgml(j)/pore(j)
      ELSEIF(z(j-1).le.zrct) THEN
        r(j) = r(j) - 1.3*rate*orgml(j) * (zrct-z(j-1))/delz(j)
      ENDIF
      rmserr = rmserr + r(j)**2
    END DO
    j = kmax
    r(j) = ( - domin(j)*(o2(j)-o2(j-1)) )
    IF(z(j).LT.zrct) THEN
      r(j) = r(j) - 1.3*rate*orgml(j)/pore(j)
    ELSEIF(z(j-1).LT.zrct) THEN
      r(j) = r(j) - 1.3*rate*orgml(j) * (zrct-z(j-1))/delz(j)
    ENDIF
    rmserr = rmserr + r(j)**2

    rmserr = rmserr**(0.5)

  END SUBROUTINE o2ss

! *************************************************************************************************
! *** calc_o2_diff ********************************************************************************
! *************************************************************************************************

  SUBROUTINE calc_o2_diff(difo2,form,pore,dopls,domin)

    REAL,INTENT(inout)::difo2
    REAL,INTENT(inout),DIMENSION(:)::form,pore,dopls,domin

    INTEGER::i

    DO i=3,kmax-1
      dopls(i)=difo2 * ((form(i+1)+form(i))/2) * 1 / pore(i) * 2 / ( (delz(i+1)+delz(i)) * delz(i) )
      domin(i)=difo2 * ((form(i-1)+form(i))/2) * 1/pore(i) * 2 / ( (delz(i-1)+delz(i)) * delz(i) )
    END DO

    i=kmax
    dopls(i)=0.
    domin(i)=difo2 * ((form(i-1)+form(i))/2) * 1/pore(i) * 2 / ( (delz(i-1)+delz(i)) * delz(i) )

    i=2
    dopls(i)=difo2 * ((form(i+1)+form(i))/2) * 1/pore(i) * 2 / ( (delz(i+1)+delz(i)) * delz(i) )
    domin(i)=difo2 * (form(i)+1)/2 * 1/pore(i) * 1/delz(i)**2

  END SUBROUTINE calc_o2_diff

! *************************************************************************************************
! *** co3ss ***************************************************************************************
! *************************************************************************************************

  SUBROUTINE co3ss(resp_c,dissc,dissn,csat,u1,u2,difc,form, &
    & pore,calgg,carb,ttrorg,ttrcal,ttral,ttrtc,diftc,difal)

    REAL,INTENT(inout)::dissc,dissn
    REAL,INTENT(in)::csat
    REAL,INTENT(in)::u1,u2
    REAL,INTENT(inout)::ttrorg,ttrcal,ttral,ttrtc,diftc,difal
    REAL,INTENT(inout),DIMENSION(:)::difc
    REAL,INTENT(inout),DIMENSION(:)::form,pore
    REAL,INTENT(in),DIMENSION(:)::calgg
    REAL,INTENT(inout),DIMENSION(:,:)::resp_c,carb

    INTEGER::k,l
    REAL,DIMENSION(nzmax)::cal_c
    REAL,DIMENSION(nzmax,3)::dcpls
    REAL,DIMENSION(nzmax,3)::dcmin

    CALL calcdc(difc,form,pore,dcpls,dcmin)

    DO k=2, kmax
      carb(k,1) = carb(1,1)
      carb(k,2) = carb(1,2)
      carb(k,3) = csat - 15e-6
    END DO
    carb(2,3) = ( 2 * carb(1,3) + csat ) / 3
    carb(3,3) = ( carb(1,3) + 2 * csat ) / 3

    DO l=1,20
      CALL calc_co3(resp_c,dissc,dissn,csat,u1,u2,dcpls,dcmin, &
        & pore,calgg,carb,cal_c)
      CALL diag(ttral,difal,ttrtc,diftc,ttrcal,ttrorg,resp_c,cal_c,carb, &
        & pore,dcmin(2,1),dcmin(2,2),dcmin(2,3))
      IF((diftc.NE.0).AND.(difal.NE.0)) THEN
        IF(( ABS(1 - ABS(ttrtc / diftc)) .LT. 0.03 ) .AND. ( ABS(1 - ABS(ttral / difal)) .LT. 0.03 )) EXIT
      ENDIF
    END DO

  END SUBROUTINE co3ss

! *************************************************************************************************
! *** calc_co3 ************************************************************************************
! *************************************************************************************************

! routine calc_co3, which calculates a single iteration
! of the carbonate system chemistry.  must be run
! several times because of the non-linearity of
! calcite dissolution kinetics.

  SUBROUTINE calc_co3(resp_c,dissc,dissn,csat,disoc1,disoc2,dplus,dminus, &
       & pore,calgg,carb,cal_c)

    REAL,INTENT(inout)::dissc,dissn
    REAL,INTENT(in)::csat
    REAL,INTENT(in)::disoc1,disoc2
    REAL,INTENT(inout),DIMENSION(:)::pore
    REAL,INTENT(in),DIMENSION(:)::calgg
    REAL,INTENT(inout),DIMENSION(:)::cal_c
    REAL,INTENT(inout),DIMENSION(:,:)::resp_c,dplus,dminus,carb

    ! note:'nzmax_co3' must be at least 3 times higher than for other routines

    INTEGER::i,k,l,m,p,o
    REAL::weight,trialw,rmstc,rmsal,rmsph
    REAL,DIMENSION(nzmax_co3,3)::r
    REAL,DIMENSION(3,3,3,nzmax_co3)::dr
    REAL,DIMENSION(nzmax_co3,nzmax_co3)::a
    REAL,DIMENSION(nzmax_co3,1)::b

    DO i=1,3
       carb(kmax+1, i) = carb(kmax, i)
       ! for the bottom boundary condition, no flux
    END DO

    ! the residual terms: array (depth; tc, alk, ph)

    DO k = 2, kmax
       ! total co2 equation
       r(k,1) = 0.
       DO i=1,3
          r(k,1) = r(k,1) + (dplus(k,i) * (carb(k+1,i)-carb(k,i)) - dminus(k,i) * (carb(k,i)-carb(k-1,i)))
          ! units of moles / l *porewater* sec
       END DO
       r(k,1) = r(k,1) + resp_c(k,1) / pore(k) + resp_c(k,2) / pore(k) + resp_c(k,3) / pore(k)
       ! units of moles / l *porewater* sec
       IF(carb(k,3).LT.csat) THEN
          r(k,1) = r(k,1) + dissc*((1-(carb(k,3)/csat))**dissn)*(1-pore(k)) / pore(k)*calgg(k)*(2.5*1000)/(100)
       ENDIF

       ! alkalinity equation
       r(k,2) = dplus(k,3) * (carb(k+1,3)-carb(k,3)) &
            & - dminus(k,3) * (carb(k,3)-carb(k-1,3)) &
            & + 0.5 * dplus(k,2) * (carb(k+1,2)-carb(k,2)) &
            & - 0.5 * dminus(k,2) * (carb(k,2)-carb(k-1,2))
       r(k,2) = r(k,2) + resp_c(k,3) / pore(k) + 0.5 * resp_c(k,2) / pore(k)
       IF(carb(k,3).LT.csat) THEN
          r(k,2) = r(k,2) + dissc*((1-(carb(k,3)/csat))**dissn)*(1-pore(k)) / pore(k)*calgg(k)*(2.5*1000)/(100)
       ENDIF
       r(k,3) = carb(k,1) * carb(k,3) / carb(k,2)**2 - disoc2 / disoc1
    END DO

    ! the derivitive terms: array (function, variable,
    ! 'k+'= 3 to 'k-' = 1, and depth level k)
    DO k=2,kmax-1
       dr(1,1,3,k) = dplus(k,1)
       dr(1,1,2,k) = -dplus(k,1) -dminus(k,1)
       dr(1,1,1,k) = dminus(k,1)

       dr(1,2,3,k) = dplus(k,2)
       dr(1,2,2,k) = -dplus(k,2) -dminus(k,2)
       dr(1,2,1,k) = dminus(k,2)

       dr(1,3,3,k) = dplus(k,3)
       dr(1,3,2,k) = -dplus(k,3) -dminus(k,3)
       IF(carb(k,3).LT.csat) THEN
          dr(1,3,2,k) = dr(1,3,2,k) &
               &                    - dissc * dissn &
               &                      * (1-pore(k)) / pore(k)&
               &                      * calgg(k)&
               &                      * (2.5*1000)/100&
               &                      / csat&
               &                 *((1-(carb(k,3)/csat))**(dissn-1.))
       ENDIF
       dr(1,3,1,k) = dminus(k,3)

       dr(2,1,3,k) = 0.
       dr(2,1,2,k) = 0.
       dr(2,1,1,k) = 0.

       dr(2,2,3,k) = (0.5) * dplus(k,2)
       dr(2,2,2,k) = -(0.5) * dplus(k,2) -(0.5) * dminus(k,2)
       dr(2,2,1,k) = (0.5) * dminus(k,2)

       dr(2,3,3,k) = dplus(k,3)
       dr(2,3,2,k) = -dplus(k,3) -dminus(k,3)
       IF(carb(k,3).LT.csat) THEN
          dr(2,3,2,k) = dr(2,3,2,k) &
               &                    - dissc * dissn &
               &                      * (1-pore(k)) / pore(k) &
               &                      * calgg(k) &
               &                      * (2.5*1000)/100 &
               &                      / csat &
               &                 *((1-(carb(k,3)/csat))**(dissn-1.))
       ENDIF
       dr(2,3,1,k) = dminus(k,3)

       dr(3,1,3,k) = 0.
       dr(3,1,2,k) = carb(k,3) / carb(k,2)**2
       dr(3,1,1,k) = 0.

       dr(3,2,3,k) = 0.
       dr(3,2,2,k) = -(0.5) * carb(k,1) * carb(k,3) / carb(k,2)**3
       dr(3,2,1,k) = 0.

       dr(3,3,3,k) = 0.
       dr(3,3,2,k) = carb(k,1) / carb(k,2)**2
       dr(3,3,1,k) = 0.

    END DO

    ! bottom special conditions
    DO l=1,3
       ! function
       DO i=1,3
          ! variable
          DO m=1,3
             ! above, below
             dr(l,i,m,kmax) = dr(l,i,m,kmax-1)
          END DO
       END DO
    END DO

    ! load the big array
    DO k=1,3*kmax-1
       DO l=1,3*kmax-1
          a(k,l)=0.
       END DO
    END DO
    DO k=2,kmax
       ! depth level
       DO l=1,3
          ! function
          DO m=1,3
             ! up, down
             DO i=1,3
                ! variable
                ! row number
                o = (k-2)*3 + l
                ! column number
                p = (m+k-4)*3 + i
                ! originally, "extras" were put in column 0, out of the way
                ! however, there is no column '0', so they are simply ignored in this version
                IF(p.GT.0) THEN
                   a(o,p) = dr(l,i,m,k)
                   IF(k.EQ.kmax) THEN
                      IF(m.EQ.2) a(o,p) = a(o,p)+dr(l,i,m+1,k)
                   ENDIF
                ENDIF
             END DO
          END DO
       END DO
    END DO

    ! load the residual array
    DO k=2,kmax
       DO l=1,3
          b( (k-2)*3+l, 1) = - r(k,l)
       END DO
    END DO

    CALL gaussj(a,(kmax-1)*3,b,1)

    weight = 1.0
    DO k=2,kmax
       trialw = - 0.75 * carb(k,3) / b( (k-2)*3+3, 1 )
       IF((trialw.GT.0.).AND.(trialw .LT.weight)) weight = trialw
    END DO
    DO k=2,kmax
       DO i=1,3
          carb(k,i) = carb(k,i) + weight * b( (k-2)*3+i, 1)
          ! ENSURE NO NEGATIVE [CO32-] SHIT GOES DOWN
          if (carb(k,i) < -const_real_nullsmall) then
             carb(k,i) = 1.0e-6
             error_Archer = .TRUE.
          end if
       END DO
    END DO

    ! the error terms, after the iteration
    DO k=2,kmax-1
       r(k,1) = 0.
       DO i=1,3
          r(k,1) = r(k,1) + dplus(k,i) * (carb(k+1,i)-carb(k,i)) - dminus(k,i) * (carb(k,i)-carb(k-1,i))
       END DO
       r(k,1) = r(k,1) + resp_c(k,1) / pore(k) + resp_c(k,2) / pore(k) + resp_c(k,3) / pore(k)
       IF(carb(k,3).LT.csat) THEN
          r(k,1) = r(k,1) + dissc*((1-(carb(k,3)/csat))**dissn)*(1-pore(k))*calgg(k)*(2.5*1000)/(100)
       ENDIF
       r(k,2) = dplus(k,3) * (carb(k+1,3)-carb(k,3)) &
            &           - dminus(k,3) * (carb(k,3)-carb(k-1,3)) &
            &     + (0.5) * dplus(k,2) * (carb(k+1,2)-carb(k,2)) &
            &     - (0.5) * dminus(k,2) * (carb(k,2)-carb(k-1,2))
       r(k,2) = r(k,2) + 0.5 * resp_c(k,2) / pore(k) + resp_c(k,3) / pore(k)
       IF(carb(k,3).LT.csat) THEN
          r(k,2) = r(k,2) + dissc*((1-(carb(k,3)/csat))**dissn)*(1-pore(k))*calgg(k)*(2.5*1000)/(100)
       ENDIF
       r(k,3) = carb(k,1) * carb(k,3) / carb(k,2)**2 - disoc2 / disoc1
    END DO

    rmstc = 0.
    rmsal = 0.
    rmsph = 0.
    DO k=2,kmax-1
       rmstc = rmstc + r(k,1)**2
       rmsal = rmsal + r(k,2)**2
       rmsph = rmsph + r(k,3)**2
    END DO
    rmstc = rmstc**(0.5)
    rmsal = rmsal**(0.5)
    rmsph = rmsph**(0.5)

    DO k = 1, kmax
       IF(carb(k,3).LT.csat) THEN
          cal_c(k) = dissc*((1-(carb(k,3)/csat))**dissn)*(1-pore(k))*calgg(k)*(2.5*1000)/(100)
       ELSE
          cal_c(k) = 0.
       ENDIF
    END DO

  END SUBROUTINE calc_co3

! *************************************************************************************************
! *** calcdc **************************************************************************************
! *************************************************************************************************

  SUBROUTINE calcdc(difc,form,pore,dcpls,dcmin)

    REAL,INTENT(inout),DIMENSION(:)::difc
    REAL,INTENT(inout),DIMENSION(:)::form,pore
    REAL,INTENT(inout),DIMENSION(:,:)::dcpls,dcmin

    INTEGER::i,j

    DO i=3,kmax-1
      DO j=1,3
        dcpls(i,j)=difc(j) &
          & *(delz(i)*form(i+1)+delz(i+1)*form(i)) &
          & / (delz(i)+delz(i+1)) &
          & * 1 / pore(i) &
          & *(2/((delz(i+1)+delz(i))*delz(i)))
        dcmin(i,j)=difc(j) &
          & *(delz(i)*form(i-1)+delz(i-1)*form(i)) &
          & / (delz(i)+delz(i-1)) &
          & * 1 / pore(i) &
          & *(2/((delz(i-1)+delz(i))*delz(i)))
      END DO
    END DO
    DO j=1,3
      i=kmax
      dcpls(i,j)=0
      dcmin(i,j)=difc(j) &
        & *(delz(i)*form(i-1)+delz(i-1)*form(i)) &
        & / (delz(i)+delz(i-1)) &
        & * 1 / pore(i) &
        & *(2/((delz(i-1)+delz(i))*delz(i)))
      i=2
      dcpls(i,j)=difc(j) &
        & *(delz(i)*form(i+1)+delz(i+1)*form(i)) &
        & / (delz(i)+delz(i+1)) &
        & * 1 / pore(i) &
        & *(2/((delz(i+1)+delz(i))*delz(i)))
      dcmin(i,j)=difc(j) &
        & *(form(i)+1)/2 &
        & * 1 / pore(i) &
        & *(1/(delz(i)**2))
    END DO

  END SUBROUTINE calcdc

! *************************************************************************************************
! *** diag ****************************************************************************************
! *************************************************************************************************

! file 'diag.for', which calculates the diffusive fluxes of
! o2, total co2, and alkalinity at the sediment-water
! interface, and also the integrated reaction rates of
! those quantities.  used by co3main to determine when to
! stop repeating the co3 subroutine.

  SUBROUTINE diag(ttral,difal,ttrtc,diftc,ttrcal,ttrorg,resp_c,cal_c,carb, &
    & pore,dcco2,dchco3,dcco3)

    REAL,INTENT(inout)::ttral,difal,ttrtc,diftc,ttrcal,ttrorg,dcco2,dchco3,dcco3
    REAL,INTENT(inout),DIMENSION(:)::cal_c,pore
    REAL,INTENT(inout),DIMENSION(:,:)::carb,resp_c

    INTEGER::j,k
    REAL,DIMENSION(3)::ttreac,difflx

! zero the diagnostics variables, ttreac and flux
    DO j=1,3
      ttreac(j) = 0.
      difflx(j) = 0.
    END DO
    ttrcal = 0.
    ttrorg = 0.

! reaction rates are in units of mol species/cm2 (total) y
    DO k = 1, kmax
      ttreac(1) = ttreac(1) + resp_c(k,1) * delz(k) * 3.15E7 / 1e3
      ttreac(2) = ttreac(2) + resp_c(k,2) * delz(k) * 3.15E7 / 1e3
      ttreac(3) = ttreac(3) + resp_c(k,3) * delz(k) * 3.15E7 / 1e3 + cal_c(k) * delz(k) * 3.15E7 / 1e3
      ttrcal = ttrcal + cal_c(k) * delz(k) * 3.15E7 / 1e3
      ttrorg = ttrorg + ( resp_c(k,1) + resp_c(k,2) + resp_c(k,3)) * delz(k) * 3.15e7 / 1e3
    END DO

! the diffusive fluxes
    difflx(1) =   dcco2 * ( carb(1,1) - carb(2,1) ) * pore(2) * delz(2) * 3.15e7 / 1e3
    difflx(2) =   dchco3 * ( carb(1,2) - carb(2,2) ) * pore(2) * delz(2) * 3.15e7 / 1e3
    difflx(3) =   dcco3 * ( carb(1,3) - carb(2,3) ) * pore(2) * delz(2) * 3.15e7 / 1e3

    ttrtc = ttreac(1) + ttreac(3)
    ttral = ttreac(3) * 2
    diftc = difflx(1) + difflx(2) + difflx(3)
    difal = difflx(2) + difflx(3) * 2.

  END SUBROUTINE diag

! *************************************************************************************************
! *** gaussj **************************************************************************************
! *************************************************************************************************

  SUBROUTINE gaussj(a,n,b,m)

    INTEGER,INTENT(in)::n,m
    REAL,INTENT(inout),DIMENSION(:,:)::a
    REAL,INTENT(inout),DIMENSION(:,:)::b

    INTEGER::i,j,k,l,ll,irow,icol
    INTEGER,DIMENSION(nmax)::indxr,indxc
    REAL::big,dum,pivinv
    REAL,DIMENSION(nmax)::ipiv

! numerical recipes, pages 28-29
    irow = 0
    icol = 0

    DO j=1,n
      ipiv(j)=0
    END DO
    DO i=1,n
      big=0.
      DO j=1,n
        IF(ipiv(j).NE.1) THEN
          DO k=1,n
            IF(ipiv(k).EQ.0) THEN
              IF(ABS(a(j,k)).ge.big) THEN
                big=ABS(a(j,k))
                irow=j
                icol=k
              ENDIF
            ELSE IF(ipiv(k).GT.1) THEN
              ipiv(k) = 1.0
              error_Archer = .TRUE.
            ENDIF
          END DO
        ENDIF
      END DO
      ipiv(icol)=ipiv(icol)+1
      IF(irow.NE.icol) THEN
        DO l=1,n
          dum=a(irow,l)
          a(irow,l)=a(icol,l)
          a(icol,l)=dum
        END DO
        DO l=1,m
          dum=b(irow,l)
          b(irow,l)=b(icol,l)
          b(icol,l)=dum
        END DO
      ENDIF
      indxr(i)=irow
      indxc(i)=icol
      IF(a(icol,icol).EQ.0.) then
         a(icol,icol) = 1.0
         error_Archer = .TRUE.
      end IF
      pivinv=1./a(icol,icol)
      a(icol,icol)=1.
      DO l=1,n
        a(icol,l)=a(icol,l)*pivinv
      END DO
      DO l=1,m
        b(icol,l)=b(icol,l)*pivinv
      END DO
      DO ll=1,n
        IF(ll.NE.icol) THEN
          dum=a(ll,icol)
          a(ll,icol)=0.
          DO l=1,n
            a(ll,l)=a(ll,l)-a(icol,l)*dum
          END DO
          DO l=1,m
            b(ll,l)=b(ll,l)-b(icol,l)*dum
          END DO
        ENDIF
      END DO
    END DO
    DO l=n,1,-1
      IF(indxr(l).NE.indxc(l)) THEN
        DO k=1,n
          dum=a(k,indxr(l))
          a(k,indxr(l))=a(k,indxc(l))
          a(k,indxc(l))=dum
        END DO
      ENDIF
    END DO

  END SUBROUTINE gaussj

! *************************************************************************************************
! *** CALC_DB *************************************************************************************
! *************************************************************************************************

  SUBROUTINE CALC_DB(db,dbpls,dbmin,z,pore,MLD)

    REAL,INTENT(in)::mld
    REAL,INTENT(in)::db
    REAL,INTENT(inout),DIMENSION(:)::dbpls,dbmin,z,pore

    INTEGER::I

    Z(KMAX+1) = MLD +1

    DO I=2, kmax
      IF(I.EQ.2) THEN
        DBPLS(I) = DB * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) * ( 1-PORE(I)+1-PORE(I+1) )/( 1-PORE(I) )
        DBMIN(I) = 0.
      ELSE IF(Z(I).LE.MLD) THEN
        DBPLS(I) = DB * 2 / ( (DELZ(I) + DELZ(I+1)) * DELZ(I) ) * ( 1-PORE(I)+1-PORE(I+1) )/( 1-PORE(I) )
        DBMIN(I) = DB * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) * ( 1-PORE(I)+1-PORE(I-1) )/( 1-PORE(I) )
      ELSE IF(Z(I-1).LE.MLD) THEN
        DBPLS(I) = 0.
        DBMIN(I) = DB * 2 / ( (DELZ(I) + DELZ(I-1)) * DELZ(I) ) * ( 1-PORE(I)+1-PORE(I-1) )/( 1-PORE(I) )
      ELSE
        DBPLS(I) = 0.
        DBMIN(I) = 0.
      END IF
    END DO
    DBPLS(kmax) = 0.

  END SUBROUTINE CALC_DB

! *************************************************************************************************
! *** pore_2_form *********************************************************************************
! *************************************************************************************************

  SUBROUTINE pore_2_form(pore,form,expb)

    REAL,INTENT(inout)::expb
    REAL,INTENT(inout),dimension(:)::pore,form

    INTEGER::k

    DO k = 1, kmax
      form(k) = pore(k)**expb
    END DO

  END SUBROUTINE pore_2_form

! *************************************************************************************************
! *** sldcon **************************************************************************************
! *************************************************************************************************

  SUBROUTINE sldcon(temp_ml,temp_gg,molwt,pore)

    REAL,INTENT(in)::molwt
    REAL,INTENT(inout),dimension(:)::temp_ml,temp_gg,pore

    INTEGER::k

! update the solid concentration accounts
    DO k=2,kmax
      temp_ml(k) = temp_gg(k)*2.5*(1-pore(k))*1000/molwt
    END DO

  END SUBROUTINE sldcon

! *************************************************************************************************
! *** sldfrc **************************************************************************************
! *************************************************************************************************

  SUBROUTINE sldfrc(temp_ml,temp_gg,molwt,pore)

    REAL,INTENT(inout)::molwt
    REAL,INTENT(inout),dimension(:)::temp_ml,temp_gg,pore

    INTEGER::i

! Update the solid wt. pct. accounts
    DO i=2,kmax
      temp_gg(i) = temp_ml(i)*molwt/(2.5*(1-pore(i))*1000)
    END DO

  END SUBROUTINE sldfrc

  ! ********************************************************************************************************************************
  ! SET UP POROSITY PROFILE
  ! NOTE: sub-surface porosity is calculated from the MASS fraction of CaCO3,
  !       whereas the sediment core model works on a VOLUME fraction basis (the difference is relatively small)
  SUBROUTINE set_pore(calgg,z,pore)
    IMPLICIT NONE
    ! dummy arguments
    REAL,INTENT(in)::calgg
    REAL,INTENT(inout),DIMENSION(:)::z,pore
    ! local variables
    INTEGER::k
    REAL::pore_max,exp_pore

    ! *** calculate local constants
    ! Zeebe and Zachos [2007] sub-surface porosity constant
    pore_max = fun_calc_sed_poros(calgg)
    ! Archer [1996] porosity scale depth
    exp_pore = 0.25*calgg + 3. *(1-calgg)

    ! *** calculate porosity profile
    pore(1) = 0.
    DO k = 2, kmax
       ! Archer porosity profile
       pore(k) = EXP(-z(k)/exp_pore) * (1.-pore_max) + pore_max
    ENDDO

  END SUBROUTINE set_pore
  ! ********************************************************************************************************************************

END MODULE sedgem_box_archer1991_sedflx


      subroutine Carte_to_UVWH(VX,VY,VZ,U,V,W)
C *******************************************************************
C CHANGES FROM (VX,VY,VZ) CARTESIAN GALACTOCENTRIC VELOCITY VECTOR TO
C (U,V,W) HELIOCENTRIC VELOCITY VECTOR
c units: km/s
C********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

C ROTATION OF VX,VY OF ANGLE 0. TO PUT X-AXIS ALIGNED WITH SUN-GC
C LINE
      ANGLE=0.!PI/2.D0
      CALL rot_horari(angle,VX,VY,VX2,VY2)
      VZ2=VZ
C SUBSTRACT THE DIFFERENTIAL ROTATION OF THE SUN
      CALL dV2(R0,0.d0,W)
      U2=VX2
      V2=VY2-W*R0
      W2=VZ2
C SUBSTRACT THE MOTION OF THE SUN WITH RESPECT TO THE LSR
      U=U2-USOL
      V=V2-VSOL
      W=W2-WSOL
      RETURN
      END

C  --------------------------------------------------------------------
c     SUBROUTINE carte_to_equatorial(X,Y,Z,ALPHA,DELTA)
c     Input cartesian coordinates: (X,Y,Z) in kpc
c     Output: equatorial coordinates: (alpha,delta) in radiants
c
c---------------------------------------------------------------------
      SUBROUTINE carte_to_equatorial(X,Y,Z,ALPHA,DELTA)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

c XYZ, centered on the Sun
       sX=X+R0
       sY=Y!-R0
       sZ=Z

c R,l,b heliocentric
       gr=dsqrt(sx*sx+sy*sy+sz*sz)
       gb=asin(sz/gr)
cc x>0, y<0:
c	if ((sx.gt.0).and.(sy.lt.0)) then
c       gl=atan(dabs(sx/sy))
c       endif
cc x>0, y>0:
c	if ((sx.gt.0).and.(sy.gt.0)) then
c       gl=atan(dabs(sy/sx))+pi/2.d0
c       endif
cc x<0, y>0:
c	if ((sx.lt.0).and.(sy.gt.0)) then
c       gl=atan(dabs(sx/sy))+pi
c       endif
cc x<0, y<0:
c	if ((sx.lt.0).and.(sy.lt.0)) then
c       gl=atan(dabs(sy/sx))+3*pi/2
c       endif
       call carte_to_galactic(X,Y,Z,gl,gb)
C alpha, delta heliocentric
       cb=Dcos(gb)
       sb=Dsin(gb)
       cl=Dcos(gl)
       sl=Dsin(gl)

       sd=cb*Dsin(gl-a2)*Dsin(a1)+
     +     sb*Dcos(a1)
       Delta=Dasin(sd)

       yk=cb*Dsin(gl-a2)*Dcos(a1)-
     .     sb*Dsin(a1)
       xk=cb*Dcos(gl-a2)
       Alpha=mod(Datan2(yk,xk) +Ag,2.d0*pi)
       RETURN
       END

C  --------------------------------------------------------------------
c     SUBROUTINE carte_to_galactic(X,Y,Z,l,b)
c     Input cartesian coordinates: (X,Y,Z) in kpc
c     Output: galactic coordinates: (l,b) in radiants
c     -Pi<l<Pi; -Pi/2<b<Pi/2
c     checked!! :)
c---------------------------------------------------------------------
      SUBROUTINE carte_to_galactic(X,Y,Z,gl,gb)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

	tol=1.d-3

c XYZ, centered on the Sun
       sX=X+R0
       sY=Y!-R0
       sZ=Z

c R,l,b heliocentric
       gr=dsqrt(sx*sx+sy*sy+sz*sz)
       gb=dasin(sz/gr)
c        write(*,*)sz,gr,gb/deg
c x>0, y<0:
	if ((sx.ge.0.d0).and.(sy.lt.0.d0)) then
       gl=2.d0*pi-datan(dabs(sy/sx))
	if (sx.lt.tol) gl=3.d0*pi/2.d0
       endif
c x>0, y=>0:
	if ((sx.ge.0.d0).and.(sy.ge.0.d0)) then
       gl=datan(dabs(sy/sx))!+pi/2.d0
	if (sx.lt.tol) gl=pi/2.d0
       endif
c x<0, y=>0:
	if ((sx.lt.0.d0).and.(sy.ge.0.d0)) then
       gl=pi-datan(dabs(sy/sx))
	if (sx.gt.-1.d0*tol) gl=pi/2.d0
       endif
c x<0, y<0:
	if ((sx.lt.0.d0).and.(sy.lt.0.d0)) then
       gl=pi+datan(dabs(sy/sx))
	if (sx.gt.-1.d0*tol) gl=3.d0*pi/2.d0
       endif

c sx=0, y=0
	if((dabs(sx).le.tol).and.(dabs(sy).le.tol)) then
	gl=0.d0
	end if
c       write(28,*)sx,sy,gl/deg,gb
       RETURN
       END

      SUBROUTINE UVWH_TO_equatorials(U,V,W,A)
C*************************************************************************
C USING TRIGONOMETRIC MATRIX COMPUTE (VR,MUA,MUD) FROM (U,V,W)HELIOCENTRIC
c input velocities in km/s, parallax, xpi, in mas, angles in radiants
C a(1)=alpha
C a(2)=delta    the first three are input variables
C a(3)=xpi
C a(4)=mua*cos(delta)
C a(5)=mud      the last three are output variables
C a(6)=Vr
c output proper motions in mas/yr and radial velocity in km/s
C*************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION A(6)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

      call get_fi(a(1),a(2),fi)
      SFI=DSIN(FI)
      CFI=DCOS(FI)
      call equ_to_gal(a(1),a(2),gl,gb)
C APPLY TRANSFORMATION MATRIX TO (U,V,W)INPUT
      cb=Dcos(gb)
      sb=Dsin(gb)
      cl=Dcos(gl)
      sl=Dsin(gl)

      B11=CL*CB
      B12=CL*SB*SFI-SL*CFI
      B13=-(CL*SB*CFI+SL*SFI)
      B21=SL*CB
      B22=SL*SB*SFI+CL*CFI
      B23=-(SL*SB*CFI-CL*SFI)
      B31=SB
      B32=-CB*SFI
      B33=CB*CFI

      a(6)=B11*U+B21*V+B31*W
      a(4)=B12*U+B22*V+B32*W
      a(5)=B13*U+B23*V+B33*W
      gr=1.d3/a(3)
C CORRECT UNITS
      a(4)=a(4)*1.d3/(kt*gr)
      a(5)=a(5)*1.d3/(kt*gr)

      RETURN
      END

      SUBROUTINE equatorials_TO_UVWH(A,U,V,W)
C*************************************************************************
C USING TROGONOMETRIC MATRIX COMPUTE (U,V,W)HELIOCENTRIC FROM (VR,MUA,MUD)
c input observed variables in equatorial coordinates
C a(1)=alfa
C a(2)=delta
C a(3)=xpi
C a(4)=mua*cos(delta)
C a(5)=mud
C a(6)=Vr
c output (U,V,W) heliocentric
c units: angles in radians, proper motions in mas/yr, Vr and U,V,W in km/s
C*************************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      dimension A(6)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

C COMPUTE PARALLACTIC ANGLE FI
      call get_fi(a(1),a(2),fi)
      SFI=DSIN(FI)
      CFI=DCOS(FI)
      call equ_to_gal(a(1),a(2),gl,gb)
C APPLY TRANSFORMATION MATRIX TO (MUA,MUD,VR) INPUT
      cb=Dcos(gb)
      sb=Dsin(gb)
      cl=Dcos(gl)
      sl=Dsin(gl)

      B11=CL*CB
      B12=CL*SB*SFI-SL*CFI
      B13=-(CL*SB*CFI+SL*SFI)
      B21=SL*CB
      B22=SL*SB*SFI+CL*CFI
      B23=-(SL*SB*CFI-CL*SFI)
      B31=SB
      B32=-CB*SFI
      B33=CB*CFI

C CORRECT FOR UNITS
      gr=1.d3/a(3)
      XMUAA=A(4)*1.d-3*GR*KT
      XMUDD=A(5)*1.d-3*GR*KT

      U=A(6)*B11+XMUAA*B12+XMUDD*B13
      V=A(6)*B21+XMUAA*B22+XMUDD*B23
      W=A(6)*B31+XMUAA*B32+XMUDD*B33
      RETURN
      END

      SUBROUTINE UVWH_TO_CARTE(UH,VH,WH,VX,VY,VZ)
C********************************************************************
C COMPUTES (VX,VY,VZ) FROM (U,V,W) HELIOCENTRIC
C********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

C ADD THE DIFFERENTIAL ROTATION OF THE SUN
      CALL dV2(R0,0.d0,W)
      U1=UH
      V1=VH+W*R0
      W1=WH
C ADD THE MOTION OF THE SUN WITH RESPECT TO THE LSR
      U2=U1+USOL
      V2=V1+VSOL
      W2=W1+WSOL
C ROTATE 0 DEG TO OBTAIN CARTESIAN COORD
      ANGLE=0.!PI/2.D0
      CALL ROT_ANTIHORARI(ANGLE,U2,V2,VX,VY)
      VZ=W2
      RETURN
      END

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

c subroutine equatorial_to_galactic(alfa,delta,gl,gb)
c input: equatorial coordinates (alfa,delta)
c output: galactic coordinates (xl,xb)
c Units: all angles l,b,alpha,delta in radians
c -pi<l<pi
c -------------------------------------------------------------

      subroutine equ_to_gal(alfa,delta,gl,gb)
      implicit real*8(a-h,o-z)
      real*8 lq,lpl
      include 'const_math.h'
      include 'const_ast.h'
      INCLUDE 'const_pot.h'

      T6=60.d0
      T36=3600.d0
      RD=PI/180.d0
      LQ=122.92851d0*RD
      ALFAG=(12.d0+51.d0/T6+26.2755d0/T36)*15.d0*RD
      DECG=(27.d0+7.d0/T6+41.704d0/T36)*RD
      SDG=dSIN(DECG)
      CDG=dCOS(DECG)

      sd=dsin(delta)
      cd=dcos(delta)

      sb=sdg*sd+cdg*cd*dcos(alfa-alfag)
      cb=sqrt(1.d0-sb**2.d0)
      gb=datan2(sb,cb)
      slpl=(cd*dsin(alfa-alfag))/cb
      clpl=(cdg*sd-sdg*cd*dcos(alfa-alfag))/cb
      lpl=datan2(slpl,clpl)
      if(lpl.le.0.d0)lpl=lpl+2.d0*pi
      gl=lq-lpl

      return
      end
*****************************************************
c input: equatorial coordinates (alfa,delta)
c output: galactic coordinates (l,b)

c Units: all angles l,b,alpha,delta in radians
c 0<l<2pi
************************************************
      subroutine lb_cal(al,de,l,b)

      implicit NONE
      real*8 pi, e,fa,fl, e2,fa2,fl2, e1,fa1,fl1,
     .        Equinox,l,b, al,de, w
      parameter ( pi = 3.1415926535897931159979634D+00 )
      parameter ( e = 62.8717d0 /180.d0*pi )
      parameter ( fa = 282.8596d0 /180.d0*pi )
      parameter ( fl = 32.93192d0 /180.d0*pi )

         l = datan2(dcos(de)*dsin(al-fa)*dcos(e)+dsin(de)*dsin(e),
     .              dcos(de)*dcos(al-fa)) + fl
         l = l  - 2*pi*int(l/(2*pi))
         if (l .lt. 0.d0)  l = l + 2*pi
         b = dasin(dsin(de)*dcos(e)-dcos(de)*dsin(al-fa)*dsin(e))

      return
      end

C  --------------------------------------------------------------------
c     SUBROUTINE equatorial_to_carte(gr,ALPHA,DELTA,x,y,z)
c     Input: equatorial coordinates: (alpha,delta) in radians
c     Input: gr:heliocentric distance in kpc.
c     Output cartesian coordinates: (X,Y,Z)
c
c---------------------------------------------------------------------
      SUBROUTINE equatorial_to_carte(gr,ALPHA,DELTA,x,y,z)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

      call equ_to_gal(alpha,delta,gl,gb)
      cl=dcos(gl)
      sl=dsin(gl)
      cb=dcos(gb)
      sb=dsin(gb)
c
      x1=gr*cb*cl
      y1=gr*cb*sl
      z=gr*sb

c      call rot_antihorari(PI/2,x1,y1,x2,y2)

c to galactocentric
      x=x1-R0
      y=y1!+R0

      RETURN
      END

c********************************************************************
c********************************************************************
C AUXILIARY SUBROUTINES
C--------------------------------------------------------------------

c-------------------------------------------------------------------
c     subroutine dV2(R,zeta,w)
c
c     give(R,z) in cylindrical coordinates, it returns the rotation
c     frequency w at that position.
c     it uses the axisymmetric potential give by Allen & Santillan (1991)
c------------------------------------------------------------------------

      SUBROUTINE dV2(R,zeta,w)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'const_math.h'
      INCLUDE 'const_ast.h'
      INCLUDE 'const_pot.h'

      zz=zeta**2.d0
      RR=R**2.d0

      q1=(zz+bdbd)**(1.d0/2.d0)
      q5=(ad+q1)**2.d0

c BULGE
      Psi1=rKMb/(RR+zz+abuabu)**(3.d0/2.d0)
      dVBdR=Psi1*R

c DISK
      Psi2=rKMd/(RR+q5)**(3.d0/2.d0)
      dVDdR=Psi2*R

c HALO
      XG=((RR+zz)**(1.d0/2.d0)/ah)**1.02d0
      Psi3=rKMh/ah*1.d0/(RR+zz)*XG/(XG+1.d0)
      dVHdR=Psi3*R

c ALL COMPONENTS
      dVdR=dVBdR+dVDdR+dVHdR

      w=dsqrt(1.d0/R*dabs(dVdR))

      RETURN
      END

c----------------------------------------------------------------
c     SUBROUTINE rot_positive(angle,X,Y,X2,Y2)
c
c     it performs a clockwise rotation of angle "angle"
c     input: rotation angle in radians
c            (x,y)
c     output: rotated coordinates (x2,y2)
c----------------------------------------------------------------
      SUBROUTINE rot_positive(angle,X,Y,X2,Y2)
      IMPLICIT REAL*8 (A-H,O-Z)

      s=dsin(angle)
      c=dcos(angle)

      X2=X*c+Y*s
      Y2=-X*s+Y*c

      RETURN
      end

c----------------------------------------------------------------
c     SUBROUTINE rot_antihorari(angle,X,Y,X2,Y2)
c     transposed transformation matrix between two ref. frames.(?)
c     it performs a counter-clockwise rotation of angle "angle"
c     input: rotation angle in radians
c            (x,y)
c     output: rotated coordinates (x2,y2)
c----------------------------------------------------------------
      SUBROUTINE rot_antihorari(angle,X,Y,X2,Y2)
      IMPLICIT REAL*8 (A-H,O-Z)

      s=dsin(angle)
      c=dcos(angle)

      X2=X*c+Y*s
      Y2=-X*s+Y*c

      RETURN
      end

c----------------------------------------------------------------
c     SUBROUTINE rot_horari(angle,X,Y,X2,Y2)
c     transformation matrix between two ref. frames.(?)
c     it performs a clockwise rotation of angle "angle"
c     input: rotation angle in radians
c            (x,y)
c     output: rotated coordinates (x2,y2)
c----------------------------------------------------------------
      SUBROUTINE rot_horari(angle,X,Y,X2,Y2)
c rotacion en sentido horario de un angulo de "angle"
      IMPLICIT REAL*8 (A-H,O-Z)

      s=dsin(angle)
      c=dcos(angle)

      X2=X*c-Y*s
      Y2=X*s+Y*c

      RETURN
      end

c-------------------------------------------------------------------
      subroutine Carte_to_UVW(X,Y,Z,VX,VY,VZ,U,V,W)
C *******************************************************************
C CHANGES FROM (VX,VY,VZ) CARTESIAN GALACTOCENTRIC VELOCITY VECTOR TO
C (U,V,W) VELOCITY VECTOR WITH U POINTING TOWARDS TO GC, V TOWARDS
C GALACTIC ROTATION AND W PERPENDICULAR TO THE GALACTIC PLANE
C WE NEED (X,Y,Z) TO COMPUTE THE POSITION ANGLE THETA.
c
c Not used in the main code, but useful.
C********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)

      PI=4.D0*DATAN(1.D0)

C POSITION ANGLE
      THETA=DATAN2(X,Y)
C ROTATION OF VX,VY OF ANGLE 270-THETA COUNTERCLOCKWISE
c      ANGLE=3.D0*PI/2.D0-THETA
c      CALL rot_antihorari(angle,VX,VY,VX2,VY2)
      ANGLE=PI/2.D0+THETA
      CALL rot_horari(angle,VX,VY,VX2,VY2)
C SUBSTRACT THE DIFFERENTIAL ROTATION OF THE STAR
      R=DSQRT(X*X+Y*Y)
      CALL dV2(R,Z,W)
      U=VX2
      V=VY2  ! -W*R
      W=VZ
      RETURN
      END

c----------------------------------------------------------
	subroutine gal_mu(dist,gl,gb,UH,VH,WH,xmub,xmuls,vr)
c***********************************************************
c Calculate the galactic proper motions using
cheliocentric distance and heliocentric V,U,W and l and b.
c Inputs: UH,VH,WH(km/s), gl, gb(radians), heliocentric distance(dist) in Kpc
c outputs: xMub=mu_b, xMuls= Mu_l*cosb in arcsec/yr
c***********************************************************
	IMPLICIT REAL*8(A-H,O-Z)
        INCLUDE 'const_math.h'
	INCLUDE 'const_ast.h'

	coef=1.d0/(kt*dist*1000.d0)

	xmub=coef*(-dsin(gb)*dcos(gl)*UH-dsin(gb)*dsin(gl)*VH
     &          +dcos(gb)*WH)
	xmuls=coef*(-dsin(gl)*UH+dcos(gl)*VH)
        vr=dcos(gb)*dcos(gl)*UH+dcos(gb)*dsin(gl)*VH+dsin(gb)
     &        *WH
	return
	end

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

c     subroutine get_fi
c input: (alfa,delta) in radians
c output: fi parallactic angle in radians

C  --------------------------------------------------------------------
      subroutine get_fi(alfa,delta,fi)
      implicit real*8(a-h,o-z)
      include 'const_math.h'
      include 'const_ast.h'

      x=Dcos(Dg)*Dsin(Delta)*Dsin(Alfa-Ag)+Dsin(Dg)*Dcos(Delta)
      y=Dcos(Dg)*Dcos(Alfa-Ag)
c Parallactic angle
      Fi=Datan2(y,x)
      return
      end

c******************************************************************
c subrutine pmeq_to_pmgal
c From J. Bovy's GalPy
      subroutine pmeq_to_pmgal(pmra,pmdec,ra,dec,pml,pmb)
      implicit real*8(a-h,o-z)
      include 'const_math.h'
      include 'const_ast.h'

c Bovy's constants
c      theta=122.932*pi/180.
c      dec_ngp=27.12825*pi/180.
c      ra_ngp=192.85948*pi/180.
c Merce's constants
      T6=60.d0
      T36=3600.d0
      RD=PI/180.d0
      theta=122.92851d0*pi/180.
      ra_ngp=(12.d0+51.d0/T6+26.2755d0/T36)*15.d0*RD
      dec_ngp=(27.d0+7.d0/T6+41.704d0/T36)*RD

      if(dec.eq.dec_ngp)dec=dec+1.e-16

      sindec_ngp= dsin(dec_ngp)
      cosdec_ngp= dcos(dec_ngp)
      sindec= dsin(dec)
      cosdec= dcos(dec)
      sinrarangp= dsin(ra-ra_ngp)
      cosrarangp= dcos(ra-ra_ngp)

      cosphi= sindec_ngp*cosdec-cosdec_ngp*sindec*cosrarangp
      sinphi= sinrarangp*cosdec_ngp
      xnorm= sqrt(cosphi**2.d0+sinphi**2.d0)
      cosphi= cosphi/xnorm
      sinphi= sinphi/xnorm

      pml= pmra*cosphi + pmdec*sinphi
      pmb=-pmra*sinphi + pmdec*cosphi

      return
      end


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc Single-prec version Barnett 4/5/17
cc
************************************************************************
      subroutine dirft3d1f(nj,xj,yj,zj,cj,iflag,ms,mt,mu,fk)
      implicit none
      integer nj, iflag, ms, mt, mu
      real*4 xj(nj), yj(nj), zj(nj)
      complex*8 cj(nj),fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2,-mu/2:(mu-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c                      nj
c     fk(k1,k2,k3) =  SUM cj(j) exp(+/-i k1 xj(j)) *
c                     j=1       exp(+/-i k2 yj(j)) *
c                                 exp(+/-i k3 zj(j))
c
c     for -ms/2 <= k1 <= (ms-1)/2,
c         -mt/2 <= k2 <= (mt-1)/2
c         -mu/2 <= k3 <= (mu-1)/2
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
************************************************************************
      integer j, k1, k2, k3
      complex*8 zf, cm1, cm2, z1n(-ms/2:(ms-1)/2), z2n(-mt/2:(mt-1)/2)
c
      do k3 = -mu/2, (mu-1)/2
         do k2 = -mt/2, (mt-1)/2
            do k1 = -ms/2, (ms-1)/2
               fk(k1,k2,k3) = cmplx(0d0,0d0)
            enddo
         enddo
      enddo
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
c
         if (iflag .ge. 0) then
            zf = cmplx(cos(xj(j)),+sin(xj(j)))
         else
            zf = cmplx(cos(xj(j)),-sin(xj(j)))
         endif
         z1n(0) = (1d0,0d0)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= conjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = conjg(zf*z1n(ms/2-1))
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k2 yj)
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = cmplx(cos(yj(j)),+sin(yj(j)))
         else
            zf = cmplx(cos(yj(j)),-sin(yj(j)))
         endif
         z2n(0) = (1d0,0d0)
         do k1 = 1, (mt-1)/2
            z2n(k1) = zf*z2n(k1-1)
            z2n(-k1)= conjg(z2n(k1))
         enddo
         if (mt/2*2.eq.mt) z2n(-mt/2) = conjg(zf*z2n(mt/2-1))
c
c     ----------------------------------------------------------
c     Loop over k3 for zj
c     ----------------------------------------------------------
c
         if (iflag .ge. 0) then
            zf = cmplx(cos(zj(j)),+sin(zj(j)))
         else
            zf = cmplx(cos(zj(j)),-sin(zj(j)))
         endif
c
         cm2 = cj(j)
         do k3 = 0, (mu-1)/2
            do k2 = -mt/2, (mt-1)/2
               cm1 = cm2 * z2n(k2)
               do k1 = -ms/2, (ms-1)/2
                  fk(k1,k2,k3) = fk(k1,k2,k3) + cm1*z1n(k1)
               enddo
            enddo
            cm2 = zf*cm2
         enddo
c
         zf = conjg(zf)
         cm2 = cj(j)
         do k3 = -1, -mu/2, -1
            cm2 = zf*cm2
            do k2 = -mt/2, (mt-1)/2
               cm1 = cm2 * z2n(k2)
               do k1 = -ms/2, (ms-1)/2
                  fk(k1,k2,k3) = fk(k1,k2,k3) + cm1*z1n(k1)
               enddo
            enddo
         enddo

      enddo
      end
c
c
c
c
c
************************************************************************
      subroutine dirft3d2f(nj,xj,yj,zj,cj, iflag, ms,mt,mu,fk)
      implicit none
      integer nj, iflag, ms, mt, mu
      real*4 xj(nj), yj(nj), zj(nj)
      complex*8 cj(nj),fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2,-mu/2:(mu-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c
c     cj(j) = SUM SUM SUM  fk(k1,k2,k3) exp(+/-i k1 xj(j)) *
c             k1  k2  k3                exp(+/-i k2 yj(j))
c                                       exp(+/-i k3 zj(j))
c
c                            for j = 1,...,nj
c
c     where -ms/2 <= k1 <= (ms-1)/2
c           -mt/2 <= k2 <= (mt-1)/2
c           -mu/2 <= k3 <= (mu-1)/2
c
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
************************************************************************
      integer j, k1, k2, k3
      complex*8 zf, cm1,cm2,cm3,z1n(-ms/2:(ms-1)/2),z2n(-mt/2:(mt-1)/2)
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = cmplx(cos(xj(j)),+sin(xj(j)))
         else
            zf = cmplx(cos(xj(j)),-sin(xj(j)))
         endif
         z1n(0) = (1d0,0d0)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= conjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = conjg(zf*z1n(ms/2-1))
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k2 yj)
c     ----------------------------------------------------------
c
         if (iflag .ge. 0) then
            zf = cmplx(cos(yj(j)),+sin(yj(j)))
         else
            zf = cmplx(cos(yj(j)),-sin(yj(j)))
         endif
         z2n(0) = (1d0,0d0)
         do k2 = 1, (mt-1)/2
            z2n(k2) = zf*z2n(k2-1)
            z2n(-k2)= conjg(z2n(k2))
         enddo
         if (mt/2*2.eq.mt) z2n(-mt/2) = conjg(zf*z2n(mt/2-1))
c
c     ----------------------------------------------------------
c     Loop over k3 for zj
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = cmplx(cos(zj(j)),+sin(zj(j)))
         else
            zf = cmplx(cos(zj(j)),-sin(zj(j)))
         endif
c
         cm2 = (0d0, 0d0)
         do k2 = -mt/2, (mt-1)/2
            cm1 = (0d0, 0d0)
            do k1 = -ms/2, (ms-1)/2
               cm1 = cm1 + z1n(k1) * fk(k1,k2,0)
            enddo
            cm2 = cm2 + z2n(k2) * cm1
         enddo
         cj(j) = cm2
c
         cm3 = zf
         do k3 = 1, (mu-1)/2
            cm2 = (0d0, 0d0)
            do k2 = -mt/2, (mt-1)/2
               cm1 = (0d0, 0d0)
               do k1 = -ms/2, (ms-1)/2
                 cm1 = cm1 + z1n(k1) * fk(k1,k2,k3)
               enddo
               cm2 = cm2 + z2n(k2) * cm1
            enddo
            cj(j) = cj(j) + cm3 * cm2

            cm2 = (0d0, 0d0)
            do k2 = -mt/2, (mt-1)/2
               cm1 = (0d0, 0d0)
               do k1 = -ms/2, (ms-1)/2
                 cm1 = cm1 + z1n(k1) * fk(k1,k2,-k3)
               enddo
               cm2 = cm2 + z2n(k2) * cm1
            enddo
            cj(j) = cj(j) + conjg(cm3) * cm2
            cm3 = cm3*zf
         enddo
c
         if (mu/2*2.eq.mu) then
            cm2 = (0d0, 0d0)
            do k2 = -mt/2, (mt-1)/2
               cm1 = (0d0, 0d0)
               do k1 = -ms/2, (ms-1)/2
                 cm1 = cm1 + z1n(k1) * fk(k1,k2,-mu/2)
               enddo
               cm2 = cm2 + z2n(k2) * cm1
            enddo
            cj(j) = cj(j) + conjg(cm3) * cm2
         endif
      enddo
      end
c
c
c
c
c
************************************************************************
      subroutine dirft3d3f(nj,xj,yj,zj,cj, iflag, nk,sk,tk,uk,fk)
      implicit none
      integer nj, iflag, nk
      real*4 xj(nj), yj(nj), zj(nj), sk(nk), tk(nk), uk(nk)
      complex*8 cj(nj), fk(nk)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c              nj
c     fk(k) = SUM cj(j) exp(+/-i s(k) xj(j)) *
c             j=1       exp(+/-i t(k) yj(j)) *
c                       exp(+/-i u(k) zj(j))
c
c                    for k = 1, ..., nk
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
************************************************************************
      integer k, j
      real*4 ssk, stk, suk
c
      do k = 1, nk
         if (iflag .ge. 0) then
            ssk =  sk(k)
            stk =  tk(k)
            suk =  uk(k)
         else
            ssk =  -sk(k)
            stk =  -tk(k)
            suk =  -uk(k)
         endif
c
         fk(k) = cmplx(0d0,0d0)
         do j = 1, nj
            fk(k) = fk(k) + cj(j) * cmplx
     &        ( cos(ssk*xj(j)+stk*yj(j)+suk*zj(j)),
     &          sin(ssk*xj(j)+stk*yj(j)+suk*zj(j)) )
         enddo
      enddo
      end


program example_sine
  use mod_kinds, only: ik, rk
  use mod_network, only: network_type
  implicit none
  type(network_type) :: net
  real(rk) :: cumloss, x, y
  real(rk), parameter :: pi = 4 * atan(1._rk)
  integer(ik) :: i
  net = network_type([1, 5, 1])
  cumloss = 0
  do i = 1, 1000000
    call random_number(x)
    y = (sin(x * 2 * pi) + 1) * 0.5
    call net % train([x], [y], eta=10._rk)
    cumloss = cumloss + net % loss([x], [y])
    print *, i, cumloss / i
  end do
end program example_sine


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief check changes between vectors [new] and [old]
!>    @param[in] mode switch absolute/relative
!>    @param[out] rms return value
!>    @param[out] difmax maximal difference
!>    @param[in] ni I-dimension for vectors [new], [old]
!>    @param[in] nj J-dimension for vectors [new], [old]
!>    @param[in] nk K-dimension for vectors [new], [old]
!>    @param[in] new vector with new values
!>    @param[in] old vector with old values
!>    @param[in] pv_idx index number (physical value), only needed for AD code generation/modification
!>    @param[out] loc_nltol tolerance criteria, only needed for AD code generation/modification
!>    @param[in] ismpl local sample index
!>    @details
!> Computes two difference metrics between the physical variable array
!> of this iteration (new) and the one from the previous iteration
!> (old): \n\n
!>
!> 1. difmax  : max. difference of fields new and old\n
!>    mode= 0 : difmax is absolute maximum difference\n
!>    else    : difmax is relative maximum difference\n\n
!>
!> 2. rms     : root mean square difference of fields new and old
!>    mode= 0 : rms is root mean square of absolute differences\n
!>    else    : rms is root mean square of relative differences\n\n
      SUBROUTINE check_change(mode,pv_idx,loc_nltol,rms,difmax,ni,nj,nk,new,old,ismpl)

        use arrays
        use mod_linfos

        IMPLICIT NONE

        INTEGER i, j, k, ni, nj, nk, ijk, ipt, jpt, kpt, mode, pv_idx, ismpl
        DOUBLE PRECISION new(ni,nj,nk), old(ni,nj,nk)
        ! DOUBLE PRECISION dif
        DOUBLE PRECISION rms, difmax, loc_nltol
        INTEGER idamax
        EXTERNAL idamax
        INTRINSIC dabs, dble, sqrt

        IF (linfos(3)>=2) WRITE(*,*) ' ... check_change'

        ! Initial values for output
        rms = 0.D0
        difmax = 0.D0
        ipt = 0
        jpt = 0
        kpt = 0

        IF (mode==0) THEN
          ! Absolute difference

          ! Number of cells
          ijk = ni*nj*nk

          ! Copy new values to x
          CALL dcopy(ijk,new,1,x(1,1,1,ismpl),1)

          ! Absolute difference array: new - old
          CALL daxpy(ijk,-1.0d0,old,1,x(1,1,1,ismpl),1)

          ! Indices of maximum absolute difference
          i = idamax(ijk,x(1,1,1,ismpl),1)
          CALL ijk_m(i,ipt,jpt,kpt)

          ! Maximum absolute difference
          difmax = x(ipt,jpt,kpt,ismpl)

          ! Sum of squares
          CALL s_ddot(ijk,x(1,1,1,ismpl),x(1,1,1,ismpl),rms)

        ELSE
          ! Relative difference (currently not used)

          ! Number of cells
          ijk = ni*nj*nk

          ! Copy new values to x
          CALL dcopy(ijk,new,1,x(1,1,1,ismpl),1)

          ! Relative difference array (new - old)/old
          CALL daxpy(ijk,-1.0d0,old,1,x(1,1,1,ismpl),1)
          DO k = 1, nk
            DO j = 1, nj
              DO i = 1, ni
                IF (dabs(old(i,j,k))>1.D-200) x(i,j,k,ismpl) = x(i,j,k,ismpl)/old(i,j,k)
              END DO
            END DO
          END DO

          ! Indices of maximum relative difference
          i = idamax(ijk,x(1,1,1,ismpl),1)
          CALL ijk_m(i,ipt,jpt,kpt)

          ! Maximum relative difference
          difmax = x(ipt,jpt,kpt,ismpl)

          ! Sum of squares
          CALL s_ddot(ijk,x(1,1,1,ismpl),x(1,1,1,ismpl),rms)

        END IF

        ! Root-Mean part of the RMSE
        rms = sqrt(rms/dble(ijk))

        ! Standard output
        IF (linfos(3)>=2) WRITE(*,'(A,1e12.5,A,1e12.5,3(A,i5),A)') &
          '   nl iteration rms =', rms, ',  difmax =', difmax, ', [', &
          ipt, ',', jpt, ',', kpt, ']'

        RETURN
      END


      DOUBLE PRECISION FUNCTION COST(V,W)
      COMMON /MSTPRM/ MSGLVL
      COMMON /POINTS/ PHI,CHI,TWOTH,N
      INTEGER N,MSGLVL
      DOUBLE PRECISION PHI(20000),CHI(20000),TWOTH(20000)
      INTEGER V,W
      DOUBLE PRECISION DMIN1,DMAX1,DABS
      DOUBLE PRECISION DISTP,DISTC,DISTT
      DISTP=DMIN1(DABS(PHI(V)-PHI(W)),DABS(DABS(PHI(V)-PHI(W))-360.0E+0)
     $        )
      DISTC=DABS(CHI(V)-CHI(W))
      DISTT=DABS(TWOTH(V)-TWOTH(W))
      COST=DMAX1(DISTP/1.00E+0,DISTC/1.0E+0,DISTT/1.00E+0)
      RETURN
      END


      subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
c
      integer n,nm,ierr,matz
      double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     of a real symmetric matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a.
c
c        a  contains the real symmetric matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        w  contains the eigenvalues in ascending order.
c
c        z  contains the eigenvectors if matz is not zero.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for tqlrat
c           and tql2.  the normal completion code is zero.
c
c        fv1  and  fv2  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  tred1(nm,n,a,w,fv1,fv2)
*  tqlrat encounters catastrophic underflow on the Vax
*     call  tqlrat(n,w,fv2,ierr)
      call  tql1(n,w,fv1,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  tred2(nm,n,a,w,fv1,z)
      call  tql2(nm,n,w,fv1,z,ierr)
   50 return
      end


      SUBROUTINE DMXM(A,N,B,M,C,L)
**
**    C = A * B
**    A ET B MATRICES A(N,M)  B(M,L) ==> C(N,L)
**
*>A      PREMIERE MATRICE
*>N      PREMIERE DIMENSION DE A ET DE C
*>B      DEUXIEME MATRICE
*>M      DEUXIEME DIMENSION DE A ET PERMIERE DE B
*<C      MATRICE PRODUIT DE A ET DE B
*>L      DEUXIEME DIMENSION DE B ET DE C
*A R. SANCHEZ ( EARLY WINTER 1987 )
*V M.F. ROBEAU
*M AM BAUDRON - AVRIL 94
*: ERREUR DANS L'APPEL A L'UTILITAIRE SGEMM
*: APPEL A L'UTILITAIRE SGEMM DE LA LIBRAIRIE BLAS SUR HP
*M AM BAUDRON - NOVEMBRE 1991
*: ERREUR ( SOMME SUR LES TERMES PAS FAITE )
*: APPEL A L'UTILITAIRE SGEMM DE LA LIBRAIRIE BLAS SUR RISC
*M AM BAUDRON - MAI 1993
*: CHANGEMENT DES %IF LOCAL SUN MIPS SUITE A INTRODUCTION VERSION IBM
      REAL*8 A(N,M),B(M,L),C(N,L),R
      DO 20 I=1,N
      DO 20 J=1,L
         R=0.
         DO 10 K=1,M
            R=R+A(I,K)*B(K,J)
   10    CONTINUE
         C(I,J)=R
   20 CONTINUE
      RETURN
      END


      double complex function A41qqppmp(e1,p2,p3,e4,za,zb,zab,zba)
C-----Authors: John Campbell and Keith Ellis, November 2011
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'zabprods_decl.f'
      double complex A1lcqqppmp,A1slcqqppmp,
     & A1fqqppmp,A1Hqqppmp
      integer e1,p2,p3,e4,e1p,e4p
      double precision nlf,nhf
      parameter(nlf=5d0,nhf=1d0)

c--- perform the swaps 5 <-> 7 and 6 <-> 8
      e1p=12-e1
      e4p=14-e4

c--- changed the sign of the term
c----   -2d0*Ncinv**2*A1lcqqppmp(e1p,p3,p2,e4p,zb,za,zba,zab)
c--- although the sign appears to be the same as written in Eq. (11) of
c---  arXiv:1101.5947, because of complex conjugation we would have
c---  expected the fourth term in this expression to have the opposite sign
      A41qqppmp=
     & (1d0-2d0*Ncinv**2)*A1lcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)
     & -A1fqqppmp(e1,p2,p3,e4,za,zb,zab,zba)*nlf/xn
     & -A1Hqqppmp(e1,p2,p3,e4,za,zb,zab,zba)*nhf/xn
     & -2d0*Ncinv**2*A1lcqqppmp(e1p,p3,p2,e4p,zb,za,zba,zab)
     & -Ncinv**2*A1slcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)

      return
      end


      subroutine small_strain_anisotropic_elasticity(matData,F,stre,cc)

      implicit none

      integer          i,
     *                 ptyp, nFib, round

      double precision matData(*), F(3,*), stre(*), cc(6,*),
     *                 a, b, c, d, e, m1, m2, m3, M(6), eps(6),
     *                 E1, E2, nu12, nu23, G12, fact,
     *                 r1d2, r1, r4

      data r1d2, r1, r4 / 0.5d0, 1.d0, 4.d0 /

c     strain tensor

      eps(1) = F(1,1) - r1
      eps(2) = F(2,2) - r1
      eps(3) = F(3,3) - r1
      eps(4) = r1d2 * (F(1,2) + F(2,1))
      eps(5) = r1d2 * (F(2,3) + F(3,2))
      eps(6) = r1d2 * (F(3,1) + F(1,3))

c     tangent tensor

      ptyp   = round(matData(1))

      if (ptyp.eq.1) then

        a    = matData(2)
        b    = matData(3)
        nFib = round(matData(4))

        call ccIsotropicPart(cc,a,b)

        do i=1, nFib

          c  = matData( 5+(i-1)*6)
          d  = matData( 6+(i-1)*6)
          e  = matData( 7+(i-1)*6)
          m1 = matData( 8+(i-1)*6)
          m2 = matData( 9+(i-1)*6)
          m3 = matData(10+(i-1)*6)

          fact = 1.d0 / (m1*m1 + m2*m2 + m3*m3)

          M(1) = m1 * m1 * fact
          M(2) = m2 * m2 * fact
          M(3) = m3 * m3 * fact
          M(4) = m1 * m2 * fact
          M(5) = m2 * m3 * fact
          M(6) = m3 * m1 * fact

          call ccFibrePart(cc,c,d,e,M)

        enddo

      else if (ptyp.eq.2) then

        E1   = matData(2)
        E2   = matData(3)
        nu12 = matData(4)
        nu23 = matData(5)
        G12  = matData(6)
        m1   = matData(7)
        m2   = matData(8)
        m3   = matData(9)

        fact = r1 / ((E1+E1) * nu12 * nu12 + E2 * (nu23-r1))

        a    = - E2 * (E1 * nu12 * nu12 + E2 * nu23) / (r1+nu23) * fact
        b    = E2 / (r1 + nu23)
        c    = E2 * (E1*nu12*(nu12-nu23-r1)+E2*nu23) / (r1+nu23) * fact
        d    = E1-r4*G12-r1d2*fact*(E2-(E1+E1)*nu12)*(E2-(E1+E1)*nu12)
        e    = G12+G12 - b

        call prgError(2,"small_strain_anisotropic_elasticity",
     *                  "ptyp = 2 has not yet been implemented!")

        fact = 1.d0 / (m1*m1 + m2*m2 + m3*m3)

        M(1) = m1 * m1 * fact
        M(2) = m2 * m2 * fact
        M(3) = m3 * m3 * fact
        M(4) = m1 * m2 * fact
        M(5) = m2 * m3 * fact
        M(6) = m3 * m1 * fact

        call ccIsotropicPart(cc,a,b)

        call ccFibrePart(cc,c,d,e,M)

      else

        call prgError(1,"small_strain_anisotropic_elasticity",
     *                     "invalid ptyp!")

      endif

c     stress

      call mult_s_4s_p(stre,cc,eps)

      return

      end

      subroutine ccIsotropicPart(cc,a,b)
      implicit none
      double precision cc(6,*), a, b, fact, r0

      r0 = 0.d0

      fact = b * .5d0

      cc(1,1) = a + b
      cc(1,2) = a
      cc(1,3) = a
      cc(1,4) = r0
      cc(1,5) = r0
      cc(1,6) = r0
      cc(2,1) = a
      cc(2,2) = a + b
      cc(2,3) = a
      cc(2,4) = r0
      cc(2,5) = r0
      cc(2,6) = r0
      cc(3,1) = a
      cc(3,2) = a
      cc(3,3) = a + b
      cc(3,4) = r0
      cc(3,5) = r0
      cc(3,6) = r0
      cc(4,1) = r0
      cc(4,2) = r0
      cc(4,3) = r0
      cc(4,4) = fact
      cc(4,5) = r0
      cc(4,6) = r0
      cc(5,1) = r0
      cc(5,2) = r0
      cc(5,3) = r0
      cc(5,4) = r0
      cc(5,5) = fact
      cc(5,6) = r0
      cc(6,1) = r0
      cc(6,2) = r0
      cc(6,3) = r0
      cc(6,4) = r0
      cc(6,5) = r0
      cc(6,6) = fact

      return

      end

      subroutine ccFibrePart(cc,c,d,e,M)
      implicit none
      double precision cc(6,*), c, d, e, M(*), ee

      ee = 0.5d0 * e

      cc(1,1) = cc(1,1)+ c *(M(1)+M(1)) + d *M(1)*M(1) + e  *(M(1)+M(1))
      cc(1,2) = cc(1,2)+ c *(M(2)+M(1)) + d *M(1)*M(2)
      cc(1,3) = cc(1,3)+ c *(M(3)+M(1)) + d *M(1)*M(3)
      cc(1,4) = cc(1,4)+ c * M(4)       + d *M(1)*M(4) + e  * M(4)
      cc(1,5) = cc(1,5)+ c * M(5)       + d *M(1)*M(5)
      cc(1,6) = cc(1,6)+ c * M(6)       + d *M(1)*M(6) + e  * M(6)
      cc(2,1) = cc(2,1)+ c *(M(1)+M(2)) + d *M(2)*M(1)
      cc(2,2) = cc(2,2)+ c *(M(2)+M(2)) + d *M(2)*M(2) + e  *(M(2)+M(2))
      cc(2,3) = cc(2,3)+ c *(M(3)+M(2)) + d *M(2)*M(3)
      cc(2,4) = cc(2,4)+ c * M(4)       + d *M(2)*M(4) + e  * M(4)
      cc(2,5) = cc(2,5)+ c * M(5)       + d *M(2)*M(5) + e  * M(5)
      cc(2,6) = cc(2,6)+ c * M(6)       + d *M(2)*M(6)
      cc(3,1) = cc(3,1)+ c *(M(1)+M(3)) + d *M(3)*M(1)
      cc(3,2) = cc(3,2)+ c *(M(2)+M(3)) + d *M(3)*M(2)
      cc(3,3) = cc(3,3)+ c *(M(3)+M(3)) + d *M(3)*M(3) + e  *(M(3)+M(3))
      cc(3,4) = cc(3,4)+ c * M(4)       + d *M(3)*M(4)
      cc(3,5) = cc(3,5)+ c * M(5)       + d *M(3)*M(5) + e  * M(5)
      cc(3,6) = cc(3,6)+ c * M(6)       + d *M(3)*M(6) + e  * M(6)
      cc(4,1) = cc(4,1)+ c *      M(4)  + d *M(4)*M(1) + e  * M(4)
      cc(4,2) = cc(4,2)+ c *      M(4)  + d *M(4)*M(2) + e  * M(4)
      cc(4,3) = cc(4,3)+ c *      M(4)  + d *M(4)*M(3)
      cc(4,4) = cc(4,4)                 + d *M(4)*M(4) + ee *(M(1)+M(2))
      cc(4,5) = cc(4,5)                 + d *M(4)*M(5) + ee * M(6)
      cc(4,6) = cc(4,6)                 + d *M(4)*M(6) + ee * M(5)
      cc(5,1) = cc(5,1)+ c *      M(5)  + d *M(5)*M(1)
      cc(5,2) = cc(5,2)+ c *      M(5)  + d *M(5)*M(2) + e  * M(5)
      cc(5,3) = cc(5,3)+ c *      M(5)  + d *M(5)*M(3) + e  * M(5)
      cc(5,4) = cc(5,4)                 + d *M(5)*M(4) + ee * M(6)
      cc(5,5) = cc(5,5)                 + d *M(5)*M(5) + ee *(M(2)+M(3))
      cc(5,6) = cc(5,6)                 + d *M(5)*M(6) + ee * M(4)
      cc(6,1) = cc(6,1)+ c *      M(6)  + d *M(6)*M(1) + e  * M(6)
      cc(6,2) = cc(6,2)+ c *      M(6)  + d *M(6)*M(2)
      cc(6,3) = cc(6,3)+ c *      M(6)  + d *M(6)*M(3) + e  * M(6)
      cc(6,4) = cc(6,4)                 + d *M(6)*M(4) + ee * M(5)
      cc(6,5) = cc(6,5)                 + d *M(6)*M(5) + ee * M(4)
      cc(6,6) = cc(6,6)                 + d *M(6)*M(6) + ee *(M(3)+M(1))

      return

      end


  module fluid_model_toy
! toy fluid model used for Roman's code comparison tests

  use phys_constants, only: c2, pi, mp

  implicit none

  real(kind=8) :: toy_l0, toy_n0, toy_h
  integer :: toy_which

  interface toy_vals
    module procedure toy_vals
  end interface

  interface init_toy
     module procedure init_toy
  end interface

  interface del_toy
     module procedure del_toy
  end interface

  contains

    subroutine init_toy(n0,h,l0,which)
! assign inputs, which is which problem we are doing
      real(kind=8), intent(in) :: n0,h,l0
      integer, intent(in) :: which
      toy_n0 = n0
      toy_h = h
      toy_l0 = l0
      toy_which = which
      write(6,*) 'init_toy: ',toy_n0,toy_h,toy_l0,toy_which
    end subroutine init_toy

! code comparison paper equations 1 and 2
    subroutine toy_vals(a,mu,r,n,l)
      real(kind=8), intent(in) :: a
      real(kind=8), dimension(:), intent(in) :: r,mu
      real(kind=8), dimension(size(r)), intent(out) :: n,l
      real(kind=8), dimension(size(r)) :: rcyl,z,dist
      real(kind=8) :: q
      q=0.5
      rcyl = r*sqrt(1.-mu**2.)
      l=toy_l0/(1.+rcyl)*rcyl**(1.+q)
      z=toy_h*mu
!      l=0.; z=0.
      dist=((r/10.)**2.+z**2.)
      where(dist.lt.20.)
         n=toy_n0*exp(-dist/2.)
      elsewhere
         n=0.
      endwhere
!      toy_omega = 1./(toy_r**(3./2.)+toy_a)
     end subroutine toy_vals

     subroutine del_toy
       !nothing so far
     end subroutine del_toy

  end module fluid_model_toy