      subroutine hydropac(lunit,xlboff)
*
* Adapted from MARCS35 routine. BPz 30/06-1998. Redone 2003-11-14/KE
*  This version is from Paul Barkleem.

* further modified by BPz 10/09-2004 for compatibility with Montpellier
* version of bsyn. Only slight remaining problem: the continuous
* contribution of H I dissolved states is properly included in the
* continuum opacity for computation of spectrum, but is not included
* in absocont, which is used for dump of opacity for multi for example.
* maybe it is now. 071204
*
* BPz 27/02-2015:

* compute H I line opacity     BPz 3/06-1998
*
      implicit none

      include 'spectrum.inc'

      character comment*100,species*20,lname*9
      integer ion,nline,ntau,iter,nlo,nup,l,k,i,lstart,lstartp,
     &        nmy,nlbldu,iint,iweak,lunit,maxlam,ll,
     ,        jlcont, nlcont
      doubleprecision ionpot,hlambda,wave,xl1,xl2,del,xlboff,xlambda
      real*8  vacair,edge(6)
      real fpart(ndp),pe,t,xlo,pg,xi,mum,ro,eps,xmyc,
     &     xup,gf,ne(ndp),
     &     nh1(ndp),nhe1(ndp),hnorm,hnormnostim(ndp),stim,
     &     diff,diffp,theta(ndp),hckt(ndp),abso,absos,absocont,
     &     dopple(ndp),contrib,xkapr,cross,hlinop,h1bfg,alpha,
     ,     ee(6),d0(ndp),d(lpoint,ndp)
      logical  lymanalpha, usedam,notfound
*
      common /atmos/ t(ndp),pe(ndp),pg(ndp),xi(ndp),mum(ndp),ro(ndp),
     &               ntau
      doubleprecision presneutral,presion,presion2,presion3, h1bfgc(30)
      common /orderedpress/ presneutral(ndp,100),presion(ndp,100),
     &                      presion2(ndp,100),presion3(ndp,100)
      common /pieces/ xl1,xl2,del,eps,nmy,nlbldu,iint,xmyc,iweak
      common /large/ xlambda(lpoint),maxlam,abso(ndp,lpoint),
     &               absos(ndp,lpoint),absocont(ndp,lpoint)
      common/rossc/ xkapr(ndp),cross(ndp)
      common/continuum/nlcont,jlcont(lpoint)

      character*50 zMC
      integer znlc ,  ii
      real    zxlm,zBP(ndp),zXC(ndp),zS(ndp),zXI(ndp)

      data  ee/ 0.,  10.199, 12.088, 12.749, 13.055, 13.221 /
c In babsma I use slighty different edges from continuous opacity file (air wavelength)
c     data  edge/ 912.00, 3647.00, 8207.00, 14588.00, 22794.00, 32915.00/
c This is not anymore the case, since we use the same jonabs_vac.dat file
c in version 7.3, and transform them to vacuum, just as in marcs.
c   BPz 21/01-2008
c vacuum edge used in MARCS :
cc      data edge/ 912.00, 3647.98, 8209.26, 14591.99, 22800.22, 32923.98/
      data edge/ 912.00, 3648.04, 8209.26, 14591.99, 22800.22, 32923.98/
      data  h1bfgc/1.0711223,  -3.0033216e-04,
     ;             1.0648009,  -5.1846584e-05,
     ;             1.0478152,  -1.7104666e-05,
     ;             1.0443061,  -8.2075951e-06,
     ;             1.0421281,  -4.6750806e-06,
     ;             1.0402398,  -2.9468910e-06,
     ;             1.0347312,  -1.9145532e-06,
     ;             1.0335221,  -1.3661146e-06,
     ;             1.0335879,  -1.0323393e-06,
     ;             1.0282216,  -7.4292798e-07,
     ;             1.0337342,  -6.4224310e-07,
     ;             1.0325113,  -5.1576699e-07,
     ;             1.0321166,  -4.2484186e-07,
     ;             1.0324288,  -3.6090637e-07,
     ;             1.0329178,  -3.0957602e-07/
*
c bsyn uses air wavelengths:
      do k=2,6
        edge(k)=vacair(edge(k))
*	print*,'k,edge(k)',k,edge(k)
      enddo

      do 2 k=2,6

* BPz 061204: potential problem: catches only k=2, if in
* lambda interval. Other edges ignored, and no
* provision if more than one edge.

ccccc        if(xl1.gt.edge(k) .or. xl2.lt.edge(k)) goto 3
        if(xl1.lt.edge(k) .and. xl2.gt.edge(k)) then
          ll=0
          diffp=1.e30
          do l=1,maxlam
            diff=abs(xlambda(l)-edge(k))
            if(diff.ge.diffp) then
              ll=l-1
              goto 1
            endif
            diffp=diff
          enddo
    1     continue
c
c          print*,'Hlinop, changed edge ',k,edge(k),xlambda(ll)
c          print*,'nearby lambdas',xlambda(ll-1),xlambda(ll+1)
          edge(k)=xlambda(ll)
        endif
    2 continue
    3 continue
c
      rewind (lunit)
      read(lunit,*) species,ion,nline
      read(lunit,*) comment
*      print*,species,ion,nline,comment
      if (species(1:6).ne.'01.000'.or.ion.ne.1) then
        print*, 'wrong H line data file!'
        print*,species,ion
        stop 'ERROR!'
      endif
*
***change nline   temporarily!
*      nline=37
*
***bort:!
* efter 1 continue:
*        do l=2,nlcont-1
*	  if(jlcont(l).eq.ll) goto 111
*	enddo
*        print*,"Hydropac: check:ll,l,jlcont(l,l-1),l",ll,l,jlcont(l),
*     ,         jlcont(l-1),xlambda(jlcont(l-1))
*	stop 'Hydropac: ll-value not found?!'
*  111   continue
*        print*,"Hydropac: check:ll,l,jlcont(l,l-1),l",ll,l,jlcont(l),
*     ,         jlcont(l-1),xlambda(jlcont(l-1))
*******************
*
      call partf(1,1,t,ntau,fpart,ionpot)

      do k=1,ntau
*        print*,"k,t(k)",k,t(k)
        theta(k)=5040./t(k)
        ne(k)=pe(k)/(t(k)*1.38066e-16)
        nh1(k)=sngl(presneutral(k,1))/(t(k)*1.38066e-16)
        nhe1(k)=sngl(presneutral(k,2))/(t(k)*1.38066e-16)
* hckt=hc/kT ready for lambda in AA.
c        hckt(k)=1.43877e8/t(k)
        hckt(k)=2.99792458e10*6.626075e-27/1.380658e-16*1.e8/t(k)
        dopple(k)=sqrt( xi(k)**2 * 1. +
     &                 2.*1.380658e-16*t(k)/1.6738e-24) /
     &                 2.99792458e10
      enddo

c
cccc
c  First add the continuous part of the H opacity from n=2,3,.,6 to dissolved
c  states following Daeppen et al. 1987. See subr. dcalc
c
cccc
c Note added 20030902: Mainly by luck the loop below starts at i=2. In PB's
c hbop package the corresponding part goes from the ground state (& up to i=15);
c this caused problems since the 'dissolved n=1 state' contributes 'too much'
c opacity at 'long' wavelengths (> 2000? AA). Whether this is due to a too
c large extrapolated sigma-bf for n=1 or to a 'd' that does not decrease fast
c enough (with wavelength) is presently not known. /KE
c
      do i=2,6
c        print*,' i edge(i)',i,edge(i)
        do k=1,ntau
*	  print*,'k',k
*          if(k.eq.30)
*     ,	  print*,k,xlambda(1),maxlam,nh1(k),ne(k),nhe1(k),d(1,k),t(k)
          call dcalc(i,xlambda,maxlam,nh1(k),ne(k),nhe1(k),d(1,k),t(k))
          do l=1,maxlam
*	    print*,' l,xlam ',l,xlambda(l)
	    if(xlambda(l) .ge. edge(i)) then
	      stim = 1. - exp(-hckt(k)/xlambda(l))
              h1bfg = h1bfgc(2*i-1) + h1bfgc(2*i)*xlambda(l)
 	      alpha = 1.044e-26 * h1bfg * xlambda(l)**3 / float(i**5)
CC added float() above and below on 09/05-2007.    BPz.
              contrib = nh1(k)* 2.*float(i)**2/fpart(k)*
     &               10.**(-ee(i)*theta(k))
     ,               / ro(k) * d(l,k) * alpha * stim  / xkapr(k)
c above division by xkapr added 030829......
c
              abso(k,l)=abso(k,l) + contrib
              absocont(k,l)=absocont(k,l) + contrib
*
cc              if (contrib.le.0.) print*,'H',xlambda(l),contrib
*      if(k.eq.30) print*," DAMc",i,k,l,xlambda(l),d(l,k),contrib,
*     ,   contrib/abso(k,l)
***
* now check if this lambda-depth point is in the 'continuum'array, if so
* then add to the continuous x also this contribution
*
              notfound=.true.
              ii=1
              do while (notfound.and.ii.le.nlcont)
                if (jlcont(ii).eq.l) then
                  read(14,rec=ii) zMC,znlc,zxlm,zBP,zXC,zS,zXI
                  zXC(k)=zXC(k)+contrib
                  write(14,rec=ii) zMC,znlc,zxlm,zBP,zXC,zS,zXI
cc	          print*,"updated XC,depth",k,zxlm,xlambda(l),contrib
                  notfound=.false.
                endif
                ii=ii+1
              enddo
* BPz 27/02-2015: abso changed to absocont in following statement
              if(contrib/absocont(k,l) .le. eps) goto 5
	    endif
          enddo
   5      continue
	enddo
      enddo
*
cc      do l=1,maxlam
cc        write(88,*) xlambda(l),abso(30,l),absos(30,l),absocont(30,l)
cc      enddo
cc      write(88,*) "*****"
*
      lstartp=1
      do 20 i=1,nline
        read(lunit,*) hlambda,nlo,nup,xlo,xup,gf,lname
cc	if(nlo.gt.1)  hlambda=vacair(hlambda)
*        print*,'Hydropac; line ',i,' of ',nline,' ',nlo,nup,hlambda
**********************************
* removed by BPz 24/01-2012
* this skipped Lyman series
*	if(nlo.eq.1) goto 20
**********************************
ccc
c Determine the fraction (d) of H b-b opacity that is lost by absorption to
c dissolved states. Left of the line is (1-d).
c See subr. dcalc  and Daeppen, Anderson & Mihalas 1987
c
     	usedam =.false.
     	if(nlo .ge. 2 .and. nlo .le. 6) usedam=.true.
     	if(usedam) then
c    	    calculate d at line-centre. (1-d)*bb is added further down.
     	  do k=1,ntau
     	    call dcalc(nlo,hlambda,1,nh1(k),ne(k),nhe1(k),d0(k),
     ,                 t(k))
     	  enddo
     	endif
        lymanalpha=.false.
	if(nlo.eq.1 .and. nup.eq.2) lymanalpha=.true.

        gf=10.**gf
*
* in bsyn we normally use airwavlengths
*
*        if (hlambda.gt.2000.) hlambda=airvac(hlambda)
* we search for the OS point nearer the line center.
        if (hlambda.le.xl1) then
          lstart=1
        else if (hlambda.gt.xl2) then
          lstart=maxlam+1
        else
          diffp=1.e30
          do l=lstartp,maxlam
            diff=abs(hlambda-xlambda(l))
            if (diff.gt.diffp) then
              lstart=l-1
* make sure everything is fine (this test has a large margin)
              if (diff.gt.(xlambda(min(maxlam,lstart+1))-
     &                     xlambda(max(1,lstart-1)))) then
                print*,'Problem in hydropac!'
                print*,' hydropac: hlambda',sngl(hlambda),
     &            'not nearest OS:',xlambda(lstart),lstart
                print*,'xlb-1,xlb,xlb+1:',xlambda(max(1,lstart-1)),
     &                  xlambda(lstart),xlambda(min(maxlam,lstart+1))
                stop 'ERROR!'
              endif
              goto 10
            endif
            diffp=diff
          enddo
        endif
10      continue
        lstartp=lstart

*        print*,'H opac: H lambda, xlb start:',sngl(hlambda),lstart,
*     .    lstartp,xlambda(lstart)
*	if(usedam) print*," DAM ",i,sngl(hlambda),d0(30)
        do k=1,ntau
