      block data electroweak_input
************************************************************************
*     Calculational scheme for EW couplings                            *
************************************************************************
c
c     ewscheme=-1  : Old MCFM default
c                    input values = Gf,alpha(m_Z),m_W,m_Z
c                    output values = sin^2(theta_W),mtop
c
c     ewscheme=0   : Old MadEvent default (= AlpGen with iewopt=2)
c                    input values = sin^2(theta_W),alpha(m_Z),m_Z
c                    output values = m_W,Gf.
c
c     ewscheme=1   : New MCFM default, also Madevent default, "G_mu scheme"
c                    = LUSIFER and AlpGen (iewopt=3) defaults
c                    input values = G_F,m_Z,m_W
c                    output values = sin^2(theta_W),alpha(m_Z).
c
c     ewscheme=2   : input  values = G_F,sin^2(theta_W),alpha(m_Z)
c                    output values = m_W,m_Z.
c
c     ewscheme=3   : User choice. All parameters are left as they are
c                    input here. You have to know what you're doing.
c
      implicit none
      include 'ewinput.f'

c     Begin anomalous couplings
      include 'spinzerohiggs_anomcoupl.f'

      data AllowAnomalousCouplings / 0 / ! Disables anomalous couplings
      data distinguish_HWWcouplings / 0 /
      data AnomalCouplPR,AnomalCouplDK / 1, 1/
      data channeltoggle_stu / 2 /
      data vvhvvtoggle_vbfvh / 2 /

      data LambdaBSM / 1000d0 /
      data Lambda2BSM / 1000d0 /

c     4th generation quark masses
      data mt_4gen / 100000d0 /
      data mb_4gen / 100000d0 /

c     MARKUS: anomalous couplings for the first resonance
c     Hgg and Hff anomalous couplings
      data kappa_top / (0d0,0d0) / ! SM=1,0
      data kappa_tilde_top / (0d0,0d0) / ! SM=0,0
      data kappa_bot / (0d0,0d0) / ! SM=1,0
      data kappa_tilde_bot / (0d0,0d0) / ! SM=0,0
      data ghg2 / (0d0,0d0) / ! SM=0,0
      data ghg3 / (0d0,0d0) / ! SM=0,0
      data ghg4 / (0d0,0d0) / ! SM=0,0

      data kappa_4gen_top / (0d0,0d0) /
      data kappa_tilde_4gen_top / (0d0,0d0) /
      data kappa_4gen_bot / (0d0,0d0) /
      data kappa_tilde_4gen_bot / (0d0,0d0) /
      data ghg2_4gen / (0d0,0d0) /
      data ghg3_4gen / (0d0,0d0) /
      data ghg4_4gen / (0d0,0d0) /

c     HVV anomalous couplings
      data Lambda_Q  / 10000d0 /
      data Lambda_z1 / 10000d0 /
      data Lambda_z2 / 10000d0 /
      data Lambda_z3 / 10000d0 /
      data Lambda_z4 / 10000d0 /

      data cz_q1sq / 0 /
      data cz_q2sq / 0 /
      data cz_q12sq / 0 /
      data Lambda_z11 / 100d0 /
      data Lambda_z21 / 100d0 /
      data Lambda_z31 / 100d0 /
      data Lambda_z41 / 100d0 /
      data Lambda_z12 / 100d0 /
      data Lambda_z22 / 100d0 /
      data Lambda_z32 / 100d0 /
      data Lambda_z42 / 100d0 /
      data Lambda_z10 / 100d0 /
      data Lambda_z20 / 100d0 /
      data Lambda_z30 / 100d0 /
      data Lambda_z40 / 100d0 /

      data ghz1 / (1d0,0d0) /
      data ghz1_prime / (0d0,0d0) /
      data ghz1_prime2 / (0d0,0d0) /
      data ghz1_prime3 / (0d0,0d0) /
      data ghz1_prime4 / (0d0,0d0) /
      data ghz1_prime5 / (0d0,0d0) /
      data ghz1_prime6 / (0d0,0d0) /
      data ghz1_prime7 / (0d0,0d0) /

      data ghz2 / (0d0,0d0) /
      data ghz2_prime / (0d0,0d0) /
      data ghz2_prime2 / (0d0,0d0) /
      data ghz2_prime3 / (0d0,0d0) /
      data ghz2_prime4 / (0d0,0d0) /
      data ghz2_prime5 / (0d0,0d0) /
      data ghz2_prime6 / (0d0,0d0) /
      data ghz2_prime7 / (0d0,0d0) /

      data ghz3 / (0d0,0d0) /
      data ghz3_prime / (0d0,0d0) /
      data ghz3_prime2 / (0d0,0d0) /
      data ghz3_prime3 / (0d0,0d0) /
      data ghz3_prime4 / (0d0,0d0) /
      data ghz3_prime5 / (0d0,0d0) /
      data ghz3_prime6 / (0d0,0d0) /
      data ghz3_prime7 / (0d0,0d0) /

      data ghz4 / (0d0,0d0) /
      data ghz4_prime / (0d0,0d0) /
      data ghz4_prime2 / (0d0,0d0) /
      data ghz4_prime3 / (0d0,0d0) /
      data ghz4_prime4 / (0d0,0d0) /
      data ghz4_prime5 / (0d0,0d0) /
      data ghz4_prime6 / (0d0,0d0) /
      data ghz4_prime7 / (0d0,0d0) /

      data Lambda_zgs1 / 10000d0 /

      data ghzgs1_prime2 / (0d0,0d0) /
      data ghzgs2 / (0d0,0d0) /
      data ghzgs3 / (0d0,0d0) /
      data ghzgs4 / (0d0,0d0) /

      data ghgsgs2 / (0d0,0d0) /
      data ghgsgs3 / (0d0,0d0) /
      data ghgsgs4 / (0d0,0d0) /

      data Lambda_w1 / 10000d0 /
      data Lambda_w2 / 10000d0 /
      data Lambda_w3 / 10000d0 /
      data Lambda_w4 / 10000d0 /

      data cw_q1sq / 0 /
      data cw_q2sq / 0 /
      data cw_q12sq / 0 /
      data Lambda_w11 / 100d0 /
      data Lambda_w21 / 100d0 /
      data Lambda_w31 / 100d0 /
      data Lambda_w41 / 100d0 /
      data Lambda_w12 / 100d0 /
      data Lambda_w22 / 100d0 /
      data Lambda_w32 / 100d0 /
      data Lambda_w42 / 100d0 /
      data Lambda_w10 / 100d0 /
      data Lambda_w20 / 100d0 /
      data Lambda_w30 / 100d0 /
      data Lambda_w40 / 100d0 /

      data ghw1 / (1d0,0d0) /
      data ghw1_prime / (0d0,0d0) /
      data ghw1_prime2 / (0d0,0d0) /
      data ghw1_prime3 / (0d0,0d0) /
      data ghw1_prime4 / (0d0,0d0) /
      data ghw1_prime5 / (0d0,0d0) /
      data ghw1_prime6 / (0d0,0d0) /
      data ghw1_prime7 / (0d0,0d0) /

      data ghw2 / (0d0,0d0) /
      data ghw2_prime / (0d0,0d0) /
      data ghw2_prime2 / (0d0,0d0) /
      data ghw2_prime3 / (0d0,0d0) /
      data ghw2_prime4 / (0d0,0d0) /
      data ghw2_prime5 / (0d0,0d0) /
      data ghw2_prime6 / (0d0,0d0) /
      data ghw2_prime7 / (0d0,0d0) /

      data ghw3 / (0d0,0d0) /
      data ghw3_prime / (0d0,0d0) /
      data ghw3_prime2 / (0d0,0d0) /
      data ghw3_prime3 / (0d0,0d0) /
      data ghw3_prime4 / (0d0,0d0) /
      data ghw3_prime5 / (0d0,0d0) /
      data ghw3_prime6 / (0d0,0d0) /
      data ghw3_prime7 / (0d0,0d0) /

      data ghw4 / (0d0,0d0) /
      data ghw4_prime / (0d0,0d0) /
      data ghw4_prime2 / (0d0,0d0) /
      data ghw4_prime3 / (0d0,0d0) /
      data ghw4_prime4 / (0d0,0d0) /
      data ghw4_prime5 / (0d0,0d0) /
      data ghw4_prime6 / (0d0,0d0) /
      data ghw4_prime7 / (0d0,0d0) /

c     MARKUS: anomalous couplings for 2nd resonance
c     Mass and width for second resonance
      data h2mass  /-1d0/ ! -1 disables the resonance
      data h2width /0d0/

c     Hgg and Hff anomalous couplings
      data kappa2_top / (0d0,0d0) /
      data kappa2_tilde_top / (0d0,0d0) /
      data kappa2_bot / (0d0,0d0) /
      data kappa2_tilde_bot / (0d0,0d0) /
      data gh2g2 / (0d0,0d0) /
      data gh2g3 / (0d0,0d0) /
      data gh2g4 / (0d0,0d0) /

      data kappa2_4gen_top / (0d0,0d0) /
      data kappa2_tilde_4gen_top / (0d0,0d0) /
      data kappa2_4gen_bot / (0d0,0d0) /
      data kappa2_tilde_4gen_bot / (0d0,0d0) /
      data gh2g2_4gen / (0d0,0d0) /
      data gh2g3_4gen / (0d0,0d0) /
      data gh2g4_4gen / (0d0,0d0) /

c     HVV anomalous couplings
      data Lambda2_Q  / 10000d0 /
      data Lambda2_z1 / 10000d0 /
      data Lambda2_z2 / 10000d0 /
      data Lambda2_z3 / 10000d0 /
      data Lambda2_z4 / 10000d0 /

      data c2z_q1sq / 0 /
      data c2z_q2sq / 0 /
      data c2z_q12sq / 0 /
      data Lambda2_z11 / 100d0 /
      data Lambda2_z21 / 100d0 /
      data Lambda2_z31 / 100d0 /
      data Lambda2_z41 / 100d0 /
      data Lambda2_z12 / 100d0 /
      data Lambda2_z22 / 100d0 /
      data Lambda2_z32 / 100d0 /
      data Lambda2_z42 / 100d0 /
      data Lambda2_z10 / 100d0 /
      data Lambda2_z20 / 100d0 /
      data Lambda2_z30 / 100d0 /
      data Lambda2_z40 / 100d0 /

      data gh2z1 / (0d0,0d0) /
      data gh2z1_prime / (0d0,0d0) /
      data gh2z1_prime2 / (0d0,0d0) /
      data gh2z1_prime3 / (0d0,0d0) /
      data gh2z1_prime4 / (0d0,0d0) /
      data gh2z1_prime5 / (0d0,0d0) /
      data gh2z1_prime6 / (0d0,0d0) /
      data gh2z1_prime7 / (0d0,0d0) /

      data gh2z2 / (0d0,0d0) /
      data gh2z2_prime / (0d0,0d0) /
      data gh2z2_prime2 / (0d0,0d0) /
      data gh2z2_prime3 / (0d0,0d0) /
      data gh2z2_prime4 / (0d0,0d0) /
      data gh2z2_prime5 / (0d0,0d0) /
      data gh2z2_prime6 / (0d0,0d0) /
      data gh2z2_prime7 / (0d0,0d0) /

      data gh2z3 / (0d0,0d0) /
      data gh2z3_prime / (0d0,0d0) /
      data gh2z3_prime2 / (0d0,0d0) /
      data gh2z3_prime3 / (0d0,0d0) /
      data gh2z3_prime4 / (0d0,0d0) /
      data gh2z3_prime5 / (0d0,0d0) /
      data gh2z3_prime6 / (0d0,0d0) /
      data gh2z3_prime7 / (0d0,0d0) /

      data gh2z4 / (0d0,0d0) /
      data gh2z4_prime / (0d0,0d0) /
      data gh2z4_prime2 / (0d0,0d0) /
      data gh2z4_prime3 / (0d0,0d0) /
      data gh2z4_prime4 / (0d0,0d0) /
      data gh2z4_prime5 / (0d0,0d0) /
      data gh2z4_prime6 / (0d0,0d0) /
      data gh2z4_prime7 / (0d0,0d0) /

      data Lambda2_zgs1 / 10000d0 /

      data gh2zgs1_prime2 / (0d0,0d0) /
      data gh2zgs2 / (0d0,0d0) /
      data gh2zgs3 / (0d0,0d0) /
      data gh2zgs4 / (0d0,0d0) /

      data gh2gsgs2 / (0d0,0d0) /
      data gh2gsgs3 / (0d0,0d0) /
      data gh2gsgs4 / (0d0,0d0) /

      data Lambda2_w1 / 10000d0 /
      data Lambda2_w2 / 10000d0 /
      data Lambda2_w3 / 10000d0 /
      data Lambda2_w4 / 10000d0 /

      data c2w_q1sq / 0 /
      data c2w_q2sq / 0 /
      data c2w_q12sq / 0 /
      data Lambda2_w11 / 100d0 /
      data Lambda2_w21 / 100d0 /
      data Lambda2_w31 / 100d0 /
      data Lambda2_w41 / 100d0 /
      data Lambda2_w12 / 100d0 /
      data Lambda2_w22 / 100d0 /
      data Lambda2_w32 / 100d0 /
      data Lambda2_w42 / 100d0 /
      data Lambda2_w10 / 100d0 /
      data Lambda2_w20 / 100d0 /
      data Lambda2_w30 / 100d0 /
      data Lambda2_w40 / 100d0 /

      data gh2w1 / (1d0,0d0) /
      data gh2w1_prime / (0d0,0d0) /
      data gh2w1_prime2 / (0d0,0d0) /
      data gh2w1_prime3 / (0d0,0d0) /
      data gh2w1_prime4 / (0d0,0d0) /
      data gh2w1_prime5 / (0d0,0d0) /
      data gh2w1_prime6 / (0d0,0d0) /
      data gh2w1_prime7 / (0d0,0d0) /

      data gh2w2 / (0d0,0d0) /
      data gh2w2_prime / (0d0,0d0) /
      data gh2w2_prime2 / (0d0,0d0) /
      data gh2w2_prime3 / (0d0,0d0) /
      data gh2w2_prime4 / (0d0,0d0) /
      data gh2w2_prime5 / (0d0,0d0) /
      data gh2w2_prime6 / (0d0,0d0) /
      data gh2w2_prime7 / (0d0,0d0) /

      data gh2w3 / (0d0,0d0) /
      data gh2w3_prime / (0d0,0d0) /
      data gh2w3_prime2 / (0d0,0d0) /
      data gh2w3_prime3 / (0d0,0d0) /
      data gh2w3_prime4 / (0d0,0d0) /
      data gh2w3_prime5 / (0d0,0d0) /
      data gh2w3_prime6 / (0d0,0d0) /
      data gh2w3_prime7 / (0d0,0d0) /

      data gh2w4 / (0d0,0d0) /
      data gh2w4_prime / (0d0,0d0) /
      data gh2w4_prime2 / (0d0,0d0) /
      data gh2w4_prime3 / (0d0,0d0) /
      data gh2w4_prime4 / (0d0,0d0) /
      data gh2w4_prime5 / (0d0,0d0) /
      data gh2w4_prime6 / (0d0,0d0) /
      data gh2w4_prime7 / (0d0,0d0) /

