  subroutine typeout (gsmObj, proj, targ, output, outData)

! ======================================================================
!
!     Generates printout of results on unit 31 (cem2kgemfit.res).
!     Simplified by putting various loops into a separate subroutine
!     PRTDIST, AJS, 10/24/03. Also removed the calculation and printing
!     of the particle multiplicity table to PRTMULT, 12/15/03.
!
!   CEM95 written by S. G. Mashnik
!
!   Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!   Modified by A. J. Sierk, April-May, 1996.
!   Modified by AJS, Dec 1997; March, 1998.
!   Modified by AJS, March, 1999.
!   Modified by SGM at 06/16/2000
!   Modified by SGM at 05/08/2001
!   Modified by SGM on 12/04/01
!   "Last change": 13-AUG-2003 by NVMokhov
!   Modfied by AJS; September-October, 2003.
!   Modfied by AJS; December, 2003.
!   Modfied by KKG; September-November, 2004.
!   Edited by AJS, January, 2005.
!   Edited by AJS, LANL T-2, December, 2011.
!   Edited by LMK, XCP-3, July 2013 (included error protection)
!   Edited by CMJ, XCP-3, June 2017 (LAQGSM expansion)
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64, int64
    use OutputDataMod, only: OutputData
    use gsm_params, only: zro, one, two, fiv, thousand, degreeToRadian, &
         & twpi
    use standarddcmdata, only: photonEG

    implicit none
    class(GSM),           intent(inout) :: gsmObj
    class(GSMProjectile), intent(in   ) :: proj
    class(GSMTarget),     intent(in   ) :: targ
    class(GSMOutput),     intent(in   ) :: output
    class(OutputData),    intent(inout) :: outData

    integer(int32)    :: i, ia, iaa, iamax, ic, ii, iii, ij, ik, in, &
         & ip, ipar, ipt, ipz, iz, iz1, iz2, iz3, izmax, j, k, lpr, &
         & lprm, m, n
    integer(int64)    :: npt
    real(real64)      :: aav, abeg, aeqav, apqav, arav, artav, atk, atks, &
         & bfav, datk, datks, def, defmu, defp, defpmu, dfis, dsigf, dy1, &
         & dy2, dy3, dys1, dys2, dys3, dyy, dyys, eeav, ef, efmu, efp, &
         & efpmu, elav, eleav, elpav, elrav, elrtav, epav, eqqv, erkav, &
         & estarav, faca, fact, fe, fision, fl, fn, fneq, fnfis, fnn, fnpreq, &
         & fnres, fnret, ppt, s1, sfu1, siga, sigaeq, sigapq, sigar, &
         & sigart, sigbf, sigee, sigel, sigep, sigeq, sigerk, sigest, sigfis, &
         & sigfw, &
         & sigg, sigin, siginn, sigl, sigla, sigle, siglp, siglr, siglrt, &
         & sigz, sigzeq, sigzpq, sigzr, sigzrt, ss, t0mev, temp, test, &
         & tetmax, tetmin, tkfbar, y1, y2, y3, ys1, ys2, ys3, yy, yys, zav, &
         & zbeg, zeqav, zpqav, zrav, zrtav
    logical           :: printit, prtz1, prtz2, prtz3
    character(LEN=10) :: dummc = ""
    character(LEN=24) :: ddate = ""

    integer(int32),    dimension(151) :: izr = 0_int32
    integer(int32),    dimension(351) :: iar = 0_int32
    real(real64),      dimension( 20) ::  om = zro, dom = zro, &
         & const = zro, doo = zro
    real(real64),      dimension(151) ::  z = zro, dasum = zro
    real(real64),      dimension(351) :: ar = zro
    logical,           dimension(151) :: prtz = .FALSE.
    character(LEN=10), dimension(218) :: gch = ""

! ======================================================================

    character(LEN=10), parameter, dimension(9) :: par2 = &
         & [' neutrons ', ' protons  ', 'deuterons ', ' tritons  ', &
         &  ' Helium-3 ', '  alphas  ', 'neg. pions', 'neut pions', &
         &  'pos. pions' ]

    character(LEN=10), parameter, dimension(218) :: ch = [ &
         ! 1-72
         & '(N,n)     ', '(N,2n)    ', '(N,3n)    ', '(N,4n)    ', &
         & '(N,5n)    ', '(N,6n)    ', '(N,7n)    ', '(N,8n)    ', &
         & '(N,9n)    ', '(N,10n)   ', '(N,11n)   ', '(N,12n)   ', &
         & '(N,13n)   ', '(N,14n)   ', '(N,15n)   ', '(N,16n)   ', &
         & '(N,17n)   ', '(N,18n)   ', '(N,19n)   ', '(N,20n)   ', &
         & '(N,p)     ', '(N,2p)    ', '(N,3p)    ', '(N,4p)    ', &
         & '(N,5p)    ', '(N,n+p)   ', '(N,2n+p)  ', '(N,3n+p)  ', &
         & '(N,4n+p)  ', '(N,5n+p)  ', '(N,6n+p)  ', '(N,7n+p)  ', &
         & '(N,8n+p)  ', '(N,9n+p)  ', '(N,10n+p) ', '(N,11n+p) ', &
         & '(N,12n+p) ', '(N,13n+p) ', '(N,14n+p) ', '(N,15n+p) ', &
         & '(N,16n+p) ', '(N,17n+p) ', '(N,18n+p) ', '(N,19n+p) ', &
         & '(N,n+2p)  ', '(N,2n+2p) ', '(N,3n+2p) ', '(N,4n+2p) ', &
         & '(N,5n+2p) ', '(N,6n+2p) ', '(N,7n+2p) ', '(N,8n+2p) ', &
         & '(N,9n+2p) ', '(N,10n+2p)', '(N,11n+2p)', '(N,12n+2p)', &
         & '(N,13n+2p)', '(N,14n+2p)', '(N,15n+2p)', '(N,16n+2p)', &
         & '(N,17n+2p)', '(N,18n+2p)', '(N,n+3p)  ', '(N,2n+3p) ', &
         & '(N,3n+3p) ', '(N,4n+3p) ', '(N,5n+3p) ', '(N,6n+3p) ', &
         & '(N,7n+3p) ', '(N,8n+3p) ', '(N,9n+3p) ', '(N,10n+3p)', & ! 1-72
         ! 73-144
         & '(N,11n+3p)', '(N,12n+3p)', '(N,13n+3p)', '(N,14n+3p)', &
         & '(N,15n+3p)', '(N,16n+3p)', '(N,17n+3p)', '(N,n+4p)  ', &
         & '(N,2n+4p) ', '(N,3n+4p) ', '(N,4n+4p) ', '(N,5n+4p) ', &
         & '(N,6n+4p) ', '(N,7n+4p) ', '(N,8n+4p) ', '(N,9n+4p) ', &
         & '(N,10n+4p)', '(N,11n+4p)', '(N,12n+4p)', '(N,13n+4p)', &
         & '(N,14n+4p)', '(N,15n+4p)', '(N,16n+4p)', '(N,n+5p)  ', &
         & '(N,2n+5p) ', '(N,3n+5p) ', '(N,4n+5p) ', '(N,5n+5p) ', &
         & '(N,6n+5p) ', '(N,7n+5p) ', '(N,8n+5p) ', '(N,9n+5p) ', &
         & '(N,10n+5p)', '(N,11n+5p)', '(N,12n+5p)', '(N,13n+5p)', &
         & '(N,14n+5p)', '(N,15n+5p)', '(N,d)     ', '(N,n+d)   ', &
         & '(N,2n+d)  ', '(N,3n+d)  ', '(N,4n+d)  ', '(N,5n+d)  ', &
         & '(N,6n+d)  ', '(N,7n+d)  ', '(N,8n+d)  ', '(N,9n+d)  ', &
         & '(N,10n+d) ', '(N,11n+d) ', '(N,12n+d) ', '(N,13n+d) ', &
         & '(N,14n+d) ', '(N,15n+d) ', '(N,16n+d) ', '(N,17n+d) ', &
         & '(N,18n+d) ', '(N,19n+d) ', '(N,p+d)   ', '(N,n+p+d) ', &
         & '(N,2n+p+d)', '(N,3n+p+d)', '(N,4n+p+d)', '(N,5n+p+d)', &
         & '(N,6n+p+d)', '(N,7n+p+d)', '(N,8n+p+d)', '(N,9n+p+d)', &
         & '(N,10n+pd)', '(N,11n+pd)', '(N,12n+pd)', '(N,13n+pd)', & ! 73-144
         ! 145-218
         & '(N,14n+pd)', '(N,2p+d)  ', '(N,n+2p+d)', '(N,2n+2pd)', &
         & '(N,3n+2pd)', '(N,4n+2pd)', '(N,5n+2pd)', '(N,6n+2pd)', &
         & '(N,7n+2pd)', '(N,8n+2pd)', '(N,9n+2pd)', '(N,10n2pd)', &
         & '(N,11n2pd)', '(N,12n2pd)', '(N,He4)   ', '(N,2He4)  ', &
         & '(N,3He4)  ', '(N,n+He4) ', '(N,2n+He4)', '(N,3n+He4)', &
         & '(N,4n+He4)', '(N,5n+He4)', '(N,6n+He4)', '(N,7n+He4)', &
         & '(N,8n+He4)', '(N,9n+He4)', '(N,10nHe4)', '(N,11nHe4)', &
         & '(N,12nHe4)', '(N,13nHe4)', '(N,14nHe4)', '(N,n+2He4)', &
         & '(N,2n2He4)', '(N,p+He4) ', '(N,np+He4)', '(N,2npHe4)', &
         & '(N,3npHe4)', '(N,4npHe4)', '(N,5npHe4)', '(N,6npHe4)', &
         & '(N,7npHe4)', '(N,8npHe4)', '(N,9npHe4)', '(N,10npHe)', &
         & '(N,11npHe)', '(N,12npHe)', '(N,13npHe)', '(N,14npHe)', &
         & '(N,xn)    ', '(N,xp)    ', '(N,xn+yp) ', '(N,xn+d)  ', &
         & '(N,xn+2d) ', '(N,xn+p+d)', '(N,xn+2pd)', '(N,xn+p2d)', &
         & '(N,xn2p2d)', '(N,xn+t)  ', '(N,xn+2t) ', '(N,xn+p+t)', &
         & '(N,xn+2pt)', '(N,xn+d+t)', '(N,xn+pdt)', '(N,xn+He4)', &
         & '(N,xn2He4)', '(N,xnpHe4)', '(N,xn2pHe)', '(N,xn3pHe)', &
         & '(N,xndHe4)', '(N,t+x)   ', '(N,He3+x) ', '(N,pi- +x)', &
         & '(N,pi0 +x)', '(N,pi+ +x)'] ! 145-218

! ======================================================================

    integer(int32) :: ntt, ntet, nt2, nt3, nti
    real(real64)   :: te1, te2, dtt, se, dtdo, d2spec, d2spe
    common /d2sdto/ te1(200), te2(200), dtt(200), &
         & se(200), dtdo(200,10), d2spec(9,10,200), &
         & d2spe(14,10,200), ntt, ntet, nt2, nt3, nti(4)
    integer(int64) :: neq
    real(real64)   :: eestt, eestsq, aeqtot, aeqsq, zeqtot, zeqsq, &
         & aemin, aemax, eletot, elesq, elemin, elemax, &
         & eestrmn, eestrmx, zemin, zemax
    common /eqidat/  eestt, eestsq, aeqtot, aeqsq, zeqtot, zeqsq, &
         & aemin, aemax, eletot, elesq, elemin, elemax, &
         & eestrmn, eestrmx, zemin, zemax, neq
    real(real64)   :: estart, estarsq, estrmn, estrmx, atot, atsq, &
         & ammin, ammax, eltot, elsq, elmmin, elmmax, ztot, &
         & ztsq, zmmin, zmmax, bftot, bfsq, bfmin, bfmax
    common /fisda2/  estart, estarsq, estrmn, estrmx, atot, atsq, &
         & ammin, ammax, eltot, elsq, elmmin, elmmax, ztot, &
         & ztsq, zmmin, zmmax, bftot, bfsq, bfmin, bfmax
    integer(int32) :: no
    integer(int64) :: npreq
    real(real64)   :: epstt, epstsq, apqtot, apqsq, zpqtot, zpqsq, &
         & apmin, apmax, elptot, elpsq, elpmin, elpmax, &
         & epstrmn, epstrmx, zpmin, zpmax
    common /predat/  epstt, epstsq, apqtot, apqsq, zpqtot, zpqsq, &
         & apmin, apmax, elptot, elpsq, elpmin, elpmax, &
         & epstrmn, epstrmx, zpmin, zpmax, npreq
    integer(int64) :: nres
    real(real64)   :: erkt, erksq, artot, arsq, zrtot, zrsq, &
         & armin, armax, elrtot, elrsq, elrmin, elrmax, &
         & erkmn, erkmx, zrmin, zrmax
    common /resdat/  erkt, erksq, artot, arsq, zrtot, zrsq, &
         & armin, armax, elrtot, elrsq, elrmin, elrmax, &
         & erkmn, erkmx, zrmin, zrmax, nres
    real(real64)   :: spec, ang, chan, dadz
    common /result/  spec(9,200), ang(9,20), chan(218), dadz(351,151)
    integer(int64) :: nret
    real(real64)   :: arttot, artsq, artmin, artmax, zrttot, zrtsq, &
         & zrtmin, zrtmax, elrttot, elrtsq, elrtmin, &
         & elrtmax
    common /retdat/  arttot, artsq, artmin, artmax, zrttot, zrtsq, &
         & zrtmin, zrtmax, elrttot, elrtsq, elrtmin, &
         & elrtmax, nret
    integer(int32) :: istp
    common /stopr/   istp
    real(real64)   :: totke
    common /tkftot/  totke

