      subroutine bnswer
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To call routines to assemble finite element equations and solve for
CD1 the Newton-Raphson equations.
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 05-20-92     G. Zyvoloski   00022   Initial implementation.
CD2                                     However, previous non-YMP
CD2                                     versions of FEHM exist, and
CD2                                     the current version differs
CD2                                     from these in minor ways.
CD2
CD2 $Log:   /pvcs.config/fehm90/src/bnswer.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:22   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:55:16   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:04:56   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:00   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:56:02   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:39:04 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.6   Fri Mar 01 14:41:52 1996   gaz
CD2 took out " strd=1. 'strd=1. in N_R loop
CD2
CD2    Rev 1.5   Mon Jan 29 13:15:24 1996   hend
CD2 Added ECD Number
CD2
CD2    Rev 1.4   Mon Jan 29 12:40:30 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.3   06/01/95 17:30:30   gaz
CD2 minor mods for minimum iterations
CD2
CD2    Rev 1.2   03/24/95 00:12:18   gaz
CD2 gaz deleted reference to tmch near end
CD2
CD2    Rev 1.1   03/18/94 15:45:14   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:21:30   pvcs
CD2 original version in process of being certified
CD2
c 3/20/95 gaz took out if(fdum.le.tmch)... covered in gensl1,2 etc:
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 None
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 None
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4 Identifier  Type     Description
CD4
CD4 itert, strd, iad, maxit, mlz, idof, idpdp, ico2, fdum, f0, iad,
CD4 itotal, tmch, epe
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4                      COMMON
CD4 Identifier   Type    Block   Description
CD4
CD4
CD4
CD4 Global Subprograms
CD4
CD4 Name    Type     Description
CD4
CD4 varchk  N/A      Updates variable states, apply corrections to
CD4                     solution vectors
CD4 outbnd  N/A      Determines if any variable values are out of bounds
CD4 gensl3  N/A      Obtain heat transfer solution
CD4 gensl4  N/A      Obtain single porosity solution
CD4 dpdp    N/A      Obtain dpdp solution
CD4 airctr  N/A      Obtain single porosity, isothermal air-water
CD4                     solution
CD4 icectr  N/A      Obtain single porosity, solid-liquid-gas
CD4                     solution
CD4 gensl1  N/A       Obtain single phase, single porosity solution
CD4
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 Identifier   Type        Description
CD5
CD5
CD5 Local Types
CD5
CD5 None
CD5
CD5 Local Variables
CD5
CD5 Identifier   Type        Description
CD5
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
CD6 N/A
CD6
C**********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 None
CD7
C**********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8  Requirements from SDN: 10086-RD-2.20-00
CD8    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD8    FEHM Application Version 2.20
CD8
C**********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 2.5.2 Solve nonlinear equation set at each time step
CD9 2.3.1 Heat-conduction equations
CD9 2.3.2 Heat- and mass-transfer equations
CD9 2.3.3 Noncondensible gas flow equations
CD9
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See FEHMN SRS, MMS, and SDD
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN bnswer
CPS
CPS REPEAT this subroutine to obtain solution
CPS
CPS EXITIF the maximum number of iterations is reached after setting...
CPS ... flag
CPS
CPS   varchk - update variable states
CPS   outbnd - check if variables are out of bounds
CPS
CPS EXITIF any variables are out of bounds
CPS
CPS   IF this is a heat transfer only solution
CPS     gensl3 - obtain solution for heat transfer
CPS   ELSE
CPS
CPS     IF this is a nonisothermal two phase calculation
CPS
CPS       IF it is single porosity
CPS         gensl4 - obtain solution
CPS       ELSE it is dpdp problem
CPS         dpdp - obtain solution
CPS       ENDIF
CPS
CPS     ENDIF
CPS
CPS
CPS     IF this is an isothermal two phase calculation
CPS
CPS       IF it is single porosity
CPS         airctr - obtain solution
CPS       ELSE it is dpdp problem
CPS         dpdp - obtain solution
CPS       ENDIF
CPS
CPS     ENDIF
CPS
CPS     IF this is a solid-liquid-gas calculation
CPS
CPS       IF it is single porosity
CPS         icectr - obtain solution
CPS       ELSE it is dpdp problem
CPS
CPS       ENDIF
CPS
CPS     ENDIF
CPS
CPS     IF this is a single phase calculation
CPS
CPS       IF it is single porosity
CPS         gensl1 - obtain solution
CPS       ELSE it is dpdp problem
CPS         dpdp - obtain solution
CPS       ENDIF
CPS
CPS     ENDIF
CPS
CPS   ENDIF
CPS
CPS EXITIF the residual is below the convergence criterion value
CPS
CPS   Add 1 to the number of iterations and total iteration count
CPS
CPS EXITIF the residual is below machine precision
CPS
CPS   varchk - apply corrections to solution vectors
CPS
CPS UNTIL the residual can go no lower
CPS
CPS END bnswer
CPS
C**********************************************************************

      use combi
      use comdi
      use comgi
      use comei
      use comdti
      use comai
      use comco2
      use comsi
      use comsplitts
      use davidi
      use comfem
      implicit none

      integer iad_min, iad_mult, i
      real*8 fdum_mult
      parameter (fdum_mult=1.d02,iad_mult= 100)

      itert=0
      minkt=0
      strd=1.
      iad=0
      mlz_save= 0
c gaz 110715
      mlz = 0
      if(g1.lt.0.0) then
	 iad_min = 0
      else if(maxit.ge.0) then
         iad_min=1
      else
         iad_min=2
      endif
      if(iflux_ts.ne.0.and.ico2.lt.0) then
         call cascade_sat(0)
      endif
      fdum = 0.0
      fdum_last = 1.

      if(istrs.gt.0) then
        delta_u = 0.0d0
        delta_v = 0.0d0
        delta_w = 0.0d0
      endif
c
c     check iterations against maximum
c
 1000 continue
      if(fdum.gt.fdum_last*fdum_mult.and.iad.ge.iad_mult) then
         mlz = -1
         bp = 0.0
         goto 2000
      else
         fdum_last = fdum
      endif
      if(iad.gt.abs(maxit)) then
         mlz=-1
         goto 2000
      endif
      if(iad.gt.abs(maxit)/2) then
c     strd=0.95
      endif
c
c     update variable states
c
      if(istrs_coupl.le.-99) then
c  istrs_coupl.le.-99 means only a stress solution (like calculating initial lithoststic stress)
c (4,0) is nonlinear (if any) material properties)
         call stressctr(4,0)
      elseif(ice.eq.0) then

c     s kelkar 11feb2011 ihms=-15 is a special option
c     allow uncoupled porosity changes, ihms is reset to -3
c     ps calculated below is a factor so that
c     pore volume = ps()*initial bulk volume (=sx1d)
c     this factor ps() is used in therm w to calculate deni()=ps()*roho
c     and the sx1d is multiplied in geneq1_.._..
         if(pore_factor.gt.0.0.and.ihms.eq.-3) then
            call porosity_wrt_displacements
         endif

         call varchk(0,0)
