c******************************************************************************
c
c      ESPJAN main program
c
c******************************************************************************
c
c      Files to be compiled and linked to build ESP:
c
c      Setup routines
c          A0.F      ESP main program
c          A1.F      run setup routines
c          A2.F      pointer setup routines
c          A3.F      help files
c          A4.F      old-style file read (special compiler switches)
c          A5.F      new-style file read
c          A6.F      chemical and atom name processing routines
c
c        Interface programs    * files depend on the interface used
c
c          IB.F      subroutines called by ESP
c        * I1.F      main interface subroutines
c        * I2.F      interface support routines
c
c        INTWRKZZ.H  interface include file
c
c******************************************************************************
c
c      Data file structure
c
c      The enthalpy and Pv product are assumed to be functions of temperature
c      only (independent of pressure).
c
c      The thermodynamic properties of reactants and products are read from
c      a file created by GEMPROP, a program based on the STANJAN chemical
c      equilibrium program.  The file is UNFORMATTED and structured as follows:
c
c      CHARACTER*8 CHEM
c
c      First record:
c          PNAME       48-character name of the properties model
c          RFT         fuel mass/total mass
c          NF          number of species in fuel
c          NO          number of species in oxidizer
c          PR          pressure at which reactant properties were evaluated
c      Next records: for J = 1,NF+NO:
c          CHEM(J)     8-character chemical name of the Jth reactant
c      Next records: for J = 1,NF+NO:
c          RMOLS(J)    mols of the reactants (relative)
c      Next records: for I=1,48:
c          HR(I)       enthalpy of reactants at Ith temperature, J/K
c      Next records: for I=1,48:
c          PVR(I)      Pv product of reactants at the Ith temperature, J/K
c      Next record:
c          NP          number of product species
c          PP          pressure at which product species were evaluated
c      Next records: for J = NF+NO+1,NF+N0+NP:
c          CHEM(J)     8-character chemical name of the (J-NF-N0)th product
c      Next records: for I=1,48:
c          HP(I)       enthalpy of products at Ith temperature, J/K
c      Next records: for I=1,48:
c          PVP(I)      Pv product of products at the Ith temperature, J/K
c
c      The temperatures are 200,300,400,...,4900 K; T(I) = 100 + 100*I.
c      The internal energies are computed from h and Pv.
c      The data are stored in COMMON blocks.
c******************************************************************************
c
c      ESPJAN main program
c
c------------------------------------------------------------------------------
c    Work array dimensioning
       INCLUDE 'ESPJWORK.H'
c------------------------------------------------------------------------------
c    Stanjan runs double precision except as noted
       IMPLICIT    REAL*8 (A-H,O-Z)
       LOGICAL     YESZZ,OK,CFNGVV
c------------------------------------------------------------------------------
c    interface work arrays
       INCLUDE 'INTWRKZZ.H'
       EQUIVALENCE(ID(5),NC)
       EQUIVALENCE(ID(6),NI)
       EQUIVALENCE(ID(7),NR)
c------------------------------------------------------------------------------
c    application-specific subroutines called by interface program GETZZ
       EXTERNAL    SETRVV,ACTRVV,HELPVV
       EXTERNAL    SETMVV,ACTMVV
       EXTERNAL    SETFVV,ACTFVV
       EXTERNAL    SETPVV,ACTPVV
       EXTERNAL    SETXVV,ACTXVV
c------------------------------------------------------------------------------
c    line length for non-graphical interface message box
       COMMON /MESBZZ/ LMESS
c------------------------------------------------------------------------------
c    Stanjan data work arrays
       CHARACTER*2     ATOM(NAMAX3)
       CHARACTER*8     CHEM(NSMAX2)
       COMMON /ATOMVV/ATOM
       COMMON /CHEMVV/CHEM
c------------------------------------------------------------------------------
c    Stanjan work arrays referenced by pointers
       INTEGER IW(NIWORK)
       REAL*8  RW(NRWORK)
       REAL*4  SW(NSWORK)
       COMMON /SJIW/IW
       COMMON /SJRW/RW
       COMMON /SJSW/SW
c------------------------------------------------------------------------------
c    Stanjan work array pointers
       DIMENSION IEPTR(80)
       DIMENSION ITPTR(20)
       DIMENSION IRPTR(20)
       DIMENSION ISPTR(10)
       COMMON /SJEPTR/ IEPTR
       COMMON /SJTPTR/ ITPTR
       COMMON /SJRPTR/ IRPTR
       COMMON /SJSPTR/ ISPTR
c------------------------------------------------------------------------------
c    pointers
       EQUIVALENCE (IoKERR,IEPTR(1))
       EQUIVALENCE (IoKMON,IEPTR(2))
       EQUIVALENCE (IoKUMO,IEPTR(4))
       EQUIVALENCE (IoNA  ,IEPTR(5))
       EQUIVALENCE (IoNP  ,IEPTR(7))
       EQUIVALENCE (IoNS  ,IEPTR(8))
       EQUIVALENCE (IoN   ,IEPTR(28))
       EQUIVALENCE (LoN   ,IEPTR(29))
       EQUIVALENCE (IoNSP ,IEPTR(30))
       EQUIVALENCE (IoHUGE,IEPTR(32))
       EQUIVALENCE (IoPA  ,IEPTR(60))
       EQUIVALENCE (IoSMOL,IEPTR(74))
c
       EQUIVALENCE (IoKFRZ,ITPTR(1))
       EQUIVALENCE (IoPATM,ITPTR(3))
       EQUIVALENCE (IoP   ,ITPTR(5))
       EQUIVALENCE (IoT   ,ITPTR(6))
       EQUIVALENCE (IoH   ,ITPTR(7))
       EQUIVALENCE (IoV   ,ITPTR(10))
       EQUIVALENCE (IoDHF0,ITPTR(14))
       EQUIVALENCE (IoWMS ,ITPTR(15))
c
       EQUIVALENCE (IoNAF ,ISPTR(4))
       EQUIVALENCE (IoNSF ,ISPTR(5))
       EQUIVALENCE (IoJFS ,ISPTR(6))
       EQUIVALENCE (IoNF  ,ISPTR(7))
       EQUIVALENCE (LoNF  ,ISPTR(8))
c------------------------------------------------------------------------------
c    Nearly-largest REAL*8 number:
       PARAMETER (HUGEN = 1.D100)
       COMMON /SJHUGE/HUGE,EAMIN,EAMAX
c------------------------------------------------------------------------------
c    Data file name
       CHARACTER*32    SUFILE
c------------------------------------------------------------------------------
c    Version designator
       CHARACTER*16    VERS
       COMMON /VERSVV/ VERS
c------------------------------------------------------------------------------
c    name of reactants
       CHARACTER*48    NREACT
       COMMON /NRCTVV/NREACT
c------------------------------------------------------------------------------
c    reactant inclusion
       DIMENSION   NOPR(NSMAX)
       COMMON /NOPRVV/NOPR
c------------------------------------------------------------------------------
c    fuel identification
       DIMENSION   NOPF(NSMAX)
       COMMON /NOPFVV/NOPF
c------------------------------------------------------------------------------
c    product identification
       DIMENSION   NOPP(NSMAX)
       COMMON /NOPPVV/NOPP
c------------------------------------------------------------------------------
c    data file name
       CHARACTER*32    DFILE
       COMMON /DFLEVV/ DFILE
c------------------------------------------------------------------------------
c    .ESJ properties file data
       PARAMETER   (IMAX=48)
       REAL*4      HP,HR,PVP,PVR,UP,UR,PP,PR,RFT
       DIMENSION   HP(IMAX),HR(IMAX),PVP(IMAX),PVR(IMAX),
     ;             UP(IMAX),UR(IMAX)
       CHARACTER*8 CHEMJ(NSMAX2)
       REAL*4   RMOLS(NSMAX)
       COMMON  /PROCVV/ CHEMJ
       COMMON  /PRONVV/ NFUEL,NOX,NPROD
       COMMON  /PRODVV/ HP,HR,PVP,PVR,UP,UR
       COMMON  /PROPVV/ PP,PR,RFT,RMOLS
       CHARACTER*48    NGPM
       COMMON  /NGPMVV/ NGPM
c------------------------------------------------------------------------------
c    output file name
       CHARACTER*32    OFILE
       COMMON /OFLEVV/ OFILE,NOUT
c------------------------------------------------------------------------------
       LOGICAL ATOMZ(NAMAX)
c------------------------------------------------------------------------------
c    Stanjan monitor file
       CHARACTER*32 MONF
c------------------------------------------------------------------------------
c    internal files
       CHARACTER*96    LINE
       CHARACTER*16    TEMP
c==============================================================================
c    set output window scroll
       CALL SOWSZZ
c------------------------------------------------------------------------------
c    set line width for messages
       LMESS = 78
c------------------------------------------------------------------------------
c    set version
       VERS = 'V2.04W  '
c------------------------------------------------------------------------------
c    set INTRFACE work array dimensions
       ID(2) = NCMAXZ
       ID(3) = NIMAXZ
       ID(4) = NRMAXZ