* numerical factor 0.014... is sqrt(pi)e2/mec
c          hnormnostim(k)=0.014974*gf*nh1(k)/fpart(k)*
c     &                   10.**(-xlo*theta(k))/rho(k)

          hnormnostim(k)=0.026540045*gf*nh1(k)/fpart(k)*
     .       10.**(-xlo*theta(k))/ro(k)

*          if(nlo.eq.2     .and. k.eq.5) then
*            print*,"Hydropac:t,ne,nh1,nhe,dopp",t(k),ne(k),nh1(k),
*     .        nhe1(k),dopple(k),hnormnostim(k)
*          endif
          do l=lstart,maxlam
	    ll=l
cctest: 	do l=nlb-100,nlb
            wave=xlambda(l)
            stim=1.-exp(-hckt(k)/xlambda(l))
            hnorm=hnormnostim(k)*stim
cc
            contrib=HLINOP(wave,nlo,nup,hlambda,t(k),ne(k),
     *                nh1(k),nhe1(k),dopple(k))  /xkapr(k)
*          If( k.eq.31 .and. abs(wave-hlambda).lt.10.
*     *        .and. nlo.eq.2 .and. nup.eq.3 )
*     *       print*,wave,contrib,hnorm

c     *     print 2224,contrib,hnorm,stim

            if(usedam) then
	      contrib=contrib*(1. - d0(k))
*	      if(k.eq.30 .and. l.eq.lstart)
*     , print*," DAMl",contrib,contrib*hnorm/abso(k,l),(1. - d0(k))
	    endif
c
            contrib=contrib*hnorm

cc              if (contrib.le.0.) print*,'H',xlambda(l),contrib

            abso(k,l)=abso(k,l) + contrib
c	    if()then
c	      write(59,   )
c	    endif

*       If( k.eq.30 )
*     . Print2222,l,wave,contrib,abso(k,l), contrib/abso(k,l)
 2222 format("l,wave,contrb,osopx,ratio",i6,f9.1,1p,3e12.3)
 2223 format("l,wave,c*ntrb,osopx,ratio",i6,f9.1,1p,3e12.3)
 2224 format("  hlinop,hnorm,stim      ",15x,1p,3e12.3)

* BPz 27/02-2015: abso changed to absocont in following statement
            if (contrib/absocont(k,l).le.eps) goto 11
*
* we jump out if contribution less than 10-4 of the continuum at that depth.
* Before calling this routine we have only added continuum opacities in osop
*
          enddo
11        continue

cc          print*,k,sngl(hlambda),'computed out to: ',xlb(ll),ll
	  ll=0
cc	    Print*,"In next loop we start at l= ",lstart-1

          do l=lstart-1,1,-1
            if(l.le.0) Print*," In the loop...;l= ",l
	    ll=l
            wave=xlambda(l)
            stim=1.-exp(-hckt(k)/xlambda(l))
            hnorm=hnormnostim(k)*stim
            contrib=HLINOP(wave,nlo,nup,hlambda,t(k),ne(k),
     *                nh1(k),nhe1(k),dopple(k))  /xkapr(k)
            if(usedam) contrib=contrib*(1. - d0(k))
 	    contrib=contrib*hnorm

cc              if (contrib.le.0.) print*,'H',xlambda(l),contrib

            abso(k,l)=abso(k,l) + contrib

*      If( k.eq.30)
*     . Print2223,l,wave,contrib,abso(k,l), contrib/abso(k,l)

* BPz 27/02-2015: abso changed to absocont in following statement
            if (contrib/absocont(k,l).le.eps) goto 12
          enddo
12        continue

c          If(ll.gt.0) then
c	    print*,k,sngl(hlambda),'computed*out to: ',xlb(ll),ll
c	  else
c	    print*,k,sngl(hlambda),': no lambda-points considered'
c	  endif

        enddo
c	print*," hydropac; after big depthloop.. "
*
cc      do l=1,maxlam
cc        write(88,*) xlambda(l),abso(30,l),absos(30,l),absocont(30,l)
cc      enddo
cc      write(88,*) "*****"
*
  20    continue

      close(lunit)

      return
      end

      subroutine dcalc(ni, wave, nwav, nH, ne, nHe, d, temp)
c
c  dcalc calculates the D-function of Daeppen, Anderson & Mihalas 1987
c  (ApJ 319, 195). Accounts for opacity from bound to dissolved states in H.
c  Coded by Paul Barklem. Translated to Fortran 20030204/KE
c
      implicit none
      real     h, c, ionH, nH, ne, nHe, d(*),
     ,         x, xx, xi, temp
cc this was wrong!  BPz 16/05-2007     ,         x, xx, xi, wi, wstar, wcalc, temp
      real*8   wave(*),wi,wstar,wcalc
      integer  ni, ij, nwav
      data h/6.626e-27/, c/2.997925e10/, ionH/2.17991e-11/
c
      do ij=1,nwav
	d(ij)=1.
        x=1./(float(ni)**2) - h*c/sngl((wave(ij))*1.e-8*ionH)
	if(x .gt. 0.) then
	  xx=1./sqrt(x)
	  xi=float(ni)
	  wi=wcalc(nH, ne, nHe, xi, temp)
	  wstar=wcalc(nH, ne, nHe, xx, temp)
	  d(ij)=1.-(wstar/wi)
	endif
      enddo
      return
      end

      REAL*8 FUNCTION WCALC(NH, NE, NHE, NS, TEMP)
C
C  Computes the occupation probability for a H atom in
C  state with effective principle quantum number NS in a plasma
C  enviroment with NH, NE, NHE number densities of H, ions,
C  and He atoms respectively.  This code assumes the perturbing
C  neutral H and He are in the ground state, (noting the hard
C  sphere approximation used is quite crude anyway) and that ions
C  are predominantly singly ionized (ie. N(Z=1 ions) = Ne).
C
C  See eqn 4.71 Hummer & Milhalas (1988)
C  Ions are now treated via Appendix A Hubeny, Hummer & Lanz (1994)
C  which is a fit to detailed calculation including correlations,
C  thus the temperature dependence
C
C  Sizes of neutral atoms adopted are sqrt(<r^2>)
C
C  Coded by Paul Barklem and Kjell Eriksson, Aug 2003
C
      IMPLICIT NONE
      REAL NH, NE, NHE, NS, TEMP
      REAL*8 IONH, A0, E, PI, K, CHI, RIH, NEUTR, ION
      REAL*8 F, A, BETAC, X, WNEUTR, WION
      DATA IONH/2.17991E-11/
      DATA A0  /5.29177E-9/
      DATA E   /4.803207E-10/
      DATA PI  /3.1415927/
C
C  Neutral perturbers
C
      CHI=IONH/(NS*NS)
      RIH=SQRT(2.5*NS**4 + 0.5*NS*NS)*A0
      NEUTR=NH*(RIH + 1.73*A0)**3 + NHE*(RIH + 1.02*A0)**3
      WNEUTR = EXP(-4.*PI/3. * (NEUTR))
C
C  Charged perturbers
C
      K=1.
      IF(NS .gt. 3.) THEN
        K=16./3.*(NS/(NS+1.))**2 * (NS + 7./6.)/(NS*NS+NS+0.5)
      ENDIF
c      ION  = NE*16.*(E**2/CHI/DSQRT(K))**3
c      WION = DEXP(-4.*PI/3. * (ION))
      IF ((NE.GT.10.).AND.(TEMP.GT.10.)) THEN  ! just in case!!!
        A = 0.09 * NE**0.16667 / SQRT(TEMP)
        X = (1. + A)**3.15
        BETAC = 8.3E14 * NE**(-0.667) * K / (NS**4.d0)
       F = 0.1402d0*X*BETAC*BETAC*BETAC/(1.+0.1285*X*BETAC*DSQRT(BETAC))
        WION = F/(1.d0+F)
      ELSE
        WION = 1.0d0
      ENDIF
C
      WCALC = WION * WNEUTR
      RETURN
      END


      SUBROUTINE ML5_0_HELAS_CALLS_AMPB_1(P,NHEL,H,IC)
C
C     Modules
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=32)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=2)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=11, NLOOPGROUPS=9, NCTAMPS=28)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=39)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=10,NLOOPWAVEFUNCS=27)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=0, NSQUAREDSO=0, NAMPSO=0)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/ML5_0_I_SO/I_SO
      INTEGER I_LIB
      COMMON/ML5_0_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/ML5_0_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE
     $ ,0:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,0:NLOOPWAVEFUNCS)
      COMMON/ML5_0_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/ML5_0_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.CT_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

      CALL IXXXXX(P(0,1),ZERO,NHEL(1),+1*IC(1),W(1,1))
      CALL OXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
      CALL OXXXXX(P(0,3),ZERO,NHEL(3),+1*IC(3),W(1,3))
      CALL IXXXXX(P(0,4),ZERO,NHEL(4),-1*IC(4),W(1,4))
      CALL VXXXXX(P(0,5),ZERO,NHEL(5),+1*IC(5),W(1,5))
      CALL FFV1_2(W(1,1),W(1,5),GC_5,ZERO,ZERO,W(1,6))
      CALL FFV2_3(W(1,4),W(1,3),GC_47,MDL_MW,MDL_WW,W(1,7))
C     Amplitude(s) for born diagram with ID 1
      CALL FFV2_0(W(1,6),W(1,2),W(1,7),GC_47,AMP(1))
      CALL FFV1_1(W(1,2),W(1,5),GC_5,ZERO,ZERO,W(1,8))
C     Amplitude(s) for born diagram with ID 2
      CALL FFV2_0(W(1,1),W(1,8),W(1,7),GC_47,AMP(2))
      CALL FFV2_1(W(1,2),W(1,7),GC_47,ZERO,ZERO,W(1,9))
C     Counter-term amplitude(s) for loop diagram number 3
      CALL R2_QQ_1_0(W(1,6),W(1,9),R2_QQQ,AMPL(1,1))
C     Counter-term amplitude(s) for loop diagram number 4
      CALL FFV2_0(W(1,6),W(1,2),W(1,7),R2_SXCW,AMPL(1,2))
C     Counter-term amplitude(s) for loop diagram number 5
      CALL FFV2_0(W(1,1),W(1,8),W(1,7),R2_SXCW,AMPL(1,3))
C     Counter-term amplitude(s) for loop diagram number 7
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,4))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,5))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,6))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,7))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQB,AMPL(1,8))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,9))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQT,AMPL(1,10))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQQ_1EPS,AMPL(2,11))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),UV_GQQG_1EPS,AMPL(2,12))
      CALL FFV1_0(W(1,1),W(1,9),W(1,5),R2_GQQ,AMPL(1,13))
      CALL FFV2_2(W(1,1),W(1,7),GC_47,ZERO,ZERO,W(1,10))
C     Counter-term amplitude(s) for loop diagram number 11
      CALL R2_QQ_1_0(W(1,10),W(1,8),R2_QQQ,AMPL(1,14))
C     Counter-term amplitude(s) for loop diagram number 12
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,15))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,16))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,17))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,18))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQB,AMPL(1,19))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,20))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQT,AMPL(1,21))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQQ_1EPS,AMPL(2,22))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),UV_GQQG_1EPS,AMPL(2,23))
      CALL FFV1_0(W(1,10),W(1,2),W(1,5),R2_GQQ,AMPL(1,24))

      GOTO 1001
 2000 CONTINUE
      CT_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