c the following is for fully coupled model
         if(idof_stress.ge.4) then
	    call stressctr(4,0)
         endif
c     RJP 04/10/07 added
         if(icarb.eq.1) then
            call icectrco2(-1,0)
            call icectrco2(1,0)
            call icectrco2(-34,0)
c     call icectrco2(22,0)
         endif
      else
         call icectr(-1,0)
         call icectr(1,0)
c     added this to check the state of hydrate for the next iteration
c     gaz-commented out 9-2-2003
         call icectr(-6,0)
c     if (mlz.eq.-1) goto 2000
      endif
c
c  very new call outbound here gaz 120709
c      call outbnd
c
c     call appropriate sub to generate equations

c     set up permeability variations with displacements (allocate memory)
      if(istrs_coupl.gt.-99) then
         flag_pstrain_perm_coupling = 0
         if(flag_permmodel.eq.1) then
            if(flag_element_perm.eq.1) then
           ! finite element option
           ! Setup connectivity list of which elements each node belongs to

               if(iPlastic.eq.1) flag_pstrain_perm_coupling=1

               if(.not. allocated(NodeElems)) then
                  call Setup_NodeElems()
               endif
           ! Setup pointers to edge numbers
               if(.not. allocated(edgeNum1)) then
                  call setup_edgePointers_3D()
               endif
             ! allocate memory for permeability update if necessay
               call stress_perm(-1,0)
             ! update edge permeability factors for current state
               call update_permfactors()
            else if (iPlastic.eq.1) then
c     update permeabilities based on plastic strain, von Mises (if flag is called)
c     Hard-wired the flag, need to input
c     this is for sequential coupling
               flag_pstrain_perm_coupling = 1
               if (flag_pstrain_perm_coupling.eq.1 .and.
     &              ifem.eq.1) then
c     Setup connectivity list of which elements each node belongs to
                  if(.not. allocated(NodeElems)) then
                     call Setup_NodeElems()
                  endif
c     Setup pointers to edge numbers
                  if(.not. allocated(edgeNum1)) then
                     call setup_edgePointers_3D()
                  endif

                  call stress_perm(-1,0)

                  call update_permfactors()
c.............................................................
               else
c     cant do plasticity without ifem
                  write(iptty,*)'error. must have fem'
                  write(iptty,*)'for plasticity'
                  stop
               endif
            else

c     control volume approach
c     allocate memory for permeability update if necessay
               call stress_perm(-1,0)
c     update nodal permeabilities (explicit)
               call stress_perm(1,0)
c     deallocate memory for permeability update if necessay
               call stress_perm(-2,0)
            endif
         endif
      endif

      if(idof_stress.ge.5) then
c 3d coupled THM
         call gensl_stress_coupled_3D
         do i = 1,neq
           delta_u(i) = delta_u(i) - bp(i + nrhs(1))
           delta_v(i) = delta_v(i) - bp(i + nrhs(2))
           delta_w(i) = delta_w(i) - bp(i + nrhs(3))
         enddo

      else if(istrs_coupl.le.-99) then
c add stress equations and derivatives
c uncoupled stress equations
         call  stressctr(8,0)
         do i = 1,neq
           delta_u(i) = delta_u(i) - bp(i + nrhs(1))
           delta_v(i) = delta_v(i) - bp(i + nrhs(2))
           delta_w(i) = delta_w(i) - bp(i + nrhs(3))
         enddo

      else if(idoff.eq.-1) then
         call gensl3
      else
         if(ico2.gt.0) then
            if(idpdp.eq.0) then
               call gensl4
            else
               call dpdp(3)
            endif
         endif

         if(ico2.lt.0.and.ice.eq.0) then
c     single porosity
            if(idpdp.eq.0) then
               if(isplitts.ge.-1) then
                  call airctr(4,0)
               else if(isplitts.eq.-2) then
                  call airctr(-4,0)
c     explicit iterations finished in airctr so return
                  go to 2000
               endif
            else
c     dpdp enabled
               call dpdp(3)
            endif
         endif

c     gaz 10-15-2001
         if(ico2.lt.0.and.ice.ne.0) then
c     single porosity
            if(idpdp.eq.0) then
               call icectr(4,0)
            else
c     dpdp not enabled
c
            endif
         endif

         if(ico2.eq.0) then
            if(idpdp.eq.0) then
c     RJP 04/17/07 changed following
               if(icarb.eq.1) then
                  call icectrco2(4,0)
               else
                  call gensl1
               end if
            else
               call dpdp(3)
            endif
         endif

      endif
      if(fdum.le.f0.and.iad.ge.iad_min) goto 2000
      if(mlz.lt.0) goto 2000
      iad=iad+1
      itotal=itotal+1
c
c     apply nr corrections
c
      if(idof_stress.ge.5) then
c     3d coupled THM
         call stressctr(9,0)
      else if(istrs_coupl.le.-99) then
	 call stressctr(9,0)
      else if(ice.eq.0) then
c     RJP 04/10/07 added following
         if(icarb.eq.1) then
            call icectrco2(2,0)
         else
            call varchk(1,0)
            if(idof_stress.ge.4) then
               call stressctr(9,0)
            endif
         end if
      else
         call icectr(2,0)
      endif
      if(epe.le.0.) goto 2000
c
c     check if varibles are out of bounds
c      outbnd moved higher
      call outbnd
      if(mlz.ne.0) goto 2000
      goto 1000
 2000 continue
      end


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYINIT
C...Initializes the generation procedure; finds maxima of the
C...differential cross-sections to be used for weighting.

      SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pydat4'
      include 'inc/pysubs'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint5'
      include 'inc/pypued'

C...Local arrays and character variables.
      DIMENSION ALAMIN(20),NFIN(20)
      CHARACTER*(*) FRAME,BEAM,TARGET
      CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6

C...Interface to PDFLIB.
      include 'inc/w50511'
      include 'inc/w50512'

      DOUBLE PRECISION VALUE(20)
      CHARACTER*20 PARM(20)
*
      EXTERNAL PYDATA
*
      DATA VALUE/20*0D0/,PARM/20*' '/

C...Data:Lambda and n_f values for parton distributions..
      DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
     &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
     &NFIN/20*4/
      DATA CHLH/'lepton','hadron'/

C...Check that BLOCK DATA PYDATA has been loaded.
      CALL PYCKBD

C...Reset MINT and VINT arrays. Write headers.
      MSTI(53)=0
      DO 100 J=1,400
        MINT(J)=0
        VINT(J)=0D0
  100 CONTINUE
      IF(MSTU(12).NE.12345) CALL PYLIST(0)
      IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)

C...Reset error counters.
      MSTU(23)=0
      MSTU(27)=0
      MSTU(30)=0

C...Reset processes that should not be on.
      MSUB(96)=0
      MSUB(97)=0