c------------------------------------------------------------------------------
c    load unset indicators (be consistent with SETZZ in file IB.F and
c     RSOVV in file S8.F.
       CD(1) = CHAR(239)
       ID(1) = -22222
       RD(1) = -1.1111111E11
c==============================================================================
c    set shorthand work array dimensions
       NIW = NIWORK
       NRW = NRWORK
       NSW = NSWORK
c
c    set pointers and check dimensions
       CALL SJSPTS(NAMAX,NPMAX,NSMAX,NIW,NRW,NSW,RW)
c
c    set exponential argument limits
       RW(IoHUGE) = HUGEN
       EAMAX = DLOG(HUGEN)
       EAMIN = - EAMAX
c
c    set Stanjan monitor file
       MONF = 'ESPJAN.MON'

c    opening header
       CALL HVERVV
c
c    briefing
1      IF (YESZZ('Would you like a briefing on ESPJAN?')) THEN
           CALL CLOWZZ
2          CALL HINSVV
c
3          CALL CLPWZZ
           IF (YESZZ('Are you ready to try using ESPJAN?'))  GOTO 4
           IF (YESZZ('Do you want to read the briefing again?')) GOTO 2
           IF (YESZZ('Do you want to quit ESPJAN?'))  STOP
           GOTO 3
           ENDIF
c
c    set the default data file
4     SUFILE = 'ESP.SUD'
c
c * read the data
c
c    do the read; integers are INTEGER*2 in .SUD files
10     CALL CLPWZZ
       INQUIRE (FILE=SUFILE,EXIST=OK)
       IF (OK) THEN
               CALL RSUDVV(8,SUFILE,OK)
               IF (.NOT.OK)  THEN
                   NOPA = 2
                   GOTO 22
                   ENDIF
           ELSE
               CALL FMESVV(2,'@','#',
     ;           'Species data file # not found.@',SUFILE)
               NOPA = 2
               GOTO 22
           ENDIF
c
c    get file counts
       NSF = IW(IoNSF)
       NAF = IW(IoNAF)
c    check file contents
       IF (NSF.EQ.0)  THEN
           CALL FMESVV(2,'@','#',
     ;       'Species data file # empty.@',SUFILE)
           NOPA = 2
           GOTO 22
           ENDIF

c    initialize no selections
       NIVR = 0
       DO I=1,NSF
           NOPR(I) = 0
           NOPF(I) = 0
           ENDDO
       NOUT = 1

c    reactant seletion
20     DO J=1,NSF
c        clear any fuel tags
           IF (NOPR(J).EQ.2) NOPR(J) = 1
           ENDDO
       CALL GETZZ(NIVR,SETRVV,HELPVV,ACTRVV,NOPA)
22     IF (NOPA.EQ.2)  THEN
           IF (YESZZ('Do you want to quit ESPJAN?'))  GOTO 200
c        use another .SUD data file
           CALL  GFNEZZ('SUD',SUFILE)
           GOTO 10
           ENDIF
c     check that all species are gas
       DO J=1,NSF
           IF (NOPR(J).NE.0)  THEN
               IF (CFNGVV(J)) THEN
                   NOPR(J) = 0
                   NIVR = 1
                   GOTO 20
                   ENDIF
               ENDIF
           ENDDO
c
c    scan file species for inclusion in the system
       JS = 0
       DO JF=1,NSF
           IF (NOPR(JF).NE.0)  THEN
c            put the file species in the system
               JS = JS + 1
               IW(IoJFS+JS) = JF
               CHEM(JS) = CHEM(NSMAX+JF)
               ENDIF
           ENDDO
       IW(IoNS) = JS
       NS = JS
c    check for nothing
       IF (NS.EQ.0)  THEN
           CALL WARNZZ('@','@You must have some species.@@')
           NIVR = 0
           GOTO 20
           ENDIF
c
c    identify fuel species
       NIVF = 0
c    clear fuel tags in reactants
30     DO J=1,NSF
           IF (NOPR(J).EQ.2) NOPR(J) = 1
           ENDDO
c    get fuel identification
       CALL GETZZ(NIVF,SETFVV,HELPVV,ACTFVV,NOPA)
       IF (NOPA.EQ.2) THEN
           NIVR = 1
           GOTO 20
           ENDIF
c    find fuel
       NFUEL = 0
       DO JS=1,NS
           IF (NOPF(JS).EQ.1) THEN
c            tag reactant as fuel
               JFS = IW(IoJFS+JS)
               NOPR(JFS) = 2
               NFUEL = NFUEL + 1
               ENDIF
           ENDDO
c    check for nothing
       IF (NFUEL.EQ.0)  THEN
           CALL WARNZZ('@','@You must have some fuel.@@')
           NIVF = 0
           GOTO 30
           ENDIF
c    set oxidizer count
       NOX = NS - NFUEL
c    clear N(I,J)
       DO J=1,NSF
           DO I=1,NAMAX
               IW(IoN+I+LoN*J) = 0
               ENDDO
           ENDDO
c    resort to put fuels first
       JS = 0
       NA = 0
c    set to do fuel
       KNOP = 2
32     DO JF=1,NSF
           IF (NOPR(JF).EQ.KNOP)  THEN
c            put the file species in the system
               JS = JS + 1
               IW(IoJFS+JS) = JF
               CHEM(JS) = CHEM(NSMAX+JF)
               RW(IoDHF0+JS) = SW(NSMAX+JF)
               RW(IoWMS+JS) = SW(NSMAX2+JF)
c            identify atoms in this species
               DO IF=1,NAF
                   IF (IW(IoNF+IF+LoNF*JF).NE.0) THEN
c                    file atom is in the species; identify system atom
                       DO IS=1,NA
                           IF (ATOM(IS).EQ.ATOM(NAMAX+IF))  GOTO 34
                           ENDDO
c                    atom not yet in system; add it
                       NA = NA + 1
                       IS = NA
                       ATOM(IS) = ATOM(NAMAX+IF)
c                    record the compostion
34                     IW(IoN+IS+LoN*JS) = IW(IoNF+IF+LoNF*JF)
                       ENDIF
                   ENDDO
               ENDIF
           ENDDO
c    check pass
       IF (KNOP.EQ.2)  THEN
c        set to do oxidizers
           KNOP = 1
           GOTO 32
           ENDIF
c    load the counts
       IW(IoNS) = JS
       IW(IoNSP+1) = JS
       IW(IoNA) = NA
c
c    reactant moles specification
       NIVM = 0
40     CALL GETZZ(NIVM,SETMVV,HELPVV,ACTMVV,NOPA)
       IF (NOPA.EQ.2) THEN
           NIVF = 1
           GOTO 30
           ENDIF
       IF (NOPA.EQ.3) THEN
           NIVR = 1
           GOTO 20
           ENDIF
c
c    compute the atom populations
       DO I=1,NA
           RW(IoPA+I) = 0
           DO J=1,NS
               RW(IoPA+I) = RW(IoPA+I) + IW(IoN+I+LoN*J)*RMOLS(J)
               ENDDO
           ENDDO
c
c    compute fuel mass / total mass
       TOTM= 0
       FUELM= 0
       IoWMF = NSMAX2
       DO JS=1,NS
           JFS = IW(IoJFS+JS)
           RMASS = RMOLS(JS)*SW(IoWMF+JFS)
           IF (NOPR(JFS).EQ.2)  FUELM = FUELM + RMASS
           TOTM = TOTM + RMASS
           ENDDO
       RFT = FUELM/TOTM
c
c    select products
       NIVP = 0
50     CALL GETZZ(NIVP,SETPVV,HELPVV,ACTPVV,NOPA)
       IF (NOPA.EQ.2) THEN
           DO J=1,NSF
               IF (NOPR(J).EQ.2) NOPR(J) = 1
               ENDDO
           NIVR = 1
           GOTO 20
           ENDIF
       IF (NOPA.EQ.3)  THEN
c        use another .SUD data file
           CALL  GFNEZZ('SUD',SUFILE)
           INQUIRE (FILE=SUFILE,EXIST=OK)
           IF (OK) THEN
                   CALL RSUDVV(8,SUFILE,OK)
               ELSE
                   CALL FMESVV(2,'@','#',
     ;               'Species data file # not found.@',SUFILE)
               ENDIF
           NIVP = 1
           GOTO 50
           ENDIF
c     check that all product species are gas
       DO J=1,NSF
           IF (NOPP(J).NE.0)  THEN
                IF (CFNGVV(J)) THEN
                    NOPP(J) = 0
                    NIVP = 1
                    GOTO 50
                    ENDIF
               ENDIF
           ENDDO
c
c    check products for atom content
       DO IS=1,NA
           ATOMZ(IS) = .FALSE.
           ENDDO
c    scan products
       DO JF=1,NSF
           IF (NOPP(JF).NE.0)  THEN
c            species included; check atoms
               DO IF=1,NAF
                   IF (IW(IoNF+IF+LoNF*JF).NE.0)  THEN
c                    atom in species; is it in the system?
                       CALL SJSCHA(NAMAX,ATOM(NAMAX+IF),ATOM,1,NA,IS)
                       IF (IS.NE.0)  THEN
c                            atom is in the system and products
                               ATOMZ(IS) = .TRUE.
                           ELSE
c                            atom not in the system; inform user
                               ML = 0
                               CALL LOADZZ('@Species ',9,LINE,ML)
                               CALL CHMNVV(CHEM(NSMAX+JF),N)
                               CALL LOADZZ(CHEM(NSMAX+JF),N,LINE,ML)
                               CALL LOADZZ(' contains atom ',15,LINE,ML)
                               CALL LOADZZ(ATOM(NAMAX+IF),2,LINE,ML)
                               CALL LOADZZ(' not in the reactants.@@',
     ;                                    24,LINE,ML)
                               CALL WARNZZ('@',LINE)
                               NIVP = 1
                               GOTO 50
                           ENDIF
                       ENDIF
                   ENDDO
               ENDIF
           ENDDO
c    check that all reactant atoms are represented
       DO IS=1,NA
           IF (.NOT.ATOMZ(IS)) THEN
c            an atom in the reactants is not in the products
               ML = 0
               CALL LOADZZ('@The products do not contain ',29,
     ;                      LINE,ML)
               CALL LOADZZ(ATOM(IS),2,LINE,ML)
               CALL LOADZZ(' atoms provided by the reactants.@@',35,
     ;                     LINE,ML)
               CALL WARNZZ('@',LINE)
               NIVP = 1
               GOTO 50
               ENDIF
           ENDDO
c
c    final data input
       NIVX = 0
60     CALL GETZZ(NIVX,SETXVV,HELPVV,ACTXVV,NOPA)
         IF (NOPA.EQ.2)  THEN
           NIVP = 1
           GOTO 50
           ENDIF
c
c    open the data fle
       CALL OPFLVV(10,DFILE,.FALSE.,.FALSE.,OK)
       IF (.NOT.OK)  THEN
           CLOSE(10)
           NIVX = 1
           GOTO 60
           ENDIF
c
c    make the Stanjan calculation
       KPASS = 1
100    IF (KPASS.EQ.1)  THEN
c            set for reactants
               RW(IoP) = PR*RW(IoPATM)
               IW(IoKFRZ) = - 1
               IW(IoNP) = 1
               DO JS=1,NS
                   CHEMJ(JS) = CHEM(JS)
                   RW(IoSMOL+JS) = RMOLS(JS)
                   ENDDO
           ELSE
c            set for products
               RW(IoP) = PP*RW(IoPATM)
               IW(IoKFRZ) = 0
c            clear atom composition
               DO J=1,NSMAX
                   DO I=1,NAMAX
                       IW(IoN+I+LoN*J) = 0
                       ENDDO
                   ENDDO
c            keep number of rectants
               NR = NS
c            set up product species in system
               NS = 0
               JS = 0
               DO JF=1,NSF
                   IF (NOPP(JF).NE.0) THEN
c                    put the file species in the system
                       JS = JS + 1
                       IW(IoJFS+JS) = JF
                       CHEM(JS) = CHEM(NSMAX+JF)
                       RW(IoDHF0+JS) = SW(NSMAX+JF)
                       RW(IoWMS+JS) = SW(NSMAX2+JF)
c                    add to the .ESJ data file specis
                       CHEMJ(NR+JS) = CHEM(JS)
c                    identify atoms in this species
                       DO IF=1,NAF
                           IF (IW(IoNF+IF+LoNF*JF).NE.0) THEN
c                            file atom is in the species; identify
                               DO IS=1,NA
                                   IF (ATOM(IS).EQ.ATOM(NAMAX+IF))
     ;                                 GOTO 134
                                   ENDDO
c                            atom not in system
                               CALL WARNZZ('@','@Program error; '//
     ;                           ' missing atom; inform program '//
     ;                           ' author.@@')
                               GOTO 20
c                            record the compostion
134                            IW(IoN+IS+LoN*JS) =
     ;                             IW(IoNF+IF+LoNF*JF)
                               ENDIF
                           ENDDO
                       ENDIF
                   ENDDO
               NS = JS
               NPROD = NS
               IW(IoNS) = NS
               IW(IoNSP+1) = JS
           ENDIF
c
c    make the calculation
       KINIT = 1
c    diagnostic monitor; normally KMON=0
       CALL OPFLVV(3,MONF,.FALSE.,.TRUE.,OK)
       IW(IoKUMO) = 3
       IW(IoKMON) = 0
c    loop point
        DO I=1,48
           RW(IoT) = 100 + 100*I
           CALL SJTP(NAMAX,NSMAX,NIW,NRW,NSW,ATOM,CHEM,IW,RW,SW,KINIT)
c        check for impossible populations
           IF (IW(IoKERR).EQ.3)  THEN
               IF (KPASS.EQ.1) THEN
                      CALL WARNZZ('@','@Program error; impossible '//
     ;                'reactant populations.  Inform program author.@@')
                       NIVR = 1
                       GOTO 20
                   ELSE
                       CALL WARNZZ('@','@The specified products '//
     ;                 'cannot contain all the atoms in the '//
     ;                 'reactants.  Change products.@@')
                   NIVP = 1
                   GOTO 50
                 ENDIF
               ENDIF
c
c        check for error
           IF (IW(IoKERR).NE.0)  THEN
c            calculation failed
               ML = 0
               CALL LOADZZ('@The calculation FAILED for T =',31,
     ;           LINE,ML)
               WRITE (TEMP,152) RW(IoT)
152            FORMAT(F6.0)
               CALL LOADZZ(TEMP,6,LINE,ML)
               CALL LOADZZ(' K.  Probable cause is poor product '//
     ;            ' species selection.@@',57,LINE,ML)
               CALL WARNZZ('@',LINE)
               NIVP = 1
               GOTO 50
               ENDIF
c
c        save the data
           IF (KPASS.EQ.1)  THEN
c                reactants
                   HR(I) = RW(IoH)
                   PVR(I) = RW(IoP)*RW(IoV)
               ELSE
c                products
                   HP(I) = RW(IoH)
                   PVP(I) = RW(IoP)*RW(IoV)
               ENDIF
           ENDDO
c
c    end of pass
       IF (KPASS.EQ.1)  THEN
c        go do reactants
           KPASS = 2
           GOTO 100
           ENDIF
c
c    write the data file
       CALL OPFLVV(10,DFILE,.FALSE.,.FALSE.,OK)
       IF (OK)  THEN
               CALL WTPFVV(10,IERR)
               IF (IERR.NE.0)  THEN
                       CALL FMESVV(2,'@','#',
     ;                  'Error writing #.  File corrupt.@',DFILE)
                   ELSE
                       CALL FMESVV(1,'@','#',
     ;                  'ESP properties data file # written.@',DFILE)
                   ENDIF
           ELSE
               CALL FMESVV(2,'@','#',
     ;           'Error opening #.  No file saved.@',DFILE)
           ENDIF
       CLOSE(10)
c
c    check for output file write
       IF (NOUT.EQ.2)  THEN
c        write display file
           CALL OPFLVV(10,OFILE,.FALSE.,.TRUE.,OK)
           IF (OK)  THEN
                   CALL DGPDVV(10)
                   CALL FMESVV(1,'@','#',
     ;              'Display file # written.@@',OFILE)
               ELSE
                   CALL FMESVV(1,'@','#',
     ;              'File # not written.@@',OFILE)
               ENDIF
           CLOSE(10)
           ENDIF
c
       NIVR = 1
       GOTO 20
c
c    exit
200    CLOSE(3)

       STOP
       END
c******************************************************************************
c
       LOGICAL FUNCTION CFNGVV(J)
c
c      Checks that file species J is a gas.  Returns .FALSE. if gas.
c      If condensed, sends message and returns  .TRUE.
c-----------------------------------------------------------------------------
c    Work array dimensioning
       INCLUDE 'ESPJWORK.H'
c------------------------------------------------------------------------------
       CHARACTER*64    LINE
c------------------------------------------------------------------------------
c    Stanjan data work arrays
       CHARACTER*8  CHEM(NSMAX2)
       COMMON /CHEMVV/CHEM
       REAL*4  SW(NSWORK)
       COMMON /SJSW/SW
c------------------------------------------------------------------------------
       IF (SW(J).EQ.0)  THEN
c        gas species
               CFNGVV = .FALSE.
c        non-gas species
           ELSE
               CALL CHMNVV(CHEM(NSMAX+J),N)
               ML = 0
               CALL LOADZZ('@',1,LINE,ML)
               CALL LOADZZ(CHEM(NSMAX+J),N,LINE,ML)
               CALL LOADZZ(' is not a gas species and '//
     ;             'cannot be included.@@',47,LINE,ML)
               CALL WARNZZ('@',LINE)
               CFNGVV = .TRUE.
           ENDIF
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE OPFLVV(IU,NAME,KE,KF,OK)
c
c      Opens file NAME on unit IU and returns OK=.TRUE. or writes problem
c      message.
c
c       KE  .TRUE. if file must exist
c       KF  .TRUE. if file is formatted
c-----------------------------------------------------------------------------
       LOGICAL         KE,KF,OK
       CHARACTER*32    NAME
c-----------------------------------------------------------------------------
c    check for existence
       IF (KE)  THEN
           INQUIRE (FILE=NAME,EXIST=OK)
           IF (.NOT.OK)  THEN
               CALL FMESVV(2,'@','#','File # not found@',NAME)
               RETURN
               ENDIF
           ENDIF
c    open the file
       IF (KF) THEN
               OPEN(IU,FILE=NAME,ERR=90)
           ELSE
               OPEN(IU,FILE=NAME,FORM='UNFORMATTED',ERR=90)
           ENDIF
       OK = .TRUE.
       RETURN
c    file open error
90     CALL FMESVV(2,'@','#','File # not opened. Probable '//
     ;     'cause; in use by other application.@',NAME)
       OK = .FALSE.
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE FMESVV(K,ESC,INS,STRING,NAME)
c
c      Issues message (K=1) or warning (K=2) ESC-terminated STRING with
c      file name inserted where INS is found.
c-----------------------------------------------------------------------------
       PARAMETER   (LNAME=32)
       PARAMETER   (LMAX=256)
       CHARACTER*1 ESC,INS,STRING(*),NAME(32),TEXT(LMAX)
c-----------------------------------------------------------------------------
c    find end of name
       DO I=1,LNAME
           IF (NAME(I).EQ.' ') THEN
               N = I - 1
               GOTO 8
               ENDIF
           ENDDO
c    no blanks
       N = LNAME
c    set to scan the string
8      LS = 0
       LT = 1
       TEXT(LT) = ESC
c    continue the scan
10     LS = LS + 1
       IF (STRING(LS).EQ.INS)  THEN
c        insert the name
           DO I=1,N
               IF (LT.EQ.LMAX-2)  GOTO 40
               LT = LT + 1
               TEXT(LT) = NAME(I)
               ENDDO
           GOTO 10
           ENDIF
       IF (STRING(LS).EQ.ESC)  GOTO 40
       IF (LT.EQ.LMAX-2)  GOTO 40
       LT = LT + 1
       TEXT(LT) = STRING(LS)
       GOTO 10
c    end the string
40     TEXT(LT+1) = ESC
       TEXT(LT+2) = ESC
c    send the message
       IF (K.EQ.1)  THEN
               CALL MESSZZ(ESC,TEXT)
               CALL PAUSZZ(0)
           ELSE
               CALL WARNZZ(ESC,TEXT)
           ENDIF
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE QUITVV
c
c      ESP close routine
c-----------------------------------------------------------------------------
       LOGICAL OUT,YESZZ
c------------------------------------------------------------------------------
c    confirm quit
       IF (YESZZ('Do you really want to quit ESPJAN?')) THEN
c        close the monitor file
           CLOSE(3)
           STOP
           ENDIF
c    no quit
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE STOPZZ
c
c      Stop routine
c------------------------------------------------------------------------------
c    close the monitor file
       CLOSE(3)
       STOP
       END
c******************************************************************************


MODULE trdtra
  USE oce
  USE dom_oce
  USE sbc_oce
  USE zdf_oce
  USE trd_oce
  USE trdtrc
  USE trdglo
  USE trdpen
  USE trdmxl
  USE ldftra
  USE ldfslp
  USE zdfddm
  USE phycst
  USE in_out_manager
  USE iom
  USE lib_mpp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: trd_tra
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: trdtx, trdty, trdt
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: avt_evd
  CONTAINS
  INTEGER FUNCTION trd_tra_alloc()
    ALLOCATE(trdtx(jpi, jpj, jpk), trdty(jpi, jpj, jpk), trdt(jpi, jpj, jpk), avt_evd(jpi, jpj, jpk), STAT = trd_tra_alloc)
    IF (lk_mpp) CALL mpp_sum(trd_tra_alloc)
    IF (trd_tra_alloc /= 0) CALL ctl_warn('trd_tra_alloc: failed to allocate arrays')
  END FUNCTION trd_tra_alloc
  SUBROUTINE trd_tra(kt, ctype, ktra, ktrd, ptrd, pun, ptra)
    INTEGER, INTENT(IN) :: kt
    CHARACTER(LEN = 3), INTENT(IN) :: ctype
    INTEGER, INTENT(IN) :: ktra
    INTEGER, INTENT(IN) :: ktrd
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN) :: ptrd
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN), OPTIONAL :: pun
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN), OPTIONAL :: ptra
    INTEGER :: jk
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: ztrds
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :, :) :: zwt, zws, ztrdt
    IF (.NOT. ALLOCATED(trdtx)) THEN
      IF (trd_tra_alloc() /= 0) CALL ctl_stop('STOP', 'trd_tra : unable to allocate arrays')
    END IF
    IF (ctype == 'TRA' .AND. ktra == jp_tem) THEN
      SELECT CASE (ktrd)
      CASE (jptra_xad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'X', trdtx)
      CASE (jptra_yad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Y', trdty)
      CASE (jptra_zad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Z', trdt)
      CASE (jptra_bbc, jptra_qsr)
        !$ACC KERNELS
        trdt(:, :, :) = ptrd(:, :, :) * tmask(:, :, :)
        ztrds(:, :, :) = 0._wp
        !$ACC END KERNELS
        CALL trd_tra_mng(trdt, ztrds, ktrd, kt)
      CASE (jptra_evd)
        !$ACC KERNELS
        avt_evd(:, :, :) = ptrd(:, :, :) * tmask(:, :, :)
        !$ACC END KERNELS
      CASE DEFAULT
        !$ACC KERNELS
        trdt(:, :, :) = ptrd(:, :, :) * tmask(:, :, :)
        !$ACC END KERNELS
      END SELECT
    END IF
    IF (ctype == 'TRA' .AND. ktra == jp_sal) THEN
      SELECT CASE (ktrd)
      CASE (jptra_xad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'X', ztrds)
        CALL trd_tra_mng(trdtx, ztrds, ktrd, kt)
      CASE (jptra_yad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Y', ztrds)
        CALL trd_tra_mng(trdty, ztrds, ktrd, kt)
      CASE (jptra_zad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Z', ztrds)
        CALL trd_tra_mng(trdt, ztrds, ktrd, kt)
      CASE (jptra_zdfp)
        ALLOCATE(zwt(jpi, jpj, jpk), zws(jpi, jpj, jpk), ztrdt(jpi, jpj, jpk))
        !$ACC KERNELS
        zwt(:, :, 1) = 0._wp
        zws(:, :, 1) = 0._wp
        zwt(:, :, jpk) = 0._wp
        zws(:, :, jpk) = 0._wp
        DO jk = 2, jpk
          zwt(:, :, jk) = avt(:, :, jk) * (tsa(:, :, jk - 1, jp_tem) - tsa(:, :, jk, jp_tem)) / e3w_n(:, :, jk) * tmask(:, :, jk)
          zws(:, :, jk) = avs(:, :, jk) * (tsa(:, :, jk - 1, jp_sal) - tsa(:, :, jk, jp_sal)) / e3w_n(:, :, jk) * tmask(:, :, jk)
        END DO
        ztrdt(:, :, jpk) = 0._wp
        ztrds(:, :, jpk) = 0._wp
        DO jk = 1, jpkm1
          ztrdt(:, :, jk) = (zwt(:, :, jk) - zwt(:, :, jk + 1)) / e3t_n(:, :, jk)
          ztrds(:, :, jk) = (zws(:, :, jk) - zws(:, :, jk + 1)) / e3t_n(:, :, jk)
        END DO
        !$ACC END KERNELS
        CALL trd_tra_mng(ztrdt, ztrds, jptra_zdfp, kt)
        !$ACC KERNELS
        zwt(:, :, :) = 0._wp
        zws(:, :, :) = 0._wp
        DO jk = 2, jpk
          zwt(:, :, jk) = avt_evd(:, :, jk) * (tsa(:, :, jk - 1, jp_tem) - tsa(:, :, jk, jp_tem)) / e3w_n(:, :, jk) * tmask(:, :, jk)
          zws(:, :, jk) = avt_evd(:, :, jk) * (tsa(:, :, jk - 1, jp_sal) - tsa(:, :, jk, jp_sal)) / e3w_n(:, :, jk) * tmask(:, :, jk)
        END DO
        ztrdt(:, :, jpk) = 0._wp
        ztrds(:, :, jpk) = 0._wp
        DO jk = 1, jpkm1
          ztrdt(:, :, jk) = (zwt(:, :, jk) - zwt(:, :, jk + 1)) / e3t_n(:, :, jk)
          ztrds(:, :, jk) = (zws(:, :, jk) - zws(:, :, jk + 1)) / e3t_n(:, :, jk)
        END DO
        !$ACC END KERNELS
        CALL trd_tra_mng(ztrdt, ztrds, jptra_evd, kt)
        DEALLOCATE(zwt, zws, ztrdt)
      CASE DEFAULT
        !$ACC KERNELS
        ztrds(:, :, :) = ptrd(:, :, :) * tmask(:, :, :)
        !$ACC END KERNELS
        CALL trd_tra_mng(trdt, ztrds, ktrd, kt)
      END SELECT
    END IF
    IF (ctype == 'TRC') THEN
      SELECT CASE (ktrd)
      CASE (jptra_xad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'X', ztrds)
      CASE (jptra_yad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Y', ztrds)
      CASE (jptra_zad)
        CALL trd_tra_adv(ptrd, pun, ptra, 'Z', ztrds)
      CASE DEFAULT
        !$ACC KERNELS
        ztrds(:, :, :) = ptrd(:, :, :) * tmask(:, :, :)
        !$ACC END KERNELS
      END SELECT
      CALL trd_trc(ztrds, ktra, ktrd, kt)
    END IF
  END SUBROUTINE trd_tra
  SUBROUTINE trd_tra_adv(pf, pun, ptn, cdir, ptrd)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pf
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pun
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: ptn
    CHARACTER(LEN = 1), INTENT(IN   ) :: cdir
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: ptrd
    INTEGER :: ji, jj, jk
    INTEGER :: ii, ij, ik
    SELECT CASE (cdir)
    CASE ('X')
      ii = 1
      ij = 0
      ik = 0
    CASE ('Y')
      ii = 0
      ij = 1
      ik = 0
    CASE ('Z')
      ii = 0
      ij = 0
      ik = - 1
    END SELECT
    !$ACC KERNELS
    ptrd(jpi, :, :) = 0._wp
    ptrd(1, :, :) = 0._wp
    ptrd(:, jpj, :) = 0._wp
    ptrd(:, 1, :) = 0._wp
    ptrd(:, :, jpk) = 0._wp
    DO jk = 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          ptrd(ji, jj, jk) = - (pf(ji, jj, jk) - pf(ji - ii, jj - ij, jk - ik) - (pun(ji, jj, jk) - pun(ji - ii, jj - ij, jk - ik)) * ptn(ji, jj, jk)) * r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE trd_tra_adv
  SUBROUTINE trd_tra_mng(ptrdx, ptrdy, ktrd, kt)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: ptrdx
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: ptrdy
    INTEGER, INTENT(IN   ) :: ktrd
    INTEGER, INTENT(IN   ) :: kt
    IF (neuler == 0 .AND. kt == nit000) THEN
      r2dt = rdt
    ELSE IF (kt <= nit000 + 1) THEN
      r2dt = 2. * rdt
    END IF
    IF (ln_tra_trd) CALL trd_tra_iom(ptrdx, ptrdy, ktrd, kt)
    IF (ln_glo_trd) CALL trd_glo(ptrdx, ptrdy, ktrd, 'TRA', kt)
    IF (ln_PE_trd) CALL trd_pen(ptrdx, ptrdy, ktrd, kt, r2dt)
    IF (ln_tra_mxl) THEN
      SELECT CASE (ktrd)
      CASE (jptra_xad)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_xad, '3D')
      CASE (jptra_yad)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_yad, '3D')
      CASE (jptra_zad)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_zad, '3D')
      CASE (jptra_ldf)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_ldf, '3D')
      CASE (jptra_bbl)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_bbl, '3D')
      CASE (jptra_zdf)
        IF (ln_traldf_iso) THEN
          CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_ldf, '3D')
        ELSE
          CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_zdf, '3D')
        END IF
      CASE (jptra_dmp)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_dmp, '3D')
      CASE (jptra_qsr)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_for, '3D')
      CASE (jptra_nsr)
        !$ACC KERNELS
        ptrdx(:, :, 2 : jpk) = 0._wp
        ptrdy(:, :, 2 : jpk) = 0._wp
        !$ACC END KERNELS
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_for, '2D')
      CASE (jptra_bbc)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_bbc, '3D')
      CASE (jptra_npc)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_npc, '3D')
      CASE (jptra_atf)
        CALL trd_mxl_zint(ptrdx, ptrdy, jpmxl_atf, '3D')
        CALL trd_mxl(kt, r2dt)
      END SELECT
    END IF
  END SUBROUTINE trd_tra_mng
  SUBROUTINE trd_tra_iom(ptrdx, ptrdy, ktrd, kt)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: ptrdx
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: ptrdy
    INTEGER, INTENT(IN   ) :: ktrd
    INTEGER, INTENT(IN   ) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: ikbu, ikbv
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :) :: z2dx, z2dy
    SELECT CASE (ktrd)
    CASE (jptra_tot)
      CALL iom_put("ttrd_tot", ptrdx)
      CALL iom_put("strd_tot", ptrdy)
    END SELECT
    IF (MOD(kt, 2) == 0) THEN
      SELECT CASE (ktrd)
      CASE (jptra_xad)
        CALL iom_put("ttrd_xad", ptrdx)
        CALL iom_put("strd_xad", ptrdy)
      CASE (jptra_yad)
        CALL iom_put("ttrd_yad", ptrdx)
        CALL iom_put("strd_yad", ptrdy)
      CASE (jptra_zad)
        CALL iom_put("ttrd_zad", ptrdx)
        CALL iom_put("strd_zad", ptrdy)
        IF (ln_linssh) THEN
          ALLOCATE(z2dx(jpi, jpj), z2dy(jpi, jpj))
          !$ACC KERNELS
          z2dx(:, :) = wn(:, :, 1) * tsn(:, :, 1, jp_tem) / e3t_n(:, :, 1)
          z2dy(:, :) = wn(:, :, 1) * tsn(:, :, 1, jp_sal) / e3t_n(:, :, 1)
          !$ACC END KERNELS
          CALL iom_put("ttrd_sad", z2dx)
          CALL iom_put("strd_sad", z2dy)
          DEALLOCATE(z2dx, z2dy)
        END IF
      CASE (jptra_totad)
        CALL iom_put("ttrd_totad", ptrdx)
        CALL iom_put("strd_totad", ptrdy)
      CASE (jptra_ldf)
        CALL iom_put("ttrd_ldf", ptrdx)
        CALL iom_put("strd_ldf", ptrdy)
      CASE (jptra_zdf)
        CALL iom_put("ttrd_zdf", ptrdx)
        CALL iom_put("strd_zdf", ptrdy)
      CASE (jptra_zdfp)
        CALL iom_put("ttrd_zdfp", ptrdx)
        CALL iom_put("strd_zdfp", ptrdy)
      CASE (jptra_evd)
        CALL iom_put("ttrd_evd", ptrdx)
        CALL iom_put("strd_evd", ptrdy)
      CASE (jptra_dmp)
        CALL iom_put("ttrd_dmp", ptrdx)
        CALL iom_put("strd_dmp", ptrdy)
      CASE (jptra_bbl)
        CALL iom_put("ttrd_bbl", ptrdx)
        CALL iom_put("strd_bbl", ptrdy)
      CASE (jptra_npc)
        CALL iom_put("ttrd_npc", ptrdx)
        CALL iom_put("strd_npc", ptrdy)
      CASE (jptra_bbc)
        CALL iom_put("ttrd_bbc", ptrdx)
      CASE (jptra_nsr)
        CALL iom_put("ttrd_qns", ptrdx(:, :, 1))
        CALL iom_put("strd_cdt", ptrdy(:, :, 1))
      CASE (jptra_qsr)
        CALL iom_put("ttrd_qsr", ptrdx)
      END SELECT
    ELSE IF (MOD(kt, 2) == 1) THEN
      SELECT CASE (ktrd)
      CASE (jptra_atf)
        CALL iom_put("ttrd_atf", ptrdx)
        CALL iom_put("strd_atf", ptrdy)
      END SELECT
    END IF
  END SUBROUTINE trd_tra_iom
