       subroutine threed(x,y,z,nrow,ncol,ista,ifn,jsta,jfn,
     *	lntp,ngrd,amxmn,ar)
C...subroutine     threed    01/12/75
C...subroutine     threed    01/09/78
       dimension z(nrow,ncol),x(1),y(1),amxmn(1),ar(1)
      common/gfmatr/t(16),a(16),nt,nt1
       common/gfcrd/xp,yp,zp/gfsur/nar,dx,ngr,ncall
       common/gflim/xmn,xmx,zmn,zmx
      common/gfview/mac(4,5),xp1,yp1,zp1
      ist=iabs(ista)
      jst=iabs(jsta)
       nar=max0(nrow,ncol)
       if(ifn.lt.ist)goto 54
       if(jfn.lt.jst)goto 54
       mxmn=isign(1,jsta)
       if(lntp.eq.0)mxmn=1
       ivis=isign(1,ista)
      do 1 i=1,4
    1 mac(i,1)=-1
       if(ista.eq.0)goto 54
       if(ista.lt.0)goto 103
       ngr=ngrd
       dx=(xmx-xmn)/(ngrd-1)
      if(nt1.eq.1)goto 100
      if(nt1.eq.3)goto 102
      if(nt.eq.2)goto 100
 103  i=4
      goto 31
  100 sn=sin(5.*3.141592/180.)
       do 201 i=1,16
  201 a(i)=t(i)
       t(4)=0.
       t(8)=0.
       t(12)=0.
       i0=1
       if(lntp.eq.0)goto 203
       if(lntp.gt.0)goto 204
       i1=3
       goto 210
  203 i0=2
       i1=4
       goto 205
  204 i1=1
  205 k=1
       movy=1
       movx=1
       call hcncrd(0.,-1.,0.)
       if(yp.gt.0.) movy=-1
       r=yp*yp+zp*zp
       snr=sqrt(r/(r+xp*xp))
  206 if(snr.gt.sn)goto 212
      if(i1-2)209,213,211
 208   i0=1
       t(4)=0.
       t(8)=0.
       t(12)=0.
  209 i1=2
  210 k=-1
       movy=1
       movx=1
       call hcncrd(-1.,0.,0.)
        if(xp.gt.0.)movx=-1
        r=xp*xp+zp*zp
       snr=sqrt(r/(r+yp*yp))
       goto 206
  211 i1=2
       goto 205
  212 do 215  i=1,16
  215 t(i)=a(i)
      call hcsurf(x,y,z,nrow,ncol,ista,ifn,
     *    jsta,jfn,k,movx,movy,amxmn,ar)
        goto(54,208),i0
  213 do 214 i=1,16
  214 t(i)=a(i)
       goto 54
  102 xp=xp1
      yp=yp1
      zp=zp1
      i1=1
      i2=2
      if(xp.eq.x(jst))goto 8
      if(xp.gt.x(jst))goto 11
  2   if(yp.gt.y(ist))goto 4
  3   i=i1
   31 mac(i,1)=1
      mac(i,2)=ista
      mac(i,3)=ifn
      mac(i,4)=jsta
      mac(i,5)=jfn
      goto 21
    4 if(yp.lt.y(ifn)) goto 6
    5 i=i2
      goto 31
    6 iy=hcind(y,ist,ifn,yp)
      do 7 i=1,2
      ir1=i-1
      ir2=2-i
      j=ir1*i2+ir2*i1
      mac(j,1)=1
      mac(j,4)=jsta
      mac(j,5)=jfn
      mac(j,2)=(ir1*ist+ir2*iy)*ivis
    7 mac(j,3)=ir1*iy+ir2*ifn
      goto 21
    8 if(yp.lt.y(ist)) goto 3
      if(yp.eq.y(ist)) return
      if(yp.gt.y(ifn)) goto 5
      return
   11 if(xp.eq.x(jfn)) goto 20
      if(xp.gt.x(jfn)) goto 19
      jx=hcind(x,jst,jfn,xp)
      if(yp.gt.y(ist))goto 15
      if(yp.eq.y(ist))return
      isw=1
      ist1=ista
  131 ifn1=ifn
      i1=1
      i2=4
  132 do 14 i=1,2
      ir1=i-1
      ir2=2-i
      j=i1*ir2+i2*ir1
      mac(j,1)=1
      mac(j,2)=ist1
      mac(j,3)=ifn1
      mac(j,4)=(ir1*jst+ir2*jx)*mxmn
   14 mac(j,5)=ir1*jx+ir2*jfn
      goto(21,18),isw
   15 if(yp.lt.y(ifn)) goto 17
      if(yp.eq.y(ifn)) return
      ifn1=ifn
  161 ist1=ista
      isw=1
      i1=2
      i2=3
      goto 132
   17 iy=hcind(y,ist,ifn,yp)
      ist1=iy*ivis
      isw=2
      goto 131
   18 ifn1=iy
      goto 161
   19 i1=4
      i2=3
      goto 2
   20 i1=4
      i2=3
      goto 8
   21 if(lntp.eq.0) goto 29
      isw2=1
      k=lntp
      goto 231
   29 isw2=2
      k=1
  231 do 24 i=1,4
      if(mac(i,1).le.0) goto 24
      movx=1
      movy=1
      if(i.lt.2) goto 28
      if(i.gt.2) goto 27
 26   movy=-1
      goto 28
   27 movx=-1
      if(i.lt.4) goto 26
      if(i.gt.4) goto 24
  28  continue
       call hcsurf(x,y,z,nrow,ncol,mac(i,2),mac(i,3),mac(i,4),
     *   mac(i,5),k,movx,movy,amxmn,ar)
   24 continue
      if(isw2.eq.1)goto 54
      k=-1
      isw2=1
      goto 231
   54 return
      end


! compile with gfortran -shared -fPIC  -o ACE.so Md_ACE.f90 Md_Constantes.f90 Md_Types_Numeriques.f90 Md_Utilitaires.f90 Md_numerical_recipes.f90

Module Md_ACE

Use Md_Types_Numeriques
Use Md_Constantes
Use Md_Utilitaires
Use Md_numerical_recipes
use iso_c_binding, only: c_double, c_int

Implicit None
Integer, parameter :: nmaxcharspec = 10       ! Maximum number of species
Integer, parameter :: nmaxelemxs = 10         ! Maximum number of different elements in one species
Integer, parameter :: nb_NASA_coef = 7        ! Number of coefficients in NASA therm polynomials

!Real(8)         :: fm(105,1)
Integer         :: code
Integer, parameter :: nspec = 105       ! Maximum number of species

Contains

!######################################################################

Subroutine ACE(specfile,thermfile,nlayers,a_apt,p_apt,t_apt,He_abund_dex,C_abund_dex,O_abund_dex, &
              N_abund_dex,fm)

!Subroutine ACE(a_apt,p_apt,t_apt,He_abund_dex,C_abund_dex,O_abund_dex,N_abund_dex, &
!               nspec,fm,code)  bind(c, name='ACE')

Integer,         intent(in)    :: nlayers                     ! number of layers
Real(8),         intent(in)    :: a_apt(nlayers)              ! array of altitude points [km]
Real(8),         intent(in)    :: p_apt(nlayers)              ! array of pressure points [bar]
Real(8),         intent(in)    :: t_apt(nlayers)              ! array of temperature points [K]
Real(8),         intent(in)    :: He_abund_dex
Real(8),         intent(in)    :: C_abund_dex
Real(8),         intent(in)    :: O_abund_dex
Real(8),         intent(in)    :: N_abund_dex
Real(8),         intent(out)   :: fm(105,nlayers)
!Integer,          intent(in)    :: nspec
!Real(8),         intent(out)   :: fm(nspec,size(a_apt))
!Integer,          intent(inout) :: code
Character(len=*), intent(in):: specfile
Character(len=*), intent(in) :: thermfile
Character(len=20) :: spec(105)

! Model parameters
Logical :: ion                                ! .true.(.false.) = there are (not) charged species
Logical :: init                               ! .true. = initialize; .false. = inside calculation

! Element parameters
Integer, parameter   :: nelem = 5               ! number of elements (H, He, C, O, N)
Integer, parameter   :: telfab = 2              ! type of element abundances (1: relative abundance ; 2: logarithmic abundance relative to H=12)
Integer              :: ilenelem(nelem)         ! number of characters of element name
Integer              :: zat(nelem)              ! atomic number Z of each element
Real(8)             :: elfab(nelem)            ! input elemental abundance [logarithmic relative to H=12]
Real(8)             :: mat(nelem)              ! atomic mass of each element [amu]
Character(len=2)     :: elem(nelem)             ! element name

! Species parameters
Integer, allocatable  :: charge(:)            ! species electrostatic charge
Integer, allocatable  :: nattot(:)            ! total number of atoms for each species
Integer, allocatable  :: nat(:,:)             ! number of atoms of element j in species i
Integer, allocatable  :: idzat(:,:)           ! atomic number Z of element j in species i
Integer, allocatable  :: ilenspec(:)          ! number of characters of species name
Integer               :: id_electr            ! species identifier for electron
Real(8), allocatable :: abun(:)              ! species abundance [mol/g mixture]

! Therm parameters
Integer,  allocatable :: idtherm(:)           ! type of therm data for each species
Real(8), allocatable :: atherm(:,:)          ! therm polynomial coefficients for each species
Real(8), allocatable :: btherm(:,:)          ! therm polynomial coefficients for each species
Real(8), allocatable :: tkmin_therm(:)       ! minimum temperature of application of therm coefficients
Real(8), allocatable :: tkmax_therm(:)       ! maximum temperature of application of therm coefficients
Real(8), allocatable :: tkmid_therm(:)       ! medium temperature for use of a or b therm coefficients

! Physical parameters
Real(8) :: altitude                          ! atmospheric altitude [km]
Real(8) :: pressure                          ! gas pressure [bar]
Real(8) :: tk                                ! gas kinetic temperature [K]
Real(8) :: density                           ! number of particles per unit volumen [cm-3]

! Other variables
Integer  :: i, j, u
Character(len=100) :: line

If (nelem > nmaxelem) Call Message_exec('E- Number of elements too high','stop')

elem(1) = 'H'
elem(2) = 'He'
elem(3) = 'C'
elem(4) = 'N'
elem(5) = 'O'

elfab(1) = H_abund_dex

elfab(2) = He_abund_dex
elfab(3) = C_abund_dex
elfab(4) = N_abund_dex
elfab(5) = O_abund_dex

ilenelem(1) = 1
ilenelem(2) = 2
ilenelem(3) = 1
ilenelem(4) = 1
ilenelem(5) = 1

zat(1) = 1
zat(2) = 2
zat(3) = 6
zat(4) = 7
zat(5) = 8

! Elemental abundances
If (telfab == 2) then
  ! convert logarithmic to relative abundance
  Do i = 1, nelem
    elfab(i) = 10.0d0**(elfab(i)-12.0d0)
  End do
End if

Do i = 1, nelem
  Do j = 1, nmaxelem
    If (elem(i) == element(j)) then
      mat(i) = atomic_weight(j)
      zat(i) = j
      Exit
    End if
  End do
End do

! Read species
Allocate(charge(nspec),nattot(nspec),nat(nspec,nmaxelem),idzat(nspec,nmaxelem), &
         ilenspec(nspec),abun(nspec),idtherm(nspec),atherm(nspec,nb_NASA_coef),btherm(nspec,nb_NASA_coef), &
	 tkmin_therm(nspec),tkmax_therm(nspec),tkmid_therm(nspec))

Call read_spec(specfile,spec,ilenspec)

! Read therm data
charge(:)   = 0
nattot(:)   = 0
nat(:,:)    = 0
idzat(:,:)  = 0

Call read_therm(thermfile,spec,ilenspec,elem,ilenelem,zat,charge,nattot,nat,idzat,idtherm,atherm,btherm, &
                tkmin_therm,tkmax_therm,tkmid_therm,ion,id_electr)

! Compute chemical equilibrium

Call compute_chemical_equilibrium(nspec,spec,elfab,mat,charge,nat,ion,id_electr,a_apt,p_apt,t_apt, &
                                  tkmid_therm,atherm,btherm,idtherm,abun,fm,code)

Deallocate(charge,nattot,nat,ilenspec,abun,idtherm,atherm,btherm, &
           tkmin_therm,tkmax_therm,tkmid_therm)

End Subroutine ACE

!######################################################################

Subroutine read_spec(specfile,spec,ilenspec)

Implicit None
Character(len=*), intent(in)  :: specfile
Character(len=*), intent(out) :: spec(:)
Integer,          intent(out) :: ilenspec(:)
Integer :: i, j, u

Call Unite_libre(u)
Open(u,file=specfile,status='old')
Do i = 1, size(spec)
  Read(u,'(5x,a10)'), spec(i)
  j = nmaxcharspec
  Do while (spec(i)(j:j) == ' ')
    j = j - 1
  End do
  ilenspec(i) = j
End do
Close(u)