C...Select global FSR/ISR/UE parameter set = 'tune'
C...See routine PYTUNE for details
      IF (MSTP(5).NE.0) THEN
        MSTP5=MSTP(5)
        CALL PYTUNE(MSTP5)
      ENDIF

C...Call user process initialization routine.
      IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
        MSEL=0
        CALL UPINIT
        MSEL=0
      ENDIF

C...Maximum 4 generations; set maximum number of allowed flavours.
      MSTP(1)=MIN(4,MSTP(1))
      MSTU(114)=MIN(MSTU(114),2*MSTP(1))
      MSTP(58)=MIN(MSTP(58),2*MSTP(1))

C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
      DO 120 I=-20,20
        VINT(180+I)=0D0
        IA=ABS(I)
        IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
          DO 110 J=1,MSTP(1)
            IB=2*J-1+MOD(IA,2)
            IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
            IPM=(5-SIGN(1,I))/2
            IDC=J+MDCY(IA,2)+2
            IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
     &      VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
  110     CONTINUE
        ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
          VINT(180+I)=1D0
        ENDIF
  120 CONTINUE

C...Initialize parton distributions: PDFLIB.
      IF(MSTP(52).EQ.2) THEN
        PARM(1)='NPTYPE'
        VALUE(1)=1
        PARM(2)='NGROUP'
        VALUE(2)=MSTP(51)/1000
        PARM(3)='NSET'
        VALUE(3)=MOD(MSTP(51),1000)
        PARM(4)='TMAS'
        VALUE(4)=PMAS(6,1)
        CALL PDFSET(PARM,VALUE)
        MINT(93)=1000000+MSTP(51)
      ENDIF

C...Choose Lambda value to use in alpha-strong.
      MSTU(111)=MSTP(2)
      IF(MSTP(3).GE.2) THEN
        ALAM=0.2D0
        NF=4
        IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
          ALAM=ALAMIN(MSTP(51))
          NF=NFIN(MSTP(51))
        ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
          ALAM=QCDL5
          NF=5
        ELSEIF(MSTP(52).EQ.2) THEN
          ALAM=QCDL4
          NF=4
        ENDIF
        PARP(1)=ALAM
        PARP(61)=ALAM
        PARP(72)=ALAM
        PARU(112)=ALAM
        MSTU(112)=NF
        IF(MSTP(3).EQ.3) PARJ(81)=ALAM
      ENDIF

C...Initialize the UED masses and widths
      IF (IUED(1).EQ.1) CALL PYXDIN

C...Initialize the SUSY generation: couplings, masses,
C...decay modes, branching ratios, and so on.
      CALL PYMSIN
C...Initialize widths and partial widths for resonances.
      CALL PYINRE
C...Set Z0 mass and width for e+e- routines.
      PARJ(123)=PMAS(23,1)
      PARJ(124)=PMAS(23,2)

C...Identify beam and target particles and frame of process.
      CHFRAM=FRAME//' '
      CHBEAM=BEAM//' '
      CHTARG=TARGET//' '
      CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
      IF(MINT(65).EQ.1) GOTO 170

C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
C...For e-gamma allow 2 alternatives.
      MINT(121)=1
      IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (ABS(MINT(11)).GT.100.OR.ABS(MINT(12)).GT.100)) MINT(121)=3
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (ABS(MINT(11)).EQ.11.OR.ABS(MINT(12)).EQ.11)) MINT(121)=2
      ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (ABS(MINT(11)).GT.100.OR.ABS(MINT(12)).GT.100)) MINT(121)=3
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
      ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (ABS(MINT(11)).GT.100.OR.ABS(MINT(12)).GT.100)) MINT(121)=2
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
      ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (ABS(MINT(11)).GT.100.OR.ABS(MINT(12)).GT.100)) MINT(121)=4
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
      ENDIF
      MINT(123)=MSTP(14)
      IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
     &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
      IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
        IF(MSTP(14).EQ.11) MINT(123)=0
        IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
        IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
        IF(MSTP(14).EQ.15) MINT(123)=2
        IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
        IF(MSTP(14).EQ.19) MINT(123)=3
      ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
        IF(MSTP(14).EQ.21) MINT(123)=0
        IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
        IF(MSTP(14).EQ.24) MINT(123)=1
      ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
        IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
        IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
      ENDIF

C...Set up kinematics of process.
      CALL PYINKI(0)

C...Set up kinematics for photons inside leptons.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)

C...Precalculate flavour selection weights.
      CALL PYKFIN

C...Loop over gamma-p or gamma-gamma alternatives.
      CKIN3=CKIN(3)
      MSAV48=0
      DO 160 IGA=1,MINT(121)
        CKIN(3)=CKIN3
        MINT(122)=IGA

C...Select partonic subprocesses to be included in the simulation.
        CALL PYINPR
        MINT(101)=1
        MINT(102)=1
        MINT(103)=MINT(11)
        MINT(104)=MINT(12)

C...Count number of subprocesses on.
        MINT(48)=0
        DO 130 ISUB=1,500
          IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
     &    MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
            MSUB(ISUB)=0
          ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
     &    MSUB(ISUB).EQ.1) THEN
            WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
            WRITE(MSTU(11),5300) ISUB
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
            WRITE(MSTU(11),5400) ISUB
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1) THEN
            MINT(48)=MINT(48)+1
          ENDIF
  130   CONTINUE

C...Stop or raise warning flag if no subprocesses on.
        IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
          IF(MSTP(127).NE.1) THEN
            WRITE(MSTU(11),5500)
            CALL PYSTOP(1)
          ELSE
            WRITE(MSTU(11),5700)
            MSTI(53)=1
          ENDIF
        ENDIF
        MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
        MSAV48=MSAV48+MINT(48)

C...Reset variables for cross-section calculation.
        DO 150 I=0,500
          DO 140 J=1,3
            NGEN(I,J)=0
            XSEC(I,J)=0D0
  140     CONTINUE
  150   CONTINUE

C...Find parametrized total cross-sections.
        CALL PYXTOT
        VINT(318)=VINT(317)

C...Maxima of differential cross-sections.
        IF(MSTP(121).LE.1) CALL PYMAXI

C...Initialize possibility of pileup events.
        IF(MINT(121).GT.1) MSTP(131)=0
        IF(MSTP(131).NE.0) CALL PYPILE(1)

C...Initialize multiple interactions with variable impact parameter.
        IF(MINT(50).EQ.1) THEN
          PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
          IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
     &    ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
          IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
            MINT(35)=1
            CALL PYMULT(1)
            MINT(35)=3
            CALL PYMIGN(1)
          ENDIF
        ENDIF

C...Save results for gamma-p and gamma-gamma alternatives.
        IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
  160 CONTINUE

C...Initialization finished.
      IF(MSAV48.EQ.0) THEN
        IF(MSTP(127).NE.1) THEN
          WRITE(MSTU(11),5500)
          CALL PYSTOP(1)
        ELSE
          WRITE(MSTU(11),5700)
          MSTI(53)=1
        ENDIF
      ENDIF
  170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)