END MODULE trdtra


module expt_syst

! use usefulbits_hs
 implicit none

 integer,parameter :: Nprod = 5
! ggH, VBF, WH, ZH, ttH
 integer,parameter :: Ndecay = 9
 integer,parameter :: Nsyst = 57
!  1: CMS H->gaga untagged 0-1 7 TeV event migration
!  2: CMS H->gaga untagged 1-2 7 TeV event migration
!  3: CMS H->gaga untagged 2-3 7 TeV event migration
!  4: CMS H->gaga untagged 0-1 8 TeV event migration
!  5: CMS H->gaga untagged 1-2 8 TeV event migration
!  6: CMS H->gaga untagged 2-3 8 TeV event migration
!  7: CMS H->gaga dijet 8 TeV event migration 0-1
!  8: Dijet tagging efficiency in dijet selection of CMS H->gaga analyses
!  9: ETmiss cut efficiency in ETmiss selection of CMS H->gaga analyses

! 10: ATLAS H->tautau ggH differential pT distribution and QCD scale
! 11: ATLAS H->tautau Top and Z->ll BG normalization (for hadlep and leplep channels)
! 12: ATLAS H->tautau hadronic tau identification and energy scale
! 13: ATLAS H->tautau JES eta calibration
! 14: ATLAS H->tautau Z->tautau normalization (for hadlep)
! 15: ATLAS H->tautau fake backgrounds (for leplep)
! 16: ATLAS H->tautau ditau(had) tagging efficiency

