program circle_test

  use class_Circle, only: Circle,circle_print

  implicit none

  type(Circle) :: acircle  ! a circle instance

  acircle%radius=3.2

  call circle_print(acircle)

  ! print out  results
  PRINT '("The radius is:",T30,F0.4,/,&
           "The area is:",T30,F0.4,/,&
           "The circumference is:",T30,F0.4)', &
             acircle%radius, acircle%area,acircle%circum

end program circle_test


      REAL             FUNCTION PSQRT14( TRANS, M, N, NRHS, A, IA, JA,
     $                                   DESCA, X, IX, JX, DESCX, WORK )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            IA, IX, JA, JX, M, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCX( * )
      REAL               A( * ), WORK( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  PSQRT14 checks whether sub( X ) is in the row space of sub( A ) or
*  sub( A )', where sub( A ) denotes A( IA:IA+M-1, JA:JA+N-1 ) and
*  sub( X ) denotes X( IX:IX+N-1, JX:JX+NRHS-1 ) if TRANS = 'N', and
*  X( IX:IX+N-1, JX:JX+NRHS-1 ) otherwise.  It does so by scaling both
*  sub( X ) and sub( A ) such that their norms are in the range
*  [sqrt(eps), 1/sqrt(eps)], then computing an LQ factorization of
*  [sub( A )',sub( X )]' (if TRANS = 'N') or a QR factorization of
*  [sub( A ),sub( X )] otherwise, and returning the norm of the trailing
*  triangle, scaled by MAX(M,N,NRHS)*eps.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  TRANS   (global input) CHARACTER*1
*          = 'N':  No transpose, check for sub( X ) in the row space of
*                  sub( A ),
*          = 'T':  Transpose, check for sub( X ) in row space of
*                  sub( A )'.
*
*  M       (global input) INTEGER
*          The number of rows to be operated on, i.e. the number of rows
*          of the distributed submatrix sub( A ). M >= 0.
*
*  N       (global input) INTEGER
*          The number of columns to be operated on, i.e. the number of
*          columns of the distributed submatrix sub( A ). N >= 0.
*
*  NRHS    (global input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the distributed submatrix sub( X ). NRHS >= 0.
*
*  A       (local input) REAL pointer into the local memory
*          to an array of dimension (LLD_A, LOCc(JA+N-1)). This array
*          contains the local pieces of the M-by-N distributed matrix
*          sub( A ).
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  X       (local input) REAL pointer into the local
*          memory to an array of dimension (LLD_X,LOCc(JX+NRHS-1)).
*          On entry, this array contains the local pieces of the
*          N-by-NRHS distributed submatrix sub( X ) if TRANS = 'N',
*          and the M-by-NRHS distributed submatrix sub( X ) otherwise.
*
*  IX      (global input) INTEGER
*          The row index in the global array X indicating the first
*          row of sub( X ).
*
*  JX      (global input) INTEGER
*          The column index in the global array X indicating the
*          first column of sub( X ).
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*
*  WORK    (local workspace) REAL array dimension (LWORK)
*          If TRANS='N', LWORK >= MNRHSP * NQ + LTAU + LWF and
*          LWORK >= MP * NNRHSQ + LTAU + LWF otherwise, where
*
*          IF TRANS='N', (LQ fact)
*            MNRHSP = NUMROC( M+NRHS+IROFFA, MB_A, MYROW, IAROW,
*                             NPROW )
*            LTAU   = NUMROC( IA+MIN( M+NRHS, N )-1, MB_A, MYROW,
*                             RSRC_A, NPROW )
*            LWF    = MB_A * ( MB_A + MNRHSP + NQ0 )
*          ELSE         (QR fact)
*            NNRHSQ = NUMROC( N+NRHS+ICOFFA, NB_A, MYCOL, IACOL,
*                             NPCOL )
*            LTAU   = NUMROC( JA+MIN( M, N+NRHS )-1, NB_A, MYCOL,
*                             CSRC_A, NPCOL )
*            LWF    = NB_A * ( NB_A + MP0 + NNRHSQ )
*          END IF
*
*          and,
*
*          IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ),
*          IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
*          IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
*          MP0 = NUMROC( M+IROFFA, MB_A, MYROW, IAROW, NPROW ),
*          NQ0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ).
*
*          INDXG2P and NUMROC are ScaLAPACK tool functions;
*          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
*          the subroutine BLACS_GRIDINFO.
*
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               ONE, ZERO
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            TPSD
      INTEGER            IACOL, IAROW, ICOFFA, ICTXT, IDUM, IIA, INFO,
     $                   IPTAU, IPW, IPWA, IROFFA, IWA, IWX, J, JJA,
     $                   JWA, JWX, LDW, LWORK, MPWA, MPW, MQW, MYCOL,
     $                   MYROW, NPCOL, NPROW, NPW, NQWA, NQW
      REAL               AMAX, ANRM, ERR, XNRM
*     ..
*     .. Local Arrays ..
      INTEGER            DESCW( DLEN_ ), IDUM1( 1 ), IDUM2( 1 )
      REAL               RWORK( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            NUMROC
      REAL               PSLANGE, PSLAMCH
      EXTERNAL           LSAME, NUMROC, PSLANGE, PSLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DESCSET, INFOG2L, PSAMAX,
     $                   PSCOPY, PSGELQF, PSGEQRF, PSLACPY,
     $                   PSLASCL, PXERBLA, SGAMX2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, MOD, REAL
*     ..
*     .. Executable Statements ..
*
*     Get grid parameters
*
      ICTXT = DESCA( CTXT_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
      PSQRT14 = ZERO
*
      IPWA = 1
      IROFFA = MOD( IA-1, DESCA( MB_ ) )
      ICOFFA = MOD( JA-1, DESCA( NB_ ) )
      IWA = IROFFA + 1
      JWA = ICOFFA + 1
      CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA,
     $              JJA, IAROW, IACOL )
      MPWA = NUMROC( M+IROFFA, DESCA( MB_ ), MYROW, IAROW, NPROW )
      NQWA = NUMROC( N+ICOFFA, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
*
      INFO = 0
      IF( LSAME( TRANS, 'N' ) ) THEN
         IF( N.LE.0 .OR. NRHS.LE.0 )
     $      RETURN
         TPSD = .FALSE.
         MPW = NUMROC( M+NRHS+IROFFA, DESCA( MB_ ), MYROW, IAROW,
     $                 NPROW )
         NQW = NQWA
*
*        Assign descriptor DESCW for workspace WORK and pointers to
*        matrices sub( A ) and sub( X ) in workspace
*
         IWX = IWA + M
         JWX = JWA
         LDW = MAX( 1, MPW )
         CALL DESCSET( DESCW, M+NRHS+IROFFA, N+ICOFFA, DESCA( MB_ ),
     $                 DESCA( NB_ ), IAROW, IACOL, ICTXT, LDW )
*
      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
         IF( M.LE.0 .OR. NRHS.LE.0 )
     $      RETURN
         TPSD = .TRUE.
         MPW = MPWA
         NQW = NUMROC( N+NRHS+ICOFFA, DESCA( NB_ ), MYCOL, IACOL,
     $                 NPCOL )
*
*        Assign descriptor DESCW for workspace WORK and pointers to
*        matrices sub( A ) and sub( X ) in workspace
*
         IWX = IWA
         JWX = JWA + N
         LDW = MAX( 1, MPW )
         CALL DESCSET( DESCW, M+IROFFA, N+NRHS+ICOFFA, DESCA( MB_ ),
     $                 DESCA( NB_ ), IAROW, IACOL, ICTXT, LDW )
      ELSE
         CALL PXERBLA( ICTXT, 'PSQRT14', -1 )
         RETURN
      END IF
*
*     Copy and scale sub( A )
*
      IPTAU = IPWA + MPW*NQW
      CALL PSLACPY( 'All', M, N, A, IA, JA, DESCA, WORK( IPWA ), IWA,
     $              JWA, DESCW )
      RWORK( 1 ) = ZERO
      ANRM = PSLANGE( 'M', M, N, WORK( IPWA ), IWA, JWA, DESCW, RWORK )
      IF( ANRM.NE.ZERO )
     $   CALL PSLASCL( 'G', ANRM, ONE, M, N, WORK( IPWA ), IWA,
     $                 JWA, DESCW, INFO )
*
*     Copy sub( X ) or sub( X )' into the right place and scale it
*
      IF( TPSD ) THEN
*
*        Copy sub( X ) into columns jwa+n:jwa+n+nrhs-1 of work
*
         DO 10 J = 1, NRHS
            CALL PSCOPY( M, X, IX, JX+J-1, DESCX, 1, WORK( IPWA ), IWX,
     $                   JWX+J-1, DESCW, 1 )
   10    CONTINUE
         XNRM = PSLANGE( 'M', M, NRHS, WORK( IPWA ), IWX, JWX, DESCW,
     $                   RWORK )
         IF( XNRM.NE.ZERO )
     $      CALL PSLASCL( 'G', XNRM, ONE, M, NRHS, WORK( IPWA ), IWX,
     $                    JWX, DESCW, INFO )
*
*        Compute QR factorization of work(iwa:iwa+m-1,jwa:jwa+n+nrhs-1)
*
         MQW = NUMROC( M+ICOFFA, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
         IPW = IPTAU + MIN( MQW, NQW )
         LWORK = DESCW( NB_ ) * ( MPW + NQW + DESCW( NB_ ) )
         CALL PSGEQRF( M, N+NRHS, WORK( IPWA ), IWA, JWA, DESCW,
     $                WORK( IPTAU ), WORK( IPW ), LWORK, INFO )
*
*        Compute largest entry in upper triangle of
*        work(iwa+n:iwa+m-1,jwa+n:jwa+n+nrhs-1)
*
         ERR = ZERO
         IF( N.LT.M ) THEN
            DO 20 J = JWX, JWA+N+NRHS-1
               CALL PSAMAX( MIN(M-N,J-JWX+1), AMAX, IDUM, WORK( IPWA ),
     $                      IWA+N, J, DESCW, 1 )
               ERR = MAX( ERR, ABS( AMAX ) )
   20       CONTINUE
         END IF
         CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, IDUM1, IDUM2,
     $                 -1, -1, 0 )
*
      ELSE
*
*        Copy sub( X )' into rows iwa+m:iwa+m+nrhs-1 of work
*
         DO 30 J = 1, NRHS
            CALL PSCOPY( N, X, IX, JX+J-1, DESCX, 1, WORK( IPWA ),
     $                   IWX+J-1, JWX, DESCW, DESCW( M_ ) )
   30    CONTINUE
*
         XNRM = PSLANGE( 'M', NRHS, N, WORK( IPWA ), IWX, JWX, DESCW,
     $                   RWORK )
         IF( XNRM.NE.ZERO )
     $      CALL PSLASCL( 'G', XNRM, ONE, NRHS, N, WORK( IPWA ), IWX,
     $                    JWX, DESCW, INFO )
*
*        Compute LQ factorization of work(iwa:iwa+m+nrhs-1,jwa:jwa+n-1)
*
         NPW = NUMROC( N+IROFFA, DESCA( MB_ ), MYROW, IAROW, NPROW )
         IPW = IPTAU + MIN( MPW, NPW )
         LWORK = DESCW( MB_ ) * ( MPW + NQW + DESCW( MB_ ) )
         CALL PSGELQF( M+NRHS, N, WORK( IPWA ), IWA, JWA, DESCW,
     $                 WORK( IPTAU ), WORK( IPW ), LWORK, INFO )
*
*        Compute largest entry in lower triangle in
*        work(iwa+m:iwa+m+nrhs-1,jwa+m:jwa+n-1)
*
         ERR = ZERO
         DO 40 J = JWA+M, MIN( JWA+N-1, JWA+M+NRHS-1 )
            CALL PSAMAX( JWA+M+NRHS-J, AMAX, IDUM, WORK( IPWA ),
     $                   IWX+J-JWA-M, J, DESCW, 1 )
            ERR = MAX( ERR, ABS( AMAX ) )
   40    CONTINUE
         CALL SGAMX2D( ICTXT, 'All', ' ', 1, 1, ERR, 1, IDUM1, IDUM2,
     $                 -1, -1, 0 )
*
      END IF
*
      PSQRT14 = ERR / ( REAL( MAX( M, N, NRHS ) ) *
     $          PSLAMCH( ICTXT, 'Epsilon' ) )
*
      RETURN
*
*     End of PSQRT14
*
      END


      subroutine g2    (cos,sin,x,y)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1972 dec 15
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   apply the rotation computed by g1 to (x,y).
      xr=cos*x+sin*y
      y=-sin*x+cos*y
      x=xr
      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARSUE (Zomplex Auxiliary Routine Sort Unimodular Eigenpairs)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine sorts the eigenvalues and optionally eigenvectors of a
! unitary matrix. The eigenpairs are sorted in ascending order of the
! argument of the eigenvalue.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  JOB            CHARACTER
!                    'E': just eigenvalues
!                    'V': eigenvectors also
!
!  N              INTEGER
!                    dimension of matrix
!
!  E              REAL(8) array of dimension (2*N)
!                    array of eigenvalues
!
!  Z              COMPLEX(8) array of dimension (N,N)
!                   if JOB = 'E' unused
!                   if JOB = 'V' sort Z as well
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies JOB is invalid
!                   INFO = -2 implies N is invalid
!                   INFO = -3 implies E is invalid
!                   INFO = -4 implies Z is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARSUE(JOB,N,E,Z,INFO)

  ! input variables
  character, intent(in) :: JOB
  integer, intent(in) :: N
  real(8), intent(inout) :: E(2*N)
  complex(8), intent(inout) :: Z(N,N)
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii, jj, ind
  real(8), parameter :: PI = 3.14159265358979323846264338327950d0
  real(8) :: theta1, theta2
  real(8) :: tol, nrm, temp
  complex(8) :: ztmp

  ! set tol
  tol = 10d0*epsilon(1d0)

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check JOB
    if ((JOB.NE.'E').AND.(JOB.NE.'V')) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"JOB must be 'E' or 'V'",INFO,INFO)
      return
    end if

    ! check N
    call IARNAN(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    call IARINF(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    if (N < 2) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check E
    call DARACH1(2*N,E,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"E is invalid",INFO,-3)
      return
    end if
    do ii=1,N
      nrm = sqrt(E(2*ii-1)**2 + E(2*ii)**2)
      if (abs(nrm-1d0) > tol) then
        INFO = -3
        call UARERR(__FILE__,__LINE__,"E is not unimodular",INFO,INFO)
        return
      end if
    end do

    ! check Z
    if (JOB.EQ.'V') then
      call ZARACH2(N,N,Z,INFO)
      if (INFO.NE.0) then
        call UARERR(__FILE__,__LINE__,"Z is invalid",INFO,-4)
        return
      end if
    end if

  end if

  ! loop through E
  do ii=1,(N-1)

    ! find index of smallest arg
    ! initialize index
    ind = ii

    ! compute theta1
    call ZARNAR(E(2*ind-1),E(2*ind),theta1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZARNAR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! check rest of E
    do jj=(ii+1),N
      ! compute theta2
      call ZARNAR(E(2*jj-1),E(2*jj),theta2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"ZARNAR failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! update if smaller
      if (theta2 < theta1) then
        ind = jj
        theta1 = theta2
      end if

    end do

    ! swap eigenvalues
    if (ind.NE.ii) then
      temp = E(2*ii-1)
      E(2*ii-1) = E(2*ind-1)
      E(2*ind-1) = temp
      temp = E(2*ii)
      E(2*ii) = E(2*ind)
      E(2*ind) = temp
    end if

    ! swap eigenvectors
    if ((ind.NE.ii).AND.(JOB.EQ.'V')) then
      do jj=1,N
        ztmp = Z(jj,ii)
        Z(jj,ii) = Z(jj,ind)
        Z(jj,ind) = ztmp
      end do
    end if
  end do

end subroutine ZARSUE


program test_mrabmethod
  use MRAB, only: dagrt_state_type, &
    timestep_initialize => initialize, &
    timestep_run => run, &
    timestep_shutdown => shutdown

  implicit none

  type(dagrt_state_type), target :: state
  type(dagrt_state_type), pointer :: state_ptr

  real*8, dimension(2) :: initial_condition
  real*8, dimension(1) :: true_sol_fast, true_sol_slow
  integer, dimension(2) :: ntrips

  integer run_count
  real*8 t_fin
  parameter (run_count=2, t_fin=50d-0)

  real*8, dimension(run_count):: dt_values, error_slow, error_fast

  real*8 min_order, est_order_fast, est_order_slow
  real*8 err_slow, err_fast
  real*8 max_err_slow, max_err_fast
  real*8 max_val_slow, max_val_fast

  integer stderr
  parameter(stderr=0)

  integer irun

  ! start code ----------------------------------------------------------------

  state_ptr => state

  initial_condition(1) = (exp(0d0))*cos(0d0) ! fast
  initial_condition(2) = (exp(0d0))*sin(0d0) ! slow

  ntrips(1) = NUM_TRIPS_ONE
  ntrips(2) = NUM_TRIPS_TWO

  do irun = 1,run_count
    dt_values(irun) = t_fin/ntrips(irun)

    call timestep_initialize( &
      dagrt_state=state_ptr, &
      state_slow=initial_condition(2:2), &
      state_fast=initial_condition(1:1), &
      dagrt_t=0d0, &
      dagrt_dt=dt_values(irun))

    max_err_fast = 0
    max_val_fast = 0
    max_err_slow = 0
    max_val_slow = 0

    do
      call timestep_run(dagrt_state=state_ptr)

      if (.not.isnan(state%ret_time_fast)) then
        true_sol_fast = (exp(state%ret_time_fast))*cos(state%ret_time_fast)
        true_sol_slow = (exp(state%ret_time_slow))*sin(state%ret_time_slow)

        err_slow = abs(true_sol_slow(1) - state%ret_state_slow(1))
        err_fast = abs(true_sol_fast(1) - state%ret_state_fast(1))

        max_err_slow = max(max_err_slow, err_slow)
        max_err_fast = max(max_err_fast, err_fast)

        max_val_slow = max(max_val_slow, abs(true_sol_slow(1)))
        max_val_fast = max(max_val_fast, abs(true_sol_fast(1)))
        !write(27,*) state%ret_time_slow, err_slow, true_sol_slow
        !write(28,*) state%ret_time_fast, err_fast, true_sol_fast

      endif

      if (state%ret_time_fast.ge.t_fin - 1d-10) then
        exit
      endif
    end do
    !write(27,*) ''
    !write(28,*) ''

    write(*,*) 'end time slow:', state%ret_time_slow
    write(*,*) 'end time fast:', state%ret_time_fast

    error_slow(irun) = max_err_slow/max_val_slow
    error_fast(irun) = max_err_fast/max_val_fast

    call timestep_shutdown(dagrt_state=state_ptr)
    write(*,*) 'done', dt_values(irun), '  ', &
      'err_slow: ', error_slow(irun), '  ', &
      'err_fast: ', error_fast(irun)
  enddo

  min_order = MIN_ORDER
  est_order_slow = log(error_slow(2)/error_slow(1))/log(dt_values(2)/dt_values(1))
  est_order_fast = log(error_fast(2)/error_fast(1))/log(dt_values(2)/dt_values(1))

  write(*,*) 'estimated order slow:', est_order_slow
  if (est_order_slow < min_order) then
    write(stderr,*) 'ERROR: achieved order too low:', est_order_slow, ' < ', &
        min_order
  endif

  write(*,*) 'estimated order fast:', est_order_fast
  if (est_order_fast < min_order) then
    write(stderr,*) 'ERROR: achieved order too low:', est_order_fast, ' < ', &
        min_order
  endif

end program


c> \file dcstep.f

c> \brief This subroutine computes a safeguarded step for a search
c>        procedure and updates an interval that contains a step that
c>        satisfies a sufficient decrease and a curvature condition.
c>
c> This subroutine computes a safeguarded step for a search
c> procedure and updates an interval that contains a step that
c> satisfies a sufficient decrease and a curvature condition.
c>
c> The parameter stx contains the step with the least function
c> value. If brackt is set to .true. then a minimizer has
c> been bracketed in an interval with endpoints stx and sty.
c> The parameter stp contains the current step.
c> The subroutine assumes that if brackt is set to .true. then
c>
c>       min(stx,sty) < stp < max(stx,sty),
c>
c> and that the derivative at stx is negative in the direction
c> of the step.
c>
c> @param stx On entry stx is the best step obtained so far and is an
c>               endpoint of the interval that contains the minimizer.

c>            On exit stx is the updated best step.
c>
c> @param fx On entry fx is the function at stx.

c>           On exit fx is the function at stx.
c>
c> @param dx On entry dx is the derivative of the function at
c>              stx. The derivative must be negative in the direction of
c>              the step, that is, dx and stp - stx must have opposite
c>              signs.

c>           On exit dx is the derivative of the function at stx.
c>
c> @param sty On entry sty is the second endpoint of the interval that
c>               contains the minimizer.

c>            On exit sty is the updated endpoint of the interval that
c>               contains the minimizer.
c>
c> @param fy On entry fy is the function at sty.

c>           On exit fy is the function at sty.
c>
c> @param dy On entry dy is the derivative of the function at sty.

c>           On exit dy is the derivative of the function at the exit sty.
c>
c> @param stp On entry stp is the current step. If brackt is set to .true.
c>               then on input stp must be between stx and sty.

c>            On exit stp is a new trial step.
c>
c> @param fp On entry fp is the function at stp.

c>           On exit fp is unchanged.
c>
c> @param dp On entry dp is the the derivative of the function at stp.

c>           On exit dp is unchanged.
c>
c> @param brackt On entry brackt specifies if a minimizer has been bracketed.
c>                  Initially brackt must be set to .false.

c>               On exit brackt specifies if a minimizer has been bracketed.
c>                  When a minimizer is bracketed brackt is set to .true.
c>
c> @param stpmin On entry stpmin is a lower bound for the step.

c>               On exit stpmin is unchanged.
c>
c> @param stpmax On entry stpmax is an upper bound for the step.

c>               On exit stpmax is unchanged.
      subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt,
     +                  stpmin,stpmax)
      logical brackt
      double precision stx,fx,dx,sty,fy,dy,stp,fp,dp,stpmin,stpmax
c
c     MINPACK-1 Project. June 1983
c     Argonne National Laboratory.
c     Jorge J. More' and David J. Thuente.
c
c     MINPACK-2 Project. October 1993.
c     Argonne National Laboratory and University of Minnesota.
c     Brett M. Averick and Jorge J. More'.
c
c     **********
      double precision zero,p66,two,three
      parameter(zero=0.0d0,p66=0.66d0,two=2.0d0,three=3.0d0)

      double precision gamma,p,q,r,s,sgnd,stpc,stpf,stpq,theta

      sgnd = dp*(dx/abs(dx))

c     First case: A higher function value. The minimum is bracketed.
c     If the cubic step is closer to stx than the quadratic step, the
c     cubic step is taken, otherwise the average of the cubic and
c     quadratic steps is taken.

      if (fp .gt. fx) then
         theta = three*(fx - fp)/(stp - stx) + dx + dp
         s = max(abs(theta),abs(dx),abs(dp))
         gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s))
         if (stp .lt. stx) gamma = -gamma
         p = (gamma - dx) + theta
         q = ((gamma - dx) + gamma) + dp
         r = p/q
         stpc = stx + r*(stp - stx)
         stpq = stx + ((dx/((fx - fp)/(stp - stx) + dx))/two)*
     +                                                       (stp - stx)
         if (abs(stpc-stx) .lt. abs(stpq-stx)) then
            stpf = stpc
         else
            stpf = stpc + (stpq - stpc)/two
         endif
         brackt = .true.

c     Second case: A lower function value and derivatives of opposite
c     sign. The minimum is bracketed. If the cubic step is farther from
c     stp than the secant step, the cubic step is taken, otherwise the
c     secant step is taken.

      else if (sgnd .lt. zero) then
         theta = three*(fx - fp)/(stp - stx) + dx + dp
         s = max(abs(theta),abs(dx),abs(dp))
         gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s))
         if (stp .gt. stx) gamma = -gamma
         p = (gamma - dp) + theta
         q = ((gamma - dp) + gamma) + dx
         r = p/q
         stpc = stp + r*(stx - stp)
         stpq = stp + (dp/(dp - dx))*(stx - stp)
         if (abs(stpc-stp) .gt. abs(stpq-stp)) then
            stpf = stpc
         else
            stpf = stpq
         endif
         brackt = .true.

c     Third case: A lower function value, derivatives of the same sign,
c     and the magnitude of the derivative decreases.

      else if (abs(dp) .lt. abs(dx)) then

c        The cubic step is computed only if the cubic tends to infinity
c        in the direction of the step or if the minimum of the cubic
c        is beyond stp. Otherwise the cubic step is defined to be the
c        secant step.

         theta = three*(fx - fp)/(stp - stx) + dx + dp
         s = max(abs(theta),abs(dx),abs(dp))

c        The case gamma = 0 only arises if the cubic does not tend
c        to infinity in the direction of the step.

         gamma = s*sqrt(max(zero,(theta/s)**2-(dx/s)*(dp/s)))
         if (stp .gt. stx) gamma = -gamma
         p = (gamma - dp) + theta
         q = (gamma + (dx - dp)) + gamma
         r = p/q
         if (r .lt. zero .and. gamma .ne. zero) then
            stpc = stp + r*(stx - stp)
         else if (stp .gt. stx) then
            stpc = stpmax
         else
            stpc = stpmin
         endif
         stpq = stp + (dp/(dp - dx))*(stx - stp)

         if (brackt) then

c           A minimizer has been bracketed. If the cubic step is
c           closer to stp than the secant step, the cubic step is
c           taken, otherwise the secant step is taken.

            if (abs(stpc-stp) .lt. abs(stpq-stp)) then
               stpf = stpc
            else
               stpf = stpq
            endif
            if (stp .gt. stx) then
               stpf = min(stp+p66*(sty-stp),stpf)
            else
               stpf = max(stp+p66*(sty-stp),stpf)
            endif
         else

c           A minimizer has not been bracketed. If the cubic step is
c           farther from stp than the secant step, the cubic step is
c           taken, otherwise the secant step is taken.

            if (abs(stpc-stp) .gt. abs(stpq-stp)) then
               stpf = stpc
            else
               stpf = stpq
            endif
            stpf = min(stpmax,stpf)
            stpf = max(stpmin,stpf)
         endif

c     Fourth case: A lower function value, derivatives of the same sign,
c     and the magnitude of the derivative does not decrease. If the
c     minimum is not bracketed, the step is either stpmin or stpmax,
c     otherwise the cubic step is taken.

      else
         if (brackt) then
            theta = three*(fp - fy)/(sty - stp) + dy + dp
            s = max(abs(theta),abs(dy),abs(dp))
            gamma = s*sqrt((theta/s)**2 - (dy/s)*(dp/s))
            if (stp .gt. sty) gamma = -gamma
            p = (gamma - dp) + theta
            q = ((gamma - dp) + gamma) + dy
            r = p/q
            stpc = stp + r*(sty - stp)
            stpf = stpc
         else if (stp .gt. stx) then
            stpf = stpmax
         else
            stpf = stpmin
         endif
      endif

c     Update the interval which contains a minimizer.

      if (fp .gt. fx) then
         sty = stp
         fy = fp
         dy = dp
      else
         if (sgnd .lt. zero) then
            sty = stx
            fy = fx
            dy = dx
         endif
         stx = stp
         fx = fp
         dx = dp
      endif

c     Compute the new step.

      stp = stpf

      return
      end


program operator_overloading

    use vector_operations

    implicit none

    type(vector) :: v1
    type(vector) :: v2
    type(vector) :: v

    v1 % components = (/1.0, 0.0, 0.0/)
    v2 % components = (/0.0, 1.0, 0.0/)

    v = v1 + v2

    print *, v

end program operator_overloading


MULTF(I,J)=I*J


!     Floating point initialization of integer parameter

!     Make sure partial eval is OK

      program main

      integer*4 i
      parameter ( i = 100 )
      integer*4 j
      parameter ( j = i*0.1 )

      integer*4 array

      common / C1 /
     *     array(j)

      array(1) = 2*j
      print *,array(1)

      end


!Recordemos que fortran nos permite utilizar operadores de comparaciôn
program comparacion
!Los operadores de comparaciôn son los siguientes:
! == o .eq.
! /= o .ne.
! > o .gt.
! < o .lt.
! >= o .ge.
! <= o .le.

real a, b
complex z1, z2

a = 2
b = a

z1 = (1, 1)
z2 = z1
! Vamos a utilizar .eqv. que es para coparar valores lógicos. Esto sólo para demostrar que los operadores son lo mismo.
print *, "(a == b) .eqv. (a .eq. b):", (a == b) .eqv. (a .eq. b)
print *, "(a /= b) .eqv. (a .ne. b):", (a /= b) .eqv. (a .ne. b)
print *, "(a > b) .eqv. (a .gt. b):", (a > b) .eqv. (a .gt. b)
print *, "(a < b) .eqv. (a .lt. b):", (a < b) .eqv. (a .lt. b)
print *, "(a >= b) .eqv. (a .ge. b):", (a >= b) .eqv. (a .ge. b)
print *, "(a <= b) .eqv. (a .le. b):", (a <= b) .eqv. (a .le. b)

end program comparacion


program scratch_file
implicit none
integer, parameter :: iu = 10, n = 25
integer :: i,isq(n)
character (len=100) :: file_name
! no name given for scratch file below
open (unit=iu,status="scratch",action="readwrite")
write (iu,"(i0)") (10*i**2,i=1,n) ! write data
inquire (unit=iu,name=file_name)
print*,"wrote to " // trim(file_name)
! rewind file so it can be read, since it cannot be
! reopened after it is closed
rewind (iu)
read (iu,*) isq
print*,isq([1,n]) ! 10 6250
end program scratch_file
! Intel Fortran sample output:
! wrote to C:\Users\name\AppData\Local\Temp\FORC5A7.tmp
!          10        6250


! { dg-do run { target fd_truncate } }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }
!
! PR fortran/34427
!
! Check that namelists and the real values Inf, NaN, Infinity
! properly coexist.
!
 PROGRAM TEST
  IMPLICIT NONE
  real , DIMENSION(11) ::foo
  integer :: infinity
  NAMELIST /nl/ foo
  NAMELIST /nl/ infinity
  foo = -1.0
  infinity = -1

  open (10, status="scratch")