c     anomalous couplings for triple and quartic gauge boson coupling with d_1-3 (SM: set all to 1)
      data dV_A / (1d0,0d0) /
      data dP_A / (1d0,0d0) /
      data dM_A / (1d0,0d0) /
      data dV_Z / (1d0,0d0) /
      data dP_Z / (1d0,0d0) /
      data dM_Z / (1d0,0d0) /
      data dZZWpWm / (1d0,0d0) /
      data dZAWpWm / (1d0,0d0) /
      data dAAWpWm / (1d0,0d0) /
c     anomalous couplings for triple and quartic gauge boson coupling with d_4 (SM: set all to 0)
      data dFour_A / (0d0,0d0) /
      data dFour_Z / (0d0,0d0) /

c     End anomalous couplings

      data ewscheme  / +3                  /   ! Chooses EW scheme
      data Gf_inp    / 1.16639d-5          /   ! G_F
      data aemmz_inp / 7.8125d-03 /   ! alpha_EM(m_Z)=1/128
      data xw_inp    / 0.23119d0            /   ! sin^2(theta_W)
      data wmass_inp / 80.399d0            /   ! W mass
      data zmass_inp / 91.1876d0           /   ! Z mass

      end
************************************************************************

      block data transversedefn
************************************************************************
*     Definition to use for computing transverse quantities            *
*         useEt=.false.    transverse momentum [previous default]      *
*         useEt=.true.     transverse energy                           *
************************************************************************
      implicit none
      include 'useet.f'
      data useEt/.false./
      end
************************************************************************

************************************************************************
*     Masses, widths and initial-state flavour information             *
************************************************************************
      block data block_properties
      implicit none
      include 'masses.f'
      include 'nflav.f'
      include 'nores.f'
c--- if true, nores removes all of the gg contribution
      data nores/.false./
c--- Masses: note that "mtausq" is typically used throughout the
c--- program to calculate couplings that depend on the mass, while
c--- "mtau" is the mass that appears in the rest of the matrix
c--- elements and phase space (and may be set to zero in the program,
c--- depending on the process number)

      data mtau,mtausq/1.7768d0,3.15701824d0/
c----   Note: after v5.6, the masses for top, bottom and charm quarks
c----         are set in the input file

c---  Widths: note that the top width is calculated in the program
c---  The W width of 2.1054 is derived using the measured BR of
c---    10.80 +/- 0.09 % (PDG) and the LO partial width calculation
c---    for Mw=80.399 GeV
      data wwidth,zwidth/2.085d0,2.4952d0/
      data tauwidth/2.267d-12/
c--- Number of active flavours in the initial state: this parameter
c--- may be changed in the program for some processes
      data nflav/5/
c--- Masses below here are currently unused
      data md,mu,ms/5d-3,5d-3,1d-1/
      data mel,mmu/0.510997d-3,0.105658389d0/
      end
************************************************************************

************************************************************************
*     CKM matrix entries                                               *
************************************************************************
      block data block_ckm
      implicit none
      double precision Vud,Vus,Vub,Vcd,Vcs,Vcb
      common/cabib/Vud,Vus,Vub,Vcd,Vcs,Vcb
      data  Vud  ,  Vus  ,  Vub  ,
     .      Vcd  ,  Vcs  ,  Vcb
     .   /0.974285d0,0.22529d0,0.00362693741331522731d0,
     .    0.225182d0,0.9734244d0,0.0416893794705567033/
c      data  Vud  ,  Vus  ,  Vub  ,
c     .      Vcd  ,  Vcs  ,  Vcb
c     .   /0.97425d0,0.2253d0,0.0413d0,
c     .    0.225d0,0.986d0,0.0411d0/
c      data  Vud  ,  Vus  ,  Vub  ,
c     .      Vcd  ,  Vcs  ,  Vcb
c     .   /1d0,0d0,0.000d0,
c     .    0d0,1d0,0.000d0/

      end
************************************************************************

************************************************************************
*     MS-bar quark massses, mQ_MS(mQ_MS)                               *
*     computed using 1-loop running from pole masses of                *
*     mb=4.66, mt=173.2                                                *
************************************************************************
      block data block_msbarmasses
      implicit none
      include 'msbarmasses.f'
      data mc_msbar/1.275d0/
      data mb_msbar/4.18d0/
      data mt_msbar/160d0/
      end
************************************************************************

************************************************************************
*     Relevant for the H+b process only :                              *
*       susycoup: the deviation of the Higgs coupling from the         *
*                 Standard Model value (S.M. = 1d0)                    *
************************************************************************
      block data block_bH
      implicit none
      include 'susycoup.f'
      data susycoup/1d0/
      end
************************************************************************

************************************************************************
*     Dim. Reg. parameter epsilon, used for checking the proper        *
*      operation of the NLO code in the program                        *
************************************************************************
      block data block_epinv
      implicit none
      include 'epinv.f'
      include 'epinv2.f'
      data epinv/ 1d3/
      data epinv2/1d3/
      end
************************************************************************


C Copyright(C) 2011-2017 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C
C * Neither the name of NTESS nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE ARCXYZ (XN, YN, XN3, YN3, ZN3, IXNP, NRNP, NPCEN,
     &   SINANG, COSANG)
C=======================================================================

C   --*** ARCYXZ *** (GEN3D) Calculate 3D coordinates - rotation about Y
C   --   Written by Amy Gilkey - revised 05/09/88
C   --   Modified by Greg Sjaardema - 02/06/89
C   --       Added Warp Function
C   --       Added Gradient to Rotations (not for center blocks)
C   --
C   --NEWXYZ calculates the coordinate array for the 3D database.
C   --
C   --Parameters:
C   --   XN, YN - IN - the 2D coordinates, destroyed
C   --   XN3, YN3, ZN3 - OUT - the 3D coordinates
C   --   IXNP - IN - the new index for each node
C   --   NRNP - IN - the number of new nodes generated for each node
C   --   NPCEN - IN - the node numbers of the center nodes by column and row
C   --   SINANG, COSANG - SCRATCH - size = NNREPL, holds sin and cos of
C   --      angles for rotations
C   --
C   --Common Variables:
C   --   Uses NDIM, NUMNP of /DBNUMS/
C   --   Uses NDIM3, NUMNP3 of /DBNUM3/
C   --   Uses DOTRAN, NNREPL, DIM3, NRTRAN, D3TRAN, ZGRAD,
C   --      CENTER, NUMCOL, NUMROW of /PARAMS/

      INCLUDE 'g3_dbnums.blk'
      INCLUDE 'g3_dbnum3.blk'
      INCLUDE 'g3_params.blk'

      REAL XN(NUMNP), YN(NUMNP),
     &   XN3(NUMNP3), YN3(NUMNP3), ZN3(NUMNP3)
      INTEGER IXNP(*), NRNP(*)
C .. Dimension of NPCEN is (NUMCOL,NUMROW), but NUMCOL may be 0
      INTEGER NPCEN(NUMCDM,*)
      REAL SINANG(NNREPL), COSANG(NNREPL)

      PI = ATAN2(0.0, -1.0)
C      --For rotations, change X and add Z so that they define pie-shaped
C      --regions around the Y axis

C   --Copy Y coordinate from original

         DO 520 INP = 1, NUMNP
            JNP0 = IXNP(INP) - 1
            DO 510 NR = 1, NRNP(INP)
               YN3(JNP0+NR) = YN(INP)
  510       CONTINUE
  520    CONTINUE

C ... Check minimum X coordinate to see if we will generate bad elements
         XMIN = XN(1)
         DO 5 INP = 2, NUMNP
           XMIN = MIN(XMIN, XN(INP))
 5       CONTINUE
         XMIN = XMIN - CENTER
         if (XMIN .LT. 0) THEN
           call prterr('WARNING',
     &       'Input mesh crosses over axis of rotation (Y). Negative '//
     &       'elements may be generated. Adjust ROTCEN or input mesh.')
         end if

C      --If center block exists, calculate center of rotation
      IF (NUMCOL .GT. 0) THEN
         CENTER = 1E36
         DO 10 IROW = 1, NUMROW
            INP = NPCEN(1,IROW)
            IF (INP .LE. 0) GOTO 10
            CENTER = MIN (CENTER, XN(INP))
   10    CONTINUE
      END IF

C      --Subtract center, so rotation is around zero

      IF (CENTER .NE. 0.0) THEN
         DO 20 INP = 1, NUMNP
            XN(INP) = XN(INP) - CENTER
   20    CONTINUE
      END IF

C      --Get the coordinates for the non-center nodes

      IBLK = 0
      NXTNR = 1
      ZEND = 0.0

    1    CONTINUE
         IBLK = IBLK + 1
         IF (NRTRAN(IBLK) .GT. 0) THEN
            ZBEG = ZEND
            ZEND = ZBEG + D3TRAN(IBLK) * PI / 180.0

            CALL INIGRD (-ZBEG, -ZEND, ZGRAD(IBLK),
     *         NRTRAN(IBLK), MIN(NRTRAN(IBLK)+1,NNREPL-NXTNR+1),
     *        COSANG(NXTNR))
            NXTNR = NXTNR + NRTRAN(IBLK)
            IF (IBLK .LT. MAXINT) GO TO 1
         END IF

         DO 30 NR = 1, NNREPL
            ANG = COSANG(NR)
            SINANG(NR) = SIN (ANG)
            COSANG(NR) = COS (ANG)
   30    CONTINUE

      DO 60 INP = 1, NUMNP
         IF (NRNP(INP) .EQ. NNREPL) THEN
            JNP = IXNP(INP)
            X = XN(INP)
            DO 50 NR = 1, NNREPL
               XN3(JNP) = X * COSANG(NR)
               ZN3(JNP) = X * SINANG(NR)
               JNP = JNP + 1
   50       CONTINUE
         END IF
   60 CONTINUE

      IF (NUMCOL .GT. 0) THEN

C         --For center rotations, process by column for each row;
C         --calculate the first 8th of the circle, then copy to other 8ths.

         RAD45 = 45.0 * (PI / 180.0)
         COSD45 = COS (RAD45)

         DO 70 IROW = 1, NUMROW
            INP = NPCEN(1,IROW)
            IF (INP .LE. 0) GOTO 70
            JNP = IXNP(INP)
            XN3(JNP) = 0.0
            ZN3(JNP) = 0.0
   70    CONTINUE

         DO 170 ICOL = 2, NUMCOL

            DO 160 IROW = 1, NUMROW
               INP = NPCEN(ICOL,IROW)
               IF (INP .LE. 0) GOTO 160

               JNP = IXNP(INP)
               JNP0 = JNP - 1
               NEND = JNP0 + NRNP(INP)
               XN3(JNP) = XN(INP)
               ZN3(JNP) = 0.0

               X = XN(INP)
               XMID = X * COSD45

               DO 80 IX = 2, ICOL-1
                  I = NPCEN(IX,IROW)
                  IF (I .NE. 0) THEN
                     Z = XN(ABS(I))
                  ELSE
                     Z = XN(INP) * (IX-1) / (ICOL-1)
                  END IF
                  IF (X .NE. 0.0) THEN
                     R = Z / X
                  ELSE
                     R = 0.0
                  END IF
                  JNP = JNP + 1
                  XN3(JNP) = SQRT (X*X - Z*Z/2)
                  ZN3(JNP) = - (R * XMID)
   80          CONTINUE

               JNP = JNP + 1
               XN3(JNP) = XMID
               ZN3(JNP) = - XMID

               DO 90 IX = ICOL-1, 1, -1
                  JNP = JNP + 1
                  XN3(JNP) = - ZN3(JNP0+IX)
                  ZN3(JNP) = - XN3(JNP0+IX)
   90          CONTINUE
               IF (JNP .LT. NEND) THEN
                  DO 100 IX = 2, ICOL
                     JNP = JNP + 1
                     XN3(JNP) = ZN3(JNP0+IX)
                     ZN3(JNP) = - XN3(JNP0+IX)
  100             CONTINUE
                  DO 110 IX = ICOL-1, 1, -1
                     JNP = JNP + 1
                     XN3(JNP) = - XN3(JNP0+IX)
                     ZN3(JNP) = ZN3(JNP0+IX)
  110             CONTINUE
               END IF
               IF (JNP .LT. NEND) THEN
                  DO 120 IX = 2, ICOL
                     JNP = JNP + 1
                     XN3(JNP) = - XN3(JNP0+IX)
                     ZN3(JNP) = - ZN3(JNP0+IX)
  120             CONTINUE
                  DO 130 IX = ICOL-1, 1, -1
                     JNP = JNP + 1
                     XN3(JNP) = ZN3(JNP0+IX)
                     ZN3(JNP) = XN3(JNP0+IX)
  130             CONTINUE
               END IF
               IF (JNP .LT. NEND) THEN
                  DO 140 IX = 2, ICOL
                     JNP = JNP + 1
                     XN3(JNP) = - ZN3(JNP0+IX)
                     ZN3(JNP) = XN3(JNP0+IX)
  140             CONTINUE
                  DO 150 IX = ICOL-1, 2, -1
                     JNP = JNP + 1
                     XN3(JNP) = XN3(JNP0+IX)
                     ZN3(JNP) = - ZN3(JNP0+IX)
  150             CONTINUE
               END IF
  160       CONTINUE
  170    CONTINUE
      END IF