End Subroutine read_spec

!######################################################################

Subroutine read_therm(thermfile,spec,ilenspec,elem,ilenelem,zat,charge,nattot,nat,idzat,idtherm, &
                      atherm,btherm,tkmin_therm,tkmax_therm,tkmid_therm,ion,id_electr)

Implicit None
Character(len=*), intent(in)  :: thermfile
Character(len=*), intent(in)  :: spec(:)
Integer,          intent(in)  :: ilenspec(:)
Character(len=*), intent(in)  :: elem(:)
Integer,          intent(in)  :: ilenelem(:)
Integer,          intent(in)  :: zat(:)
Integer,          intent(out) :: charge(:)	      ! species electrostatic charge
Integer,          intent(out) :: nattot(:)	      ! total number of atoms for each species
Integer,          intent(out) :: nat(:,:)	      ! number of atoms of element j in species i
Integer,          intent(out) :: idzat(:,:)	      ! atomic number Z of element j in species i
Integer,          intent(out) :: idtherm(:)	      ! type of therm data for each species
Real(8),         intent(out) :: atherm(:,:)	      ! therm polynomial coefficients for each species
Real(8),         intent(out) :: btherm(:,:)	      ! therm polynomial coefficients for each species
Real(8),         intent(out) :: tkmin_therm(:)       ! minimum temperature of application of therm coefficients
Real(8),         intent(out) :: tkmax_therm(:)       ! maximum temperature of application of therm coefficients
Real(8),         intent(out) :: tkmid_therm(:)       ! medium temperature for use of a or b therm coefficients
Logical,          intent(out) :: ion                  ! .true.(.false.) = there are (not) charged species
Integer,          intent(out) :: id_electr            ! species identifier for electron
Character(len=nmaxcharspec) :: read_spec, cwk1, cwk2
Character(len=256) :: line
Character(len=2)   :: read_txt(2*nmaxelemxs), read_elem(nmaxelemxs)
Integer  :: read_nattot, read_nelem, read_charge, read_idtherm
Integer  :: read_nat(nmaxelemxs)
Real(8) :: read_a(nb_NASA_coef), read_b(nb_NASA_coef)
Real(8) :: read_tkmin, read_tkmax, read_tkmid
Integer  :: ilen, il
Integer  :: nspec, nelem
Integer  :: ntherm
Logical  :: fnd_spec(size(spec)), fnd_read_elem
Integer  :: i, j, k, l, m, u
Integer  :: end_of_file ! < 0 si c'est la fin du fichier

nspec = size(spec)
nelem = size(ilenelem)

ntherm=0
fnd_spec(:) = .false.

Call Unite_libre(u)
Open(u,file=thermfile,status='old')

Do while(ntherm <= nspec)

  line(1:256)=''		   ! read parameters from therm file
  Read(u,'(a256)',iostat=end_of_file), line
  If (end_of_file < 0) Exit
  If (line(1:1) == '#')Cycle
  Read(line,*,iostat=end_of_file), read_spec, read_nattot, read_nelem, read_charge, read_idtherm

  Read(u,*)(read_txt(j),j=1,2*read_nelem)
  Do i = 1, 2*read_nelem
    If (((-1)**i) < 0) read_elem((i+1)/2)(1:2) = read_txt(i)(1:2)
    If (((-1)**i) > 0) read(read_txt(i)(1:2),*), read_nat(i/2)
  End do

  if(read_idtherm == 1)then
    Read(u,*), read_tkmin, read_tkmax, read_tkmid
    Read(u,*), (read_a(j),j=1,nb_NASA_coef)
    Read(u,*), (read_b(j),j=1,nb_NASA_coef)
  Else
    Write(*,*) ' E- unknown therm data type for: ',read_spec
    Stop
  End if

  i = nmaxcharspec		   ! verify whether species is included or not
  Do while (read_spec(i:i) == ' ')   ! ... and if so, save parameters
    i = i - 1			   ! - number of atoms: nattot(i)
  End do			   ! - number of atoms of each element: nat(i,j)
  ilen = i			   ! - charge: charge(i)
  Do i = 1, nspec  		   ! - thermo data coefficients: atherm(i,j)
    If(fnd_spec(i))Cycle
    If(ilen /= ilenspec(i))Cycle
    cwk1(1:nmaxcharspec) = ''	  ! make not case sensitive
    cwk2(1:nmaxcharspec) = ''	  ! comparison of names in species and therm files
    Do j = 1, ilen
      k = iachar(read_spec(j:j))
      If((k >= 65) .and. (k <= 90)) k=k+32
      cwk1(j:j) = achar(k)
      k=iachar(spec(i)(j:j))
      If((k >= 65) .and. (k <= 90)) k=k+32
      cwk2(j:j) = achar(k)
    End do
    If(cwk1(1:ilen) == cwk2(1:ilen))then
      ntherm = ntherm + 1
      nattot(i) = read_nattot
      If(read_nelem > nmaxelemxs-1)then
        Write(*,*)' E- Many elements in: ',spec(i)
        stop
      End if
      Do j = 1, read_nelem
        fnd_read_elem = .false.
        il = 2
        Do while (read_elem(j)(il:il) == ' ')
          il = il - 1
        End do
        Do k=1,nelem
          If(il /= ilenelem(k))Cycle
          cwk1(1:2) = ''         ! make not case sensitive
          cwk2(1:2) = ''         ! comparison of element names
          Do l = 1, il
            m = iachar(read_elem(j)(l:l))
            If((m >= 65) .and. (m <= 90)) m = m + 32
            cwk1(l:l) = achar(m)
            m = iachar(elem(k)(l:l))
            If((m >= 65) .and. (m <= 90)) m = m + 32
            cwk2(l:l) = achar(m)
          End do
          If(cwk1(1:il) == cwk2(1:il))then
            nat(i,k) = read_nat(j)
            idzat(i,k) = zat(k)
            fnd_read_elem = .true.
            Exit
          End if
        End do
        If(.not.(fnd_read_elem))then
          Write(*,*)' E- Error on elements for: ',spec(i)
          stop
        End if
      End do
      charge(i)  = read_charge
      idtherm(i) = read_idtherm
      Do j = 1, nb_NASA_coef
        atherm(i,j) = read_a(j)
        btherm(i,j) = read_b(j)
      End do
      tkmin_therm(i) = read_tkmin
      tkmax_therm(i) = read_tkmax
      tkmid_therm(i) = read_tkmid
      fnd_spec(i) = .true.
      Exit
    End if
  End do

  read_spec(1:nmaxcharspec) = ''     ! reset 'read_...' variables
  read_nattot  = 0
  read_nelem   = 0
  read_charge  = 0
  read_idtherm = 0
  Do j = 1, 2*nmaxelemxs
    read_txt(j)(1:2) = ''
  End do
  Do j = 1, nmaxelemxs
    read_elem(j)(1:2) = ''
    read_nat(j) = 0
  End do
  Do j = 1, nb_NASA_coef
    read_a(j) = 0.0d0
    read_b(j) = 0.0d0
  End do
  read_tkmin = 0.0d0
  read_tkmax = 0.0d0
  read_tkmid = 0.0d0

End do
Close(u)

! verify that all species have thermo data
If(ntherm /= nspec) then
  Write(*,*)' E- Error searching for thermo data', ntherm, nspec
  Stop
End if
Do i = 1, nspec
  If(nattot(i) == 0) then
    Write(*,*)' E- Number of atoms zero for: ',spec(i)
    Stop
  End if
End do

! verify that the total number of each species of atoms is correct
Do i = 1, nspec
  k = 0
  Do j = 1, nelem
    k = k + nat(i,j)
  End do
  If(k /= nattot(i)) then
    Write(*,*)' E- Wrong number of atoms for: ',spec(i),k,nattot(i)
    Stop
  End if
End do

! verify that a species does not appear more than once
Do i = 1, nspec-1
  il = ilenspec(i)
  Do j = i+1, nspec
    k = ilenspec(j)
    If(il /= k) Cycle
    If(spec(i)(1:il) == spec(j)(1:il)) then
      Write(*,*)' E- Twice species ',spec(i)(1:il)
      Stop
    End if
  End do
End do

! verify species charge
j = 0
k = 0
ion = .false.
Do i = 1, nspec
  If(charge(i) /= 0) ion = .true.
  If(charge(i) > 0)  j = j + 1
  If(charge(i) < 0)  k = k + 1
End do
If (ion .and. ((j == 0) .or. (k == 0))) then
  Write(*,*)' E- Missing (+/-) charged species'
  Stop
End if

! identify electron species if present
If (ion) then
  id_electr = 0
  Do i = 1, nspec
    If ((nattot(i) == 0) .and. (charge(i) == -1)) id_electr = i
  End do
End if

End Subroutine read_therm

!######################################################################

Subroutine compute_chemical_equilibrium(nspec,spec,elfab,mat,charge,nat,ion,id_electr,a_apt,p_apt,t_apt, &
                                        tkmid_therm,atherm,btherm,idtherm,abun,fm,code)

Implicit None
Integer,          intent(in)    :: nspec  	    ! number of atoms of element j in species i
Real(8),         intent(in)    :: elfab(:)	    ! input elemental abundance [logarithmic relative to H=12]
Real(8),         intent(in)    :: mat(:) 	    ! atomic mass of each element [amu]
Integer,          intent(in)    :: charge(:)	    ! species electrostatic charge
Integer,          intent(inout) :: nat(:,:)	    ! number of atoms of element j in species i
Logical,          intent(in)    :: ion  	    ! .true.(.false.) = there are (not) charged species
Integer,          intent(in)    :: id_electr	    ! species identifier for electron
Real(8),         intent(in)    :: a_apt(:)
Real(8),         intent(in)    :: p_apt(:)
Real(8),         intent(in)    :: t_apt(:)
Real(8),         intent(in)    :: tkmid_therm(:)
Real(8),         intent(in)    :: atherm(:,:)
Real(8),         intent(in)    :: btherm(:,:)
Integer,          intent(in)    :: idtherm(:)
Real(8),         intent(out)   :: abun(:)	    ! species abundance [mol/g mixture]
Real(8),         intent(out)   :: fm(:,:)
Character(len=*), intent(in)    :: spec(nspec)
Integer,          intent(inout) :: code

Integer, parameter :: nmaxeqt = 73          ! Maximum number of conservation equations (nmaxelem+1)
Integer  :: nelem                           ! number of elements (H, He, C, O, N)
Real(8) :: abunmax(nspec)                  ! maximum species abundance [mol/g mixture]
Real(8) :: b0(nmaxeqt)                     ! conservation term for each element [mol/g mixture] + conservation term for charge if ions present
Real(8) :: rwk, abeltot
Real(8) :: abuntot                         ! total abundance of all species [mol/g mixture]
Real(8) :: altitude, pressure, tk
Real(8) :: abun_avant(nspec)
Real(8) :: abuntot_avant
Integer  :: neqt                            ! number of conservation equations (nelem or nelem+1 if ionic species)
Integer  :: napt                            ! number of (T,p) points
Integer  :: iapt                            ! current (T,p) point
Integer  :: i, j, iwk

nelem = size(elfab)
napt  = size(a_apt)

! compute terms b0(i) of initial elemental abundances (+charge)
rwk = 0.0d0
Do i = 1, nelem
  rwk = rwk + elfab(i) * mat(i) * amu*1000
End do
abeltot = 0.0d0
Do i = 1, nelem
  b0(i) = elfab(i)/ Cte_Avogadro / rwk ! [=] mole [g of mixture]-1
  abeltot = abeltot + b0(i)
End do
If (ion) then		   ! charge
  b0(nelem+1) = 0.0d0
  Do j = 1, nspec  	  ! add charge to nat(i,j) variable
    nat(j,nelem+1) = charge(j)
  End do
End if

! compute the maximum abundance reachable by each species
Do j = 1, nspec
  abunmax(j) = Infini_dp
  Do i = 1, nelem
    iwk = nat(j,i)
    If ((iwk /= 0) .and. (abunmax(j) > (b0(i)/Real(iwk,8)))) abunmax(j) = b0(i)/Real(iwk,8)
  End do
End do

If (ion .and. (id_electr /=0)) abunmax(id_electr) = abeltot

! assign initial guess for abundances of species
abuntot = abeltot 	   ! initially everything is atomic
Do j = 1, nspec
  abun(j) = abuntot / Real(nspec,8)
  If (abun(j) > abunmax(j)) abun(j) = abunmax(j)
End do

! evaluate number of equations to solve with Newton-Raphson
neqt = nelem + 1
If (ion) neqt = nelem + 2