! 17: ATLAS H->gaga gg->H + (>2jets) cross section (affects VBF and VH(hadronic) channel)
! 18: ATLAS H->gaga gg->H + (3 jets) cross section (affect only VBF channels)
! 19: ATLAS H->gaga Underlying Event on gg->H yield
! 20: ATLAS H->gaga Underlying Event on ttH yield
! 21: ATLAS H->gaga pT spectrum modelling: migration between high- and low-pT categories of gg->H yield (central)
! 22: ATLAS H->gaga pT spectrum modelling: migration between high- and low-pT categories of gg->H yield (forward)
! 23: ATLAS H->gaga 2-jet Delta(Phi) angular distribution of gg->H in VBF categories
! 24: ATLAS H->gaga 2-jet Delta(Eta*) angular distribution of gg->H in VBF categories
! 25: ATLAS H->gaga gg->H contribution to ttH categories
! 26: ATLAS H->gaga heavy flavor fraction of gg->H, VBF, WH contribution to ttH categories
! 27: ATLAS H->gaga experimental: jet energy scale / resolution and vertex fraction
! 28: ATLAS H->gaga experimental: ETmiss energy scale and resolution
! 29: ATLAS H->gaga diphoton mass resolution (Tab. XII): Constant term
! 30: ATLAS H->gaga diphoton mass resolution (Tab. XII): Sampling term
! 31: ATLAS H->gaga diphoton mass resolution (Tab. XII): Material modeling
! 32: ATLAS H->gaga diphoton mass resolution (Tab. XII): Noise term
! 33: ATLAS H->gaga experimental: Photon Isolation (Tab. IX)
! 34: ATLAS H->gaga experimental: Photon ID (Tab. IX)
! 35: ATLAS H->gaga experimental: b-tagging efficiency
! 36: ATLAS H->gaga migration (not official): between VBF categories
! 37: ATLAS H->gaga migration (not official): between gg->H(forward) and VBF categories
! 38: ATLAS H->gaga unofficial VH error

! 39: CMS H->gaga untagged 3-4 8 TeV event migration
! 40: CMS H->gaga dijet 7 TeV event migration 0-1
! 41: CMS H->gaga dijet 8 TeV event migration 1-2
! 42: CMS H->gaga VH tight-loose migration 8 TeV
! 43: CMS H->gaga VH tight-loose common systematic 8 TeV
! 44: CMS H->gaga ttH(lepton)-VH tight migration
! 45: CMS H->gaga VH(loose)-VBF(dijet) migration
! 46: CMS H->gaga VBF(dijet2)-VH(ETmiss) migration
! 47: CMS H->gaga VH(ETmiss)-ttH multijet migration
! 48: CMS H->gaga ttH(multijet)-VH(dijet) migration
! 49: CMS H->gaga VH(dijet)-untagged migration
! 50: CMS H->gaga VBF uncertainty in untagged

! NEW 13 TeV results:
! CMS-16-020, H->gaga
! 51: UE and parton shower, jet energy scale/smearing: VBF-VBF Tag migration, 7% and 4-15%, respectively.
! 52: UE and parton shower, jet energy scale/smearing: VBF-untagged Tag migration, 9% and 4-15%, respectively.
! 53: Event migration untagged 0-1
! 54: Event migration untagged 1-2
! 55: Event migration untagged 2-3
! n.b: QCD scale uncertainty and energy scale/resolution, all categories, ~5-10% and ~6%, respectively. -> makes fit worse!
! 56: ggF contamination in VBF, ttH categories, ~39%
! 57: ggF contamination: VBF-VBF Tag migration, ~10%

 double precision :: rel_corr_err(2,0:Nprod,0:Ndecay,Nsyst)

! scaletype determines whether the systematic uncertainty is scaled with the
! observed (typical for BG uncertainties) [0] or with the predicted mu (typical
! for signal uncertainties) [1].
 integer :: scaletype(Nsyst)

 contains

 !------------------------------------------------
 subroutine fill_scaletype
 !------------------------------------------------
 ! Set scaletypes (default is scaling with predicted)
 scaletype(:)=1
 ! Set to 0 for mostly background-affecting systematics
 scaletype(11)=0
 scaletype(12)=0
 scaletype(13)=0
 scaletype(14)=0
 scaletype(15)=0
 scaletype(16)=0
 scaletype(27)=0
 scaletype(28)=0
 scaletype(29)=0
 scaletype(30)=0
 scaletype(31)=0
 scaletype(32)=0
 scaletype(33)=0
 scaletype(34)=0
 scaletype(35)=0