! Works:
  write (10,*) " &nl foo = 5, 5, 5, nan, infinity, infinity "
  write (10,*)
  write (10,*) "      = 1, /"
  rewind (10)
  READ (10, NML = nl)
  close (10)

  if(infinity /= 1) STOP 1
  if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) &
     .or. foo(5) <= huge(foo) .or. any(foo(6:11) /= -1.0)) &
    STOP 2
! Works too:
  foo = -1.0
  infinity = -1

  open (10, status="scratch")
  rewind (10)
  write (10,'(a)') "&nl foo = 5, 5, 5, nan, infinity, infinity"
  write (10,'(a)') "=1,/"
  rewind (10)
  READ (10, NML = nl)
  CLOSE (10)

  if(infinity /= 1) STOP 3
  if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) &
     .or. foo(5) <= huge(foo) .or. any(foo(6:11) /= -1.0)) &
    STOP 4
 END PROGRAM TEST


!---------------------------------------------------------------
! Sort an index-array and an index-index array by a double array target
!---------------------------------------------------------------

! use quicksort
subroutine qcolsort(array_size, indexi, index, value)
   implicit none
   integer, parameter :: dp = selected_real_kind(15, 307)
   integer, parameter :: QSORT_THRESHOLD = 32
   integer, intent(in) :: array_size
   integer, intent(inout) :: index(array_size)
   integer, intent(inout) :: indexi(array_size)
   real(dp), intent(in) :: value(array_size)

   include "qsort_inline.inc"