C...Formats for initialization information.
 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
     &'routines',1X,17('*'))
 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
     &'-',A6,' interactions.'/1X,'Execution stopped!')
 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
     &1X,'Execution stopped!')
 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
     &1X,'Execution stopped!')
 5500 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
     &22('*'))
 5700 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution will stop if you try to generate events.')

      RETURN
      END


MODULE LAPS_PARAMS

!==============================================================================
!doc  THIS ROUTINE DEFINES ALL PARAMETERS REQUIRED FOR LAPS.
!doc
!doc  HISTORY:
!doc	CREATION:	YUANFU XIE	MAY 2007
!doc    MODIFIED:       YUANFU XIE	MAR 2008 ADDING RADAR VARIABLES
!==============================================================================

  IMPLICIT NONE

  ! CONSTANTS:
  INTEGER,PARAMETER :: OUTPUT_CHANNEL=20,BFRTBL_CHANNEL=21,POINTS_CHANNEL=22
  ! FOR LAPSPLOT OF OBSERVATIONS:
  INTEGER,PARAMETER :: TMGOUT_CHANNEL=23,PIGOUT_CHANNEL=24,PRGOUT_CHANNEL=25,&
                       SAGOUT_CHANNEL=26
  REAL,PARAMETER :: INCHES_CONV2MM=2.54		! FROM INCH TO MILLI-METER

  ! BUFR encoding:
  CHARACTER*80, PARAMETER :: HEADER_PREBUFR= &
    'SID TYP T29 RPT DHR YOB XOB ELV ITP SQN PROCN'
  INTEGER,      PARAMETER :: HEADER_NUMITEM=11
  CHARACTER*80, PARAMETER :: OBSDAT_PREBUFR= &
    'ZOB POB TOB UOB VOB QOB PMO PRSS PWO'
  INTEGER,      PARAMETER :: OBSDAT_NUMITEM=9
  CHARACTER*80, PARAMETER :: OBSERR_PREBUFR= &
    'ZOE POE TOE WOE QOE PWE'
  INTEGER,      PARAMETER :: OBSERR_NUMITEM=6
  CHARACTER*80, PARAMETER :: OBSQMS_PREBUFR= &
    'ZQM PQM TQM WQM QQM PMQ PWQ'
  INTEGER,      PARAMETER :: OBSQMS_NUMITEM=7

  CHARACTER*80, PARAMETER :: SFCDAT_PREBUFR= &
    'PRSS ??? TOB ??? WDIR1 NWSPD1'
  INTEGER,      PARAMETER :: SFCDAT_NUMITEM=9
  CHARACTER*80, PARAMETER :: SFCERR_PREBUFR= &
   'SFCERR PREBUFR UNKNOWN'
  INTEGER,      PARAMETER :: SFCERR_NUMITEM=6
  CHARACTER*80, PARAMETER :: SFCQMS_PREBUFR= &
   'SFCQMS PREBUFR UNKNOWN'
  INTEGER,      PARAMETER :: SFCQMS_NUMITEM=7

  ! MISSING DATA:
  REAL*8,       PARAMETER :: MISSNG_PREBUFR=10.0E10

  ! REFERENCE VALUE FOR ICE/WATER RELATIVE HUMIDITY:
  REAL,         PARAMETER :: ABSOLU_TMPZERO=273.15
  REAL,         PARAMETER :: TEMPTR_REFEREN=-5.0 !-132.0

  ! GENERAL VARS:
  CHARACTER*8 :: FORMAT_REQUEST		! DATA FORMAT REQUESTED TO CONVERT TO
  CHARACTER*9 :: SYSTEM_ASCTIME 	! ASCII SYSTEM TIME
  CHARACTER   :: ANALYS_HOURCHA*2, &	! ANALYSIS HOUR
                 ANALYS_MINUTES*2, &	! ANALYSIS MINUTE
                 YYYEAR_JULIANS*5	! YY YEAR AND JULIAN DAYS
  CHARACTER   :: STRING_ASCTIME*16, &	! TIME IN A STRING
                 NUMBER_ASCTIME*14      ! TIME IN YYYYMMDDHHMM FORM
  INTEGER     :: NUMBER_GRIDPTS(4)	! NUMBER GRID POINTS IN X, Y, Z AND T
  INTEGER     :: LENGTH_ANATIME		! ANAL TIME WINDOW
  INTEGER     :: YYYYMM_DDHHMIN(5)	! TIME IN INTEGERS
  INTEGER     :: SYSTEM_IN4TIME		! I4 SYSTEM TIME
  INTEGER     :: RADARS_TIMETOL         ! RADAR TIME TOLERANCE
  INTEGER     :: IVALUE_MISSING		! MISSING VALUE IN INTEGER
  REAL        :: RVALUE_MISSING		! MISSING VALUE IN REAL
  REAL        :: SFCOBS_INVALID 	! BAD SURFACE OBSERVATION
  REAL        :: GRID4D_SPACING(4)	! GRID DISTANCE OF 4 DIMEMSION
  REAL, ALLOCATABLE, DIMENSION(:) :: &
		PRESSR_GRID1DM		! PRESSURE LEVELS
  REAL, ALLOCATABLE, DIMENSION(:,:) :: &
	        DOMAIN_LATITDE,        & ! GRID LATITUDES
		DOMAIN_LONGITD,        & ! GRID LONGITUDE
		DOMAIN_TOPOGRP           ! GRID TOPOGRAPHY
  REAL, ALLOCATABLE,DIMENSION(:,:,:) :: &
                HEIGHT_GRID3DM,&	! LAPS 3D HEIGHT BACKGROUND FIELD
                temptr_GRID3DM,&	! LAPS 3D HEIGHT BACKGROUND FIELD
                uuwind_GRID3DM,&	! LAPS 3D HEIGHT BACKGROUND FIELD
                vvwind_GRID3DM	! LAPS 3D HEIGHT BACKGROUND FIELD

  ! USE A NEW LAPS WIND PARAMETER SCHEME AND SO THE FOLLOWINGS ARE COVERED
  ! EXCEPT THOSE USED:

  ! FOR WIND DATA:
  ! LOGICAL     :: USEOBS_RAOBDAT	! USE RAOB DATA
  ! LOGICAL     :: USEOBS_CLDRFWD	! USE CLOUD DRIFT WIND
  ! LOGICAL     :: USEOBS_RADARWD	! USE RADIAL WIND
  ! INTEGER     :: THRESH_RADAROB(3)	! THRESHOLD NUMBERS DOPPLER OBS/LEVEL
					! BY FACTOR 2,4,9
  INTEGER     :: MAXNUM_PROFLRS	! MAX NUM PROFILERS
  INTEGER     :: MAXLVL_PROFLRS	! MAX LEVEL OF PROF

  INTEGER     :: MAXNUM_SONDES	! MAX NUM SONDES
  INTEGER     :: MAXLVL_SONDES 	! MAX LEVEL OF SONDES

  ! INTEGER     :: WEIGHT_OPTIONS	! LAPS WEIGHT SCHEME
  ! REAL        :: WEIGHT_BKGWIND	! WEIGHT FOR BACKGROUND WIND
  ! REAL        :: WEIGHT_RADARWD	! WEIGHT FOR RADAR WIND OBS
  ! REAL        :: THRESH_RMSWIND	! THRESHOLD FOR RMS FIT OF ANALYSIS TO
					! THE OBSERVATIONS

  ! NAME LIST FOR WIND:
  ! NAMELIST /WIND_NL/ USEOBS_RAOBDAT,USEOBS_CLDRFWD, &
  !		     USEOBS_RADARWD,THRESH_RADAROB, &
  !		     WEIGHT_BKGWIND,WEIGHT_RADARWD, &
  !		     THRESH_RMSWIND,MAXNUM_PROFLRS, &
  !		     MAXLVL_PROFLRS,WEIGHT_OPTIONS

