!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!                  Calculating the Peak Likelihood of the ZDCF
!
!        A special version for processing the ZDCF output file *.dcf
!
!          Version 4.0 (Fortran 95 double precision, 25/1/2013)
!
!    (Bayesian prior assumption of uniform distribution in z-space)
!
!
!                               Tal Alexander
!
!   Reference to the PLIKE algorithm:
!
!   T. Alexander, 2013, 'Improved AGN light curve analysis with the
!   z-transformed discrete correlation function', arXiv:1302.1508,
!   astro-ph.IM
!
!   Reference to the ZDCF algorithm:
!
!   T. Alexander, 1997, 'Is AGN variability correlated with other AGN
!   properties? - ZDCF analysis of small samples of sparse light curves',
!   in "Astronomical Time Series", eds. D. Maoz, A. Sternberg and
!   E.M. Leibowitz, Kluwer, Dordrecht, p. 163
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! SAMPLE RUN (user input marked by "<-USER". See explanations below)
! ----------
!
!PLIKE V4.0 begins.
!Enter dcf file name:
!test.dcf   <-USER
!Enter lower bound on peak location:
!-200       <-USER
!Enter upper bound on peak location:
!+200       <-USER
!
!Calculating ML in range t_lag = -2.000E+02 to  2.000E+02
!
!ZDCF peak at  +1.333E-01 r_max =  +8.811E-01 ZDCF C.O.M. at  -4.311E+00
!
!Progress meter: .......
!
!Results:
!
!# PLIKE V4.0 ZDCF peak likelihood analysis
!# for file test.dcf
!#
!# num      lag         r         -dr        +dr    likelihood
!# ---- ---------- ---------- ---------- ---------- ----------
!     1 -7.677E+01  3.552E-01  3.141E-01  2.753E-01  2.701E-03
!     2 -1.979E+01  7.796E-01  1.210E-01  9.680E-02  1.106E-01
!     3  1.333E-01  8.811E-01  8.032E-02  6.053E-02  4.577E-01
!     4  5.618E+00  8.211E-01  1.237E-01  9.322E-02  2.054E-01
!     5  2.410E+01  3.915E-01  3.061E-01  2.648E-01  3.669E-03
!     6  8.748E+01 -1.617E-01  3.189E-01  3.389E-01  2.365E-05
!     7  1.999E+02 -4.352E-01  2.513E-01  2.950E-01  7.652E-07
!#
!# ML Peak at t_lag =  +1.333E-01, Likelihood at peak =  +4.577E-01
!# 1 sigma ML t_lag interval =  +1.333E-01  +1.004E+01  -2.372E+01
!#                           = ( -2.359E+01 ,  +1.017E+01)
!
!Output written on plike.out.
!Program ended.
!
! EXPLANATION
! -----------
!
! o The program uses the *.dcf output file of the ZDCF.
!
! o The user has to give lower and upper bounds on the peak location.
!
! o The output is printed to the terminal and (over-)written on the
!   file plike.out. It consists of the likelihood function and the
!   fiducial interval, given both as t_peak + dt_up - dt_low, and as
!   the interval (t_min, t_max).
!
! FORTRAN ISSUES
! --------------
!
! o To compile:
!   gfortran -O3 -o plike plike_v4.0.f90
!
!   (no-convergence issues with the ifort 13.0 compiler have been
!    reported).
!
! o The program can be VERY slow - don't panic!
!
! o This program incorporates the functions QROMO, POLINT and MIDPNT
!   from Numerical Recipes / Press, Flannery, Teukolsky & Vetterling.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
MODULE cons
  IMPLICIT NONE
  ! Defining double precision
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15, 60)
  REAL(dp), PARAMETER :: Pi = 4*ATAN(1.0_dp)