! compute thermochemical equilibrium abundances for the grid of points
abun_avant(:) = 0.0d0
abuntot_avant = 0.0d0
Do iapt = 1, napt
  altitude = a_apt(iapt)
  pressure = p_apt(iapt)
  tk       = t_apt(iapt)
  code     = 0
  Call minimize_gibbs_energy(nspec,spec,neqt,nmaxeqt,nb_NASA_coef,nat,b0,pressure, &
                             tk,tkmid_therm,atherm,btherm,idtherm,abun,abunmax,abuntot, &
			     code)
  If (code == 1) then
    ! En cas de bug, on remplit les niveaux restants avec le dernier niveau connu et on sort
    Do j = iapt, napt
      fm(:,j) = abun_avant(:)/abuntot_avant
    End do
    Return
  Else
    fm(:,iapt) = abun(:)/abuntot
    abun_avant(:) = abun(:)
    abuntot_avant = abuntot
  End if

End do

End Subroutine compute_chemical_equilibrium

!######################################################################

Subroutine minimize_gibbs_energy(nspec,spec,neqt,nmaxeqt,nb_NASA_coef,nat,b0,pressure, &
                                 tk,tkmid_therm,atherm,btherm,idtherm,abun,abunmax,abuntot, &
				 code)

Implicit None
Integer,          intent(in)    :: nspec
Integer,          intent(in)    :: neqt
Integer,          intent(in)    :: nmaxeqt
Integer,          intent(in)    :: nb_NASA_coef
Integer,          intent(in)    :: nat(:,:)	    ! number of atoms of element j in species i
Real(8),         intent(inout) :: abuntot
Real(8),         intent(in)    :: b0(:)
Real(8),         intent(in)    :: pressure
Real(8),         intent(in)    :: tk
Real(8),         intent(in)    :: tkmid_therm(nspec)
Real(8),         intent(in)    :: atherm(nspec,nb_NASA_coef)
Real(8),         intent(in)    :: btherm(nspec,nb_NASA_coef)
Integer,          intent(in)    :: idtherm(nspec)
Real(8),         intent(out)   :: abun(nspec)	    ! species abundance [mol/g mixture]
Real(8),         intent(in)    :: abunmax(nspec)   ! chemical potential of each species divided by RT
Character(len=*), intent(in)    :: spec(nspec)
Integer,          intent(inout) :: code

Integer,  parameter :: nmaxit = 200	      ! maximum number of Newton-Raphson iterations
Integer,  parameter :: nminit = 5	      ! minimum number of Newton-Raphson iterations
Real(8), parameter :: abtol = 0.5d-5         ! abundance relative tolerance

Real(8) :: mu(nspec)                         ! chemical potential of each species divided by RT
Real(8) :: pilag(nmaxeqt-1)                  ! pi lagrange multiplier
Real(8) :: dlnn                              ! variation of Ln(abuntot) among succesive iterations
Real(8) :: x(nspec), dlnns(nspec)
Real(8) :: rwk
Real(8) :: lambda, lambda1, lambda2
Real(8) :: err, maxerr, corr
Logical  :: converge
Integer  :: i, j, k, it, iwk

! assign initial guess for pi lagrange multipliers and Delta Ln(n)
Do i = 1, neqt-1
  pilag(i) = 0.0d0
End do
dlnn = 0.0d0

! assign initial values
it = 1
converge = .false.
Do i = 1, neqt-1
  x(i) = pilag(i)
End do
x(neqt) = dlnn

Do while ((it <= nmaxit) .and. (.not.converge))

  ! compute chemical potential of all species
  Call compute_chemical_potential(nspec,nb_NASA_coef,spec,abun,abuntot, &
                                  pressure,tk,tkmid_therm,atherm,btherm,idtherm,mu)

  ! call Newton-Raphson routine, 1 iteration and back
  Call mnewt(neqt,nspec,nat,pilag,dlnn,abun,mu,b0,abuntot, &
             1,x,neqt,eps_dp,eps_dp,code)
  If (code == 1) Return

  ! update values of pi lagrange multipliers and Delta Ln(n)
  Do i = 1, neqt-1
    pilag(i) = x(i)
  End do
  dlnn = x(neqt)
  !dlnn = 0.0d0

  ! compute correction to abundances: Delta Ln[n(j)]
  Do j = 1, nspec
    dlnns(j) = 0.0d0
    Do k = 1, neqt-1
      dlnns(j) = dlnns(j) + nat(j,k)*pilag(k)
    End do
    dlnns(j) = dlnns(j) + dlnn - mu(j)
  End do

  ! compute control factor: lambda
  lambda1 = dabs(5.0d0*dlnn)
  lambda2 = Infini_dp
  Do j = 1, nspec
    If ((abun(j)/abuntot) > 1.0d-8) then
      If (dabs(dlnns(j)) > lambda1) lambda1 = dabs(dlnns(j))
    Else
      If (dlnns(j) >= 0.0d0) then
         ! La condition du if est parfois remplie et j'ai donc ajout� cette boucle if pour �viter un rwk=NAN
	If ((abun(j)/abuntot-dlog(1.0d4)) <= 0.0d0) then
	  rwk = Infini_dp
	Else
	  rwk = dabs((-dlog(abun(j)/abuntot-dlog(1.0d4))/(dlnns(j)-dlnn)))
        End if
        If (rwk < lambda2) lambda2 = rwk
      End if
    End if
  End do
  lambda1 = 2.0d0 / lambda1
  lambda  = min(1.0d0,lambda1,lambda2)

  ! update estimates of n and n(j)   (abuntot and abun(j), resp.)
  corr = lambda * dlnn
  If (corr >  0.4d0) corr =  0.4d0
  If (corr < -0.4d0) corr = -0.4d0
  abuntot = abuntot*dexp(corr)                                        ! apply correction to n
  Do j = 1, nspec
    corr = lambda * dlnns(j)
    If ((abun(j)/abuntot) > 1.0d-8) then
      If (corr >  2.0d0) corr =  2.0d0
      If (corr < -2.0d0) corr = -2.0d0
    End if
    rwk = abun(j)
    abun(j) = abun(j) * dexp(corr)                                    ! apply correction to abundances
    If (abun(j) > abunmax(j)) abun(j) = 0.5d0 * (rwk+abunmax(j))      ! correct if too high abundance
  End do

  ! verify convergence
  rwk=0.0d0
  Do j = 1, nspec
    rwk = rwk + abun(j)
  End do
  iwk = 0
  maxerr = 0.0d0
  Do j = 1, nspec
    err = abun(j) * dabs(dlnns(j)) / rwk
    If (err <= abtol) iwk = iwk + 1
    If (err > maxerr) maxerr = err
  End do
  err = abuntot * dabs(dlnn) / rwk
  If (err <= abtol)   iwk = iwk + 1
  If (err >  maxerr)  maxerr = err
  If (iwk == nspec+1) converge = .true.
  If (it  <  nminit)  converge = .false.

  it = it + 1

End do

End Subroutine minimize_gibbs_energy

!######################################################################

Subroutine compute_chemical_potential(nspec,nb_NASA_coef,spec,abun,abuntot, &
                                      pressure,tk,tkmid_therm,atherm,btherm,idtherm,mu)

Implicit None
Integer,          intent(in)  :: nspec
Integer,          intent(in)  :: nb_NASA_coef
Character(len=*), intent(in)  :: spec(nspec)     ! species name
Real(8),         intent(in)  :: abun(nspec)
Real(8),         intent(in)  :: abuntot
Real(8),         intent(in)  :: pressure
Real(8),         intent(in)  :: tk
Real(8),         intent(in)  :: tkmid_therm(nspec)
Real(8),         intent(in)  :: atherm(nspec,nb_NASA_coef)
Real(8),         intent(in)  :: btherm(nspec,nb_NASA_coef)
Integer,          intent(in)  :: idtherm(nspec)
Real(8),         intent(out) :: mu(nspec)

Real(8) :: h, s, a(7)
Integer  :: i, j

Do i = 1, nspec
  If (idtherm(i) == 1) then
    Do j = 1, 7
      If (tk >= tkmid_therm(i)) a(j) = atherm(i,j)
      If (tk <  tkmid_therm(i)) a(j) = btherm(i,j)
    End do
  Else
    Write(*,*) ' E- unknown therm data type for: ', spec(i)
    Stop
  End if
  h = a(1) + a(2)*tk/2.0d0 + a(3)*tk**2.0d0/3.0d0 + a(4)*tk**3.0d0/4.0d0 + a(5)*tk**4.0d0/5.0d0 + a(6)/tk
  s = a(1)*dlog(tk) + a(2)*tk + a(3)*tk**2.0d0/2.0d0 + a(4)*tk**3.0d0/3.0d0 + a(5)*tk**4.0d0/4.0d0 + a(7)
  ! Condition if remplie pour les esp�ces tr�s peu abondantes qui d�croissent en montant dans l'atmosph�re et tendent vers 0
  If (abun(i) == 0.0d0) then
    mu(i) = -750.0d0
  Else
    mu(i) = h - s + dlog(abun(i)/abuntot) + dlog(pressure)
  End if
End do

End Subroutine compute_chemical_potential

!######################################################################

End Module Md_ACE


!/ ------------------------------------------------------------------- /
      MODULE W3IORSMD
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    See subroutine for update log.
!/
!  1. Purpose :
!
!     Read/write restart files.
!
!  2. Variables and types :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      VERINI    C*10  Private  Restart file version number.
!      IDSTR     C*26  Private  Restart file UD string.
!     ----------------------------------------------------------------
!
!  3. Subroutines and functions :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      W3IORS    Subr. Public   Read/write restart files.
!     ----------------------------------------------------------------
!
!  4. Subroutines and functions used :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3SETO, W3SETG, W3SETW, W3DIMW
!                Subr. W3xDATMD Manage data structures.
!      STRACE    Subr. W3SERVMD Subroutine tracing.            (!/S)
!      EXTCDE    Subr. W3SERVMD Abort program with exit code.
!      MPI_STARTALL, MPI_WAITALL                              (!/MPI)
!                Subr.          MPI persistent communication routines
!     ----------------------------------------------------------------
!
!  5. Remarks :
!
!  6. Switches :
!
!     See also routine.
!
!  7. Source code :
!
!/ ------------------------------------------------------------------- /
      PUBLIC
!/
!/ Private parameter statements (ID strings)
!/
      CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERINI = 'III  3.01 '
      CHARACTER(LEN=26), PARAMETER, PRIVATE ::                        &
                               IDSTR = 'WAVEWATCH III RESTART FILE'