! for finite qq
subroutine mksecspec(qq,igglf1,igglf2,iks,vol,pi,ssnrg,ssdnrg, &
& test_bands_pol, &
& nsppol,shiftk,npw,igmx,igmn,ipaw,nsym,nkpt, &
& ncg,bantot,npwt,nlmn, &
& nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom, &
& xred, &
& projwf, &
& kg, &
& enrgy, &
& cg, &
& indxkpw, &
& indxkbnd, &
& indxkcg, &
& npwarr, &
& kpt, &
& nsymk,symk,symrel,syminv, &
& ihlf,lvtrans, &
& ntypepaw, &
& pwmatel1,tpwmatel1,pwmatel2,tpwmatel2, &
& igndx,ikndx,isymndx,isymg, &
& nband,secspec)
implicit none
integer :: bantot,ncg,nkpt,ipw1,ipw2,ipw,nlmn,natom
double precision :: qq(3),qp(3),dq(3),vq,vol,pi,wmax,dw
integer :: nwpt,nbcore,nbocc,ncband,ngkpt(3),npwt,npw,iks(3)
integer :: nsym,igmx(3),igmn(3),igcut,nsppol,ipaw
integer :: igglf1(3),igglf2(3)
integer :: test_bands_pol(4)
double precision :: shiftk(3)
double precision :: xred(3,natom)
integer :: kg(3,npwt)
double complex :: projwf(natom,nlmn,nkpt,nbcore+1:ncband)
double precision :: enrgy(bantot)
double complex :: cg(ncg)
integer :: indxkpw(nkpt),indxkbnd(nkpt)
integer :: indxkcg(nkpt),npwarr(nkpt)
double precision :: kpt(3,nkpt)
integer :: nsymk(nkpt),symk(nkpt,nsym*2)
integer :: symrel(3,3,nsym),syminv(3,3,nsym)
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ihlf(nkpt)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: ikndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymg(3,nkpt,nsym),igsymk(3),igsymq(3)
integer :: nband(nkpt*nsppol)
double complex :: cmat2(ngkpt(1),ngkpt(2),ngkpt(3)),cmatel,cmatellf,cmat2v(8)
double complex :: amatel,amatellf
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3)),e_cond(ngkpt(1),ngkpt(2),ngkpt(3)),e_val(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,whi2,wlo2,ww,ww1,ww2,enval(8),encond(8),wflmin,wflmax
integer :: iwh,iwl,iwh2,iwl2
double precision :: xck(3),xckq(3)
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),gap
integer :: ivgndx(igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3),ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ii,jj,kk,iw,jw,iocc,iunocc,ikk(3),ikkp(3),jkk(3),jka(3),isym,isymq
integer :: ig,jg,igg(3),jgg(3),jgs(3),ikpt,ikptq,ix,iy,iz,igx,igy,igz,igg0(3)
integer :: ntypepaw
double complex :: pwmatel1(ntypepaw,nlmn,nlmn),tpwmatel1(ntypepaw,nlmn,nlmn)
double complex :: pwmatel2(ntypepaw,nlmn,nlmn),tpwmatel2(ntypepaw,nlmn,nlmn)
double precision :: ssnrg, ssdnrg, ssnrghi, ssnrglo, secspec(nwpt), specnorm
double complex :: tss

ssnrghi=ssnrg+ssdnrg/2.
ssnrglo=ssnrg-ssdnrg/2.

igg0=(/0,0,0/)
qp=qq-igglf1+igglf2
dw=wmax/dble(nwpt)
do iw=1,nwpt
  secspec(iw)=0.d0
enddo

!write(6,'(a)') 'occupied band, unoccupied band, minimum gap'
!write(6,*) nbocc, ncband-nbocc
do iocc=test_bands_pol(1),test_bands_pol(2)
!do iocc=7,7
  do iunocc=test_bands_pol(3),test_bands_pol(4)
!  do iunocc=16,16
!    write(6,*) iocc,iunocc
    gap=1.d20
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=1,1
!    do iz=1,1
      ikk=(/ix,iy,iz/)
      ikpt=ikndx(ikk(1),ikk(2),ikk(3))
      isym=isymndx(ikk(1),ikk(2),ikk(3))
      igsymk=isymg(:,ikpt,isym)
      do ii=1,3
        jka(ii)=ikk(ii)-iks(ii)
        jkk(ii)=mod(jka(ii)-1,ngkpt(ii))+1
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
        xck(ii)=dble(ikk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xck(ii)=mod(xck(ii),1.d0)
        if (xck(ii).lt.0.d0) xck(ii)=xck(ii)+1
        xck(ii)=1.d0-mod(1.d0-xck(ii),1.d0)
        xck(ii)=xck(ii)-0.5d0
        xckq(ii)=dble(jkk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xckq(ii)=mod(xckq(ii),1.d0)
        if (xckq(ii).lt.0.d0) xckq(ii)=xckq(ii)+1
        xckq(ii)=1.d0-mod(1.d0-xckq(ii),1.d0)
        xckq(ii)=xckq(ii)-0.5d0
        igg(ii)=nint(xckq(ii)-xck(ii)+qq(ii))-igglf1(ii)
      enddo
      ikptq=ikndx(jkk(1),jkk(2),jkk(3))
      isymq=isymndx(jkk(1),jkk(2),jkk(3))
      igsymq=isymg(:,ikptq,isymq)
      call mkmatelX1(iocc,iunocc,ikpt,ikptq,igglf1,igg, &
&       ncg,nkpt,npwt,igmx,igmn,igndx, &
&       isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&       lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&       cg,indxkcg,indxkpw,npwarr,kg, &
&       cmatel)
      omega(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikpt)+iunocc) &
&                                -enrgy(indxkbnd(ikptq)+iocc)
      e_val(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikptq)+iocc)
      e_cond(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikpt)+iunocc)
      if (ipaw.ne.0) then
        call mkPAWmatelX1(pi,iocc,iunocc,ikk,jkk,qq,igg0, &
& pwmatel1,tpwmatel1,nbcore,ncband,amatel)
      else
        amatel=(0.d0,0.d0)
      endif
      if (igglf1(1).eq.igglf2(1).and.igglf1(2).eq.igglf2(2).and. &
&         igglf1(3).eq.igglf2(3)) then
        cmat2(ikk(1),ikk(2),ikk(3))=dble((cmatel+amatel)*conjg(cmatel+amatel))
      else
        call mkmatelX1(iocc,iunocc,ikpt,ikptq,igglf2,igg, &
&         ncg,nkpt,npwt,igmx,igmn,igndx, &
&         isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&         lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&         cg,indxkcg,indxkpw,npwarr,kg, &
&         cmatellf)
        if (ipaw.ne.0) then
          call mkPAWmatelX1(pi,iocc,iunocc,ikk,jkk,qp,igg0, &
& pwmatel2,tpwmatel2,nbcore,ncband,amatellf)
        else
          amatellf=(0.d0,0.d0)
        endif
        cmat2(ikk(1),ikk(2),ikk(3))=(cmatel+amatel)*conjg(cmatellf+amatellf)
      endif
      if (omega(ikk(1),ikk(2),ikk(3)).lt.gap) gap=omega(ikk(1),ikk(2),ikk(3))
    enddo
    enddo
    enddo
!stop
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=8,8
!    do iz=2,2
      ikk=(/ix,iy,iz/)
      call fhilo(e_cond,ikk,ngkpt,whi,wlo)
      call fhilo(e_val,ikk,ngkpt,whi2,wlo2)
!      write(6,'(2i3,2x,3i3,2x,2f14.6,2x,2f14.6)') iocc,iunocc,ix,iy,iz,wlo,whi,wlo2,whi2
      whi2=whi2+ssnrg+ssdnrg
      wlo2=wlo2+ssnrg-ssdnrg
      whi=min(whi,whi2)
      wlo=max(wlo,wlo2)
      if (wlo.lt.whi.and.whi.lt.wmax) then
        iwh=min(nint(whi*dble(nwpt)/wmax),nwpt)
        iwl=max(nint(wlo*dble(nwpt)/wmax),0)
!        write(6,*)
!        write(6,'(2i3,2x,3i3,2x,3i5)') iocc,iunocc,ix,iy,iz,iwl,iwh
!        write(6,*) ssnrg
!        write(6,'(2i3,2x,3i3,2x,2f14.6,2x,2f14.6)') iocc,iunocc,ix,iy,iz,wlo,whi
        if (iwl.gt.nwpt) cycle
        call fval(e_cond,ikk,ikkp,ngkpt,encond)
        call fval(e_val,ikk,ikkp,ngkpt,enval)
        call fpol(cmat2,ngkpt,ikk,ikkp,cmat2v)
        do iw=iwl,iwh
!        do iw=16,16
          ww=iw*dw
!          write(6,*)
!          write(6,'(2i3,2x,3i3,2x,3i5)') iocc,iunocc,ix,iy,iz,iw
!          write(6,*) cmat2v
          call cubeint_d(encond,enval,ww,cmat2v,ww-ssnrghi,ww-ssnrglo,tss)
          secspec(iw)=secspec(iw)+dble(tss)/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
!          if (tss.ne.0.d0) then
!            write(6,'(2i3,2x,3i3,2x,i5,3x,e14.6)') iocc,iunocc,ix,iy,iz,iw,tss
!          endif
        enddo
      endif
    enddo
    enddo
!    write(68,*) ix+1,'------------------------------------------------------'
!    write(68,*)
    enddo
  enddo
enddo

specnorm=0.d0;
do iw=1,nwpt
  specnorm=specnorm+secspec(iw)*dw
!write(6,*) iw,secspec(iw),specnorm
enddo
!write(6,*) specnorm/sqrt(dot_product(qq,qq)*dot_product(qp,qp))
if (specnorm.eq.0.d0) then
  write(6,*) 'ERROR: spectrum normalization is zero'
  stop
endif
do iw=1,nwpt
  secspec(iw)=secspec(iw)/specnorm
!write(6,*) iw,secspec(iw)
enddo

return
end subroutine mksecspec

!*************************************************************************

! intended for use when qq->(0.d0,0.d0,0.d0).  Still use qq to get direction
subroutine mksecspecj(qq,igglf1,igglf2,iks,vol,pi,ssnrg,ssdnrg,bmet, &
& test_bands_pol, &
& nsppol,shiftk,npw,igmx,igmn,ipaw,nsym,nkpt, &
& ncg,bantot,npwt,nlmn, &
& nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom, &
& xred, &
& projwf, &
& kg, &
& enrgy, &
& cg, &
& indxkpw, &
& indxkbnd, &
& indxkcg, &
& npwarr, &
& kpt, &
& nsymk,symk,symrel,syminv, &
& ihlf,lvtrans, &
& ntypepaw, &
& pwjmatel,tpwjmatel,pwmatel1,tpwmatel1,pwmatel2,tpwmatel2, &
& igndx,ikndx,isymndx,isymg, &
& nband,secspec)
implicit none
integer :: bantot,ncg,nkpt,ipw1,ipw2,ipw,nlmn,natom
double precision :: qq(3),qp(3),dq(3),vq,vol,pi,wmax,dw
double precision :: bmet(3,3),qqmag,qpmag,qq2,qp2,qqnorm(3),qpnorm(3)
integer :: nwpt,nbcore,nbocc,ncband,ngkpt(3),npwt,npw,iks(3)
integer :: nsym,igmx(3),igmn(3),igcut,nsppol,ipaw
integer :: igglf1(3),igglf2(3)
integer :: test_bands_pol(4)
double precision :: shiftk(3)
double precision :: xred(3,natom)
integer :: kg(3,npwt)
double complex :: projwf(natom,nlmn,nkpt,nbcore+1:ncband)
double precision :: enrgy(bantot)
double complex :: cg(ncg)
integer :: indxkpw(nkpt),indxkbnd(nkpt)
integer :: indxkcg(nkpt),npwarr(nkpt)
double precision :: kpt(3,nkpt)
integer :: nsymk(nkpt),symk(nkpt,nsym*2)
integer :: symrel(3,3,nsym),syminv(3,3,nsym)
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ihlf(nkpt)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: ikndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymg(3,nkpt,nsym),igsymk(3),igsymq(3)
integer :: nband(nkpt*nsppol)
double complex :: cmat2(ngkpt(1),ngkpt(2),ngkpt(3)),cmatel,cmatellf,cmat2v(8)
double complex :: jmatel(3),jmatellf(3),tmat2(ngkpt(1),ngkpt(2),ngkpt(3),3,3)
double complex :: amatel,vmatel(3)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3)),e_cond(ngkpt(1),ngkpt(2),ngkpt(3)),e_val(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,whi2,wlo2,ww,ww1,ww2,enval(8),encond(8),wflmin,wflmax
integer :: iwh,iwl,iwh2,iwl2
double precision :: xck(3),xckq(3)
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),gap
integer :: ivgndx(igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3),ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ii,jj,kk,iw,jw,iocc,iunocc,ikk(3),ikkp(3),jkk(3),jka(3),isym,isymq
integer :: ig,jg,igg(3),jgg(3),jgs(3),ikpt,ikptq,ix,iy,iz,igx,igy,igz,igg0(3)
integer :: ntypepaw
double complex :: pwjmatel(ntypepaw,nlmn,nlmn),tpwjmatel(ntypepaw,nlmn,nlmn)
double complex :: pwmatel1(ntypepaw,nlmn,nlmn),tpwmatel1(ntypepaw,nlmn,nlmn)
double complex :: pwmatel2(ntypepaw,nlmn,nlmn),tpwmatel2(ntypepaw,nlmn,nlmn)
double precision :: ssnrg, ssdnrg, ssnrghi, ssnrglo, secspec(nwpt), specnorm
double complex :: tss

ssnrghi=ssnrg+ssdnrg/2.
ssnrglo=ssnrg-ssdnrg/2.