!  scaletype(53)=0

 end subroutine fill_scaletype
!------------------------------------------------
 subroutine fill_rel_corr_err(ID,N)
 !------------------------------------------------
  implicit none
   integer, intent(in) :: ID, N

  rel_corr_err(N,:,:,:) = 0.0D0

  select case(ID)
! ----------------------------------------------------------------------
! This is for an outdated CMS CONF-Note for H->gamma gamma, which should not
! be used in conjunction with the updated CMS results for this analysis (0558...)
! ----------------------------------------------------------------------
   case(13001107) ! untagged 0 7TeV
    rel_corr_err(N,:,1,1)=  +0.125D0
   case(13001108) ! untagged 1 7TeV
    rel_corr_err(N,:,1,1)=  -0.125D0
    rel_corr_err(N,:,1,2)=  +0.125D0
   case(13001109) ! untagged 2 7TeV
    rel_corr_err(N,:,1,2)=  -0.125D0
    rel_corr_err(N,:,1,3)=  +0.125D0
   case(13001110) ! untagged 3 7TeV
    rel_corr_err(N,:,1,3)=  -0.125D0
   case(13001111) ! untagged 0 8TeV
    rel_corr_err(N,:,1,4)=  +0.125D0
   case(13001112) ! untagged 1 8TeV
    rel_corr_err(N,:,1,4)=  -0.125D0
    rel_corr_err(N,:,1,5)=  +0.125D0
   case(13001113) ! untagged 2 8TeV
    rel_corr_err(N,:,1,5)=  -0.125D0
    rel_corr_err(N,:,1,6)=  +0.125D0
   case(13001114) ! untagged 3 8TeV
    rel_corr_err(N,:,1,6)=  -0.125D0
   case(13001105) ! CMS H->gaga dijet loose tagged categories (8 TeV)
    rel_corr_err(N,:,1,7)= + 0.15D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
   case(13001106) ! CMS H->gaga dijet tight tagged categories (8 TeV)
    rel_corr_err(N,:,1,7)= - 0.15D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.15D0
   case(12015103) ! CMS H->gaga dijet tagged category (7 TeV)
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
   case(13001102) ! CMS H->gaga ETmiss tagged categories
    rel_corr_err(N,1,1,9)=   0.15D0
    rel_corr_err(N,2,1,9)=   0.15D0
    rel_corr_err(N,3,1,9)=   0.04D0
    rel_corr_err(N,4,1,9)=   0.04D0
    rel_corr_err(N,5,1,9)=   0.04D0
! ----------------------------------------------------------------------
! updated (full LHC I run) CMS H->gamma gamma results
! partly using the same systematics than in older results
! ----------------------------------------------------------------------
   case(0558101) ! untagged 0 7TeV
    rel_corr_err(N,:,1,1)=  +0.2D0
   case(0558102) ! untagged 1 7TeV
    rel_corr_err(N,:,1,1)=  -0.2D0
    rel_corr_err(N,:,1,2)=  +0.2D0
   case(0558103) ! untagged 2 7TeV
    rel_corr_err(N,:,1,2)=  -0.2D0
    rel_corr_err(N,:,1,3)=  +0.2D0
   case(0558104) ! untagged 3 7TeV
    rel_corr_err(N,:,1,3)=  -0.2D0
   case(0558111) ! untagged 0 8TeV
    rel_corr_err(N,:,1,4)=  +0.2D0
   case(0558112) ! untagged 1 8TeV
    rel_corr_err(N,:,1,4)=  -0.2D0
    rel_corr_err(N,:,1,5)=  +0.2D0
   case(0558113) ! untagged 2 8TeV
    rel_corr_err(N,:,1,5)=  -0.2D0
    rel_corr_err(N,:,1,6)=  +0.2D0
   case(0558114) ! untagged 3 8TeV
    rel_corr_err(N,:,1,6)=  -0.2D0
    rel_corr_err(N,:,1,39)= +0.2D0
   case(0558115) !  untagged 4 8TeV
    rel_corr_err(N,:,1,39)= -0.2D0
   case(0558116) ! CMS H->gaga VBF dijet 0 categories (8 TeV)
    rel_corr_err(N,:,1,7)= + 0.3D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
    rel_corr_err(N,:,1,45)= -0.2D0
   case(0558117) ! CMS H->gaga VBF dijet 1 categories (8 TeV)
    rel_corr_err(N,:,1,7)= - 0.3D0
    rel_corr_err(N,:,1,41)= + 0.3D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.15D0
   case(0558118) ! CMS H->gaga VBF dijet 2 categories (8 TeV)
    rel_corr_err(N,:,1,41)= - 0.3D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.15D0
    rel_corr_err(N,:,1,46)= +0.2D0
   case(0558105) ! CMS H->gaga VBF dijet 0 categories (7 TeV)
    rel_corr_err(N,:,1,40)= + 0.15D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.05D0
    rel_corr_err(N,:,1,44)= +0.2D0
   case(0558106) ! CMS H->gaga VBF dijet 1 categories (7 TeV)
    rel_corr_err(N,:,1,40)= - 0.15D0
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.05D0
    rel_corr_err(N,:,1,44)= +0.2D0
   case(0558108) ! CMS H->gaga VH ETmiss 7 TeV
    rel_corr_err(N,1,1,9)=   0.15D0
    rel_corr_err(N,2,1,9)=   0.15D0
    rel_corr_err(N,3,1,9)=   0.04D0
    rel_corr_err(N,4,1,9)=   0.04D0
    rel_corr_err(N,5,1,9)=   0.04D0
   case(0558121) ! CMS H->gaga VH ETmiss 8 TeV
    rel_corr_err(N,1,1,9)=   0.15D0
    rel_corr_err(N,2,1,9)=   0.15D0
    rel_corr_err(N,3,1,9)=   0.04D0
    rel_corr_err(N,4,1,9)=   0.04D0
    rel_corr_err(N,5,1,9)=   0.04D0
    rel_corr_err(N,:,1,46)= -0.2D0
    rel_corr_err(N,:,1,47)= +0.2D0
   case(0558109) ! CMS H->gaga VH dijet 7 TeV
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
   case(0558110) ! CMS H->gaga ttH multijets 7 TeV
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
   case(0558122) ! CMS H->gaga VH dijet 8 TeV
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
    rel_corr_err(N,:,1,48)= +0.2D0
   case(0558124) ! CMS H->gaga ttH multijets 8 TeV
    rel_corr_err(N,1,1,8)= - 0.3D0
    rel_corr_err(N,2,1,8)= + 0.1D0
    rel_corr_err(N,:,1,47)= -0.2D0
    rel_corr_err(N,:,1,48)= +0.2D0
   case(0558119) ! CMS H->gaga VH tight
    rel_corr_err(N,:,1,42)= + 0.2D0
    rel_corr_err(N,:,1,43)= + 0.15D0
    rel_corr_err(N,:,1,44)= -0.2D0
   case(0558120) ! CMS H->gaga VH loose
    rel_corr_err(N,:,1,42)= - 0.2D0
    rel_corr_err(N,:,1,43)= + 0.15D0
    rel_corr_err(N,:,1,45)= +0.2D0
   case(0558123) ! CMS H->gaga ttH lepton
    rel_corr_err(N,:,1,44)= +0.2D0
! ----------------------------------------------------------------------
   case(2012160101,2014061101) ! ATL H->tautau leplep boosted category
    rel_corr_err(N,1,4,10)=   0.32D0
    rel_corr_err(N,:,4,11)=   0.15D0
!    rel_corr_err(N,2,4,13)=  -0.12D0
    rel_corr_err(N,:,4,15)=   0.12D0
   case(2012160102,2014061102) ! ATL H->tautau leplep VBF category
    rel_corr_err(N,1,4,10)=   0.08D0
    rel_corr_err(N,:,4,11)=   0.15D0
    rel_corr_err(N,:,4,13)=   0.12D0
!    rel_corr_err(N,2,4,13)=  -0.12D0
    rel_corr_err(N,:,4,15)=   0.12D0
   case(2012160103,2014061103) ! ATL H->tautau hadlep boosted category
    rel_corr_err(N,1,4,10)=   0.32D0
    rel_corr_err(N,:,4,11)=   0.15D0
    rel_corr_err(N,:,4,12)=   0.04D0
!    rel_corr_err(N,2,4,13)=  -0.12D0
    rel_corr_err(N,:,4,14)=   0.10D0
   case(2012160104,2014061104) ! ATL H->tautau hadlep VBF category
    rel_corr_err(N,1,4,10)=   0.08D0
    rel_corr_err(N,:,4,11)=   0.15D0
    rel_corr_err(N,:,4,12)=   0.04D0!
    rel_corr_err(N,:,4,13)=   0.12D0
!    rel_corr_err(N,2,4,13)=  -0.12D0
    rel_corr_err(N,:,4,14)=   0.10D0
   case(2012160105,2014061105) ! ATL H->tautau hadhad boosted category
    rel_corr_err(N,1,4,10)=   0.22D0
    rel_corr_err(N,:,4,12)=   0.12D0
!    rel_corr_err(N,2,4,13)=  -0.12D0
    rel_corr_err(N,:,4,16)=   0.07D0
   case(2012160106,2014061106) ! ATL H->tautau hadhad VBF category
    rel_corr_err(N,1,4,10)=  0.05D0
    rel_corr_err(N,:,4,12)=  0.12D0
    rel_corr_err(N,:,4,13)=  0.12D0
!    rel_corr_err(N,2,4,13)= -0.12D0
    rel_corr_err(N,:,4,16)=  0.07D0
!---NEW SUMMER 2014 results
   case(7084101) ! ATLAS H->gaga central low-pT
    rel_corr_err(N,1,1,17)=  -0.10D0 ! n.b.: not official, guess of migration to VBF/VH(had) categories (>2jet)
    rel_corr_err(N,1,1,19)=  -0.05D0 ! n.b.: not official, guess of migration due to UE
    rel_corr_err(N,1,1,21)=  0.24D0
    rel_corr_err(N,1,1,27)=  0.001D0
    rel_corr_err(N,2,1,27)=  0.029D0
    rel_corr_err(N,3,1,27)=  0.001D0
    rel_corr_err(N,4,1,27)=  0.001D0
    rel_corr_err(N,5,1,27)=  0.04D0
    rel_corr_err(N,3,1,28)=  0.001D0
    rel_corr_err(N,4,1,28)=  0.002D0
    rel_corr_err(N,5,1,28)=  0.002D0
    rel_corr_err(N,:,1,29)=  0.075D0
    rel_corr_err(N,:,1,30)=  0.026D0
    rel_corr_err(N,:,1,31)=  0.049D0
    rel_corr_err(N,:,1,32)=  0.026D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,37)=  -0.50D0 ! n.B.: not official, trying migration between VBF categories
!    rel_corr_err(N,1,1,39)=  0.15D0 ! n.B.: overall gg->H uncertainty in untagged categories
   case(7084102) ! ATLAS H->gaga central high-pT
    rel_corr_err(N,1,1,17)=  -0.10D0 ! n.b.: not official, guess of migration to VBF/VH(had) categories (>2jet)
    rel_corr_err(N,1,1,19)=  -0.05D0 ! n.b.: not official, guess of migration due to UE
    rel_corr_err(N,1,1,21)=  -0.24D0
    rel_corr_err(N,1,1,27)=  0.011D0
    rel_corr_err(N,2,1,27)=  0.045D0
    rel_corr_err(N,3,1,27)=  0.014D0
    rel_corr_err(N,4,1,27)=  0.014D0
    rel_corr_err(N,5,1,27)=  0.035D0
    rel_corr_err(N,3,1,28)=  0.001D0
    rel_corr_err(N,4,1,28)=  0.002D0
    rel_corr_err(N,5,1,28)=  0.002D0
    rel_corr_err(N,:,1,29)=  0.096D0
    rel_corr_err(N,:,1,30)=  0.056D0
    rel_corr_err(N,:,1,31)=  0.062D0
    rel_corr_err(N,:,1,32)=  0.017D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,37)=  -0.500D0 ! n.B.: not official, trying migration between VBF categories