!/
      CONTAINS
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, INTYPE, IMOD )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    12-Jan-1999 : Final FORTRAN 77                    ( version 1.18 )
!/    27-Dec-1999 : Upgrade to FORTRAN 90               ( version 2.00 )
!/    30-Apr-2002 : Add ice for transparencies.         ( version 2.20 )
!/    13-Nov-2002 : Add stress as vector.               ( version 3.00 )
!/    19-Aug-2003 : Output server options added.        ( version 3.04 )
!/    09-Dec-2004 : Multiple grid version.              ( version 3.06 )
!/    24-Jun-2005 : Adding MAPST2.                      ( version 3.07 )
!/    27-Jun-2006 : Adding file name preamble.          ( version 3.09 )
!/    05-Jul-2006 : Consolidate stress arrays.          ( version 3.09 )
!/    08-May-2007 : Starting from calm as an option.    ( version 3.11 )
!/    17-May-2007 : Adding NTPROC/NAPROC separation.    ( version 3.11 )
!/    22-Jun-2007 : Dedicated output processes.         ( version 3.11 )
!/    15-Apr-2008 : Clean up for distribution.          ( version 3.14 )
!/    21-Apr-2008 : Remove PGI bug internal files.      ( version 3.14 )
!/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
!/
!/    Copyright 2009 National Weather Service (NWS),
!/       National Oceanic and Atmospheric Administration.  All rights
!/       reserved.  WAVEWATCH III is a trademark of the NWS.
!/       No unauthorized use without permission.
!/
!  1. Purpose :
!
!     Reads/writes restart files.
!
!  2. Method :
!
!     The file is opened within the routine, the name is pre-defined
!     and the unit number is given in the parameter list. The restart
!     file is written using UNFORMATTED write statements. The routine
!     generates new names when called more than once. File names are :
!
!                                 restart.FILEXT
!                                 restart1.FILEXT
!                                 restart2.FILEXT etc.
!
!     The file to be read thus always is unnumbered, whereas all
!     written files are automatically numbered.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       INXOUT  C*(*)  I   Test string for read/write, valid are:
!                          'READ' Reading of a restart file.
!                          'HOT'  Writing a full restart from the model.
!                          'COLD' Writing a cold start file.
!                          'WIND' Initialize fields using first wind
!                                 field.
!                          'CALM' Starting from calm conditions.
!       NDSR    Int.  I/O  File unit number.
!       DUMFPI  Real   I   Dummy values for FPIS for cold start.
!       INTYPE  Int.   O   Type of input field,
!                           0 : cold start,
!                           1 : cold start with fetch-limited spectra,
!                           2 : full restart,
!                           3 : for writing file.
!                           4 : starting from calm.
!       IMOD    Int.   I   Optional grid number, defaults to 1.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3INIT    Subr. W3INITMD Wave model initialization routine.
!      W3WAVE    Subr. W3WAVEMD Actual wave model routine.
!      WW3_STRT  Prog.   N/A    Initial conditions program.
!     ----------------------------------------------------------------
!
!  6. Error messages :
!
!       Tests on INXOUT, file status and on array dimensions.
!
!  7. Remarks :
!
!     - MAPSTA is dumped as it contains information on inactive points.
!       Note that the original MAPSTA is dumped in the model def. file
!       for use in the initial conditions (and output) programs.
!     - Note that MAPSTA and MAPST2 data is combinded in the file.
!     - The depth is recalculated in a write to avoid floting point
!       errors in W3STRT.
!     - Fields and field info read by all, written by las processor
!       only.
!     - The MPP version of the model will perform a gather here to
!       maximize hiding of communication with IO.
!
!  8. Structure :
!
!     +---------------------------------------------------------------+
!     | initialisations                                               |
!     | test INXOUT                                                   |
!     | open file                                                     |
!     +---------------------------------------------------------------|
!     |                             WRITE ?                           |
!     | Y                                                           N |
!     |-------------------------------|-------------------------------|
!     | Write identifiers and         | Write identifiers and         |
!     |   dimensions.                 |   dimensions.                 |
!     |                               | Check ident. and dimensions.  |
!     +-------------------------------+-------------------------------|
!     |                       Full restart ?                          |
!     | Y                                                           N |
!     |-------------------------------|-------------------------------|
!     | read/write/test time          |                               |
!     +-------------------------------+-------------------------------|
!     |                             WRITE ?                           |
!     | Y                                                           N |
!     |-------------------------------|-------------------------------|
!     |          TYPE = 'WIND' ?      |          TYPE = 'WIND' ?      |
!     | Y                           N | Y                           N |
!     |---------------|---------------|---------------|---------------|
!     | close file    | write spectra | gen. fetch-l. | read spectra  |
!     | RETURN        |               |   spectra.    |               |
!     |---------------+---------------+---------------+---------------|
!     |                             WRITE ?                           |
!     | Y                                                           N |
!     |-------------------------------|-------------------------------|
!     |          TYPE = 'FULL' ?      |          TYPE = 'FULL' ?      |
!     | Y                           N | Y                           N |
!     |---------------|---------------|---------------|---------------|
!     | write level & | ( prep. level | read level &  | initalize l.& |
!     |   (ice) map & |   for test    |   (ice) map.& |   times       |
!     |   times       |   output )    |   times       | ( no ice )    |
!     +---------------+---------------+---------------+-------------- +
!
!  9. Switches :
!
!     !/SEED  Linear input / seeding option.
!     !/LNx
!
!     !/SHRD  Switch for shared / distributed memory architecture.
!     !/DIST  Id.
!     !/MPI   Id.
!
!     !/LRBn  Word length in bites.
!
!     !/S     Enable subroutine tracing.
!     !/T     Enable test output
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      ! CESM specific use statements
      use shr_sys_mod, only : shr_sys_abort
      use w3cesmmd   , only : casename, initfile, runtype, stdout, inst_suffix

      USE W3GDATMD, ONLY: W3SETG
      USE W3ODATMD, ONLY: W3SETO
!/
      USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, NSPEC, MAPSTA, MAPST2, &
                          GNAME, FILEXT
      USE W3WDATMD
      USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, &
                          IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP
      USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, VAAUX
!/
      USE W3SERVMD, ONLY: EXTCDE

      ! QL, 150823, save in restart file
      ! QL, 160530, save LAMULT instead of LASLPJ and ALPHAL
      USE W3ADATMD, ONLY : LAMULT, USSX, USSY
!
      IMPLICIT NONE
!
      INCLUDE "mpif.h"
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)           :: NDSR
      INTEGER, INTENT(IN), OPTIONAL :: IMOD
      INTEGER, INTENT(OUT)          :: INTYPE
      REAL, INTENT(INOUT)           :: DUMFPI
      CHARACTER, INTENT(IN)         :: INXOUT*(*)
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER, PARAMETER      :: LRB = 8
!
      INTEGER                 :: IGRD, I, J, LRECL, NSIZE, IYS, IERR, &
                                 NSEAT, MSPEC, TTIME(2), ISEA, JSEA,  &
                                 NREC, NPART, IPART, IX, IY, IYL, IP
      INTEGER, ALLOCATABLE    :: MAPTMP(:,:)
      INTEGER                 :: IERR_MPI, IH, IB, ISEA0, ISEAN, &
                                 NRQ
      ! QL, 150629, for restart file name
      INTEGER                 :: YY,MM,DD,HH,MN,SS,TOTSEC
      INTEGER, ALLOCATABLE    :: STAT1(:,:), STAT2(:,:)
      LOGICAL                 :: WRITE, IOSFLG
      CHARACTER(LEN=4)        :: TYPE
      CHARACTER(LEN=10)       :: VERTST
      CHARACTER(LEN=256)      :: FNAME
      CHARACTER(LEN=26)       :: IDTST
      CHARACTER(LEN=30)       :: TNAME
      character(len=256)      :: error_msg
      logical                 :: exists    ! if file exists or not
!/
!/ ------------------------------------------------------------------- /
!/
!
      IOSFLG = IOSTYP .GT. 0
!
! test parameter list input ------------------------------------------ *
!
      IF ( PRESENT(IMOD) ) THEN
          IGRD   = IMOD
        ELSE
          IGRD   = 1
        END IF
!
      CALL W3SETO ( IGRD, NDSE, NDST )
      CALL W3SETG ( IGRD, NDSE, NDST )
      CALL W3SETW ( IGRD, NDSE, NDST )
!
      IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT'  .AND.               &
          INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND.               &
          INXOUT.NE.'CALM' ) THEN
          IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT
          CALL EXTCDE ( 1 )
        END IF
!
      WRITE = INXOUT .NE. 'READ'
      IF ( INXOUT .EQ. 'HOT' ) THEN
          TYPE   = 'FULL'
        ELSE
          TYPE   = INXOUT
        END IF
!
! initializations ---------------------------------------------------- *
!
      IF ( .NOT.DINIT ) THEN
          IF ( IAPROC .LE. NAPROC ) THEN
              CALL W3DIMW ( IMOD, NDSE, NDST )
            ELSE
              CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. )
            END IF
        END IF
!
      IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0.
!
      LRECL  = MAX ( LRB*NSPEC , LRB*NX ,                             &
                     LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) )
      NSIZE  = LRECL / LRB
      IYS    = NSIZE / NX
!
! open file ---------------------------------------------------------- *
!
!      I = LEN_TRIM(FILEXT)
      J = LEN_TRIM(FNMPRE)
!
!      IF ( IFILE.EQ.0 ) THEN
!          FNAME  = 'restart.'//FILEXT(:I)
!        ELSE
!          FNAME  = 'restartN.'//FILEXT(:I)
!          IF ( WRITE .AND. IAPROC.EQ.NAPRST )                         &
!               WRITE (FNAME(8:8),'(I1)') IFILE
!        END IF

      IFILE  = IFILE + 1
!
      YY =  TIME(1)/10000
      MM = (TIME(1)-YY*10000)/100
      DD = (TIME(1)-YY*10000-MM*100)
      HH = TIME(2)/10000
      MN = (TIME(2)-HH*10000)/100
      SS = (TIME(2)-HH*10000-MN*100)
      TOTSEC = HH*3600+MN*60+SS

      ! Open and read/write file
      if (len_trim(inst_suffix) > 0) then
         WRITE(FNAME,'(A,I4.4,A,I2.2,A,I2.2,A,I5.5)') &
              trim(CASENAME)//&
              &'.ww3'//trim(inst_suffix)//'.r.',YY,'-',MM,'-',DD,'-',TOTSEC
      else
         WRITE(FNAME,'(A,I4.4,A,I2.2,A,I2.2,A,I5.5)') &
              trim(CASENAME)//'.ww3.r.',YY,'-',MM,'-',DD,'-',TOTSEC
      ENDIF
      IF ( WRITE ) THEN
         IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST )             &
              OPEN (NDSR,FILE=FNAME,FORM='UNFORMATTED',       &
              ACCESS='DIRECT',RECL=LRECL,ERR=800,IOSTAT=IERR)
         IF ( IAPROC .EQ. NAPERR ) then
            WRITE (NDSE,*) ' wrote restart file ',trim(FNAME)
         end IF

      ELSE ! READ

         if (runtype /= 'continue') then
            FNAME = INITFILE
         end if
         ! initial file MUST exist, if not exit
         inquire( file=FNAME, exist=exists)
         if ( exists ) then
            IF ( IAPROC .EQ. NAPERR ) then
               WRITE (NDSE,*) ' reading initial file ',trim(FNAME)
            end IF
            OPEN (NDSR, FILE=FNAME, FORM='UNFORMATTED',          &
                 ACCESS='DIRECT',RECL=LRECL,ERR=800,IOSTAT=IERR, &
                 STATUS='OLD')
         ELSE
            error_msg = "required initial file " // trim(FNAME) // "does not exist"
            call shr_sys_abort(error_msg)
         END IF
      END IF
!

! test info ---------------------------------------------------------- *
!
      IF ( WRITE ) THEN
!
          IF ( IAPROC .EQ. NAPRST ) WRITE (NDSR,REC=1)                &
            IDSTR, VERINI, GNAME, TYPE, NSEA, NSPEC
          INTYPE = 3
!
        ELSE
          READ (NDSR,REC=1,ERR=802,IOSTAT=IERR)                       &
            IDTST, VERTST, TNAME, TYPE, NSEAT, MSPEC
!
          IF ( IDTST .NE. IDSTR ) THEN
              IF ( IAPROC .EQ. NAPERR )                               &
                  WRITE (NDSE,901) IDTST, IDSTR
              CALL EXTCDE ( 10 )
            END IF
          IF ( VERTST .NE. VERINI ) THEN
              IF ( IAPROC .EQ. NAPERR )                               &
                  WRITE (NDSE,902) VERTST, VERINI
              CALL EXTCDE ( 11 )
            END IF
          IF ( TNAME .NE. GNAME ) THEN
              IF ( IAPROC .EQ. NAPERR )                               &
                  WRITE (NDSE,903) TNAME, GNAME
            END IF
          IF (TYPE.NE.'FULL' .AND. TYPE.NE.'COLD' .AND.               &
              TYPE.NE.'WIND' .AND. TYPE.NE.'CALM' ) THEN
              IF ( IAPROC .EQ. NAPERR )                               &
                  WRITE (NDSE,904) TYPE
              CALL EXTCDE ( 12 )
            END IF
          IF (NSEAT.NE.NSEA .OR. NSPEC.NE.MSPEC) THEN
              IF ( IAPROC .EQ. NAPERR )                               &
                  WRITE (NDSE,905) MSPEC, NSEAT, NSPEC, NSEA
              CALL EXTCDE ( 13 )
            END IF
          IF (TYPE.EQ.'FULL') THEN
              INTYPE = 2
            ELSE IF (TYPE.EQ.'WIND') THEN
              INTYPE = 1
            ELSE IF (TYPE.EQ.'CALM') THEN
              INTYPE = 4
            ELSE
              INTYPE = 0
            END IF
!
        END IF
!
  100 CONTINUE
!
! TIME if required --------------------------------------------------- *
!
      IF (TYPE.EQ.'FULL') THEN
          IF ( WRITE ) THEN
              IF ( IAPROC .EQ. NAPRST ) WRITE (NDSR,REC=2) TIME
            ELSE
              READ (NDSR,REC=2,ERR=802,IOSTAT=IERR) TTIME
              ! Abort if the error check fails for a branch or continue run
              if (runtype == 'branch' .or. runtype == 'continue') then
                 IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN
                    IF ( IAPROC .EQ. NAPERR ) then
                       WRITE (NDSE,906) TTIME, TIME
                       CALL EXTCDE ( 20 )
                    END IF
                 END IF
              end if
           END IF
        END IF
!
! Spectra ------------------------------------------------------------ *
!          ( Bail out if write for TYPE.EQ.'WIND' )
!
      IF ( WRITE ) THEN
          IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN
              IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) CLOSE ( NDSR )
              RETURN
            ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN
!
! Original non-server version writing of spectra
!
              IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN
                  DO JSEA=1, NSEAL
                    ISEA   = IAPROC + (JSEA-1)*NAPROC
                    NREC   = ISEA + 2
                    WRITE (NDSR,REC=NREC) (VA(I,JSEA),I=1,NSPEC)
                    END DO
!
! I/O server version writing of spectra ( !/MPI )
!
                ELSE
!
                  IF ( IAPROC .NE. NAPRST ) THEN
                      NRQ    = 1
                    ELSE IF ( NAPRST .LE. NAPROC ) THEN
                      NRQ    = NAPROC - 1
                    ELSE
                      NRQ    = NAPROC
                    END IF
!
                  ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) )
                  IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL    &
                                      ( NRQ, IRQRSS, IERR_MPI )