igg0=(/0,0,0/)
qp=qq-igglf1+igglf2
qq2=0.d0
qp2=0.d0
do ii=1,3
do jj=1,3
  qq2 = qq2 + qq(ii)*bmet(ii,jj)*qq(jj)
  qp2 = qp2 + qp(ii)*bmet(ii,jj)*qp(jj)
enddo
enddo
qqmag=sqrt(qq2)
qpmag=sqrt(qp2)
do ii=1,3
  qqnorm(ii)=qq(ii)/qqmag
  qpnorm(ii)=qp(ii)/qpmag
enddo
dw=wmax/dble(nwpt)
do iw=1,nwpt
  secspec(iw)=0.d0
enddo

!write(6,'(a)') 'occupied band, unoccupied band, minimum gap'
!write(6,*) nbocc, ncband-nbocc
do iocc=test_bands_pol(1),test_bands_pol(2)
!do iocc=7,7
  do iunocc=test_bands_pol(3),test_bands_pol(4)
!  do iunocc=16,16
!    write(6,*) iocc,iunocc
    gap=1.d20
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=1,1
!    do iz=1,1
      ikk=(/ix,iy,iz/)
      ikpt=ikndx(ikk(1),ikk(2),ikk(3))
      isym=isymndx(ikk(1),ikk(2),ikk(3))
      igsymk=isymg(:,ikpt,isym)
      do ii=1,3
        jka(ii)=ikk(ii)-iks(ii)
        jkk(ii)=mod(jka(ii)-1,ngkpt(ii))+1
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
        xck(ii)=dble(ikk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xck(ii)=mod(xck(ii),1.d0)
        if (xck(ii).lt.0.d0) xck(ii)=xck(ii)+1
        xck(ii)=1.d0-mod(1.d0-xck(ii),1.d0)
        xck(ii)=xck(ii)-0.5d0
        xckq(ii)=dble(jkk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xckq(ii)=mod(xckq(ii),1.d0)
        if (xckq(ii).lt.0.d0) xckq(ii)=xckq(ii)+1
        xckq(ii)=1.d0-mod(1.d0-xckq(ii),1.d0)
        xckq(ii)=xckq(ii)-0.5d0
        igg(ii)=nint(xckq(ii)-xck(ii)+qq(ii))-igglf1(ii)
      enddo
      ikptq=ikndx(jkk(1),jkk(2),jkk(3))
      isymq=isymndx(jkk(1),jkk(2),jkk(3))
      igsymq=isymg(:,ikptq,isymq)
!      write(6,'(4(3i3,3x))') ikk,jkk,iks,igg
!      write(6,'(3(3f10.6,3x))') xck,xckq
!      write(6,'(3(3f10.6,3x))') qq,qq-igglf1
!      write(6,'(3f8.4,4x,3f8.4)') kpt(1:3,ikpt),kpt(1:3,ikptq)
!      write(6,'(3i5)') ikpt,ikptq
!      write(6,'(3i5)') isym,isymq,nsym
!      write(6,'(2i4,4x,2i4)') mod(isym-1,nsym)+1,-(2*((isym-1)/nsym)-1),mod(isymq-1,nsym)+1,-(2*((isymq-1)/nsym)-1)
!      do ii=1,3
!        write(6,'(3i3,5x,3i3)') symrel(1:3,ii,mod(isym-1,nsym)+1),syminv(1:3,ii,mod(isymq-1,nsym)+1)
!      enddo
      omega(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikpt)+iunocc) &
&                                -enrgy(indxkbnd(ikptq)+iocc)
      e_val(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikptq)+iocc)
      e_cond(ikk(1),ikk(2),ikk(3))=enrgy(indxkbnd(ikpt)+iunocc)
      if (igglf1(1).eq.0.and.igglf1(2).eq.0.and.igglf1(3).eq.0) then
        call mkmatelJ1(iocc,iunocc,ikpt,ikptq,igglf1,igg, &
&         ncg,nkpt,npwt,igmx,igmn,igndx, &
&         isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&         lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&         cg,indxkcg,indxkpw,npwarr,kg, &
&         jmatel)
!write(46,'(3("(",f8.4,",",f8.4,")"))') jmatel
        if (ipaw.ne.0) then
          call mkPAWmatelJ1(pi,iocc,iunocc,ikk,jkk, &
&                         pwjmatel,tpwjmatel,nbcore,ncband,vmatel)
          jmatel(:) = jmatel(:) + vmatel(:)
        endif
        do ii=1,3
          jmatel(ii) = jmatel(ii)/omega(ikk(1),ikk(2),ikk(3))
        enddo
      else
        call mkmatelX1(iocc,iunocc,ikpt,ikptq,igglf1,igg, &
&         ncg,nkpt,npwt,igmx,igmn,igndx, &
&         isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&         lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&         cg,indxkcg,indxkpw,npwarr,kg, &
&         cmatel)
        if (ipaw.ne.0) then
          call mkPAWmatelX1(pi,iocc,iunocc,ikk,jkk,qq,igg0, &
&                        pwmatel1,tpwmatel1,nbcore,ncband,amatel)
          cmatel = cmatel + amatel
        endif
        jmatel(:) = cmatel*qq(:)/qq2
      endif
      if (igglf1(1).eq.igglf2(1).and.igglf1(2).eq.igglf2(2).and. &
&         igglf1(3).eq.igglf2(3)) then
        do ii=1,3
        do jj=1,3
          tmat2(ikk(1),ikk(2),ikk(3),ii,jj)=dble(jmatel(ii)*conjg(jmatel(jj)))
        enddo
        enddo
      else
        if (igglf2(1).eq.0.and.igglf2(2).eq.0.and.igglf2(3).eq.0) then
          call mkmatelJ1(iocc,iunocc,ikpt,ikptq,igglf2,igg, &
&           ncg,nkpt,npwt,igmx,igmn,igndx, &
&           isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&           lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&           cg,indxkcg,indxkpw,npwarr,kg, &
&           jmatellf)
          if (ipaw.ne.0) then
            call mkPAWmatelJ1(pi,iocc,iunocc,ikk,jkk, &
&                           pwjmatel,tpwjmatel,nbcore,ncband,vmatel)
            jmatellf(:) = jmatellf(:) + vmatel(:)
          endif
          do ii=1,3
            jmatellf(ii) = jmatellf(ii)/omega(ikk(1),ikk(2),ikk(3))
          enddo
        else
          call mkmatelX1(iocc,iunocc,ikpt,ikptq,igglf2,igg, &
&           ncg,nkpt,npwt,igmx,igmn,igndx, &
&           isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&           lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&           cg,indxkcg,indxkpw,npwarr,kg, &
&           cmatel)
          if (ipaw.ne.0) then
            call mkPAWmatelX1(pi,iocc,iunocc,ikk,jkk,qp,igg0, &
&                          pwmatel2,tpwmatel2,nbcore,ncband,amatel)
            cmatel = cmatel + amatel
          endif
          jmatellf(:) = cmatel*qp(:)/qp2
        endif
        do ii=1,3
        do jj=1,3
          tmat2(ikk(1),ikk(2),ikk(3),ii,jj)=dble(jmatel(ii)*conjg(jmatellf(jj)))
        enddo
        enddo
      endif
      if (omega(ikk(1),ikk(2),ikk(3)).lt.gap) gap=omega(ikk(1),ikk(2),ikk(3))
!write(6,*) dble(cmat2(ikk(1),ikk(2),ikk(3)))
!write(6,*) dble(cmat2(ikk(1),ikk(2),ikk(3)))*vq
!write(6,*)
!      stvec(ikk(3))=enrgy(indxkbnd(ikpt)+iunocc)
!      stvec(ikk(3))=e_cond(ikk(1),ikk(2),ikk(3))-dw*58
!      stvec(ikk(3))=dble(cmat2(ikk(1),ikk(2),ikk(3)))*vq
!      stvec2(ikk(3))=dimag(cmat2(ikk(1),ikk(2),ikk(3)))*vq
!      stvec(ikk(3))=dble(cmat2(ikk(1),ikk(2),ikk(3)))
!      stvec2(ikk(3))=dimag(cmat2(ikk(1),ikk(2),ikk(3)))
!      stvec(ikk(3))=abs(cmatel)
!      stvec(ikk(3))=dble(cmatel)
!      stvec2(ikk(3))=dimag(cmatel)
!      stvec(ikk(3))=dble(cmatellf)
!      stvec2(ikk(3))=dimag(cmatellf)
!      stvec(ikk(3))=dble(cmatel*conjg(cmatellf))*vq
!      stvec(ikk(3))=dble(amatel*conjg(amatellf))*vq
    enddo
!    write(68,'(10f8.3)') stvec(1:ngkpt(3)),stvec2(1:ngkpt(3))
!    write(68,'(10f8.3)') stvec(1:ngkpt(3))
!    write(68,'(10f8.3)') stvec2(1:ngkpt(3))
!    write(68,*)
!    write(68,'(10f8.2)') stvec(1:ngkpt(3))*27.2113845d0
!    write(68,'(10es8.1)') stvec(1:ngkpt(3))
!    write(68,'(10es8.1)') stvec2(1:ngkpt(3))
!    write(68,*)
    enddo
!    write(68,*) ix+1,'------------------------------------------------------'
!    write(68,*)
    enddo
!    write(6,'(2(i6,9x),f10.3)') iocc,iunocc,gap*27.2113845d0
!write(6,'(6i6))') iocc,iunocc, test_bands_pol
!stop
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=8,8
!    do iz=2,2
      ikk=(/ix,iy,iz/)
      call fhilo(e_cond,ikk,ngkpt,whi,wlo)
      call fhilo(e_val,ikk,ngkpt,whi2,wlo2)
!      write(6,'(2i3,2x,3i3,2x,2f14.6,2x,2f14.6)') iocc,iunocc,ix,iy,iz,wlo,whi,wlo2,whi2
      whi2=whi2+ssnrg+ssdnrg
      wlo2=wlo2+ssnrg-ssdnrg
      whi=min(whi,whi2)
      wlo=max(wlo,wlo2)
      if (wlo.lt.whi.and.whi.lt.wmax) then
        iwh=min(nint(whi*dble(nwpt)/wmax),nwpt)
        iwl=nint(wlo*dble(nwpt)/wmax)
!        write(6,*)
!        write(6,'(2i3,2x,3i3,2x,3i5)') iocc,iunocc,ix,iy,iz,iwl,iwh
!        write(6,*) ssnrg
!        write(6,'(2i3,2x,3i3,2x,2f14.6,2x,2f14.6)') iocc,iunocc,ix,iy,iz,wlo,whi
        if (iwl.gt.nwpt) cycle
        call fval(e_cond,ikk,ikkp,ngkpt,encond)
        call fval(e_val,ikk,ikkp,ngkpt,enval)
!if (iunocc.lt.test_bands_pol(3)) then
!  write(6,*) iunocc,test_bands_pol(3),"A"
!  stop
!endif
        do ii=1,3
!if (iunocc.lt.test_bands_pol(3)) then
!  write(6,*) iunocc,test_bands_pol(3),"B"
!  stop
!endif
        do jj=1,3
!if (iunocc.lt.test_bands_pol(3)) then
!  write(6,*) iunocc,test_bands_pol(3),"C"
!  stop
!endif
          call fpol(tmat2(:,:,:,ii,jj),ngkpt,ikk,ikkp,cmat2v)
          do iw=iwl,iwh
!          do iw=16,16
            ww=iw*dw
!            write(6,*)
!            write(6,'(2i3,2x,3i3,2x,3i5)') iocc,iunocc,ix,iy,iz,iw
!            write(6,*) cmat2v
            call cubeint_d(encond,enval,ww,cmat2v,ww-ssnrghi,ww-ssnrglo,tss)
            secspec(iw)=secspec(iw)+dble(tss)/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
!            if (tss.ne.0.d0) then
!              write(6,'(2i3,2x,3i3,2x,i5,3x,e14.6)') iocc,iunocc,ix,iy,iz,iw,tss
!            endif
          enddo
        enddo
        enddo
      endif
    enddo
    enddo
    enddo
  enddo
enddo

specnorm=0.d0;
do iw=1,nwpt
  specnorm=specnorm+secspec(iw)*dw
enddo
!write(6,*) specnorm/sqrt(dot_product(qq,qq)*dot_product(qp,qp))
if (specnorm.eq.0.d0) then
  write(6,*) 'ERROR: spectrum normalization is zero'
  stop
endif
do iw=1,nwpt
  secspec(iw)=secspec(iw)/specnorm
enddo

return
end subroutine mksecspecj