! ======================================================================

    ! Require only one thread to enter output printing at a time
    !$OMP critical

    fl = dble(outData%limcc)
    fn = dble(outData%ncas)
    fe = dble(outData%intel)
    fneq = dble(neq)
    fnpreq = dble(npreq)
    fnres = dble(nres)
    fnret = dble(nret)
    fnfis = dble(outData%nfis)
    temp = fl
    if ( temp < div0Lim .and. temp > -div0Lim ) then
       temp = div0Lim
       write(gsmObj%io%message, 5000) "229"
       call gsmObj%io%print(4, 3, gsmObj%io%message)
    end if
    sigin = outData%sigom * fn / temp
    t0mev = proj%kinEnergy * thousand
!  KKG 09/17/04
    sigla = sigin   ! use the calculated MC cross section by default
    if (proj%numBaryons >= 1) then
       ! 'iii' id's a n, p, d, t, he3, or he4 particle (1-6, respectively)
       iii = proj%numProtons + proj%numBaryons
       if ( iii <= 6 .and. iii > 0 ) then
          sigla = gsmObj%sinvla (iii, targ%numBaryons, targ%numProtons, t0mev)
       endif
    endif
! Photon interaction:
!   KKG  10/13/04
    if ( fn < div0Lim .and. fn > -div0Lim ) then
       fn = div0Lim
       write(gsmObj%io%message, 5000) "217,218, 232, 234"
       call gsmObj%io%print(4, 3, gsmObj%io%message)
    end if
    if (proj%particleFlag == photonProjFlag .or. &
        & proj%particleFlag == bremsProjFlag) then
       if (proj%particleFlag == bremsProjFlag) then
!         eqqv = proj%brems%tEqv()/(fn*(proj%brems%tMax() - proj%brems%tMin()))
!          if ( proj%brems%tMax() < div0Lim .and. proj%brems%tMax() > -div0Lim ) then
!             call proj%brems%setTMax(div0Lim)
!             write(gsmObj%io%message, 5000) "217"
!             call gsmObj%io%print(4, 3, gsmObj%io%message)
!          end if
          eqqv = proj%brems%tEqv()/(fn*proj%brems%tMax())
          sigla = proj%brems%sxabs()/fn
          if ( eqqv < div0Lim .and. eqqv > -div0Lim ) then
             eqqv = div0Lim
             write(gsmObj%io%message, 5000) "220"
             call gsmObj%io%print(4, 3, gsmObj%io%message)
          end if
          sigeq = sigla/eqqv
          write (31, 999) eqqv, sigeq, sigla
          sigla = sigeq
       else
          sigla = photonEG%photocrosssection (t0mev, targ%numBaryons)
       endif
       test = 0.01d0
    else
       test = one
    endif
    write (31, 1000) sigla, sigin
    sigin = sigla
    outData%sigom = sigla*fl/fn
    sigel = outData%sigom*fe/temp
    siginn = sigin/fn
    dfis = zro
    dsigf = zro
    estarav = zro
    sigest = zro
    zav = zro
    aav = zro
    elav = zro
    sigz = zro
    siga = zro
    sigl = zro
    if (outData%sfu.ne.zro) then
       sfu1 = outData%sfu/fn
       sigfw = sfu1*sigin
       if (outData%nfis.ne.0) then
          fision = fnfis/fn
          dfis = sqrt(abs(fnfis))/fn
          sigfis = fision*sigin
          tkfbar = totke/fnfis
          dsigf = dfis*sigin
          estarav = estart/fnfis
          sigest = sqrt(abs(estarsq/fnfis - estarav**2))
          bfav = bftot/fnfis
          sigbf = sqrt(abs(bfsq/fnfis - bfav**2))
          zav = ztot/fnfis
          sigz = sqrt(abs(ztsq/fnfis - zav**2))
          aav = atot/fnfis
          siga = sqrt(abs(atsq/fnfis - aav**2))
          elav = eltot/fnfis
          sigl = sqrt(abs(elsq/fnfis - elav**2))
!         if (iz0 > 0) then
!           a0av = azro/dble(iz0)
!           el0av = elzro/dble(iz0)
!         endif
       endif
    endif
    if ( fnpreq < div0Lim .and. fnpreq > -div0Lim ) then
       fnpreq = div0Lim
       write(gsmObj%io%message, 5000) "272-279"
       call gsmObj%io%print(4, 3, gsmObj%io%message)
    end if
    epav = epstt/fnpreq
    zpqav = zpqtot/fnpreq
    apqav = apqtot/fnpreq
    elpav = elptot/fnpreq
    sigep = sqrt(abs(epstsq/fnpreq - epav**2))
    sigzpq = sqrt(abs(zpqsq/fnpreq - zpqav**2))
    sigapq = sqrt(abs(apqsq/fnpreq - apqav**2))
    siglp = sqrt(abs(elpsq/fnpreq - elpav**2))
    if (fneq > zro) then
       eeav = eestt/fneq
       zeqav = zeqtot/fneq
       aeqav = aeqtot/fneq
       eleav = eletot/fneq
       sigee = sqrt(abs(eestsq/fneq - eeav**2))
       sigzeq = sqrt(abs(zeqsq/fneq - zeqav**2))
       sigaeq = sqrt(abs(aeqsq/fneq - aeqav**2))
       sigle = sqrt(abs(elesq/fneq - eleav**2))
    endif
    if (fnres > zro) then
       erkav = erkt/fnres
       zrav = zrtot/fnres
       arav = artot/fnres
       elrav = elrtot/fnres
       sigerk = sqrt(abs(erksq/fnres - erkav**2))
       sigzr = sqrt(abs(zrsq/fnres - zrav**2))
       sigar = sqrt(abs(arsq/fnres - arav**2))
       siglr = sqrt(abs(elrsq/fnres - elrav**2))
    endif
    if (fnret > zro) then
       zrtav = zrttot/fnret
       artav = arttot/fnret
       elrtav = elrttot/fnret
       sigzrt = sqrt(abs(zrtsq/fnret - zrtav**2))
       sigart = sqrt(abs(artsq/fnret - artav**2))
       siglrt = sqrt(abs(elrtsq/fnret - elrtav**2))
    endif

    call fdate (ddate)
    write ( *, 1900) ddate
    write (31, 1900) ddate
    if (proj%particleFlag == nucleusProjFlag .or. &
        & proj%particleFlag == pionProjFlag) then
       if ( t0mev < 1000) then
          write (31, 1700) t0mev, proj%numProtons, proj%numBaryons, &
              & targ%numProtons, targ%numBaryons, outData%ncas, outData%intel, &
              & sigin, sigel
       else
          write (31, 1725) t0mev/1000, proj%numProtons, proj%numBaryons, &
              & targ%numProtons, targ%numBaryons, outData%ncas, &
              & outData%intel, sigin, sigel
       endif
    else
       if ( t0mev < 1000) then
          write (31, 1750) t0mev, proj%numProtons, proj%numBaryons, &
              & targ%numProtons, targ%numBaryons, outData%ncas, outData%intel, &
              & sigin, sigel
       else
          write (31, 1775) t0mev/1000, proj%numProtons, proj%numBaryons, &
              & targ%numProtons, targ%numBaryons, outData%ncas, &
              & outData%intel, sigin, sigel
       endif
    endif
      ! Displays reaction to user at end of calculation
    if ( t0mev < 1000 ) then
       ! Displays t0mev in units of MeV
       write ( *, 1800) t0mev, proj%numProtons, proj%numBaryons, &
           &  targ%numProtons, targ%numBaryons
    elseif ( t0mev < 1000000 ) then
       ! Displays t0mev in units of GeV
       write ( *, 1825) (t0mev/1000), proj%numProtons, proj%numBaryons, &
           & targ%numProtons, targ%numBaryons
    elseif ( t0mev < 1000000000 ) then
         ! Displays t0mev in units of TeV
       write ( *, 1850) (t0mev/1000000), proj%numProtons, proj%numBaryons, &
           & targ%numProtons, targ%numBaryons
    else
         ! Displays in units of MeV in scientific notation
       write ( *, 1875) t0mev, proj%numProtons, proj%numBaryons, &
           & targ%numProtons, targ%numBaryons
    endif

    if (npreq > 0) &
         & write (31, 2200) npreq, epav, sigep, epstrmn, epstrmx, &
         & zpqav, sigzpq, zpmin, zpmax, apqav, sigapq, &
         & apmin, apmax, elpav, siglp, elpmin, elpmax
    if (istp > zro) write (31, 2300) istp
    if (outData%ifermi > zro) write (31, 4800) outData%ifermi
    if (nret > 0) &
         & write (31, 2400) nret, zrtav, sigzrt, zrtmin, zrtmax, artav, &
         & sigart, artmin, artmax, elrtav, siglrt, &
         & elrtmin, elrtmax
    if (gsmObj%options%preeqOpts%excludePreeq == 0 .and. neq > 0) then
       write (31, 3100) neq, eeav, sigee, eestrmn, eestrmx, &
            & zeqav, sigzeq, zemin, zemax, aeqav, sigaeq, &
            & aemin, aemax, eleav, sigle, elemin, elemax
    endif
    if (nres > 0) &
         & write (31, 2600) nres, erkav, sigerk, erkmn, erkmx, &
         & zrav, sigzr, zrmin, zrmax, arav, sigar, &
         & armin, armax, elrav, siglr, elrmin, elrmax
    if (outData%sfu.ne.zro .and. outData%nfis == 0) write (31, 2100) sfu1, sigfw
    if (outData%nfis > 0) then
       write (31, 2500) outData%nfis, estarav, sigest, estrmn, estrmx, &
            & zav, sigz, zmmin, zmmax, aav, siga, &
            & ammin, ammax, elav, sigl, elmmin, elmmax, &
            & bfav, sigbf, bfmin, bfmax
       write (31, 4900) tkfbar
       write (31, 2000) fision, dfis, sigfis, dsigf
       if (outData%sfu.ne.zro) write (31, 2100) sfu1, sigfw
!       if (infis == 1) write (31, 2700) infis
!       if (infis > 1) write (31, 2800) infis
!       if (iz0 == 1) then
!         write (31, 3000) iz0, a0av, el0av
!       elseif (iz0 > 1) then
!         write (31, 2900) iz0, a0av, el0av
!       endif
    endif
!  Print particle-multiplicity table:
    if (output%multiplicities > 0 .or. &
         & output%energySpectra > 0 .or. &
         & output%doubleDiffSpectra > 0. .or. &
         & output%nuclideCrossSection > 0 .or. &
         & output%angularSpectra > 0) then
       sigg = sigin
       fnn = fn
       if (output%fisOnly) then
!  Multiplicity for fissioning nuclei only:
          sigg = sigfis
          fnn = fnfis
       endif
       if (output%multiplicities > 0 .or. &
            & output%energySpectra > 0 .or. &
            & output%doubleDiffSpectra > 0. &
            & .or. output%angularSpectra > 0) then
          do ipar = 1,9
             call gsmObj%prtmult (output, outData, ipar, fnn, sigg, nt2, nt3)
          end do
       endif
    endif
!
!   Print out cross sections for various particle-emission channels:
!
    if (output%channelCrossSection > 0) then
       fact = siginn
       if (proj%particleFlag == nucleusProjFlag .or. &
           & proj%particleFlag == pionProjFlag) then
          write (31, 3200)
       else
          write (31, 3250)
       endif
       m = 1
10     if (m <= 192) then
          if (fact*chan(m) >= test) then
             ef = chan(m)*fact
             def = sqrt(abs(chan(m)))*fact
             if (m < 192) then
                do in = m+1,192
                   if (fact*chan(in) >= test) then
                      n = in
                      efp = chan(n)*fact
                      defp = sqrt(abs(chan(n)))*fact
                      if (proj%particleFlag == nucleusProjFlag .or. &
                          & proj%particleFlag == pionProjFlag) then
                         write (31, 3400) ch(m), ef, def, ch(n), efp, defp
                      else
                         dummc = ch(m)
                         dummc(2:2) = 'g'
                         gch(m) = dummc
                         dummc = ch(n)
                         dummc(2:2) = 'g'
                         gch(n) = dummc
                         efmu = thousand*ef
                         defmu = thousand*def
                         efpmu = thousand*efp
                         defpmu = thousand*defp
                         write (31, 3450) gch(m), efmu, defmu, gch(n), efpmu, &
                              & defpmu
                      endif
                      m = n + 1
                      go to 10
                   endif
                end do
             endif
             write (31, 3500) ch(m), ef, def
          else
             m = m + 1
             go to 10
          endif
       endif
       write (31, 3300)
       do ii = 1, 13
          ij = 192 + 2*ii - 1
          ik = 192 + 2*ii
          ef = chan(ij)*fact
          def = sqrt(abs(chan(ij)))*fact
          efp = chan(ik)*fact
          defp = sqrt(abs(chan(ik)))*fact
          if (ef >= test .or. efp >= test) then
             if (proj%particleFlag == nucleusProjFlag .or. &
                 & proj%particleFlag == pionProjFlag) then
                write (31, 3400) ch(ij), ef, def, ch(ik), efp, defp
             else
                dummc = ch(ij)
                dummc(2:2) = 'g'
                gch(ij) = dummc
                dummc = ch(ik)
                dummc(2:2) = 'g'
                gch(ik) = dummc
                efmu = thousand*ef
                defmu = thousand*def
                efpmu = thousand*efp
                defpmu = thousand*defp
                write (31, 3450) gch(ij), efmu, defmu, gch(ik), efpmu, &
                     & defpmu
             endif
          endif
       end do
    endif