!
                  DO IB=1, NBLKRS
                    ISEA0  = 1 + (IB-1)*RSBLKS*NAPROC
                    ISEAN  = MIN ( NSEA , IB*RSBLKS*NAPROC )
!
                    IF ( IAPROC .EQ. NAPRST ) THEN
!
                        IH     = 1 + NRQ * (IB-1)
                        CALL MPI_WAITALL                         &
                           ( NRQ, IRQRSS(IH), STAT1, IERR_MPI )
                        IF ( IB .LT. NBLKRS ) THEN
                            IH     = 1 + NRQ * IB
                            CALL MPI_STARTALL                    &
                               ( NRQ, IRQRSS(IH), IERR_MPI )
                          END IF
!
                        DO ISEA=ISEA0, ISEAN
                          NREC   = ISEA + 2
                          JSEA   = 1 + (ISEA-1)/NAPROC
                          IP     = 1 + MOD(ISEA-1,NAPROC)
                          IF ( IP .EQ. NAPRST ) THEN
                              WRITE (NDSR,REC=NREC) VA(:,JSEA)
                            ELSE
                              JSEA   = JSEA - 2*((IB-1)/2)*RSBLKS
                              WRITE (NDSR,REC=NREC)              &
                                     VAAUX(:,JSEA,IP)
                            END IF
                          END DO
!
                      ELSE
!
                        CALL MPI_STARTALL                        &
                           ( 1, IRQRSS(IB), IERR_MPI )
                        CALL MPI_WAITALL                         &
                           ( 1, IRQRSS(IB), STAT1, IERR_MPI )
!
                      END IF
                    END DO
!
                  DEALLOCATE ( STAT1 )
!
                END IF
!
            END IF
        ELSE
!
! Reading spectra
!
          IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN
            ELSE
              DO JSEA=1, NSEAL
                ISEA   = IAPROC + (JSEA-1)*NAPROC
                NREC   = ISEA + 2
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                         (VA(I,JSEA),I=1,NSPEC)
                END DO
            END IF
        END IF
!
! Water level etc. if required --------------------------------------- *
!     ( For cold start write test output and cold start initialize
!       water levels. Note that MAPSTA overwrites the one read from the
!       model definition file, so that it need not be initialized. )
!
      NREC   = NSEA + 3
      NPART  = 1 + (NSEA-1)/NSIZE
!
      IF ( WRITE ) THEN
!
          IF (TYPE.EQ.'FULL') THEN
!
              IF ( IAPROC .EQ. NAPRST ) THEN
!
                  ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) )
                  CALL MPI_WAITALL                               &
                     ( NRQRS, IRQRS , STAT2, IERR_MPI )
                  DEALLOCATE ( STAT2 )
!
                  WRITE (NDSR,REC=NREC) TLEV, TICE
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE,          &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE,          &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  ALLOCATE ( MAPTMP(NY,NX) )
                  MAPTMP = MAPSTA + 8*MAPST2
                  DO IY=1, NY, IYS
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          ((MAPTMP(IYL,IX),IX=1,NX),IYL=IY,           &
                                                    MIN(NY,IY+IYS-1))
                    END DO
                  DEALLOCATE ( MAPTMP )
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (UST(ISEA),ISEA=1+(IPART-1)*NSIZE,          &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE,       &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE,          &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE,         &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (LAMULT(ISEA),ISEA=1+(IPART-1)*NSIZE,       &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (USSX(ISEA),ISEA=1+(IPART-1)*NSIZE,         &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                  DO IPART=1,NPART
                    NREC  = NREC + 1
                    WRITE (NDSR,REC=NREC)                             &
                          (USSY(ISEA),ISEA=1+(IPART-1)*NSIZE,         &
                                          MIN(NSEA,IPART*NSIZE))
                    END DO
                END IF
            END IF
        ELSE
          IF (TYPE.EQ.'FULL') THEN
              READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR) TLEV, TICE
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE,              &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE,              &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              ALLOCATE ( MAPTMP(NY,NX) )
              DO IY=1, NY, IYS
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      ((MAPTMP(IYL,IX),IX=1,NX),IYL=IY,               &
                                                MIN(NY,IY+IYS-1))
                END DO
              MAPSTA = MOD(MAPTMP+2,8) - 2
              MAPST2 = (MAPTMP-MAPSTA) / 8
              DEALLOCATE ( MAPTMP )
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (UST(ISEA),ISEA=1+(IPART-1)*NSIZE,              &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE,           &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE,              &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE,             &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (LAMULT(ISEA),ISEA=1+(IPART-1)*NSIZE,           &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (USSX(ISEA),ISEA=1+(IPART-1)*NSIZE,             &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
              DO IPART=1,NPART
                NREC  = NREC + 1
                READ (NDSR,REC=NREC,ERR=802,IOSTAT=IERR)              &
                      (USSY(ISEA),ISEA=1+(IPART-1)*NSIZE,             &
                                      MIN(NSEA,IPART*NSIZE))
                END DO
            ELSE
              TLEV(1) = -1
              TLEV(2) =  0
              TICE(1) = -1
              TICE(2) =  0
              WLV     =  0.
              ICE     =  0.
              UST     =  1.
              USTDIR  =  0.
              ASF     =  1.
              FPIS    =  DUMFPI
            END IF
        END IF
!
! Close file --------------------------------------------------------- *
!
      IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) CLOSE ( NDSR )
!
      RETURN
!
! Escape locations read errors :
!
  800 CONTINUE
      TYPE   = 'CALM'
      INTYPE = 4
      IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR
      GOTO 100
!
  801 CONTINUE
      IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,991)
      CALL EXTCDE ( 30 )
!
  802 CONTINUE
      IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,992) IERR
      CALL EXTCDE ( 31 )
!
! Formats
!
  900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     ILLEGAL INXOUT VALUE: ',A/)
  901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     ILLEGAL IDSTR, READ : ',A/                       &
               '                   CHECK : ',A/)
  902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     ILLEGAL VERINI, READ : ',A/                      &
               '                    CHECK : ',A/)
  903 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS :'/              &
               '     ILLEGAL GNAME, READ : ',A/                       &
               '                   CHECK : ',A/)
  904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     ILLEGAL TYPE : ',A/)
  905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     CONFLICTING NSPEC, NSEA GRID : ',2I8/            &
               '                         EXPECTED : ',2I8/)
  906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/                &
               '     CONFLICTING TIMES: FILE : ',I10.8,I8.6/          &
               '                       MODEL : ',I10.8,I8.6/)