contains
   include "colsort.inc"
end subroutine qcolsort

! use insertion sort
subroutine icolsort(array_size, indexi, index, value)
   implicit none
   integer, parameter :: dp = selected_real_kind(15, 307)
   integer, intent(in) :: array_size
   integer, intent(inout) :: index(array_size)
   integer, intent(inout) :: indexi(array_size)
   real(dp), intent(in) :: value(array_size)

   integer :: left, right
   do right = 2, array_size
      left = right - 1
      if (less_than(right, left)) then
         do  ! need two separate if's since fortran has no short circuit "&&"
            if (left < 2) exit
            if (.NOT. less_than(right, left - 1)) exit
            left = left - 1
         enddo
         call rshift(left, right)
      endif
   enddo
contains
   include "colsort.inc"
end subroutine icolsort


! { dg-do compile }
      program bug
      implicit none
      complex(kind=8) z
      double precision x,y
      z = cmplx(1.e0_8,2.e0_8)
      y = imag(z)
      y = imagpart(z)
      x = realpart(z)
      end


C     LAST UPDATE 10/12/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SCANS(BUF,GSTOPN,VALS,NV)
      IMPLICIT NONE
C
C Purpose: Does line plots and peak fits.
C
C Calls   8: ASK    , PAPER  , PSPACE , FILNAM , FPLOT  , ERASE  ,
C            GREND  , RDCOMF
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
      INCLUDE 'FIT.COM'