!   End of channelCrossSection loop ^
!
!   Print out isotope formation cross sections:
!
    if (output%nuclideCrossSection > 0) then
       abeg = targ%numBaryons + fiv
       zbeg = targ%numProtons + fiv
       izmax = nint(zbeg)
       izmax = min(izmax, 148)
       iamax = nint(abeg) + proj%numBaryons
       iamax = min(iamax, 348)
       do iz = 1,izmax + 1
          z(iz) = max (-one, zbeg - dble(iz-1))
          dasum(iz) = zro
          do ia = 1,iamax
             ar(ia) = max(abeg - dble(ia-1), zro)
             dasum(iz) = dasum(iz) + dadz(ia,iz)
          end do
          prtz(iz) = z(iz) >= zro .and. dasum(iz) > zro
       end do
       write (31, 3700)
       lprm = (izmax + 3)/3
       lprm = max(lprm, 1)
       do lpr = 1,lprm
          iz1 = 3*lpr - 2
          iz2 = 3*lpr - 1
          iz3 = 3*lpr
          prtz1 = prtz(iz3)
          prtz2 = .not.prtz(iz3) .and. prtz(iz2)
          prtz3 = (.not.prtz(iz2) .and. .not.prtz(iz3)) .and. prtz(iz1)
          if (prtz1) then
             write (31, 3800) z(iz1), z(iz2), z(iz3)
          elseif (prtz2) then
             write (31, 3900) z(iz1), z(iz2)
          elseif (prtz3) then
             write (31, 4000) z(iz1)
          endif
          if ( fn < div0Lim .and. fn > -div0Lim ) then
             fn = div0Lim
             write(gsmObj%io%message, 5000) "487"
             call gsmObj%io%print(4, 3, gsmObj%io%message)
          end if
          faca = sigin/fn
          ppt = zro
          do k = 1,iamax
             y1 = zro
             y2 = zro
             y3 = zro
             y1 = dadz(k,iz1)*faca
             dy1 = sqrt(abs(dadz(k,iz1)))*faca
             y2 = dadz(k,iz2)*faca
             dy2 = sqrt(abs(dadz(k,iz2)))*faca
             y3 = dadz(k,iz3)*faca
             dy3 = sqrt(abs(dadz(k,iz3)))*faca
             printit = y1 > zro .or. y2 > zro .or. y3 > zro
             if (printit) then
!  KKG 11/15/04
                if (ar(k) > zro .and. ar(k) >= z(iz3)) then
                   iaa = nint(ar(k))
                   prtz1 = prtz(iz3)
                   prtz2 = .not.prtz(iz3) .and. prtz(iz2)
                   prtz3 = (.not.prtz(iz2) .and. .not.prtz(iz3)) .and. &
                        & prtz(iz1)
                   if (prtz1) then
                      ppt = ppt + one
                      write (31, 4100) iaa, y1, dy1, y2, dy2, y3, dy3
                   elseif (prtz2) then
                      ppt = ppt + one
                      write (31, 4200) iaa, y1, dy1, y2, dy2
                   elseif (prtz3) then
                      ppt = ppt + one
                      write (31, 4300) iaa, y1, dy1
                   endif
                endif
             endif
          end do
          if (ppt > zro) then
             ipt = nint(ppt)
             ys1  = dasum(iz1)*faca
             dys1 = sqrt(abs(dasum(iz1)))*faca
             ys2  = dasum(iz2)*faca
             dys2 = sqrt(abs(dasum(iz2)))*faca
             ys3  = dasum(iz3)*faca
             dys3 = sqrt(abs(dasum(iz3)))*faca
             if (ys3 > zro) then
                write (31, 4400) ipt, ys1, dys1, ys2, dys2, ys3, dys3
             elseif (ys2 > zro) then
                write (31, 4500) ipt, ys1, dys1, ys2, dys2
             elseif (ys1 > zro) then
                write (31, 4600) ipt, ys1, dys1
             endif
          endif
       end do
       write (31, 4700)
       ip = nint(abeg)
       ipz = nint(zbeg)
       do i=1,ip
          iar(i) = ip - i + 1
       end do
       do i=1,ipz
          izr(i) = ipz - i + 1
       end do
       ss = faca
       write (31, 1100)
       yys   = zro
       atks  = zro
       datks = zro
       npt = 0
       do i = 1,ip
          yy = dadz(i,150)*ss
          dyy = sqrt(abs(dadz(i,150)))*ss
          yys = yys + dadz(i,150)
          if (dadz(i,150) > zro) then
             atk   = dadz(i,151)/dadz(i,150)
             atks  = atks + dadz(i,151)
             datk  = sqrt(abs(dadz(i,149)/dadz(i,150) - atk**2))
             datks = datks + dadz(i,149)
          else
             atk  = zro
             datk = zro
          endif
          printit = yy > zro
          if (printit) then
             npt = npt + 1
             write (31, 1200) iar(i), yy, dyy, atk, datk
          endif
       end do
       dyys = sqrt(abs(yys))*ss
       if (yys > zro) then
          atks  = atks/yys
          datks = sqrt(abs(datks/yys - atks**2))
       endif
       yys = yys*ss
       write (31, 1500) npt, yys, dyys, atks, datks
       write (31, 1300)
       yys = zro
       atks  = zro
       datks = zro
       npt = 0
       do i = 1,ipz+1
          yy = dadz(351,i)*ss
          dyy = sqrt(abs(dadz(351,i)))*ss
          yys = yys + dadz(351,i)
          if (dadz(351,i) > zro) then
             atk   = dadz(350,i)/dadz(351,i)
             atks  = atks + dadz(350,i)
             datk  = sqrt(abs(dadz(349,i)/dadz(351,i) - atk**2))
             datks = datks + dadz(349,i)
          else
             atk  = zro
             datk = zro
          endif
          printit = yy > zro
          if (printit) then
             npt = npt + 1
             write (31, 1400) izr(i), yy, dyy, atk, datk
          endif
       end do
       dyys = sqrt(abs(yys))*ss
       if (yys > zro) then
          atks  = atks/yys
          datks = sqrt(abs(datks/yys - atks**2))
       endif
       yys = yys*ss
       write (31, 1600) npt, yys, dyys, atks, datks
    endif
!   End of nuclideCrossSection loop ^
!   Print forward/backward isotope production correlations:
    if (output%nuclideCrossSection >= 2) &
        & call gsmObj%prtdadz (targ%numBaryons, targ%numProtons, proj%numBaryons, sigin, fn)
    if (output%nuclideCrossSection == 3) &
        & call gsmObj%prrdis (targ%numBaryons, targ%numProtons, proj%numBaryons, fn)
    if (output%nuclideCrossSection == 3 .and. outData%nfis.ne.0) &
        & call gsmObj%propan (fnfis)
    if (output%nuclideCrossSection == 3) &
        & call gsmObj%pdisnm (fn)
!
!   Print out angular distributions and/or spectra:
!
    if (output%energySpectra > 0 .or. &
         & output%doubleDiffSpectra > 0 .or. &
         & output%angularSpectra > 0) then
       if (output%angularSpectra > 0) then
          do m = 1,20
             om(m) = output%deltaTheta/two + dble(m-1)*output%deltaTheta
             tetmin = dble(m-1)*output%deltaTheta*degreeToRadian
             tetmax = dble(m)*output%deltaTheta*degreeToRadian
             dom(m) = (cos(tetmin) - cos(tetmax))*twpi
             temp = fl*dom(m)
             if ( temp < div0Lim .and. temp > -div0Lim ) then
                temp = div0Lim
                write(gsmObj%io%message, 5000) "629"
                call gsmObj%io%print(4, 3, gsmObj%io%message)
             end if
             const(m) = outData%sigom/(temp)
          end do
       endif
       if (output%energySpectra > 0 .or. output%doubleDiffSpectra > 0) then
          do m = 1, ntt
             temp = fl*dtt(m)
             if ( temp < div0Lim .and. temp > -div0Lim ) then
                temp = div0Lim
                write(gsmObj%io%message, 5000) "636"
                call gsmObj%io%print(4, 3, gsmObj%io%message)
             end if
             se(m) = outData%sigom/(temp)
          end do
          if (output%doubleDiffSpectra > 0) then
             do j = 1,ntt
                do i = 1,ntet
                   temp = twpi*(cos(output%angleBins(i)%lowerBound*degreeToRadian) - &
                        & cos(output%angleBins(i)%upperBound*degreeToRadian))
                   if ( temp < div0Lim .and. temp > -div0Lim ) then
                      temp = div0Lim
                      write(gsmObj%io%message, 5000) "643"
                      call gsmObj%io%print(4, 3, gsmObj%io%message)
                   end if
                   dtdo(j,i) = se(j)/(temp)
                end do
             end do
          endif
       endif
       do i = 1,ntet
          temp = fl*twpi*(cos(output%angleBins(i)%lowerBound*degreeToRadian) - &
               & cos(output%angleBins(i)%upperBound*degreeToRadian))
          if ( temp < div0Lim .and. temp > -div0Lim ) then
             temp = div0Lim
             write(gsmObj%io%message, 5000) "651"
             call gsmObj%io%print(4, 3, gsmObj%io%message)
          end if
          doo(i) = outData%sigom/(temp)
       end do
       if (output%energySpectra > 0 .or. output%doubleDiffSpectra > 0) then
90        s1 = spec(1,ntt) + spec(2,ntt) + spec(3,ntt) + spec(4,ntt) + &
               & spec(5,ntt) + spec(6,ntt) + spec(7,ntt) + spec(8,ntt) + &
               & spec(9,ntt)
          if (s1 == zro) then
             ntt = ntt - 1
             go to 90
          endif
       endif
       ejectileTally: do ic = output%minEjectileRange, output%maxejectileRange
          if(.not.output%spectraEjectiles(ic)) cycle ejectileTally
!         goahead = spec(ic,nt3) > zro .or. d2spec(ic,
          if (spec(ic,nt3) > zro .or. ang(ic,20) > zro) then
             if (spec(ic,nt3) > zro) write (31, 3600) par2(ic)
             call gsmObj%prtdist(output, ic, om, const, doo, siginn)
          endif
       end do ejectileTally
    endif
! LMK 06/2012
    if(output%printPISA)  call gsmObj%pisaprint(output, sigin, outData%ncas)

    !$OMP end critical
!
    return

! ======================================================================
999 format (/2x,'Number of equivalent gamma quanta = ',1pe13.6/ &
         & 2x,'Inelasic cross section per eqqv   = ',e13.6/ &
         & 2x,'Averaged absorption cross section = ',e13.6/ &
         & 2x,'Results are normalized to eqqv.' )
1000 format (/3x,'Inelastic cross section used here = ',f7.2,' mb'/ &
          & 1x,'Monte Carlo inelastic cross section = ',f7.2,' mb'/)
1100 format (/'Mass yield [mb] and the mean and variance of the ', &
          & 'kinetic energy [MeV]'/1x,'of residual nuclei:')
1200 format (1x,'A =',i4,1x,1pe9.3,' +/- ',e8.2,2x,e9.3,' +/- ',e8.2)
1300 format (/'Charge yield [mb] and the mean and variance of the ', &
          & ' kinetic energy [MeV]'/1x,'of residual nuclei:')
1400 format (1x,'Z =',i3,1x,1pe9.3,' +/- ',e8.2,2x,e9.3,' +/- ',e8.2)
1500 format (1x,'S =',i4,1x,1pe9.3,' +/- ',e8.2,2x,e9.3,' +/- ',e8.2)
1600 format (1x,'S =',i3,1x,1pe9.3,' +/- ',e8.2,2x,e9.3,' +/- ',e8.2)
1700 format (/15x,f6.1,' MeV (Z = ',i2,', A = ',i1,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')' &
          & //1x,'Number of inelastic interactions = ',i8,',' &
          & /1x,'Number of elastic interactions   = ',i8,',' &
          & //1x,'Reaction cross section = ',f7.2,' mb,', &
          & 1x,'Elastic cross section = ',f7.2,' mb.')
1725 format (/15x,f6.1,' GeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')' &
          & //1x,'Number of inelastic interactions = ',i8,',' &
          & /1x,'Number of elastic interactions   = ',i8,',' &
          & //1x,'Reaction cross section = ',f7.2,' mb,', &
          & 1x,'Elastic cross section = ',f7.2,' mb.')
1750 format (/15x,f6.1,' MeV (Z = ',i2,', A = ',i1,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')' &
          & //1x,'Number of inelastic interactions = ',i12,',' &
          & /1x,'Number of elastic interactions   = ',i12,',' &
          & //1x,'Reaction cross section = ',f7.2,' mb,', &
          & 1x,'Elastic cross section = ',f7.2,' mb.')
1775 format (/15x,f6.1,' GeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')' &
          & //1x,'Number of inelastic interactions = ',i12,',' &
          & /1x,'Number of elastic interactions   = ',i12,',' &
          & //1x,'Reaction cross section = ',f7.2,' mb,', &
          & 1x,'Elastic cross section = ',f7.2,' mb.')
1800 format (/15x,f6.1,' MeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')')
1825 format (/15x,f6.1,' GeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')')
1850 format (/15x,f6.1,' TeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')')
1875 format (/15x,es9.2,' MeV (Z = ',i3,', A = ',i3,') + (Z = ',f3.0, &
          & ', A = ',f4.0,')')
1900 format (5x,a24)
2000 format (/15x,'Direct Monte Carlo Simulation Method:'/ &
          & 1x,'Fissility = ',f7.4,' +/- ',f7.4,','/1x,'Fission ', &
          & 'cross section = ',1pe11.5,' +/- ',e8.2,' mb.')
2100 format (/15x,'Statistical Weight Functions Method:'/ &
          & 1x,'Fissility = ',f7.4,','/1x,'Fission cross section = ', &
          & 1pe11.5,' mb.')
2200 format (/2x,'The mean excitation energy, charge, mass, and ', &
          & 'angular momentum'/2x,'of the',i9,' nuclei after the ', &
          & /2x,'cascade and before preequilibrium decay are:'/2x, &
          & 'E*av =', f6.1,' +/-',f5.1, &
          & ' MeV;  E*min =',f6.1,';  E*max =',f6.1, &
          & /2x,' Zav = ',f5.1,' +/- ',f4.1,';       Zmin = ',f4.0, &
          & ';    Zmax = ',f4.0/2x,' Aav = ',f5.1,' +/- ',f4.1,';',7x, &
          & 'Amin = ',f4.0,';    Amax = ',f4.0 &
          & /2x,' Lav =  ',f4.1,' +/- ',f4.1,' h-bar; Lmin = ',f4.0, &
          & ';    Lmax = ',f4.0)