!    rel_corr_err(N,1,1,39)=  0.15D0 ! n.B.: overall gg->H uncertainty in untagged categories
   case(7084103) ! ATLAS H->gaga forward low-pT
    rel_corr_err(N,1,1,17)=  -0.15D0 ! n.b.: not official, guess of migration to VBF/VH(had) categories  (>2jet)
    rel_corr_err(N,1,1,18)=  -0.10D0   ! n.b.: not official, guess of migration to VBF categories (3jet)
    rel_corr_err(N,1,1,19)=  -0.05D0 ! n.b.: not official, guess of migration due to UE
    rel_corr_err(N,1,1,22)=  0.24D0
    rel_corr_err(N,1,1,27)=  0.001D0
    rel_corr_err(N,2,1,27)=  0.029D0
    rel_corr_err(N,3,1,27)=  0.001D0
    rel_corr_err(N,4,1,27)=  0.001D0
    rel_corr_err(N,5,1,27)=  0.04D0
    rel_corr_err(N,3,1,28)=  0.001D0
    rel_corr_err(N,4,1,28)=  0.002D0
    rel_corr_err(N,5,1,28)=  0.002D0
    rel_corr_err(N,:,1,29)=  0.099D0
    rel_corr_err(N,:,1,30)=  0.013D0
    rel_corr_err(N,:,1,31)=  0.060D0
    rel_corr_err(N,:,1,32)=  0.021D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,37)=  -0.300D0 ! n.B.: not official, trying migration between VBF categories
!    rel_corr_err(N,1,1,39)=  0.15D0 ! n.B.: overall gg->H uncertainty in untagged categories
   case(7084104) ! ATLAS H->gaga forward high-pT
    rel_corr_err(N,1,1,17)=  -0.15D0 ! n.b.: not official, guess of migration to VBF/VH(had) categories (>2jet)
    rel_corr_err(N,1,1,18)=  -0.10D0   ! n.b.: not official, guess of migration to VBF categories (3jet)
    rel_corr_err(N,1,1,19)=  -0.05D0 ! n.b.: not official, guess of migration due to UE
    rel_corr_err(N,1,1,22)=  -0.24D0
    rel_corr_err(N,1,1,27)=  0.011D0
    rel_corr_err(N,2,1,27)=  0.045D0
    rel_corr_err(N,3,1,27)=  0.014D0
    rel_corr_err(N,4,1,27)=  0.014D0
    rel_corr_err(N,5,1,27)=  0.035D0
    rel_corr_err(N,3,1,28)=  0.001D0
    rel_corr_err(N,4,1,28)=  0.002D0
    rel_corr_err(N,5,1,28)=  0.002D0
    rel_corr_err(N,:,1,29)=  0.120D0
    rel_corr_err(N,:,1,30)=  0.028D0
    rel_corr_err(N,:,1,31)=  0.078D0
    rel_corr_err(N,:,1,32)=  0.019D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,37)=  -0.300D0 ! n.B.: not official, trying migration between VBF categories
!    rel_corr_err(N,1,1,39)=  0.15D0 ! n.B.: overall gg->H uncertainty in untagged categories
   case(7084105) ! ATLAS H->gaga VBF loose
    rel_corr_err(N,1,1,17)=  0.20D0
    rel_corr_err(N,1,1,18)=  0.25D0
    rel_corr_err(N,1,1,19)=  0.06D0
    rel_corr_err(N,1,1,23)=  0.089D0
    rel_corr_err(N,1,1,24)=  0.048D0
    rel_corr_err(N,1,1,27)=  0.120D0
    rel_corr_err(N,2,1,27)=  0.044D0
    rel_corr_err(N,3,1,27)=  0.130D0
    rel_corr_err(N,4,1,27)=  0.130D0
    rel_corr_err(N,5,1,27)=  0.076D0
    rel_corr_err(N,3,1,28)=  0.001D0
    rel_corr_err(N,4,1,28)=  0.002D0
    rel_corr_err(N,5,1,28)=  0.010D0
    rel_corr_err(N,:,1,29)=  0.094D0
    rel_corr_err(N,:,1,30)=  0.026D0
    rel_corr_err(N,:,1,31)=  0.060D0
    rel_corr_err(N,:,1,32)=  0.021D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,36)=  0.500D0 ! n.B.: not official, add theory error for VBF
    rel_corr_err(N,2,1,37)=  0.250D0 ! n.B.: not official, trying migration between VBF categories
   case(7084106) ! ATLAS H->gaga VBF tight
    rel_corr_err(N,1,1,17)=  0.20D0
    rel_corr_err(N,1,1,18)=  0.52D0
    rel_corr_err(N,1,1,19)=  0.06D0
    rel_corr_err(N,1,1,23)=  0.112D0
    rel_corr_err(N,1,1,24)=  0.066D0
    rel_corr_err(N,1,1,27)=  0.130D0
    rel_corr_err(N,2,1,27)=  0.091D0
    rel_corr_err(N,3,1,27)=  0.170D0
    rel_corr_err(N,4,1,27)=  0.170D0
    rel_corr_err(N,5,1,27)=  0.063D0
    rel_corr_err(N,3,1,28)=  0.011D0
    rel_corr_err(N,5,1,28)=  0.027D0
    rel_corr_err(N,:,1,29)=  0.100D0
    rel_corr_err(N,:,1,30)=  0.038D0
    rel_corr_err(N,:,1,31)=  0.065D0
    rel_corr_err(N,:,1,32)=  0.021D0
    rel_corr_err(N,:,1,33)=  0.023D0
    rel_corr_err(N,:,1,34)=  0.010D0
    rel_corr_err(N,2,1,36)=  0.500D0 ! n.B.: not official, add theory error for VBF
    rel_corr_err(N,2,1,37)=  0.250D0 ! n.B.: not official, trying migration between VBF categories
   case(7084107) ! ATLAS H->gaga VH hadronic
    rel_corr_err(N,1,1,17)=  0.20D0
    rel_corr_err(N,1,1,27)=  0.028D0
    rel_corr_err(N,2,1,27)=  0.041D0
    rel_corr_err(N,3,1,27)=  0.025D0
    rel_corr_err(N,4,1,27)=  0.025D0
    rel_corr_err(N,5,1,27)=  0.095D0
    rel_corr_err(N,4,1,28)=  0.001D0
    rel_corr_err(N,5,1,28)=  0.007D0
    rel_corr_err(N,:,1,29)=  0.110D0
    rel_corr_err(N,:,1,30)=  0.040D0
    rel_corr_err(N,:,1,31)=  0.072D0
    rel_corr_err(N,:,1,32)=  0.016D0
    rel_corr_err(N,:,1,33)=  0.038D0
    rel_corr_err(N,:,1,34)=  0.041D0
    rel_corr_err(N,1,1,35)= -0.15D0 ! n.b.: not official, guess of migration due to b-tagging uncertainty
    rel_corr_err(N,3,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
    rel_corr_err(N,4,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
   case(7084108) ! ATLAS H->gaga VH ETmiss
    rel_corr_err(N,1,1,27)=  0.026D0
    rel_corr_err(N,2,1,27)=  0.090D0
    rel_corr_err(N,3,1,27)=  0.002D0
    rel_corr_err(N,4,1,27)=  0.002D0
    rel_corr_err(N,5,1,27)=  0.012D0
    rel_corr_err(N,1,1,28)= -0.35D0
    rel_corr_err(N,2,1,28)= -0.35D0
    rel_corr_err(N,3,1,28)= -0.013D0
    rel_corr_err(N,4,1,28)= -0.009D0
    rel_corr_err(N,5,1,28)= -0.011D0
    rel_corr_err(N,:,1,29)=  0.110D0
    rel_corr_err(N,:,1,30)=  0.036D0
    rel_corr_err(N,:,1,31)=  0.074D0
    rel_corr_err(N,:,1,32)=  0.017D0
    rel_corr_err(N,:,1,33)=  0.038D0
    rel_corr_err(N,:,1,34)=  0.041D0
    rel_corr_err(N,3,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
    rel_corr_err(N,4,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
   case(7084109) ! ATLAS H->gaga VH one-lepton
    rel_corr_err(N,1,1,27)=  0.049D0
    rel_corr_err(N,2,1,27)=  0.062D0
    rel_corr_err(N,3,1,27)=  0.005D0
    rel_corr_err(N,4,1,27)=  0.005D0
    rel_corr_err(N,5,1,27)=  0.028D0
    rel_corr_err(N,1,1,28)=  0.045D0
    rel_corr_err(N,2,1,28)=  0.045D0
    rel_corr_err(N,3,1,28)=  0.004D0
    rel_corr_err(N,4,1,28)=  0.040D0
    rel_corr_err(N,5,1,28)=  0.006D0
    rel_corr_err(N,:,1,29)=  0.098D0
    rel_corr_err(N,:,1,30)=  0.028D0
    rel_corr_err(N,:,1,31)=  0.063D0
    rel_corr_err(N,:,1,32)=  0.021D0
    rel_corr_err(N,:,1,33)=  0.038D0
    rel_corr_err(N,:,1,34)=  0.041D0
    rel_corr_err(N,3,1,35)= -0.05D0 ! n.b.: not official, guess of migration due to b-tagging uncertainty
    rel_corr_err(N,3,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
    rel_corr_err(N,4,1,38)=  0.50D0  !n.b.: not official, added theory error on VH
   case(7084110) ! ATLAS H->gaga ttH hadronic
    rel_corr_err(N,1,1,19)=  0.60D0
    rel_corr_err(N,5,1,20)=  0.11D0
    rel_corr_err(N,1,1,25)=  0.50D0
    rel_corr_err(N,1,1,26)=  1.00D0
    rel_corr_err(N,1,2,26)=  1.00D0
    rel_corr_err(N,1,3,26)=  1.00D0
    rel_corr_err(N,1,1,27)=  0.11D0
    rel_corr_err(N,2,1,27)=  0.21D0
    rel_corr_err(N,3,1,27)=  0.22D0
    rel_corr_err(N,4,1,27)=  0.22D0
    rel_corr_err(N,5,1,27)=  0.073D0
    rel_corr_err(N,:,1,29)=  0.096D0
    rel_corr_err(N,:,1,30)=  0.036D0
    rel_corr_err(N,:,1,31)=  0.063D0
    rel_corr_err(N,:,1,32)=  0.019D0
    rel_corr_err(N,:,1,33)=  0.038D0
    rel_corr_err(N,:,1,34)=  0.041D0
    rel_corr_err(N,1,1,35)=  0.30D0
   case(7084111) ! ATLAS H->gaga ttH leptonic
    rel_corr_err(N,5,1,20)=  0.03D0
    rel_corr_err(N,1,1,25)=  0.50D0
    rel_corr_err(N,1,1,26)=  1.00D0
    rel_corr_err(N,1,2,26)=  1.00D0
    rel_corr_err(N,1,3,26)=  1.00D0
    rel_corr_err(N,1,1,27)=  0.37D0
    rel_corr_err(N,2,1,27)=  0.077D0
    rel_corr_err(N,3,1,27)=  0.074D0
    rel_corr_err(N,4,1,27)=  0.074D0
    rel_corr_err(N,5,1,27)=  0.005D0
    rel_corr_err(N,1,1,28)=  0.019D0
    rel_corr_err(N,2,1,28)=  0.019D0
    rel_corr_err(N,3,1,28)=  0.010D0
    rel_corr_err(N,4,1,28)=  0.030D0
    rel_corr_err(N,5,1,28)=  0.001D0
    rel_corr_err(N,:,1,29)=  0.095D0
    rel_corr_err(N,:,1,30)=  0.034D0
    rel_corr_err(N,:,1,31)=  0.062D0
    rel_corr_err(N,:,1,32)=  0.021D0
    rel_corr_err(N,:,1,33)=  0.038D0
    rel_corr_err(N,:,1,34)=  0.041D0
    rel_corr_err(N,3,1,35)=  0.07D0
! LHC 13 TeV results
! CMS H-gaga, CMS-16-020:
! 51: UE and parton shower, jet energy scale/smearing: VBF-VBF Tag migration, 7% and 4-15%, respectively.
! 52: UE and parton shower, jet energy scale/smearing: VBF-untagged Tag migration, 9% and 4-15%, respectively.
! 53: Event migration untagged 0-1
! 54: Event migration untagged 1-2
! 55: Event migration untagged 2-3
! n.b: QCD scale uncertainty and energy scale/resolution, all categories, ~5-10% and ~6%, respectively. -> makes fit worse!
! 56: ggF contamination in VBF, ttH categories, ~39%
! 57: ggF contamination: VBF-VBF Tag migration, ~10%
   case(1602011) ! untagged 0
!     rel_corr_err(N,1,1,52)=  -0.24D0
    rel_corr_err(N,2,1,52)=  +0.10D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,:,1,53)=  +0.10D0
   case(1602012) ! untagged 1
!     rel_corr_err(N,1,1,52)=  -0.24D0
    rel_corr_err(N,2,1,52)=  +0.05D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,:,1,53)=  -0.10D0
    rel_corr_err(N,:,1,54)=  +0.10D0
   case(1602013) ! untagged 2
!     rel_corr_err(N,1,1,52)=  -0.24D0
    rel_corr_err(N,2,1,52)=  +0.05D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,:,1,54)=  -0.10D0
    rel_corr_err(N,:,1,55)=  +0.10D0
   case(1602014) ! untagged 3
!     rel_corr_err(N,1,1,52)=  -0.24D0
    rel_corr_err(N,2,1,52)=  +0.05D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,:,1,55)=  -0.10D0
   case(1602015) ! VBF tag 0
    rel_corr_err(N,:,1,51)=  +0.10D0
!     rel_corr_err(N,2,1,51)=  -0.22D0
    rel_corr_err(N,2,1,52)=  -0.10D0
!     rel_corr_err(N,2,1,52)=  -0.24D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,1,1,56)=  +0.39D0
    rel_corr_err(N,1,1,57)=  +0.10D0
   case(1602016) ! VBF tag 1
    rel_corr_err(N,:,1,51)=  -0.10D0