C
C Arguments:
C
      REAL BUF(NPIX*NRAST)
      LOGICAL GSTOPN
      REAL VALS(10)
      INTEGER NV
C
C Local variables:
C
      REAL LBUF(MAXDIM)
      REAL*8 ASTDER(MAXPAR)
      REAL AREA,PI,X,Y,DX,DY,VECX,VECY,DIST,SHAPE,X0,Y0,DX1,DY1,DX2,DY2,
     &     PHI1,PHI2,DPHI,PHI,R,RTOD,R1,R2
      INTEGER IVAL(10),ITEM(1)
      INTEGER I,J,K,L,M,IX,IY,IRC,KUNIT,LUNIT,NCHAN,N,NW,NL,JOP,ICLO,
     &        IMEM
      LOGICAL REPLY
      CHARACTER*10 WORD
      CHARACTER*80 OFNAM,HEAD1,HEAD2
C
C FPLOT declarations:
C
      REAL*8 A(MAXPAR)
      REAL XPOS(MAXDIM),SIG(MAXDIM)
      INTEGER NFRAMI,IFLAG
      LOGICAL REPT,FIT,HCOPY,INIT,XAXIS,AUTO
      CHARACTER*12 CTYPE(5)
c++++++++GHOST++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c      CHARACTER*80 NAMFIL
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C External function:
C
      REAL PSNINT,VGTINT
      EXTERNAL PSNINT,VGTINT
