!
! NESDIS_LandIR_PhyModel
!
! Module containing the NESDIS infrared non-snow land emissivity model
! Currently, this physical model is not well developed.
!
!
! CREATION HISTORY:
!       Written by:     Ming Chen, Fuzhong Weng, 02-28-2015
!                       Ming.Chen@noaa.gov
!                       Fuzhong.Weng@noaa.gov

MODULE NESDIS_LandIR_PhyModel

  ! -----------------
  ! Enviroment set up
  ! -----------------
  ! Module use
  USE CSEM_Type_Kinds, ONLY: fp => CSEM_fp

  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC  :: NESDIS_LandIR_Emiss

  ! -----------------
  ! Module parameters
  ! -----------------
  REAL(fp), PARAMETER :: ZERO   = 0.0_fp
  REAL(fp), PARAMETER :: ONE    = 1.0_fp
  REAL(fp), PARAMETER :: TWO    = 2.0_fp
  REAL(fp), PARAMETER :: PI     = 3.141592653589793238462643_fp
  REAL(fp), PARAMETER :: EMISSH_DEFAULT = 0.25_fp
  REAL(fp), PARAMETER :: EMISSV_DEFAULT = 0.30_fp

CONTAINS

!
!--------------------------------------------------------------------------------
!
! NAME:
!       NESDIS_LandIR_Emiss
!
! PURPOSE:
!       Function to simulate infrared emissivity over non-snow land conditions.
!
! REFERENCES:
!       Weng, F., B. Yan, and N. Grody, 2001: "A infrared land emissivity model",
!         J. Geophys. Res., 106, 20, 115-20, 123
!
! CALLING SEQUENCE:
!              Error_Status = NESDIS_LandIR_Emiss(              &
!                                  Frequency,                   &  ! Input
!                                  Angle,                       &  ! Input
!                                  Land_Skin_Temperature,       &  ! Input
!                                  Soil_Temperature,            &  ! Input
!                                  Soil_Moisture_Content,       &  ! Input
!                                  Vegetation_Fraction,         &  ! Input
!                                  LAI,                         &  ! Input
!                                  Vegetation_Type,             &  ! Input
!                                  Soil_Type,                   &  ! Input
!                                  Emissivity_H,                &  ! Output
!                                  Emissivity_V)                   ! Output
!
!
! INPUT ARGUMENTS:
!                                  DIMENSION:  Scalar
!
! OUTPUT ARGUMENTS:
!         Emissivity_H:            The surface emissivity at a horizontal
!                                  polarization.
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!         Emissivity_V:            The surface emissivity at a vertical polarization.
!                                  UNITS:      N/A
!                                  TYPE:       REAL(fp)
!                                  DIMENSION:  Scalar
!
!
! INTERNAL ARGUMENTS:
!
! CREATION HISTORY:
!       Recoded by:     Ming Chen, Feb 2015
!                       Ming.Chen@noaa.gov
!
!------------------------------------------------------------------------------------------------------------

  FUNCTION NESDIS_LandIR_Emiss(      &
      & Wavenumber,                  &  ! Input
      & Angle,                       &  ! Input
      & Land_Skin_Temperature,       &  ! Input
      & Soil_Temperature,            &  ! Input
      & Soil_Moisture_Content,       &  ! Input
      & Vegetation_Fraction,         &  ! Input
      & LAI,                         &  ! Input
      & Vegetation_Type,             &  ! Input
      & Soil_Type,                   &  ! Input
      & Emissivity_H,                &  ! Output
      & Emissivity_V)                &  ! Output
    RESULT (Error_Status)

    ! Arguments
    REAL(fp), INTENT(IN) :: Wavenumber
    REAL(fp), INTENT(IN) :: Angle
    REAL(fp), INTENT(IN) :: Soil_Moisture_Content
    REAL(fp), INTENT(IN) :: Vegetation_Fraction
    REAL(fp), INTENT(IN) :: Soil_Temperature
    REAL(fp), INTENT(IN) :: Land_Skin_Temperature
    REAL(fp), INTENT(IN) :: LAI
    INTEGER,  INTENT(IN) :: Soil_Type
    INTEGER,  INTENT(IN) :: Vegetation_Type
    REAL(fp), INTENT(OUT):: Emissivity_V, Emissivity_H
    INTEGER :: Error_Status
    ! local
    INTEGER  :: idummy
    REAL(fp) :: rdummy

    Error_Status = 0
    IF(.FALSE.) THEN
    rdummy =  Wavenumber
    rdummy =  Angle
    rdummy =  Land_Skin_Temperature
    rdummy =  Soil_Temperature
    rdummy =  Soil_Moisture_Content
    rdummy =  Vegetation_Fraction
    rdummy =  LAI
    idummy =  Vegetation_Type
    idummy =  Soil_Type
    END IF

    Emissivity_H = EMISSH_DEFAULT
    Emissivity_V = EMISSV_DEFAULT

  END FUNCTION NESDIS_LandIR_Emiss