END MODULE LAPS_PARAMS


!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

 module barotropic

!BOP
! !MODULE: barotropic
!
! !DESCRIPTION:
! This module contains the routine for solving the barotropic
! equations.
!
! !REVISION HISTORY:
! CVS:$Id: barotropic.F90,v 1.17 2003/03/12 13:16:48 pwjones Exp $
! CVS:$Name: POP_2_0_1 $

! !USES:

   use kinds_mod, only: int_kind, i4, r8
! use blocks, only: nx_block, ny_block, block, get_block
! use distribution, only:
   use domain, only: distrb_clinic, blocks_clinic, nblocks_clinic, &
       bndy_clinic
   use constants, only: field_type_vector, field_type_scalar, &
       grav, c1, c0, field_loc_NEcorner, field_loc_center
   use prognostic, only: max_blocks_clinic, GRADPX, GRADPY, UBTROP, VBTROP, &
       PSURF, curtime, oldtime, newtime, PGUESS
   use boundary, only: update_ghost_cells
   use solvers, only: A0_CLINIC, AC, elliptic_solver
   use operators, only: grad, div
   use grid, only: sfc_layer_type, sfc_layer_varthick, TAREA, REGION_MASK, &
       KMT, FCOR, HU, CALCT, sfc_layer_rigid, sfc_layer_oldfree
   use time_management, only: mix_pass, leapfrogts, impcor, c2dtu, theta, &
       gamma, f_euler_ts, beta, c2dtp, dtp
   use global_reductions, only: global_sum
   use forcing, only: ATM_PRESS, FW
   use forcing_ap, only: ap_data_type
   use tavg, only: define_tavg_field, tavg_requested, accumulate_tavg_field
   use blocks
   use communicate
   use exit_mod

   implicit none
   private
   save

! !PUBLIC MEMBER FUNCTIONS:

   public :: init_barotropic, &
             barotropic_driver

!EOP
!BOC
!-----------------------------------------------------------------------
!
! module variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
     tavg_SU, &! tavg id for vertically-integrated U
     tavg_SV ! tavg id for vertically-integrated V

!-----------------------------------------------------------------------
!
! nullspace removal
!
! CHECKER +/- checkerboard field for removing global
! checkerboard nullspace from surface pressure field.
! zero on land and marginal seas.
! CONSTNT constant field for removing constant nullspace
! from surface presure field. zero on land and in marginal
! seas, one in open ocean.
!
! sum_check = sum(CHECKER)
! sum_const = sum(CONSTNT)
!
! acheck = sum(CHECKER*TAREA)/sum(CONSTNT*TAREA)
!
! rcheck = acheck/(sum_const - acheck*sum_check)
! rconst = 1/(sum_const - acheck*sum_check)
!
!-----------------------------------------------------------------------

   integer (i4), dimension (:,:,:), allocatable :: &
      CHECKER, &! checkerboard nullspace field
      CONSTNT ! constant nullspace field

   real (r8) :: &
      rcheck, rconst ! scalar constants for checkboard removal

   real (r8) :: &
      r_beta_c2dtp, &! scalar constants for MIC div opr
      r_beta_c2dtp_etc

!EOC
!***********************************************************************

 contains

!***********************************************************************
!BOP
! !IROUTINE: init_barotropic
! !INTERFACE:

   subroutine init_barotropic

! !DESCRIPTION:
! This routine initializes barotropic quantities - mostly tavg
! diagnostics related to barotropic velocities.
!
! !REVISION HISTORY:
! same as module

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j,n, &! loop indices
      iblock, &! local block index
      sum_check, &! global sum of checkboard field
      sum_const ! global sum of constant field

   real (r8) :: &
      acheck ! sum(CHECKER*TAREA)/sum(CONSTNT*TAREA)

   real (r8), dimension(:,:,:), allocatable :: &
      CHECK_AREA, &! TAREA*CHEKER
      CONST_AREA ! TAREA*CONSTNT

   type (block) :: &
      this_block ! block information for this block

!-----------------------------------------------------------------------
!
! define tavg diagnostics related to barotropic velocities
!
!-----------------------------------------------------------------------

   call define_tavg_field(tavg_SU,'SU',2, &
                     long_name='Vertically-integrated zonal velocity', &
                          units='cm/s', grid_loc='2221')

   call define_tavg_field(tavg_SV,'SV',2, &
                long_name='Vertically-integrated meridional velocity', &
                          units='cm/s', grid_loc='2221')

!-----------------------------------------------------------------------
!
! initialize nullspace removal fields
!
!-----------------------------------------------------------------------

   if (sfc_layer_type == sfc_layer_varthick) then

      allocate ( CHECKER(nx_block,ny_block,max_blocks_clinic), &
                   CONSTNT(nx_block,ny_block,max_blocks_clinic), &
                CHECK_AREA(nx_block,ny_block,max_blocks_clinic), &
                CONST_AREA(nx_block,ny_block,max_blocks_clinic))

      !$OMP PARALLEL DO PRIVATE(iblock, this_block, i, j, n)

      do iblock = 1,nblocks_clinic
         this_block = get_block(blocks_clinic(iblock),iblock)

         do j = 1,ny_block
         do i = 1,nx_block

            n = this_block%i_glob(i) + this_block%j_glob(j)
            CHECKER(i,j,iblock) = 2*mod(n,2) - 1
            CHECK_AREA(i,j,iblock) = CHECKER(i,j,iblock)* &
                                       TAREA(i,j,iblock)

         enddo
         enddo

         if (allocated(REGION_MASK)) then
            where(KMT(:,:,iblock) > 0 .and. &
                  REGION_MASK(:,:,iblock) > 0)
               CONSTNT(:,:,iblock) = 1
               CONST_AREA(:,:,iblock) = TAREA(:,:,iblock)
            elsewhere
               CHECKER(:,:,iblock) = 0
               CONSTNT(:,:,iblock) = 0
               CHECK_AREA(:,:,iblock) = 0
               CONST_AREA(:,:,iblock) = 0
            endwhere
         else
            where(KMT(:,:,iblock) > 0)
               CONSTNT(:,:,iblock) = 1
               CONST_AREA(:,:,iblock) = TAREA(:,:,iblock)
            elsewhere
               CHECKER(:,:,iblock) = 0
               CONSTNT(:,:,iblock) = 0
               CHECK_AREA(:,:,iblock) = 0
               CONST_AREA(:,:,iblock) = 0
            endwhere
         endif
      end do
      !$OMP END PARALLEL DO

      sum_check = global_sum(CHECKER,distrb_clinic,field_loc_center)
      sum_const = global_sum(CONSTNT,distrb_clinic,field_loc_center)

      acheck = global_sum(CHECK_AREA,distrb_clinic,field_loc_center) &
              /global_sum(CONST_AREA,distrb_clinic,field_loc_center)

      rcheck = acheck/(sum_const - acheck*sum_check)
      rconst = c1/(sum_const - acheck*sum_check)

      deallocate(CHECK_AREA, CONST_AREA)

   endif ! varthick