c++++++++PGPLOT+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      INTEGER PGBEG
      EXTERNAL PGBEG
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Common block:
C
      INTEGER NPEAKS,NBAK,FEXP,NSELPK,KORIG
      LOGICAL LATCON
      DOUBLE PRECISION XORIG
      INTEGER FTYPE(20),VTABLE(MAXPAR)
      COMMON /FCOM  /NPEAKS,NBAK,FEXP,FTYPE,VTABLE,NSELPK
      COMMON /FCOM2 /XORIG,KORIG,LATCON
C
C Data:
C
      DATA  KUNI T/12/ , LUNIT /13/ , NFRAMI /0/ , IMEM /1/
      DATA  PI /3.1415927/ , RTOD /57.2957795/
      DATA  CTYPE /'Gaussian    ' , 'Lorentzian  ' , 'Pearson VII ' ,
     &             'Voigt       ' , 'Debye       '/
      DATA INIT /.FALSE./ , REPT /.FALSE./ , XAXIS /.TRUE./ ,
     &     AUTO /.FALSE./
C
C-----------------------------------------------------------------------
      IF(NSCAN.EQ.0)RETURN
C
C========Initialize graphics
C
      IF(.NOT.GSTOPN)THEN
c++++++++GHOST++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c         CALL PAPER(1)
c         CALL PSPACE(0.1,0.9,0.1,0.9)
c         CALL GPSTOP(0)
c++++++++PGPLOT+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         IRC = PGBEG(0,'/XWINDOW',1,1)
         IF(IRC.NE.1)GOTO 9999
         CALL PGPAP(6.0,0.7)
         CALL PGASK(.FALSE.)
         CALL PGSCIR(1,15)
         CALL PGSVP(0.1,0.9,0.1,0.9)
         CALL PGPAGE
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         GSTOPN = .TRUE.
      ENDIF
      IF(NV.EQ.0)THEN
         IVAL(1) = 1
         IVAL(2) = NSCAN
         NV = 2
      ELSE
         DO 25 I=1,NV
            IVAL(I) = NINT(VALS(I))
 25      CONTINUE
      ENDIF
C
C========Prompt for peak fitting
C
      FIT = .FALSE.
      CALL ASK('702 Do you want to fit the data',FIT,0)
C
C========Prompt for hardcopy output
C
      HCOPY = .FALSE.
c++++++++GHOST+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c      CALL ASK('Do you require hardcopy output',HCOPY,0)
c      IF(HCOPY)THEN
c         WRITE(6,1000)
c         READ(5,'(A80)',ERR=9999,END=9999)NAMFIL
c         CALL FILNAM(NAMFIL)
c      ENDIF
c++++++++PGPLOT+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C========No hardcopy at present
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      WRITE(6,'(/)')
C
C========Start main loop
C
      DO 60 I=1,NV,2
         IF(I+1.GT.NV)IVAL(I+1) = IVAL(I)
         DO 50 J=IVAL(I),IVAL(I+1)
            DX1 = XSCAN(1,J) - XCSCAN(J)
            DY1 = YCSCAN(J) - YSCAN(1,J)
            DX2 = XSCAN(2,J) - XCSCAN(J)
            DY2 = YCSCAN(J) - YSCAN(2,J)
            R1 = SQRT(DX1*DX1+DY1*DY1)
            R2 = SQRT(DX2*DX2+DY2*DY2)
            PHI1 = ATAN2(DY1,DX1)
            PHI2 = ATAN2(DY2,DX2)
            IF(PHI2.LT.PHI1)PHI2 = PHI2 + 2.0*PI
            IF(RADIAL)THEN
C
C========Interpolate between end points
C
               DIST = ABS(R2-R1)
               IF(INT(DIST).GT.MAXDIM)THEN
                  NCHAN = MAXDIM
                  DIST = FLOAT(NCHAN)
               ELSE
                  NCHAN = INT(DIST)
               ENDIF
               VECX = COS(PHI1)*(R2-R1)/DIST
               VECY = SIN(PHI1)*(R2-R1)/DIST
               DO 30 K=1,NCHAN
                  X0 = DX1 + FLOAT(K)*VECX
                  Y0 = DY1 + FLOAT(K)*VECY
                  LBUF(K) = 0.0
                  R = SQRT(X0*X0+Y0*Y0)
                  NL = NINT(R*ABS(PHI2-PHI1))
                  DPHI = 1/R
                  DO 27 L=0,NL
                     PHI = FLOAT(L)*DPHI
                     X = XCSCAN(J) + X0*COS(PHI) - Y0*SIN(PHI)
                     Y = YCSCAN(J) - X0*SIN(PHI) - Y0*COS(PHI)
                     IX = INT(X)
                     IY = INT(Y)
                     IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &                  IY.GE.1.AND.IY.LT.NRAST)THEN
                        M = (IY-1)*NPIX + IX
                        DX = X - FLOAT(IX)
                        DY = Y - FLOAT(IY)
                        LBUF(K) = LBUF(K)
     &                          + (1.0-DX)*(1.0-DY)*BUF(M)
     &                          +       DX*(1.0-DY)*BUF(M+1)
     &                          +       (1.0-DX)*DY*BUF(M+NPIX)
     &                          +             DX*DY*BUF(M+NPIX+1)
                     ENDIF
 27               CONTINUE
                  LBUF(K) = LBUF(K)/FLOAT(NL+1)
                  XPOS(K) = R
                  SIG(K) = 1.0
 30            CONTINUE
            ELSE
               R = (R1+R2)/2.0
               DIST = ABS(R*(PHI2-PHI1))
               IF(INT(DIST).GT.MAXDIM)THEN
                  NCHAN = MAXDIM
                  DIST = FLOAT(NCHAN)
               ELSE
                  NCHAN = INT(DIST)
               ENDIF
               DPHI = (PHI2-PHI1)/DIST
               DO 32 K=1,NCHAN
                  PHI = PHI1 + FLOAT(K)*DPHI
                  X0 = XCSCAN(J) + R1*COS(PHI)
                  Y0 = YCSCAN(J) - R1*SIN(PHI)
                  LBUF(K) = 0.0
                  DX1 = R2 - R1
                  NL = NINT(ABS(DX1))
                  VECX = COS(PHI)*SIGN(1.0,DX1)
                  VECY = -SIN(PHI)*SIGN(1.0,DX1)
                  DO 31 L=0,NL
                     X = X0 + FLOAT(L)*VECX
                     Y = Y0 + FLOAT(L)*VECY
                     IX = INT(X)
                     IY = INT(Y)
                     IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &                  IY.GE.1.AND.IY.LT.NRAST)THEN
                        M = (IY-1)*NPIX + IX
                        DX = X - FLOAT(IX)
                        DY = Y - FLOAT(IY)
                        LBUF(K) = LBUF(K)
     &                          + (1.0-DX)*(1.0-DY)*BUF(M)
     &                          +       DX*(1.0-DY)*BUF(M+1)
     &                          +       (1.0-DX)*DY*BUF(M+NPIX)
     &                          +             DX*DY*BUF(M+NPIX+1)
                     ENDIF
 31               CONTINUE
                  LBUF(K) = LBUF(K)/FLOAT(NL+1)
                  XPOS(K) = PHI*RTOD
                  SIG(K) = 1.0
 32            CONTINUE
            ENDIF