END MODULE NESDIS_LandIR_PhyModel


      subroutine rlperm_wtsi(iflg)
!***********************************************************************
!  Copyright, 2006,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To compute the relative permeabilities for water table (wtsi) macro
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.30
!D2
!D2 Initial implementation: 2-14-06, Programmer: G. Zyvoloski
!D2
!D2 $Log:   /pvcs.config/fehm90/src/rlperm_wtsi.f_a  $
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 ?
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************

      use comdti
      use comai
      use combi
      use comci
      use comdi
      use comgi
      use comii
      use comfi
      use comwt
      implicit none
      integer iflg, inode, mm, ihead_ck, j
      integer iadtest, iad_ck_wtsi
      real*8  hmin, hmax, hfac_l, hfac_h, strd_wtsi
      real*8  rlzf_dum, dis_ck, head_ck1, head_ck2
      real*8  fac_wtsi
      parameter (iad_ck_wtsi= 1)
      parameter (strd_wtsi= 1.d00)
      parameter (hfac_h=1.0d0, hfac_l=1.00001d0, fac_wtsi= 10000.)
      save iadtest

      if(iflg.eq.0) then

      else if(iflg.eq.1) then
c         rho1grav = crl(1,1)*(9.81d-6)
c
c     calculate relative perms and other free surface quantities
c
c     first check and change phase state
c
         if(iad.lt.iad_up_wtsi) then
            if(iad.eq.0) dry_zone = 0
            if(iad.eq.0) strd = 1.0d0
            do inode=1,n0
               if(izone_free_nodes(inode).eq.3) then
                  hmin=head12(inode,1)
                  hmax=head12(inode,2)
                  if(phi(inode).lt.hmax*hfac_l
     &                 .and.phi(inode).gt.hmin*hfac_h) then
                     izone_free_nodes(inode)= 2
                     strd = strd_wtsi
                  else if(phi(inode).gt.hmax*hfac_h) then
                     izone_free_nodes(inode)= 1
                     strd = strd_wtsi
                  endif
               else if(izone_free_nodes(inode).eq.2) then
                  hmin=head12(inode,1)
                  hmax=head12(inode,2)
                  if(phi(inode).lt.hmin*hfac_l) then
                     izone_free_nodes(inode)= 3
                     strd = strd_wtsi
                  else if(phi(inode).gt.hmax*hfac_h) then
                     izone_free_nodes(inode)= 1
                     strd = strd_wtsi
                  endif
               else
                  hmin=head12(inode,1)
                  hmax=head12(inode,2)
                  if(phi(inode).lt.hmax*hfac_l) then
                     izone_free_nodes(inode)= 2
                     strd = strd_wtsi
                  endif
               endif
            enddo
         endif

         ifree1 = 0
         do inode=1,n0

            if(izone_free_nodes(inode).eq.1) then

               rlxyf(inode) = 1.d0
               drlxyf(inode) = 0.d0

            else if(izone_free_nodes(inode).eq.2) then
               hmin=head12(inode,1)
               hmax=head12(inode,2)
               rlxyf(inode) = (phi(inode)-hmin)/(hmax-hmin) + rlptol
               drlxyf(inode) = 1.d0/(hmax-hmin)
               ifree1 = ifree1 +1
            else if(izone_free_nodes(inode).eq.3) then
               hmin=head12(inode,1)
               hmax=head12(inode,2)
               rlxyf(inode) = 0.d0 + rlptol
               drlxyf(inode) = 1.d0/(hmax-hmin)
               ifree1 = ifree1 +1
            else
               rlxyf(inode) = 1.d0 + rlptol
               drlxyf(inode) = 0.0d0

            endif