C      --Add center of rotation

      IF (CENTER .NE. 0.0) THEN
         DO 180 JNP = 1, NUMNP3
            XN3(JNP) = XN3(JNP) + CENTER
  180    CONTINUE
      END IF
      RETURN
      END


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

      subroutine trcoef ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Gas and liquid exchange organic micro pollutants (Lyman and O'Conner)

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        Calculation of transport coefficients for air-water exhchange
!        as a function of:
!        sw=0: wind, veloc and molmass (Chemical estimates, Lyman)
!        sw=1: veloc, diffusion coefficients (IMPAQT)= O'Conner formulas
!
! Name    T   L I/O   Description                                   Uni
! ----    --- -  -    -------------------                            --
! SWITCH  R*4 1 I  Switch for calculation method                     [-]
! WIND    R*4 1 I  Windspeed                                       [m/s]
! VELOC   R*4 1 I  Flow velocity                                   [m/s]
! M       R*4 1 I  Molecuulmassa omive                           [g/mol]
! LDIF    R*4 1 O  molekular diffusion coefficient waterphase     [m2/d]
! GDIF    R*4 1 O  molekular diffusion coefficient gasphase       [m2/d]
! KL      R*4 1 O  mass transport coefficient waterphase           [m/d]
! KG      R*4 1 O  mass transport coefficient gasphase             [m/d]
! VL      R*4 1 LC viscosity waterphase                    [Pa/s=kg/m/s]
! VG      R*4 1 LC viscosity gashase                       [Pa/s=kg/m/s]
! RHOL    R*4 1 LC density waterphase                            [kg/m3]
! RHOG    R*4 1 LC density gasphase                              [kg/m3]
! TEMP    R*4 1 I  Temperatuur
! DEPTH   R*4 1 I  Diepte
!-----------------------------------------------------------------------

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------
      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      LOGICAL  WOROPT , WNDOPT , TMPOPT
!
!     Local declarations, constants in source
!
      PARAMETER ( C1     =    18.     ,
     +            C2     =     5.64   ,
     +            C3     =     0.969  ,
     +            C4     =     0.673  ,
     +            C5     =    32.     ,
     +            C6     =     0.526  ,
     +            C7     =     0.7    ,
     +            CRIT1  =     1.9    ,
     +            CRIT2  =     5.0    ,
     +            E      =     2.718  ,
     +            KELVIN =   273.15   ,
     +            VCMIN  =     0.001  ,
     +            C11    =     1.293  ,
     +            C12    =     0.00367,
     +            C13    =  1000.0    ,
     +            C14    =     0.088  ,
     +            C15    =     1.32   ,
     +            C16    =     0.009  ,
     +            C17    =     1.E-5  ,
     +            C18    =     0.001  ,
     +            C21    =     0.01   ,
     +            C22    =     6.1    ,
     +            C23    =     0.63   ,
     +            C24    =     0.001  ,
     +            C25    =     0.0463 ,
     +            C26    =     0.67   ,
     +            C27    =     1.E-6  ,
     +            C28    =     0.0144 ,
     +            C29    =     0.00341,
     +            C30    =     2.2    ,
     +            CRIT3  =     0.3     )
!
      IN2  = INCREM( 2)
      IN4  = INCREM( 4)
      IN5  = INCREM( 5)
      IN6  = INCREM( 6)
      IN7  = INCREM( 7)
      IN8  = INCREM( 8)
!
      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
!
      EXP1 = EXP ( C6*(CRIT2-CRIT1) )
      IF ( IN2 .EQ. 0 ) THEN
         WIND   = PMSA(IP2 )
      IF( WIND  .LT. 0.0   ) CALL ERRSYS ('WIND       in TRCOEF < 0', 1)
         IF ( WIND .GE. CRIT1 ) THEN
            IF ( WIND .LT. CRIT2 ) THEN
               EXP2   = EXP ( C6*(WIND-CRIT1) )
            ELSE
               FAC1   = ( 1. + (WIND - CRIT2)**C7 ) * EXP1
            ENDIF
         ENDIF
!     Calculate wind at watersurface from wind at 10m (m/s)
         FWIND  = C21 * WIND * SQRT( C22 + C23 * WIND)
         IF ( FWIND .LT. CRIT3  ) THEN
            FWIN2 = C28 * FWIND**C30
         ELSE
            FWIN2 = C29 * FWIND
         ENDIF
         WNDOPT = .FALSE.
      ELSE
         WNDOPT = .TRUE.
      ENDIF
!
      IF ( IN4 .EQ. 0 ) THEN
         M      = PMSA(IP4 )
      IF( M     .LT. 1.E-30) CALL ERRSYS ('MOLMASS    in TRCOEF = 0', 1)
         WORTL1 = SQRT(C1/M)
         WORTL5 = SQRT(C5/M)*C2
         WOROPT = .FALSE.
      ELSE
         WOROPT = .TRUE.
      ENDIF
!
      IF ( IN5 .EQ. 0 .AND. IN6 .EQ. 0 .AND. IN8 .EQ. 0 ) THEN
         TEMP   = PMSA(IP8 )
!--calculation of bulk densitys of water and air:
         RHOG = C11 / (1. + C12 * TEMP)
         RHOL = C13 - C14 * TEMP
!--calculation of viscosities of water and air:
         VG = (C15 + C16 * TEMP) * C17
         VL = C18
         LDIF   = PMSA(IP5 )
         GDIF   = PMSA(IP6 )
      IF( GDIF  .LT. 1.E-30) CALL ERRSYS ('GAS-DIFF   in TRCOEF = 0', 1)
      IF( LDIF  .LT. 1.E-30) CALL ERRSYS ('WATER-DIFF in TRCOEF = 0', 1)
!     Calculate Schmidt numbers for water and gas
         SCG    = VG / ( RHOG * GDIF / 86400.)
         SCL    = VL / ( RHOL * LDIF / 86400.)
         TMPOPT = .FALSE.
      ELSE
         TMPOPT = .TRUE.
      ENDIF
!
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.EQ.1) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.1)) THEN
!
!     Map PMSA on local variables
!
      ISWTCH = PMSA(IP1 ) + 0.5
!
      IF ( ISWTCH .EQ. 0 ) THEN
!
         VELOC  = PMSA(IP3 )
      IF( VELOC .LT. 0.0   ) CALL ERRSYS ('VELOC      in TRCOEF < 0', 1)
         DEPTH  = PMSA(IP7 )
!
         IF ( WNDOPT ) THEN
            WIND  = PMSA(IP2 )
      IF( WIND  .LT. 0.0   ) CALL ERRSYS ('WIND       in TRCOEF < 0', 1)
            IF ( WIND .GE. CRIT1 ) THEN
               IF ( WIND .LT. CRIT2 ) THEN
                  EXP2   = EXP ( C6*(WIND-CRIT1) )
               ELSE
                  FAC1   = ( 1. + (WIND - CRIT2)**C7 ) * EXP1
               ENDIF
            ENDIF
         ENDIF
      IF( WIND  .LT. 0.0   ) CALL ERRSYS ('WIND       in TRCOEF < 0', 1)
!
         IF ( WOROPT ) THEN
            M      = PMSA(IP4 )
      IF( M     .LT. 1.E-30) CALL ERRSYS ('MOLMASS    in TRCOEF = 0', 1)
            WORTL1 = SQRT(C1/M)
            WORTL5 = SQRT(C5/M)*C2
         ENDIF
!
!     Ensure that VELOC is >= VCMIN
!
         VELOC = MAX ( VELOC , VCMIN )
!
!     Gasphase exchange coefficient
!
         KG    = KELVIN * (WIND + VELOC) * WORTL1
!
!     Water exchange coefficient
!
         IF ( WIND .LT. CRIT1  ) THEN
            KL  = VELOC**C3/DEPTH**C4*WORTL5
         ELSEIF ( WIND .LT. CRIT2 ) THEN
            KL  = VELOC**C3/DEPTH**C4*WORTL5*EXP2
         ELSE
            KL  = VELOC**C3/DEPTH**C4*WORTL5*FAC1
         ENDIF
!
      ENDIF

      IF ( ISWTCH .EQ. 1 ) THEN