!-----------------------------------------------------------------------
!EOC

   end subroutine init_barotropic

!***********************************************************************
!BOP
! !IROUTINE: barotropic_driver
! !INTERFACE:

 subroutine barotropic_driver(ZX,ZY)

! !DESCRIPTION:
! This routine solves the barotropic equations for the surface
! pressure and barotropic velocity field using the implicit
! free-surface formulation.
!
! For leapfrog steps, the momentum equations for the auxiliary
! velocity $(u',v')$ are
! \begin{eqnarray}
! (u' - u^{n-1}) - 2 \Delta t \alpha f(v' - v^{n-1})
! &=& 2 \Delta t [F_x - \gamma \nabla_x p -
! (1-\gamma)\nabla_x p^{n-1}] \! (v' - v^{n-1}) + 2 \Delta t \alpha f(u' - u^{n-1})

! &=& 2 \Delta t [F_y - \gamma \nabla_y p -
! (1-\gamma)\nabla_y p^{n-1}].
! \end{eqnarray}
! The elliptic equation for new pressure $p^{n+1}$ is
! \begin{equation}
! \nabla\cdot(H \nabla(p^{n+1}) - p^{n+1}/(\alpha 2 \Delta t^2 g)
! = \nabla\cdot(H(u',v')/(\alpha 2\Delta t) + \nabla p^{n-1})
! - p^n/(\alpha 2\Delta t^2 g - F_w/(\alpha 2\Delta t)
! \end{equation}
! New velocities $(U^{n+1},V^{n+1})$ are then constructed using
! \begin{eqnarray}
! U^{n+1} & = & u' - \alpha 2\Delta t \nabla_x(p^{n+1} - p^{n-1}) \!     V^{n+1} & = & v' - \alpha 2\Delta t \nabla_y(p^{n+1} - p^{n-1})

! \end{eqnarray}
!
! On the first pass of Matsuno steps, the auxiliary velocity is
! \begin{eqnarray}
! (u' - u^n) - \Delta t\theta f(v' - v^n)
! &=& \Delta t (F_x - \nabla_x p^n) \! (v' - v^n) + \Delta t\theta f(u' - u^n)

! &=& \Delta t (F_y - \nabla_y p^n),
! \end{eqnarray}
! the elliptic equation for new pressure is
! \begin{equation}
! \nabla\cdot(H\nabla({p`}^{n+1}) -
! {p`}^{n+1}/(\theta\Delta t^2 g)
! = \nabla\cdot(H[(u',v')/(\theta\Delta t) + \nabla p^n])
! - p^n/(\theta*\Delta t^2 g) - F_w/(\theta\Delta t),
! \end{equation}
! and the velocities are constructed using
! \begin{eqnarray}
! U^{n+1} &=& u' - \theta\Delta t \nabla_x(p^{n+1} - p) \!         V^{n+1} &=& v' - \theta\Delta t \nabla_y(p^{n+1} - p)

! \end{eqnarray}
!
! On the second pass of Matsuno steps, the auxiliary velocity is
! \begin{eqnarray}
! (u' - u^n) - \Delta t \theta f(v' - v^n)
! &=& \Delta t (F_x' - \theta\nabla_x {p'}^{n+1} -
! (1-\theta)\nabla_x p^n) \! (v' - v^n) + \Delta t \theta f(u' - u^n)

! &=& \Delta t (F_y' - \theta\nabla_y {p'}^{n+1} -
! (1-\theta)\nabla_y p^n),
! \end{eqnarray}
! the elliptic equation for new pressure is
! \begin{equation}
! \nabla\cdot(H\nabla p^{n+1}) - p^{n+1}/(\theta\Delta t^2 g)
! = \nabla\cdot(H[(u',v')/(\theta\Delta t) + \nabla p^{n+1}])
! - p^n/(\theta\Delta t^2 g) - F_w/(\theta\Delta t)
! \end{equation}
! and the velocities are constructed using
! \begin{eqnarray}
! U^{n+1} &=& u' - \theta\Delta t\nabla_x(p^{n+1} - {p'}^{n+1})\! V^{n+1} &=& v' - \theta\Delta t\nabla_y(p^{n+1} - {p'}^{n+1})

! \end{eqnarray}
!
! The above equations are written for the case of implicit treatment
! of the coriolis terms. The parameters $\alpha$ and $\gamma$ are
! used to vary the time-centering of the coriolis terms and surface
! pressure gradients, which enter the equations centered in time
! as follows:
! \begin{eqnarray}
! \alpha Q^{n+1} + \gamma Q^n + (1-\alpha-\gamma)Q^{n-1} & &
! {\rm (leapfrog\ timesteps)} \! \theta Q^{n+1} + (1-\theta)Q^n & & {\rm (matsuno\ timesteps)}