c
c     new code gaz 12-15-05 for  horizontal-vertical anisotropy
c

            rlzf_dum = zfac_ani*rlxyf(inode)
            if(rlzf_dum.le.rlptol) then
               rlzf(inode) = 0.d0
               drlzf(inode)  = zfac_ani*drlxyf(inode)
            else if(rlzf_dum.ge.1.d00) then
               rlzf(inode) = 1.d00
               drlzf(inode)  = 0.0d0
            else
               rlzf(inode) = rlzf_dum
               drlzf(inode)= zfac_ani*drlxyf(inode)
            endif

         enddo

         if(iad.ne.0) then
            head_ck = 0.0
            ihead_ck = 0

            do inode = 1,neq
               if(izone_free_nodes(inode).eq.2.and.ka(inode).ge.0) then
                  hmin=head12(inode,1)
                  hmax=head12(inode,2)
                  dis_ck=(hmax-hmin)/rho1grav
                  head_ck1 = (s(inode)-rlxyf(inode))*dis_ck
                  head_ck2 = abs(head_ck1)
                  if(head_ck2.gt.abs(head_ck)) then
                     ihead_ck = inode
                     head_ck = head_ck1
                  endif
               else if(izone_free_nodes(inode).eq.1.and.ka(inode).ge.0)
     &                 then
                  head_ck1 = -bp(inode)/rho1grav
                  head_ck2 = abs(head_ck1)
                  if(head_ck2.gt.abs(head_ck)) then
                     ihead_ck = inode
                     head_ck = head_ck1
                  endif
               endif
            enddo
!            if (iout .ne. 0) then
!               write(iout,3000) l, iad, head_ck, ihead_ck,
!     &              (cord(ihead_ck,j),j=1,3),izone_free_nodes(ihead_ck)
!            end if
c            if(iptty.ne.0) then
c               write(iptty,3000) l, iad, head_ck, ihead_ck,
c     &              (cord(ihead_ck,j),j=1,3),izone_free_nodes(ihead_ck)
c            endif
         endif

         if(iad.eq.1) then
	    iadtest = 0
	    head_ck_first = abs(head_ck)
         else if(iad.gt.1) then

            if(abs(head_ck).gt.fac_wtsi*head_ck_first) then
               iadtest = iadtest +1
               if(iadtest.eq.iad_ck_wtsi) then
                  iad = abs(maxit)
                  if (iout .ne. 0) write(iout,*)
     &                 'restart time step due to head divergence'
                  if(iptty.ne.0) write(iptty,*)
     &                 'restart time step due to head divergence'
	       endif
            endif

         endif
         s = rlxyf

      else

      endif
 3000 format('timestep, iteration, max head diff, node, x,y,z,',
     &     ' grid state',/,1x,i5,1x,i3,1x,1p,g14.5,1x,i9,3(1x,g14.5),
     &     1x,i3)

      return
      end


      program hybrid