!
  990 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/             &
               '     ERROR IN OPENING FILE, ',                        &
                    'INITIALIZE WITH ''',A,''' INSTEAD'/              &
               '     IOSTAT =',I5/)
  991 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/               &
               '     PREMATURE END OF FILE'/)
  992 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/               &
               '     ERROR IN READING FROM FILE'/                     &
               '     IOSTAT =',I5/)
!
!/
!/ End of W3IORS ----------------------------------------------------- /
!/
      END SUBROUTINE W3IORS
!/
!/ End of module W3IORSMD -------------------------------------------- /
!/
      END MODULE W3IORSMD


!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Ole Amund Sovde, March 2016
!//=========================================================================
!// Mineral dust initialisation.
!//=========================================================================
module dead_inirun
  !// ----------------------------------------------------------------------
  !// MODULE: dead_inirun
  !// DESCRIPTION: Initialises DEAD using settings from CTM3
  !// ----------------------------------------------------------------------
  implicit none
  !// ----------------------------------------------------------------------
  character(len=*), parameter, private :: f90file = 'dead_inirun.f90'
  !// ----------------------------------------------------------------------
  private
  public inirun
  !// ----------------------------------------------------------------------

contains

  !// ----------------------------------------------------------------------
  subroutine inirun( &
       delt, &          ! I [s] Time step
       latwts, &        ! I [-] latitude weighting
       calday, &        ! I [1-366]
       mbl_name, &       ! I Name of mobilisation map to read
       mbl_fudgefactor)  ! I Fudge factor matching mobilisation map
    !// --------------------------------------------------------------------
    !// Purpose: Initialize dust stuff
    !//
    !// History: Taken from match_dst/src/inirun routine (in main.F).
    !//
    !// Rewritten for Oslo CTM2: Alf Grini (2002/2003)
    !// Checked for Oslo CTM3, Amund Sovde, October 2009
    !// Converted to f90 March 2016
    !// --------------------------------------------------------------------
    ! Choice of real8 /real4
    use dead_precision
    ! Grid definitions
    use pmgrid
    ! [mdl] Control variables, routines
    use dstctl
    ! [mdl] Nomenclature for outfld()
    use dstnm, only: dst_nm_cmn_ini
    ! [mdl] Physical constants for dust routines
    use dstcst, only:dst_cst_cmn_ini
    ! [mdl] Module initialization
    use dstcmnini, only:dst_msc_cmn_ini
    ! [mdl] Dust particle size distributions
    use dstpsd, only:dst_psd_ini,dst_psd_src_ini
    ! [mdl] Time-invariant boundary data sets
    use dsttibds, only:dst_tibds_ini
    ! [mdl] Time-varying boundary data sets
    use dsttvbds, only:dst_tvbds_ini
    ! Initialization of budget stuff
    use dstbdg, only:bdg_cmn_ini
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------

    !// INPUT
    real(r8), intent(in) :: &
         delt, &              !Timestep
         latwts(plat), &      !Latitude weights (0-1)
         calday               !Days for reading time varying input (real)
    character(len=*), intent(in) :: mbl_name ! Variable name for mobilisation
    real(r8), intent(in) :: mbl_fudgefactor  ! Fudge factor for mobilisation

    character(len=50) :: dstfile

    !// LOCAL VARIABLES
    integer :: J
    !// --------------------------------------------------------------------
    character(len=*), parameter :: subr = 'inirun'
    !// --------------------------------------------------------------------

    write(6,'(a)') f90file//':'//subr//': DEAD INIRUN'
    write(6,'(a,f12.3)') 'timestep:   ',delt
    write(6,'(a,f12.3)') 'calday:     ',calday
    !// Check if mbl_name is reasonable
    if (trim(mbl_name) .eq. 'NOT_SET') then
       write(6,'(a)') f90file//':'//subr//': mbl_name is not defined'
       write(6,'(a)') '  You need to define correct entry in the STV section'
       write(6,'(a)') '  of emission list, which sets the mbl_name.'
       stop
    end if
    if (mbl_fudgefactor .eq. 0._r8) then
       write(6,'(a)') f90file//':'//subr//': mbl_fudgefactor is not defined'
       write(6,'(a)') '  You need to define EFACT entry in the STV section'
       write(6,'(a)') '  of emission list.'
       stop
    end if
    write(6,'(a,es12.6)') 'mbl_fudgefactor: ',mbl_fudgefactor
    write(6,'(a)')        'mbl_name:        '//trim(mbl_name)

    do J = 1, plat
       write(6,'(a,i5,es24.15)') ' latwts',J,latwts(J)
    end do
    !// Initialize dust names (checked ok for CTM3)
    !// NB: dst_nm_cmn_ini() must be called before MATCH:src/deffld()
    call dst_nm_cmn_ini()

    !// Initialize time-invariant physical constants
    !// Variables are input to subroutine where variables are set for later use
    !// in dust subroutines. (checked ok for CTM3)
    call dst_cst_cmn_ini(mbl_fudgefactor)

    !//Initialize dust size distributions and miscellaneaous
    !// (checked ok for CTM3)
    call dst_psd_src_ini()

    !// Initialize size grid (checked ok for CTM3)
    call dst_psd_ini()

    !// Initialize miscellaneous common blocks (checked ok for CTM3)
    call dst_msc_cmn_ini()

    !// Initialize time-invariant boundary data from netCDF file
    !// (checked ok for CTM3)
    if (IPARW .eq. 128) then
       dstfile = 'dst_T42.nc'
    else if (IPARW .eq. 320) then
       dstfile = 'dst_T159.nc'
    else
       write(6,'(a)') f90file//':'//subr// &
            ': Not defined dst_Txxx.nc file for this resolution! - Stopping'
       stop
    end if

    !// Adjusted to read mobilisation name from input file
    call dst_tibds_ini(trim(dstfile),mbl_name)

    !// NB: dst_tibds_ini() opens and closes the file, while
    !// dst_tvbds_ini() opens the file and leaves it open
    !// Initialize time-varying seasonal cycle data from netCDF file
    !// (checked ok for CTM3)
    call dst_tvbds_ini(trim(dstfile),calday)
    !//Initialize fields derived from external datasets
    !// call dst_lsm_ini()

    !// --------------------------------------------------------------------
  end subroutine inirun
  !// ----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
end module dead_inirun
!//=========================================================================


MODULE GETHFREQOUT
! ** TO GET HIGH FREQUENCY OUTPUT FOR TIMESERIES
! ** NGROUP==0 FOR ALL GROUPS
! ** NPOINT==0 FOR ALL POINTS
! ** AUTHOR: DH CHUNG

USE GLOBALVARS
USE EFDCPROMOD,ONLY:FREEMEM
USE INFOMOD
USE IFPORT
USE TECMOD
USE XYIJCONV

IMPLICIT NONE

CONTAINS
SUBROUTINE GETHFREQ
INTEGER(4)    ::N,I,IS,nc_id,L,LS,ISO
INTEGER(4)    ::STATUS,ENDR,NCAL,NS
CHARACTER(200)::BUFFER, NCFILE*50,STR*5,MESS,NSTR*5
LOGICAL(4)    ::RES

DO N=1,NTSWQVM
  UOUTI(N)  = 200+N
  UCVPRF(N) = 300+N
ENDDO

!*** READ EFDC INPUT FILES AND DETERMINE THE MODEL GRID PARAMETERS

OPEN(1,FILE=SETSFILE,action='read')
CALL SKIPCOM(1,'*')
READ(1,*,IOSTAT=ISO) NSUBSET
IF(ISO>0) STOP 'SUBSET.INP: READING ERROR!'
ALLOCATE(HFREGRP(NSUBSET))
ALLOCATE(IJHFRE(NSUBSET),HFREDAYBG(NSUBSET),HFREDAYEN(NSUBSET))
ALLOCATE(HFREDUR(NSUBSET),HFREDAY(NSUBSET),HFREMIN(NSUBSET),NPNT(NSUBSET))
DO NS=1,NSUBSET
  CALL SKIPCOM(1,'*')
  READ(1,*,IOSTAT=ISO) IS,IJHFRE(IS),HFREDAYBG(IS),HFREDUR(IS),HFREMIN(IS),NPNT(IS)
  IF(ISO>0) STOP 'SUBSET.INP: READING ERROR!'
  HFREDAY(IS) = HFREDAYBG(IS)
  HFREDAYEN(IS) = HFREDAYBG(IS) + HFREDUR(IS)/24
  ALLOCATE (HFREGRP(IS)%ICEL(NPNT(IS)),HFREGRP(IS)%JCEL(NPNT(IS)))
  ALLOCATE (HFREGRP(IS)%XCEL(NPNT(IS)),HFREGRP(IS)%YCEL(NPNT(IS)))
  DO NP=1,NPNT(IS)
    CALL SKIPCOM(1,'*')
    IF (IJHFRE(IS)==1) THEN
      READ(1,*,IOSTAT=ISO) HFREGRP(IS)%ICEL(NP),HFREGRP(IS)%JCEL(NP)
    ELSE
      READ(1,*,IOSTAT=ISO) HFREGRP(IS)%XCEL(NP),HFREGRP(IS)%YCEL(NP)
    ENDIF
    IF(ISO>0) STOP 'SUBSET.INP: READING ERROR!'
  ENDDO
  IF (IJHFRE(IS)==0) CALL XY2IJ(HFREGRP(IS))
ENDDO
CLOSE(1)

CALL GETHFRE_HYD
IF( ANY(ISTRAN(1:7)>0) ) CALL HFRE_WC
IF(ISTRAN(8) > 0) CALL HFRE_WQ

DEALLOCATE(HFREGRP)
DEALLOCATE(IJHFRE,HFREDAYBG,HFREDAYEN)
DEALLOCATE(HFREDUR,HFREDAY,HFREMIN,NPNT)

CALL FREEMEM

END SUBROUTINE

SUBROUTINE GETHFRE_HYD
INTEGER(4)::NS,NCAL,ENDR,PMAX
INTEGER(4)::L,LN,K,NP,N,VER,HSIZE,KC1,ICEL,JCEL
REAL(4)   ::UTMPS,VTMPS,HPTMP(LCM)
REAL(8)   ::TIMEDAY,XCEL,YCEL
CHARACTER(200)::INPFILE,NSTR*3,NSTR1*7
CHARACTER(200),ALLOCATABLE::OUTFILE(:)

PMAX = MAXVAL(NPNT)
ALLOCATE(OUTFILE(PMAX))

WRITE(NSTR,'(I3)') 3*KC+3
SFMT = '('//NSTR//'F14.5)'
DO NS=1,NSUBSET
  IF (NGROUP>0 .AND. NS /= NGROUP) CYCLE
  WRITE(NSTR,'(I3.3)') NS
  INPFILE  = trim(OUTFOLDER)//'HFRE_HYD_'//TRIM(NSTR)//'.OUT'
  OPEN(10,FILE=INPFILE,ACTION='READ',STATUS='OLD',FORM='BINARY')
  DO NP=1,NPNT(NS)
    IF (NPOINT>0.AND.NP/=NPOINT) CYCLE
    WRITE(NSTR1,'(I3.3,A1,I3.3)') NS,'_',NP
    OUTFILE(NP)  = trim(OUTFOLDER)//'HFREDAT\HFRE_HYD_'//TRIM(NSTR1)//'.DAT'
    OPEN(11,FILE=OUTFILE(NP),ACTION='WRITE')
    WRITE(11,'(A)') 'TIMEDAY,BELV(L),HP(L),(U(L,K),V(L,K),W(L,K),K=1,KC)'
    CLOSE(11)
  ENDDO

  READ (10) VER,HSIZE
  READ (10) KC1
  READ (10) NPNT(NS)
  DO NP=1,NPNT(NS)
    READ (10) ICEL,JCEL,XCEL,YCEL
  ENDDO
  ! ** end of header **

  DO WHILE(1)
    READ (10,END=100) TIMEDAY
    DO NP=1,NPNT(NS)
      L = LIJ(HFREGRP(NS)%ICEL(NP),HFREGRP(NS)%JCEL(NP))
      READ(10) BELV(L),HPTMP(L),(U(L,K),V(L,K),W(L,K),K=1,KC)
      IF (NPOINT>0.AND.NP/=NPOINT) CYCLE
      OPEN(11,FILE=OUTFILE(NP),ACTION='WRITE',ACCESS='APPEND')
      WRITE(11,SFMT) TIMEDAY,BELV(L),HPTMP(L),(U(L,K),V(L,K),W(L,K),K=1,KC)
      CLOSE(11)
    ENDDO
  ENDDO
  100 CLOSE(10)
ENDDO
END SUBROUTINE

SUBROUTINE FREE_WC
  DEALLOCATE(SAL)
  DEALLOCATE(TEM)
  DEALLOCATE(DYE)
  DEALLOCATE(SFL)
  DEALLOCATE(TOX)
  DEALLOCATE(SED)
  DEALLOCATE(SND)
  DEALLOCATE(TEMB)
  DEALLOCATE(QQWV1)
  DEALLOCATE(SEDDIA)
  DEALLOCATE(KBT)
  DEALLOCATE(TAUBSED)
  DEALLOCATE(TAUBSND)
  DEALLOCATE(TAUB)
  DEALLOCATE(WVWHA)
  DEALLOCATE(WVFRQL)
  DEALLOCATE(WACCWE)
  DEALLOCATE(WVDISP)
  DEALLOCATE(WVHUU)
  DEALLOCATE(WVHVV)
  DEALLOCATE(WVHUV)
  DEALLOCATE(TOXB)
  DEALLOCATE(HBED)
  DEALLOCATE(BDENBED)
  DEALLOCATE(PORBED)
  DEALLOCATE(SEDB)
  DEALLOCATE(SNDB)
  DEALLOCATE(CQBEDLOADX)
  DEALLOCATE(CQBEDLOADY)
  DEALLOCATE(VFRBED)
  DEALLOCATE(SALA)
  DEALLOCATE(TEMA)
  DEALLOCATE(DYEA)
  DEALLOCATE(SFLA)
  DEALLOCATE(TOXA)
  DEALLOCATE(SEDA)
  DEALLOCATE(SNDA)
END SUBROUTINE

SUBROUTINE HFRE_WC
  INTEGER(4)::NCAL,NSS
  INTEGER*4 NP,VER,HSIZE,KC,ICEL,JCEL
  INTEGER*4 IWQ(40), NACTIVE, NWQVAR
  INTEGER*4 NS,NW,MW,I,ALLOVAR
  INTEGER*4 L,K,ISYS,NT,NX,N1,NSXD
  REAL(4)::WQ
  REAL(8)::EETIME,XCEL,YCEL
  CHARACTER(200)::OUTFILE,NSTR*3,NSTR1*7

  ALLOVAR=0
  DO NSS=1,NSUBSET
    IF (NGROUP>0 .AND. NSS /= NGROUP) CYCLE
    WRITE(NSTR,'(I3.3)') NSS
    WCFILEI  = trim(OUTFOLDER)//'HFRE_WC_'//TRIM(NSTR)//'.OUT'

    DO NP=1,NPNT(NSS)
      IF (NPOINT>0.AND.NP/=NPOINT) CYCLE
      WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
      IF(ISTRAN(1)==1) THEN
        SALTSF   = trim(OUTFOLDER)//'HFREDAT\SAL_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(11),FILE=SALTSF,ACTION='WRITE')   !TSER
        WRITE(UOUTI(11),'(A)') '** EETIME,SAL(L,K) [PPT], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(11))
      ENDIF
      IF(ISTRAN(2)==1) THEN
        TEMTSF   = trim(OUTFOLDER)//'HFREDAT\TEM_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(12),FILE=TEMTSF,ACTION='WRITE')                     !TSER
        WRITE(UOUTI(12),'(A)') '** EETIME,TEM(L,K) [C], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(12))
      ENDIF
      IF(ISTRAN(3)==1) THEN
        DYETSF   = trim(OUTFOLDER)//'HFREDAT\DYE_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(13),FILE=DYETSF,ACTION='WRITE')
        WRITE(UOUTI(13),'(A)') '** EETIME,DYE(L,K) [MG/L], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(13))
      ENDIF
      IF(ISTRAN(4)==1) THEN
        SFLTSF   = trim(OUTFOLDER)//'HFREDAT\SFL_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(14),FILE=SFLTSF,ACTION='WRITE')
        WRITE(UOUTI(14),'(A)') '** EETIME,SFL(L,K), GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(14))
      ENDIF
      IF(ISTRAN(5)==1) THEN
        TOXTSF  = trim(OUTFOLDER)//'HFREDAT\TOX_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(15),FILE=TOXTSF,ACTION='WRITE')
        WRITE(UOUTI(15),'(A)') '** EETIME,TOX(L,K,NTOX) [MG/L], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(15))
      ENDIF
      IF(ISTRAN(6)==1) THEN
        SEDTSF  = trim(OUTFOLDER)//'HFREDAT\SED_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(16),FILE=SEDTSF,ACTION='WRITE')
        WRITE(UOUTI(16),'(A)') '** EETIME,SED(L,K,NSED) [MG/L], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(16))
      ENDIF
      IF(ISTRAN(7)==1) THEN
        SNDTSF  = trim(OUTFOLDER)//'HFREDAT\SND_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
        OPEN(UOUTI(17),FILE=SNDTSF,ACTION='WRITE')
        WRITE(UOUTI(17),'(A)') '** EETIME,(SND(L,K,NSND) [MG/L], GRP_CELL: '//TRIM(NSTR1)
        CLOSE(UOUTI(17))
      ENDIF
    ENDDO

    ! *** WATER COLUMN AND TOP LAYER OF SEDIMENT
    OPEN(95,FILE=WCFILEI,STATUS='UNKNOWN',ACCESS='SEQUENTIAL',FORM='BINARY')
    READ(95) VER,HSIZE             ! File Format Version and Header Size
    READ(95) (ISTRAN(I),I=1,7)
    READ(95) KC,NSED,NSND,NTOX
    READ(95) NPNT(NSS)             ! Number of stations
    DO NP=1,NPNT(NSS)
      READ(95) ICEL,JCEL,XCEL,YCEL
    ENDDO

    NSXD=NSED+NSND

    IF (ALLOVAR==0) THEN
      ALLOCATE(SAL(LA,KC))
      ALLOCATE(TEM(LA,KC))
      ALLOCATE(DYE(LA,KC))
      ALLOCATE(SFL(LA,KC))
      ALLOCATE(TOX(LCM,KCM,NTXM))
      ALLOCATE(SED(LCM,KCM,NSCM))
      ALLOCATE(SND(LCM,KCM,NSNM))
      ALLOCATE(TEMB(LA))
      ALLOCATE(QQWV1(LA))
      ALLOCATE(SEDDIA(NSXD))
      ALLOCATE(KBT(LA))
      ALLOCATE(TAUBSED(LA))
      ALLOCATE(TAUBSND(LA))
      ALLOCATE(TAUB(LA))
      ALLOCATE(WVWHA(LA))
      ALLOCATE(WVFRQL(LA))
      ALLOCATE(WACCWE(LA))
      ALLOCATE(WVDISP(LA,KC))
      ALLOCATE(WVHUU(LA,KC))
      ALLOCATE(WVHVV(LA,KC))
      ALLOCATE(WVHUV(LA,KC))
      ALLOCATE(TOXB(LA,KBM,NTOX))
      ALLOCATE(HBED(LA,KBM))
      ALLOCATE(BDENBED(LA,KBM))
      ALLOCATE(PORBED(LA,KBM))
      ALLOCATE(SEDB(LA,KBM,NSED))
      ALLOCATE(SNDB(LA,KBM,NSND))
      ALLOCATE(CQBEDLOADX(LA,NSND))
      ALLOCATE(CQBEDLOADY(LA,NSND))
      ALLOCATE(VFRBED(LA,KBM,NSTM))
      ALLOCATE(SALA(LA))
      ALLOCATE(TEMA(LA))
      ALLOCATE(DYEA(LA))
      ALLOCATE(SFLA(LA))
      ALLOCATE(TOXA(LCM,NTXM))
      ALLOCATE(SEDA(LCM,NSCM))
      ALLOCATE(SNDA(LCM,NSNM))
      ALLOVAR=1
    ENDIF

    DO WHILE(1)
      ! *** WATER COLUMN AND TOP LAYER OF SEDIMENT
      READ(95,END=100) EETIME,NACTIVE
      IF(ISTRAN(6) == 1 .OR. ISTRAN(7) >= 1)THEN
        DO NP=1,NPNT(NSS)
          L = LIJ(HFREGRP(NSS)%ICEL(NP),HFREGRP(NSS)%JCEL(NP))
          READ(95)KBT(L)
        ENDDO
      ENDIF

      ! *** WRITE THE WATER COLUMN AND TOP LAYER OF SEDIMENT DATA, IF NEEDED
      DO NP=1,NPNT(NSS)
        L = LIJ(HFREGRP(NSS)%ICEL(NP),HFREGRP(NSS)%JCEL(NP))
        IF(ISTRAN(1) == 1) THEN
          READ(95)(SAL(L,K),K=1,KC)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            N1=KBT(L)
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            SALTSF   = trim(OUTFOLDER)//'HFREDAT\SAL_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(11),FILE=SALTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(11),'(101F14.5)') REAL(EETIME),(SAL(L,K),K=1,KC)
            CLOSE(UOUTI(11))
          ENDIF
        ENDIF

        IF(ISTRAN(2) == 1)THEN
          READ(95)(TEM(L,K),K=1,KC)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            TEMTSF   = trim(OUTFOLDER)//'HFREDAT\TEM_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(12),FILE=TEMTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(12),'(101F14.5)') REAL(EETIME),(TEM(L,K),K=1,KC)
            CLOSE(UOUTI(12))
          ENDIF
        ENDIF

        IF(ISTRAN(3) == 1) THEN
          READ(95,ERR=999,IOSTAT=ISYS)(DYE(L,K),K=1,KC)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            DYETSF   = trim(OUTFOLDER)//'HFREDAT\DYE_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(13),FILE=DYETSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(13),'(101F14.5)') REAL(EETIME),(DYE(L,K),K=1,KC)
            CLOSE(UOUTI(13))
          ENDIF
        ENDIF

        IF(ISTRAN(4) == 1) THEN
          READ(95)(SFL(L,K),K=1,KC)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            SFLTSF   = trim(OUTFOLDER)//'HFREDAT\SFL_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(14),FILE=SFLTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(14),'(101F14.5)') REAL(EETIME),(SFL(L,K),K=1,KC)
            CLOSE(UOUTI(14))
          ENDIF
        ENDIF

        IF(ISTRAN(5) == 1)THEN
          READ(95)((TOX(L,K,NT),K=1,KC),NT=1,NTOX)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            TOXTSF  = trim(OUTFOLDER)//'HFREDAT\TOX_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(15),FILE=TOXTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(15),'(101F14.5)') REAL(EETIME),((TOX(L,K,NT),K=1,KC),NT=1,NTOX)
            CLOSE(UOUTI(15))
          ENDIF
        ENDIF

        IF(ISTRAN(6) == 1)THEN
          READ(95)((SED(L,K,NS),K=1,KC),NS=1,NSED)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            SEDTSF  = trim(OUTFOLDER)//'HFREDAT\SED_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(16),FILE=SEDTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(16),'(101F14.5)') REAL(EETIME),((SED(L,K,NS),K=1,KC),NS=1,NSED)
            CLOSE(UOUTI(16))
          ENDIF
        ENDIF

        IF(ISTRAN(7) == 1)THEN
          READ(95)((SND(L,K,NX),K=1,KC),NX=1,NSND)
          IF (NPOINT==0.OR.(NP==NPOINT)) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            SNDTSF  = trim(OUTFOLDER)//'HFREDAT\SND_TS_CELLS_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(17),FILE=SNDTSF,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(17),'(101F14.5)') REAL(EETIME),((SND(L,K,NX),K=1,KC),NX=1,NSND)
            CLOSE(UOUTI(17))
          ENDIF
        ENDIF
      ENDDO
    ENDDO
    100 CLOSE(95)
  ENDDO
  CALL FREE_WC
  RETURN
  999 PRINT*,TRIM(WCFILEI)//': READING ERROR'
  STOP
END SUBROUTINE

SUBROUTINE HFRE_WQ
  IMPLICIT NONE
  INTEGER(4)::NCAL,NSS
  INTEGER*4 NP,N
  INTEGER*4 IWQ(40), NACTIVE, NWQVAR
  INTEGER*4 NS,NW,MW
  INTEGER*4 L,K,KC,ICEL,JCEL
  INTEGER*4 VER,HSIZE
  REAL(8):: EETIME,XCEL,YCEL
  REAL(4),ALLOCATABLE::WQ(:,:)
  CHARACTER(50)::NSTR*3,NSTR1*7,TSFILE*200

    CHCTSF = 'CHC_TS_CELLS.DAT'
    CHDTSF = 'CHD_TS_CELLS.DAT'
    CHGTSF = 'CHG_TS_CELLS.DAT'
    ROCTSF = 'ROC_TS_CELLS.DAT'
    LOCTSF = 'LOC_TS_CELLS.DAT'
    DOCTSF = 'DOC_TS_CELLS.DAT'
    ROPTSF = 'ROP_TS_CELLS.DAT'
    LOPTSF = 'LOP_TS_CELLS.DAT'
    DOPTSF = 'DOP_TS_CELLS.DAT'
    P4DTSF = 'P4D_TS_CELLS.DAT'
    RONTSF = 'RON_TS_CELLS.DAT'
    LONTSF = 'LON_TS_CELLS.DAT'
    DONTSF = 'DON_TS_CELLS.DAT'
    NHXTSF = 'NHX_TS_CELLS.DAT'
    NOXTSF = 'NOX_TS_CELLS.DAT'
    SUUTSF = 'SUU_TS_CELLS.DAT'
    SAATSF = 'SAA_TS_CELLS.DAT'
    CODTSF = 'COD_TS_CELLS.DAT'
    DOXTSF = 'DOX_TS_CELLS.DAT'
    TAMTSF = 'TAM_TS_CELLS.DAT'
    FCBTSF = 'FCB_TS_CELLS.DAT'
    CO2TSF = 'CO2_TS_CELLS.DAT'
    MACTSF = 'MAC_TS_CELLS.DAT'

    TSWQF(1:23) = (/CHCTSF,CHDTSF,CHGTSF,ROCTSF,LOCTSF,DOCTSF,ROPTSF,LOPTSF,&
                  DOPTSF,P4DTSF,RONTSF,LONTSF,DONTSF,NHXTSF,NOXTSF,SUUTSF,SAATSF,CODTSF,&
                  DOXTSF,TAMTSF,FCBTSF,CO2TSF,MACTSF /)

  DO NSS=1,NSUBSET
    IF (NGROUP>0 .AND. NSS /= NGROUP) CYCLE
    WRITE(NSTR,'(I3.3)') NSS
    WQFILEI  = trim(OUTFOLDER)//'HFRE_WQ_'//TRIM(NSTR)//'.OUT'

    ! *** WATER QUALITY MODEL (HEM3D) RESULTS
    OPEN(95,FILE=WQFILEI,STATUS='UNKNOWN',ACCESS='SEQUENTIAL',FORM='BINARY')
    READ(95) VER,HSIZE
    READ(95) KC,NWQVAR
    ALLOCATE(WQ(KC,NWQVAR))
    READ(95) NPNT(NSS)
    DO NP=1,NPNT(NSS)
      READ(95) ICEL,JCEL,XCEL,YCEL
    ENDDO
    READ(95)(IWQ(NW),NW=1,NWQVAR)
    ! ** END HEADER

    DO NP=1,NPNT(NSS)
      IF (NPOINT>0.AND.NP/=NPOINT) CYCLE
      DO N=1,NWQVAR
        IF (IWQ(N)>=1) THEN
          WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
          TSFILE = trim(OUTFOLDER)//'HFREDAT\'//TRIM(TSWQF(N))//'_'//TRIM(NSTR1)//'.DAT'
          OPEN(UOUTI(N),FILE=TSFILE,ACTION='WRITE')
          WRITE(UOUTI(N),'(A)') 'JULTIME,('//TSWQF(N)(1:3)//'(K),K=1,KC),GRP_CELL: '//TRIM(NSTR1)
          CLOSE(UOUTI(N))
        ENDIF
      ENDDO
    ENDDO

    WQ = -999
    DO WHILE(1)
      READ(95,END=100)EETIME
      DO NP=1,NPNT(NSS)
      DO K=1,KC
        DO NW=1,NWQVAR
          IF(IWQ(NW) > 0)THEN
            READ(95)WQ(K,NW)
          ENDIF
        ENDDO
      ENDDO
      ENDDO

      DO NP=1,NPNT(NSS)
        IF (NPOINT>0.AND.NP/=NPOINT) CYCLE
        DO NW=1,NWQVAR
          IF(IWQ(NW) > 0) THEN
            WRITE(NSTR1,'(I3.3,A1,I3.3)') NSS,'_',NP
            TSFILE = trim(OUTFOLDER)//'HFREDAT\'//TRIM(TSWQF(NW))//'_'//TRIM(NSTR1)//'.DAT'
            OPEN(UOUTI(NW),FILE=TSFILE,ACTION='WRITE',ACCESS='APPEND')
            WRITE(UOUTI(NW),'(101F14.5)') REAL(EETIME),(WQ(K,NW),K=1,KC)
            CLOSE(UOUTI(NW))
          ENDIF
        ENDDO
      ENDDO
    ENDDO
    100 CLOSE(95)
    DEALLOCATE(WQ)
  ENDDO
  RETURN
  999 PRINT*,TRIM(WQFILEI)//': READING ERROR'
  STOP

END SUBROUTINE

END MODULE


C=======================================================================
C  TR_OPGROW, Subroutine
C
C  Generates output for growth data for Taro
C-----------------------------------------------------------------------
C  Revision history
C  08/18/2005 CHP Written based on PT_OPGROW
C=======================================================================

      SUBROUTINE TR_OPGROW (CONTROL, ISWITCH, SOILPROP,   !Input
     &    BIOMAS, CORMWT, DEADLF, DTT, ISTAGE,            !Input
     &    LAI, LFWT, MDATE, NLAYR, NSTRES, PLTPOP,        !Input
     &    RLV, ROOTN, RTDEP, RTWT, SATFAC, SENESCE,       !Input
     &    PETWT, STOVN, STOVWT, SWFAC, CORMN,             !Input
     &    MCORMWT, CORMLNO,                               !Input
     &    TURFAC, WTNCAN, WTNUP, XLAI, YRPLT)             !Input

!-----------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
      IMPLICIT  NONE
      SAVE

      CHARACTER*1   IDETG, ISWNIT
      CHARACTER*12  OUTG, OUTPN
      CHARACTER*30 FILEIO
      CHARACTER*120 NITHEAD(4)
      CHARACTER*250 GROHEAD(4), TEXT

      INTEGER DAP, DAS, DOY, DYNAMIC, FROP
      INTEGER I, ISTAGE, L, NLAYR
      INTEGER NOUTPN, NOUTDG, RUN, TIMDIF
      INTEGER YEAR, YRDOY, MDATE, YRPLT

      REAL LAI, XLAI,PETWT,SDWT,WTLF,BIOMAS,RTWT,PODWT,SEEDNO
      REAL SLA,PCNL,TURFAC,CANHT,CANWH,RLV(NL),HI,SHELPC
      REAL PODNO,RTDEP,NSTRES,SWFAC,SATFAC,PLTPOP,GM2KG
      REAL FRYLD,DEADLF, DTT, CORMWT, MCORMWT, CORMLNO

      REAL LFWT, PCNGRN, PCNRT
      REAL PCNST, PCNVEG, ROOTN
      REAL STOVN, STOVWT
      REAL CORMN, WTNCAN
      REAL WTNLF, WTNSD, WTNSH, WTNST
      REAL WTNUP, WTNVEG

      REAL CUMSENSURF, CUMSENSOIL, CUMSENSURFN, CUMSENSOILN

      LOGICAL FEXIST

!-----------------------------------------------------------------------
!     Define constructed variable types based on definitions in
!     ModuleDefs.for.

!     The variable "CONTROL" is of type "ControlType".
      TYPE (ControlType) CONTROL

!     The variable "ISWITCH" is of type "SwitchType".
      TYPE (SwitchType) ISWITCH
      TYPE (ResidueType)SENESCE
      TYPE (SoilType)   SOILPROP

!     Transfer values from constructed data types into local variables.
      IDETG   = ISWITCH % IDETG
      IF (IDETG .NE. 'Y') RETURN

      DAS     = CONTROL % DAS
      DYNAMIC = CONTROL % DYNAMIC
      FILEIO  = CONTROL % FILEIO
      FROP    = CONTROL % FROP
      RUN     = CONTROL % RUN
      YRDOY   = CONTROL % YRDOY

      ISWNIT  = ISWITCH % ISWNIT

C-----------------------------------------------------------------------
      DATA GROHEAD /
!      DATA GROHEAD(1)/
     &'!          Days  Days        Leaf Fresh
     &                                    <----Stress (0-1)---->  Leaf S
     &hell  Spec  <-Canopy->  Root    <---Root Length Density by layer--
     &->   Grow',

!      DATA GROHEAD(2)/
     &'!         after after  Grow  Area Yield  <--------- Dry Weight (k
     &g/ha) --------->  Harv <---Corm-->  <-----Water---->  Nitr   Nit
     &-ing  Leaf  Hght Width   Dep    <--------cm[root]/cm3[soil]-------
     &-> Degree',

!      DATA GROHEAD(3)/
     &'!<-Date->   sim plant Stage Index Mg/Ha  Leaf Petiole Corm Root
     &Crop  Tops DLeaf Index kg/ha   No.  Phot  Grow Exces           %
     &   %  Area     m     m     m
     &     Days',

!      DATA GROHEAD(4) /
     &'@YEAR DOY   DAS   DAP  GSTD  LAID  UYAD  LWAD  SWAD  UWAD  RWAD
     &TWAD  CWAD  DWAD  HIAD  EWAD  E#AD  WSPD  WSGD  EWSD  NSTD  LN%D
     &SH%D  SLAD  CHTD  CWID  RDPD    RL1D    RL2D    RL3D    RL4D    RL
     &5D   DTTD'/

C-----------------------------------------------------------------------
      DATA NITHEAD /
!      DATA NITHEAD(1)/
     &'!          Days  Days',

!      DATA NITHEAD(2)/
     &'!         after after <--------- N mass (kg/ha) -------->  <-----
     &------ N % ---------->',

!      DATA NITHEAD(3)/
     &'!<-Date->   sim plant Uptak  Crop   Veg  Leaf  Stem  Corm  Corm
     & Veg  Leaf  Stem  Root',

!      DATA NITHEAD(4)/
     &'@YEAR DOY   DAS   DAP  NUPC  TUNA  VNAD  LNAD  SNAD  UNAD  UN%D
     &VN%D  LN%D  SN%D  RN%D'/

!***********************************************************************
!***********************************************************************
!     Run initialization - run once per simulation
!***********************************************************************
      IF (DYNAMIC .EQ. RUNINIT) THEN
!-----------------------------------------------------------------------
        OUTG  = 'PlantGro.OUT'
        CALL GETLUN('OUTG',  NOUTDG)

        OUTPN  = 'PlantN.OUT  '
        CALL GETLUN('OUTPN', NOUTPN)

!***********************************************************************
!***********************************************************************
!     Seasonal initialization - run once per season
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. SEASINIT) THEN
!-----------------------------------------------------------------------
!     Initialize daily growth output file
        INQUIRE (FILE = OUTG, EXIST = FEXIST)
        IF (FEXIST) THEN
          OPEN (UNIT = NOUTDG, FILE = OUTG, STATUS = 'OLD',
     &      POSITION = 'APPEND')
          !FIRST = .FALSE.
        ELSE
          OPEN (UNIT = NOUTDG, FILE = OUTG, STATUS = 'NEW')
          WRITE(NOUTDG,'("*GROWTH ASPECTS OUTPUT FILE")')
          !FIRST = .TRUE.
        ENDIF

        !Write headers
        CALL HEADER(SEASINIT, NOUTDG, RUN)

!       Fill in layer depths in GROHEAD(3)
        TEXT = GROHEAD(3)
        WRITE (GROHEAD(3),'(A159,5A8,A21)')
     &      TEXT(1:159),(SoilProp%LayerText(L),L=1,5),TEXT(200:220)

C       Variable heading for GROWTH.OUT
        WRITE (NOUTDG,2192) GROHEAD(1)
        WRITE (NOUTDG,2192) GROHEAD(2)
        WRITE (NOUTDG,2192) GROHEAD(3)
        WRITE (NOUTDG,2192) GROHEAD(4)
 2192   FORMAT (A227)

        SEEDNO = 0.0
        !GPP   = 0.0
        !WTNUP = 0.0
        CANHT = 0.0
        CANWH = 0.0

!-----------------------------------------------------------------------
!     Initialize daily plant nitrogen output file
      IF (ISWNIT .EQ. 'Y') THEN
        INQUIRE (FILE = OUTPN, EXIST = FEXIST)
        IF (FEXIST) THEN
          OPEN (UNIT = NOUTPN, FILE = OUTPN, STATUS = 'OLD',
     &      POSITION = 'APPEND')
          !FIRST = .FALSE.
        ELSE
          OPEN (UNIT = NOUTPN, FILE = OUTPN, STATUS = 'NEW')
          WRITE(NOUTPN,'("*PLANT N OUTPUT FILE")')
          !FIRST = .TRUE.
        ENDIF

        CALL HEADER(SEASINIT, NOUTPN, RUN)

        WRITE (NOUTPN,2240) NITHEAD(1)
        WRITE (NOUTPN,2240) NITHEAD(2)
        WRITE (NOUTPN,2240) NITHEAD(3)
        WRITE (NOUTPN,2240) NITHEAD(4)
 2240   FORMAT (A110)
      ENDIF

      CUMSENSURF  = 0.0
      CUMSENSOIL  = 0.0
      CUMSENSURFN = 0.0
      CUMSENSOILN = 0.0

!***********************************************************************
!***********************************************************************
!     Daily Output
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. OUTPUT) THEN
C-----------------------------------------------------------------------
      IF (YRDOY .LT. YRPLT .AND. YRPLT .GT. 0) RETURN

!     Accumulate senesced matter for surface and soil.
      CUMSENSURF  = CUMSENSURF  + SENESCE % ResWt(0)
      CUMSENSURFN = CUMSENSURFN + SENESCE % ResE(0,1)
      DO L = 1, NLAYR
        CUMSENSOIL  = CUMSENSOIL  + SENESCE % ResWt(L)
        CUMSENSOILN = CUMSENSOILN + SENESCE % ResE(L,1)
      ENDDO

!     Compute reported growth variables
      SDWT   = CORMWT           !SDWT used by OPHARV, OPPHO and OPSEQ
      WTLF   = LFWT   * PLTPOP !WTLF used by OPNIT, OPPHO and OPOPS

      IF (WTLF .GT. 0.0) THEN
        SLA  = XLAI * 10000 / WTLF
      ELSE
        SLA  = 0.0
      ENDIF

      PODWT  = 0.0
      PODNO = 0.0

      IF (STOVWT .GT. 0.0) THEN
        WTNLF = STOVN * (LFWT  / STOVWT) * PLTPOP
      ELSE
        WTNLF = 0.0
      ENDIF

      IF (LFWT*PLTPOP .GT. 0.0) THEN
        PCNL = WTNLF /( LFWT * PLTPOP) * 100.0
      ELSE
        PCNL = 0.0
      ENDIF

C
C     GM2KG converts gm/plant to kg/ha
C
      GM2KG  = PLTPOP * 10.0
      SHELPC = 0.0
      IF (PODWT .GT. 0.1) THEN
        SHELPC = SDWT*100.0/PODWT
      ENDIF

!     Local variable HI used in OPHARV with different formula
      HI = 0.0
      IF (BIOMAS .GT. 0.0 .AND. SDWT .GE. 0.0) THEN
        HI = CORMWT/BIOMAS          ! 12/5/14 BIOMAS AND CORMWT IN G/PLANT
      ENDIF
!      YIELD  = CORMWT*10.*PLTPOP
!      FRYLD = (YIELD/1000.)/0.2
      FRYLD = (CORMWT*GM2KG/1000.)* 3  ! 12/5/14 Fresh yield with 200% moisture

!---------------------------------------------------------------------------
!     Compute reported plant N variables
      WTNCAN = (STOVN + CORMN) * PLTPOP
      IF (LFWT + PETWT > 1.E-6) THEN
        WTNST = STOVN * (PETWT  / (LFWT + PETWT)) * PLTPOP
        WTNLF = STOVN *  (LFWT /  (LFWT + PETWT)) * PLTPOP
      ELSE
        WTNST = 0.0
        WTNLF = 0.0
      ENDIF

      WTNSD = CORMN * PLTPOP
      WTNSH = 0.0
      IF (LFWT*PLTPOP .GT. 0.0) THEN
        PCNL = WTNLF /( LFWT * PLTPOP) * 100.0
      ELSE
        PCNL = 0.0
      ENDIF
      IF (PETWT*PLTPOP .GT. 0.0) THEN
        PCNST = WTNST/(PETWT * PLTPOP) * 100.0
      ELSE
        PCNST = 0.0
      ENDIF
      IF (RTWT .GT. 0.0) THEN
        PCNRT = ROOTN/RTWT * 100.0
      ELSE
        PCNRT = 0.0
      ENDIF

      WTNVEG  = (WTNLF + WTNST)
      IF ((WTLF+PETWT) .GT. 0.0) THEN
        PCNVEG = (WTNLF+WTNST)/(WTLF+(PETWT*PLTPOP))*100.0
      ELSE
        PCNVEG = 0.0
      ENDIF

      IF (CORMWT .GT. 0.0) THEN
        PCNGRN = CORMN*100.0/CORMWT
      ELSE
        PCNGRN = 0.0
      ENDIF

!---------------------------------------------------------------------------
      IF ((MOD(DAS,FROP) .EQ. 0)          !Daily output every FROP days,
     &  .OR. (YRDOY .EQ. YRPLT)           !on planting date, and
     &  .OR. (YRDOY .EQ. MDATE)) THEN     !at harvest maturity

        DAP = MAX(0,TIMDIF(YRPLT,YRDOY))
        IF (DAP > DAS) DAP = 0
        CALL YR_DOY(YRDOY, YEAR, DOY)

!       PlantGro.out file
        IF (IDETG .EQ. 'Y') THEN
          WRITE (NOUTDG,400)YEAR, DOY, DAS, DAP, ISTAGE, LAI, FRYLD,
     &        NINT(LFWT*GM2KG), NINT(PETWT*GM2KG), NINT(CORMWT*GM2KG),
     &        NINT(RTWT*GM2KG), NINT(BIOMAS*GM2KG),
     &        NINT(WTLF*10.0)+NINT(PETWT*GM2KG), NINT(DEADLF*GM2KG), HI,
     &        NINT(MCORMWT*GM2KG), NINT(CORMLNO), 1.0-SWFAC, 1.0-TURFAC,
     &        SATFAC, 1.0-NSTRES, PCNL, SHELPC, SLA, CANHT, CANWH,
     &        (RTDEP/100), (RLV(I),I=1,5),DTT
 400      FORMAT (1X,I4,1X,I3.3,3(1X,I5),1X,F5.3,1X,F5.1,7(1X,I5),
     &          1X,F5.3,2(1X,I5),4(1X,F5.3),2(1X,F5.2),1X,F5.1,
     &          3(1X,F5.2),5(1X,F7.2), F7.2)
        ENDIF

C-----------------------------------------------------------------------
!       From OPNIT.OUT
        IF (ISWNIT .EQ. 'Y') THEN
          WRITE (NOUTPN,300) YEAR, DOY, DAS, DAP, WTNUP, (WTNCAN*10.0),
     &            (WTNVEG*10.0), (WTNLF*10.0), (WTNST*10.0),
     &            (WTNSD*10.0), PCNGRN, PCNVEG,
     &            PCNL, PCNST, PCNRT
 300      FORMAT (1X,I4,1X,I3.3,2(1X,I5),6(1X,F5.1),5(1X,F5.2))
        ENDIF
      ENDIF

!***********************************************************************
!***********************************************************************
!     Seasonal Output
!***********************************************************************
      ELSE IF (DYNAMIC .EQ. SEASEND) THEN
C-----------------------------------------------------------------------
        !Close daily output files.
        CLOSE (NOUTDG)
        CLOSE (NOUTPN)

!***********************************************************************
!***********************************************************************
!     END OF DYNAMIC IF CONSTRUCT
!***********************************************************************
      ENDIF
!***********************************************************************
      RETURN
      END SUBROUTINE TR_OPGROW
!=======================================================================