C
C========Do plotting and fitting
C
            CALL FPLOT(LBUF,NCHAN,REPT,FIT,A,ASTDER,INIT,NFRAMI,
     &                 XPOS,SIG,XAXIS,AUTO,IFLAG)
C
C========Exit if GUI demands it (i.e. ^D received)
C
            IF(IFLAG.EQ.-2)GOTO 60
C
C========Interpret A and write out parameters
C
            IF(FIT.AND.IFLAG.EQ.0)THEN
               WRITE(KUNIT,1040)J,XCSCAN(J),YCSCAN(J),R1,R2,
     &                          RTOD*PHI1,RTOD*PHI2
               WRITE(6,1040)J,XCSCAN(J),YCSCAN(J),R1,R2,
     &                      RTOD*PHI1,RTOD*PHI2
               CALL FLUSH(6)
               M = 0
               DO 40 L=1,NPEAKS
                  IF(FTYPE(L).EQ.1.OR.FTYPE(L).EQ.2)THEN
                     A(M+3) = ABS(A(M+3))
                     IF(FTYPE(L).EQ.1)THEN
                        AREA = A(M+1)*A(M+3)*SQRT(PI)
                     ELSE
                        AREA = A(M+1)*A(M+3)*PI
                     ENDIF
                     SHAPE = 0.0
                     N = 3
                  ELSEIF(FTYPE(L).EQ.3.OR.FTYPE(L).EQ.4)THEN
                     IF(FTYPE(L).EQ.3)THEN
                        AREA = PSNINT(A(M+1),A(M+3),A(M+4))
                     ELSE
                        AREA = VGTINT(A(M+1),A(M+3),A(M+4))
                     ENDIF
                     SHAPE = A(M+4)
                     N = 4
                  ELSEIF(FTYPE(L).EQ.5)THEN
                     AREA = A(M+1)*A(M+3)*SQRT(PI)*8.0/3.0
                     SHAPE = 0.0
                     N = 3
                  ENDIF
                  WRITE(KUNIT,1050)L,(A(M+K),K=1,3),SHAPE,AREA,
     &                 CTYPE(FTYPE(L))
                  WRITE(6,1050)L,(A(M+K),K=1,3),SHAPE,AREA,
     &                 CTYPE(FTYPE(L))
                  WRITE(KUNIT,1055)(ASTDER(M+K),K=1,N)
                  WRITE(6,1055)(ASTDER(M+K),K=1,N)
                  CALL FLUSH(6)
                  M = M + N
 40            CONTINUE
C
C========Write out background polynomial coefficients
C
               WRITE(6,1060)NBAK,(K,K=0,4)
               WRITE(KUNIT,1060)NBAK,(K,K=0,4)
               WRITE(6,1070)(A(M+K),K=NBAK+1,1,-1)
               WRITE(KUNIT,1070)(A(M+K),K=NBAK+1,1,-1)
               WRITE(6,1075)(ASTDER(M+K),K=NBAK+1,1,-1)
               WRITE(KUNIT,1075)(ASTDER(M+K),K=NBAK+1,1,-1)
               IF(FEXP.GT.0)THEN
                  WRITE(6,1080)A(M+NBAK+2),A(M+NBAK+3)
                  WRITE(KUNIT,1080)A(M+NBAK+2),A(M+NBAK+3)
                  WRITE(6,1085)ASTDER(M+NBAK+2),ASTDER(M+NBAK+3)
                  WRITE(KUNIT,1085)ASTDER(M+NBAK+2),ASTDER(M+NBAK+3)
               ENDIF
               IF(LATCON)THEN
                  WRITE(6,1090)XORIG
                  WRITE(KUNIT,1090)XORIG
                  IF(KORIG.GT.0)THEN
                     WRITE(6,1095)ASTDER(KORIG)
                     WRITE(KUNIT,1095)ASTDER(KORIG)
                  ENDIF
               ENDIF
               CALL FLUSH(6)
               WRITE(6,1110)J
               CALL FLUSH(6)
            ENDIF
C
C========Prompt to save data as otoko file
C
            REPLY = .FALSE.
            CALL ASK('714 Save data as a new OTOKO file',REPLY,0)
            IF(REPLY)THEN
               CALL OUTFIL(5,6,OFNAM,HEAD1,HEAD2,IRC)
               IF(IRC.NE.0)THEN
                  WRITE(6,2010)
                  CALL FLUSH(6)
               ELSE
                  ICLO = 1
                  JOP = 0
                  CALL DAWRT(LUNIT,OFNAM,IMEM,NCHAN,1,HEAD1,HEAD2,
     &                       LBUF,I,JOP,ICLO,IRC)
                  IF(IRC.NE.0)THEN
                     WRITE(6,2020)
                     CALL FLUSH(6)
                  ENDIF
               ENDIF
            ENDIF
C
C========Wait until ready for next plot
C
            IF(.NOT.FIT)THEN
               WRITE(6,1100)
               CALL FLUSH(6)
               CALL RDCOMF(5,WORD,NW,VALS,NV,ITEM,1,1,10,IRC)
               CALL PGPAGE
               IF(IRC.NE.0)THEN
                  IFLAG = -2
                  GOTO 60
               ELSEIF(NW.GT.0)THEN
                  IF(WORD(1:2).EQ.'^D')THEN
                     IFLAG = -2
                     GOTO 60
                  ENDIF
               ENDIF
            ENDIF
c++++++++GHOST++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c            IF(HCOPY)CALL FILEND
c++++++++PGPLOT+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C========No hardcopy at present
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 50      CONTINUE
 60   CONTINUE
c++++++++PGPLOT+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF(GSTOPN)THEN
         CALL PGEND
         GSTOPN = .FALSE.
      ENDIF
c++++++++END++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      WRITE(6,1120)
      CALL FLUSH(6)
 9999 RETURN
C
 1000 FORMAT(1X,'900',
     &       1X,'Enter gridfile name: ',$)
 1040 FORMAT(/1X,'200'/
     &       1X,'Scan ',I3,':  Centre (',F6.1,',',F6.1,')',
     &       2X,'R1,R2 (',F6.1,',',F6.1,')',
     &       2X,'Phi1,Phi2 (',F6.1,',',F6.1,')'/
     &       1X,'200',8X,'Height      Position     Width      Shape   '
     &       ,4X,'Integrated      Type')
 1050 FORMAT(/1X,'Peak ',I3,1X,5G12.5,4X,A12)
 1055 FORMAT(1X,'Std Err',2X,5G12.5)
 1060 FORMAT(/1X,'Background polynomial degree ',I3/
     &       1X,'200',6X,5(4X,'a',I1,6X))
 1070 FORMAT(1X,'Coeff',4X,5G12.5)
 1075 FORMAT(1X,'Std Err',2X,5G12.5)
 1080 FORMAT(/1X,'Exponential background'/
     &       10X,G12.5,' * exp(',G12.5,' * x)')
 1085 FORMAT(1X,'Std Err',2X,G12.5,7X,G12.5)
 1090 FORMAT(/1X,'Origin for lattice constraints = ',G12.5)
 1095 FORMAT(1X,'                       Std Err = ',G12.5)
 1100 FORMAT(1X,'806',
     &       1X,'Hit return for next frame or <ctrl-D> to exit'/
     &       1X,'200',
     &       1X,'Waiting to continue...')
 1110 FORMAT(1X,'202',
     &       1X,'Finished fitting scan ',I3)
 1120 FORMAT(1X,'205',
     &       1X,'Closing plot window')
 2000 FORMAT(1X,'400 Numeric input expected')
 2010 FORMAT(1X,'400',
     &       1X,'Error opening output file')
 2020 FORMAT(1X,'400',
     &       1X,'Error writing binary output file')
      END


       subroutine  trac(RHS_x)