! --- Impact formulations (O'connor personal communication?)
!
         IF ( WNDOPT ) THEN
            WIND  = PMSA(IP2 )
      IF( WIND  .LT. 0.0   ) CALL ERRSYS ('WIND       in TRCOEF < 0', 1)
!     Calculate wind at watersurface from wind at 10m (m/s)
            FWIND = C21 * WIND * SQRT( C22 + C23 * WIND)
            IF ( FWIND .LT. CRIT3  ) THEN
               FWIN2 = C28 * FWIND**C30
            ELSE
               FWIN2 = C29 * FWIND
            ENDIF
         ENDIF
!
         IF ( TMPOPT ) THEN
            TEMP   = PMSA(IP8 )
!--calculation of bulk densitys of water and air:
            RHOG = C11 / (1. + C12 * TEMP)
            RHOL = C13 - C14 * TEMP
!--calculation of viscosities of water and air:
            VG = (C15 + C16 * TEMP) * C17
            VL = C18
! --- Impact formulations (O'connor personal communication?)
            LDIF   = PMSA(IP5 )
            GDIF   = PMSA(IP6 )
      IF( GDIF  .LT. 1.E-30) CALL ERRSYS ('GAS-DIFF   in TRCOEF = 0', 1)
      IF( LDIF  .LT. 1.E-30) CALL ERRSYS ('WATER-DIFF in TRCOEF = 0', 1)
!     Calculate Schmidt numbers for water and gas
            SCG    = VG / ( RHOG * GDIF / 86400.)
            SCL    = VL / ( RHOL * LDIF / 86400.)
         ENDIF
         KG = ( C24 + C25 * FWIND / SCG**C26 )* 86400.
         KL = ( C27 + FWIN2 / SQRT(SCL) ) * 86400.
      ENDIF
!
!     Output
!
      PMSA(IP9 ) = KL
      PMSA(IP10) = KG
!
      ENDIF
      ENDIF
!
      IP1   = IP1   + INCREM (  1 )
      IP2   = IP2   + INCREM (  2 )
      IP3   = IP3   + INCREM (  3 )
      IP4   = IP4   + INCREM (  4 )
      IP5   = IP5   + INCREM (  5 )
      IP6   = IP6   + INCREM (  6 )
      IP7   = IP7   + INCREM (  7 )
      IP8   = IP8   + INCREM (  8 )
      IP9   = IP9   + INCREM (  9 )
      IP10  = IP10  + INCREM ( 10 )
!
 9000 CONTINUE
!
      RETURN
!
      END


*deck sf3eq7
      subroutine sf3eq7( a,        cx,       eta,      g4,
     &         h4,       icb,      icc,      ipt,      iscmci,
     &         is,       isf,      js,       jsf,      ks,
     &         ksf,      ijgt,     ijx,      ijy,      ijz,
     &         klgt,     klx,      kly,      klz,      lmnp1,
     &         lmnv,     mcons,    nc,       ncon,     nfct,
     &         ngw,      nrcr,     nt,       ntl,      ntu,
     &         x,        y,        z,        zet )
      implicit real*8 (a-h,o-z)
      logical kceqlc
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      common /cxindx/ ntij,ntik,ntil,ntkl,ntjl,ntjk,ntij1,ntjk1,ntkl1,
     1  ijcxst(2),ikcxst(2),ilcxst(2),klcxst(2),jlcxst(2),jkcxst(2)
      common /dim21/ ipq(256)
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
      common /sf3ao/ ibl
      dimension a(*),cx(*),eta(mrcru,mconu,*),g4(*),h4(*),icb(4,24,*),
     1  ipt(*),ijgt(*),ijx(*),ijy(*),ijz(*),klgt(*),klx(*),kly(*),
     2  klz(*),lmnp1(*),lmnv(3,*),mcons(*),nc(*),ncon(*),nfct(*),ngw(*),
     3  nrcr(*),nt(*),ntl(*),ntu(*),x(mcu,*),y(mcu,*),z(mcu,*),
     4  zet(mconu,*)
      dimension icxbg(3), jbl(2), kcxbg(3,3)
c
      ic=icb(inx,1,icc)
      jc=icb(jnx,1,icc)
      kc=icb(knx,1,icc)
      lc=icb(lnx,1,icc)
      kceqlc=kc.eq.lc
      do 12 jesfb=iscmci,2
      jbl(jesfb)=0
      do 10 ist=1,nst
        jbl(jesfb)=jbl(jesfb)+
     &    npriri(2,iscmci,ist)*nprirk(jesfb,iscmci,ist)
   10   continue
   12 continue
      if(iscmci.eq.2) go to 60
c
      jbld=jbl(2)-jbl(1)
      jblkl=ipq(krcru)*jbl(2)+krcru*jbl(1)
      fnfct=(nwt*nfct(icc))
      icxbg(1)=ijcxst(2)+((ic-1)*nc(js)+(jc-1))*ntij
      kcxbg(1,1)=klcxst(1)+ipq((kc-1)*nt(ksf)+1)*nprk(1,1)+(lc-1)*ntkl1
      kcxbg(2,1)=klcxst(2)+((kc-1)*nc(ks)+(lc-1))*ntkl
      kcxbg(3,1)=kcxbg(2,1)-(kc-lc)*(nc(ks)-1)*ntkl
      call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,jc,ks,ksf,kc,ks,ksf,lc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      ndxj=1
      ngtj=nt(ksf)**2
      iblbij=0
      do 48 ircr=1,ircru
      do 46 jrcr=1,jrcru
      do 44 krcr=1,krcru
      if(kceqlc) lrcru=krcr
      do 42 lrcr=1,lrcru
      if(krcr-lrcr) 18, 20, 22
   18 iblb=iblbij+(ipq(lrcr)+(krcr-1))*jbl(2)-(lrcr-1)*jbld
      kesfb=2
      kcxbg1=kcxbg(3,1)
      ngtk=1
      ngtl=nt(ksf)
      go to 26
   20 iblb=iblbij+ipq(krcr)*jbl(2)+(krcr-1)*jbl(1)
      kesfb=1
      go to 24
   22 iblb=iblbij+(ipq(krcr)+(lrcr-1))*jbl(2)-(krcr-1)*jbld
      kesfb=2
   24 kcxbg1=kcxbg(kesfb,1)
      ngtk=nt(ksf)
      ngtl=1
   26 icxs(2,1)=icxbg(1)
      do 40 it=itl,itu
        do 38 jt=jtl,jtu
          kcxs(kesfb,1)=kcxbg1
          ndxk=ndxj
          do 36 kt=ktl,ktu
            if(krcr.eq.lrcr.and.kceqlc) ltu=kt
            ndxl=ndxk
            do 34 lt=ltl,ltu
              val=g4(ndxl)
              if(abs(val).le.cutoff) go to 30
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, 1, val )
   30         ndxl=ndxl+ngtl
              kcxs(kesfb,1)=kcxs(kesfb,1)+nprk(kesfb,1)
   34       continue
            ndxk=ndxk+ngtk
   36     continue
          ndxj=ndxj+ngtj
          icxs(2,1)=icxs(2,1)+npri(2,1)
   38   continue
   40 continue
      continue
   42 continue
   44 continue
      iblbij=iblbij+jblkl
   46 continue
   48 continue
      return
c
   60 icxbg(2)=ikcxst(2)+((ic-1)*nc(ks)+(kc-1))*ntik
      icxbg(3)=icxbg(2)+(lc-kc)*ntik
      kcxbg(2,3)=jkcxst(2)+((jc-1)*nc(ks)+(kc-1))*ntjk
      kcxbg(2,2)=kcxbg(2,3)+(lc-kc)*ntjk
      if(kceqlc) then
        fnfct=(nwt*nfct(icc))
      else
        do 64 igw=2,ngw(icc)
          if(icb(inx,igw,icc).eq.ic.and.
     &       icb(jnx,igw,icc).eq.jc.and.
     &       icb(knx,igw,icc).eq.lc) go to 66
   64   continue
        iscmu = 3
        fnfct=(nwt*nfct(icc))
        go to 68
   66   fnfct=(2*nwt*nfct(icc))
      endif
      iscmu = 2
   68 do 98 iscm=2,iscmu
      if(iscm.eq.2) then
        call jandk(a,eta,g4,ipt,is,isf,ic,ks,ksf,kc,js,jsf,jc,ks,ksf,lc,
     1    ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2    nrcr,nt,ntl,ntu,x,y,z,zet)
      else
        call jandk(a,eta,g4,ipt,is,isf,ic,ks,ksf,lc,js,jsf,jc,ks,ksf,kc,
     1    ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2    nrcr,nt,ntl,ntu,x,y,z,zet)
      endif
      ndx=0
      iblb=0
      do 96 ircr=1,ircru
      do 94 krcr=1,krcru
      do 92 jrcr=1,jrcru
      do 90 lrcr=1,lrcru
      icxs(2,iscm)=icxbg(iscm)
      do 88 it=itl,itu
        do 86 kt=ktl,ktu
          kcxs(2,iscm)=kcxbg(2,iscm)
          do 84 jt=jtl,jtu
            do 82 lt=ltl,ltu
              ndx=ndx+1
              val=g4(ndx)
              if(abs(val).le.cutoff) go to 80
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, iscm, val )
   80         kcxs(2,iscm)=kcxs(2,iscm)+nprk(2,2)
   82       continue
   84     continue
          icxs(2,iscm)=icxs(2,iscm)+npri(2,2)
   86   continue
   88 continue
      iblb=iblb+jbl(2)
   90 continue
   92 continue
   94 continue
   96 continue
   98 continue
      return
      end


      subroutine fitchk
c
c      this routine does some error checking of the math expressions
c      for feffit.  the expressions have already been encoded in
c      fitinp, and the math syntax has been checked in encod, but not
c      all the checks could be done until all the input files have been
c      read in. done here are checks so that:
c        1.  all variables named in the math expresions must
c            be defined as either variables or functions.
c        2.  all defined variables and functions are used, or a
c            warning will be given.
c        3.  all encoded math expressions can be reliably decoded.
c            all math expressions are actually evaluated here.
c
c      also done here is the use of the zeroth (0th) path as the default
c      expression for the various path parameters. the 0th path will be
c      used here to overwrite those path parameters that were not
c      explicitly given in the input file.
c
c      copyright 1993 university of washington         matt newville
c
c----------------------------------------------------------------
       include 'fitcom.h'
c  from encod!
       integer   jconst, io2n(maxval)
       integer  iv, id, i, j, ip, jv, ilcl, inpath, jpar
       integer  idata, inpth0, idpath, ipar, nvar
       parameter (jconst = 8192)
c----------------------------------------------------------------------
c
c fix integer codes to put variables first, then constants, then
c ordered math expressions, so that a single pass will correctly
c evaluate all "set" values
c notes:  puts "local" variables  after constants
c         doesn't check for pathological recursion
       nvar = numvar
       call fixicd(icdval, maxval, micode, jconst, ixlocl,
     $      vnames, values, nvar, nconst, nmathx, io2n)
       if (nvar.ne.numvar)  call finmsg(3200,' ',' ',0)
c update xguess to reordered values!
       do 150 iv = 1, numvar
          xguess(iv) = values(iv)
 150      continue
c
       do 360 id = 1, ndata
          do 340 j = 1, mlocal
             do 320 i = 1, micode
                if (icdloc(i,j,id).eq.0) go to 325
                if ((icdloc(i,j,id).gt.0).and.
     $               (icdloc(i,j,id).le.nmathx) )
     $               icdloc(i,j,id) = io2n(icdloc(i,j,id))
 320         continue
 325         continue
 340      continue
 360   continue
c
       do 860 ip = 1, mpaths
          do 840 j = 1, mpthpr
             do 820 i = 1, micode
                if (icdpar(i,j,ip).eq.0) go to 825
                if ((icdpar(i,j,ip).gt.0).and.
     $               (icdpar(i,j,ip).le.nmathx))
     $               icdpar(i,j,ip) = io2n(icdpar(i,j,ip))
 820         continue
 825         continue
 840      continue
 860   continue
c
c  check that variables named in math expressions are defined
       do 1000 iv = 1, nmathx
          if ( (vnames(iv).ne.' ').and.(icdval(1,iv).eq.0) )
     $         call finmsg(3220,vnames(iv),' ',0)
 1000  continue
c
c  check that the variables and user-defined functions are used.
c  expection for '_bkg_#' - these won't show up in other user-def fun's
       do 2000 iv = 1, nmathx
          if ( vnames(iv)(1:6).ne.'_bkg_#' ) then
c     check other user-defined functions and local values
             do 1600  jv = 1, nmathx
                if ((icdval(1,jv).gt.0).and.
     $               (icdval(1,jv).le.ixlocl)) then
                   do 1500 i = 1, micode
                      if (icdval(i,jv).eq.iv) go to 1990
 1500              continue
                elseif(icdval(1,jv).gt.ixlocl) then
                   ilcl = icdval(1,jv) -ixlocl
                   do 1560 id = 1, ndata
                      do 1530 i = 1, micode
                         if (icdloc(i,ilcl,id).eq.iv) go to 1990
 1530                 continue
 1560              continue
                endif
 1600        continue
c     check path parameters
             do 1850  inpath = 1, mpaths
                do 1820  jpar = 1, mpthpr
                   do 1800 i   = 1, micode
                      if (icdpar(i,jpar,inpath).eq.iv) go to 1990
 1800              continue
 1820           continue
 1850        continue
             call finmsg(3240,vnames(iv),' ',-1)
          end if
 1990     continue
 2000  continue
c
c  load default path params from the Oth  path.  copy 0th path param
c  to all non-explicitily given path params for that data set.
       do 4200 idata = 1, ndata
          inpth0  = jdtpth(0,idata)
c   if a 0th path is given for this data set...
          if (inpth0.le.0)  go to 4190
c   check all paths for this data set ...
          do 4150 idpath = 1, mdpths
             inpath = jdtpth(idpath, idata)
             if (inpath.gt.0) then
c   that if a zeroth path param was given ***and***
c   an explicit path param was ***not*** given ...
                do 4100 ipar = 1, mpthpr
                   if ((icdpar(1,ipar,inpath).eq.0).and.
     $                  (icdpar(1,ipar,inpth0).ne.0))   then
c   that the zeroth path expression be copied.
                      do 4050 j = 1, micode
                         icdpar(j,ipar,inpath) = icdpar(j,ipar,inpth0)
 4050                 continue
                   endif
 4100           continue
             endif
 4150        continue
 4190     continue
 4200  continue