! \end{eqnarray}
! where Q is the coriolis term or surface-pressure gradient.
! The force terms $(F_x,F_y)$ contain r.h.s. coriolis terms which
! vary depending on the type of timestep (see comments in clinic).
! If the coriolis terms are treated explicitly, then they are
! simply evaluated at time (n), and appear only in the force terms.
!
! In the 2nd pass of a matsuno timestep, the force terms
! $(F_x',F_y')$ are constructed in baroclinic using the predicted
! prognostic fields $({U'}^{n+1},{V'}^{n+1}),T^{n+1}$ from the first
! pass.
!
! The auxiliary velocities $(u',v')$ are solutions of the momentum
! equation using an earlier known pressure. The elliptic equation
! solves for the correction to this pressure, and its gradient is
! added to $(u',v')$ to obtain the new velocites $(U^{n+1},V^{n+1})$.
!
! The elliptic equation is multiplied by the T-cell area to make
! the operator matrix used by the cg solver symmetric.
! $F_w$ is the surface freshwater flux in cm/s for the variable
! thickness surface layer option.
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,max_blocks_clinic), &
      intent(in) :: &
      ZX, ZY ! vertical integrals of forcing

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: iblock

   integer (int_kind) :: &
      ierr, &!
      i,j ! explicit do-loop

   real (r8) :: &
      xcheck ! global sum of checkerboard

   real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: &
      RHS, &! r.h.s. of elliptic eqn times T-cell area
      UH,VH, &! auxiliary velocities (see description above)
      PCHECK, &! array for computing null space
      WORKX,WORKY ! local temp space

   real (r8), dimension(nx_block,ny_block) :: &
      WORK1,WORK2,WORK3,WORK4 ! local work space

   type (block) :: &
      this_block ! block information for current block

   r_beta_c2dtp = c1/(beta*c2dtp)
   r_beta_c2dtp_etc = c1/(beta*c2dtp*dtp*grav)

!-----------------------------------------------------------------------
!
! calculate r.h.s. of barotropic momentum equations.
!
!-----------------------------------------------------------------------

   !$OMP PARALLEL DO PRIVATE(iblock, this_block, &
   !$OMP WORK1, WORK2, WORK3, WORK4)

   do iblock = 1,nblocks_clinic
      this_block = get_block(blocks_clinic(iblock),iblock)

      if (leapfrogts) then ! leapfrog

        do j=1,ny_block
         WORK3(:,j) = c2dtp*(ZX(:,j,iblock) - &
                              gamma *GRADPX(:,j,curtime,iblock) - &
                        (c1 - gamma)*GRADPX(:,j,oldtime,iblock))
         WORK4(:,j) = c2dtp*(ZY(:,j,iblock) - &
                              gamma *GRADPY(:,j,curtime,iblock) - &
                        (c1 - gamma)*GRADPY(:,j,oldtime,iblock))
        enddo

      elseif (mix_pass == 1 .or. f_euler_ts) then ! matsuno 1st pass

        do j=1,ny_block
         WORK3(:,j) = c2dtp*(ZX(:,j,iblock) - GRADPX(:,j,curtime,iblock))
         WORK4(:,j) = c2dtp*(ZY(:,j,iblock) - GRADPY(:,j,curtime,iblock))
        enddo

      else ! (mix_pass == 2) ! matsuno 2nd pass

        do j=1,ny_block
         WORK3(:,j) = c2dtp*(ZX(:,j,iblock) - &
                              theta *GRADPX(:,j,newtime,iblock) - &
                        (c1 - theta)*GRADPX(:,j,curtime,iblock))
         WORK4(:,j) = c2dtp*(ZY(:,j,iblock) - &
                              theta *GRADPY(:,j,newtime,iblock) - &
                        (c1 - theta)*GRADPY(:,j,curtime,iblock))
        enddo

      endif

!-----------------------------------------------------------------------
!
! calculate negative gradient of surface atmospheric pressure
! and add it to r.h.s. forcing
!
!-----------------------------------------------------------------------

      if (ap_data_type /= 'none') then

         call grad(1, WORK1, WORK2, ATM_PRESS(:,:,iblock), this_block)

         WORK3 = WORK3 - c2dtp*WORK1
         WORK4 = WORK4 - c2dtp*WORK2
      endif

!-----------------------------------------------------------------------
!
! solve for auxiliary velocities ([Uh],[Vh])
!
!-----------------------------------------------------------------------

      if (impcor) then ! implicit coriolis

        do j=1,ny_block
         WORK1(:,j) = c2dtp*beta*FCOR(:,j,iblock)
         WORK2(:,j) = c1/(c1 + WORK1(:,j)**2)
         UH(:,j,iblock) = WORK2(:,j)*(WORK3(:,j) + WORK1(:,j)*WORK4(:,j)) + &
                          UBTROP(:,j,oldtime,iblock)
         VH(:,j,iblock) = WORK2(:,j)*(WORK4(:,j) - WORK1(:,j)*WORK3(:,j)) + &
                          VBTROP(:,j,oldtime,iblock)
        enddo

      else ! explicit coriolis

         UH(:,:,iblock) = WORK3 + UBTROP(:,:,oldtime,iblock)
         VH(:,:,iblock) = WORK4 + VBTROP(:,:,oldtime,iblock)

      endif

!-----------------------------------------------------------------------
!
! calculate r.h.s. of elliptic equation
!
!-----------------------------------------------------------------------

      if (leapfrogts) then ! leapfrog

        do j=1,ny_block
         WORK3(:,j) = HU(:,j,iblock)*(UH(:,j,iblock) + &
                                 beta*c2dtp*GRADPX(:,j,oldtime,iblock))
         WORK4(:,j) = HU(:,j,iblock)*(VH(:,j,iblock) + &
                                 beta*c2dtp*GRADPY(:,j,oldtime,iblock))
        enddo

      elseif (mix_pass == 1 .or. f_euler_ts) then ! matsuno 1st pass

        do j=1,ny_block
         WORK3(:,j) = HU(:,j,iblock)*(UH(:,j,iblock) + &
                                 beta*c2dtp*GRADPX(:,j,curtime,iblock))
         WORK4(:,j) = HU(:,j,iblock)*(VH(:,j,iblock) + &
                                 beta*c2dtp*GRADPY(:,j,curtime,iblock))
        enddo

      else ! (mix_pass == 2) ! matsuno 2nd pass

        do j=1,ny_block
         WORK3(:,j) = HU(:,j,iblock)*(UH(:,j,iblock) + &
                                 beta*c2dtp*GRADPX(:,j,newtime,iblock))
         WORK4(:,j) = HU(:,j,iblock)*(VH(:,j,iblock) + &
                                 beta*c2dtp*GRADPY(:,j,newtime,iblock))
        enddo

      endif

      !*** div returns T-cell area * divergence
      call div(1,RHS(:,:,iblock),WORK3,WORK4,this_block)
      do j=1,ny_block
      RHS(:,j,iblock) = RHS(:,j,iblock)*r_beta_c2dtp
      enddo

!-----------------------------------------------------------------------
!
! add diagonal term to central coefficient in implicit free-surface
! formulation, and add correction to r.h.s.
!
!-----------------------------------------------------------------------

      select case (sfc_layer_type)

      case(sfc_layer_varthick)
        do j=1,ny_block
         A0_CLINIC(:,j,iblock) = &
                        merge(TAREA(:,j,iblock)*r_beta_c2dtp_etc, &
                              c0,CALCT(:,j,iblock))
         RHS(:,j,iblock) = RHS(:,j,iblock) - &
                     A0_CLINIC(:,j,iblock)*PSURF(:,j,curtime,iblock) - &
                     FW(:,j,iblock)*TAREA(:,j,iblock)*r_beta_c2dtp
         A0_CLINIC(:,j,iblock) = AC(:,j,iblock) - A0_CLINIC(:,j,iblock)
        enddo

      case(sfc_layer_rigid)
        do j=1,ny_block
         A0_CLINIC(:,j,iblock) = AC(:,j,iblock)
        enddo

      case(sfc_layer_oldfree)
        do j=1,ny_block
         A0_CLINIC(:,j,iblock) = &
                        merge(TAREA(:,j,iblock)*r_beta_c2dtp_etc, &
                              c0,CALCT(:,j,iblock))
         RHS(:,j,iblock) = RHS(:,j,iblock) - &
                     A0_CLINIC(:,j,iblock)*PSURF(:,j,curtime,iblock)
         A0_CLINIC(:,j,iblock) = AC(:,j,iblock) - A0_CLINIC(:,j,iblock)
        enddo

      end select