!----------------------------------- !
!     M. Faganello, 2007             !
!                                    !
!   Trasporto passivo: calcolo di    !
!                                    !
!     -(U * Nabla) Tracciante        !
!                                    !
!----------------------------------- !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!   3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

use parameter_mod
use box_mod
use deriv_mod
use fields_DP_mod
use fields_UJ_mod
use dom_distr_mod, only: nxl, nyt, nzl

IMPLICIT NONE

integer :: ix, iy, iz

REAL(dp),DIMENSION (nxl,ny,nz) :: RHS_x
REAL(dp), ALLOCATABLE :: Trt(:,:,:)
REAL(dp), ALLOCATABLE:: zy(:), zx(:), zz(:)

ALLOCATE( Trt( nx, nyt,nz ) )  ! nyt ~ ny/nproc
allocate(zx(nx),zy(ny),zz(nz))

 CALL traspdist( Tracciante, Trt, 1 )

do iz = 1, nz
 do iy = 1, nyt
  call  derx_1( Trt(:,iy,iz), zx )
  Trt(:,iy,iz) = zx
 enddo
enddo

 CALL traspdist( RHS_x, Trt, -1 )

RHS_x = - Ux * RHS_x

do iz = 1, nz
 do ix = 1, nxl
  call  dery_1(Tracciante(ix,:,iz), zy)
  RHS_x(ix,:,iz) = RHS_x(ix,:,iz) - Uy(ix,:,iz) * zy
 enddo
enddo

deallocate(zx)
deallocate(zy)
deallocate(zz)
deallocate(Trt)