2300 format (/2x,'The code entered PRECOF with Z < 3 or A < 5 ', &
          & i7,' times.')
2400 format (/2x,'The mean charge, mass, and angular momentum '/2x, &
          & 'of the ',i7,' residual nuclei with less than ', &
          & /2x,'3 MeV of excitation energy after the cascade are:' &
          & /2x,' Zav = ',f5.1,' +/-',f5.1,';       Zmin = ',f4.0, &
          & ';   Zmax = ',f4.0/2x,' Aav = ',f5.1,' +/-',f5.1,';',7x, &
          & 'Amin = ',f4.0,';   Amax = ',f4.0 &
          & /2x,' Lav =  ',f4.1,' +/-',f5.1,' h-bar; Lmin = ',f4.0, &
          & ';   Lmax = ',f4.0)
2500 format (/2x,'The mean excitation energy, charge, mass, ', &
          & 'angular momentum, and '/2x,'fission barrier height of ', &
          & 'the ',i7,' fissioning nuclei are:'/2x,'E*av =',f6.1, &
          & ' +/-',f5.1,' MeV; E*min =',f6.1,'; E*max = ',f6.1, &
          & /2x,' Zav = ',f5.1,' +/-',f4.1,';        Zmin = ',f4.0, &
          & ';  Zmax = ',f4.0/2x,' Aav = ',f5.1,' +/-',f4.1,';',8x, &
          & 'Amin = ',f4.0,';  Amax = ',f4.0 &
          & /2x,' Lav =  ',f4.1,' +/-',f4.1,' h-bar;  Lmin = ',f4.0, &
          & ';  Lmax = ',f4.0 &
          & /2x,'Bfav =  ',f4.1,' +/-',f4.1,' MeV;   Bfmin = ',f4.1, &
          & '; Bfmax = ',f4.1)
2600 format (/2x,'The mean kinetic energy, charge, mass, and ', &
          & 'angular momentum '/2x,'of ', &
          & 'the ',i7,' residual nuclei are:'/2x,'Ekav = ',f5.1, &
          & ' +/-',f5.1,' MeV;  Ekmin = ',f4.1,';  Ekmax =',f6.1, &
          & /2x,' Zav = ',f5.1,' +/-',f5.1,';       Zmin = ',f4.0, &
          & ';   Zmax = ',f4.0/2x,' Aav = ',f5.1,' +/-',f5.1,';',7x, &
          & 'Amin = ',f4.0,';   Amax = ',f4.0 &
          & /2x,' Lav =  ',f4.1,' +/-',f5.1,' h-bar; Lmin = ',f4.0, &
          & ';   Lmax = ',f4.0)
!2700 format (/1x,i7,' nucleus with delta-Z > 29, delta-A > 59, or ', &
!          & 'L > 99 fissioned.')
! 2800 format (/1x,i7,' nuclei with delta-Z > 29, delta-A > 59, or ', &
!           & 'L > 99 fissioned.')
!2900 format (/1x,i5,' nuclei with Z > Zinit fissioned; their average ', &
!          & 'A is ',f5.1/2x,'their average L is ',f4.1,'.')
!3000 format (/1x,i5,' nucleus with Z > Zinit fissioned; with ', &
!          & 'A = ',f5.1,' and L = ',f4.1,'.')
3100 format (/2x,'The mean excitation energy, charge, mass, and ', &
          & 'angular momentum'/2x,'of the ',i7,' nuclei after ', &
          & 'preequilibrium'/2x,'decay and before the start of ', &
          & 'statistical decay are:'/2x,'E*av =',f6.1,' +/- ',f5.1, &
          & ' MeV; E*min = ',f5.1,';  E*max =',f6.1, &
          & /2x,' Zav = ',f5.1,' +/- ',f4.1,';       Zmin = ',f4.0, &
          & ';   Zmax = ',f4.0/2x,' Aav = ',f5.1,' +/- ',f4.1,';',7x, &
          & 'Amin = ',f4.0,';   Amax = ',f4.0 &
          & /2x,' Lav =  ',f4.1,' +/- ',f4.1,' h-bar; Lmin = ',f4.0, &
          & ';   Lmax = ',f4.0)
3200 format (/1x, 'Yields of different channels (with > 1 mb):'/)
3250 format (/1x, 'Yields of different channels (with > 10 micro-b):'/)
3300 format (/1x, 'Yields of several summed channels:'/)
3400 format (1x,a,': ',f7.2,' +/- ',f5.2,' mb,',4x,a,': ',f7.2, &
          & ' +/- ',f5.2,' mb,')
3450 format (1x,a,': ',f7.1,' +/- ',f5.1,' mub,',4x,a,': ',f7.1, &
          & ' +/- ',f5.1,' mub,')
3500 format (1x,a,': ',f7.2,' +/- ',f5.2,' mb.')
3600 format (/1x,'********************************** ',a,' *********', &
          & '************************')
3700 format (/1x,'*************** Nuclide yields [mb]  (zero values ', &
          & 'suppressed) *****************')
3800 format (/17x,'Z = ',f4.0,15x,'Z = ',f4.0,15x,'Z = ',f4.0)
3900 format (/17x,'Z = ',f4.0,15x,'Z = ',f4.0)
4000 format (/17x,'Z = ',f4.0)
4100 format (1x,'A =',i4,3(1x,1pe9.3,' +/- ',e8.2)) !
4200 format (1x,'A =',i4,2(1x,1pe9.3,' +/- ',e8.2))
4300 format (1x,'A =',i4,1(1x,1pe9.3,' +/- ',e8.2))
4400 format (1x,'S =',i4,3(1x,1pe9.3,' +/- ',e8.2))
4500 format (1x,'S =',i4,2(1x,1pe9.3,' +/- ',e8.2))
4600 format (1x,'S =',i4,1(1x,1pe9.3,' +/- ',e8.2))
4700 format (/1x,'End of nuclide yields.')
4800 format (/1x,'The program called Fermi breakup ',i8,' times.')
4900 format (/1x,'The mean total fission product kinetic energy ', &
          & 'after neutron emission is ',f6.2,' MeV.')
5000 format("Divide by zero error prevented in 'typeout.f90', line(s) ", A)
! ======================================================================
  end subroutine typeout


	SUBROUTINE PDS_VLDT  ( flgdtm, lasttm, idt, b13_25, i13_25,
     +			       iret )
C************************************************************************
C* PDS_VLDT								*
C*									*
C* This subroutine uses the full GEMPAK time (YYYYMMDD/HHHHFhhhmm) for	*
C* grids to set PDS bytes 13 through 25.				*
C*									*
C* Note that the input date must have a 4-digit year.			*
C*									*
C* PDS_VLDT  ( FLGDTM, LASTTM, IDT, B13_25, I13_25, IRET )		*
C*									*
C* Input parameters:							*
C*	FLGDTM (2)	CHAR*		GEMPAK grid times		*
C*	LASTTM		CHAR*		Last grid time			*
C*	IDT		INTEGER		Time interval from parm (hours) *
C*									*
C* Output parameters:							*
C*	B13_25 (13)	CHAR*1		PDS byte values 13--25		*
C*	I13_25 (13)	INTEGER		Integer value of bytes 13--25	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-89 = cannot handle dual times	*
C*					-90 = 4-digit year required	*
C*					-91 = forecast must be in hours *
C*					-97 = fhr not dvsble by 3, 6, 12*
C*					-98 = idt not dvsble by 3, 6, 12*
C**									*
C* Log:									*
C* K. Brill/HPC		 7/99						*
C* K. Brill/HPC		01/06	Allow time units 3, 6, 12 (PDS byte 18) *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	CHARACTER*(*)	flgdtm (2), lasttm
	CHARACTER*1	b13_25 (13)
	INTEGER		i13_25 (13)
C*
	INTEGER		intdtm (3)
	CHARACTER*1	ctype
	CHARACTER*6	chm
	CHARACTER*20	hlddtm
C------------------------------------------------------------------------
	iret = 0
	DO i = 1, 13
	    i13_25 (i) = 255
	    b13_25 (i) = CHAR (255)
	END DO
C*
	IF ( flgdtm (2) .ne. ' ' ) THEN
	    iret = -89
	    RETURN
	END IF
	islash = INDEX ( flgdtm (1), '/' )
        IF ( islash .ne. 9 ) THEN
	    iret = -90
	    RETURN
	END IF
C*
	hlddtm = flgdtm (1) (3: )
	CALL GFULTM ( flgdtm (1), lasttm, hlddtm, ier )
	CALL TG_CTOI ( hlddtm, intdtm, ier )
	CALL TG_CFTM ( intdtm (3), ctype, chm, ier )
	CALL ST_LSTR ( chm, lng, ier )
	IF ( lng .gt. 3 ) THEN
	    iret = -91
	    RETURN
	END IF
C
C*	Split the GEMPAK time into integers.
C
	CALL ST_NUMB ( flgdtm (1) (1:2), icy, ier )
	iyr = intdtm (1) / 10000
	IF ( iyr .eq. 0 ) THEN
	    iyr = 100
	ELSE
	    icy = icy + 1
	END IF
	imh = MOD ( ( intdtm (1) / 100 ), 100 )
        idy = MOD ( intdtm (1), 100 )
	ihr = intdtm (2) / 100
	imn = MOD ( intdtm (2), 100 )
	CALL ST_NUMB ( chm, ifh, ier )
	mhr = 0
	i18 = 9
	jfh = ifh
	DO WHILE ( jfh .gt. 255 .and. i18 .lt. 12 )
	    i18 = i18 + 1
	    mhr = mhr + 3
	    IF ( MOD ( ifh, mhr ) .eq. 0 ) THEN
		jfh = ifh / mhr
	    END IF
	END DO
	IF ( jfh .gt. 255 ) THEN
	    iret = -97
	    RETURN
	END IF
	ifh = jfh
	IF ( mhr .ne. 0 ) THEN
	    IF ( MOD ( idt, mhr ) .ne. 0 ) THEN
		iret = -98
		RETURN
	    END IF
	    idt = idt / mhr
	ELSE
	    i18 = 1
	END IF
C
C*	Start assigning output integers.
C
	i13_25 (1) = iyr
	i13_25 (2) = imh
	i13_25 (3) = idy
	i13_25 (4) = ihr
	i13_25 (5) = imn
	i13_25 (6) = i18
	IF ( idt .le. 0 ) THEN
	    i13_25 (7) = ifh
	    i13_25 (8) = 0
	    i13_25 (9) = 0
	ELSE
	    i13_25 (7) = ifh - idt
	    i13_25 (8) = ifh
	    i13_25 (9) = 4
	END IF
	i13_25 (10) = 0
	i13_25 (11) = 0
	i13_25 (12) = 0
	i13_25 (13) = icy
	DO i = 1, 13
	    b13_25 (i) = CHAR ( i13_25 (i) )
	END DO
C*
	RETURN
	END


MODULE ED_BATH
  USE SF_CONSTANTS, only: zero
  USE SF_IOTOOLS, only:free_unit,reg,file_length,txtfy
  USE SF_LINALG, only: eye,inv
  USE SF_MISC, only: assert_shape
  USE ED_INPUT_VARS
  USE ED_VARS_GLOBAL
  USE ED_AUX_FUNX
  implicit none

  private

  !##################################################################
  !
  !     USER BATH ROUTINES:
  !
  !##################################################################
  !explicit symmetries:
  interface break_symmetry_bath
     module procedure break_symmetry_bath_site
     module procedure break_symmetry_bath_lattice
  end interface break_symmetry_bath
  !
  interface spin_symmetrize_bath
     module procedure spin_symmetrize_bath_site
     module procedure spin_symmetrize_bath_lattice
  end interface spin_symmetrize_bath
  !
  interface ph_symmetrize_bath
     module procedure ph_symmetrize_bath_site
     module procedure ph_symmetrize_bath_lattice
  end interface ph_symmetrize_bath
  !
  interface ph_trans_bath
     module procedure ph_trans_bath_site
     module procedure ph_trans_bath_lattice
  end interface ph_trans_bath
  !
  interface enforce_normal_bath
     module procedure enforce_normal_bath_site
     module procedure enforce_normal_bath_lattice
  end interface enforce_normal_bath

  public :: get_bath_dimension
  public :: check_bath_dimension
  public :: break_symmetry_bath
  public :: spin_symmetrize_bath
  public :: ph_symmetrize_bath
  public :: ph_trans_bath
  public :: enforce_normal_bath

  !##################################################################
  !
  !     DMFT BATH ROUTINES:
  !
  !##################################################################
  !PUBLIC   = transparent to the final user
  !INTERNAL = opaque to the user but available for internal use in the code.
  !
  !DMFT BATH procedures:
  public :: allocate_dmft_bath               !INTERNAL (for effective_bath)
  public :: deallocate_dmft_bath             !INTERNAL (for effective_bath)
  public :: init_dmft_bath                   !INTERNAL (for effective_bath)
  public :: write_dmft_bath                  !INTERNAL (for effective_bath)
  public :: save_dmft_bath                   !INTERNAL (for effective_bath)
  public :: set_dmft_bath                    !INTERNAL (for effective_bath)
  public :: get_dmft_bath                    !INTERNAL (for effective_bath)