c
c**********************************************************************
c
c     dl_poly utility to determine the probable hybridization of atoms
c     in an organic molecule based on a bondlength criterion (warning -
c     not foolproof, but a useful start)
c
c     molecular configuration specified in dl_poly CONFIG file
c
c     for use with Dreiding forcefield
c
c     copyright daresbury laboratory 1999
c     author w. smith november 1999
c
c**********************************************************************
c
      implicit real*8(a-h,o-z)
      parameter (mxatm=2500,mega=1000000,mxpair=15)
      parameter (pi=3.141592653589793d0)
      character*8 name(mxatm)
      character*80 title
      character*40 fname
      dimension xxx(mxatm),yyy(mxatm),zzz(mxatm)
      dimension list(mxatm,mxpair),num(mxatm)
      dimension cell(9),rcell(9),celprp(10)
c
c     read control parameters

      write(*,'(a)')'enter the maximum permitted bondlength:'
      read(*,*)bond
      write(*,'(a)')'enter name of config file'
      read(*,'(a40)')fname
c
c     open files

      open(7,file=fname,err=200)
      open(8,file='CFGHYB')
c
c     read configuration data
      read(7,'(a)')title
      write(*,'(a)')'File header: ',title
      write(8,'(a)')title
      read(7,*)levcfg,imcon
      write(8,'(2i10)')0,imcon
      if(imcon.gt.0)then
        read(7,*)cell(1),cell(2),cell(3)
        read(7,*)cell(4),cell(5),cell(6)
        read(7,*)cell(7),cell(8),cell(9)
        write(8,'(3f20.10)')cell(1),cell(2),cell(3)
        write(8,'(3f20.10)')cell(4),cell(5),cell(6)
        write(8,'(3f20.10)')cell(7),cell(8),cell(9)
        call invert(cell,rcell,det)
        call dcell(cell,celprp)
        rchk=0.5d0*min(celprp(7),celprp(8),celprp(9))
        if(rchk.lt.bond)then
          write(*,'(a)')'error - chosen bondlength exceeds cell width'
          stop
        endif
      endif
      do i=1,mega
        if(i.gt.mxatm)then
          write(*,'(a)')'error - too many atoms in config file'
          stop
        endif
        read(7,'(a)',end=100)name(i)
        read(7,*,end=100)xxx(i),yyy(i),zzz(i)
        if(levcfg.gt.0)read(7,*,end=100)vxx,vyy,vzz
        if(levcfg.gt.1)read(7,*,end=100)fxx,fyy,fzz
      enddo
  100 natm=i-1
      write(*,'(a,i6)')'number of atoms in config file: ',natm
      close (7)
c
c     initialize num array

      do i=1,natm

        num(i)=0

      enddo
c
c     determine bonds in system
      k=0
      last=natm
      m1=natm/2
      m2=(natm-1)/2
      do m=1,m1
        if(m.gt.m2)last=m1
        do i=1,last
          j=i+m
          if(j.gt.natm)j=j-natm
          xd=xxx(i)-xxx(j)
          yd=yyy(i)-yyy(j)
          zd=zzz(i)-zzz(j)
          if(imcon.gt.0)then
            ssx=(rcell(1)*xd+rcell(4)*yd+rcell(7)*zd)
            ssy=(rcell(2)*xd+rcell(5)*yd+rcell(8)*zd)
            ssz=(rcell(3)*xd+rcell(6)*yd+rcell(9)*zd)
            xss=ssx-nint(ssx)
            yss=ssy-nint(ssy)
            zss=ssz-nint(ssz)
            xd=(cell(1)*xss+cell(4)*yss+cell(7)*zss)
            yd=(cell(2)*xss+cell(5)*yss+cell(8)*zss)
            zd=(cell(3)*xss+cell(6)*yss+cell(9)*zss)
          endif
          rsq=xd*xd+yd*yd+zd*zd
          if(rsq.le.bond**2)then

            if(num(i).eq.mxpair.or.num(j).eq.mxpair)then
              write(*,'(a)')'error - too many bonds found'
              stop
            endif
            k=k+1
            num(i)=num(i)+1
            num(j)=num(j)+1
            list(i,num(i))=j
            list(j,num(j))=i

          endif
        enddo
      enddo
      npairs=k
      write(*,'(a,i6)')'number of bonds in config file: ',npairs