end subroutine


    module Reionization
    use Precision
    use AMLutils
    implicit none

    !This module puts smooth tanh reionization of specified mid-point (z_{re}) and width
    !The tanh function is in the variable (1+z)**Rionization_zexp

    !Rionization_zexp=1.5 has the property that for the same z_{re}
    !the optical depth agrees with infinitely sharp model for matter domination
    !So tau and zre can be mapped into each other easily (for any symmetric window)
    !However for generality the module maps tau into z_{re} using a binary search
    !so could be easily modified for other monatonic parameterizations.

    !AL March 2008
    !AL July 2008 - added trap for setting optical depth without use_optical_depth

    !See CAMB notes for further discussion: http://cosmologist.info/notes/CAMB.pdf

    character(LEN=*), parameter :: Reionization_Name = 'CAMB_reionization'

    real(dl), parameter :: Reionization_DefFraction = -1._dl
    !if -1 set from YHe assuming Hydrogen and first ionization of Helium follow each other

    real(dl) :: Reionization_AccuracyBoost = 1._dl
    real(dl) :: Rionization_zexp = 1.5_dl

    logical :: include_helium_fullreion = .true.

    type ReionizationParams
        logical    :: Reionization
        logical    :: use_optical_depth
        real(dl)   :: redshift, delta_redshift, fraction
        real(dl)   :: optical_depth
        !Parameters for the second reionization of Helium
        real(dl)   :: helium_redshift  = 3.5_dl
        real(dl)   :: helium_delta_redshift  = 0.5
        real(dl)   :: helium_redshiftstart  = 5._dl
    end type ReionizationParams

    type ReionizationHistory
        !These two are used by main code to bound region where xe changing
        real(dl) :: tau_start, tau_complete
        !This is set from main code
        real(dl) :: akthom, fHe

        !The rest are internal to this module.
        real(dl) :: WindowVarMid, WindowVarDelta

    end type ReionizationHistory

    real(dl), parameter :: Reionization_maxz = 50._dl
    real(dl), private, parameter :: Reionization_tol = 1d-5

    real(dl), private, external :: dtauda, rombint,rombint2

    Type(ReionizationParams), private, pointer ::  ThisReion
    Type(ReionizationHistory), private, pointer :: ThisReionHist

    contains

    function Reionization_xe(a, tau, xe_recomb)
    !a and time tau and redundant, both provided for convenience
    !xe_recomb is xe(tau_start) from recombination (typically very small, ~2e-4)
    !xe should map smoothly onto xe_recomb
    real(dl), intent(in) :: a
    real(dl), intent(in), optional :: tau, xe_recomb
    real(dl) Reionization_xe
    real(dl) tgh, xod
    real(dl) xstart

    if (present(xe_recomb)) then
        xstart = xe_recomb
    else
        xstart = 0._dl
    end if

    xod = (ThisReionHist%WindowVarMid - 1._dl/a**Rionization_zexp)/ThisReionHist%WindowVarDelta
    if (xod > 100) then
        tgh=1.d0
    else
        tgh=tanh(xod)
    end if
    Reionization_xe =(ThisReion%fraction-xstart)*(tgh+1._dl)/2._dl+xstart

    if (include_helium_fullreion .and. a > (1/(1+ ThisReion%helium_redshiftstart))) then

        !Effect of Helium becoming fully ionized is small so details not important
        xod = (1+ThisReion%helium_redshift - 1._dl/a)/ThisReion%helium_delta_redshift
        if (xod > 100) then
            tgh=1.d0
        else
            tgh=tanh(xod)
        end if

        Reionization_xe =  Reionization_xe + ThisReionHist%fHe*(tgh+1._dl)/2._dl

    end if

    end function Reionization_xe

    function Reionization_timesteps(ReionHist)
    !minimum number of time steps to use between tau_start and tau_complete
    !Scaled by AccuracyBoost later
    !steps may be set smaller than this anyway
    Type(ReionizationHistory) :: ReionHist
    integer Reionization_timesteps

    Reionization_timesteps = 50

    end  function Reionization_timesteps

    subroutine Reionization_ReadParams(Reion, Ini)
    use IniFile
    Type(ReionizationParams) :: Reion
    Type(TIniFile) :: Ini

    Reion%Reionization = Ini_Read_Logical_File(Ini,'reionization')
    if (Reion%Reionization) then

        Reion%use_optical_depth = Ini_Read_Logical_File(Ini,'re_use_optical_depth')

        if (Reion%use_optical_depth) then
            Reion%optical_depth = Ini_Read_Double_File(Ini,'re_optical_depth')
        else
            Reion%redshift = Ini_Read_Double_File(Ini,'re_redshift')
        end if

        Reion%delta_redshift = Ini_Read_Double_File(Ini,'re_delta_redshift', 0.5_dl) !default similar to CMBFAST original
        Reion%fraction = Ini_Read_Double_File(Ini,'re_ionization_frac',Reionization_DefFraction)

        Reion%helium_redshift  = Ini_Read_Double_File(Ini,'re_helium_redshift', 3.5_dl)
        Reion%helium_delta_redshift  = Ini_Read_Double_File(Ini,'re_helium_delta_redshift', 0.5_dl)
        Reion%helium_redshiftstart  = Ini_Read_Double_File(Ini,'re_helium_redshiftstart', &
            Reion%helium_redshift + 3*Reion%helium_delta_redshift)

    end if

    end subroutine Reionization_ReadParams

    subroutine Reionization_SetParamsForZre(Reion,ReionHist)
    Type(ReionizationParams), target :: Reion
    Type(ReionizationHistory), target :: ReionHist

    ReionHist%WindowVarMid = (1._dl+Reion%redshift)**Rionization_zexp
    ReionHist%WindowVarDelta = &
        Rionization_zexp*(1._dl+Reion%redshift)**(Rionization_zexp-1._dl)*Reion%delta_redshift

    end subroutine Reionization_SetParamsForZre

    subroutine Reionization_Init(Reion, ReionHist, Yhe, akthom, tau0, FeedbackLevel)
    use constants
    use errors
    Type(ReionizationParams), target :: Reion
    Type(ReionizationHistory), target :: ReionHist
    real(dl), intent(in) :: akthom, tau0, Yhe
    integer, intent(in) :: FeedbackLevel
    real(dl) astart

    ReionHist%akthom = akthom
    ReionHist%fHe =  YHe/(mass_ratio_He_H*(1.d0-YHe))

    ReionHist%tau_start=tau0
    ReionHist%tau_complete=tau0

    ThisReion => Reion
    ThisReionHist => ReionHist

    if (Reion%Reionization) then

        if (Reion%optical_depth /= 0._dl .and. .not. Reion%use_optical_depth) &
            write (*,*) 'WARNING: You seem to have set the optical depth, but use_optical_depth = F'

        if (Reion%use_optical_depth.and.Reion%optical_depth<0.001 &
            .or. .not.Reion%use_optical_depth .and. Reion%Redshift<0.001) then
            Reion%Reionization = .false.
        end if

    end if

    if (Reion%Reionization) then

        if (Reion%fraction==Reionization_DefFraction) &
            Reion%fraction = 1._dl + ReionHist%fHe  !H + singly ionized He

        if (Reion%use_optical_depth) then
            call Reionization_SetFromOptDepth(Reion,ReionHist)
            if (global_error_flag/=0) return
            if (FeedbackLevel > 0) write(*,'("Reion redshift       =  ",f6.3)') Reion%redshift
        end if

        call Reionization_SetParamsForZre(ThisReion,ThisReionHist)

        !this is a check, agrees very well in default parameterization
        if (FeedbackLevel > 1) write(*,'("Integrated opt depth = ",f7.4)') &
            Reionization_GetOptDepth(Reion, ReionHist)

        !Get relevant times
        astart=1.d0/(1.d0+Reion%redshift + Reion%delta_redshift*8)
        ReionHist%tau_start = max(0.05_dl, rombint(dtauda,0._dl,astart,1d-3))
        !Time when a very small reionization fraction (assuming tanh fitting)

        ReionHist%tau_complete = min(tau0, &
            ReionHist%tau_start+ rombint(dtauda,astart,1.d0/(1.d0+max(0.d0,Reion%redshift-Reion%delta_redshift*8)),1d-3))

    end if

    end subroutine Reionization_Init

    subroutine Reionization_SetDefParams(Reion)
    Type(ReionizationParams) :: Reion

    Reion%Reionization = .true.
    Reion%use_optical_depth = .false.
    Reion%optical_depth = 0._dl
    Reion%redshift = 10
    Reion%fraction = Reionization_DefFraction
    Reion%delta_redshift = 0.5_dl

    Reion%helium_redshift  = 3.5_dl
    Reion%helium_delta_redshift  = 0.5
    Reion%helium_redshiftstart  = 5._dl

    end subroutine Reionization_SetDefParams

    subroutine Reionization_Validate(Reion, OK)
    Type(ReionizationParams),intent(in) :: Reion
    logical, intent(inout) :: OK

    if (Reion%Reionization) then
        if (Reion%use_optical_depth) then
            if (Reion%optical_depth<0 .or. Reion%optical_depth > 0.9  .or. &
                include_helium_fullreion .and. Reion%optical_depth<0.01) then
                OK = .false.
                write(*,*) 'Optical depth is strange. You have:', Reion%optical_depth
            end if
        else
            if (Reion%redshift < 0 .or. Reion%Redshift +Reion%delta_redshift*3 > Reionization_maxz .or. &
                include_helium_fullreion .and. Reion%redshift < Reion%helium_redshift) then
                OK = .false.
                write(*,*) 'Reionization redshift strange. You have: ',Reion%Redshift
            end if
        end if
        if (Reion%fraction/= Reionization_DefFraction .and. (Reion%fraction < 0 .or. Reion%fraction > 1.5)) then
            OK = .false.
            write(*,*) 'Reionization fraction strange. You have: ',Reion%fraction
        end if
        if (Reion%delta_redshift > 3 .or. Reion%delta_redshift<0.1 ) then
            !Very narrow windows likely to cause problems in interpolation etc.
            !Very broad likely to conflict with quasar data at z=6
            OK = .false.
            write(*,*) 'Reionization delta_redshift is strange. You have: ',Reion%delta_redshift
        end if
    end if

    end  subroutine Reionization_Validate

    function Reionization_doptdepth_dz(z)
    real(dl) :: Reionization_doptdepth_dz
    real(dl), intent(in) :: z
    real(dl) a

    a = 1._dl/(1._dl+z)

    Reionization_doptdepth_dz = Reionization_xe(a)*ThisReionHist%akthom*dtauda(a)

    end function Reionization_doptdepth_dz

    function Reionization_GetOptDepth(Reion, ReionHist)
    Type(ReionizationParams), target :: Reion
    Type(ReionizationHistory), target :: ReionHist
    real(dl) Reionization_GetOptDepth

    ThisReion => Reion
    ThisReionHist => ReionHist
    Reionization_GetOptDepth = rombint2(Reionization_doptdepth_dz,0.d0,Reionization_maxz,&
        Reionization_tol, 20, nint(Reionization_maxz/Reion%delta_redshift*5))

    end function Reionization_GetOptDepth

    subroutine Reionization_zreFromOptDepth(Reion, ReionHist)
    !General routine to find zre parameter given optical depth
    use Errors
    Type(ReionizationParams) :: Reion
    Type(ReionizationHistory) :: ReionHist
    real(dl) try_b, try_t
    real(dl) tau
    integer i

    try_b = 0
    try_t = Reionization_maxz
    i=0
    do
        i=i+1
        Reion%redshift = (try_t + try_b)/2
        call Reionization_SetParamsForZre(Reion,ReionHist)
        tau = Reionization_GetOptDepth(Reion, ReionHist)

        if (tau > Reion%optical_depth) then
            try_t = Reion%redshift
        else
            try_b = Reion%redshift
        end if
        if (abs(try_b - try_t) < 2e-3/Reionization_AccuracyBoost) exit
        if (i>100) call GlobalError('Reionization_zreFromOptDepth: failed to converge',error_reionization)
    end do

    if (abs(tau - Reion%optical_depth) > 0.002 .and. global_error_flag==0) then
        write (*,*) 'Reionization_zreFromOptDepth: Did not converge to optical depth'
        write (*,*) 'tau =',tau, 'optical_depth = ', Reion%optical_depth
        write (*,*) try_t, try_b
        write (*,*) '(If running a chain, have you put a constraint on tau?)'
        call GlobalError('Reionization did not converge to optical depth',error_reionization)
    end if

    end subroutine Reionization_zreFromOptDepth

    subroutine Reionization_SetFromOptDepth(Reion, ReionHist)
    Type(ReionizationParams) :: Reion
    Type(ReionizationHistory) :: ReionHist

    ! This subroutine calculates the redshift of reionization

    ! This implementation is approximate but quite accurate and fast

    real(dl) dz, optd
    real(dl) z, tmp, tmpHe
    integer na

    Reion%redshift = 0

    if (Reion%Reionization .and. Reion%optical_depth /= 0) then

        !Do binary search to find zre from z
        !This is general method
        call Reionization_zreFromOptDepth(Reion, ReionHist)

        if (.false.) then
            !Use equivalence with sharp for special case
            optd=0
            na=1
            dz=1._dl/2000/Reionization_AccuracyBoost
            tmp = dz*Reion%fraction*ThisReionHist%akthom
            tmpHe = dz*(Reion%fraction+ReionHist%fHe)*ThisReionHist%akthom
            z=0
            do while (optd < Reion%optical_depth)
                z=na*dz
                if (include_helium_fullreion .and. z < Reion%helium_redshift) then
                    optd=optd+ tmpHe*dtauda(1._dl/(1._dl+z))
                else
                    optd=optd+tmp*dtauda(1._dl/(1._dl+z))
                end if
                na=na+1
            end do
        end if
    else
        Reion%Reionization = .false.
    end if

    end  subroutine Reionization_SetFromOptDepth

    end module Reionization