subroutine integrate_state_fcvode(lo, hi, &
                                  state   , s_l1, s_l2, s_l3, s_h1, s_h2, s_h3, &
                                  diag_eos, d_l1, d_l2, d_l3, d_h1, d_h2, d_h3, &
                                  a, half_dt, min_iter, max_iter)
!
    use amrex_error_module, only : amrex_abort
    use amrex_fort_module, only : rt => amrex_real
    use meth_params_module, only : NVAR, NDIAG

    implicit none

    integer         , intent(in) :: lo(3), hi(3)
    integer         , intent(in) :: s_l1, s_l2, s_l3, s_h1, s_h2, s_h3
    integer         , intent(in) :: d_l1, d_l2, d_l3, d_h1, d_h2, d_h3
    real(rt), intent(inout) ::    state(s_l1:s_h1, s_l2:s_h2,s_l3:s_h3, NVAR)
    real(rt), intent(inout) :: diag_eos(d_l1:d_h1, d_l2:d_h2,d_l3:d_h3, NDIAG)
    real(rt), intent(in)    :: a, half_dt
    integer         , intent(inout) :: max_iter, min_iter

!   integer :: i, j, k
!   real(rt) :: z, rho
!   real(rt) :: T_orig, ne_orig, e_orig
!   real(rt) :: T_out , ne_out , e_out, mu, mean_rhob

!   logical  :: firstcall

    call amrex_abort("Cannot call fcvode without compiling with USE_CVODE=TRUE")

end subroutine integrate_state_fcvode


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine rear   ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Reaeration of carbon dioxide and oxygen

!
!     Description of the module :
!
! Name    T   L I/O   Description                                   Units
! ----    --- -  -    -------------------                            ----
! DEPTH   R*4 1 I actual depth of the water column                     [m]
! FCOVER  R*4 1 I fraction of water surface covered <0-1>              [-]
! FL (1)  R*4 1 O reaeration flux                                 [g/m3/d]
! HCRT    R*4 1 I critical water depth/velocity                        [m]
! IFREAR  I*4 1 I switch for the rearation formula                     [-]
! MAXRRC  R*4 1 I maximum wat trf. coef. for temp. lim.              [m/d]
! MINRRC  R*4 1 I minimum reaeration rate                            [m/d]
! O2      R*4 1 I concentration of dissolved oxygen                 [g/m3]
! OXSAT   R*4 1 L saturation concentration of dissolved oxygen      [g/m3]
! RAIN    R*4 1 L rainfall rate                                     [mm/h]
! REARTC  R*4 1 L reaeration temperatuur coefficient                   [-]
! REARKL  R*4 1 L reaeration transfer coefficient                    [m/d]
! REARRC  R*4 1 L reaeration rate                                    [1/d]
! TEMP    R*4 1 I ambient temperature                                 [xC]
! TEMP20  R*4 1 L ambient temperature - stand. temp (20)              [xC]
! VELOC   R*4 1 I streamflow velocity                                [m/s]
! VWIND   R*4 1 I wind velocity                                      [m/s]

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      IMPLICIT NONE

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
!     Local declarations
!
      INTEGER  IFREAR, IKMRK1, IKMRK2, ISEG, IFLUX
      INTEGER  IP1 , IP2 , IP3 , IP4 , IP5 , IP6 , IP7 , IP8, IP9, IP10,
     +         IP11, IP12, IP13, IP14, IP15, IP16, IP17, IP18,IP19,IP20,
     +         IP21, IP22, IP23, IP24, IP25, IP26, IP27
      REAL     SAL   , B_ENHA, SC    , SC20  , KLREAR, TOTDEP,
     +         REARTC, REARRC, HCRT  , VELOC , VWIND , TEMP  ,
     +         OXSAT , O2    , TEMP20, TMPCF , DEPTH , FL1   ,
     +         FCOVER, MAXRRC, REARKL, SATPERC,MINRRC, DELT  , RAIN
      REAL     A     , B1    , B2    , C1    ,
     +         C2    , D1    , D2    , D3    , D4  ,
     +         D1Os  , D2Os  , D3Os  , D4Os  ,
     +         D1Cs  , D2Cs  , D3Cs  , D4Cs  ,
     +         D1Hs  , D2Hs  , D3Hs  , D4Hs

!   PBo3: hard coded original coefficients -> user defined input
!     Parameters for Schmidt number calculation (Warninkhoff and Guerin)
!     A1-D1=oxygen Wannikhof (seawater)
!     A2-D2=oxygen Gerin and Wannikhof (both fresh)
!     A3-D3=CO2 Wannikhof (seawater)
!     A4-D4=CO2 Gerin and Wannikhof (both fresh)
!     A5-D5= reserved for CH4 seawater
!     A6-D6=CH4 freshwater

!      PARAMETER ( A1 = 1953.4     ,
!    +            B1 =  128.00    ,
!    +            C1 =    3.9918  ,
!    +            D1 =    0.050091,
!    +            A2 = 1800.6     ,
!    +            B2 =  120.10    ,
!    +            C2 =    3.7818  ,
!    +            D2 =    0.047608,
!    +            A3 = 2073.1     ,
!    +            B3 =  125.62    ,
!    +            C3 =    3.6276  ,
!    +            D3 =    0.043219,
!    +            A4 = 1911.1     ,
!    +            B4 =  118.11    ,
!    +            C4 =    3.4527  ,
!    +            D4 =    0.04132 ,
!    +            A6 = 1897.8     ,
!    +            B6 =  114 .28   ,
!    +            C6 =    3.2902  ,
!    +            D6 =    0.039061 )

!   PBo3: hard coded coefficients for salt water options Wannikhof
!     Parameters for Schmidt number calculation (Wanninkhoff and Guerin)
!     D1-4Os = oxygen Wannikhof (seawater)
!     D1-4Cs = CO2 Wannikhof (seawater)
!     D1-4Hs = dummy values for CH4 seawater

      PARAMETER ( D1Os = 1953.4     ,
     +            D2Os =  128.00    ,
     +            D3Os =    3.9918  ,
     +            D4Os =    0.050091,
     +            D1Cs = 2073.1     ,
     +            D2Cs =  125.62    ,
     +            D3Cs =    3.6276  ,
     +            D4Cs =    0.043219,
     +            D1Hs = 2073.1     ,
     +            D2Hs =  125.62    ,
     +            D3Hs =    3.6276  ,
     +            D4Hs =    0.043219   )

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)
      IP13 = IPOINT(13)
      IP14 = IPOINT(14)
      IP15 = IPOINT(15)
      IP16 = IPOINT(16)
      IP17 = IPOINT(17)
      IP18 = IPOINT(18)
      IP19 = IPOINT(19)
      IP20 = IPOINT(20)
      IP21 = IPOINT(21)
      IP22 = IPOINT(22)
      IP23 = IPOINT(23)
      IP24 = IPOINT(24)
      IP25 = IPOINT(25)
      IP26 = IPOINT(26)
      IP27 = IPOINT(27)

!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
      CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
      IF (IKMRK1.EQ.1) THEN
!     als ook rekenen voor drooggevallen platen dan :
!jvb  IF (IKMRK1.EQ.0.OR.IKMRK1.EQ.1) THEN

!         Compute saturation percentage for all layers

      O2     = PMSA(IP1 )
      OXSAT  = PMSA(IP10 )
      SATPERC = O2 / OXSAT * 100
      PMSA (IP27) = SATPERC

      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.1)) THEN
!
      DEPTH  = PMSA(IP2 )
      TEMP   = PMSA(IP3 )
      VELOC  = PMSA(IP4 )
      VWIND  = PMSA(IP5 )
      IFREAR = PMSA(IP6 ) + 0.5
      REARKL = PMSA(IP7 )
      REARTC = PMSA(IP8 )
      DELT   = PMSA(IP9  )
      SAL    = PMSA(IP11 )
      TOTDEP = PMSA(IP12 )
      FCOVER = PMSA(IP13 )
      MAXRRC = PMSA(IP14 )
      MINRRC = PMSA(IP15 )
      RAIN   = PMSA(IP16 )
      A      = PMSA(IP17 )
      B1     = PMSA(IP18 )
      B2     = PMSA(IP19 )
      C1     = PMSA(IP20 )
      C2     = PMSA(IP21 )
      D1     = PMSA(IP22 )
      D2     = PMSA(IP23 )
      D3     = PMSA(IP24 )
      D4     = PMSA(IP25 )

      IF (DEPTH   .LT. 1E-30) CALL ZEROME ('DEPTH in REAR')

!     JvG, 1 May 2002
!     Current formulation was not valid for layered schematisations
!     Correct by using the methodology as follows:
!     a) compute surface transfer coefficient in m/day per method
!     b) compute flux by multiplying with (surface) deficit
!     c) convert to volumetric flux by using the (surface) layer thickness

      IF (IFREAR .EQ. 0) THEN
!
!         0. Unscaled user input coefficient in 1/day
!
          REARRC = REARKL * TOTDEP

      ELSEIF (IFREAR .EQ. 1) THEN
!
!         1. User input coefficient in m/day
!
          REARRC = REARKL

      ELSEIF (IFREAR .EQ. 2) THEN
!
!         2. Churchill [1962]
!
          REARRC = 0.0
          IF (VELOC  .GT. 1E-30)
     J    REARRC = 5.026 * (VELOC**0.969) / (TOTDEP**0.673)

      ELSEIF (IFREAR .EQ. 3) THEN
!
!         3. O'Connor - Dobbins [1958]
!
          REARRC = 0.0
          IF (VELOC  .GT. 1E-30)
     J    REARRC = 3.863 * (VELOC**0.5) / (TOTDEP**0.5)

      ELSEIF (IFREAR .EQ. 4) THEN
!
!         4. Scaled version of O'Connor - Dobbins [1958]
!
          REARRC = 0.0
          IF (VELOC  .GT. 1E-30)
     J    REARRC = 3.863 * (VELOC**0.5) / (TOTDEP**0.5) * REARKL

      ELSEIF (IFREAR .EQ. 5) THEN
!
!         5. Owens - Edwards - Gibb [1964]
!
          REARRC = 0.0
          IF (VELOC  .GT. 1E-30)
     J    REARRC = 5.322 * (VELOC**0.67) / (TOTDEP**0.85)

      ELSEIF (IFREAR .EQ. 6) THEN
!
!         6. Langbien - Durum [1967]
!
          REARRC = 0.0
          IF (VELOC  .GT. 1E-30)
     J    REARRC = 11.23 * VELOC / (TOTDEP**0.333)

      ELSEIF (IFREAR .EQ. 7) THEN
!
!         7. Van Pagee[1978] and Delvigne [1980]
!
          IF (VELOC  .GT. 1E-30) THEN
              REARRC = ( REARKL * 0.065 * VWIND**2 +
     &               3.86  * SQRT( VELOC/TOTDEP ) )
          ELSE
              REARRC = REARKL* 0.065 * VWIND**2
          ENDIF

      ELSEIF (IFREAR .EQ. 8) THEN
!
!         8. Thackston - Krenkel [1966]
!
          WRITE (*,*) ' Reaeration formula 8 has not been implemented'
          CALL SRSTOP(1)

      ELSEIF (IFREAR .EQ. 9) THEN
!
!         9. DBS
!
          REARRC = ( 0.30 + REARKL * 0.028 * VWIND**2 )

      ELSEIF (IFREAR .EQ. 10) THEN
!
!        10. Wanninkhof Oxygen
!
          IF ( SAL .GT. 5.0 ) THEN
             SC   = D1Os - D2Os*TEMP + D3Os*TEMP**2 - D4Os*TEMP**3
             SC20 = D1Os - D2Os*20.0 + D3Os*20.0**2 - D4Os*20.0**3
          ELSE
             SC   = D1 - D2*TEMP + D3*TEMP**2 - D4*TEMP**3
             SC20 = D1 - D2*20.0 + D3*20.0**2 - D4*20.0**3
          ENDIF
          KLREAR = 0.31*VWIND**2*(SC/SC20)**(-0.5)*24./100.
          REARRC = KLREAR

      ELSEIF (IFREAR .EQ. 11) THEN
!
!        10. Wanninkhof CO2
!
          IF ( SAL .GT. 5.0 ) THEN
             SC   = D1Cs - D2Cs*TEMP + D3Cs*TEMP**2 - D4Cs*TEMP**3
             SC20 = D1Cs - D2Cs*20.0 + D3Cs*20.0**2 - D4Cs*20.0**3
          ELSE
             SC   = D1 - D2*TEMP + D3*TEMP**2 - D4*TEMP**3
             SC20 = D1 - D2*20.0 + D3*20.0**2 - D4*20.0**3
          ENDIF
          B_ENHA = 2.5*(.5246+1.6256E-2*TEMP+4.9946E-4*TEMP**2)
          KLREAR = (B_ENHA + 0.31*VWIND**2)*(SC/SC20)**(-0.5)*24./100.
          REARRC = KLREAR

      ELSEIF (IFREAR .EQ. 12) THEN