c
c  check the newly encoded expressions by evaluating them.
c  evaluate the user defined values
       id  = 1
       call setval(1,nmathx,icdval,maxval,micode,
     $      consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
       return
c  end subroutine fitchk
       end


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE YCLAIS(FRAME,NAME1,FILL,REFAPR,EPS,DATA,ERR,
     *                    PEDGR1,DESCR1,ISTAT)
*
*  Module number:
*
*  Module name: YCLAIS
*
*  Keyphrase:
*  ----------
*       Convert to flux units (new method)
*
*  Description:
*  ------------
*       This routine multiplies  OBJECT spectra by the appropriate inverse
*	sensitivity vector.  Points where the inverse sens. is 0.0 are
*	flagged with a data quality value of 200.0. This routine uses
*	the new method of applying a single average inverse sensitivity
*	curve to data from all apertures and using the APR_CORR routine
*	to correct the data for the relative throughputs of different
*	apertures.
*
*  FORTRAN name: YCLAIS.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       NAME1                   I       average INV. SENS. file (AISHFILE)
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       ymsput, yrdais
*
*  History:
*  --------
*  Version      Date        Author          Description
*    1		Oct 94	H. Bushouse	Designed and coded (based on YCLIVS)
*    1.1        Mar 97  M. De La Pena   Added KYDEPLOY to CONFG1
*    1.2        Sep 98  M. De La Pena   Removed dead statements.
*-------------------------------------------------------------------------------
*
* INPUTS:
*       frame - frame number
*       name1 - name of the inv. sens. ref. file
*       fill - bad epsilon limit
*	refapr - reference aperture from CCSB table
*       eps - epsilon array
*
* INPUT/OUTPUT
*       data - data array
*       err - error array
*
* OUTPUT:
*	pedgr1 - ref file PEDIGREE keyword
*	descr1 - ref file DESCRIP keyword
*       istat - error status
*
	IMPLICIT NONE
C
        INTEGER FRAME,ISTAT
	CHARACTER*3  REFAPR
        CHARACTER*64 NAME1
	CHARACTER*68 PEDGR1,DESCR1
        REAL FILL,EPS(*),DATA(*),ERR(*)
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C Common block containing confiquration parameters
C
        CHARACTER*5 DET
        CHARACTER*3 FGWAID,APERID,YTYPE(3)
        CHARACTER*1 POLID
        INTEGER FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME
        LOGICAL HEADER,TRAILR,DEFDDT,KYDPLY
        COMMON /CONFG1/KYDPLY,DET,FGWAID,APERID,POLID,YTYPE
        COMMON /CONFG2/FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME,HEADER,TRAILR,
     *          DEFDDT
        INTEGER NX,NOBJ,NSKY,NBCK
        COMMON /CONFG3/NX,NOBJ,NSKY,NBCK
        LOGICAL PAIRED
        REAL YUPPER,YLOWER
        COMMON /CCS1CM/PAIRED,YUPPER,YLOWER
C
C brigtness units for output files
C
        CHARACTER * 20 BUNITS(10)
        COMMON /BUNITS/ BUNITS
C
C Local variables
C
        REAL IVS(5000)
        CHARACTER*3 DTYPE
        INTEGER YOFF,SOFF,I,II,IS,IY
        CHARACTER*80 CONTXT
C---------------------------------------------------------------------------
C
C read reference file if first frame
C
        IF(FRAME.EQ.1)THEN
            CALL YRDAIS(NAME1,REFAPR,5000,IVS,PEDGR1,DESCR1,ISTAT)
            IF(ISTAT.NE.0)GO TO 1000
            CONTXT='Conversion to abs. flux units using '//NAME1
            CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
C
C If the reference file contains dummy data, then skip correction
C
            IF(PEDGR1(1:5).EQ.'DUMMY')THEN
               CONTXT='WARNING: PEDIGREE = DUMMY for '//NAME1//';'
               CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
               CONTXT='         Flux calibration will be skipped'
               CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
               GO TO 1000
	    END IF
C
        ENDIF
C------------------ end of frame 1 only processing ----------------------------
C
C Loop on slices
C
        DO 500 IS=1,SLICES
            SOFF = NX*YSTEPS*(IS-1)
C                                    --->offset for the slice
C
C loop on ysteps
C
            DO 400 IY=1,YSTEPS
C
C Is it a OBJ
C
                IF(IY.GT.3)THEN
                        DTYPE='OBJ'
                ELSE
                        DTYPE=YTYPE(IY)
                ENDIF
                IF(DTYPE.EQ.'OBJ')THEN
C
C multiply by the inv. sens.
C
                    YOFF = SOFF + (IY-1)*NX
                    DO 100 I=1,NX
                        II = YOFF + I
                        IF(EPS(II).LT.FILL)THEN
                           DATA(II) = DATA(II)*IVS(I)
                           ERR(II)  = ERR(II) *IVS(I)
                           IF(IVS(I).EQ.0 .AND. EPS(II).LT.200.0)
     *			      EPS(II)=200.0
                        ENDIF
100                 CONTINUE
                ENDIF
400         CONTINUE
500     CONTINUE
C
C update brightness units for output files
C
        BUNITS(2) = 'ERGS/CM**2/S/A'
        BUNITS(3) = 'ERGS/CM**2/S/A'
        BUNITS(5) = 'ERGS/CM**2/S/A'
C
        ISTAT = 0
1000    RETURN
        END


Module module_plumerise1

  integer, parameter :: nveg_agreg = 4

  real, dimension(nveg_agreg) :: firesize,mean_fct
CONTAINS
subroutine plumerise_driver (id,ktau,dtstep, &
           ebu,ebu_in,mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, &
           firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, &
           config_flags, t_phy,moist, &
           rho_phy,vvel,u_phy,v_phy,p_phy, &
           emis_ant,z_at_w,z,scale_fire_emiss, &
           ids,ide, jds,jde, kds,kde, &
           ims,ime, jms,jme, kms,kme, &
           its,ite, jts,jte, kts,kte )
  USE module_configure
  USE module_model_constants
  USE module_state_description
  USE module_zero_plumegen_coms
  USE module_chem_plumerise_scalar
  IMPLICIT NONE
   TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
   INTEGER, INTENT(IN ) :: id,ktau, &
                                  ids,ide, jds,jde, kds,kde, &
                                  ims,ime, jms,jme, kms,kme, &
                                  its,ite, jts,jte, kts,kte
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
         INTENT(IN ) :: moist
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_ebu ), &
         INTENT(INOUT ) :: ebu
   REAL, DIMENSION( ims:ime, 1, jms:jme, num_ebu_in ), &
         INTENT(INOUT ) :: ebu_in
   REAL, DIMENSION( ims:ime, jms:jme ), &
         INTENT(IN ) :: &
           mean_fct_agtf,mean_fct_agef,&
           mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, &
           firesize_agsv,firesize_aggr
   REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme,num_emis_ant ), &
         INTENT(IN ) :: &
                     emis_ant
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: &
                                                      t_phy, &
                 z,z_at_w,vvel,u_phy,v_phy,rho_phy,p_phy
      REAL, INTENT(IN ) :: &
                             dtstep
   LOGICAL, INTENT(IN ) :: scale_fire_emiss
      INTEGER :: nv, i, j, k, ksub, nspecies
      INTEGER :: ifplumerise
      real, dimension (num_ebu) :: eburn_in
      real, dimension (kte,num_ebu) :: eburn_out
      real, dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in &
                              ,rho_phyin ,qv_in ,zmid &
                              ,z_lev
      real :: sum_fires, ffirs, ratio
      ffirs=0.
      nspecies=num_ebu
      if( scale_fire_emiss ) then
        if( config_flags%chem_opt /= MOZCART_KPP .and. &
            config_flags%chem_opt /= MOZART_KPP .and. &
            config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then
          call wrf_error_fatal3("<stdin>",112,&
"Fire emission scaling only supported for MOZART_KPP, MOZCART_KPP chem options")
        endif
      endif
       if ( config_flags%biomass_burn_opt == BIOMASSB ) then
         do j=jts,jte
            do i=its,ite
               ebu(i,kts,j,p_ebu_no)=ebu_in(i,1,j,p_ebu_in_no)
               ebu(i,kts,j,p_ebu_no2)=ebu_in(i,1,j,p_ebu_in_no2)
               ebu(i,kts,j,p_ebu_co)=ebu_in(i,1,j,p_ebu_in_co)
               ebu(i,kts,j,p_ebu_co2)=ebu_in(i,1,j,p_ebu_in_co2)
               ebu(i,kts,j,p_ebu_eth)=ebu_in(i,1,j,p_ebu_in_eth)
               ebu(i,kts,j,p_ebu_hc3)=ebu_in(i,1,j,p_ebu_in_hc3)
               ebu(i,kts,j,p_ebu_hc5)=ebu_in(i,1,j,p_ebu_in_hc5)
               ebu(i,kts,j,p_ebu_hc8)=ebu_in(i,1,j,p_ebu_in_hc8)
               ebu(i,kts,j,p_ebu_ete)=ebu_in(i,1,j,p_ebu_in_ete)
               ebu(i,kts,j,p_ebu_olt)=ebu_in(i,1,j,p_ebu_in_olt)
               ebu(i,kts,j,p_ebu_oli)=ebu_in(i,1,j,p_ebu_in_oli)
               ebu(i,kts,j,p_ebu_pm25)=ebu_in(i,1,j,p_ebu_in_pm25)
               ebu(i,kts,j,p_ebu_pm10)=ebu_in(i,1,j,p_ebu_in_pm10)
               ebu(i,kts,j,p_ebu_dien)=ebu_in(i,1,j,p_ebu_in_dien)
               ebu(i,kts,j,p_ebu_iso)=ebu_in(i,1,j,p_ebu_in_iso)
               ebu(i,kts,j,p_ebu_api)=ebu_in(i,1,j,p_ebu_in_api)
               ebu(i,kts,j,p_ebu_lim)=ebu_in(i,1,j,p_ebu_in_lim)
               ebu(i,kts,j,p_ebu_tol)=ebu_in(i,1,j,p_ebu_in_tol)
               ebu(i,kts,j,p_ebu_xyl)=ebu_in(i,1,j,p_ebu_in_xyl)
               ebu(i,kts,j,p_ebu_csl)=ebu_in(i,1,j,p_ebu_in_csl)
               ebu(i,kts,j,p_ebu_hcho)=ebu_in(i,1,j,p_ebu_in_hcho)
               ebu(i,kts,j,p_ebu_ald)=ebu_in(i,1,j,p_ebu_in_ald)
               ebu(i,kts,j,p_ebu_ket)=ebu_in(i,1,j,p_ebu_in_ket)
               ebu(i,kts,j,p_ebu_macr)=ebu_in(i,1,j,p_ebu_in_macr)
               ebu(i,kts,j,p_ebu_ora1)=ebu_in(i,1,j,p_ebu_in_ora1)
               ebu(i,kts,j,p_ebu_ora2)=ebu_in(i,1,j,p_ebu_in_ora2)
               ebu(i,kts,j,p_ebu_bc)=ebu_in(i,1,j,p_ebu_in_bc)
               ebu(i,kts,j,p_ebu_oc)=ebu_in(i,1,j,p_ebu_in_oc)
               ebu(i,kts,j,p_ebu_so2)=ebu_in(i,1,j,p_ebu_in_so2)
               ebu(i,kts,j,p_ebu_dms)=ebu_in(i,1,j,p_ebu_in_dms)
            enddo
         enddo
       elseif ( config_flags%biomass_burn_opt == BIOMASSB_MOZC .or. &
                config_flags%biomass_burn_opt == BIOMASSB_MOZ ) then
         do j=jts,jte
            do i=its,ite
               ebu(i,kts,j,p_ebu_no)=ebu_in(i,1,j,p_ebu_in_no)
               ebu(i,kts,j,p_ebu_co)=ebu_in(i,1,j,p_ebu_in_co)
               ebu(i,kts,j,p_ebu_bigalk) = ebu_in(i,1,j,p_ebu_in_bigalk)
               ebu(i,kts,j,p_ebu_bigene) = ebu_in(i,1,j,p_ebu_in_bigene)
               ebu(i,kts,j,p_ebu_c2h4) = ebu_in(i,1,j,p_ebu_in_c2h4)
               ebu(i,kts,j,p_ebu_c2h5oh) = ebu_in(i,1,j,p_ebu_in_c2h5oh)
               ebu(i,kts,j,p_ebu_c2h6) = ebu_in(i,1,j,p_ebu_in_c2h6)
               ebu(i,kts,j,p_ebu_c3h6) = ebu_in(i,1,j,p_ebu_in_c3h6)
               ebu(i,kts,j,p_ebu_c3h8) = ebu_in(i,1,j,p_ebu_in_c3h8)
               ebu(i,kts,j,p_ebu_ch2o) = ebu_in(i,1,j,p_ebu_in_ch2o)
               ebu(i,kts,j,p_ebu_ch3cho) = ebu_in(i,1,j,p_ebu_in_ch3cho)
               ebu(i,kts,j,p_ebu_ch3coch3) = ebu_in(i,1,j,p_ebu_in_ch3coch3)
               ebu(i,kts,j,p_ebu_ch3oh) = ebu_in(i,1,j,p_ebu_in_ch3oh)
               ebu(i,kts,j,p_ebu_mek) = ebu_in(i,1,j,p_ebu_in_mek)
               ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2)
               ebu(i,kts,j,p_ebu_toluene) = ebu_in(i,1,j,p_ebu_in_toluene)
               ebu(i,kts,j,p_ebu_nh3) = ebu_in(i,1,j,p_ebu_in_nh3)
               ebu(i,kts,j,p_ebu_no2)=ebu_in(i,1,j,p_ebu_in_no2)
               ebu(i,kts,j,p_ebu_open) = ebu_in(i,1,j,p_ebu_in_open)
               ebu(i,kts,j,p_ebu_c10h16) = ebu_in(i,1,j,p_ebu_in_c10h16)
               ebu(i,kts,j,p_ebu_mgly) = ebu_in(i,1,j,p_ebu_in_mgly)
               ebu(i,kts,j,p_ebu_ch3cooh) = ebu_in(i,1,j,p_ebu_in_ch3cooh)
               ebu(i,kts,j,p_ebu_cres) = ebu_in(i,1,j,p_ebu_in_cres)
               ebu(i,kts,j,p_ebu_glyald) = ebu_in(i,1,j,p_ebu_in_glyald)
               ebu(i,kts,j,p_ebu_gly)=ebu_in(i,1,j,p_ebu_in_gly)
               ebu(i,kts,j,p_ebu_acetol) = ebu_in(i,1,j,p_ebu_in_acetol)
               ebu(i,kts,j,p_ebu_isop) = ebu_in(i,1,j,p_ebu_in_isop)
               ebu(i,kts,j,p_ebu_macr) = ebu_in(i,1,j,p_ebu_in_macr)
               ebu(i,kts,j,p_ebu_mvk)=ebu_in(i,1,j,p_ebu_in_mvk)
               ebu(i,kts,j,p_ebu_ol2)=ebu_in(i,1,j,p_ebu_in_ol2)
               ebu(i,kts,j,p_ebu_par)=ebu_in(i,1,j,p_ebu_in_par)
               ebu(i,kts,j,p_ebu_eth)=ebu_in(i,1,j,p_ebu_in_eth)
               ebu(i,kts,j,p_ebu_olt)=ebu_in(i,1,j,p_ebu_in_olt)
               ebu(i,kts,j,p_ebu_oli)=ebu_in(i,1,j,p_ebu_in_oli)
               ebu(i,kts,j,p_ebu_iso)=ebu_in(i,1,j,p_ebu_in_iso)
               ebu(i,kts,j,p_ebu_tol)=ebu_in(i,1,j,p_ebu_in_tol)
               ebu(i,kts,j,p_ebu_csl)=ebu_in(i,1,j,p_ebu_in_csl)
               ebu(i,kts,j,p_ebu_hcho)=ebu_in(i,1,j,p_ebu_in_hcho)
               ebu(i,kts,j,p_ebu_ald)=ebu_in(i,1,j,p_ebu_in_ald)
               ebu(i,kts,j,p_ebu_ket)=ebu_in(i,1,j,p_ebu_in_ket)
               ebu(i,kts,j,p_ebu_xyl)=ebu_in(i,1,j,p_ebu_in_xyl)
               ebu(i,kts,j,p_ebu_ora1)=ebu_in(i,1,j,p_ebu_in_ora1)
               ebu(i,kts,j,p_ebu_ora2)=ebu_in(i,1,j,p_ebu_in_ora2)
               ebu(i,kts,j,p_ebu_co2)=ebu_in(i,1,j,p_ebu_in_co2)
               ebu(i,kts,j,p_ebu_ete)=ebu_in(i,1,j,p_ebu_in_ete)
               ebu(i,kts,j,p_ebu_dien)=ebu_in(i,1,j,p_ebu_in_dien)
               ebu(i,kts,j,p_ebu_api)=ebu_in(i,1,j,p_ebu_in_api)
               ebu(i,kts,j,p_ebu_lim)=ebu_in(i,1,j,p_ebu_in_lim)
            enddo
         enddo
         if( config_flags%biomass_burn_opt == BIOMASSB_MOZC ) then
           do j=jts,jte
             ebu(its:ite,kts,j,p_ebu_pm10) = ebu_in(its:ite,1,j,p_ebu_in_pm10)
             ebu(its:ite,kts,j,p_ebu_pm25) = ebu_in(its:ite,1,j,p_ebu_in_pm25)
             ebu(its:ite,kts,j,p_ebu_oc) = ebu_in(its:ite,1,j,p_ebu_in_oc)
             ebu(its:ite,kts,j,p_ebu_bc) = ebu_in(its:ite,1,j,p_ebu_in_bc)
           enddo
         endif
       elseif ( config_flags%biomass_burn_opt == BIOMASSB_SAPRC ) then
         do j=jts,jte
            do i=its,ite
               ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co)
               ebu(i,kts,j,p_ebu_no) = ebu_in(i,1,j,p_ebu_in_no)
               ebu(i,kts,j,p_ebu_no2) = ebu_in(i,1,j,p_ebu_in_no2)
               ebu(i,kts,j,p_ebu_so2) = ebu_in(i,1,j,p_ebu_in_so2)
               ebu(i,kts,j,p_ebu_nh3) = ebu_in(i,1,j,p_ebu_in_nh3)
               ebu(i,kts,j,p_ebu_ch4) = ebu_in(i,1,j,p_ebu_in_ch4)
               ebu(i,kts,j,p_ebu_acet) = ebu_in(i,1,j,p_ebu_in_acet)
               ebu(i,kts,j,p_ebu_c2h6) = ebu_in(i,1,j,p_ebu_in_c2h6)
               ebu(i,kts,j,p_ebu_c3h8) = ebu_in(i,1,j,p_ebu_in_c3h8)
               ebu(i,kts,j,p_ebu_alk3) = ebu_in(i,1,j,p_ebu_in_alk3)
               ebu(i,kts,j,p_ebu_alk4) = ebu_in(i,1,j,p_ebu_in_alk4)
               ebu(i,kts,j,p_ebu_alk5) = ebu_in(i,1,j,p_ebu_in_alk5)
               ebu(i,kts,j,p_ebu_aro1) = ebu_in(i,1,j,p_ebu_in_aro1)
               ebu(i,kts,j,p_ebu_aro2) = ebu_in(i,1,j,p_ebu_in_aro2)
               ebu(i,kts,j,p_ebu_bald) = ebu_in(i,1,j,p_ebu_in_bald)
               ebu(i,kts,j,p_ebu_ccho) = ebu_in(i,1,j,p_ebu_in_ccho)
               ebu(i,kts,j,p_ebu_cco_oh) = ebu_in(i,1,j,p_ebu_in_cco_oh)
               ebu(i,kts,j,p_ebu_ethene) = ebu_in(i,1,j,p_ebu_in_ethene)
               ebu(i,kts,j,p_ebu_hcho) = ebu_in(i,1,j,p_ebu_in_hcho)
               ebu(i,kts,j,p_ebu_hcooh) = ebu_in(i,1,j,p_ebu_in_hcooh)
               ebu(i,kts,j,p_ebu_hono) = ebu_in(i,1,j,p_ebu_in_hono)
               ebu(i,kts,j,p_ebu_isoprene) = ebu_in(i,1,j,p_ebu_in_isoprene)
               ebu(i,kts,j,p_ebu_mek) = ebu_in(i,1,j,p_ebu_in_mek)
               ebu(i,kts,j,p_ebu_meoh) = ebu_in(i,1,j,p_ebu_in_meoh)
               ebu(i,kts,j,p_ebu_methacro) = ebu_in(i,1,j,p_ebu_in_methacro)
               ebu(i,kts,j,p_ebu_mgly) = ebu_in(i,1,j,p_ebu_in_mgly)
               ebu(i,kts,j,p_ebu_mvk) = ebu_in(i,1,j,p_ebu_in_mvk)
               ebu(i,kts,j,p_ebu_ole1) = ebu_in(i,1,j,p_ebu_in_ole1)
               ebu(i,kts,j,p_ebu_ole2) = ebu_in(i,1,j,p_ebu_in_ole2)
               ebu(i,kts,j,p_ebu_phen) = ebu_in(i,1,j,p_ebu_in_phen)
               ebu(i,kts,j,p_ebu_prod2) = ebu_in(i,1,j,p_ebu_in_prod2)
               ebu(i,kts,j,p_ebu_rcho) = ebu_in(i,1,j,p_ebu_in_rcho)
               ebu(i,kts,j,p_ebu_rno3) = ebu_in(i,1,j,p_ebu_in_rno3)
               ebu(i,kts,j,p_ebu_terp) = ebu_in(i,1,j,p_ebu_in_terp)
               ebu(i,kts,j,p_ebu_pm10) = ebu_in(i,1,j,p_ebu_in_pm10)
               ebu(i,kts,j,p_ebu_pm25) = ebu_in(i,1,j,p_ebu_in_pm25)
               ebu(i,kts,j,p_ebu_oc) = ebu_in(i,1,j,p_ebu_in_oc)
               ebu(i,kts,j,p_ebu_bc) = ebu_in(i,1,j,p_ebu_in_bc)
            enddo
         enddo
       elseif ( config_flags%biomass_burn_opt == BIOMASSB_GHG ) then
         do j=jts,jte
            do i=its,ite
               ebu(i,kts,j,p_ebu_co) = ebu_in(i,1,j,p_ebu_in_co)
               ebu(i,kts,j,p_ebu_co2) = ebu_in(i,1,j,p_ebu_in_co2)
               ebu(i,kts,j,p_ebu_ch4) = ebu_in(i,1,j,p_ebu_in_ch4)
            enddo
          enddo
       endif
       do nv=1,num_ebu
          do j=jts,jte
            do k=kts+1,kte
               do i=its,ite
                 ebu(i,k,j,nv)=0.
               enddo
            enddo
          enddo
       enddo
    ifplumerise = 1
    if(ifplumerise == 1) then
       do j=jts,jte
          do i=its,ite
            sum_fires=mean_fct_agtf(i,j)+mean_fct_agef(i,j)+mean_fct_agsv(i,j) &
                    +mean_fct_aggr(i,j)
            if(sum_fires.lt.1.e-6)Cycle
            sum_fires=firesize_agtf(i,j)+firesize_agef(i,j)+firesize_agsv(i,j) &
                    +firesize_aggr(i,j)
            if(sum_fires.lt.1.e-6)Cycle
            eburn_out=0.
            mean_fct(1)=mean_fct_agtf(i,j)
            mean_fct(2)=mean_fct_agef(i,j)
            mean_fct(3)=mean_fct_agsv(i,j)
            mean_fct(4)=mean_fct_aggr(i,j)
            firesize(1)=firesize_agtf(i,j)
            firesize(2)=firesize_agef(i,j)
            firesize(3)=firesize_agsv(i,j)
            firesize(4)=firesize_aggr(i,j)
            do nv=1,num_ebu
            eburn_in(nv)=ebu(i,kts,j,nv)
            enddo
            if( maxval( eburn_in(:) ) == 0. ) cycle
            do k=kts,kte
              u_in(k)=u_phy(i,k,j)
              v_in(k)=v_phy(i,k,j)
              w_in(k)=vvel(i,k,j)
              qv_in(k)=moist(i,k,j,p_qv)
              pi_in(k)=cp*(p_phy(i,k,j)/p1000mb)**rcp
              zmid(k)=z(i,k,j)-z_at_w(i,kts,j)
              z_lev(k)=z_at_w(i,k,j)-z_at_w(i,kts,j)
              rho_phyin(k)=rho_phy(i,k,j)
              theta_in(k)=t_phy(i,k,j)/pi_in(k)*cp
            enddo
            call plumerise(kte,1,1,1,1,1,1,firesize,mean_fct &
                    ,nspecies,eburn_in,eburn_out &
                    ,u_in ,v_in ,w_in ,theta_in ,pi_in &
                    ,rho_phyin ,qv_in ,zmid &
                    ,z_lev )
            do nv=1,num_ebu
              do k=kts+1,kte
                ebu(i,k,j,nv)=eburn_out(k,nv)*(z_at_w(i,k+1,j)-z_at_w(i,k,j))
              enddo
            enddo