!     rel_corr_err(N,2,1,51)=  +0.22D0
!    rel_corr_err(N,1,1,52)=  +0.24D0
    rel_corr_err(N,:,1,52)=  -0.15D0
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,1,1,56)=  +0.39D0
    rel_corr_err(N,1,1,57)=  -0.10D0
   case(1602017) ! TTH tag hadr
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,1,1,56)=  +0.39D0
   case(1602018) ! TTH tag lept
!     rel_corr_err(N,:,1,53)=  +0.10D0
    rel_corr_err(N,1,1,56)=  +0.39D0
   case default

  end select

 end subroutine fill_rel_corr_err
!------------------------------------------------
 subroutine get_expt_syst_corr_for_peaks(value, peak1, mu1, peak2, mu2, model)
!------------------------------------------------
  use usefulbits_hs, only : mupeak, print_dble_matrix
  implicit none

  type(mupeak), intent(in) :: peak1, peak2
  integer, intent(in) :: model
  double precision, intent(in) :: mu1, mu2 ! observed mu
  double precision, intent(out) :: value

  integer :: id1, p1, d1, id2, p2, d2
  integer :: i,j,k

  call fill_rel_corr_err(peak1%id,1)
  call fill_rel_corr_err(peak2%id,2)

!  if(peak1%id.eq.13001105.and.peak2%id.eq.13001106) then
!  write(*,*)'#-------------- ',peak1%id,' --------------#'
!  do k=1,Nprod
!   write(*,*) rel_corr_err(1,k,1,:)
!  enddo
!  write(*,*)'#-------------- ',peak2%id,' --------------#'
!  do k=1,Nprod
!   write(*,*) rel_corr_err(2,k,1,:)
!  enddo
!  endif

  value = 0.0D0

  do i=lbound(peak1%channel_id,dim=1),ubound(peak1%channel_id,dim=1)
   do j=lbound(peak2%channel_id,dim=1),ubound(peak2%channel_id,dim=1)
    id1 = peak1%channel_id(i)
    p1 = int((id1-modulo(id1,10))/dble(10))
    d1 = modulo(id1,10)
    id2 = peak2%channel_id(j)
    p2 = int((id2-modulo(id2,10))/dble(10))
    d2 = modulo(id2,10)

!  if(peak1%id.eq.13001105.and.peak2%id.eq.13001106) then
!   write(*,*) id1, p1, d1, id2, p2, d2
!   write(*,*) value
!  endif

    do k=1,Nsyst
     if(model.eq.1) then
      if(scaletype(k).eq.1) then
       value = value + &
&            peak1%channel_w_model(i)*rel_corr_err(1,p1,d1,k)*peak1%total_mu* &
&            peak2%channel_w_model(j)*rel_corr_err(2,p2,d2,k)*peak2%total_mu
      elseif(scaletype(k).eq.0) then
             value = value + &
&            peak1%channel_w(i)*rel_corr_err(1,p1,d1,k)*mu1* &
&            peak2%channel_w(j)*rel_corr_err(2,p2,d2,k)*mu2
      else
       write(*,*) "WARNING in get_expt_syst_corr_for peaks: Unknown scaletype of ",k
      endif
     else
     value = value + &
&            peak1%channel_w(i)*rel_corr_err(1,p1,d1,k)*mu1* &
&            peak2%channel_w(j)*rel_corr_err(2,p2,d2,k)*mu2
     endif
    enddo
   enddo
  enddo

!  if(abs(value).ge.0.0000001D0) then
!   write(*,*) "Non-zero correlated systematics:", peak1%id, peak2%id, mu1, mu2, value
!   write(*,*) "1st weights: ",peak1%channel_w_model
!   do k=1,Nprod
!    write(*,*) rel_corr_err(1,k,1,:)
!   enddo
!   write(*,*) "2nd weights: ",peak2%channel_w_model
!   do k=1,Nprod
!    write(*,*) rel_corr_err(2,k,1,:)
!   enddo
!
!  if(peak1%id.eq.13001105.and.peak2%id.eq.13001105) write(22,*) value
!  if(peak1%id.eq.13001106.and.peak2%id.eq.13001106) write(23,*) value, peak1%channel_w_model(1)*mu1
!  if(peak1%id.eq.12015103.and.peak2%id.eq.12015103) write(24,*) value, peak1%channel_w_model(1)*mu1
!  if(peak1%id.eq.13001105.and.peak2%id.eq.13001106) write(25,*) value
!  if(peak1%id.eq.12015103.and.peak2%id.eq.13001106) write(26,*) value

 end subroutine get_expt_syst_corr_for_peaks
!------------------------------------------------
end module


      module module_data_cbmz
      integer nfixed_kppmax
      parameter (nfixed_kppmax = 20)
      integer nreact_kppmax
      parameter (nreact_kppmax = 256)
      real avognumkpp
      parameter (avognumkpp = 6.02252e23)
      integer nvar_r01_kpp, nfix_r01_kpp, nreact_r01_kpp, &
              lu_nonzero_v_r01_kpp
      parameter ( nvar_r01_kpp = 28 )
      parameter ( nfix_r01_kpp = 5 )
      parameter ( nreact_r01_kpp = 74 )
      parameter ( lu_nonzero_v_r01_kpp = 194 )
      integer nvar_r02_kpp, nfix_r02_kpp, nreact_r02_kpp, &
              lu_nonzero_v_r02_kpp
      parameter ( nvar_r02_kpp = 48 )
      parameter ( nfix_r02_kpp = 5 )
      parameter ( nreact_r02_kpp = 118 )
      parameter ( lu_nonzero_v_r02_kpp = 459 )
      integer nvar_r03_kpp, nfix_r03_kpp, nreact_r03_kpp, &
              lu_nonzero_v_r03_kpp
      parameter ( nvar_r03_kpp = 53 )
      parameter ( nfix_r03_kpp = 5 )
      parameter ( nreact_r03_kpp = 134 )
      parameter ( lu_nonzero_v_r03_kpp = 564 )
      integer nvar_r04_kpp, nfix_r04_kpp, nreact_r04_kpp, &
              lu_nonzero_v_r04_kpp
      parameter ( nvar_r04_kpp = 39 )
      parameter ( nfix_r04_kpp = 5 )
      parameter ( nreact_r04_kpp = 106 )
      parameter ( lu_nonzero_v_r04_kpp = 334 )
      integer nvar_r05_kpp, nfix_r05_kpp, nreact_r05_kpp, &
              lu_nonzero_v_r05_kpp
      parameter ( nvar_r05_kpp = 59 )
      parameter ( nfix_r05_kpp = 5 )
      parameter ( nreact_r05_kpp = 150 )
      parameter ( lu_nonzero_v_r05_kpp = 606 )
      integer nvar_r06_kpp, nfix_r06_kpp, nreact_r06_kpp, &
              lu_nonzero_v_r06_kpp
      parameter ( nvar_r06_kpp = 64 )
      parameter ( nfix_r06_kpp = 5 )
      parameter ( nreact_r06_kpp = 166 )
      parameter ( lu_nonzero_v_r06_kpp = 715 )
      integer &
        ino_z, ino2_z, ino3_z, &
        in2o5_z, ihono_z, ihno3_z, &
        ihno4_z, io3_z, io1d_z, &
        io3p_z, ioh_z, iho2_z, &
        ih2o2_z, ico_z, iso2_z, &
        ih2so4_z, inh3_z, ihcl_z, &
        ich4_z, ic2h6_z, ich3o2_z, &
        iethp_z, ihcho_z, ich3oh_z, &
        ic2h5oh_z, ich3ooh_z, iethooh_z, &
        iald2_z, ihcooh_z, ipar_z, &
        iaone_z, imgly_z, ieth_z, &
        iolet_z, iolei_z, itol_z, &
        ixyl_z, icres_z, ito2_z, &
        icro_z, iopen_z, ionit_z, &
        ipan_z, ircooh_z, irooh_z, &
        ic2o3_z, iro2_z, iano2_z, &
        inap_z, ixo2_z, ixpar_z, &
        iisop_z, iisoprd_z, iisopp_z, &
        iisopn_z, iisopo2_z, idms_z, &
        imsa_z, idmso_z, idmso2_z, &
        ich3so2h_z, ich3sch2oo_z, ich3so2_z, &
        ich3so3_z, ich3so2oo_z, ich3so2ch2oo_z, &
        imtf_z, &
        ih2o_z, io2_z, in2_z, &
        ih2_z
      parameter ( &
        ino_z=01, ino2_z=02, ino3_z=03, &
        in2o5_z=04, ihono_z=05, ihno3_z=06, &
        ihno4_z=07, io3_z=08, io1d_z=09, &
        io3p_z=10, ioh_z=11, iho2_z=12, &
        ih2o2_z=13, ico_z=14, iso2_z=15, &
        ih2so4_z=16, inh3_z=17, ihcl_z=18, &
        ich4_z=19, ic2h6_z=20, ich3o2_z=21, &
        iethp_z=22, ihcho_z=23, ich3oh_z=24, &
        ic2h5oh_z=25, ich3ooh_z=26, iethooh_z=27, &
        iald2_z=28, ihcooh_z=29, ipar_z=30, &
        iaone_z=31, imgly_z=32, ieth_z=33, &
        iolet_z=34, iolei_z=35, itol_z=36, &
        ixyl_z=37, icres_z=38, ito2_z=39, &
        icro_z=40, iopen_z=41, ionit_z=42, &
        ipan_z=43, ircooh_z=44, irooh_z=45, &
        ic2o3_z=46, iro2_z=47, iano2_z=48, &
        inap_z=49, ixo2_z=50, ixpar_z=51, &
        iisop_z=52, iisoprd_z=53, iisopp_z=54, &
        iisopn_z=55, iisopo2_z=56, idms_z=57, &
        imsa_z=58, idmso_z=59, idmso2_z=60, &
        ich3so2h_z=61, ich3sch2oo_z=62, ich3so2_z=63, &
        ich3so3_z=64, ich3so2oo_z=65, ich3so2ch2oo_z=66, &
        imtf_z=67, &
        ih2o_z=68, io2_z=69, in2_z=70, &
        ih2_z=71 )
      integer ngas_z
      parameter (ngas_z=71)
      character(len=12), save :: name_z(ngas_z) = (/ &
        'no          ', 'no2         ', 'no3         ', &
        'n2o5        ', 'hono        ', 'hno3        ', &
        'hno4        ', 'o3          ', 'o1d         ', &
        'o3p         ', 'oh          ', 'ho2         ', &
        'h2o2        ', 'co          ', 'so2         ', &
        'h2so4       ', 'nh3         ', 'hcl         ', &
        'ch4         ', 'c2h6        ', 'ch3o2       ', &
        'ethp        ', 'hcho        ', 'ch3oh       ', &
        'c2h5oh      ', 'ch3ooh      ', 'ethooh      ', &
        'ald2        ', 'hcooh       ', 'par         ', &
        'aone        ', 'mgly        ', 'eth         ', &
        'olet        ', 'olei        ', 'tol         ', &
        'xyl         ', 'cres        ', 'to2         ', &
        'cro         ', 'open        ', 'onit        ', &
        'pan         ', 'rcooh       ', 'rooh        ', &
        'c2o3        ', 'ro2         ', 'ano2        ', &
        'nap         ', 'xo2         ', 'xpar        ', &
        'isop        ', 'isoprd      ', 'isopp       ', &
        'isopn       ', 'isopo2      ', 'dms         ', &
        'msa         ', 'dmso        ', 'dmso2       ', &
        'ch3so2h     ', 'ch3sch2oo   ', 'ch3so2      ', &
        'ch3so3      ', 'ch3so2oo    ', 'ch3so2ch2oo ', &
        'mtf         ', &
        'h2o         ', 'o2          ', 'n2          ', &
        'h2          ' /)
      integer &
       jphoto_no2, jphoto_no3, jphoto_hono, &
       jphoto_hno3, jphoto_hno4, jphoto_n2o5, &
       jphoto_o3a, jphoto_o3b, jphoto_h2o2, &
       jphoto_hchoa, jphoto_hchob, jphoto_ch3ooh, &
       jphoto_ethooh, jphoto_ald2, jphoto_aone, &
       jphoto_mgly, jphoto_open, jphoto_rooh, &
       jphoto_onit, jphoto_isoprd
      parameter ( &
       jphoto_no2=1, jphoto_no3=2, jphoto_hono=3, &
       jphoto_hno3=4, jphoto_hno4=5, jphoto_n2o5=6, &
       jphoto_o3a=7, jphoto_o3b=8, jphoto_h2o2=9, &
       jphoto_hchoa=10, jphoto_hchob=11, jphoto_ch3ooh=12, &
       jphoto_ethooh=13, jphoto_ald2=14, jphoto_aone=15, &
       jphoto_mgly=16, jphoto_open=17, jphoto_rooh=18, &
       jphoto_onit=19, jphoto_isoprd=20 )
      integer ngas_m1, nrxn_m1, ngas_m2, nrxn_m2, &
              ngas_m3, nrxn_m3, ngas_m4, nrxn_m4
      parameter(ngas_m1 = 31, nrxn_m1 = 74, &
                ngas_m2 = 19, nrxn_m2 = 53, &
                ngas_m3 = 5, nrxn_m3 = 16, &
                ngas_m4 = 11, nrxn_m4 = 32)
      integer ngas_tot
      parameter(ngas_tot= ngas_m1 + ngas_m2 + ngas_m3 + ngas_m4)
      integer ngas_r1, ngas_r2, ngas_r3, ngas_r4, ngas_r5, ngas_r6
      parameter(ngas_r1 = ngas_m1)
      parameter(ngas_r2 = ngas_m1 + ngas_m2)
      parameter(ngas_r3 = ngas_m1 + ngas_m2 + ngas_m3)
      parameter(ngas_r4 = ngas_m1 + ngas_m4)
      parameter(ngas_r5 = ngas_m1 + ngas_m2 + ngas_m4)
      parameter(ngas_r6 = ngas_m1 + ngas_m2 + ngas_m3 + ngas_m4)
      integer nperox
      parameter(nperox=10)
      integer nphoto
      parameter(nphoto=20)
      integer &
          jch3o2, jethp, jro2, jc2o3, jano2, &
          jnap, jisopp, jisopn, jisopo2, jxo2
      parameter ( &
          jch3o2=1, jethp=2, jro2=3, jc2o3=4, jano2=5, &
          jnap=6, jisopp=7, jisopn=8, jisopo2=9, jxo2=10 )
      end module module_data_cbmz