!     Note this option is not included in the process documentation!
!
!         12. Hybride formulation using O'Connor - Dobbins [1958]
!             and Owens - Edwards - Gibb [1964]
!
          REARRC = 0.0
          HCRT = 3.93/5.32*TOTDEP**0.35
          IF (VELOC  .GT. 1E-30) THEN
             IF (VELOC .LT. HCRT**6) THEN
                REARRC = 3.93 * (VELOC**0.5) / (TOTDEP**0.5)
             ELSE
                REARRC = 5.32 * (VELOC**0.67) / (TOTDEP**0.85)
             ENDIF
          ENDIF
          REARRC = MAX(MINRRC,REARRC)

      ELSEIF ( IFREAR .EQ. 13) THEN
!
!        13. Guerin O2  - only fresh water
!            Guerin CO2 - only fresh water
!            Guerin CH4 - only fresh water
!
          SC   = D1 - D2*TEMP + D3*TEMP**2 - D4*TEMP**3
          SC20 = D1 - D2*20.0 + D3*20.0**2 - D4*20.0**3

          KLREAR =(A*EXP(B1 * VWIND**B2)+C1*Rain**C2)*(SC/SC20)**(-0.67)
          REARRC = KLREAR

          REARTC = 1.0
!
      ELSE
          WRITE (*,*) ' Illegal option for reaeration formula'
          CALL SRSTOP(1)
      ENDIF

      PMSA (IP26 ) = REARRC/DEPTH

!     Calculation of rearation flux ( M.L-1.DAY)
!     negatieve zuurstof wordt 0 gemaakt i.v.m. deficiet berekening!
!     Wanninkhof, don't use temperature dependency

      O2 = MAX (O2, 0.0)
      IF ( IFREAR .EQ. 10 .OR. IFREAR .EQ. 11 ) THEN
         FL1 = REARRC * ( OXSAT - O2 ) / DEPTH
      ELSE
         TEMP20 = TEMP - 20.0
         TMPCF  = REARTC ** TEMP20
         IF (REARRC.LE.MAXRRC) THEN
            REARRC = REARRC * TMPCF
         ENDIF
         FL1 = MIN( 1.0 / DELT, REARRC * (1-FCOVER)/DEPTH ) * (OXSAT-O2)
      ENDIF

!     Limitation of FL(1) to amount of oxygen present
      IF (FL1 .LT. 0.0 ) THEN
          FL1 = MAX (-1.*O2/DELT,  FL1 )
      ENDIF
      FL( 1+IFLUX) = FL1

      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + INCREM (  1 )
      IP2   = IP2   + INCREM (  2 )
      IP3   = IP3   + INCREM (  3 )
      IP4   = IP4   + INCREM (  4 )
      IP5   = IP5   + INCREM (  5 )
      IP6   = IP6   + INCREM (  6 )
      IP7   = IP7   + INCREM (  7 )
      IP8   = IP8   + INCREM (  8 )
      IP9   = IP9   + INCREM (  9 )
      IP10  = IP10  + INCREM ( 10 )
      IP11  = IP11  + INCREM ( 11 )
      IP12  = IP12  + INCREM ( 12 )
      IP13  = IP13  + INCREM ( 13 )
      IP14  = IP14  + INCREM ( 14 )
      IP15  = IP15  + INCREM ( 15 )
      IP16  = IP16  + INCREM ( 16 )
      IP17  = IP17  + INCREM ( 17 )
      IP18  = IP18  + INCREM ( 18 )
      IP19  = IP19  + INCREM ( 19 )
      IP20  = IP20  + INCREM ( 20 )
      IP21  = IP21  + INCREM ( 21 )
      IP22  = IP22  + INCREM ( 22 )
      IP23  = IP23  + INCREM ( 23 )
      IP24  = IP24  + INCREM ( 24 )
      IP25  = IP25  + INCREM ( 25 )
      IP26  = IP26  + INCREM ( 26 )
      IP27  = IP27  + INCREM ( 27 )
!
 9000 CONTINUE
!
      RETURN
!
      END


*
*     ------------------------------------------------------------------
*       R E A D W 2
*     ------------------------------------------------------------------
*
      SUBROUTINE readw2
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NWD=128,NOD=220)
      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
      POINTER(QIAJCMP,IAJCMP(1)),(QLJCOMP,LJCOMP(1)),
     :       (QNJCOMP,NJCOMP(1)),(QIAJCLD,IAJCLD(1)),
     :       (QLJCLSD,LJCLSD(1))
      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCF
      COMMON /NON30/ QIAJCMP,QNJCOMP,QLJCOMP,QIAJCLD,QLJCLSD,MAXORB
      COMMON /NOR/NCOM,NCLOSI,NCLOSF,NORBI,NORBF,IWAR
      COMMON /INOUT/IREAD,IWRITE,ISCW,iuc(2),iuw(2),iul(2),iuj(2),iut(2)
      COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
     :       (IQMAX,MAX(1))
      COMMON /RAS/ ninac(11,2),nras1(11,10,2),nras2(11,2),
     :             nras3(11,10,2),NGAS1(2),NGAS3(2),
     :             nl(11,2),elras(2*nwd),elrasi(nwd),elrasf(nwd),
     :             itab(nwd,2),lmax(2)
      COMMON /NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7),el(nwd)
      COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
      COMMON /FO/IWF(2),NCLOS(2),NOPEN(2),MAXNFO
      COMMON/DFG/ IBUGM
      CHARACTER*6 atom, term
      LOGICAL found(NWD,2),check
      CHARACTER*3 el,el1,elras,elrasi,elrasf,eltens
      COMMON /ELT/ELTENS(NWD)
      character*7 label(2)
      DOUBLE PRECISION PT(NOD)
      DATA LABEL/'Initial','Final  '/
*
* --- allocate the /NEL/
*
      if(ibugm.ne.0) print*,' iqp     allocation: nod*maxnfo = ',
     :               nod*maxnfo
      call alloc(iqp,nod*maxnfo,8)
      if(ibugm.ne.0) print*,' iqn     allocation: maxnfo = ',maxnfo
      call alloc(iqn,maxnfo,4)
      if(ibugm.ne.0) print*,' iql     allocation: maxnfo = ',maxnfo
      call alloc(iql,maxnfo,4)
      if(ibugm.ne.0) print*,' iqaz    allocation: maxnfo = ',maxnfo
      call alloc(iqaz,maxnfo,8)
      if(ibugm.ne.0) print*,' iqmax   allocation: maxnfo = ',maxnfo
      call alloc(iqmax,maxnfo,4)
*
* --- read the radial wavefunctions on units iuw(1) and iuw(2)
*     and sort them according the RAS order
*
*
* --- transfer NDIMS/NON30 -> PARAM
*
      nwf = maxnfo
      ncfg = ncf
      print*,' in readw2, nwf = ',nwf,' ncfg = ',ncfg
*
      do 1 i = 1,nwf
        if(i.le.iwf(1)) then
           elrasi(i) = elras(i)
           found(i,1) = .false.
        else
           k = i-iwf(1)
           elrasf(k) = elras(i)
           found(k,2) = .false.
        end if
    1 continue
      print*,' elrasi = ',(elrasi(i),i=1,iwf(1))
      print*,' elrasf = ',(elrasf(i),i=1,iwf(2))
*
*  *****  READ THE RADIAL FUNCTIONS
*
      IW = 1
  14  IF (IW .LE. (iwf(1))) THEN
          IK = 1
          READ(iuw(1)) ATOM,Term,EL1,M,ZZ,ETI,EKI,AZD,(PT(J),J=1,M)
          call eptr(elrasi,el1,i,*999)
      ELSE
          IK = 2
          READ(iuw(2)) ATOM,Term,EL1,M,ZZ,ETI,EKI,AZD,(PT(J),J=1,M)
          call eptr(elrasf,el1,i,*999)
      END IF
      if (.not. found(i,ik)) then
        if (ik.eq.1) then
          ij = i
        elseif (ik.eq.2) then
          ij = i+iwf(1)
        end if
        print*,label(ik),' electron ',el1,' P index = ',ij
        Do 15 j= 1,m
            p(j,ij) = pt(j)
   15   continue
        n(ij) = ichar(el1(2:2))-ichar('1')+1
        l(ij) = lval(el1(3:3))
	az(ij) = azd
	max(ij) = m
        DO 24 J = M+1,NO
   24       P(J,ij) = D0
        found(i,ik) = .true.
      end if
      Z = ZZ
      IW = IW+1
  999 IF (IW.LE.NWF) GO TO 14
   13 close(iuw(1))
      close(iuw(2))
*
* ---  check that all functions were found
*
      check = .true.
      do 16 i = 1,iwf(1)
	 check = check .and. found(i,1)
  16  continue
      do 17 i = 1,iwf(2)
	 check = check .and. found(i,2)
  17  continue
      if (.not. check) then
	 write(iscw,*) ' Not all radial functions were found'
         write(iscw,'(1X,A3,2X,L1)')(elrasi(i),found(i,1),i=1,iwf(1))
         write(iscw,'(1X,A3,2X,L1)')(elrasf(i),found(i,2),i=1,iwf(2))
	 stop
      end if
      do 20 i = 1,maxorb
        do 21 j=1,iwf(1)
          if(eltens(i).eq.elrasi(j)) itab(i,1)=j
  21    continue
        do 22 j=1,iwf(2)
          if(eltens(i).eq.elrasf(j)) itab(i,2)=j+iwf(1)
  22    continue
  20  continue
       print*
      print*
      print*,' Position of biorthonormal shells in P vector : '
      print*,' ---------------------------------------------- '
      print*,label(1),' :  ',(itab(i,1),i=1,maxorb)
      print*,label(2),' :  ',(itab(i,2),i=1,maxorb)
      print*
*     .. initialize R and Rydberg constant
      call initm2(1)
      return
      end


! Generate hotstart.in with const. elev. (from elev.ic) and 0 vel (i.e. S,T only; no tracers)
! History: added ivcor=1; fixed a bug in ntracers
! pgf90 -O2 -mcmodel=medium -Mbounds -Bstatic -o bay_delta_hotstart /sciclone/home04/yinglong/SELFE/svn/trunk/src/Utility/UtilLib/argparse.F90 bay_delta_hotstart.f90
! ifort -Bstatic -assume byterecl -O2 -o bay_delta_hotstart bay_delta_hotstart.f90 argparse.F90
! ifort -Bstatic /assume:byterecl -O2 -fpp -o bay_delta_hotstart bay_delta_hotstart.f90 argparse.F90
!   Input:
!     (1) USGS survey data: (e.g. usgs_cruise_station.txt, usgs_2009_02_10.txt) -WARNING:
!                            dates have to be in: mm/dd/yyyy... i.e. double digits for mm & dd,
!                            and mm must be preceded by exactly 1 space!
!     (2) hgrid.gr3;
!     (3) vgrid.in;
!     (4) estuary.gr3 (flags): depth=0: outside; =1: Bay; =2: Delta
!     (5) elev.ic: init. condition for elev
!   Output: hotstart.in ; fort.11 (fatal); fort.27 (debug)

!      implicit none