c
c     determine probable hybridizations

      do i=1,natm

        if(name(i)(1:1).eq."H")then

          name(i)="H_"

        elseif(name(i)(1:1).eq."P")then

          name(i)="P_3"

        elseif(name(i)(1:1).eq."C")then

          if(num(i).ge.4)then

            name(i)="C_3"

          elseif(num(i).eq.3)then

            name(i)="C_2"

          elseif(num(i).eq.2)then

            name(i)="C_1"

          endif

        elseif(name(i)(1:1).eq."O")then

          if(num(i).ge.2)then

            name(i)="O_3"

          elseif(num(i).eq.1)then

            name(i)="O_2"

          endif

        elseif(name(i)(1:1).eq."N")then

          if(num(i).ge.3)then

            name(i)="N_3"

          elseif(num(i).eq.2)then

            name(i)="N_2"

          elseif(num(i).eq.1)then

            name(i)="N_1"

          endif
        endif
      enddo
c
c     now check for possible resonance condition

      do i=1,natm

        if(name(i).eq."O_3".or.name(i).eq."N_3")then

          do j=1,num(i)

            if(name(j).eq."C_2")name(i)=name(i)(1:1)//"_2"

          enddo

        endif

      enddo
c
c     write out new config file

      do i=1,natm

        write(8,'(a8,i10)')name(i),i
        write(8,'(3f20.10)')xxx(i),yyy(i),zzz(i)

      enddo
      close (8)
      stop

  200 continue
      write(*,*)'Error - file not found'
      stop

      end
      subroutine invert(a,b,d)
c
c***********************************************************************
c
c     dl_poly subroutine to invert a 3 * 3 matrix using cofactors
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       april 1992
c
c***********************************************************************
c

      real*8 a,b,d,r

      dimension a(9),b(9)
c
c     calculate adjoint matrix
      b(1)=a(5)*a(9)-a(6)*a(8)
      b(2)=a(3)*a(8)-a(2)*a(9)
      b(3)=a(2)*a(6)-a(3)*a(5)
      b(4)=a(6)*a(7)-a(4)*a(9)
      b(5)=a(1)*a(9)-a(3)*a(7)
      b(6)=a(3)*a(4)-a(1)*a(6)
      b(7)=a(4)*a(8)-a(5)*a(7)
      b(8)=a(2)*a(7)-a(1)*a(8)
      b(9)=a(1)*a(5)-a(2)*a(4)
c
c     calculate determinant
      d=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
      r=0.d0
      if(abs(d).gt.0.d0)r=1.d0/d
c
c     complete inverse matrix
      b(1)=r*b(1)
      b(2)=r*b(2)
      b(3)=r*b(3)
      b(4)=r*b(4)
      b(5)=r*b(5)
      b(6)=r*b(6)
      b(7)=r*b(7)
      b(8)=r*b(8)
      b(9)=r*b(9)
      return
      end
      subroutine dcell(aaa,bbb)

c
c***********************************************************************
c
c     dl_poly subroutine to calculate the dimensional properies of
c     a simulation cell specified by the input matrix aaa.
c     the results are returned in the array bbb, with :
c
c     bbb(1 to 3) - lengths of cell vectors
c     bbb(4 to 6) - cosines of cell angles
c     bbb(7 to 9) - perpendicular cell widths
c     bbb(10)     - cell volume
c
c     copyright daresbury laboratory 1992
c     author - w. smith         july 1992
c
c***********************************************************************
c

      implicit real*8 (a-h,o-z)

      dimension aaa(9),bbb(10)