!-----------------------------------------------------------------------
!
! initial guess for solver
! in matsuno 2nd pass, temporarily store press gradient from
! 1st pass
!
!-----------------------------------------------------------------------

      PSURF(:,:,newtime,iblock) = PGUESS(:,:,iblock)

      if (mix_pass == 2) then
         WORKX(:,:,iblock) = GRADPX(:,:,newtime,iblock)
         WORKY(:,:,iblock) = GRADPY(:,:,newtime,iblock)
      endif

   end do ! block loop

   !$OMP END PARALLEL DO

   !ljm tuning
   !lmic_trace = .true.
   call update_ghost_cells(RHS, bndy_clinic, field_loc_center, &
                                             field_type_scalar)

! lmic_trace = .false.
! !ljm tuning
! do j=1,distrb_clinic%local_block_num
! i = distrb_clinic%local_block_ids(j)
! if (i>nblocks_tot) then ! tiny-block
! this_block = get_block(i,j)
! write(6,*) 'pcg-zero:RHS:',this_block%block_id,i-nblocks_tot,sum(RHS(:,:,j))
! else
! write(6,*) 'pcg-zero:RHS:',i,0,sum(RHS(:,:,j))
! endif
! enddo
! call MPI_BARRIER(MPI_COMM_OCN, ierr)
! call exit_POP(sigAbort,'debug pcg-zero-R...')

!-----------------------------------------------------------------------
!
! solve elliptic equation for surface pressure
!
!-----------------------------------------------------------------------

   call elliptic_solver(PSURF(:,:,newtime,:),RHS)

!-----------------------------------------------------------------------
!
! calculate global sum of checkerboard nullspace
!
!-----------------------------------------------------------------------

   if (sfc_layer_type == sfc_layer_varthick) then

      !$OMP PARALLEL DO PRIVATE(iblock)
      do iblock = 1,nblocks_clinic
        do j=1,ny_block
         PCHECK(:,j,iblock) = PSURF(:,j,newtime,iblock)* &
                            CHECKER(:,j,iblock)
        enddo
      end do
      !$OMP END PARALLEL DO

      xcheck = global_sum(PCHECK,distrb_clinic,field_loc_center)
   endif

   !$OMP PARALLEL DO PRIVATE(iblock,this_block)

   do iblock = 1,nblocks_clinic
      this_block = get_block(blocks_clinic(iblock),iblock)

!-----------------------------------------------------------------------
!
! remove checkerboard nullspace from solution
!
!-----------------------------------------------------------------------

      if (sfc_layer_type == sfc_layer_varthick) then
        do j=1,ny_block
         PSURF(:,j,newtime,iblock) = PSURF(:,j,newtime,iblock) + &
                                   CONSTNT(:,j,iblock)*rcheck*xcheck - &
                                   CHECKER(:,j,iblock)*rconst*xcheck
        enddo
      endif

!-----------------------------------------------------------------------
!
! calculate gradient of PSURF(:,:,newtime)
!
!-----------------------------------------------------------------------

      call grad(1,GRADPX(:,:,newtime,iblock), &
                  GRADPY(:,:,newtime,iblock), &
                   PSURF(:,:,newtime,iblock),this_block)

!-----------------------------------------------------------------------
!
! update new barotropic velocity, pressure, pressure gradient
!
!-----------------------------------------------------------------------

      if (leapfrogts) then ! leapfrog

        do j=1,ny_block
         UBTROP(:,j,newtime,iblock) = UH(:,j,iblock) - &
                             beta*c2dtp*(GRADPX(:,j,newtime,iblock) - &
                                         GRADPX(:,j,oldtime,iblock))
         VBTROP(:,j,newtime,iblock) = VH(:,j,iblock) - &
                             beta*c2dtp*(GRADPY(:,j,newtime,iblock) - &
                                         GRADPY(:,j,oldtime,iblock))
        enddo

      elseif (mix_pass == 1 .or. f_euler_ts) then ! matsuno 1st pass

        do j=1,ny_block
         UBTROP(:,j,newtime,iblock) = UH(:,j,iblock) - &
                             beta*c2dtp*(GRADPX(:,j,newtime,iblock) - &
                                         GRADPX(:,j,curtime,iblock))
         VBTROP(:,j,newtime,iblock) = VH(:,j,iblock) - &
                             beta*c2dtp*(GRADPY(:,j,newtime,iblock) - &
                                         GRADPY(:,j,curtime,iblock))
        enddo

      else ! (mix_pass == 2) ! matsuno 2nd pass

        do j=1,ny_block
         UBTROP(:,j,newtime,iblock) = UH(:,j,iblock) - &
                             beta*c2dtp*(GRADPX(:,j,newtime,iblock) - &
                                         WORKX(:,j,iblock))
         VBTROP(:,j,newtime,iblock) = VH(:,j,iblock) - &
                             beta*c2dtp*(GRADPY(:,j,newtime,iblock) - &
                                         WORKY(:,j,iblock))
        enddo

      endif

!-----------------------------------------------------------------------
!
! accumulate tavg diagnostics for barotropic velocities
!
!-----------------------------------------------------------------------

      if (tavg_requested(tavg_SU)) then
         call accumulate_tavg_field(HU(:,:,iblock)* &
                                    UBTROP(:,:,curtime,iblock), &
                                    tavg_SU, iblock, 1)
      endif

      if (tavg_requested(tavg_SV)) then
         call accumulate_tavg_field(HU(:,:,iblock)* &
                                    VBTROP(:,:,curtime,iblock), &
                                    tavg_SV, iblock, 1)
      endif

   end do ! block loop

   !$OMP END PARALLEL DO

   call update_ghost_cells(PSURF (:,:,newtime,:), bndy_clinic, &
                           field_loc_center , field_type_scalar)
   call update_ghost_cells(GRADPX(:,:,newtime,:), bndy_clinic, &
                           field_loc_NEcorner, field_type_vector)
   call update_ghost_cells(GRADPY(:,:,newtime,:), bndy_clinic, &
                           field_loc_NEcorner, field_type_vector)

!-----------------------------------------------------------------------
!EOC

 end subroutine barotropic_driver

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

 end module barotropic

!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||