module iteration_final_mono

  use core_lib, only : idp, dp, warn, random_exp, random, error

  use type_photon, only : photon

  use sources, only : emit

  use mpi_core, only : main_process, mp_join
  use mpi_routines, only : mp_reset_first, mp_n_photons

  use peeled_images, only : make_peeled_images, peeloff_photon

  use dust_main, only : n_dust
  use dust_interact, only : interact

  use grid_physics, only : energy_abs_tot, &
       &                   emit_from_grid, &
       &                   precompute_jnu_var

  use grid_monochromatic, only : allocate_monochromatic_grid_pdfs, &
       &                         setup_monochromatic_grid_pdfs, &
       &                         emit_from_monochromatic_grid_pdf, &
       &                         deallocate_monochromatic_grid_pdfs

  use grid_propagate, only : grid_integrate_noenergy, &
       &                     grid_escape_tau

  use grid_geometry, only : escaped

  use settings, only : frequencies, &
       &               n_inter_max, &
       &               n_inter_max_warn, &
       &               n_reabs_max,  &
       &               n_reabs_max_warn,  &
       &               forced_first_scattering

  use performance, only : perf_header, &
       &                  perf_footer

  use counters, only : killed_photons_int

  implicit none
  save

  private
  public :: do_final_mono

contains

  subroutine do_final_mono(n_photons_sources,n_photons_thermal,n_photons_chunk, peeloff_scattering_only)

    implicit none

    ! Number of photons to run, and size of chunk to use
    integer(idp),intent(in) :: n_photons_sources, n_photons_thermal, n_photons_chunk

    ! Whether to only peeloff scattered photons
    logical,intent(in) :: peeloff_scattering_only

    ! Number of photons to run in chunk, and number of photons emitted so far
    integer(idp) :: n_photons, n_photons_curr

    ! Photon object and variable to loop over photons
    integer :: ip
    type(photon) :: p

    integer :: inu
    logical :: empty

    ! Precompute emissivity variable locator for each cell
    call precompute_jnu_var()

    call mp_join()

    if(n_photons_sources > 0) then

       ! Loop over monochromatic frequencies
       do inu=1,size(frequencies)

          if(main_process()) write(*,'(" [mono] computing source photons for nu =",ES11.4," Hz")') frequencies(inu)

          ! Tell multi-process routines that this is the start of an iteration
          call mp_reset_first()

          ! Print performance header
          if(main_process()) call perf_header()

          call mp_join()

          ! Initialize the number of completed photons
          n_photons_curr = 0

          ! Start loop over chunks of photons
          do

             ! Find out how many photons to run
             call mp_n_photons(n_photons_sources, n_photons_curr, n_photons_chunk, n_photons)

             if(n_photons==0) exit

             ! Compute all photons in chunk
             do ip=1,n_photons

                ! Emit photon from a source
                call emit(p,inu=inu)

                ! Scale the energy by the number of photons
                p%energy = p%energy / dble(n_photons_sources)

                ! Peeloff the photons from the star
                if(make_peeled_images) then
                   if(.not.peeloff_scattering_only) call peeloff_photon(p, polychromatic=.false.)
                end if

                ! Propagate until photon is absorbed again
                call propagate(p)

             end do

          end do

          call mp_join()

          ! Print performance footer
          if(main_process()) call perf_footer()

       end do

    else
       if(main_process()) then
          write(*,*)
          write(*,'("      ---------- Skipping source emission ----------")')
          write(*,*)
       end if
    end if

    call mp_join()

    if(n_photons_thermal > 0) then

       ! Allocate emissivity PDFs
       call allocate_monochromatic_grid_pdfs()

       ! Loop over monochromatic frequencies
       do inu=1,size(frequencies)

          ! Pre-compute emissivity grids for each dust type
          call setup_monochromatic_grid_pdfs(inu, empty)

          if(main_process()) write(*,'(" [mono] computing dust photons for nu =",ES11.4," Hz")') frequencies(inu)

          if(.not.empty) then

             ! Tell multi-process routines that this is the start of an iteration
             call mp_reset_first()

             if(main_process()) call perf_header()

             call mp_join()

             ! Initialize the number of completed photons
             n_photons_curr = 0

             ! Start loop over chunks of photons
             do

                ! Find out how many photons to run
                call mp_n_photons(n_photons_thermal, n_photons_curr, n_photons_chunk, n_photons)

                if(n_photons==0) exit

                ! Compute all photons in chunk
                do ip=1,n_photons

                   p = emit_from_monochromatic_grid_pdf(inu)

                   if(p%energy > 0._dp) then

                      ! Scale energy
                      p%energy = p%energy * energy_abs_tot(p%dust_id) / dble(n_photons_thermal) * dble(n_dust)

                      ! Peeloff the photons from the dust
                      if(make_peeled_images) then
                         if(.not.peeloff_scattering_only) call peeloff_photon(p, polychromatic=.false.)
                      end if

                      ! Propagate until photon is absorbed again
                      call propagate(p)

                   end if

                end do

             end do

             call mp_join()

             if(main_process()) call perf_footer()

          else
             if(main_process()) then
                write(*,*)
                write(*,'("      -------- No emission at this frequency -------")')
                write(*,*)
             end if
          end if

       end do

       ! Deallocate emissivity PDFs
       call deallocate_monochromatic_grid_pdfs()

    else
       if(main_process()) then
          write(*,*)
          write(*,'("      ----------- Skipping dust emission -----------")')
          write(*,*)
       end if
    end if

  end subroutine do_final_mono

  subroutine propagate(p)

    implicit none

    type(photon), intent(inout) :: p
    integer(idp) :: interactions
    real(dp) :: tau_achieved, tau, tau_escape
    type(photon) :: p_tmp
    real(dp) :: xi
    logical :: killed
    integer :: ia

    ! Propagate photon
    do interactions=1, n_inter_max+1

       ! Sample a random optical depth and propagate that optical depth
       call random_exp(tau)

       if(interactions==1) then
          if(forced_first_scattering) then
             p_tmp = p
             call grid_escape_tau(p_tmp, huge(1._dp), tau_escape, killed)
             if(tau_escape > 1.e-10_dp .and. .not. killed) then
                call random(xi)
                tau = -log(1._dp-xi*(1._dp - exp(-tau_escape)))
                p%energy = p%energy * (1._dp - exp(-tau_escape))
             end if
          end if
       end if

       call grid_integrate_noenergy(p,tau,tau_achieved)

       if(p%reabsorbed) then

          ! Loop until the photon finally escapes interacting with sources
          do ia=1,n_reabs_max

             ! The parentheses are required in the following expression to
             ! force the evaluation of the option (otherwise it gets reset
             ! because p has intent(out) from emit)
             call emit(p, reemit=.true., reemit_id=(p%reabsorbed_id), reemit_energy=(p%energy), inu=(p%inu))

             ! We now peeloff the photon even if only scattered photons are
             ! wanted because this is a kind of scattering, and will not be
             ! taken into account in the raytracing.
             if(make_peeled_images) call peeloff_photon(p, polychromatic=.false.)

             ! Sample optical depth and travel
             call random_exp(tau)
             call grid_integrate_noenergy(p,tau,tau_achieved)

             ! If we haven't intersected another source, we can proceed
             if(.not.p%reabsorbed) exit

          end do

          ! Check that we haven't reached the maximum number of successive reabsorptions
          if(ia == n_reabs_max + 1) then
             if(n_reabs_max_warn) call warn('do_final_mono', 'maximum number of successive re-absorptions exceeded')
             killed_photons_int = killed_photons_int + 1
             p%killed = .true.
             exit
          end if

       end if

       ! Check whether the photon has escaped the grid or was killed
       if(p%killed.or.escaped(p)) exit

       ! Absorb & re-emit, or scatter
       call interact(p)
       p%killed = .not.p%scattered
       if(p%killed) exit
       if(make_peeled_images) call peeloff_photon(p, polychromatic=.false.)

    end do

    if(interactions==n_inter_max+2) then
       if(n_inter_max_warn) call warn("main","photon exceeded maximum number of interactions - killing")
       killed_photons_int = killed_photons_int + 1
       p%killed = .true.
    end if

  end subroutine propagate

end module iteration_final_mono