c
c     calculate lengths of cell vectors

      bbb(1)=sqrt(aaa(1)*aaa(1)+aaa(2)*aaa(2)+aaa(3)*aaa(3))
      bbb(2)=sqrt(aaa(4)*aaa(4)+aaa(5)*aaa(5)+aaa(6)*aaa(6))
      bbb(3)=sqrt(aaa(7)*aaa(7)+aaa(8)*aaa(8)+aaa(9)*aaa(9))
c
c     calculate cosines of cell angles

      bbb(4)=(aaa(1)*aaa(4)+aaa(2)*aaa(5)+aaa(3)*aaa(6))/(bbb(1)*bbb(2))
      bbb(5)=(aaa(1)*aaa(7)+aaa(2)*aaa(8)+aaa(3)*aaa(9))/(bbb(1)*bbb(3))
      bbb(6)=(aaa(4)*aaa(7)+aaa(5)*aaa(8)+aaa(6)*aaa(9))/(bbb(2)*bbb(3))
c
c     calculate vector products of cell vectors

      axb1=aaa(2)*aaa(6)-aaa(3)*aaa(5)
      axb2=aaa(3)*aaa(4)-aaa(1)*aaa(6)
      axb3=aaa(1)*aaa(5)-aaa(2)*aaa(4)
      bxc1=aaa(5)*aaa(9)-aaa(6)*aaa(8)
      bxc2=aaa(6)*aaa(7)-aaa(4)*aaa(9)
      bxc3=aaa(4)*aaa(8)-aaa(5)*aaa(7)
      cxa1=aaa(8)*aaa(3)-aaa(2)*aaa(9)
      cxa2=aaa(1)*aaa(9)-aaa(3)*aaa(7)
      cxa3=aaa(2)*aaa(7)-aaa(1)*aaa(8)
c
c     calculate volume of cell

      bbb(10)=abs(aaa(1)*bxc1+aaa(2)*bxc2+aaa(3)*bxc3)
c
c     calculate cell perpendicular widths

      bbb(7)=bbb(10)/sqrt(bxc1*bxc1+bxc2*bxc2+bxc3*bxc3)
      bbb(8)=bbb(10)/sqrt(cxa1*cxa1+cxa2*cxa2+cxa3*cxa3)
      bbb(9)=bbb(10)/sqrt(axb1*axb1+axb2*axb2+axb3*axb3)

      return
      end


module NScool_epochs
    use NScool_def
    integer, parameter :: initial_epoch_length = 64
    integer, parameter :: token_null   = 0
    integer, parameter :: token_EOF    = 1
    integer, parameter :: token_string = 2
    integer, parameter :: token_value  = 3