has_total_emissions : &
            if( scale_fire_emiss ) then
is_mozcart : &
              if( (config_flags%chem_opt == MOZCART_KPP .and. &
                   config_flags%biomass_burn_opt == BIOMASSB_MOZC) .or. &
                  (config_flags%chem_opt == MOZART_KPP .and. &
                   config_flags%biomass_burn_opt == BIOMASSB_MOZ) .or. &
                  (config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP .and. &
                   config_flags%biomass_burn_opt == BIOMASSB_MOZC) ) then
                sum_fires = 0.
                do k = kts,kte
                  sum_fires = sum_fires + ebu(i,k,j,p_ebu_co)
                end do
                if( sum_fires > 0. ) then
                  ratio = ebu(i,kts,j,p_ebu_co)/sum_fires
                else
                  ratio = 0.
                endif
                do k = kts,kte
                  ebu(i,k,j,p_ebu_no) = ebu(i,k,j,p_ebu_no)*ratio
                  ebu(i,k,j,p_ebu_co) = ebu(i,k,j,p_ebu_co)*ratio
                  ebu(i,k,j,p_ebu_bigalk) = ebu(i,k,j,p_ebu_bigalk)*ratio
                  ebu(i,k,j,p_ebu_bigene) = ebu(i,k,j,p_ebu_bigene)*ratio
                  ebu(i,k,j,p_ebu_c2h4) = ebu(i,k,j,p_ebu_c2h4)*ratio
                  ebu(i,k,j,p_ebu_c2h5oh) = ebu(i,k,j,p_ebu_c2h5oh)*ratio
                  ebu(i,k,j,p_ebu_c2h6) = ebu(i,k,j,p_ebu_c2h6)*ratio
                  ebu(i,k,j,p_ebu_c3h6) = ebu(i,k,j,p_ebu_c3h6)*ratio
                  ebu(i,k,j,p_ebu_c3h8) = ebu(i,k,j,p_ebu_c3h8)*ratio
                  ebu(i,k,j,p_ebu_ch2o) = ebu(i,k,j,p_ebu_ch2o)*ratio
                  ebu(i,k,j,p_ebu_ch3cho) = ebu(i,k,j,p_ebu_ch3cho)*ratio
                  ebu(i,k,j,p_ebu_ch3coch3) = ebu(i,k,j,p_ebu_ch3coch3)*ratio
                  ebu(i,k,j,p_ebu_ch3oh) = ebu(i,k,j,p_ebu_ch3oh)*ratio
                  ebu(i,k,j,p_ebu_mek) = ebu(i,k,j,p_ebu_mek)*ratio
                  ebu(i,k,j,p_ebu_so2) = ebu(i,k,j,p_ebu_so2)*ratio
                  ebu(i,k,j,p_ebu_toluene) = ebu(i,k,j,p_ebu_toluene)*ratio
                  ebu(i,k,j,p_ebu_nh3) = ebu(i,k,j,p_ebu_nh3)*ratio
                  ebu(i,k,j,p_ebu_no2) = ebu(i,k,j,p_ebu_no2)*ratio
                  ebu(i,k,j,p_ebu_open) = ebu(i,k,j,p_ebu_open)*ratio
                  ebu(i,k,j,p_ebu_c10h16) = ebu(i,k,j,p_ebu_c10h16)*ratio
                  ebu(i,k,j,p_ebu_mgly) = ebu(i,k,j,p_ebu_mgly)*ratio
                  ebu(i,k,j,p_ebu_ch3cooh) = ebu(i,k,j,p_ebu_ch3cooh)*ratio
                  ebu(i,k,j,p_ebu_cres) = ebu(i,k,j,p_ebu_cres)*ratio
                  ebu(i,k,j,p_ebu_glyald) = ebu(i,k,j,p_ebu_glyald)*ratio
                  ebu(i,k,j,p_ebu_gly) = ebu(i,k,j,p_ebu_gly)*ratio
                  ebu(i,k,j,p_ebu_acetol) = ebu(i,k,j,p_ebu_acetol)*ratio
                  ebu(i,k,j,p_ebu_isop) = ebu(i,k,j,p_ebu_isop)*ratio
                  ebu(i,k,j,p_ebu_macr) = ebu(i,k,j,p_ebu_macr)*ratio
                  ebu(i,k,j,p_ebu_mvk) = ebu(i,k,j,p_ebu_mvk)*ratio
                end do
                if( config_flags%chem_opt == MOZCART_KPP .or. &
                    config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
                  do k = kts,kte
                    ebu(i,k,j,p_ebu_pm10) = ebu(i,k,j,p_ebu_pm10)*ratio
                    ebu(i,k,j,p_ebu_pm25) = ebu(i,k,j,p_ebu_pm25)*ratio
                    ebu(i,k,j,p_ebu_oc) = ebu(i,k,j,p_ebu_oc)*ratio
                    ebu(i,k,j,p_ebu_bc) = ebu(i,k,j,p_ebu_bc)*ratio
                  end do
                endif
              end if is_mozcart
            end if has_total_emissions
          enddo
          enddo
    endif
end subroutine plumerise_driver
END Module module_plumerise1


      SUBROUTINE INJECT(ISUB)
*
*
*       Injection of chain member.
*       --------------------------
*
      INCLUDE 'common6.h'
      PARAMETER  (NMX=10,NMX3=3*NMX,NMX4=4*NMX,NMXm=NMX*(NMX-1)/2)
      REAL*8  M,MASS,MC
      COMMON/ARCHAIN/XCH(NMX3),VCH(NMX3),WTTL,M(NMX),
     &           XCDUM(NMX3),WCDUM(NMX3),MC(NMX),
     &           XI(NMX3),VI(NMX3),MASS,RINV(NMXm),RSUM,INAME(NMX),NN
      COMMON/CHAINC/  XC(3,NCMAX),UC(3,NCMAX),BODYC(NCMAX),ICH,
     &                LISTC(LMAX)
      COMMON/CHREG/  TIMEC,TMAX,RMAXC,CM(10),NAMEC(NMX),NSTEP1,KZ27,KZ30
      COMMON/CLUMP/   BODYS(NCMAX,5),T0S(5),TS(5),STEPS(5),RMAXS(5),
     &                NAMES(NCMAX,5),ISYS(5)
      COMMON/CCOLL2/  QK(NMX4),PK(NMX4),RIK(NMX,NMX),SIZE(NMX),VSTAR1,
     &                ECOLL1,RCOLL,QPERI,ISTAR(NMX),ICOLL,ISYNC,NDISS1
*
*
*       Determine closest approaching neighbour (JCLOSE for ABSORB).
      RX = 1.0
      DO 10 I = IFIRST,N
          IF (I.EQ.ICH) GO TO 10
          RIJ2 = 0.0
          DO 5 K = 1,3
              RIJ2 = RIJ2 + (X(K,I) - X(K,ICH))**2
    5     CONTINUE
          IF (RIJ2.LT.RX) THEN
              RD = 0.0
              DO 6 K = 1,3
                  RD = RD + (X(K,I)-X(K,ICH))*(XDOT(K,I)-XDOT(K,ICH))
    6         CONTINUE
              IF (RD.LT.0.0) THEN
                  JCLOSE = I
                  RX = RIJ2
              END IF
          END IF
   10 CONTINUE
*
*       Save KS component for termination.
      JCOMP = JCLOSE
      WRITE (6,20)  TIME+TOFF, NN, NAME(JCLOSE), SQRT(RX), 1.0/RINV(1)
   20 FORMAT (/,' CHAIN INJECT    T NN NM RX RBH ',F8.3,I4,I8,1P,2E10.2)
      CALL FLUSH(6)
*
*     NNB = LISTC(1) + 2
*     LISTC(NNB) = ICH
*     DO 30 L = 2,NNB
*     J = LISTC(L)
*     WRITE (6,25) J, NAME(J),BODY(J), STEP(J), (X(K,J),K=1,3)
*  25 FORMAT (' LISTC   J NM S M X  ',2I7,1P,2E10.2,2X,3E10.2)
*  30 CONTINUE
*
*       Increase chain membership in the usual way.
      MASS = MASS + BODY(JCLOSE)
      CALL ABSORB(ISUB)
*
*       Update perturber list.
      CALL CHLIST(ICH)
*
      RETURN
*
      END


      subroutine iniflu(npt,iyd,UTsec,z,glat,glong,stl,f107,
     .                ap,chi,Ne,Te,Tj,indlim,jpreci,
     .             Nh,No,No2,Nn2,Nn,Tn,Po,Po2,Pn2,Ph,Pn,Heat,
     .
     .                  nspec,knm,nen,nang,nango2,nalt,
     .                  ddeng,botE,centE,gmu,gwt,angzb,altkm,altcm,
     .                  dipang,smgdpa,
     .            fluxup,fluxdown,densneut,tneutre,tempexo,
     .                  albedo,chideg,denelc,temelc,temion,UT,hrloc,
     .                  ztop,zbot,colden,day,year)
c
c     Initialisation des parametres necessaires au programme cinetique
c     lorsque celui-ci est appele par le programme fluide.
c
c     ENTREES DE INIFLU ISSUES DU PROGRAMME FLUIDE
c     --------------------------------------------
c     Passees par liste d'appel :
c      ---------------------------
C       IYD     jour de l'annee sous la forme YYJJJ,
c               avec YY=annee et JJJ=jour dans l'annee
C       SEC     temps universel                                 (s)
C       Z       tableau des altitudes                           (km)
C       GLAT    latitude geographique                           (degres)
C       GLONG   longitude geographique                          (degres)
C       STL     temps local                                     (heure)
C       F107    flux solaire moyen
C       F107    flux solaire instantane de la veille
C       AP      tableau des ap (convention MSIS86)
c     CHI     Angle solaire zenithal (radian)
c
C       Ne      tableau des concentrations electroniques
c               (unites normalisees)
C       Te      tableau des temperatures electroniques
c               (unites normalisees)
C       Tj      tableau des temperatures de l'ion O+
c               (unites normalisees)
C       NX      nombre d'altitudes resolues
c     indlim     = Nombre d'altitudes de calcul du transport fluide
c     npt     = dimension des tableaux utilises par fluide.
c       Nh(npt),No(npt),No2(npt),Nn2(npt),Nn(npt),Tn(npt)
c         = densites et temperature neutres de fluide.f
C       N_0     coefficient de normalisation des concentrations (cm-3)
C       T_0     coefficient de normalisation des temperatures   (K)
c     Px     Productions, simplement initialisees a 0 ici
c     Heat     Chauffage, simplement initialisees a 0 ici
c    jpreci = 0 if sun only, 1 if prec. only, 2 if both
c
c     PARAMETRES INTERNES A CE SPGMME
c     -------------------------------
c     En particulier pour l'ecriture eventuelle de ELEC et NEUTRAL
c     index(7)= index des elements neutres de fluide.f
c     ndelta     = nombre d'altitudes a rajouter pour descendre jusqu'a
c         90 km
c     ztrav     = altitudes a rajouter pour descendre jusqu'a 90 km
c     dens(8,100),fcdens(8),Ttrav,xmasdens,fctemp
c     modatmos, alpha (ici, param. bidon),dne(id.),dte,dti,spfac
c     moddene,modtemp,modcomp,z50,derivte,comp
c
c     sw : tableau de switches pour msis95
c
c     SORTIES DE INIFLU INTERNES A CE SPGMME, POUR LE TRANS. CINETIQUE
c     ----------------------------------------------------------------
c     A terme, tout ceci devra etre mieux calcule...
c    nspec, knm, nen Emax, nang, nango2, stepnrj, anormnrj, ddeng,
c    botE, centE, pi, pideg, albedo
c
c     SORTIES DE INIFLUX CALCULEES A PARTIR DES ENTREES DE FLUIDE
c     ------------------------------------------------------------
c    altkm, altcm(ialt) = altitudes
c     zbot, ztop
c     fluxup, fluxdown
c     smgdpa
c     tempexo
c     densneut,colden, tneutre
c    UT, hrloc, year, nan, day, Apind, chideg, jpreci,
c    Flux_elec_int = Flux d'electrons integre (cm-2.s-1.sr-1)
c     Flux_ener_int = Flux d'energie integre (kev.cm-2.s-1.sr-1)
c           par liste d'appel
c
        implicit none
c
        logical flg_err
        common/err/flg_err

        integer jpreci0
        logical flgini,flgchi
        data flgini/.true./
        data flgchi/.false./

        include 'TRANSPORT.INC'
c
         integer npt,ind,indref,i
         integer nspec,knm,nen,nang,nango2,nalt,indlim,index(7)
        data index/3,4,2,7,1,8,5/
        integer in
        data in/1/

c
        real Nh(npt),No(npt),No2(npt),Nn2(npt),Nn(npt),Tn(npt)
        real Ph(npt),Po(npt),Po2(npt),Pn2(npt),Pn(npt),Heat(npt)

        real Eave,Flux_elec_int,E,Flux_ener_int,coef_flux,fluxE
c
        real z(npt),Ne(npt),Te(npt),Tj(npt)
c
         real stepnrj,anormnrj
         real ddeng(nbren),botE(nbren),centE(nbren),Emax
         real angzb(2*nbrango2),gmu(2*nbrango2),gwt(2*nbrango2)
         real altkm(nbralt),altcm(nbralt),dipang(nbralt),smgdpa(nbralt)
        real fluxdown(nbren,nbrango2),fluxup(nbren,nbrango2)
         real tneutre(nbralt),densneut(8,nbralt),colden(8,nbralt)
         real denelc(nbralt),temelc(nbralt),temion(nbralt)
         real dne(nbralt),dte(nbralt),dti(nbralt)
         real tempexo,albedo
         real UT,UTsec,hrloc,stl,year,day,chi,chideg,f107(3),
     .        ap(7),glong,glat
         real ztop,zbot
         integer iyd,nan,jpreci
        integer ialt,ien,iang,isp,ii
         real pi,d(8),t(2),sw(26)
         integer ndelta
         real ztrav(50),Ttrav(50)
          real dens(8,50),fcdens(8),xmasdens(50),fctemp,comp(nbralt)
         integer isotro,modatmos,moddene,modtemp,modcomp
c     Pour IRI :
         integer nziri,jmag,iddd
         real ztopiri,zbotiri,zstepiri,ziri(5),Neiri(50),xind
        logical jf(12)
        real outiri1(11,50),outiri2(30),traviri(5)
        real date,xbid,ybid,zbid,bf,decbid
        real mgdpa(nbralt),field(nbralt)
c
        real lonmag,latmag,tmag,cofo,cofh,cofn,Fe0,Ee0,Fi0,Ei0,chi0
        real Bmag,dipangle,Enord,Eest,vperpnord,vperpest,vhorizon,vpara
        real ddp,Jtop
        integer ikp

        common/buff/lonmag,latmag,tmag,ikp,cofo,cofh,cofn,chi0,
     &                  Fe0,Ee0,Fi0,Ei0,
     &                  Bmag,dipangle,Enord,Eest,
     &                  vperpnord,vperpest,vhorizon,vpara,ddp,Jtop

         real*8 dtu,dlon,dlat
         real kp
        common/prec/coef_flux

         real alpha,spfac,z50,derivte(nbralt)
         integer icont(12),iprt(9)
c
         data fcdens /1.,1.,1.,1.,1.,1.,1.,1./
        data fctemp /1./,modatmos /2/,moddene /1/,modtemp/1/,modcomp/1/
         data icont /0,0,0,0,0,0,0,0,0,0,0,0/
         data iprt /1,1,0,0,0,0,0,0,0/
         integer fanion
         data fanion /0/
c       Les options sont les options standard de IRI
        data jf /.false.,.false.,.false.,.true.,.true.,.true.,.true.,
     .           .true.,.true.,.true.,.true.,.true./
c
        real PT(150),PD(150,9),PS(150),PDL(25,2),PTL(100,4),PMA(100,10)
        COMMON /PARM6/     PT,PD,PS,PDL,PTL,PMA

        integer ndeg_pn,ndeg_pf

c
c
c ====================================================================
c     definition de la grille d'altitude
c ====================================================================
c
         ndelta = 0
        do ialt=1,indlim
          altkm(ialt)=z(indlim+1-ialt)
          altcm(ialt)=1.e5*altkm(ialt)
        enddo
         nalt = indlim
c     Les altitudes doivent descendre a 90 km au moins.
c     On genere eventuellement les altitudes supplementaires pour ca.
          if(z(1).gt.90.)then
c       On va calculer une grille avec un pas moyen de 2 km
           ndelta = ifix((z(1) - 90.)/2.)
           ndelta = min(ndelta,50)
           if (ndelta.gt.1) then
             call gridexp (ndelta,90.,z(1),ztrav)
             do ialt = 2,ndelta
               nalt = nalt + 1
               altkm(nalt) = ztrav(ialt)
              altcm(nalt)=1.e5*altkm(nalt)
             enddo
           endif
         endif
        ztop=altkm(1)
        zbot=altkm(nalt)
c
c ====================================================================
c     Chargement de l'atmosphere neutre
c ====================================================================
c
c
c     Pour le moment, le code fluide ne se sert pas de he.
        nspec = 4
c
        day=mod(float(iyd),1000.)
         ikp = 2*max(0.,log((ap(1)+2.5)/4.))+.5
        UT=UTsec/3600.
        hrloc=stl
        year=float(iyd/1000)
        if (iyd.lt.1900000) then
          year=year+1900.
        endif
        nan=ifix(year)
        tempexo=Tn(indlim)
c
        do ialt=1,indlim
          densneut(1,ialt)=Nn2(indlim+1-ialt)
          densneut(2,ialt)=No2(indlim+1-ialt)
          densneut(3,ialt)=No (indlim+1-ialt)
          densneut(4,ialt)=Nh (indlim+1-ialt)
          tneutre(ialt)=Tn(indlim+1-ialt)
         enddo
c     Si le transport fluide ne descend pas assez bas, il fo modeliser
c     les densites neutres en bas
      if(z(1).gt.90. .and. ndelta.gt.1)then
       do ialt = 2,ndelta
c         ... msis90
          if (flg_err) then
            print*,iyd,UTsec,ztrav(ialt),glat,glong,
     &    stl,f107(3),f107(2),ap
            endif

       print*,'iniflux call gtd6'
          call gtd6(iyd,UTsec,ztrav(ialt),glat,glong,stl,
     .            f107(3),f107(2),ap,48,d,t)
c
         densneut(1,indlim+ialt-1)=d(3)        ! N2
         densneut(2,indlim+ialt-1)=d(4)        ! O2
         densneut(3,indlim+ialt-1)=d(2)        ! O
         densneut(4,indlim+ialt-1)=d(7)        ! H
         tneutre(indlim+ialt-1)=t(2)
        enddo
       endif
c
c     Calcul de la densite colonne (cm-2).
        print*,'call column'
        call column(nbralt,nalt,altcm,nspec,densneut,colden)
c
c
c ====================================================================
c     Chargement des conditions ionospheriques
c ====================================================================
c
c     Attention ! Le programme fluide sort des te/ti a basse alt.
c     qui peuvent etre < Tn ...
        do ialt=1,indlim
          denelc(ialt)=N_0*Ne(indlim+1-ialt)
          temelc(ialt)=max(T_0*Te(indlim+1-ialt),tneutre(ialt))
          temion(ialt)=max(T_0*Tj(indlim+1-ialt),tneutre(ialt))
        enddo
c     Si le transport fluide ne descend pas assez bas, il fo modeliser
c     Ne, Te, Ti
c
        if(z(1).gt.90. .and. ndelta.gt.1)then
          nziri = 5
          ztopiri = altkm(indlim+1)
          zbotiri = altkm(nalt)
          zstepiri = (ztopiri-zbotiri)/4.
          call gridcst (nziri,zbotiri,ztopiri,ziri,traviri)
c         Calcule Ne ...
          jf(1) = .true.
c       IRI n'estime pas les Te Ti en dessous de 120 km.
          jf(2) = .false.
c         Les latitudes et longitudes sont geographiques.
          jmag = 0
c         La date est en jours : negative pour IRI
          iddd = -ifix(day)
c         L'indice est f107 : negatif pour IRI
          xind = -f107(3)
          call iris12(jf,jmag,glat,glong,xind,iddd,hrloc,zbotiri,
     .              ztopiri,zstepiri,outiri1,outiri2)
c       Il reste a interpoler depuis la grille reguliere de iri
c       vers la grille exp de calcul :
       do ialt = 1,nziri
         traviri(ialt) = outiri1(1,ialt)/1.e+06
       enddo

       print*,'call intlin'
       call intlin(nziri,ziri,traviri,ndelta,ztrav,Neiri)
       do ialt = 2,ndelta
        denelc(indlim+ialt-1)=Neiri(ndelta+2-ialt)
       enddo
c
c       iri ne modelise pas les temperatures en dessous de 120 km-->
c       on prend Te=Ti=Tn
       do ialt = indlim+1,nalt
        temelc(ialt)=tneutre(ialt)
        temion(ialt)=tneutre(ialt)
       enddo
        endif
c
c     Initialisation a 0 des productions
         call zeroit(Pn2,npt)
         call zeroit(Po2,npt)
         call zeroit(Po,npt)
         call zeroit(Ph,npt)
         call zeroit(Pn,npt)
         call zeroit(Heat,npt)
c
c
c ====================================================================
c     definition des grilles de calcul
c ====================================================================
c
c     Numero d'identification du run
        knm=ifix(UTsec)
c     S'il y a des precipitations, elles sont isotropes
         isotro = 1

c     Si il n'y a pas de precipitations, on garde la 1ere grille.
       if (jpreci.eq.0)then
           Emax = 300.
           print*,'call quelle_grille'
           call quelle_grille(Emax,nen,centE,botE,ddeng,
     .        nang,nango2,gmu,gwt,angzb)
       else
c
c       Il faut connaitre l'energie caracteristique des precipitations
c       pour definir sur quelle grille il faut travailler. On
c       calcule le flux donne par le modele statistique de Hardy.
c       Ce programme donne
c         le flux total Flux_elec_int EN ELECTRONS/CM2.S.SR
c         le flux total d'energie Flux_ener_int EN KEV/CM2.S.SR
c
c      call prec_time(iyd,UTsec,Eave,Flux_ener_int)
          dlon=dble(15.*tmag)
          dlat=dble(latmag)
          dtu=dble(UTsec)
          kp=ikp/3.
          call precipitation(iyd,dtu,kp,dlon,dlat,Eave,Fluxe)
          Flux_ener_int=Fluxe

c       Pour une maxwellienne, 99% du signal est contenu avant 7Eo
          emax =10.*Eave
CME      correction CME
      Emax=min(40000.,10.*Eave)
        Emax=10000.
c
c       write(6,*)'Flux_ener_int,Eave',Flux_ener_int,Eave
       print*,'quelle_grille'
       call quelle_grille(Emax,nen,centE,botE,ddeng,
     .        nang,nango2,gmu,gwt,angzb)
c
c
c         ============================================================
c         Initialisation du flux precipite
c         ============================================================
c
c       On a suppose donc (a l'encontre de ce que precise Hardy) que
c       le flux est maxwellien

c    if (latmag.ge.0.) then
c    if (latmag.le.0.) then
c      isotro=1
         print*,'fluxkappa'
         call fluxkappa(nango2,nen,centE,isotro,
     .                  gmu,fluxdown,fluxup,Eave,Flux_ener_int)

!          open(44,file='fluxtop.dat',status='replace')
!          write(44,*) ((fluxdown(ien,iang),ien=1,nen),iang=1,nango2)
!          close(44)
          print*,'flux_integre'
          call flux_integre(nango2,nen,centE,ddeng,
     .                    gmu,gwt,fluxdown,fluxup,
     .            Eave,Flux_ener_int)
      Fe0=Flux_ener_int*6.2832
      Ee0=Eave
c
c    else
c      isotro=1
c        call inmaxwl(Flux_ener_int,Eave,nango2,nen,centE,
c     .            isotro,gmu,fluxdown,fluxup)
c          call normflux(Flux_ener_int,nango2,nen,centE,ddeng,gmu,gwt,
c     .            fluxdown,fluxup)
c      Fe0=Flux_ener_int*6.2832
c      Ee0=Eave
        endif

        Fe0=Fe0*1.6e-12
c     endif
c
c
c ====================================================================
c       Initialisation d'un flux precipite de perturbation
c ====================================================================
c
c     Connaissant le flux de particules integre [cm-2.s-1.sr-1]
c       et le flux d'energie integre [keV.cm-2.s-1.sr-1], on a le
c     choix entre diverses possibilites.
c     Il faut appeler un programme qui en fonction de ces
c     parametre estime un flux. En routine, il existe un flux
c     maxwellien, gaussien ou un flux monoenergitique (dirac)
c     On les appelle par
c
c     call inmaxwl(Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c
c       call ingauss (Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c
c       call indirac (Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c
c       isotro = parametre d'isotropie du flux precipite :
c       0 = distribution gaussienne
c       1 = flux isotrope
c       2 = dirac
c
c     La discretisation impose dans tous les cas de normaliser a
c     Flux_ener_int.
c       call normflux(Flux_ener_int,nango2,nen,centE,ddeng,gmu,gwt,
c    .        fluxdown,fluxup)
c
c     Pour mettre des perturbations, on peut changer brutalement la
c    forme et l'intensite du flux. Il suffit d'initialiser
c     Flux_ener_int,Eave,isotro et de retirer les c de commentaire
c     a l'appel souhaite. Il faut eventuellement redefinir la grille
c     d'energie.
c
c     Remarque : 1 Erg = 6.25e+11 eV...
c
c ----     ICI COMMENCENT LES CHANGEMENTS EVENTUELS POUR UNE PERTURBATION
c
c     emax = 400.
c    call quelle_grille(Emax,nen,centE,botE,ddeng,
c    .        nang,nango2,gmu,gwt,angzb)
c    isotro = 1
c    Flux_ener_int = 6.25e+11 * 3.
c     Eave = 200.
c
c     call inmaxwl(Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c       call normflux(Flux_ener_int,nango2,nen,centE,ddeng,gmu,gwt,
c    .            fluxdown,fluxup)
c
c    isotro = 1
c       call ingauss (Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c       call normflux(Flux_ener_int,nango2,nen,centE,ddeng,gmu,gwt,
c    .            fluxdown,fluxup)
c
c    isotro = 1
c       call indirac (Flux_ener_int,Eave,nango2,nen,centE,
c    .            isotro,gmu,fluxdown,fluxup)
c       call normflux(Flux_ener_int,nango2,nen,centE,ddeng,gmu,gwt,
c    .            fluxdown,fluxup)
c
c ----    FIN DE CES CHANGEMENTS.
c
c
c ====================================================================
c     Chargement des conditions du run
c ====================================================================
c
c
c       Calcul du champ : mgdpa = magnetic dip angle (radians)
        date=float(nan)+day/100.
        if(nan.lt.100)date=1900.+float(nan)+day/100.
        do ialt = 1,nalt
          call bfield(date,altkm(ialt),glat,glong,xbid,ybid,zbid,bf,
     .              mgdpa(ialt),decbid)
          mgdpa(ialt)=abs(mgdpa(ialt))
          smgdpa(ialt)=sin(mgdpa(ialt))
c       La valeur du champ pourra dans le futur etre a garder...
c         Conversion de B, des gammas en Tesla
c         field(ialt)=bf*1.0e-09
        enddo
        albedo=1.
c
        chideg = chi * 180.0 / (4.*atan(1.))

        if (chideg.ge.108.) then
          if (.not.flgchi) jpreci0=jpreci
          flgchi=.true.
          if (jpreci.eq.2) jpreci=1
          if (jpreci.eq.6) jpreci=4
        else
          if (flgchi) then
            jpreci=jpreci0
            flgchi=.false.
          else
            jpreci0=jpreci
          endif
        endif

c        if (Fluxe.lt.1.e-30) then
c          if (.not.flgchi) jpreci0=jpreci
c          flgchi=.true.
c          if (jpreci.eq.2) jpreci=1
c          if (jpreci.eq.6) jpreci=4
c        else
c          if (flgchi) then
c            jpreci=jpreci0
c            flgchi=.false.
c          else
c            jpreci0=jpreci
c          endif
c        endif

c
c ====================================================================
c     Eventuellement, ecriture pour verifications.
c ====================================================================
c
c     Pour mettre off ces ecritures, mettre iprt(1) et iprt (2) a
c     0 dans la ligne data en debut de ce sous programme
      if (iprt(1).eq.1 .or. iprt(2).eq.1) then
       fanion = fanion + 1
       do ialt = 1,nalt
         dne (ialt) = denelc(ialt)/10.
         dte (ialt) = temelc(ialt)/10.
         dti (ialt) = temion(ialt)/10.
       enddo
          call ecr(nspec,nalt,zbot,ztop,UT,hrloc,day,nan,
     .      jpreci,tempexo,f107(2),f107(3),ap(1),fctemp,fcdens,glat,
     .      glong,modatmos,albedo,altkm,nen,botE,centE,ddeng,knm,eave,
     .      alpha,nang,angzb,gmu,gwt,fluxdown,fluxup,denelc,dne,
     .      temelc,dte,temion,dti,derivte,comp,z50,densneut,tneutre,
     .      xmasdens,colden,mgdpa,smgdpa,chideg,icont,iprt,spfac,
     .      moddene,modtemp,modcomp)
      endif
c
      return
      end
c
c------------------------ column -------------------------------
c
        subroutine column(nbralt,nalt,altcm,nspec,densneut,colden)
*
*    Calculates the column density HTAU
*
         implicit none
c
c     Parametres d'entree/sortie
        integer nbralt,nalt,nspec
        real densneut(8,nbralt),altcm(nbralt),colden(8,nbralt)
c     Parametres internes
        real epsilon,d
        integer i1,i2,i3,i4,isp,ialt
c
        epsilon=1.e-10
        if(altcm(nalt).lt.altcm(1)) then
            i1=1
            i2=2
            i3=nalt
            i4=1
        else
            i1=nalt
            i2=nalt-1
            i3=1
            i4=-1
        end if
         do isp=1,nspec
          d=0.
          if(densneut(isp,i2).gt.0..and.densneut(isp,i1).gt.0.)
     .        d=abs(log(densneut(isp,i2)/densneut(isp,i1)))
        if(abs(d).ge.epsilon)
     .        colden(isp,i1)=densneut(isp,i1)/d*(altcm(i1)-altcm(i2))
      do ialt=i2,i3,i4
      d=0.
        if(densneut(isp,ialt-i4).gt.0..and.densneut(isp,ialt).gt.0.)
     .        d=abs(log(densneut(isp,ialt-i4)/densneut(isp,ialt)))
        if(abs(d).ge.epsilon) then
          colden(isp,ialt)=colden(isp,ialt-i4)+
     .                  abs((altcm(ialt)-altcm(ialt-i4))/d*
     .            (densneut(isp,ialt)-densneut(isp,ialt-i4)))
        else
          colden(isp,ialt)=colden(isp,ialt-i4)+
     .            densneut(isp,ialt)*(altcm(ialt-i4)-altcm(ialt))
        end if
       enddo
        enddo

        end subroutine column