!     integer, parameter :: debug=1

      program bay_delta_hotstart
      implicit none

      character*120 tempsaltfile
      character*120 stationfile
      character*120 hotstartfile
      character*120 initialelevfile
      character*120 hgridfile
      character*120 vgridfile
      character*120 estuaryfile
      real         deltasalt
      real         deltatemp
      real         coastal_T

      call hotstart_input(tempsaltfile,&
                          stationfile,&
                          initialelevfile,&
                          hgridfile,&
                          vgridfile,&
                          estuaryfile,&
                          deltasalt,&
                          deltatemp, &
                          coastal_T, &
                          hotstartfile)

      call hotstart_from_cruise_data(tempsaltfile,&
                                     stationfile,&
                                     initialelevfile,&
                                     hgridfile,&
                                     vgridfile,&
                                     estuaryfile,&
                                     deltasalt,&
                                     deltatemp, &
                                     coastal_T, &
                                     hotstartfile)
      end program

      subroutine hotstart_input(tempsaltfile,&
                                          stationfile,&
                                          initialelevfile,&
                                          hgridfile,&
                                          vgridfile,&
                                          estuaryfile,&
                                          deltasalt,&
                                          deltatemp, &
                                          coastal_T, &
                                          hotstartfile)
      use argparse
      implicit none
      character :: cmd = "bay_delta_hotstart"
      character*120 tempsaltfile
      character*120 stationfile
      character*120 hotstartfile
      character*120 initialelevfile
      character*120 hgridfile
      character*120 vgridfile
      character*120 estuaryfile
      real         deltasalt
      real         deltatemp
      real         coastal_T
      logical :: fileexists
      logical :: validate_files = .FALSE.
      cmd_name = cmd
      deltasalt=0.15
      deltatemp=10.5
      coastal_T=12.
      hotstartfile="hotstart.in"
      initialelevfile="elev.ic"
      hgridfile="hgrid.gr3"
      vgridfile="vgrid.in"
      estuaryfile="estuary.gr3"

      !you must provde station file
      stationfile="invalid"
      tempsaltfile="invalid"
      call cla_init(cmd_name)
      call cla_register('-s','--station','Name of station file describing cruise stations',cla_char,'')
      call cla_register('-t','--tempsalt','Name of temp/salt file (beware date format!)',cla_char,'')
      call cla_register('-o','--hotstart','Name of hotstart file for output (default hotstart.in)',cla_char,'hotstart.in')
      call cla_register('-z','--elev','Path of initial elevation file (elev.ic)',cla_char,'elev.ic')
      call cla_register('-v','--vgrid','Path of vgrid.in file (vgrid.in)',cla_char,'vgrid.in')
      call cla_register('-h','--hgrid','Path of hgrid.gr3 file (hgrid.gr3)',cla_char,'hgrid.gr3')
      call cla_register('-e','--estuary','Path of estuary.gr3 file (vgrid.in)',cla_char,'estuary.gr3')
      call cla_register('-d','--deltasalt','Delta salinity in psu.',cla_float,'0.15')
      call cla_register('-p','--deltatemp','Delta temperature in C.',cla_float,'10.5')
      call cla_register('-c','--coastal_T','Coastal temperature in C.',cla_float,'12')

      call cla_get("--station",stationfile)
      call cla_get("--tempsalt",tempsaltfile)
      call cla_get("--hotstart",hotstartfile)
      call cla_get("--elev",initialelevfile)
      call cla_get("--vgrid",vgridfile)
      call cla_get("--hgrid",hgridfile)
      call cla_get("--estuary",estuaryfile)
      call cla_get("--deltasalt",deltasalt)
      call cla_get("--deltatemp",deltatemp)
      call cla_get("--coastal_T",coastal_T)

      call cla_validate()
      if (validate_files) then
      inquire(FILE=tempsaltfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, tempsaltfile,"is invalid"
         stop -1
      endif
      inquire(FILE=estuaryfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, estuaryfile,"is invalid"
         stop -1
      endif
      inquire(FILE=stationfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, stationfile,"is invalid"
         stop -1
      endif
      inquire(FILE=hgridfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, hgridfile,"is invalid"
         stop -1
      endif
      inquire(FILE=vgridfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, vgridfile,"is invalid"
         stop -1
      endif
      inquire(FILE=initialelevfile, EXIST=fileexists)
      if (.not.fileexists) then
         print *, initialelevfile,"is invalid"
         stop -1
      endif
      end if

      end subroutine

      subroutine hotstart_from_cruise_data(tempsaltfile,stationfile,initialelevfile,&
                 hgridfile,vgridfile,estuaryfile,deltasalt,deltatemp,coastal_T,hotstartfile)
      !implicit none
      character*120 tempsaltfile
      character*120 stationfile
      character*120 hotstartfile
      character*120 initialelevfile
      character*120 hgridfile
      character*120 vgridfile
      character*120 estuaryfile
      real         deltasalt
      real         deltatemp
      real         coastal_T

      integer, parameter :: mcasts=1000 !max. # of casts on 03/12
      integer, parameter :: mndps=200 !max. # of depth bins
      integer, parameter :: mnp=400000 !400000
      integer, parameter :: mne=400000
      integer, parameter :: mns=650000 !790000
      integer, parameter :: mnv=140    !100
      integer, parameter :: mnope=20 !max # of open bnd segments
      integer, parameter :: mnond=1000 !max # of open bnd nodes in each segment
      integer, parameter :: mnei=20 !neighbor
      integer, parameter :: nbyte=4
      real, parameter :: small1=1.e-3 !used to check area ratios

!     Vertical postion, salinity, and temperature
      integer :: ne,np,i,j
      integer :: nope,neta
      integer, dimension(:,:), allocatable :: kbp
      integer   code
      integer tmp
      real htmp,stmp,ttmp
      integer   ier ! allocate error return.
      integer   dummy,commalocation
      integer ::  dd,mm,yyyy,tttt
      character(len=1) ::  c1,c2,c3,c4
      character*120  tempstring
      integer :: iostatus
      integer, allocatable :: i34(:)
      real,allocatable :: xnd(:),ynd(:),nm(:,:),dp(:),eta(:)
      !dimension xnd(mnp),ynd(mnp),nm(mne,4),dp(mnp),i34(mne),eta(mnp)
      real,allocatable :: sigma(:),cs(:),z(:,:)
      integer,allocatable :: iest(:),ixy(:,:)
      !dimension sigma(mnv),cs(mnv),z(mnp,mnv),iest(mnp),ixy(mnp,2)
      dimension arco(3),ztot(0:mnv)
      dimension iwild(100)
      dimension tempout(mnp,mnv), saltout(mnp,mnv),month_day(12)
      dimension tsd(mns,mnv),ssd(mns,mnv),tsel(mnv,mne,2)
      integer,allocatable :: nne(:),ine(:,:),ic3(:,:),js(:,:),is(:,:),isidenode(:,:)

      dimension nx(4,4,3)
      dimension xcj(mns),ycj(mns),nond(mnope),iond(mnope,mnond) !,iob(mnope),iond2(mnope*mnond)
      dimension sta2(mcasts),casts_xyz(mcasts,3),cast_h(mcasts,mndps),cast_S(mcasts,mndps), &
     &cast_T(mcasts,mndps),nbins(mcasts)
      dimension kbp2(mnp),sigma_lcl(mnv,mnp)
      allocatable :: sta1(:),xsta(:),ysta(:),hsta(:),map(:)
!     Read in (const) elev.
      open(10,file=initialelevfile,status='old')
      read(10,*)
      read(10,*)ne, np
      allocate(xnd(np),ynd(np),nm(ne,4),dp(np),i34(ne),eta(np))
      allocate(sigma(mnv),cs(mnv),z(np,mnv),iest(np),ixy(np,2))
      allocate(nne(np),ine(np,mnei),ic3(ne,4),js(ne,4),is(mns,2),isidenode(mns,2))
      do i=1,np
        read(10,*)j,xtmp,ytmp,eta(i)
      enddo
      close(10)

!     Read in survey data
      open(8,file=stationfile,status='old')
      open(9,file=tempsaltfile,status='old')
      read(8,*)
      nsta=0
      do
          read(8,*,iostat=iostatus) dummy
          if (iostatus.ne.0) then
              exit
          endif
          nsta=nsta+1
      enddo
      rewind 8
      read(8,*)
      allocate(sta1(nsta),xsta(nsta),ysta(nsta),hsta(nsta))
      do i=1,nsta
        read(8,*)sta1(i),ysta(i),xsta(i),hsta(i)
      enddo !i
      close(8)
      mapdim=maxval(sta1(1:nsta)*10) !for mapping array
      !print*, 'mapdim=',mapdim
      allocate(map(mapdim))
      map=0
      do i=1,nsta
        map(int(sta1(i)*10))=i
      enddo !i

      ncasts=1 !# of casts
      ndps=0 !# of depth bins
      i = 1
      do ! i=1,549 !read only 03/12 data
        if(i<=2) then
          read(9,*)
        else
          mm=-9999
          dd=-9999
100       format (i3,a1,i2,a1,i4,a1,i4,a1,a)
          read(9,100,iostat=code) mm,c1,dd,c2,yyyy,c3,tttt,c4,tempstring
!          if(i==3) print*, mm,c1,dd,c2,yyyy,c3,tttt,c4,tempstring

          ! reach the end of file
          if (code.ne.0) then
             if (i.eq.3) then
               write(*,*) "input data is empty, no result generated:",mm,c1,dd,c2,yyyy,c3,tttt,c4,tempstring
               stop -1
             else ! at least have one data
               exit
             end if
          end if

          if ((.not.((mm.le.12).and.(mm.ge.1))) .or. (.not.((dd.le.31).and.(dd.ge.1))) )then
             if (i.eq.3) then
               write(*,*) "valid data must start from the third line, no result generated"
               stop -1
             else ! at least have one data
               exit
             end if
          end if

          !total four data seperate by 3 comma are expected
          commalocation=index(tempstring,",")
          if (commalocation.eq.0) then
              write(*,'(a,i,a)') "data line",i,"is invalid"
          end if
          read(tempstring(1:commalocation-1),*,iostat=code)tmp
          tmp=int(tmp)
          tempstring=tempstring(commalocation+1:)
          commalocation=index(tempstring,",")
          if (commalocation.eq.0) then
              write(*,'(a,i,a)') "data line",i,"is invalid"
          end if
          read(tempstring(1:commalocation-1),*,iostat=code)htmp
          tempstring=tempstring(commalocation+1:)
          commalocation=index(tempstring,",")
          if (commalocation.eq.0) then
              write(*,'(a,i,a)') "data line",i,"is invalid"
          end if
          read(tempstring(1:commalocation-1),*,iostat=code)stmp
          tempstring=tempstring(commalocation+1:)
          read(tempstring,*,iostat=code)ttmp

!          read(9,*,iostat=code)iwild(1:5),tmp,htmp,stmp,ttmp

          if (code<0) then
            tmp = -1
          endif
          !print*, 'check:',iwild(1:5),tmp,htmp,stmp,ttmp
          if(i>3) then
            if(abs(tmp-sta2(ncasts))>0.1) then
              nbins(ncasts)=ndps;
!              print*, 'cast # ',ncasts,ndps,sta2(ncasts),casts_xyz(ncasts,1:3)
!              print*, 'cast T=',cast_T(ncasts,1:ndps),'; depths=',cast_h(ncasts,1:ndps)
              ncasts=ncasts+1; ndps=0
            endif
            if (tmp == -1) then
               exit
            endif
          endif !i>3
          ndps=ndps+1
          if(ncasts>mcasts.or.ndps>mndps) then
            write(*,*)'Increase mcasts or mndps:',ncasts,ndps
            stop -1
          endif
          sta2(ncasts)=tmp
          itmp=map(int(tmp*10))
          casts_xyz(ncasts,1)=xsta(itmp)
          casts_xyz(ncasts,2)=ysta(itmp)
          casts_xyz(ncasts,3)=hsta(itmp)
          cast_h(ncasts,ndps)=htmp
          cast_S(ncasts,ndps)=stmp
          cast_T(ncasts,ndps)=ttmp
        endif
        i = i + 1
      enddo !i

      nbins(ncasts)=ndps !for last cast
      close(9)
      print*, '# of casts',ncasts
      print*, 'Last cast (x,y,h)=',casts_xyz(ncasts,1:3),'; depths=',cast_h(ncasts,1:nbins(ncasts))
!      stop -1

!     Read in hgrid and vgrid
      open(17,file=estuaryfile,status='old')
      open(14,file=hgridfile,status='old') !only need depth info and connectivity
      open(19,file=vgridfile,status='old')
      print*,"Reading hgrid"
      read(14,*)
      read(14,*)ne,np
      if(np.gt.mnp.or.ne.gt.mne) then
        write(*,*)'Increase mnp/mne'
        stop -1
      endif
      read(17,*)
      read(17,*)
      print*, "ne = ",ne," np=",np
      do i=1,np
        read(14,*)j,xnd(i),ynd(i),dp(i)
        read(17,*)j,xtmp,ytmp,iest(i)
        if(iest(i)<0.or.iest(i)>2) then
          write(11,*)'Estuary flag wrong:',i,iest(i)
          stop -1
        endif
      enddo !i
      do i=1,ne
        read(14,*)j,i34(i),(nm(i,l),l=1,i34(i))
      enddo !i
!     Open bnds
      read(14,*) nope
      read(14,*) neta
      ntot=0
      if(nope>mnope) stop 'Increase mnope (2)'
      do k=1,nope
        read(14,*) nond(k)
        if(nond(k)>mnond) stop 'Increase mnond'
        do i=1,nond(k)
          read(14,*) iond(k,i)
        enddo
      enddo

!      nond0=0
!      do i=1,nob
!        ibnd=iob(i)
!        do j=1,nond(ibnd)
!          nond0=nond0+1
!          iond2(nond0)=iond(ibnd,j)
!        enddo !j
!      enddo !i
      close(14)

!     V-grid
      print*,"Reading vgrid"
      read(19,*)ivcor
      if(ivcor==2) then
        read(19,*) nvrt,kz,h_s !kz>=1
        if(nvrt>mnv.or.nvrt<2) then
          write(11,*)'nvrt > mnv or nvrt<2'
          stop -1
        endif
        if(kz<1) then !.or.kz>nvrt-2) then
          write(11,*)'Wrong kz:',kz
          stop -1
        endif
        if(h_s<10) then
          write(11,*)'h_s needs to be larger:',h_s
          stop -1
        endif

!       # of z-levels excluding "bottom" at h_s
        read(19,*) !for adding comment "Z levels"
        do k=1,kz-1
          read(19,*)j,ztot(k)
          if(k>1.and.ztot(k)<=ztot(k-1).or.ztot(k)>=-h_s) then
            write(11,*)'z-level inverted:',k
            stop -1
          endif
        enddo !k
        read(19,*) !level kz
!       In case kz=1, there is only 1 ztot(1)=-h_s
        ztot(kz)=-h_s

        nsig=nvrt-kz+1 !# of S levels (including "bottom" & f.s.)
        read(19,*) !for adding comment "S levels"
        read(19,*)h_c,theta_b,theta_f
        if(h_c<5) then !large h_c to avoid 2nd type abnormaty
          write(11,*)'h_c needs to be larger:',h_c
          stop -1
        endif
        if(theta_b<0.or.theta_b>1) then
          write(11,*)'Wrong theta_b:',theta_b
          stop -1
        endif
        if(theta_f<=0) then
          write(11,*)'Wrong theta_f:',theta_f
          stop -1
        endif
!       Pre-compute constants
        s_con1=sinh(theta_f)

        sigma(1)=-1 !bottom
        sigma(nsig)=0 !surface
        read(19,*) !level kz
        do k=kz+1,nvrt-1
          kin=k-kz+1
          read(19,*) j,sigma(kin)
          if(sigma(kin)<=sigma(kin-1).or.sigma(kin)>=0) then
            write(11,*)'Check sigma levels at:',k,sigma(kin),sigma(kin-1)
            stop -1
          endif
        enddo
        read(19,*) !level nvrt

!       Compute C(s) and C'(s)
        do k=1,nsig
          cs(k)=(1-theta_b)*sinh(theta_f*sigma(k))/sinh(theta_f)+ &
     &theta_b*(tanh(theta_f*(sigma(k)+0.5))-tanh(theta_f*0.5))/2/tanh(theta_f*0.5)
        enddo !k=1,nvrt

        do i=1,np
          do k=kz,nvrt
            kin=k-kz+1
            hmod2=max(0.1,min(dp(i),h_s))
            if(hmod2<=h_c) then
              z(i,k)=sigma(kin)*hmod2
            else
              z(i,k)=h_c*sigma(kin)+(hmod2-h_c)*cs(kin)
            endif
          enddo !k

!         Z-levels; shallow pts have junk values
          do k=1,kz-1
            z(i,k)=ztot(k)
          enddo !k
        enddo !i
      else if(ivcor==1) then !Localized
        read(19,*)nvrt
        if(nvrt>mnv.or.nvrt<3) then
          write(11,*)'nvrt > mnv or nvrt<4:',nvrt
          stop -1
        endif

        do i=1,np
          read(19,*)j,kbp2(i),sigma_lcl(kbp2(i):nvrt,i)

          hmod2=max(0.1,dp(i))
          z(i,kbp2(i))=-hmod2 !to avoid underflow
          z(i,nvrt)=0
          do k=kbp2(i)+1,nvrt-1
            z(i,k)=sigma_lcl(k,i)*hmod2
          enddo !k

          !Check
          do k=kbp2(i)+1,nvrt
            if(z(i,k)-z(i,k-1)<=0) then
              write(11,*)'Inverted Z:',z(i,k),z(i,k-1),k,i,dp(i),sigma_lcl(:,i)
              stop -1
            endif
          enddo !k

          !Extend bottom (as these are used)
          z(i,1:kbp2(i)-1)=z(i,kbp2(i))
        enddo !i=1,np
      else
        write(11,*)'Unknow ivcor'
        stop -1
      endif !ivcor

      close(19)
      print*,"Computing geometry information such as interpolation neighbors"
!     Compute geometry
      do k=3,4
        do i=1,k
          do j=1,k-1
            nx(k,i,j)=i+j
            if(nx(k,i,j)>k) nx(k,i,j)=nx(k,i,j)-k
            if(nx(k,i,j)<1.or.nx(k,i,j)>k) then
              write(*,*)'nx wrong',i,j,k,nx(k,i,j)
              stop -1
            endif
          enddo !j
        enddo !i
      enddo !k

      do i=1,np
        nne(i)=0
      enddo

      do i=1,ne
        do j=1,i34(i)
          nd=nm(i,j)
          nne(nd)=nne(nd)+1
          if(nne(nd)>mnei) then
            write(11,*)'Too many neighbors',nd
            stop -1
          endif
          ine(nd,nne(nd))=i
        enddo
      enddo

!     Compute ball info; this won't be affected by re-arrangement below
      do i=1,ne
        do j=1,i34(i)
          ic3(i,j)=0 !index for bnd sides
          nd1=nm(i,nx(i34(i),j,1))
          nd2=nm(i,nx(i34(i),j,2))
          do k=1,nne(nd1)
            ie=ine(nd1,k)
            if(ie/=i.and.(nm(ie,1)==nd2.or.nm(ie,2)==nd2.or.nm(ie,3)==nd2.or.(i34(ie)==4.and.nm(ie,4)==nd2))) ic3(i,j)=ie
          enddo !k
        enddo !j
      enddo !i

      print*,"Computing edge information"
      ns=0 !# of sides
      do i=1,ne
        do j=1,i34(i)
          nd1=nm(i,nx(i34(i),j,1))
          nd2=nm(i,nx(i34(i),j,2))
          if(ic3(i,j)==0.or.i<ic3(i,j)) then !new sides
            ns=ns+1
            if(ns>mns) then
              print*,"Too many sides (ns must be bigger in script"
              write(11,*)'Too many sides:'
              stop -1
            endif
            js(i,j)=ns
            is(ns,1)=i
            isidenode(ns,1)=nd1
            isidenode(ns,2)=nd2
            xcj(ns)=(xnd(nd1)+xnd(nd2))/2
            ycj(ns)=(ynd(nd1)+ynd(nd2))/2

            is(ns,2)=ic3(i,j) !bnd element => bnd side
!           Corresponding side in element ic3(i,j)
            if(ic3(i,j)/=0) then !old internal side
              iel=ic3(i,j)
              indexside=0
              do k=1,i34(iel)
                if(ic3(iel,k)==i) then
                  indexside=k
                  exit
                endif
              enddo !k
              if(indexside==0) then
                write(11,*)'Wrong ball info',i,j
                stop -1
              endif
              js(iel,indexside)=ns
            endif !ic3(i,j).ne.0
          endif !ic3(i,j)==0.or.i<ic3(i,j)
        enddo !j=1,i34
      enddo !i=1,ne
      print*,"Number of sides: ",ns
      if(ns<ne.or.ns<np) then
        write(11,*)'Weird grid with ns < ne or ns < np',np,ne,ns
        stop -1
      endif

!     Compute node T,S
      tempout=-9999.
      saltout=-9999. !init.
      do i=1,np
!       z() defined for dry pts also
        if(iest(i)==0) then !outside Bay
          saltout(i,:)=33.5
          tempout(i,:)=coastal_T !from ROMS (bottom)
        else if(iest(i)==2) then !Delta
          saltout(i,:)=deltasalt
          tempout(i,:)=deltatemp
        else !inside Bay
          !Find nearest cast
          rlmin=1.e23
          icast=0
          do j=1,ncasts
            rl2=(casts_xyz(j,1)-xnd(i))**2+(casts_xyz(j,2)-ynd(i))**2
            if(rl2<rlmin) then
              rlmin=rl2; icast=j
            endif
          enddo !j
          if(icast==0) stop 'Failed to find a cast'
          nbins0=nbins(icast)

          !Do vertical interpolation
          do k=1,nvrt
            if(z(i,k)>=-cast_h(icast,1)) then
              saltout(i,k)=cast_S(icast,1)
              tempout(i,k)=cast_T(icast,1)
            else if(z(i,k)<=-cast_h(icast,nbins0)) then
              saltout(i,k)=cast_S(icast,nbins0)
              tempout(i,k)=cast_T(icast,nbins0)
            else !normal
              ind0=0
              do kk=1,nbins0-1
                if(z(i,k)<=-cast_h(icast,kk).and.z(i,k)>=-cast_h(icast,kk+1)) then
                  ind0=kk
                  zrat=(z(i,k)+cast_h(icast,kk+1))/(-cast_h(icast,kk)+cast_h(icast,kk+1))
                  exit
                endif
              enddo !kk
              if(ind0==0.or.zrat<0.or.zrat>1) then
                write(*,*)'Failed to find a level:',i,k
                stop -1
              endif
              saltout(i,k)=zrat*cast_S(icast,ind0)+(1-zrat)*cast_S(icast,ind0+1)
              tempout(i,k)=zrat*cast_T(icast,ind0)+(1-zrat)*cast_T(icast,ind0+1)
            endif !z()
          enddo !k
        endif !in/out Bay
      enddo !i=1,np

      !Check
      do i=1,np
        write(27,*)i,xnd(i),ynd(i),saltout(i,1)
      enddo !i
      write(*,*)'S max/min=',maxval(saltout(1:np,1:nvrt)),minval(saltout(1:np,1:nvrt))
      write(*,*)'T max/min=',maxval(tempout(1:np,1:nvrt)),minval(tempout(1:np,1:nvrt))

!     Output hotstart
!     Note: although I swapped order of indices in SCHISM for S,T,
!           I didn't do the same for them in this code; as long as
!           the order of writing is correct in hotstart.in, it does not matter
      do i=1,ns
        n1=isidenode(i,1)
        n2=isidenode(i,2)
        do k=1,nvrt
          tsd(i,k)=(tempout(n1,k)+tempout(n2,k))/2
          ssd(i,k)=(saltout(n1,k)+saltout(n2,k))/2
        enddo !k
      enddo !i

      do i=1,ne
        do k=2,nvrt
          tsel(k,i,1)=0.
          tsel(k,i,2)=0.
          do j=1,i34(i)
            tsel(k,i,1)=tsel(k,i,1)+tempout(nm(i,j),k)+tempout(nm(i,j),k-1)
            tsel(k,i,2)=tsel(k,i,2)+saltout(nm(i,j),k)+saltout(nm(i,j),k-1)
          enddo
          tsel(k,i,1)=tsel(k,i,1)/(2*i34(i))
          tsel(k,i,2)=tsel(k,i,2)/(2*i34(i))
        enddo

        tsel(1,i,1)=tsel(2,i,1) !mainly for hotstart format
        tsel(1,i,2)=tsel(2,i,2)
      enddo !i

!     MPI SCHISM
      ntracers2=0 !_excluding_ T,S
      open(36,file=hotstartfile,form='unformatted',status='replace')
      write(36) 0.d0,0,1
      do i=1,ne
        !Add CoSINE tracers here
        tmp=0
        write(36) i,0,(0.d0,dble(tsel(j,i,1:2)),(dble(tmp),l=1,ntracers2),j=1,nvrt)
      enddo !i
      do i=1,ns
        write(36) i,0,(0.d0,0.d0,dble(tsd(i,j)),dble(ssd(i,j)),j=1,nvrt)
      enddo !i
      do i=1,np
        !Need to add tracers for CoSINE here also
        write(36) i,dble(eta(i)),0,(dble(tempout(i,j)),dble(saltout(i,j)), &
                  dble(tempout(i,j)),dble(saltout(i,j)),0.d0,0.d0, &
                  0.d0,0.d0,0.d0,0.d0,0.d0,j=1,nvrt)
      enddo !i
      close(36)
      !deallocate(xnd,ynd,nm,dp,i34,eta)
      !deallocate(sigma,cs,z,iest,ixy)
      stop
    end  subroutine