contains

    subroutine do_load_epochs(s, ierr)
        use iso_fortran_env, only : IOSTAT_END, error_unit
        use exceptions_lib
        use constants_def, only : julian_day
        use storage, only: allocate_NScool_epoch_arrays

        type(NScool_info), pointer :: s
        integer, intent(out) :: ierr
        character(len=*), parameter :: this_routine = 'do_load_epochs'
        character(len=256) :: buffer, string
        integer :: file_id, t, n, i, m, i0, i1
        integer :: lines_read,iostat,this_line,epoch_length,n_cycles
        integer :: col_time, col_Mdot
        real(dp) :: delta_t
        real(dp), dimension(:,:), allocatable :: in_array
        type(failure) :: file_error=failure(scope='do_load_epochs')
        type(alert) :: file_not_empty=alert(&
        &   scope='do_load_epochs',message='unexpected EOF')
        type(alert) :: bad_token=alert(scope='do_load_epochs')
        type(failure) :: allocation_error=failure(scope='do_load_epochs', &
        &   message='allocating storage')

        if (.not. s% load_epochs) return

        ! set defaults
        ierr = 0
        n = 0
        i = 0
        n_cycles = 1
        col_time = 1
        col_Mdot = 2

        open(newunit=file_id,file=trim(s% epoch_datafile), &
            & status='old',action='read',iostat=ierr)
        if (file_error% raised(ierr, &
        &   'unable to open ' // trim(s% epoch_datafile))) return

        ! there are 5 data flags
        !   number_cycles: allows for a repeating pattern
        !   Mdot_scale: useful if the table is in Eddington values and need to
        !       be converted to cgs scale
        !   time_scale: for converting time to solar days
        !   columns: indicates order of columns, default is time Mdot
        !   epochs: loader assumes rest of file are columns of time [MJD],
        !       accretion rate
        scan_file: do
            t = token(file_id,n,i,buffer,string)
            if (t == token_EOF) then
                ! note this does not raise an error flag, but the number of
                ! epochs will be 0
                call file_not_empty% report
                return
            end if
            if (t == token_value) then
                select case(trim(string))
                case('number_cycles')
                    t = token(file_id,n,i,buffer,string,advance=.FALSE.)
                    if (t /= token_value) then
                        call bad_token% report('reading number_cycles')
                        cycle
                    end if
                    read(string,*) n_cycles
                case('Mdot_scale')
                    t = token(file_id,n,i,buffer,string,advance=.FALSE.)
                    if (t /= token_value) then
                        call bad_token% report('reading Mdot_scale')
                        cycle
                    end if
                    read(string,*) s% epoch_Mdot_scale
                case('time_scale')
                    t = token(file_id,n,i,buffer,string,advance=.FALSE.)
                    if (t /= token_value) then
                        call bad_token% report('reading time_scale')
                        cycle
                    end if
                    read(string,*) s% epoch_time_scale
                case('columns')
                    t = token(file_id,n,i,buffer,string,advance=.FALSE.)
                    if (t /= token_string) then
                        call bad_token% report('reading columns')
                        cycle
                    end if
                    if (string(1:4) == 'Mdot') then
                        col_Mdot = 1; col_time = 2
                    else if (string(1:4) == 'time') then
                        col_time = 1; col_Mdot = 2
                    else
                        call bad_token% report('reading columns')
                        cycle
                    end if
                case('epochs')
                    exit    ! terminate cycle, read in data table
                case default
                    call bad_token% report('unexpected token ' // trim(string))
                end select
            end if
        end do scan_file

        epoch_length = initial_epoch_length
        allocate(in_array(2,epoch_length), stat=ierr)
        if (allocation_error% raised(ierr)) return

        lines_read = 0
        read_table: do
            this_line = lines_read+1
            read(file_id,*,iostat=ierr) in_array(:,this_line)
            if (ierr == IOSTAT_END) then
                ierr = 0
                exit
            end if
            lines_read = this_line
            if (this_line == size(in_array,dim=2)) then
                epoch_length = 2*size(in_array,dim=2)
                call realloc(in_array,2,epoch_length,ierr)
                if (allocation_error% raised(ierr)) exit
            end if
        end do read_table
        close(file_id)

        ! scale the accretion rates and times
        in_array(col_time,:) = in_array(col_time,:) * &
        &   s% epoch_time_scale * julian_day
        in_array(col_Mdot,:) = in_array(col_Mdot,:) * s% epoch_Mdot_scale

        if (ierr == 0) then
            ! Store the table. For n lines read and m cycles, we repeat
            ! lines 1:n-1 m times. The times are stored in epoch_boundares
            ! 0:(n-1)-1, n-1:2(n-1)-1, ..., (m-1)*(n-1):m(n-1)-1;
            ! if the table has times t_1,...,t_n, then with Delta = t_n-t_1 the
            ! stored times are
            ! t_1,t_2,...,t_(n-1),t_1+Delta,...,t_(n-1)+Delta,t_1+2*Delta,...
            ! t_(n-1)+(m-1)*Delta. The final time is stored in
            ! epoch_boundaries(m*(n-1)) = t_n+(m-1)*Delta.
            ! The accretion rates are stored in
            ! epoch_Mdots 1:n-1, (n-1)+1:2(n-1), ..., (m-1)*(n-1)+1:m(n-1).
            !
            n = lines_read
            s% number_epochs = n_cycles*(n-1)
            call allocate_NScool_epoch_arrays(s, ierr)
            delta_t = in_array(col_time,n)-in_array(col_time,1)
            do m = 0, n_cycles-1
                i0 = m*(n-1)
                i1 = i0+n-2
                s% epoch_boundaries(i0:i1) = in_array(col_time,1:n-1)  &
                &   + m*delta_t
                s% epoch_Mdots(i0+1:i1+1) =  in_array(col_Mdot,1:n-1)
            end do
            ! final time (end of integration)
            s% epoch_boundaries(s% number_epochs) = in_array(col_time,n) &
            &   + (n_cycles-1)*delta_t
        end if

        deallocate(in_array)
     end subroutine do_load_epochs

     subroutine realloc(a,n1,n2,ierr)
         real(dp), dimension(:,:), allocatable, intent(inout) :: a
         integer, intent(in) :: n1, n2
         integer, intent(out) :: ierr
         real(dp), dimension(size(a,dim=1),size(a,dim=2)) :: tmp
         integer :: m1, m2

         m1 = size(a,dim=1)
         m2 = size(a,dim=2)
         ierr = 0
         tmp = a
         deallocate(a)
         allocate(a(n1,n2),stat = ierr)
         if (ierr /= 0) return
         a(1:m1,1:m2) = tmp(1:m1,1:m2)
     end subroutine realloc

     function token(fid,n,i,buffer,string,advance)
         use iso_fortran_env, only : IOSTAT_END
         integer, intent(in) :: fid
         integer, intent(inout) :: n,i
         character(len=*), intent(inout) :: buffer,string
         logical, intent(in), optional :: advance
         integer :: token
         logical :: okay_to_advance
         integer :: info, j, j1, j2, l, str_len
         character(len=1), parameter :: tab = char(9)
         character(len=1) :: delim

         okay_to_advance = .TRUE.
         if (present(advance)) okay_to_advance = advance

         token = token_null
         line_loop: do
             do while (i >= n)
                 if (.not.okay_to_advance) return
                 read(fid,fmt='(a)',iostat=info) buffer
                 if (info == IOSTAT_END) then
                     token = token_EOF
                     return
                 end if
                 n = len_trim(buffer)
                 i = 0
             end do

             token_loop: do while (i < n)
                 i = i + 1
                 select case(buffer(i:i))
                 case ('!')
                     i = n
                     cycle line_loop
                 case (' ',tab)
                     cycle token_loop
                 case ('"','''')
                     j = 1; str_len = len(string)
                     delim = buffer(i:i)
                     string_loop: do
                         i = i + 1
                         if (i > n) exit
                         if (buffer(i:i) == delim) exit
                         if (j > str_len) exit
                         string(j:j) = buffer(i:i)
                         j = j+1
                     end do string_loop
                     do while (j <= str_len)
                        string(j:j) = ' '
                        j = j+1
                     end do
                     token = token_string
                     return
                 case default
                     j1 = i; j2 = i; str_len = len(string)
                     value_loop: do
                         if (i+1 > n) exit
                         if (buffer(i+1:i+1) == ' ') exit
                         if (buffer(i+1:i+1) == tab) exit
                         i = i + 1
                         j2 = i
                     end do value_loop
                     l = min(j2-j1+1,str_len)
                     string(1:l) = buffer(j1:j2)
                     do j = l+1,str_len
                         string(j:j) = ' '
                     end do
                     token = token_value
                     return
                 end select
             end do token_loop
         end do line_loop
     end function token
end module NScool_epochs