contains

  !##################################################################
  !
  !     USER BATH ROUTINES:
  !
  !##################################################################
  !+-------------------------------------------------------------------+
  !PURPOSE  : Inquire the correct bath size to allocate the
  ! the bath array in the calling program.
  !
  ! Get size of each dimension of the component array.
  ! The Result is an rank 1 integer array Ndim with dimension:
  ! 3 for get_component_size_bath
  ! 2 for get_spin_component_size_bath & get_orb_component_size_bath
  ! 1 for get_spin_orb_component_size_bath
  !+-------------------------------------------------------------------+
  function get_bath_dimension(Hloc_nn,ispin_) result(bath_size)
    complex(8),optional,intent(in) :: Hloc_nn(:,:,:,:)
    integer,optional               :: ispin_
    integer                        :: bath_size,ndx,ispin,iorb,jspin,jorb,io,jo
    complex(8),allocatable         :: Hloc(:,:,:,:)
    !
    select case(bath_type)
    case default
       !( e [Nspin][Norb][Nbath] + v [Nspin][Norb][Nbath] )
       bath_size = Norb*Nbath + Norb*Nbath
       if(.not.present(ispin_))bath_size=Nspin*bath_size
    case('hybrid')
       !(e [Nspin][1][Nbath] + v [Nspin][Norb][Nbath] )
       bath_size = Nbath + Norb*Nbath
       if(.not.present(ispin_))bath_size=Nspin*bath_size
    end select
  end function get_bath_dimension

  !##################################################################
  !
  !     USER BATH PREDEFINED SYMMETRIES:
  !
  !##################################################################

  !+-------------------------------------------------------------------+
  !PURPOSE  : given a bath array apply a specific transformation or
  ! impose a given symmetry:
  ! - break spin symmetry by applying a symmetry breaking field
  ! - given a bath array set both spin components to have
  !    the same bath, i.e. impose non-magnetic solution
  ! - given a bath array enforces the particle-hole symmetry
  !    by setting the positive energies in modulo identical to the negative
  !    ones.
  ! - given a bath enforce normal (i.e. non superconducting) solution
  ! - given a dmft bath pull/push the components W^{ss'}_\a(l) of the Hybridization
  !    matrix
  !+-------------------------------------------------------------------+
  subroutine break_symmetry_bath_site(bath_,field,sign,save)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    real(8)                :: field
    real(8)                :: sign
    logical,optional       :: save
    logical                :: save_
    save_=.true.;if(present(save))save_=save
    call allocate_dmft_bath(dmft_bath_)
    call set_dmft_bath(bath_,dmft_bath_)
    dmft_bath_%e(1,:,:)    =dmft_bath_%e(1,:,:)      + sign*field
    dmft_bath_%e(Nspin,:,:)=dmft_bath_%e(Nspin,:,:)  - sign*field
    if(save_)call save_dmft_bath(dmft_bath_)
    call get_dmft_bath(dmft_bath_,bath_)
    call deallocate_dmft_bath(dmft_bath_)
  end subroutine break_symmetry_bath_site
  subroutine break_symmetry_bath_lattice(bath_,field,sign,save)
    real(8),dimension(:,:) :: bath_
    real(8)                :: field
    real(8)                :: sign
    logical,optional       :: save
    logical                :: save_
    integer                :: Nsites,ilat
    save_=.true.;if(present(save))save_=save
    Nsites=size(bath_,1)
    do ilat=1,Nsites
       ed_file_suffix="_site"//reg(txtfy(ilat,Npad=4))
       call break_symmetry_bath_site(bath_(ilat,:),field,sign,save_)
    enddo
    ed_file_suffix=""
  end subroutine break_symmetry_bath_lattice

     !---------------------------------------------------------!

  subroutine spin_symmetrize_bath_site(bath_,save)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    logical,optional       :: save
    logical                :: save_
    save_=.true.;if(present(save))save_=save
    if(Nspin==1)then
       write(LOGfile,"(A)")"spin_symmetrize_bath: Nspin=1 nothing to symmetrize"
       return
    endif
    !
    call allocate_dmft_bath(dmft_bath_)
    call set_dmft_bath(bath_,dmft_bath_)
    !
    if(save_)call save_dmft_bath(dmft_bath_)
    call get_dmft_bath(dmft_bath_,bath_)
    call deallocate_dmft_bath(dmft_bath_)
  end subroutine spin_symmetrize_bath_site
  subroutine spin_symmetrize_bath_lattice(bath_,save)
    real(8),dimension(:,:) :: bath_
    logical,optional       :: save
    logical                :: save_
    integer                :: Nsites,ilat
    save_=.true.;if(present(save))save_=save
    Nsites=size(bath_,1)
    do ilat=1,Nsites
       ed_file_suffix="_site"//reg(txtfy(ilat,Npad=4))
       call spin_symmetrize_bath_site(bath_(ilat,:),save_)
    enddo
    ed_file_suffix=""
  end subroutine spin_symmetrize_bath_lattice

  !---------------------------------------------------------!

  subroutine ph_symmetrize_bath_site(bath_,save)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    integer                :: i
    logical,optional       :: save
    logical                :: save_
    save_=.true.;if(present(save))save_=save
    call allocate_dmft_bath(dmft_bath_)
    call set_dmft_bath(bath_,dmft_bath_)
    if(Nbath==1)return
    if(mod(Nbath,2)==0)then
       do i=1,Nbath/2
          dmft_bath_%e(:,:,Nbath+1-i)=-dmft_bath_%e(:,:,i)
          dmft_bath_%v(:,:,Nbath+1-i)= dmft_bath_%v(:,:,i)
       enddo
    else
       do i=1,(Nbath-1)/2
          dmft_bath_%e(:,:,Nbath+1-i)=-dmft_bath_%e(:,:,i)
          dmft_bath_%v(:,:,Nbath+1-i)= dmft_bath_%v(:,:,i)
       enddo
       dmft_bath_%e(:,:,(Nbath-1)/2+1)=0.d0
    endif
    if(save_)call save_dmft_bath(dmft_bath_)
    call get_dmft_bath(dmft_bath_,bath_)
    call deallocate_dmft_bath(dmft_bath_)
  end subroutine ph_symmetrize_bath_site
  subroutine ph_symmetrize_bath_lattice(bath_,save)
    real(8),dimension(:,:) :: bath_
    logical,optional       :: save
    logical                :: save_
    integer                :: Nsites,ilat
    save_=.true.;if(present(save))save_=save
    Nsites=size(bath_,1)
    do ilat=1,Nsites
       ed_file_suffix="_site"//reg(txtfy(ilat,Npad=4))
       call ph_symmetrize_bath_site(bath_(ilat,:),save_)
    enddo
    ed_file_suffix=""
  end subroutine ph_symmetrize_bath_lattice

  !---------------------------------------------------------!

  subroutine ph_trans_bath_site(bath_,save)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    type(effective_bath)   :: tmp_dmft_bath
    integer                :: i
    logical,optional       :: save
    logical                :: save_
    save_=.true.;if(present(save))save_=save
    call allocate_dmft_bath(dmft_bath_)
    call allocate_dmft_bath(tmp_dmft_bath)
    call set_dmft_bath(bath_,dmft_bath_)
    if(Nbath==1)return
    do i=1,Nbath
       select case(Norb)
       case default
          ! do nothing
          dmft_bath_%e(:,:,i)= dmft_bath_%e(:,:,i)
          dmft_bath_%v(:,:,i)= dmft_bath_%v(:,:,i)
       case(1)
          dmft_bath_%e(:,:,i)= -dmft_bath_%e(:,:,i)
          dmft_bath_%v(:,:,i)=  dmft_bath_%v(:,:,i)
       case(2)
          tmp_dmft_bath%e(:,1,i) = -dmft_bath_%e(:,2,i)
          tmp_dmft_bath%e(:,2,i) = -dmft_bath_%e(:,1,i)
          dmft_bath_%e(:,:,i)    = tmp_dmft_bath%e(:,:,i)
          tmp_dmft_bath%v(:,1,i) = dmft_bath_%v(:,2,i)
          tmp_dmft_bath%v(:,2,i) = dmft_bath_%v(:,1,i)
          dmft_bath_%v(:,:,i)    = tmp_dmft_bath%v(:,:,i)
       end select
    end do
    if(save_)call save_dmft_bath(dmft_bath_)
    call get_dmft_bath(dmft_bath_,bath_)
    call deallocate_dmft_bath(dmft_bath_)
  end subroutine ph_trans_bath_site
  subroutine ph_trans_bath_lattice(bath_,save)
    real(8),dimension(:,:) :: bath_
    logical,optional       :: save
    logical                :: save_
    integer                :: Nsites,ilat
    save_=.true.;if(present(save))save_=save
    Nsites=size(bath_,1)
    do ilat=1,Nsites
       ed_file_suffix="_site"//reg(txtfy(ilat,Npad=4))
       call ph_trans_bath_site(bath_(ilat,:),save_)
    enddo
    ed_file_suffix=""
  end subroutine ph_trans_bath_lattice

  !---------------------------------------------------------!

  subroutine enforce_normal_bath_site(bath_,save)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    logical,optional       :: save
    logical                :: save_
    save_=.true.;if(present(save))save_=save
    call allocate_dmft_bath(dmft_bath_)
    call set_dmft_bath(bath_,dmft_bath_)
    if(save_)call save_dmft_bath(dmft_bath_)
    call get_dmft_bath(dmft_bath_,bath_)
    call deallocate_dmft_bath(dmft_bath_)
  end subroutine enforce_normal_bath_site
  subroutine enforce_normal_bath_lattice(bath_,save)
    real(8),dimension(:,:) :: bath_
    logical,optional       :: save
    logical                :: save_
    integer                :: Nsites,ilat
    save_=.true.;if(present(save))save_=save
    Nsites=size(bath_,1)
    do ilat=1,Nsites
       ed_file_suffix="_site"//reg(txtfy(ilat,Npad=4))
       call enforce_normal_bath_site(bath_(ilat,:),save_)
    enddo
    ed_file_suffix=""
  end subroutine enforce_normal_bath_lattice

  !##################################################################
  !
  !     DMFT BATH ROUTINES:
  !
  !##################################################################
  !+-------------------------------------------------------------------+
  !PURPOSE  : Allocate the ED bath
  !+-------------------------------------------------------------------+
  subroutine allocate_dmft_bath(dmft_bath_)
    type(effective_bath) :: dmft_bath_
    if(dmft_bath_%status)call deallocate_dmft_bath(dmft_bath_)
    !
    select case(bath_type)
    case default
       !
       allocate(dmft_bath_%e(Nspin,Norb,Nbath))  !local energies of the bath
       allocate(dmft_bath_%v(Nspin,Norb,Nbath))  !same-spin hybridization
       !
    case('hybrid')
       !
       allocate(dmft_bath_%e(Nspin,1,Nbath))     !local energies of the bath
       allocate(dmft_bath_%v(Nspin,Norb,Nbath))  !same-spin hybridization
       !
    end select
    dmft_bath_%status=.true.
  end subroutine allocate_dmft_bath

  !+-------------------------------------------------------------------+
  !PURPOSE  : Deallocate the ED bath
  !+-------------------------------------------------------------------+
  subroutine deallocate_dmft_bath(dmft_bath_)
    type(effective_bath) :: dmft_bath_
    if(allocated(dmft_bath_%e))   deallocate(dmft_bath_%e)
    if(allocated(dmft_bath_%v))   deallocate(dmft_bath_%v)
    dmft_bath_%status=.false.
  end subroutine deallocate_dmft_bath

  !+------------------------------------------------------------------+
  !PURPOSE  : Initialize the DMFT loop, builindg H parameters and/or
  !reading previous (converged) solution
  !+------------------------------------------------------------------+
  subroutine init_dmft_bath(dmft_bath_)
    type(effective_bath) :: dmft_bath_
    integer              :: i,unit,flen,Nh
    integer              :: io,jo,iorb,ispin,jorb,jspin
    logical              :: IOfile
    real(8)              :: de,noise_tot
    character(len=21)    :: space
    if(.not.dmft_bath_%status)stop "init_dmft_bath error: bath not allocated"
    !Get energies:
    dmft_bath_%e(:,:,1)    =-hwband
    dmft_bath_%e(:,:,Nbath)= hwband
    Nh=Nbath/2
    if(mod(Nbath,2)==0.and.Nbath>=4)then
       de=hwband/max(Nh-1,1)
       dmft_bath_%e(:,:,Nh)  = -1.d-3
       dmft_bath_%e(:,:,Nh+1)=  1.d-3
       do i=2,Nh-1
          dmft_bath_%e(:,:,i)   =-hwband + (i-1)*de
          dmft_bath_%e(:,:,Nbath-i+1)= hwband - (i-1)*de
       enddo
    elseif(mod(Nbath,2)/=0.and.Nbath>=3)then
       de=hwband/Nh
       dmft_bath_%e(:,:,Nh+1)= 0.0d0
       do i=2,Nh
          dmft_bath_%e(:,:,i)        =-hwband + (i-1)*de
          dmft_bath_%e(:,:,Nbath-i+1)= hwband - (i-1)*de
       enddo
    endif
    !Get spin-keep yhbridizations
    do i=1,Nbath
       dmft_bath_%v(:,:,i)=max(0.1d0,1.d0/sqrt(dble(Nbath)))
    enddo
    !
    !Read from file if exist:
    !
    inquire(file=trim(Hfile)//trim(ed_file_suffix)//".restart",exist=IOfile)
    if(IOfile)then
       write(LOGfile,"(A)")'Reading bath from file'//trim(Hfile)//trim(ed_file_suffix)//".restart"
       unit = free_unit()
       flen = file_length(trim(Hfile)//trim(ed_file_suffix)//".restart")
       !
       open(unit,file=trim(Hfile)//trim(ed_file_suffix)//".restart")
       !
       select case(bath_type)
       case default
          !
          read(unit,*)
          do i=1,min(flen,Nbath)
             read(unit,*)((&
                  dmft_bath_%e(ispin,iorb,i),&
                  dmft_bath_%v(ispin,iorb,i),&
                  iorb=1,Norb),ispin=1,Nspin)
          enddo
          !
       case ('hybrid')
          read(unit,*)
          !
          do i=1,min(flen,Nbath)
             read(unit,*)(&
                  dmft_bath_%e(ispin,1,i),&
                  (&
                  dmft_bath_%v(ispin,iorb,i),&
                  iorb=1,Norb),&
                  ispin=1,Nspin)
          enddo
          !
       end select
       close(unit)
    endif
  end subroutine init_dmft_bath

  !+-------------------------------------------------------------------+
  !PURPOSE  : write out the bath to a given unit with
  ! the following column formatting:
  ! [(Ek_iorb,Vk_iorb)_iorb=1,Norb]_ispin=1,Nspin
  !+-------------------------------------------------------------------+
  subroutine write_dmft_bath(dmft_bath_,unit)
    type(effective_bath) :: dmft_bath_
    integer,optional     :: unit
    integer              :: unit_
    integer              :: i
    integer              :: io,jo,iorb,ispin
    complex(8)           :: hybr_aux
    complex(8)           :: hrep_aux(Nspin*Norb,Nspin*Norb)
    unit_=LOGfile;if(present(unit))unit_=unit
    if(.not.dmft_bath_%status)stop "write_dmft_bath error: bath not allocated"
    select case(bath_type)
    case default
       !
       write(unit_,"(90(A21,1X))")&
            ((&
            "#Ek_l"//reg(txtfy(iorb))//"_s"//reg(txtfy(ispin)),&
            "Vk_l"//reg(txtfy(iorb))//"_s"//reg(txtfy(ispin)),&
            iorb=1,Norb),ispin=1,Nspin)
       do i=1,Nbath
          write(unit_,"(90(F21.12,1X))")((&
               dmft_bath_%e(ispin,iorb,i),&
               dmft_bath_%v(ispin,iorb,i),&
               iorb=1,Norb),ispin=1,Nspin)
       enddo
       !
    case('hybrid')
       !
       write(unit_,"(90(A21,1X))")(&
            "#Ek_s"//reg(txtfy(ispin)),&
            ("Vk_l"//reg(txtfy(iorb))//"_s"//reg(txtfy(ispin)),iorb=1,Norb),&
            ispin=1,Nspin)
       do i=1,Nbath
          write(unit_,"(90(F21.12,1X))")(&
               dmft_bath_%e(ispin,1,i),&
               (dmft_bath_%v(ispin,iorb,i),iorb=1,Norb),&
               ispin=1,Nspin)
       enddo
       !
    end select
  end subroutine write_dmft_bath

  !+-------------------------------------------------------------------+
  !PURPOSE  : save the bath to a given file using the write bath
  ! procedure and formatting:
  !+-------------------------------------------------------------------+
  subroutine save_dmft_bath(dmft_bath_,file,used)
    type(effective_bath)      :: dmft_bath_
    character(len=*),optional :: file
    character(len=256)        :: file_
    logical,optional          :: used
    logical                   :: used_
    character(len=16)         :: extension
    integer                   :: unit_
    if(.not.dmft_bath_%status)stop "save_dmft_bath error: bath is not allocated"
    used_=.false.;if(present(used))used_=used
    extension=".restart";if(used_)extension=".used"
    file_=reg(reg(Hfile)//reg(ed_file_suffix)//reg(extension))
    if(present(file))file_=reg(file)
    unit_=free_unit()
    open(unit_,file=reg(file_))
    call write_dmft_bath(dmft_bath_,unit_)
    close(unit_)
  end subroutine save_dmft_bath

  !+-------------------------------------------------------------------+
  !PURPOSE  : set the bath components from a given user provided
  ! bath-array
  !+-------------------------------------------------------------------+
  subroutine set_dmft_bath(bath_,dmft_bath_)
    real(8),dimension(:)   :: bath_
    type(effective_bath)   :: dmft_bath_
    integer                :: stride,io,jo,i
    integer                :: iorb,ispin,jorb,jspin,ibath
    logical                :: check
    complex(8)             :: hrep_aux(Nspin*Norb,Nspin*Norb)
    complex(8)             :: U(Nspin*Norb,Nspin*Norb)
    complex(8)             :: Udag(Nspin*Norb,Nspin*Norb)
    real(8)                :: element_R,element_I,eps_k,lambda_k
    if(.not.dmft_bath_%status)stop "set_dmft_bath error: bath not allocated"
    check = check_bath_dimension(bath_)
    if(.not.check)stop "set_dmft_bath error: wrong bath dimensions"
    !
    select case(bath_type)
    case default
       !
       stride = 0
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Nbath*Norb
                dmft_bath_%e(ispin,iorb,i) = bath_(io)
             enddo
          enddo
       enddo
       stride = Nspin*Norb*Nbath
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Nbath*Norb
                dmft_bath_%v(ispin,iorb,i) = bath_(io)
             enddo
          enddo
       enddo
       !
       !
    case ('hybrid')
       !
       stride = 0
       do ispin=1,Nspin
          do i=1,Nbath
             io = stride + i + (ispin-1)*Nbath
             dmft_bath_%e(ispin,1,i) = bath_(io)
          enddo
       enddo
       stride = Nspin*Nbath
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Norb*Nbath
                dmft_bath_%v(ispin,iorb,i) = bath_(io)
             enddo
          enddo
       enddo
       !
       !
    end select
  end subroutine set_dmft_bath

  !+-------------------------------------------------------------------+
  !PURPOSE  : copy the bath components back to a 1-dim array
  !+-------------------------------------------------------------------+
  subroutine get_dmft_bath(dmft_bath_,bath_)
    type(effective_bath)   :: dmft_bath_
    real(8),dimension(:)   :: bath_
    complex(8)             :: hrep_aux(Nspin*Norb,Nspin*Norb)
    complex(8)             :: U(Nspin*Norb,Nspin*Norb)
    complex(8)             :: Udag(Nspin*Norb,Nspin*Norb)
    integer                :: stride,io,jo,i
    integer                :: iorb,ispin,jorb,jspin,ibath
    logical                :: check
    if(.not.dmft_bath_%status)stop "get_dmft_bath error: bath not allocated"
    check=check_bath_dimension(bath_)
    if(.not.check)stop "get_dmft_bath error: wrong bath dimensions"
    !
    select case(bath_type)
    case default
       !
       stride = 0
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Nbath*Norb
                bath_(io) = dmft_bath_%e(ispin,iorb,i)
             enddo
          enddo
       enddo
       stride = Nspin*Norb*Nbath
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Nbath*Norb
                bath_(io) = dmft_bath_%v(ispin,iorb,i)
             enddo
          enddo
       enddo
       !
    case ('hybrid')
       !
       stride = 0
       do ispin=1,Nspin
          do i=1,Nbath
             io = stride + i + (ispin-1)*Nbath
             bath_(io) =  dmft_bath_%e(ispin,1,i)
          enddo
       enddo
       stride = Nspin*Nbath
       do ispin=1,Nspin
          do iorb=1,Norb
             do i=1,Nbath
                io = stride + i + (iorb-1)*Nbath + (ispin-1)*Norb*Nbath
                bath_(io) =  dmft_bath_%v(ispin,iorb,i)
             enddo
          enddo
       enddo
       !
    end select
  end subroutine get_dmft_bath

  !##################################################################
  !
  !     USER BATH CHECKS:
  !
  !##################################################################
  !+-------------------------------------------------------------------+
  !PURPOSE  : Check if the dimension of the bath array are consistent
  !+-------------------------------------------------------------------+
  function check_bath_dimension(bath_,Hloc_nn) result(bool)
    real(8),dimension(:)           :: bath_
    integer                        :: Ntrue
    logical                        :: bool
    complex(8),optional,intent(in) :: Hloc_nn(:,:,:,:)
    if (present(Hloc_nn))then
       Ntrue = get_bath_dimension(Hloc_nn)
    else
       Ntrue = get_bath_dimension()
    endif
    bool  = ( size(bath_) == Ntrue )
  end function check_bath_dimension

END MODULE ED_BATH


	SUBROUTINE WW_OUT ( lunf, itype, strtim, stptim, wnum, icorr,
     +			    icancl, rlat, rlon, npt, iret )
C************************************************************************
C* WW_OUT 								*
C*									*
C* This subroutine writes watch box data to an ASCII file.              *
C*                                                                      *
C* WW_OUT ( LUNF, ITYPE, STRTIM, STPTIM, WNUM, ICORR, ICANCL, RLAT,     *
C*	    RLON, NPT, IRET )             				*
C*									*
C* Input parameters:							*
C*	LUNF		INTEGER		ASCII output file number	*
C*	ITYPE		INTEGER		Watch type                      *
C*	STRTIM		CHAR*		Watch start time, GEMPAK format *
C*	STPTIM		CHAR*		Watch end time, GEMPAK format   *
C*	WNUM		CHAR*		Watch number			*
C*	ICORR		INTEGER		Correction indicator            *
C*	ICANCL		INTEGER		Watch cancellation indicator    *
C*	RLAT (*)	REAL		Latitudes of points             *
C*	RLON (*)	REAL		Longitudes of points            *
C*	NPT		INTEGER		Number of points                *
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 5/99	                                        *
C* D. Kidwell/NCEP	 7/99	Added replacement watch type RP         *
C* D. Kidwell/NCEP	 8/99	Added status report type ST             *
C* M. James/UCAR        05/16   gfortran 4.6+ fix for writing files     *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	wnum, strtim, stptim
	REAL   		rlat (*), rlon (*)
C*
	CHARACTER	type*2, corr*1, cancl*1, string*40
C------------------------------------------------------------------------
	iret = 0
C
C*	Construct the header string.
C
	IF ( itype .eq. 0 ) THEN
	    type = 'TN'
	  ELSE IF ( itype .eq. 1 ) THEN
	    type = 'TS'
	  ELSE IF ( itype .eq. 2 ) THEN
	    type = 'RP'
	  ELSE IF ( itype .eq. 3 ) THEN
	    type = 'ST'
	  ELSE
	    type = ' '
	END IF
	CALL ST_INCH ( icorr, corr, ier )
	CALL ST_INCH ( icancl, cancl, ier )
	CALL ST_LSTR ( strtim, lenstr, ier )
	CALL ST_LSTR ( stptim, lenstp, ier )
	string = '|' // type // '|' // strtim ( :lenstr ) // '|' //
     +		 stptim ( :lenstp ) // '|' // wnum // '|' // corr //
     +		 '|' // cancl
C
	BACKSPACE(lunf)
	WRITE ( lunf, 10 ) string
   10	FORMAT ( A )
C
C*	Write out the points.
C
	DO i = 1, npt
	    WRITE ( lunf, 20 ) rlat (i), rlon (i)
	END DO
   20 	FORMAT ( 2F9.2 )
C*
	RETURN
	END


module obs_sensitivity
!$$$ module documentation block
!           .      .    .                                       .
! module:   obs_sensitivity
!   prgmmr: tremolet
!
! abstract: Contains variables and routines for computation of
!           forecast sensitivity to observations.
!
! program history log:
!   2007-06-26 tremolet
!   2007-07-19 tremolet - increment sensitivity to observations
!   2009-08-07 lueken   - updated documentation
!   2010-04-30 tangborn - add pointer to carbon monoxide
!   2010-05-27 todling  - remove all user-specific TL-related references
!   2010-07-16 todling  - add reference to aero and aerol
!   2010-08-19 lueken   - add only to module use;no machine code, so use .f90
!   2011-03-29 todling  - add reference to pm2_5
!   2012-04-15 todling  - add reference to gust, vis, pblh
!   2015-07-10 pondeca  - add reference to wspd10m, td2m ,mxtm ,mitm ,pmsl,
!                         howv ,tcamt, lcbas, cldch
!   2016-02-20 pagowski - add pm10
!   2016-05-05 pondeca  - add reference to uwnd10m, vwnd10m
!   2017-05-12 Y. Wang and X. Wang - add reflectivity (dBZ), POC: xuguang.wang@ou.edu
!   2017-01-16 Apodaca  - add reference to lightning
!   2017-05-06 todling  - reload ensemble when FSOI calc doing EnVarFSOI-like
!   2017-05-21 todling  - implement ability to do 2nd EnVarFSOI-like calc
!
! Subroutines Included:
!   init_fc_sens  - Initialize computations
!
! Variable Definitions:
!   fcsens - forecast sensitivity gradient
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
! ------------------------------------------------------------------------------
use kinds, only: r_kind,i_kind,r_quad
use constants, only: zero, zero_quad, two
use gsi_4dvar, only: nobs_bins, l4dvar, lsqrtb, nsubwin
use gsi_4dvar, only: tau_fcst,evfsoi_order,evfsoi_afcst,evfsoi_ana
use jfunc, only: jiter, miter, niter, iter, jiterend

use gsi_obOperTypeManager, only: nobs_type => obOper_count
use gsi_obOperTypeManager, only: obOper_typeinfo
use mpimod, only: mype
use control_vectors, only: control_vector,allocate_cv,read_cv,deallocate_cv, &
    dot_product,assignment(=)
use state_vectors, only: allocate_state,deallocate_state
use gsi_bundlemod, only: self_add
use gsi_bundlemod, only: assignment(=)
use gsi_bundlemod, only: gsi_bundle
use bias_predictors, only: predictors,allocate_preds,deallocate_preds, &
    assignment(=)
use mpl_allreducemod, only: mpl_allreduce
use gsi_4dcouplermod, only: gsi_4dcoupler_getpert
use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,destroy_hybens_localization_parameters
use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble
use hybrid_ensemble_isotropic, only: hybens_localization_setup
use mpeu_util, only: perr,die
! ------------------------------------------------------------------------------
implicit none
save
private
public lobsensfc,lobsensjb,lobsensincr,lobsensadj,&
       lobsensmin,iobsconv,llancdone,lsensrecompute, &
       fcsens, sensincr, &
       init_obsens, init_fc_sens, save_fc_sens, dot_prod_obs
public evfsoi_o2_update

public:: obsensCounts_realloc
public:: obsensCounts_set
public:: obsensCounts_dealloc

logical lobsensfc,lobsensjb,lobsensincr, &
        lobsensadj,lobsensmin,llancdone,lsensrecompute
integer(i_kind) :: iobsconv

! ------------------------------------------------------------------------------
type(control_vector) :: fcsens
real(r_kind), allocatable :: sensincr(:,:,:)
integer(i_kind):: orig_tau_fcst=-1

integer(i_kind),save,allocatable:: obscounts(:,:)

character(len=*),parameter:: myname="obs_sensitivity"
! ------------------------------------------------------------------------------
contains
!>> object obsensCounts_:
!>> this object was public obsmod::obscounts(:,:), but now private module
!>> variable in this module.  It is accessed through following module procedures
!>> []_alloc(), []_set() and []_dealloc().

subroutine obsensCounts_realloc(ntype,nbin)
!>> was implemented in setuprhsall()
  implicit none
  integer(i_kind),intent(in):: ntype
  integer(i_kind),intent(in):: nbin
  character(len=*),parameter:: myname_=myname//"::obsensCounts_realloc"
  if(allocated(obscounts)) deallocate(obscounts)
  allocate(obscounts(ntype,nbin))
end subroutine obsensCounts_realloc

subroutine obsensCounts_set(iobsglb)
!>> was implemented in evaljo()
  implicit none
  integer(i_kind),dimension(:,:),intent(in):: iobsglb
  character(len=*),parameter:: myname_=myname//"::obsensCounts_set"
  if(.not.allocated(obscounts)) then
    call perr(myname_,'not allocated, obscounts')
    call perr(myname_,'was evaljo() exception 125')
    call  die(myname_)
  endif
  if(any(shape(obscounts)/=shape(iobsglb))) then
    call perr(myname_,'mismatched, storage size(obscounts,1) =',size(obscounts,1))
    call perr(myname_,'             argument size(iobsglb,1) =',size(iobsglb,1))
    call perr(myname_,'            storage size(obscounts,2) =',size(obscounts,2))
    call perr(myname_,'             argument size(iobsglb,2) =',size(iobsglb,2))
    call  die(myname_)
  endif
  obscounts(:,:)=iobsglb(:,:)
end subroutine obsensCounts_set

subroutine obsensCounts_dealloc()
!>> was a part of obsmod::destroyobs_().
  implicit none
  character(len=*),parameter:: myname_=myname//"::obsensCounts_dealloc"
  if(allocated(obscounts)) deallocate(obscounts)
end subroutine obsensCounts_dealloc

! ------------------------------------------------------------------------------
subroutine init_obsens
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_obsens
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-07  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
implicit none

lobsensfc=.false.
lobsensjb=.false.
lobsensincr=.false.
lobsensadj=.false.
lobsensmin=.false.
lsensrecompute=.false.
llancdone=.false.
iobsconv=0

end subroutine init_obsens
! ------------------------------------------------------------------------------
subroutine init_fc_sens
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_fc_sens
!   prgmmr:      tremolet
!
! abstract: Read forecast sensitivity gradient
!
! program history log:
!   2007-06-26  tremolet - initial code
!   2009-08-07  lueken - added subprogram doc block
!   2010-05-27  todling - gsi_4dcoupler; remove dependence on GMAO specifics
!   2012-05-22  todling - update interface to getpert
!   2015-12-01  todling - add several obs-types that Pondeca forget to add here
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

implicit none

character(len=12) :: clfile
type(gsi_bundle) :: fcgrad(nsubwin)
type(gsi_bundle) :: eval(ntlevs_ens)
type(predictors) :: zbias
type(control_vector) :: xwork
real(r_kind) :: zjx
integer(i_kind) :: ii
character(len=80),allocatable,dimension(:)::fname
integer :: mydate(5)

if (mype==0) then
   write(6,*)'init_fc_sens: lobsensincr,lobsensfc,lobsensjb=', &
                            lobsensincr,lobsensfc,lobsensjb
   write(6,*)'init_fc_sens: lobsensadj,lobsensmin,iobsconv=', &
                            lobsensadj,lobsensmin,iobsconv
   write(6,*)'init_fc_sens: lsensrecompute=',lsensrecompute
endif

call allocate_cv(fcsens)
fcsens=zero

if (lobsensadj.and.lobsensmin) then
   write(6,*)'init_fc_sens: unknown method',lobsensadj,lobsensmin
   call stop2(155)
end if

if (iobsconv>=2) then
   allocate(sensincr(nobs_bins,nobs_type,niter(jiter)))
else
   allocate(sensincr(nobs_bins,nobs_type,1))
endif
sensincr=zero

! Initialize fcsens
if (lobsensfc) then
   if (lobsensincr) then
      clfile='xhatsave.ZZZ'
      write(clfile(10:12),'(I3.3)') jiter
      call read_cv(fcsens,clfile)
      if (jiter>1) then
         clfile='xhatsave.ZZZ'
         write(clfile(10:12),'(I3.3)') jiter-1
         call allocate_cv(xwork)
         call read_cv(xwork,clfile)
         do ii=1,fcsens%lencv
            fcsens%values(ii) = fcsens%values(ii) - xwork%values(ii)
         end do
         call deallocate_cv(xwork)
      endif
   else
      if (jiter==miter) then
         if (lobsensjb) then
            clfile='xhatsave.ZZZ'
            write(clfile(10:12),'(I3.3)') miter
            call read_cv(fcsens,clfile)
         else
!           read and convert output of GCM adjoint
            allocate(fname(nsubwin))
            fname='NULL'
            if (tau_fcst>0) then
               fname='B'
            endif
            do ii=1,nsubwin
               call allocate_state(fcgrad(ii))
            end do
            call allocate_preds(zbias)
            zbias=zero
            call gsi_4dcoupler_getpert(fcgrad,nsubwin,'adm',fname)
            if (tau_fcst>0) then ! .and. miter/=jiterend) then ! note: when jiterend=miter forecast ens already loaded
               mydate(1)=1776;mydate(2)=7;mydate(3)=4;mydate(4)=12;mydate(5)=0
               call advect_cv(mype,mydate,tau_fcst,fcgrad)
            endif
            if (lsqrtb) then
               call control2model_ad(fcgrad,zbias,fcsens)
            else
               if (l_hyb_ens) then
                  if (tau_fcst>0) then ! .and. miter/=jiterend) then ! note: when jiterend=miter forecast ens already loaded
                     call destroy_hybens_localization_parameters
                     call destroy_ensemble
                     call create_ensemble
                     ! now restore actual ens of backgrounds
                     call load_ensemble(tau_fcst)
                     call hybens_localization_setup
                  endif
                  do ii=1,ntlevs_ens
                     call allocate_state(eval(ii))
                  end do
                  eval(1)=fcgrad(1)
                  fcgrad(1)=zero
                  call ensctl2state_ad(eval,fcgrad(1),fcsens)
                  call control2state_ad(fcgrad,zbias,fcsens)
                  do ii=1,ntlevs_ens
                     call deallocate_state(eval(ii))
                  end do
                  if (tau_fcst>0) then
!                    mydate(1)=1776;mydate(2)=7;mydate(3)=4;mydate(4)=12;mydate(5)=0
!                    call advect_cv(mype,mydate,tau_fcst,fcsens)
                     call destroy_hybens_localization_parameters
                     call destroy_ensemble
                     call create_ensemble
                     ! now restore actual ens of backgrounds
                     evfsoi_afcst=.false.
                     orig_tau_fcst=tau_fcst
                     tau_fcst=-1
                     call load_ensemble(tau_fcst)
                     call hybens_localization_setup
                  endif
               else
                  call control2state_ad(fcgrad,zbias,fcsens)
               end if
            endif
            do ii=1,nsubwin
               call deallocate_state(fcgrad(ii))
            end do
            call deallocate_preds(zbias)
            deallocate(fname)
         endif
      else
!        read gradient from outer loop jiter+1
         clfile='fgsens.ZZZ'
         WRITE(clfile(8:10),'(I3.3)') jiter+1
         call read_cv(fcsens,clfile)
      endif
   endif
   zjx=dot_product(fcsens,fcsens)
   if (mype==0) write(6,888)'init_fc_sens: Norm fcsens=',sqrt(zjx)
endif
888 format(A,3(1X,ES25.18))

return
end subroutine init_fc_sens
! ------------------------------------------------------------------------------
subroutine evfsoi_o2_update(sval)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    order2_fc_sens
!   prgmmr:      todling
!
! abstract: Read forecast sensitivity gradient
!
! program history log:
!   2007-06-26  tremolet - initial code
!   2009-08-07  lueken - added subprogram doc block
!   2010-05-27  todling - gsi_4dcoupler; remove dependence on GMAO specifics
!   2012-05-22  todling - update interface to getpert
!   2015-12-01  todling - add several obs-types that Pondeca forget to add here
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

implicit none
type(gsi_bundle),intent(inout)  :: sval(nobs_bins)

character(len=80),allocatable,dimension(:)::fname
type(gsi_bundle) :: fcgrad(nsubwin)
type(gsi_bundle) :: eval(ntlevs_ens)
type(gsi_bundle) :: mval(nsubwin)
type(predictors) :: zbias
real(r_kind) :: zjx
integer(i_kind) :: ii

tau_fcst=orig_tau_fcst
if (tau_fcst<=0) return
if (evfsoi_order/=2) return
if (.not.l_hyb_ens) return

if (mype==0) then
   print *, 'in order2_fc_sens ...'
endif

if (lobsensadj.and.lobsensmin) then
   write(6,*)'order2_fc_sens: unknown method',lobsensadj,lobsensmin
   call stop2(155)
end if

! Zero out whatever is in fcsens
 fcsens=zero

! read and convert output of GCM adjoint
 allocate(fname(nsubwin))
 fname='A'
 do ii=1,nsubwin
    call allocate_state(fcgrad(ii))
 end do
 call allocate_preds(zbias)
 zbias=zero
 do ii=1,ntlevs_ens
    call allocate_state(eval(ii))
 end do
 do ii=1,nsubwin
    fcgrad(ii)=zero
 end do
 call gsi_4dcoupler_getpert(fcgrad,nsubwin,'adm',fname)
! Wipe out loaded ensemble members to allow reloading ensemble of analysis
 call destroy_ensemble
! Read in ens forecasts issued from "analysis"
 evfsoi_afcst=.true.
 call create_ensemble
 call load_ensemble(tau_fcst)
 do ii=1,ntlevs_ens
    call allocate_state(eval(ii))
 end do
 eval(1)=fcgrad(1)
 fcgrad(1)=zero
 call ensctl2state_ad(eval,fcgrad(1),fcsens)
 call control2state_ad(fcgrad,zbias,fcsens)
 do ii=1,ntlevs_ens
    call deallocate_state(eval(ii))
 end do
 do ii=1,nsubwin
    call deallocate_state(fcgrad(ii))
 end do
 call deallocate_preds(zbias)
 deallocate(fname)
! Wipeout ensemble from memory
 call destroy_ensemble

! RT: I think somewhere around here is where we should advect the resulting
! sensitivities ... TBD (similar to advecting localization scales, is it?)
! could also be a few lines above ... not sure yet

! Report magnitude of input vector
 zjx=dot_product(fcsens,fcsens)
 if (mype==0) write(6,888)'order2_fc_sens: Norm fcsens=',sqrt(zjx)
888 format(A,3(1X,ES25.18))

! Read in ensemble of analysis (these are EnKF, not GSI, analyses obviously)
 evfsoi_ana=.true.
 call create_ensemble
 call load_ensemble(-1)

! Allocate local variables
 do ii=1,nsubwin
    call allocate_state(mval(ii))
 end do
 do ii=1,ntlevs_ens
    call allocate_state(eval(ii))
 end do
 call allocate_preds(zbias)

! Convert from control variable to state space
 call control2state(fcsens,mval,zbias)

! Convert ensemble control variable to state space and update from previous value
 call ensctl2state(fcsens,mval(1),eval)
 do ii=1,ntlevs_ens
    call self_add(sval(ii),eval(ii))
 end do

! Release memory
call deallocate_preds(zbias)
do ii=1,ntlevs_ens
   call deallocate_state(eval(ii))
end do
do ii=1,nsubwin
   call deallocate_state(mval(ii))
end do

return
end subroutine evfsoi_o2_update
subroutine save_fc_sens
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    save_fc_sens
!   prgmmr:      tremolet
!
! abstract: Compute and save forecast sensitivity to observations
!
! program history log:
!   2007-06-26  tremolet - initial code
!   2009-08-07  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
implicit none

real(r_kind) :: zz
integer(i_kind) :: ii,jj,kk

! Save statistics
if (mype==0) then

!  Full stats
   do jj=1,nobs_type
      write(6,'(A,2X,I3,2X,A)')'Obs types:',jj,obOper_typeinfo(jj)
   enddo
   write(6,'(A,2X,I4)')'Obs bins:',nobs_bins
   write(6,*)'Obs Count Begin'
   if (.not.allocated(obscounts)) then
      write(6,*)'save_fc_sens: obscounts not allocated'
      call stop2(156)
   end if
   do jj=1,nobs_type
      write(6,'((1X,I12))')(obscounts(jj,ii),ii=1,nobs_bins)
   enddo
   write(6,*)'Obs Count End'

   write(6,*)'Obs Impact Begin'
   do kk=1,SIZE(sensincr,3)
      if (SIZE(sensincr,3)==1) then
         write(6,'(A,I4)')'Obs Impact iteration= ',niter(jiter)
      else
         write(6,'(A,I4)')'Obs Impact iteration= ',kk
      endif
      do jj=1,nobs_type
         write(6,'((1X,ES12.5))')(sensincr(ii,jj,kk),ii=1,nobs_bins)
      enddo
   enddo
   write(6,*)'Obs Impact End'

   kk=SIZE(sensincr,3)
!  Summary by obs type
   do jj=1,nobs_type
      zz=zero
      do ii=1,nobs_bins
         zz=zz+sensincr(ii,jj,kk)
      enddo
      if (zz/=zero) write(6,'(A,2X,A3,2X,ES12.5)')'Obs Impact type',obOper_typeinfo(jj),zz
   enddo

!  Summary by obs bins
   do ii=1,nobs_bins
      zz=zero
      do jj=1,nobs_type
         zz=zz+sensincr(ii,jj,kk)
      enddo
      if (zz/=zero) write(6,'(A,2X,I3,2X,ES12.5)')'Obs Impact bin',ii,zz
   enddo

endif

deallocate(sensincr)
call deallocate_cv(fcsens)

return
end subroutine save_fc_sens
! ------------------------------------------------------------------------------
real(r_kind) function dot_prod_obs()
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_fc_sens
!   prgmmr:      tremolet
!
! abstract: Computes scalar product in observation space
!           (based on evaljo)
!
! program history log:
!   2007-06-27  tremolet
!   2009-01-18  todling - carry summations in quad precision
!   2009-08-07  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
use m_obsdiagNode, only: obs_diag
use m_obsdiags, only: obsdiags
implicit none

integer(i_kind) :: ii,jj,ij,it
real(r_quad)    :: zzz
real(r_quad)    :: zprods(nobs_type*nobs_bins)
type(obs_diag),pointer:: obsptr
! ----------------------------------------------------------

zprods(:)=zero_quad

ij=0
do ii=1,size(obsdiags,2)
   do jj=1,size(obsdiags,1)
      ij=ij+1

      obsptr => obsdiags(jj,ii)%head
      do while (associated(obsptr))
         if (obsptr%luse.and.obsptr%muse(jiter)) then
            zprods(ij) = zprods(ij) + obsptr%nldepart(jiter) * obsptr%obssen(jiter)
         endif
         obsptr => obsptr%next
      enddo

   enddo
enddo

! Gather contributions
call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods)

! Save intermediate values
it=-1
if (iobsconv>=2) then
   if (iter>=1.and.iter<=niter(jiter)) it=iter
else
   it=1
endif

if (it>0) then
   ij=0
   do ii=1,nobs_bins
      do jj=1,nobs_type
         ij=ij+1
         sensincr(ii,jj,it)=zprods(ij)
      enddo
   enddo
endif

! Sum
zzz=zero_quad

ij=0
do ii=1,nobs_bins
   do jj=1,nobs_type
      ij=ij+1
      zzz=zzz+zprods(ij)
   enddo
enddo

dot_prod_obs=zzz

return
end function dot_prod_obs
! ------------------------------------------------------------------------------
end module obs_sensitivity


PROGRAM TOOL
  USE Params
  USE Parallel
  USE Solver
  USE Markov
  USE Data
  USE Chain
  USE User
  IMPLICIT NONE
  INTEGER :: i,rndseed(1:20),rndsize,j,jj
  REAL(db) :: mseed, r2seed, lnPm,lnPb, lnPn
  CHARACTER(13) :: names
  LOGICAL :: exists
  NAMELIST /init/ refden, xseed, xMax, lnPmin, linkdots, withMPI, &
		    Love, MomI, MomQ, nDen, BE
  NAMELIST /Mchain/ CRUSTknots,COREknots,linkpoints, restart, step, cut, djump, step0, stepMax, MINknot, lnPall0
  NAMELIST /maps/ Nx,Ny,NM,NR,xL,xR,yD,yU,ML,MR,RD,RU,NLove,LoveL,LoveR,Ntrn,trnL,trnR,Nfrc,frcD,frcU, &
		    NusrX,NusrY,usrXL,usrXR,usrYU,usrYD
  NAMELIST /input/ fileEOS, dotsEOS, units, addBAND,addMAP,addLOVE,addMOM, addUSR
  NAMELIST /output/ writeevery, writeNS
  NAMELIST /Odata/  MmaxNS, &
		    M1maxNS,sM1maxNS,M2maxNS,sM2maxNS,M3maxNS,sM3maxNS, &
		    RsNS,sRsNS,MmnNS, &
		    M1,sM1,R1,sR1,&
		    R1inf,sR1inf,R2inf,sR2inf,z2,sz2, &
		    LoveLimit, Mlimit, Rlimit, &
		    glitchAmax, glitchRmax, glitchPmx
  NAMELIST /Ndata/ NucPh,fileEDF

  CALL init_all_mpi

  WRITE(*,*) mpi_myproc,': reading knobs'

   OPEN(unit=11,file='knobs',status='old',form='formatted')
    READ(11,init,END=11)
    READ(11,Mchain,END=11)
    READ(11,maps,END=11)
    READ(11,input,END=11)
    READ(11,output,END=11)
    READ(11,Odata,END=11)
    READ(11,Ndata,END=11)
11 CLOSE(11)

  IF(wflag.AND.MomQ) STOP 'Quadrupole moment is not suported yet. Set MomQ=F.'

  IF(MomI.AND.xseed==0.AND.Ntrn/=0) STOP 'No bare SQM star without crust, failed to get crust moment of inertia'

  IF(BE) nDen=.TRUE.

  IF(wflag.AND.Love) WRITE(*,*) 'Love number lambda will be calculated, output units km^5'
  IF(wflag.AND.MomI) WRITE(*,*) 'Moment of inertia for slow spin will be calculated, output units M_Sun*km^2'
  IF(wflag.AND.BE) WRITE(*,*) 	'Binding Energy will be calculated, output units M_Sun*c^2'

  IF(restart) THEN
   IF(wflag) WRITE(*,*) 'Restarting from step=',step
   addMAP=.TRUE.
   addBAND=.TRUE.
   addLOVE=.TRUE.
   addMOM=.TRUE.
   addUSR=.TRUE.
  ENDIF

  WRITE(names,'(A5,I6.6)') 'pmap.',mpi_myproc
  INQUIRE(FILE=TRIM('MAP/'//names),EXIST=exists)
  IF(.NOT.exists.AND.addMAP) addMAP=.FALSE.
  WRITE(names,'(A5,I6.6)') 'band.',mpi_myproc
  INQUIRE(FILE=TRIM('BND/'//names),EXIST=exists)
  IF(.NOT.exists.AND.addBAND) addBAND=.FALSE.
  WRITE(names,'(A5,I6.6)') 'lmap.',mpi_myproc
  INQUIRE(FILE=TRIM('LOV/'//names),EXIST=exists)
  IF(.NOT.exists.AND.addLOVE) addLOVE=.FALSE.
  WRITE(names,'(A5,I6.6)') 'ivst.',mpi_myproc
  INQUIRE(FILE=TRIM('MOM/'//names),EXIST=exists)
  IF(.NOT.exists.AND.addMOM) addMOM=.FALSE.
  WRITE(names,'(A5,I6.6)') 'umap.',mpi_myproc
  INQUIRE(FILE=TRIM('USR/'//names),EXIST=exists)
  IF(.NOT.exists.AND.addUSR) addUSR=.FALSE.

  IF(wflag) WRITE(*,*) 'Chain: crust knots = ',CRUSTknots,', core knots = ',COREknots,', points per link =',linkpoints
  IF(wflag) WRITE(*,*) 'Movable knots >= ',MINknot

  CALL alloc_chain

  rhos=EDtoKM*refden*(2.0D0/5)*(hbarc)**2*(3*pi**2*refden)**(2.0D0/3)/(2*mnc2)
  rss=rhos*Rkm*Rkm
  IF(wflag) WRITE(*,*) 'Reference energy density from neutron Fermi gas pressure ',rhos,' km^-2 (',rhos/EDtoKM,' MeV/fm^3)'

  IF (dotsEOS>0) THEN
   CALL loadEOS
  ELSE
   STOP 'no seed EOS'
  ENDIF

  IF (NucPh) THEN
   CALL loadEDF
  ELSE
   IF(wflag) WRITE(*,*) 'no EDF is used'
  ENDIF

  CALL init_MR(xseed,mseed,r2seed)
  IF(wflag) WRITE(*,*) mpi_myproc,': Seed EOS for n<=',nseed,' ln(rhoseed/rhos)<=',xseed,' yseed=',yseed,' iseed=',iseed
  IF(wflag) WRITE(*,*) mpi_myproc,': Seed star M=',mseed,'Msol R=',SQRT(r2seed),'km ',' I=',NSchain(1,6),' Msol*km^2'

  IF(wflag) WRITE(*,*) 'Init. random seed'
  call random_seed(size=rndsize)
  do i=1,rndsize
   call system_clock(count=rndseed(i))
   rndseed(i)=rndseed(i)+mpi_myproc
  enddo
  call random_seed(put=rndseed(1:rndsize))

  CALL init_chain(lnPm,lnPb)
  lnPn=MAX(lnPm,lnPb)
  WRITE(*,*) mpi_myproc,': lnPn=',lnPn

  IF(NM>0.OR.Nfrc>0) CALL init_grid
  IF(Nx>0) CALL init_gridEOS

  WRITE(*,*) mpi_myproc,': xchain=',xchain
  WRITE(*,*) mpi_myproc,': ychain=',ychain

  CALL Markov_start

  CALL kill_data
  CALL kill_chain
  CALL kill_grids

  IF(MomI) CALL kill_profile
  IF(NusrX>0) CALL kill_user

  CALL finish_mpi

END PROGRAM TOOL


!-------------------------------------------------------------------------------
!> Program SCALE-LES init
!!
!! @par Description
!!          This program makes initial data for ideal test cases
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2012-04-08 (H.Yashiro)  [mod] merge all init programs
!! @li      2012-06-13 (Y.Sato)     [mod] add HBINW option
!!
!<
!-------------------------------------------------------------------------------
program scaleles_init
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use dc_log, only: &
     LogInit
  use gtool_file, only: &
     FileCloseAll
  use scale_precision
  use scale_stdio
  use scale_prof

  use scale_process, only: &
     PRC_setup,    &
     PRC_MPIstart, &
     PRC_MPIstop,  &
     PRC_MPIfinish
  use scale_const, only: &
     CONST_setup
  use scale_calendar, only: &
     CALENDAR_setup
  use scale_random, only: &
     RANDOM_setup
  use scale_time, only: &
     TIME_setup
  use scale_grid_index, only: &
     GRID_INDEX_setup
  use scale_land_grid_index, only: &
     LAND_GRID_INDEX_setup
  use scale_grid, only: &
     GRID_setup
  use scale_land_grid, only: &
     LAND_GRID_setup
  use scale_tracer, only: &
     TRACER_setup
  use scale_fileio, only: &
     FILEIO_setup
  use scale_comm, only: &
     COMM_setup
  use scale_topography, only: &
     TOPO_setup
  use scale_landuse, only: &
     LANDUSE_setup
  use scale_grid_real, only: &
     REAL_setup,   &
     REAL_update_Z
  use scale_gridtrans, only: &
     GTRANS_setup
  use scale_interpolation, only: &
     INTERP_setup
  use scale_stats, only: &
     STAT_setup
  use scale_history, only: &
     HIST_setup
  use mod_atmos_vars, only: &
     ATMOS_vars_setup
  use mod_atmos_vars_sf, only: &
     ATMOS_vars_sf_setup
  use scale_atmos_hydrostatic, only: &
     ATMOS_HYDROSTATIC_setup
  use scale_atmos_thermodyn, only: &
     ATMOS_THERMODYN_setup
  use scale_atmos_saturation, only: &
     ATMOS_SATURATION_setup
  use mod_land_vars, only: &
     LAND_vars_setup
  use mod_ocean_vars, only: &
     OCEAN_vars_setup
  use mod_cpl_vars, only: &
     CPL_vars_setup
  use mod_mktopo, only: &
     MKTOPO_setup, &
     MKTOPO
  use mod_mkinit, only: &
     MKINIT_setup, &
     MKINIT
  !-----------------------------------------------------------------------------
  implicit none
  !-----------------------------------------------------------------------------
  !
  !++ parameters & variables
  !
  !=============================================================================

  !########## Initial setup ##########

  ! setup standard I/O
  call IO_setup

  ! start MPI
  call PRC_MPIstart

  ! setup process
  call PRC_setup

  ! setup Log
  call LogInit(IO_FID_CONF, IO_FID_LOG, IO_L)

  ! setup constants
  call CONST_setup

  ! setup calendar
  call CALENDAR_setup

  ! setup random number
  call RANDOM_setup

  ! setup time
  call TIME_setup( setup_TimeIntegration = .false. )

  call PROF_rapstart('Initialize')

  ! setup horisontal/vertical grid index
  call GRID_INDEX_setup
  call LAND_GRID_INDEX_setup

  ! setup grid coordinates (cartesian,idealized)
  call GRID_setup
  call LAND_GRID_setup

  ! setup tracer index
  call TRACER_setup

  ! setup file I/O
  call FILEIO_setup

  ! setup mpi communication
  call COMM_setup

  ! setup topography
  call TOPO_setup
  ! setup land use category index/fraction
  call LANDUSE_setup
  ! setup grid coordinates (real world)
  call REAL_setup

  ! setup grid transfer metrics (uses in ATMOS_dynamics)
  call GTRANS_setup
  ! setup Z-ZS interpolation factor (uses in History)
  call INTERP_setup

  ! setup statistics
  call STAT_setup
  ! setup history I/O
  call HIST_setup

  ! setup atmos
  call ATMOS_HYDROSTATIC_setup
  call ATMOS_THERMODYN_setup
  call ATMOS_SATURATION_setup

  ! setup variable container: atmos
  call ATMOS_vars_setup
  ! setup variable container: atmos_sf
  call ATMOS_vars_sf_setup
  ! setup variable container: land
  call LAND_vars_setup
  ! setup variable container: ocean
  call OCEAN_vars_setup
  ! setup variable container: coupler
  call CPL_vars_setup

  ! setup mktopo
  call MKTOPO_setup

  ! setup mkinit
  call MKINIT_setup

  call PROF_rapend('Initialize')

  !########## main ##########

  call PROF_rapstart('Main')

  ! execute mktopo
  call PROF_rapstart('MkTopo')
  call MKTOPO
  call PROF_rapend  ('MkTopo')

  ! re-setup
  call REAL_update_Z

  ! execute mkinit
  call PROF_rapstart('MkInit')
  call MKINIT
  call PROF_rapend  ('MkInit')

  call PROF_rapend('Main')

  !########## Finalize ##########

  call PROF_rapreport

  call FileCloseAll

  ! stop MPI
  call PRC_MPIfinish

  stop
  !=============================================================================
end program scaleles_init