END MODULE cons
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE quad77
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! NUMERICAL RECIPES "SIMPLE" QUADRATURE ROUTINES CONVERTED FROM FORTRAN77
  ! to REAL(dp) FORTRAN90
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE polint(xa,ya,n,x,y,dy)
    USE cons
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: xa(n),ya(n),x
    INTEGER, INTENT(in) :: n
    REAL(dp), INTENT(out) :: y,dy
    !
    INTEGER, PARAMETER :: NMAX=10
    INTEGER :: i,m,ns
    REAL(dp) :: den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
    !
    ns=1
    dif=ABS(x-xa(1))
    DO i=1,n
       dift=ABS(x-xa(i))
       IF (dift < dif) THEN
          ns=i
          dif=dift
       END IF
       c(i)=ya(i)
       d(i)=ya(i)
    END DO
    y=ya(ns)
    ns=ns-1
    DO m=1,n-1
       DO i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          IF (den == 0.) THEN
             WRITE (*,*) 'failure in polint'
             STOP
          END IF
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
       END DO
       IF (2*ns < n-m)THEN
          dy=c(ns+1)
       ELSE
          dy=d(ns)
          ns=ns-1
       END IF
       y=y+dy
    END DO
  END SUBROUTINE polint
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE trapzd(func,a,b,s,n)
    USE cons
    IMPLICIT NONE
    INTEGER, INTENT(in) :: n
    REAL(dp), INTENT(in) :: a, b
    REAL(dp), INTENT(inout) :: s
    INTERFACE
       FUNCTION func(x)
         USE cons
         IMPLICIT NONE
         REAL(dp), INTENT(in) :: x
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    !
    INTEGER :: it,j
    REAL(dp) :: del,sum,tnm,x
    !
    IF (n == 1) THEN
       s=0.5_dp*(b-a)*(func(a)+func(b))
    ELSE
       it=2**(n-2)
       tnm=it
       del=(b-a)/tnm
       x=a+0.5_dp*del
       sum=0.0_dp
       DO j=1,it
          sum=sum+func(x)
          x=x+del
       END DO
       s=0.5_dp*(s+(b-a)*sum/tnm)
    END IF
  END SUBROUTINE trapzd
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE qromb(func,a,b,ss)
    !
    ! USES polint,trapzd
    !
    USE cons
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: a,b
    REAL(dp), INTENT(out) :: ss

    INTERFACE
       FUNCTION func(x)
         USE cons
         IMPLICIT NONE
         REAL(dp), INTENT(in) :: x
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    REAL(dp), PARAMETER :: EPS=1.e-6
    INTEGER, PARAMETER :: JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1
    INTEGER :: j
    REAL(dp) :: dss,h(JMAXP),s(JMAXP)
    !
    h(1)=1.0_dp
    DO j=1,JMAX
       CALL trapzd(func,a,b,s(j),j)
       IF (j >= K) THEN
          CALL polint(h(j-KM),s(j-KM),K,0.0_dp,ss,dss)
          IF (ABS(dss) <= EPS*ABS(ss)) RETURN
       END IF
       s(j+1)=s(j)
       h(j+1)=0.25_dp*h(j)
    END DO
    WRITE (*,*) 'QROMB: too many steps'
    STOP
  END SUBROUTINE qromb
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE qromo(func,a,b,ss,choose)
    USE cons
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: a,b
    REAL(dp), INTENT(out) :: ss
    INTERFACE
       FUNCTION func(x)
         USE cons
         IMPLICIT NONE
         REAL(dp), INTENT(in) :: x
         REAL(dp) :: func
       END FUNCTION func
       SUBROUTINE choose(funk,aa,bb,s,n)
         USE cons
         IMPLICIT NONE
         REAL(dp), INTENT(IN) :: aa,bb
         REAL(dp), INTENT(INOUT) :: s
         INTEGER, INTENT(IN) :: n
         INTERFACE
            FUNCTION funk(x)
              USE cons
              IMPLICIT NONE
              REAL(dp), INTENT(IN) :: x
              REAL(dp) :: funk
            END FUNCTION funk
         END INTERFACE
       END SUBROUTINE choose
    END INTERFACE
    !
    REAL(dp), PARAMETER :: EPS=1.0d-6
    INTEGER, PARAMETER :: JMAX=14, JMAXP=JMAX+1, K=5, KM=K-1
    !dbg: INTEGER, PARAMETER :: JMAX=50, JMAXP=JMAX+1, K=5, KM=K-1
    INTEGER :: j
    REAL(dp) ::  dss,h(JMAXP),s(JMAXP)
    !
    h(1)=1.0_dp
    DO j=1,JMAX
       CALL choose(func,a,b,s(j),j)
       IF (j >= K) THEN
          CALL polint(h(j-KM),s(j-KM),K,0.0_dp,ss,dss)
          IF (ABS(dss) <= EPS*ABS(ss)) RETURN
       END IF
       s(j+1)=s(j)
       h(j+1)=h(j)/9.0_dp
    END DO
    WRITE (*,*) 'QROMO: too many steps'
    STOP
  END SUBROUTINE qromo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE midpnt(func,a,b,s,n)
    USE cons
    IMPLICIT NONE
    REAL(dp), INTENT(IN) :: a,b
    REAL(dp), INTENT(INOUT) :: s
    INTEGER, INTENT(IN) :: n
    INTERFACE
       FUNCTION func(x)
         USE cons, ONLY: dp
         IMPLICIT NONE
         REAL(dp), INTENT(IN) :: x
         REAL(dp) :: func
       END FUNCTION func
    END INTERFACE
    !
    INTEGER :: it,j
    REAL(dp) :: ddel,del,sum,tnm,x
    !
    IF (n == 1) THEN
       s=(b-a)*func(0.5_dp*(a+b))
    ELSE
       it=3**(n-2)
       tnm=it
       del=(b-a)/(3.0_dp*tnm)
       ddel=del+del
       x=a+0.5_dp*del
       sum=0.0_dp
       DO j=1,it
          sum=sum+func(x)
          x=x+ddel
          sum=sum+func(x)
          x=x+del
       END DO
       s=(s+(b-a)*sum/tnm)/3.0_dp
    END IF
  END SUBROUTINE midpnt
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE quad77
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Variables for calculating the likelihood
MODULE like_vars
  USE cons
  IMPLICIT NONE
  INTEGER :: np ! Number of points
  ! time and correlation coefficient data
  REAL(dp), ALLOCATABLE :: t(:),dtm(:),dtp(:)
  REAL(dp), ALLOCATABLE :: r(:),drm(:),drp(:)
  ! z-transformed data and number in bin
  REAL(dp), ALLOCATABLE :: z(:)
  INTEGER, ALLOCATABLE :: n(:)
  ! the likelihood vector
  REAL(dp), ALLOCATABLE :: liklhd(:)
  ! Auxiliary integration variables
  INTEGER :: i0  ! The index of the ZDCF point for which the
                 ! likelihood is to be calculated (see LIKINT)
  INTEGER :: n0  ! Bin number (see PHIZ1)
  REAL(dp) :: z0 ! z value (see PHIZ1)
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE allocate_vars(np)
    IMPLICIT NONE
    INTEGER, INTENT(in) :: np
    INTEGER :: ierr
    !
    ALLOCATE (t(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate t(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (dtm(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate dtm(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (dtp(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate dtp(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (r(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate r(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (drm(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate drm(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (drp(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate drp(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (z(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate z(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (n(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate n(',np,') Error ',ierr
       STOP
    END IF
    ALLOCATE (liklhd(np),stat=ierr)
    IF (ierr /= 0) THEN
       WRITE (*,*) 'Cannot allocate liklhd(',np,') Error ',ierr
       STOP
    END IF
  END SUBROUTINE allocate_vars
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE deallocate_vars()
    IMPLICIT NONE
    DEALLOCATE (t)
    DEALLOCATE (dtm)
    DEALLOCATE (dtp)
    DEALLOCATE (r)
    DEALLOCATE (drm)
    DEALLOCATE (drp)
    DEALLOCATE (z)
    DEALLOCATE (n)
    DEALLOCATE (liklhd)
  END SUBROUTINE deallocate_vars
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE like_vars
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Functions  for calculating the likelihood
MODULE like_funcs
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Calculate quantities associated with the Fisher transform
  SUBROUTINE calc_Fisher(r,n,zbar,sz,dzdr)
    USE cons
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: r
    INTEGER, INTENT(in) :: n
    REAL(dp), INTENT(out) :: zbar,sz,dzdr
    !
    zbar = LOG((1+r)/(1-r))/2. + r/2/(n-1) &
         & *(1+(5+r**2)/4/(n-1)+(11+2*r**2+3*r**4) &
         & /8/(n-1)**2)
    sz = SQRT(1.0_dp/(n-1) &
         & *(1+(4-r**2)/2/(n-1)+(22-6*r**2-3*r**4) &
         & /6/(n-1)**2))
    dzdr = 1.0_dp/(1+r)/(1-r)
  END SUBROUTINE calc_Fisher
!///////////////////////////////////////////////////////////////////////
! The integrand of the cumulative likelihood function
! exp(-(z(r)-zbar(rho))/sz(rho))**2/2)/sqrt(2Pi)/sz(rho)
  FUNCTION PHIZ1(Rho)
    USE cons
    USE like_vars
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: Rho
    REAL(dp) :: PHIZ1
    !
    REAL(dp) :: dzdr,zbar,sz
    ! sqrpi2 = 1/sqrt(2*Pi)
    REAL(dp), PARAMETER :: SQRPI2 = 1.0_dp/sqrt(2*Pi)
    !
    IF (ABS(Rho) >= 1.0_dp) THEN
       WRITE (*,*)  'PHIZ1: |rho| >= 1'
       STOP
    END IF
    !
    call calc_Fisher(Rho,n0,zbar,sz,dzdr)
    PHIZ1 = dzdr*SQRPI2/sz*EXP(-((z0-zbar)/sz)**2/2)
  END FUNCTION PHIZ1
!///////////////////////////////////////////////////////////////////////
! Integrating over the likelihood function from rho=-1 to rho=rho0 for a
! given value of the estimator r evaluated on n pairs.
  FUNCTION CLIKE(Rho0,Z1,N1)
    USE cons
    USE quad77
    USE like_vars
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: Rho0
    REAL(dp), INTENT(in) :: Z1
    INTEGER, INTENT(in) :: N1
    REAL(dp) :: CLIKE
    !
    IF (ABS(Rho0) > 1.0) THEN
       WRITE (*,*)  'CLIKE: |rho| > 1'
       STOP
    END IF
    ! Initializing PHIZ1
    n0 = N1
    z0 = Z1
    !
    CALL QROMO(PHIZ1,-1D0,Rho0,CLIKE,MIDPNT)
  END FUNCTION CLIKE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! The integrand of the likelihood function
  ! i0 is the point whose peak likelihood is calculated
  FUNCTION LIKINT(Rho)
    USE cons
    USE like_vars
    IMPLICIT NONE
    REAL(dp), INTENT(in) :: Rho
    REAL(dp) :: LIKINT
    !
    REAL(dp) :: cn,zbar,sz,dzdr
    INTEGER :: j
    ! cpi = 1/sqrt(2*Pi)
    REAL(dp), PARAMETER ::  CPI=1.0_dp/SQRT(2*Pi), TINY=1D-10
    !
    IF (ABS(Rho) >= 1.0) THEN
       WRITE (*,*) 'LIKINT: |rho| >= 1'
       STOP
    END IF
    !
    call calc_Fisher(Rho,n(i0),zbar,sz,dzdr)
    LIKINT = LOG(dzdr) + LOG(CPI) - LOG(sz) - ((z(i0)-zbar)/sz)**2/2
    DO j = 1 , i0-1
       cn = CLIKE(Rho,z(j),n(j))
       IF (cn <= TINY) THEN
          LIKINT = 0.0_dp
          RETURN
       END IF
       LIKINT = LIKINT + LOG(cn)
    END DO
    DO j = i0+1 , np
       cn = CLIKE(Rho,z(j),n(j))
       IF (cn <= TINY) THEN
          LIKINT = 0.0_dp
          RETURN
       END IF
       LIKINT = LIKINT + LOG(cn)
    END DO
    LIKINT = EXP(LIKINT)
  END FUNCTION LIKINT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE like_funcs
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
PROGRAM plike
  USE cons
  USE like_vars
  IMPLICIT NONE
  REAL(dp) :: mxlik,tmxlik
  REAL(dp) :: tlow,thigh,dtlikl,dtliku,tcom
  CHARACTER(len=100) :: dcf
  INTEGER :: ioerr,i,j
  REAL(dp) :: tdummy
  !
  WRITE (*,'("PLIKE V4.0 begins.")')
  WRITE (*,'("Enter dcf file name:")')
  READ (*,'(a100)') dcf
  OPEN (UNIT=11,FILE=dcf,STATUS='OLD',IOSTAT=ioerr)
  IF (ioerr /= 0) THEN
     WRITE (*,*) 'Error ',ioerr,' opening file ',TRIM(dcf)
     STOP
  END IF
  !
  WRITE (*,'("Enter lower bound on peak location:")')
  READ (*,*) tlow
  WRITE (*,'("Enter upper bound on peak location:")')
  READ (*,*) thigh
  WRITE (*,'(/,"Calculating ML in range t_lag = ",es10.3," to ",es10.3)') &
       tlow,thigh
  !
  ! Going through data first to find how many data points there are
  ! in *.dcf file in requested time-lag range.
  !
  np = 0
  DO
     READ (11,*,END=100) tdummy
     IF (tdummy >= tlow .AND. tdummy <= thigh) np = np + 1
  END DO
100 CONTINUE
  !
  WRITE (*,*)
  WRITE (*,'(i4," data points found in time-lag range")') np
  CALL allocate_vars(np)
  !
  ! Actually reading data
  !
  REWIND(11)
  i = 0
  DO WHILE (i < np)
     READ (11,*,END=200) t(i+1),dtm(i+1),dtp(i+1), &
          r(i+1),drm(i+1),drp(i+1),n(i+1)
     IF (t(i+1) >= tlow .AND. t(i+1) <= thigh) i = i+1
  END DO
200 CONTINUE
  CLOSE (UNIT=11,STATUS='KEEP',IOSTAT=ioerr)
  IF (ioerr /= 0) THEN
     WRITE (*,*) 'Error ',ioerr,' closing file ',TRIM(dcf)
     STOP
  END IF
  !
  WRITE (*,*)
  tcom = COM(i)
  WRITE (*,'("ZDCF peak at ",sp,es11.3," r_max = ",es11.3,&
       &" ZDCF C.O.M. at ",es11.3)') t(i),r(i),tcom
  WRITE (*,*)
  CALL PLIKE4(tmxlik,mxlik,dtlikl,dtliku,2)
  !
  WRITE (*,'("Results:",/)')
  OPEN (UNIT=11,FILE='plike.out',STATUS='UNKNOWN',IOSTAT=ioerr)
  IF (ioerr /= 0) THEN
     WRITE (*,*) 'Error ',ioerr,' opening file plike.out'
     STOP
  END IF
  DO j = 6,11,5
     WRITE (j,'("# PLIKE V4.0 ZDCF peak likelihood analysis",/,&
          &"# for file ",a)') TRIM(dcf)
     WRITE (j,'("#")')
     WRITE (j, &
          '("# num      lag         r         -dr        +dr    likelihood ")')
     WRITE (j, &
          '("# ---- ---------- ---------- ---------- ---------- ---------- ")')
     WRITE (j,'(2x,i4,1x,es10.3,1x,es10.3,1x,es10.3,1x,es10.3,1x,es10.3)') &
          (i,t(i),r(i),drm(i),drp(i),liklhd(i),i=1,np)
     !
     WRITE (j,'("#")')
     WRITE (j,'("# ML Peak at t_lag = ",sp,es11.3,", Likelihood at peak = ",es11.3)') &
          tmxlik,mxlik
     WRITE (j,'("# 1 sigma ML t_lag interval = ",sp,es11.3,1x,es11.3,1x,&
          &es11.3,/,"#",26x," = (",es11.3," , ",es11.3,")")') &
          tmxlik,dtliku,-dtlikl,tmxlik-dtlikl,tmxlik+dtliku
  END DO
  CLOSE (UNIT=11,STATUS='KEEP',IOSTAT=ioerr)
  IF (ioerr /= 0) THEN
     WRITE (*,*) 'Error ',ioerr,' closing file plike.out'
     STOP
  END IF
  !
  WRITE (*,*)
  WRITE (*,'("Output written on plike.out.")')
  CALL deallocate_vars()
  WRITE (*,'("Program ended.")')
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! com calculates the center-of-mass (centroid) around the ZDCF peak.
  ! The sum is taken over all the points lying between the two nearest
  ! the maximum with r < r_max/2.
  !
  FUNCTION COM(Imax)
    USE cons
    USE like_vars
    IMPLICIT NONE
    INTEGER, INTENT(out) :: Imax
    REAL(dp) :: com
    !
    REAL :: sumr,sumtr,rhalf
    INTEGER :: i,i1,i2
    ! Locating the maximum
    Imax = SUM(MAXLOC(R))
    !
    rhalf = R(Imax)/2.
    ! Locating the peak between half max to the left (i1) and right (i2)
    i1 = Imax - 1
    DO WHILE (i1 >= 1 .AND. R(i1) >= rhalf)
       i1 = i1 - 1
    END DO
    i1 = i1 + 1
    ! Warning
    IF (i1 == 1 .AND. R(1) >= rhalf) THEN
       WRITE (*,*) 'COM: Warning - Peak extends beyond range to the left.'
    END IF
    !
    i2 = Imax + 1
    DO WHILE (i2 <= np .AND. R(i2) >= rhalf)
       i2 = i2 + 1
    END DO
    i2 = i2 - 1
    ! Warning
    IF (i2 == np .AND. R(np) >= rhalf) THEN
       WRITE (*,*) 'COM: Warning - Peak extends beyond range to the right.'
    END IF
    ! Calculating the center of mass
    sumtr = SUM(T(i1:i2)*R(i1:i2))
    sumr = SUM(R(i1:i2))
    IF (sumr <= 0.0) THEN
       WRITE (*,*)  'COM: Problems. np = ',np ,' imax = ', Imax ,      &
            &' rmax = ',R(Imax),' i1 = ',i1,' i2 = ' , i2 ,   &
            &' sumr = ' , sumr
       WRITE (*,'(1x,f10.3,1x,f10.3)') (T(i),R(i),i=1,np)
       STOP
    ELSE
       COM = sumtr/sumr
    END IF
  END FUNCTION COM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE plike4(tmxlik,mxlik,dtlikl,dtliku,zrflag)
    USE cons
    USE quad77
    USE like_vars
    USE like_funcs
    IMPLICIT NONE
    INTEGER, INTENT(in) :: zrflag
    REAL(dp), INTENT(out) :: tmxlik,mxlik,dtlikl,dtliku
    !
    REAL(dp) :: rpeak
    INTEGER :: imxlik,ipeak
    REAL(dp), PARAMETER :: EPSLIK = 1e-10_dp
    !
    ipeak = SUM(MAXLOC(R))
    rpeak = R(ipeak)
    liklhd = 0.0_dp
    ! Input given in z-space (zrflag = 1): vector r holds z
    IF (zrflag == 1) THEN ! NOT IN USE!
       z(1:np) = R(1:np)
    ! Input given in r-space (rzflag <> 1)
    ELSE
       z(1:np) = LOG((1.+R(1:np))/(1.-R(1:np)))/2
    END IF
    !
    ! Calculating the likelihood function around the peak
    ! Saving time by stopping when negligibly low values reached.
    !
    WRITE (*,'("Progress meter: ",$)')
    DO i = ipeak-1,1,-1
       i0 = i ! Initializing LIKINT
       WRITE (*,'(".",$)')
       CALL QROMO(LIKINT,-1D0,1D0,liklhd(i),MIDPNT)
       IF (liklhd(i) < EPSLIK) EXIT
    END DO
    DO i = ipeak,np
       i0 = i ! Initializing LIKINT
       WRITE (*,'(".",$)')
       CALL QROMO(LIKINT,-1D0,1D0,liklhd(i),MIDPNT)
       IF (liklhd(i) < EPSLIK) EXIT
    END DO
    WRITE (*,'(/)')
    !
    ! Finding the maximal likelihood value and error interval
    !
    CALL CONF1(imxlik,tmxlik,mxlik,dtlikl,dtliku)
    !
  END SUBROUTINE plike4
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Finding the +/- 1 sigma intervals on the interpolated likelihood
! function which (after normalization) is the "Fiducial Probability
! Function" (Kendall & Stuart, Vol 2, 3rd ed. p. 141)
  SUBROUTINE CONF1(imxlik,tmxlik,mxlik,dtlikl,dtliku)
    !
    USE cons
    USE like_vars
    IMPLICIT NONE
    INTEGER, INTENT(out) :: imxlik
    REAL(dp), INTENT(out) :: tmxlik,mxlik,dtlikl,dtliku
    !
    INTEGER :: i
    REAL(dp) :: cn,s,p,t1sigl,t1sigu
    REAL(dp) :: Pcum(np)
    LOGICAL :: edge
    !
    ! Find the maximal likelihood
    !
    imxlik = SUM(MAXLOC(liklhd(1:np)))
    tmxlik = T(imxlik)
    mxlik = liklhd(imxlik)
    !
    ! Find the +/- 1 sigma limits
    !
    cn = 0.0
    Pcum(1) = 0.0
    DO i = 2 , Np
       cn = cn + (liklhd(i)+liklhd(i-1))/2.0*(T(i)-T(i-1))
       Pcum(i) = cn
    END DO
    Pcum(1:np) = Pcum(1:np)/cn
    !
    edge = .TRUE.
    p = Pcum(imxlik) + 0.3413*(Pcum(Np)-Pcum(imxlik))*2
    t1sigu = T(Np)
    DO i = imxlik,Np
       IF (Pcum(i) >= p) THEN
          s = (liklhd(i)-liklhd(i-1))/(T(i)-T(i-1))
          t1sigu = T(i-1) &
               & + (-liklhd(i-1)+SQRT(liklhd(i-1)**2+2*(p-Pcum(i-1))&
               & *s*cn))/s
          edge = .FALSE.
          EXIT
       END IF
    END DO
    IF (edge) WRITE (*,*) &
         'CONF1: Warning - 1 sigma interval may extend beyond range to the right.'
    !
    edge = .TRUE.
    p = Pcum(imxlik) - 0.3413*(Pcum(imxlik)-Pcum(1))*2
    t1sigl = T(1)
    DO i = imxlik ,1,-1
       IF (Pcum(i) <= p) THEN
          s = (liklhd(i+1)-liklhd(i))/(T(i+1)-T(i))
          t1sigl = T(i) &
               & + (-liklhd(i)+SQRT(liklhd(i)**2+2*(p-Pcum(i))*s*cn)&
               & )/s
          edge = .FALSE.
          EXIT
       END IF
    END DO
    IF (edge) WRITE (*,*) &
         'CONF1: Warning - 1 sigma interval may extend beyond range to the left.'
    !
    dtliku = MAX(t1sigu-tmxlik,dtp(imxlik))
    dtlikl = max(tmxlik-t1sigl,dtm(imxlik))
  END SUBROUTINE CONF1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END PROGRAM plike


      MODULE m_dylm
      use m_juDFT
c.....------------------------------------------------------------------
c     preparation of dylmt1(=d(ylm)/dtheta),
c     dylmt2(=d(dylmt1)/dtheta),
c     dylmf1, dylmf2 are for fai.
c     dylmtf=d(dylmt1)/df
c     t.a. june, 1996.
c.....------------------------------------------------------------------
      CONTAINS
      SUBROUTINE dylm3(
     >                 lmaxd,lmax,v,ylm,
     <                 dylmt1,dylmt2,dylmf1,dylmf2,dylmtf)
c
      use m_constants
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: lmaxd,lmax
C     ..
C     .. Array Arguments ..
      REAL,    INTENT (IN) :: v(3)
      COMPLEX, INTENT (IN) ::    ylm( (lmaxd+1)**2 )
      COMPLEX, INTENT (OUT):: dylmt1( (lmaxd+1)**2 )
      COMPLEX, INTENT (OUT):: dylmt2( (lmaxd+1)**2 )
      COMPLEX, INTENT (OUT):: dylmf1( (lmaxd+1)**2 )
      COMPLEX, INTENT (OUT):: dylmf2( (lmaxd+1)**2 )
      COMPLEX, INTENT (OUT):: dylmtf( (lmaxd+1)**2 )
C     ..
C     .. Local Scalars ..
      INTEGER lm1,lm,lm2,lm1m,lmm1m,lmm,lmm1,lmm2
      INTEGER l,m,ll1,llm
      COMPLEX em1f,em2f,ep1f,ep2f
      REAL cph,rxy,small,sph,x,xy,y
C     ..
C     .. Data Statements ..
      DATA small/1.0e-12/
c.....------------------------------------------------------------------
c     ..
      IF (lmax.GT.lmaxd) THEN
        WRITE (oUnit,*) lmax,lmaxd
         CALL juDFT_error("lmax.GT.lmaxd",calledby="dylm3")
      ENDIF

c--->    calculate sin and cos of phi
      x = v(1)
      y = v(2)

      xy = x*x + y*y
      rxy = sqrt(xy)
c
      IF (rxy.gt.small) THEN
         cph = x/rxy
         sph = y/rxy
      ELSE
         cph = 1.e0
         sph = 0.e0
      ENDIF

      ep1f=cmplx(cph,sph)
      em1f=conjg(ep1f)
      ep2f=ep1f*ep1f
      em2f=em1f*em1f
c
      DO 21 l=0,lmax
         ll1 = l*(l+1)

         DO m=-l,l
            llm = ll1 + m + 1
            dylmt1(llm) = cmplx(0.0,0.0)
            dylmt2(llm) = cmplx(0.0,0.0)
         ENDDO

         DO 23 m=-l,l
            llm = ll1 + m + 1

            lmm1m = l - m - 1
            lmm   = l - m
            lmm1  = l - m + 1
            lmm2  = l - m + 2
            lm1m  = l + m - 1
            lm    = l + m
            lm1   = l + m + 1
            lm2   = l + m + 2

            dylmt2(llm)=dylmt2(llm) -
     +                      (lmm*lm1+lmm1*lm)/4.e0*ylm(llm)

            IF (m+2.le.l) dylmt2(llm)=dylmt2(llm) +
     +           sqrt(real(lmm1m*lmm*lm1*lm2))/4*ylm(llm+2)*em2f

            IF (m+1.le.l) dylmt1(llm)=dylmt1(llm) +
     +           sqrt(real(lmm*lm1))/2*ylm(llm+1)*em1f

            IF (m-1.ge.-l) dylmt1(llm)=dylmt1(llm) -
     +           sqrt(real(lm*lmm1))/2*ylm(llm-1)*ep1f

            IF (m-2.ge.-l) dylmt2(llm)=dylmt2(llm) +
     +           sqrt(real(lmm1*lmm2*lm1m*lm))/4*ylm(llm-2)*ep2f

   23    ENDDO

         DO m=-l,l
            llm = ll1 + m + 1
            dylmf1(llm) = ImagUnit * m *    ylm(llm)
            dylmf2(llm) = -m * m *    ylm(llm)
            dylmtf(llm) = ImagUnit * m * dylmt1(llm)
         ENDDO

   21 ENDDO

      RETURN
      END SUBROUTINE dylm3
      END MODULE m_dylm


program main
    use precision
    use Input
    use Output
    use Simulation
    implicit none
    !external EscreveArquivo
    character(len=80), allocatable :: args(:)
    integer(kind=4) :: nArgs, i, ios
    real(kr8), allocatable :: isiData(:), parAData(:), parBData(:), intData(:)
    character(len=1024) :: headerSaida

    call inicializaParametros()

    nArgs = command_argument_count()
    if (nArgs >= 1) then
        allocate(args(1:nArgs))
        do i = 1, nArgs
            call get_command_argument(i, args(i))
        end do
        write (*, '(A)') 'arguments: '
        write (*, '(A)') (trim(args(i)),i=1,nArgs)
        call ajustaParametros(args, nArgs, ios)
        if (ios == -1) then
            ! error occurred during the processing of the parameters
            stop
        end if
    end if

    write (*,*) 'Simulando ...'
    call Simula(parBData, parAData, isiData, intData)

    if (.not.par%writeOnRun) then
        headerSaida = trim(pegaStrParamEntrada())// &
                      "# "//trim(par%parB)//"     "//trim(par%parA)//&
                      "     "//trim(par%measure)//"     intensity"
        call EscreveArquivo(parBData, &
                            parAData, &
                            isiData, &
                            intData, &
                            "(4D17.8)", &
                            headerSaida, &
                            pegaNomeArqSaida())
    end if

end program main


!      INTEGER N, iters
!      REAL check

!      N = 128
!      iters = N*3
!      CALL echo_f77Tuned(N,iters,check)
!      PRINT *, check
!      END

      SUBROUTINE echo_f77Tuned(N, niters, check)
      INTEGER N, niters, iter
      REAL check
      REAL P1(N,N), P2(N,N), P3(N,N), C(N,N)
      INTEGER i, j
      INTEGER nitersd3, remainder

      CALL echo_f77_set2(c, P1, P2, P3, N)
      CALL checkArray2(P2, N)
      CALL checkArray2(c, N)

      nitersd3 = niters / 3
      remainder = niters - 3 * nitersd3
      IF (remainder .NE. 0) THEN
        PRINT *, 'niters should be divisible by 3, results will be off'
      ENDIF

      DO iter=1, niters, 3
        CALL stencil5(c, P1, P2, P3, N)
        CALL stencil5(c, P2, P3, P1, N)
        CALL stencil5(c, P3, P1, P2, N)
      END DO

      check = P1(N/2,7*N/8)

      RETURN
      END

      SUBROUTINE echo_f77_set2(c, P1, P2, P3, N)
      INTEGER N
      REAL c(N,N), P1(N,N), P2(N,N), P3(N,N)

      INTEGER i, j, blockLeft, blockRight, blockTop, blockBottom
      INTEGER channelLeft, channelRight, channel1Height, channel2Height
      INTEGER cr, cc
      REAL s2

!     Default velocity in the air

      DO j=1,N
        DO i=1,N
          c(i,j) = 0.2
        END DO
      END DO

!     Solid block with which the pulse collids

      blockLeft = 1
      blockRight = 2 * N / 5.0
      blockTop = N / 3.0
      blockBottom = 2 * N / 3.0

      DO j=blockLeft,blockRight
        DO i=blockTop,blockBottom
          c(i,j) = 0.5
        END DO
      END DO

!     Channel directing the pulse leftwards

      channelLeft = 4 * N / 5.0
      channelRight = N
      channel1Height = 3 * N / 8.0
      channel2Height = 5 * N / 8.0

      DO j = channelLeft,channelRight
        c(channel1Height,j) = 0.0
        c(channel2Height,j) = 0.0
      END DO

!     Initial pressure distribution: a gaussian pulse inside the channel

      cr = N / 2
      cc = 7 * N / 8.0
      s2 = 64.0 * 9.0 / ((N/2.0) ** 2)

      print *, 'cr = ', cr, ' cc = ', cc, ' s2 = ', s2

      DO j=1,N
        DO i=1,N
          P1(i,j) = 0.0
          P2(i,j) = exp(-((i-cr)**2 + (j-cc)**2) * s2)
          P3(i,j) = 0.0
        END DO
      END DO

      RETURN
      END

      SUBROUTINE stencil5(c, P1, P2, P3, N)
      INTEGER N
      REAL c(N,N), P1(N,N), P2(N,N), P3(N,N)
      REAL tmp1, tmp2, tmp3
      INTEGER TileWidth, TileHeight, bj, nj, bi, ni, i

      TileWidth = 16
      TileHeight = 3

      DO bj=2, N-1, TileWidth
        nj = MIN(bj+TileWidth-1, N-1)

        DO bi=2, N-1, TileHeight
          IF (bi+TileHeight .LT. N) THEN
            i = bi
            DO j=bj,nj
              tmp1 = (2-4*c(i,j))*P2(i,j) + c(i,j)*(P2(i,j-1)
     .          + P2(i,j+1) + P2(i-1,j) + P2(i+1,j)) - P1(i,j)
              tmp2 = (2-4*c(i+1,j))*P2(i+1,j) + c(i+1,j)
     .          *(P2(i+1,j-1) + P2(i+1,j+1) + P2(i,j) + P2(i+2,j))
     .          - P1(i+1,j)
              tmp3 = (2-4*c(i+2,j))*P2(i+2,j) + c(i+2,j)
     .          *(P2(i+2,j-1) + P2(i+2,j+1) + P2(i+1,j) + P2(i+3,j))
     .          - P1(i+2,j)
              P3(i,j) = tmp1
              P3(i+1,j) = tmp2
              P3(i+2,j) = tmp3
            END DO
          ELSE
            DO i=bi, N-1
              DO j=bj,nj
                P3(i,j) = (2-4*c(i,j))*P2(i,j) + c(i,j)*(P2(i,j-1)
     .            + P2(i,j+1) + P2(i-1,j) + P2(i+1,j)) - P1(i,j)
              END DO
            END DO
          END IF
        END DO
      END DO

      RETURN
      END

      SUBROUTINE checkArray2(A, N)
      INTEGER N
      REAL A(N,N)

      INTEGER i,j
      REAL check
      check = 0.0
      DO j=1,N
        DO i=1,N
          check = check + (i*n+j)*A(i,j)
        END DO
      END DO

      PRINT *, 'Array check: ', check
      RETURN
      END


      SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      COMPLEX*16         AB( LDAB, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  ZPBTRS solves a system of linear equations A*X = B with a Hermitian
*  positive definite band matrix A using the Cholesky factorization
*  A = U**H*U or A = L*L**H computed by ZPBTRF.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangular factor stored in AB;
*          = 'L':  Lower triangular factor stored in AB.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
*          The triangular factor U or L from the Cholesky factorization
*          A = U**H*U or A = L*L**H of the band matrix A, stored in the
*          first KD+1 rows of the array.  The j-th column of U or L is
*          stored in the j-th column of the array AB as follows:
*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZTBSV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPBTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Solve A*X = B where A = U'*U.
*
         DO 10 J = 1, NRHS
*
*           Solve U'*X = B, overwriting B with X.
*
            CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
     $                  KD, AB, LDAB, B( 1, J ), 1 )
*
*           Solve U*X = B, overwriting B with X.
*
            CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1 )
   10    CONTINUE
      ELSE
*
*        Solve A*X = B where A = L*L'.
*
         DO 20 J = 1, NRHS
*
*           Solve L*X = B, overwriting B with X.
*
            CALL ZTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
     $                  LDAB, B( 1, J ), 1 )
*
*           Solve L'*X = B, overwriting B with X.
*
            CALL ZTBSV( 'Lower', 'Conjugate transpose', 'Non-unit', N,
     $                  KD, AB, LDAB, B( 1, J ), 1 )
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of ZPBTRS
*
      END


c=======================================================================
c Sparse Matrix Multiplication Package
c
c Randolph E. Bank and Craig C. Douglas
c
c na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov
c
c Compile this with the following command (or a similar one):
c
c     f77 -c -O smmp.f
c
c=======================================================================
        subroutine symbmm
     *                   (n, m, l,
     *                    ia, ja, diaga,
     *                    ib, jb, diagb,
     *                    ic, jc, diagc,
     *                    index)
c
            integer       ia(*), ja(*), diaga,
     *                    ib(*), jb(*), diagb,
     *                    ic(*), jc(*), diagc,
     *                    index(*)
c
c       symbolic matrix multiply c=a*b
c
        maxlmn = max(l,m,n)
        do 10 i=1,maxlmn
   10       index(i)=0
        if (diagc.eq.0) then
            ic(1)=1
        else
            ic(1)=n+2
        endif
        minlm = min(l,m)
        minmn = min(m,n)
c
c    main loop
c
        do 50 i=1,n
            istart=-1
            length=0
c
c    merge row lists
c
            do 30 jj=ia(i),ia(i+1)
c    a = d + ...
                if (jj.eq.ia(i+1)) then
                    if (diaga.eq.0 .or. i.gt.minmn) goto 30
                    j = i
                else
                    j=ja(jj)
                endif
c    b = d + ...
                if (index(j).eq.0 .and. diagb.eq.1 .and. j.le.minlm)then
                    index(j)=istart
                    istart=j
                    length=length+1
                endif
                do 20 k=ib(j),ib(j+1)-1
                    if(index(jb(k)).eq.0) then
                        index(jb(k))=istart
                        istart=jb(k)
                        length=length+1
                    endif
   20           continue
   30       continue
c
c   row i of jc
c
            if (diagc.eq.1 .and. index(i).ne.0) length = length - 1
            ic(i+1)=ic(i)+length
            do 40 j= ic(i),ic(i+1)-1
                if (diagc.eq.1 .and. istart.eq.i) then
                    istart = index(istart)
                    index(i) = 0
                endif
                jc(j)=istart
                istart=index(istart)
                index(jc(j))=0
   40       continue
            index(i) = 0
   50   continue
        return
        end
        subroutine numbmm
     *                   (n, m, l,
     *                    ia, ja, diaga, a,
     *                    ib, jb, diagb, b,
     *                    ic, jc, diagc, c,
     *                    temp)
c
            integer       ia(*), ja(*), diaga,
     *                    ib(*), jb(*), diagb,
     *                    ic(*), jc(*), diagc
c
            real          a(*), b(*), c(*), temp(*)
c
c       numeric matrix multiply c=a*b
c
        maxlmn = max(l,m,n)
        do 10 i = 1,maxlmn
 10         temp(i) = 0.
        minlm = min(l,m)
        minln = min(l,n)
        minmn = min(m,n)
c
c   c = a*b
c
        do 50 i = 1,n
             do 30 jj = ia(i),ia(i+1)
c    a = d + ...
                if (jj.eq.ia(i+1)) then
                    if (diaga.eq.0 .or. i.gt.minmn) goto 30
                    j = i
                    ajj = a(i)
                else
                    j=ja(jj)
                    ajj = a(jj)
                endif
c    b = d + ...
                if (diagb.eq.1 .and. j.le.minlm)
     *              temp(j) = temp(j) + ajj * b(j)
                do 20 k = ib(j),ib(j+1)-1
 20                 temp(jb(k)) = temp(jb(k)) + ajj * b(k)
 30         continue
c    c = d + ...
            if (diagc.eq.1 .and. i.le.minln) then
                c(i) = temp(i)
                temp(i) = 0.
            endif
            do 40 j = ic(i),ic(i+1)-1
                c(j) = temp(jc(j))
 40             temp(jc(j)) = 0.
 50     continue
        return
        end
        subroutine transp
     *                   (n, m,
     *                    ia, ja, diaga, a,
     *                    ib, jb,        b,
     *                    move)
c
            integer       ia(*), ja(*), diaga,
     *                    ib(*), jb(*),
     *                    move
c
            real          a(*), b(*)
c
c       compute b = a(transpose)
c
c       first make ib
c
        do 10 i=1,m+1
   10       ib(i)=0
        if (move.eq.1) then
            do 15 i =1,m+1
   15           b(i) = 0.
        endif
        if (diaga.eq.1) then
            ib(1)=m + 2
        else
            ib(1)=1
        endif
c
c       count indices for each column
c
        do 30 i=1,n
            do 20 j=ia(i),ia(i+1)-1
                ib(ja(j)+1)=ib(ja(j)+1)+1
   20       continue
   30   continue
        do 40 i=1,m
   40      ib(i+1)=ib(i)+ib(i+1)
c
c       now make jb
c
        do 60 i=1,n
            do 50 j=ia(i),ia(i+1)-1
                index=ja(j)
                jb(ib(index))=i
                if (move.eq.1) b(ib(index)) = a(j)
                ib(index)=ib(index)+1
   50       continue
   60   continue
c
c       now fixup ib
c
        do 70 i=m,2,-1
   70       ib(i)=ib(i-1)
        if (diaga.eq.1) then
            if (move.eq.1) then
                j = min(n,m)
                do 80 i = 1,j
   80               b(i) = a(i)
            endif
            ib(1)=m + 2
        else
            ib(1)=1
        endif
        return
        end
        subroutine ytobs
     *                  (n,
     *                   ia, ja, diaga, syma, a,
     *                   ib, jb,              b,
     *                   move)
c
            integer     ia(*), ja(*), diaga, syma,
     *                  ib(*), jb(*), move
c
            real        a(*), b(*)
c
c       create the bank-smith data structures b from the
c       corresponding yale data structures a
c
        do 10 i=1,n
   10       ib(i+1)=ia(i+1)-ia(i)
c
c       look for upper triangular entries and duplicate entries
c
        do 50 i=1,n
            do 40 jj=ia(i),ia(i+1)-1
                j=ja(jj)
                if (i.eq.j) then
                    ib(i+1)=ib(i+1)-1
                    ja(jj) = -j
                endif
                if(j.gt.i) then
                    ib(i+1)=ib(i+1)-1
                    ib(j+1)=ib(j+1)+1
c
c       check for duplicates
c
                    do 20 k=ia(j),ia(j+1)-1
                        if(ja(k).eq.i) then
                            ib(j+1)=ib(j+1)-1
                            ja(jj)=-j
                            go to 30
                        endif
   20               continue
   30               continue
                endif
   40       continue
   50   continue
c
c       compute ib
c
        ib(1)=n + 2
        do 60 i=1,n
   60       ib(i+1)=ib(i+1)+ib(i)
c
c       initialize b if move = 1
c
        if (move.eq.1) then
            lshift = 0
            if (syma.eq.0) lshift = ib(n+1) - ib(1)
            do 62 ii = 1,ib(n+1)+lshift-1
   62           b(ii) = 0.
            if (diaga.eq.1) then
                do 64 ii = 1,n
   64               b(ii) = a(ii)
            endif
        endif
c
c       compute jb
c
        do 80 i=1,n
            do 70 jj=ia(i),ia(i+1)-1
                j=ja(jj)
                if(j.gt.i) then
                    jb(ib(j))=i
                    if (move.eq.1) b(ib(j)) = a(jj)
                    ib(j)=ib(j)+1
                else
                    if(j.le.0) then
                        ja(jj)=-j
                        if (move.eq.1 .and. i.eq.-j) b(i) = a(jj)
                    else
                        jb(ib(i))=j
                        if (move.eq.1) b(ib(i)+lshift) = a(jj)
                        ib(i)=ib(i)+1
                    endif
                endif
   70       continue
   80   continue
c
c       fixup ib
c
        do 90 i=n,2,-1
   90       ib(i)=ib(i-1)
        ib(1)=n + 2
        return
        end
        subroutine bstoy
     *                  (n,
     *                   ia, ja,        syma, a,
     *                   ib, jb, diagb,       b,
     *                   move)
c
            integer      ia(*), ja(*),        syma,
     *                   ib(*), jb(*), diagb,
     *                   move
c
            real         a(*), b(*)
c
c       create the yale data structures b from the
c       corresponding bank-smith data structures a
c
c       compute ib
c
        if (diagb.eq.1) then
            ib(1) = n + 2
            icor = 0
            if (move.eq.1) then
                lshift = 0
                if (syma.eq.0) lshift = ia(n+1) - ia(1)
                do 2 i = 1,n
    2               b(i) = a(i)
            endif
        else
            ib(1) = 1
            icor = 1
        endif
        do 10 i=1,n
   10       ib(i+1)=ia(i+1)-ia(i)+icor
        do 30 i=1,n
            do 20 j=ia(i),ia(i+1)-1
                ib(ja(j)+1)=ib(ja(j)+1)+1
   20       continue
   30   continue
c
        do 40 i=1,n
   40       ib(i+1)=ib(i+1)+ib(i)
        if (diagb.eq.0) then
            do 45 i = 1,n
                jb(ib(i)) = i
                if (move.eq.1) b(ib(i)) = a(i)
   45           ib(i) = ib(i) + 1
        endif
c
c       now compute jb
c
        do 60 i=1,n
            do 50 jj=ia(i),ia(i+1)-1
                j = ja(jj)
                jb(ib(j))=i
                jb(ib(i))=j
                if (move.eq.1) then
                    b(ib(j)) = a(jj)
                    b(ib(i)) = a(jj+lshift)
                endif
                ib(i)=ib(i)+1
                ib(j)=ib(j)+1
   50       continue
   60   continue
c
c       fixup ib
c
        do 70 i=n,2,-1
   70       ib(i)=ib(i-1)
        if (diagb.eq.1) then
            ib(1)=n+2
        else
            ib(1)=1
        endif
        return
        end


        module cdat
        real*8,public,parameter :: PI=4.d0*atan(1.0)
C        Integer,parameter::NI=512,NJ=512,N2=NI*NJ
        complex*16,public,parameter::im=(0d0,1d0)
        save
        end module cdat


!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOI
!
!  !TITLE: Returns a new date/time from an initial date/time and offset
!
!  !AUTHORS: Rob Lucchesi
!
!  !AFFILIATION: Data Assimilation Office, NASA/GSFC, Greenbelt, MD 20771
!
!  !DATE: July 20, 1998
!
!EOI
!-------------------------------------------------------------------------
!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE: GetDate --- Returns a new date/time from an initial date/time
!                       and offset
!
! !INTERFACE:
!

       subroutine GetDate (yyyymmdd_1,hhmmss_1,offset,
     .                     yyyymmdd_2,hhmmss_2,rc)

!
! !USES:
!
       use, intrinsic :: iso_fortran_env, only: INT64

       implicit none

!
! !INPUT PARAMETERS:
!

       integer yyyymmdd_1               ! Initial date in YYYYYMMDD format
       integer hhmmss_1                 ! Initial time in HHMMSS format
       integer offset                   ! Offset to add (in seconds)

!
! !OUTPUT PARAMETERS:
!
       integer yyyymmdd_2               ! New date in YYYYMMDD format
       integer hhmmss_2                 ! New time in HHMMSS format
       integer rc                       ! Return code. (<0 = error)
!
! !DESCRIPTION:   This subroutine returns a new date and time in yyyymmdd
!                 and hhmmss format given and initial date, time, and
!                 offset in seconds.  The routine converts the input date
!                 and time to julian seconds, adds the offset, and converts
!                 back to yyyymmdd and hhmmss format.  This routine has been
!                 tested for Y2K compiance.
!
! !REVISION HISTORY:
!
!  1998.07.20  Lucchesi    Initial version.
!  2010.05.11  Lucchesi  Integer for julian seconds changed to 64-bit. StartDate
!                        constant no longer needed.
!
!EOP
!-------------------------------------------------------------------------

      integer julday

      integer year1,mon1,day1,hour1,min1,sec1
      integer year2,mon2,day2,hour2,min2,sec2
      integer(kind=INT64) julian1
      integer(kind=INT64) julsec, remainder

! Error checking.

      if (hhmmss_1 .lt. 0 .or. hhmmss_1 .ge. 240000 ) then
         rc=-1
         return
      endif

! Convert Date/Time strings to integer variables.

!ams       write (dateString, 200) yyyymmdd_1
!ams 200   format (I8)
!ams       read (dateString, 201) year1, mon1, day1
!ams 201   format (I4,2I2)
!ams       write (dateString, 202) hhmmss_1
!ams 202   format (I6)
!ams       read (dateString, 203) hour1, min1, sec1
!ams 203   format (3I2)

      call GFIO_parseIntTime ( yyyymmdd_1, year1, mon1, day1 )
      call GFIO_parseIntTime (   hhmmss_1, hour1, min1, sec1 )

! Get Julian Day and subtract off a constant (Julian days since 01/01/1850)

      julian1 = julday (mon1, day1, year1)

! Calculcate Julian seconds

      julsec = (julian1-1)*86400 + hour1*3600 + min1*60 + sec1

! Add offset and calculate new julian day.

      julsec = julsec + offset
      julian1 = INT(julsec/86400) + 1
      remainder = MOD(julsec,86400)

! Convert julian day to YYYYMMDD.

      call caldat (julian1, mon2, day2, year2)

! Calculate HHMMSS from the remainder.

      hour2 = INT(remainder/3600)
      remainder = MOD(remainder,3600)
      min2 = INT(remainder/60)
      sec2 = MOD(remainder,60)

! Build YYYYMMDD and HHMMSS variables.

      yyyymmdd_2 = year2*10000 + mon2*100 + day2
      hhmmss_2 = hour2*10000 + min2*100 + sec2

      rc = 0
      return
      end


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! 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.
!

module MArrays

    implicit none
    private

    type, public :: TArrays
    contains
        procedure, nopass :: fillWithSequence1d
        procedure, nopass :: fillWithSequence2d

        procedure, nopass :: fillWithDirtySequence
        procedure, nopass :: fillWithRandom
        procedure, nopass :: fillWithInversedSequence

        procedure, nopass :: increaseWhenRequiredAllocatable
        procedure, nopass :: increaseWhenRequiredAllocatable2d
        procedure, nopass :: increaseWhenRequiredPointer

        procedure, nopass :: resizeAllocatable
        procedure, nopass :: resizeAllocatable2d

        procedure, nopass :: isSorted

        procedure, nopass :: print1d
        procedure, nopass :: print2d

        procedure, nopass :: swap1d

        generic :: fillWithSequence     => fillWithSequence1d, fillWithSequence2d
        generic :: increaseWhenRequired => increaseWhenRequiredAllocatable,   &
                                           increaseWhenRequiredAllocatable2d, &
                                           increaseWhenRequiredPointer

        generic :: resize => resizeAllocatable, resizeAllocatable2d

        generic :: print => print1d, print2d
        generic :: swap  => swap1d
    end type
contains
    !
    ! Fills the array with sequence from one to the last index.
    !
    subroutine fillWithSequence1d(array)
        integer, dimension(:), intent(in out) :: array
        integer index

        array = (/ (index, index = 1, size(array)) /)
    end subroutine

    subroutine fillWithSequence2d(array)
        integer, dimension(:,:), intent(in out) :: array
        integer index

        array = reshape((/ (index, index = 1, size(array)) /), shape(array))
    end subroutine

    !
    ! Fills the array with sequence from one to the last index
    ! and ten percent ramdom values.
    !
    subroutine fillWithDirtySequence(array)
        integer, dimension(:), intent(in out) :: array

        integer index
        integer step

        array = (/ (index, index = 1, size(array)) /)
        step  = size(array) / (size(array) * 0.1)

        do index = step, size(array), step
            array(index) =  array(index) * 2
        end do
    end subroutine

    !
    ! Fills the array with random numbers between zero and maximal
    ! value of type of the array.
    !
    subroutine fillWithRandom(array)
        integer, dimension(:), intent(in out) :: array
        real, dimension(size(array)) :: temporary

        call random_seed()
        call random_number(temporary)

        array = floor(temporary * huge(array))
    end subroutine

    !
    ! Fills the array with sequence from last index of array to the one.
    !
    subroutine fillWithInversedSequence(array)
        integer, dimension(:), intent(in out) :: array
        integer index

        array = (/ (index, index = size(array), 1, -1) /)
    end subroutine

    !
    ! Increase the size of given array if limit is larger than size of array.
    !
    subroutine increaseWhenRequiredAllocatable(array, limit)
        integer, dimension(:), allocatable, intent(in out) :: array
        integer, intent(in) :: limit

        integer, dimension(:), allocatable :: temporary_array
        integer length

        ! increase array size when required
        if (limit > size(array)) then
            length = size(array) * 3 / 2
            allocate(temporary_array(length))
            temporary_array = 0
            temporary_array(1:size(array)) = array
            deallocate(array)
            call move_alloc(temporary_array, array)
        end if
    end subroutine

    subroutine increaseWhenRequiredAllocatable2d(array, limit1, limit2)
        integer, dimension(:,:), allocatable, intent(in out) :: array
        integer, intent(in) :: limit1
        integer, intent(in) :: limit2

        integer, dimension(:,:), allocatable :: temporary_array
        integer length1
        integer length2

        ! increase array size when required
        if ((limit1 > size(array, 1)) .or. (limit2 > size(array, 2))) then
            !print *, limit1, limit2
            length1 = size(array, 1) * 3 / 2
            length2 = size(array, 2) * 3 / 2

            allocate(temporary_array(length1, length2))
            temporary_array = 0
            temporary_array(1:size(array, 1), 1:size(array, 2)) = array
            deallocate(array)
            call move_alloc(temporary_array, array)
        end if
    end subroutine

    subroutine increaseWhenRequiredPointer(array, limit)
        integer, dimension(:), pointer, intent(in out) :: array
        integer, intent(in) :: limit

        integer, dimension(:), pointer :: temporary_array
        integer length

        ! increase array size when required
        if (limit > size(array)) then
            length = size(array) * 3 / 2
            allocate(temporary_array(length))
            temporary_array = 0
            temporary_array(1:size(array)) = array
            deallocate(array)
            array => temporary_array
        end if
    end subroutine

    !
    ! Reallocate array to a given length.
    !
    subroutine resizeAllocatable(array, length)
        integer, dimension(:), allocatable, intent(in out) :: array
        integer, intent(in) :: length

        integer, dimension(:), allocatable :: temporary_array

        if (length /= size(array)) then
            allocate(temporary_array(length))
            temporary_array = 0
            temporary_array(1:length) = array(1:length)
            deallocate(array)
            call move_alloc(temporary_array, array)
        end if
    end subroutine

    subroutine resizeAllocatable2d(array, length1, length2)
        integer, dimension(:,:), allocatable, intent(in out) :: array
        integer, intent(in) :: length1
        integer, intent(in) :: length2

        integer, dimension(:,:), allocatable :: temporary_array

        if ((length1 /= size(array, 1)) .or. (length2 /= size(array, 2))) then
            allocate(temporary_array(length1, length2))
            temporary_array = 0
            temporary_array(1:length1, 1:length2) = array(1:length1, 1:length2)
            deallocate(array)
            call move_alloc(temporary_array, array)
        end if
    end subroutine

    !
    ! Validates given array to be sorted.
    !
    function isSorted(array) result(sorted)
        integer, dimension(:), intent(in) :: array
        logical                           :: sorted

        integer index

        do index = 2, size(array)
            if (array(index - 1) > array(index)) then
                sorted =  .false.
                return
            end if
         end do

         sorted = .true.
     end function

     !
     ! Prints given array to console.
     !
     subroutine print1d(array)
         integer, dimension(:), intent(in) :: array

         character(len=80) :: count
         character(len=80) :: length
         integer           :: maximum
         integer           :: value

         maximum = (maxval(array))
         if (maximum == 0) then
             value = 2
         else if ((mod(maximum, 10) == 0) .or. (maximum == 1)) then
             value = ceiling(log10(real(maximum))) + 2
         else
             value = ceiling(log10(real(maximum))) + 1
         end if

         write(count,  '(i0.0)') size(array)
         write(length, '(i0.0)') value

         print '(' // trim(count) // 'i' // trim(length) // ')', array
     end subroutine

     subroutine print2d(array)
         integer, dimension(:,:), intent(in) :: array

         character(len=80) :: count
         character(len=80) :: length
         integer           :: maximum
         integer           :: value

         maximum = (maxval(array))
         if (maximum == 0) then
             value = 2
         else if ((mod(maximum, 10) == 0) .or. (maximum == 1)) then
             value = ceiling(log10(real(maximum))) + 2
         else
             value = ceiling(log10(real(maximum))) + 1
         end if

         write(count,  '(i0.0)') size(array, 2)
         write(length, '(i0.0)') value

         print '(' // trim(count) // 'i' // trim(length) // ')', transpose(array)
     end subroutine

     subroutine swap1d(array, index, jndex)
         integer, dimension(:), intent(in out) :: array
         integer, intent(in) :: index
         integer, intent(in) :: jndex

         integer buffer

         buffer = array(index)
         array(index) = array(jndex)
         array(jndex) = buffer
     end subroutine
end module


*******************************************************************************
      PROGRAM integration
* Version 3.1: AN 21/04/05
* Version 3.0: AN 28/02/03
* Version 2.0: HO 17/07/00
* Version 1.0: HD 15/05/99
*
* New in Version 3.1: adapted to new block Gauss-Seidel preconditioner.
*
* New in Version 3.0: (mainly in subroutine step)
* - Smart choice of teta in scheme
* - Corrector: Newton-chord instead of Newton-Raphson
*   fix Jacobian over several time steps
* - Tuning of accuracy in solution of systems
* - Error estimate for local truncation error
* - Adaptive step size control
*
* A point from a previous time integration is read (or a starting point)
* and integrated in time for nstp steps. We keep the I/O structure
* exactly the same as in the continuation code, even reading/writing
* eigenvalues/eigenvectors.
*
      USE m_start
      implicit none
      include 'bag.com'
      include 'res.com'
!      include 'start.com'
      real    g05caf
      integer iad
      integer irs, nstp, i, lab, ipert, outp, idum, ico
      real    time, ppert, upert, tdum

*  irs : Label of restart point
*  nstp: Number of time steps
*  ds  : Time-step size in dimensionless quantities
*  outp: Output control parameter
*  ipert : (0/1..npar) (N/Y) random perturbation of initial field
*  ppert : parameter perturbation
*  upert : solution perturbation

      open(11,file= 'input')
      read(11,*) irs, nstp, ds, maxds, outp,
     >             ipert, ppert, upert, idum, idum, tdum, ico
      close(11)

      open(98,status='replace')
      close(98)
      open(7,status='replace')
      close(7)

      CALL allocate_mat  ! allocate matrixarrays
      ALLOCATE(rb2old(ndim),r2o(ndim),dfdmu(ndim))
      ALLOCATE(rh0(ndim),rh1(ndim),rh2(ndim))

      call init
      p0 = 0
      ures = 0
      iad = 0

      IF (irs.EQ.0) THEN
         call stpnt(u)
         icp   = 0
         time  = 0.0
      ELSE
         call read_data(4,irs,icp)
         time  = det
      END IF
      IF (ipert.ne.0) THEN
         DO i=1,ndim
            u(i) = u(i) + upert*g05caf()
         ENDDO
         par(ipert) = par(ipert) + ppert
      ENDIF
      call prpar(ds,nstp,irs)

      cstep = 0
      DO i = 1,nstp
         call step(time,ico)
         icp = icp + 1
         xl  = time
         det = time
         call monitor(0,0,7)
      ENDDO

      det = time
      call write_data(3,irs)

      CALL deallocate_mat  ! deallocate matrixarrays
      DEALLOCATE(rb2old, r2o, dfdmu, rh0,rh1,rh2)

      open(11,file= 'input')
      write(11,'(2i5,2e,i5,a,i2)') irs, nstp, ds, maxds, outp,
     >          '   0 0 0 0 0 0 ',ico
      close(11)

      END
*************************************************************************
      SUBROUTINE step(time,ico)
      USE m_start
      USE m_gsolve
      USE m_bgspars
      implicit none
      include 'bag.com'
      include 'mix.com'
!      include 'start.com'
*     IMPORT/EXPORT
      real     time
      integer  ico
*     LOCAL
      integer  k,itmx,i
      real     rh(ndim),rb(ndim),res,eps,kapp,newds
      real     un(ndim),tdti,Bu(ndim)
      real     teta, error, D(ndim)
      integer  id
      logical  chst
*     FUNCTION
      real     linrm
*
**HO  -B(u^n+1 - u^n)/dt + teta * rhs(u^n+1) + (1-teta) * rhs(u^n) = 0
**HO  teta = 0,.5,1 (Forward Euler, Trapezoidal, Backward Euler)
**HO  in the formulation below teta = 0 is not possible
**AN  teta = .5 + kapp*dt  with 0<kapp*dt<.5 (trunc.error u^n+1 is O(dt^3))
**AN  NB eps is the desired accuracy of the global solution
*     below A is the Jacobian matrix of rhs(u).
*
*     itmx : maximum number of iterations in Newton(-chord) method (<10)
*     eps  : desired accuracy after unit time
*            NB accuracy after time interval T is equal to eps*T

      chst = .true.
      itmx = 10
*     eps*T is acuracy of solution after time T
      eps  = 1.0e-04
      res  = 1.0e+00

      IF (cstep.EQ.0) THEN
         fix = .false.
         call rhs(u,rh2)
      END IF

      IF (fix) THEN
         rh0 = rh1
         rh1 = rh2
      ELSE
         rh0 = 0.0
         rh1 = rh2
      END IF

      kapp = 1.0
      kapp = min(kapp,.5/ds)
      teta = 1.0 ! .5 + kapp*ds
      tdti = 1.0 / (teta * ds)
*     calculate: - rhs(u^n)
      vmix_fix=0 ! ATvS-Mix
      call rhs(u,rh)
*     fill only matrix B
      call fillcolB
*     calculate total residu at n: tdti*Bu^n +rhs(u^n)
      call matBvec(u,Bu)
      rh = -((1-teta)/teta) * rh + tdti * Bu
*     compute secant guess
      un   = u + ds*up
*
      write(99,*) ' Newton process '
      nid = 0

      k=0
      DO WHILE ((k.LT.itmx).AND.(res.gt.eps))
         k = k+1
*     compute new preconditioner or not?
         fix = .false.
         IF (fix) THEN
            id = 2
         ELSE
            id = 0
         END IF
*     set tolerances for solver
         tolabs = 1.0e-06
         tolred = 1.0e-06
*     compute first iterate for: -rhs(u^n+1)
         call rhs(un,rb)
         call matBvec(un,Bu)
*     compute total residue
         rb = rb - rh + tdti * Bu
*     fill matrix A - 2B/dt
         call matrix(un,tdti)
         call g_solve(rb,det,id)
*     correct pressure field
         call cor_pres(rb)
         un = un + rb
         res = linrm(rb,ndim)
         write(99,999) k,res
         IF ((k.EQ.itmx).AND.(res.GT.eps)) THEN
               STOP ' in step: Newton process not converged'
         ELSE
            fix = .true.
         END IF
         nid = nid + 1
      ENDDO

*     det = 1.0
*     compute approximation of derivative
      up = (un-u)/ds
      u = un
      time = time + ds
      cstep = cstep+1
*
 999  format(9x,'it: ',i2,' Res :',e12.4)
      END
*******************************************************************************
      SUBROUTINE prpar(ds,nst,irs)
      implicit none
      include 'bag.com'
*     IMPORT/EXPORT
      integer  nst,isw,irs,ide
      real     ds
*     LOCAL
      integer  i
*
*     open(7,position='append')
      write(7,996)
      write(7,999) (par(i),i=1,npar)
      write(7,996)
      write(7,998) irs,nst,ds
      write(7,996)
      write(7,995) 'time','max(psi)','min(psi)','max(psi)_at',
     >                    'min(psi)_at','ave(psi)_at'
*     close(7)
 999  format('*',5e15.5)
 998  format('*',4x,'irs = ',i4,4x,' nstp = ',i4,
     &       5x,'ds = ',e12.4)
 996  format('*')
 995  format(6x,6a12)
      END
***************************************************************
      SUBROUTINE pcorrect(un)
*     Set pressure in point intcond equal to zero.
      implicit none
      include 'usr.com'
*     IMPORT/EXPORT
      real    un(ndim)
      real    pref
*     LOCAL
      integer i,j,k,row
*     EXTERNAL
      integer find_row2

      pref = un(rowintcon)
      write(99,*) 'reference pressure: ', pref

      do k = 1, l
      do j = 1, m
      do i = 1, n
         if (landm(i,j,k) .eq. OCEAN) then
           row = find_row2(i,j,k,PP)
           un(row) = un(row) - pref
         endif
      enddo
      enddo
      enddo

      end
***************************************************************
      subroutine cor_pres(un)
      IMPLICIT none
      INCLUDE 'usr.com'

      real un(ndim), s1(ndim), s2(ndim), x1(ndim), x2(ndim), un2(ndim)
      real dp1, dp2
      integer k,j,i, find_row2, row
      integer px,py,pz,pv

      s1=0.0
      s2=0.0
      do k = 1,l
         do j = 1,m
            do i = 1,n
               if (landm(i,j,k)==ocean) then
                  row=find_row2(i,j,k,PP)
                  if (mod(i+j,2)==0) then
                     s1(row) = 1.0
                  else
                     s2(row) = 1.0
                  endif
               endif
            enddo
         enddo
      enddo

      s1 = s1/sqrt(sum(s1))
      s2 = s2/sqrt(sum(s2))

      dp1= dot_product(un,s1)
      dp2= dot_product(un,s2)
      call matAvec(s1,x1)
      call matAvec(s2,x2)
      un2 = un - dp1*s1 - dp2*s2

      un=un2

      end


module ad_intrinsic

    use ad_kinds, only: rk
    use ad_types, only: tree_t, assignment(=)
    implicit none
    private

    public :: abs, max, min
    public :: sin, cos, tan
    public :: exp, sqrt, log, log10

    interface abs
        module procedure :: abs_t
    end interface abs

    interface max
        module procedure :: max_tt
        module procedure :: max_tr
        ! Ambiguous interfaces in generic interface 'max' for 'max_tr' at (1) and 'max_rt' here
        ! module procedure :: max_rt
    end interface max

    interface min
        module procedure :: min_tt
        module procedure :: min_tr
        ! module procedure :: min_rt
    end interface min

    interface sin
        module procedure :: sin_t
    end interface sin

    interface cos
        module procedure :: cos_t
    end interface cos

    interface tan
        module procedure :: tan_t
    end interface tan

    interface exp
        module procedure :: exp_t
    end interface exp

    interface sqrt
        module procedure :: sqrt_t
    end interface sqrt

    interface log
        module procedure :: log_t
    end interface log

    interface log10
        module procedure :: log10_t
    end interface log10

contains

    impure elemental function abs_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = abs(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = merge(-1.0_rk, 1.0_rk, t1%node%value < 0.0_rk)

    end function abs_t

    impure elemental function max_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = max(t1%node%value, t2%node%value)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk

    end function max_tt

    ! impure elemental function max_rt(r, t1) result(t)
    !     real(rk), intent(in) :: r
    !     type(tree_t), intent(in) :: t1
    !     type(tree_t) :: t

    !     allocate (t%node)
    !     t%node%value = max(r, t1%node%value)

    !     t%node%left => t1%node
    !     t%node%left_grad = 1.0_rk

    ! end function max_rt

    impure elemental function max_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = max(t1%node%value, r)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk

    end function max_tr

    impure elemental function min_tt(t1, t2) result(t)
        type(tree_t), intent(in) :: t1, t2
        type(tree_t) :: t

        t = min(t1%node%value, t2%node%value)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk

    end function min_tt

    ! impure elemental function min_rt(r, t1) result(t)
    !     real(rk), intent(in) :: r
    !     type(tree_t), intent(in) :: t1
    !     type(tree_t) :: t

    !     allocate (t%node)
    !     t%node%value = min(r, t1%node%value)

    !     t%node%left => t1%node
    !     t%node%left_grad = 1.0_rk

    ! end function min_rt

    impure elemental function min_tr(t1, r) result(t)
        type(tree_t), intent(in) :: t1
        real(rk), intent(in) :: r
        type(tree_t) :: t

        t = min(t1%node%value, r)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk

    end function min_tr

    impure elemental function sin_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = sin(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = cos(t1%node%value)

    end function sin_t

    impure elemental function cos_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = cos(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = -sin(t1%node%value)

    end function cos_t

    impure elemental function tan_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = tan(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk/(cos(t1%node%value)*cos(t1%node%value))

    end function tan_t

    impure elemental function exp_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = exp(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = t%node%value

    end function exp_t

    impure elemental function sqrt_t(t1) result(t)
        use, intrinsic :: ieee_arithmetic, only: ieee_value, NAN => ieee_quiet_nan
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = sqrt(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = merge(0.5_rk/t%node%value, ieee_value(1.0_rk, NAN), t1%node%value >= 0.0_rk) !TODO: NAN

    end function sqrt_t

    impure elemental function log_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = log(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk/t1%node%value

    end function log_t

    impure elemental function log10_t(t1) result(t)
        type(tree_t), intent(in) :: t1
        type(tree_t) :: t

        t = log10(t1%node%value)

        t%node%left => t1%node
        t%node%left_grad = 1.0_rk/t1%node%value/log(10.0_rk)

    end function log10_t

end module ad_intrinsic


module probin_multispecies_module

  use bl_types
  use bl_space

  implicit none

  integer, parameter :: max_species=10
  integer, parameter :: max_element=max_species*(max_species-1)/2

  integer, save      :: nspecies,inverse_type,timeinteg_type,temp_type,chi_iterations
  real(kind=dp_t)    :: start_time
  real(kind=dp_t)    :: T_init(2)
  real(kind=dp_t)    :: Dbar(max_element)
  real(kind=dp_t)    :: Dtherm(max_species)
  real(kind=dp_t)    :: H_offdiag(max_element)
  real(kind=dp_t)    :: H_diag(max_species)
  real(kind=dp_t)    :: fraction_tolerance
  logical            :: correct_flux,print_error_norms,plot_stag
  logical            :: is_nonisothermal,is_ideal_mixture,use_lapack
  real(kind=dp_t)    :: c_init(2,max_species)
  real(kind=dp_t)    :: c_bc(3,2,max_species)
  real(kind=dp_t)    :: alpha1,beta,delta,sigma     ! manufactured solution parameters populated in init

  namelist /probin_multispecies/ nspecies
  namelist /probin_multispecies/ fraction_tolerance ! For roundoff errors in mass and mole fractions
  namelist /probin_multispecies/ start_time
  namelist /probin_multispecies/ inverse_type       ! Only for LAPACK:  1=inverse, 2=pseudo inverse
  namelist /probin_multispecies/ timeinteg_type
  namelist /probin_multispecies/ correct_flux       ! Manually ensure mass is conserved to roundoff
  namelist /probin_multispecies/ print_error_norms
  namelist /probin_multispecies/ is_ideal_mixture   ! If T assume Gamma=I (H=0) and simplify
  namelist /probin_multispecies/ is_nonisothermal   ! If T Soret effect will be included
  namelist /probin_multispecies/ use_lapack         ! Use LAPACK or iterative method for diffusion matrix (recommend False)
  namelist /probin_multispecies/ chi_iterations     ! number of iterations used in Dbar2chi_iterative
  namelist /probin_multispecies/ T_init     ! initial values for temperature (bottom/top, inside/outside circle, etc.)
  namelist /probin_multispecies/ temp_type  ! for initializing temperature
  namelist /probin_multispecies/ c_init   ! initial values for c
  namelist /probin_multispecies/ c_bc     ! c_i boundary conditions (dir,lohi,species)
  ! These are lower-triangules of symmetric matrices represented as vectors
  ! Number of elements is (nspecies*(nspecies-1)/2)
  ! The values are red row by row starting from top going down (this allows easy addition/deletion of new species/rows)
  ! So D_12; D_13, D_23; D_14, D_24, D_34; ...
  namelist /probin_multispecies/ Dbar       ! Maxwell-Stefan diffusion constant
  namelist /probin_multispecies/ Dtherm     ! thermo-diffusion coefficients, only differences among elements matter
  namelist /probin_multispecies/ H_offdiag
  namelist /probin_multispecies/ H_diag     ! Diagonal of H=d^2F/dx^2, these are vectors of length nspecies
  namelist /probin_multispecies/ plot_stag  ! plot staggered velocities in separate plotfile

contains

  subroutine probin_multispecies_init()

    use f2kcli
    use parallel
    use bl_IO_module
    use bl_prof_module
    use bl_error_module
    use bl_constants_module
    use cluster_module

    integer            :: narg, farg
    character(len=128) :: fname
    integer            :: un
    logical            :: lexist,need_inputs

    narg = command_argument_count()

    ! here we set some random values to be replaced from the input file
    nspecies           = 2
    fraction_tolerance = 1e-13
    start_time         = 0.0d0
    inverse_type       = 1
    timeinteg_type     = 1
    correct_flux       = .true.
    print_error_norms  = .true.
    is_ideal_mixture   = .true.
    is_nonisothermal   = .true.
    use_lapack         = .false.
    chi_iterations     = 10
    T_init             = 1.0d0
    temp_type          = 0
    c_init             = 1.0d0
    c_bc               = 0.d0
    Dbar               = 1.0d0
    Dtherm             = 0.0d0
    H_offdiag          = 0.0d0
    H_diag             = 0.0d0
    plot_stag          = .false.

    ! read from input file
    need_inputs = .true.
    farg = 1
    if ( need_inputs .AND. narg >= 1 ) then
       call get_command_argument(farg, value = fname)
       inquire(file = fname, exist = lexist )
       if ( lexist ) then
          farg = farg + 1
          un = unit_new()
          open(unit=un, file = fname, status = 'old', action = 'read')
          read(unit=un, nml = probin_multispecies)
          close(unit=un)
          need_inputs = .false.
       end if
    end if

    ! also can be read in from the command line by appending
    do while ( farg <= narg )
       call get_command_argument(farg, value = fname)
       select case (fname)

       case ('--nspecies')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) nspecies

       case ('--fraction_tolerance')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) fraction_tolerance

       case ('--start_time')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) start_time

       case ('--inverse_type')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) inverse_type

       case ('--timeinteg_type')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) timeinteg_type

       case ('--correct_flux')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) correct_flux

       case ('--print_error_norms')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) print_error_norms

       case ('--is_ideal_mixture')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) is_ideal_mixture

       case ('--is_nonisothermal')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) is_nonisothermal

       case ('--use_lapack')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) use_lapack

       case ('--chi_iterations')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) chi_iterations

       case ('--temp_type')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) temp_type

       case ('--plot_stag')
          farg = farg + 1
          call get_command_argument(farg, value = fname)
          read(fname, *) plot_stag

       case ('--')
          farg = farg + 1
          exit
       case default

       end select
       farg = farg + 1
    end do

    ! check that nspecies<=max_species, otherwise abort with error message
    if(nspecies.gt.max_species) then
       call bl_error(" nspecies greater than max_species - Aborting")
       stop
    end if

  end subroutine probin_multispecies_init

end module probin_multispecies_module