      INCLUDE 'elsepa.f'
      INCLUDE 'f1f2wd.f'
      INCLUDE 'f2allm.f'
      INCLUDE 'f2glob.f'
      INCLUDE 'r1998.f'

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C               +++++++++++++++++++++++++++++
C               +++    PROGRAM ELSCATA    +++
C               +++++++++++++++++++++++++++++
C
C
C                       O. Koshchii
C                    December 27, 2020
C
C   This program does relativistic (Dirac) partial wave calculations
C   of elastic scattering of electrons and positrons by neutral atoms
c   and positive ions with Z=1-103. The interaction between the projectile
C   and the target system is assumed to be equal to the electrostatic
C   potential energy, plus a local exchange potential in the case of
C   projectile electrons. For projectiles with relatively low energies,
C   approximate correlation-polarization and absorption corrections can
C   be introduced.
C
C   The code calculates the phase shifts, the direct and spin-flip
C   scattering amplitudes, the differential cross section (DCS) and the
C   Sherman function (spin polarization) for electrons and positrons with
C   kinetic energies larger than 10 eV. For kinetic energies larger than
C   10 MeV, the convergence of the partial-wave series is too slow and
C   the differential cross section is calculated using approximate high-
C   energy factorization methods.
C
C
C   The input data file.
C
C   Data are read from a formatted input file (unit 5). Each line in
C   this file consists of a 6-character keyword (columns 1-6) followed by
C   a numerical value (in free format) that is written on the columns
C   8-19. Keywords are explicitly used/verified by the program (which is
C   case sensitive!). The text after column 20 describes the input
C   quantity and its default value (in square brackets). This text is a
C   reminder for the user and is not read by the program.
C
C   Lines defining default values can be omitted from the input file.
C   The program assigns default values to input parameters that are not
C   explicitly defined, and also to those that are manifestly wrong. The
C   code stops when it finds an inconsistent input datum. The conflicting
C   quantity appears in the last line written on the screen.
C
C
C   The computed information is delivered in various files with the
C   extension '.dat'. The output file 'dcs_xpyyyezz.dat' contains the
C   calculated DCS for the energy x.yyyEzz (E format, in eV) in a format
C   ready for visualization with a plotting program. The output files
C   'scfield.dat' and 'scatamp.dat' contain tables of the scattering
C   potential and the scattering amplitudes of the last calculated case;
C   they are overwritten (i.e. lost) when a new case is calculated.
C
C   This program uses the subroutine package 'elsepa.f', which has
C   been inserted into this source file by using an INCLUDE statement
C   (see above).
C
C
        IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Z), COMPLEX*16 (C),
     1      INTEGER*4 (I-N)
        CHARACTER*6 KWORD
        CHARACTER*22 BUFFER,OFILE,OFILE1,OFILE2,OFILE3,OFILE4,
     1               OFILE5,OFILE6
C
        PARAMETER (A0B=5.2917721067D-9)
        PARAMETER (A0B2=A0B*A0B)
        PARAMETER (PI=3.1415926535897932D0)
        PARAMETER (FMTOINVGEV=5.067730759D0)
C
C   Results from the partial wave calculation.
C
        PARAMETER (NGT=1650)
        COMMON/DCSTAB/ECS,TCS1,TCS2,TH(NGT),THLAB(NGT),XT(NGT),NTAB,
     1                DCST(NGT),DCSTLAB(NGT),SPOL(NGT),ERROR(NGT)
        COMMON/CTOTCS/TOTCS,ABCS
        COMMON/KINPARAM/BEAMMASS,TARGMASS,SINVTARG,EVLABGEV,EVLAB
C
C   Atomic polarizabilities of free atoms (in cm**3), from
C   Thomas M. Miller, 'Atomic and molecular polarizabilities' in
C   CRC Handbook of Chemistry and Physics, Editor-in-chief David
C   R. Linde. 79th ed., 1998-1999, pp. 10-160 to 10-174.
C
        DIMENSION ATPOL(103)
        DATA ATPOL/   0.666D-24, 0.205D-24, 24.30D-24, 5.600D-24,
     A   3.030D-24, 1.760D-24, 1.100D-24, 0.802D-24, 0.557D-24,
     1   3.956D-25, 24.08D-24, 10.06D-24, 6.800D-24, 5.380D-24,
     A   3.630D-24, 2.900D-24, 2.180D-24, 1.641D-24, 43.40D-24,
     2   22.80D-24, 17.80D-24, 14.60D-24, 12.40D-24, 11.60D-24,
     A   9.400D-24, 8.400D-24, 7.500D-24, 6.800D-24, 6.100D-24,
     3   7.100D-24, 8.120D-24, 6.070D-24, 4.310D-24, 3.770D-24,
     A   3.050D-24, 2.484D-24, 47.30D-24, 27.60D-24, 22.70D-24,
     4   17.90D-24, 15.70D-24, 12.80D-24, 11.40D-24, 9.600D-24,
     A   8.600D-24, 4.800D-24, 7.200D-24, 7.200D-24, 10.20D-24,
     5   7.700D-24, 6.600D-24, 5.500D-24, 5.350D-24, 4.044D-24,
     A   59.60D-24, 39.70D-24, 31.10D-24, 29.60D-24, 28.20D-24,
     6   31.40D-24, 30.10D-24, 28.80D-24, 27.70D-24, 23.50D-24,
     A   25.50D-24, 24.50D-24, 23.60D-24, 22.70D-24, 21.80D-24,
     7   21.00D-24, 21.90D-24, 16.20D-24, 13.10D-24, 11.10D-24,
     A   9.700D-24, 8.500D-24, 7.600D-24, 6.500D-24, 5.800D-24,
     8   5.100D-24, 7.600D-24, 6.800D-24, 7.400D-24, 6.800D-24,
     A   6.000D-24, 5.300D-24, 48.70D-24, 38.30D-24, 32.10D-24,
     9   32.10D-24, 25.40D-24, 24.90D-24, 24.80D-24, 24.50D-24,
     A   23.30D-24, 23.00D-24, 22.70D-24, 20.50D-24, 19.70D-24,
     1   23.80D-24, 18.20D-24, 17.50D-24, 20.00D-24/
C
C   Ionization energies of neutral atoms (in eV).
C   NIST Physical Reference Data.
C   http://sed.nist.gov/PhysRefData/IonEnergy/tblNew.html
C   For astatine (Z=85), the value given below was calculated with
C   the DHFXA code (Salvat and Fernandez-Varea, UBIR-2003).
C
        DIMENSION EIONZ(103)
        DATA EIONZ/  13.5984D0, 24.5874D0, 5.39170D0, 9.32270D0,
     A  8.29800D0, 11.2603D0, 14.5341D0, 13.6181D0, 17.4228D0,
     1  21.5646D0, 5.13910D0, 7.64620D0, 5.98580D0, 8.15170D0,
     A  10.4867D0, 10.3600D0, 12.9676D0, 15.7596D0, 4.34070D0,
     2  6.11320D0, 6.56150D0, 6.82810D0, 6.74620D0, 6.76650D0,
     A  7.43400D0, 7.90240D0, 7.88100D0, 7.63980D0, 7.72640D0,
     3  9.39420D0, 5.99930D0, 7.89940D0, 9.78860D0, 9.75240D0,
     A  11.8138D0, 13.9996D0, 4.17710D0, 5.69490D0, 6.21710D0,
     4  6.63390D0, 6.75890D0, 7.09240D0, 7.28000D0, 7.36050D0,
     A  7.45890D0, 8.33690D0, 7.57620D0, 8.99380D0, 5.78640D0,
     5  7.34390D0, 8.60840D0, 9.00960D0, 10.4513D0, 12.1298D0,
     A  3.89390D0, 5.21170D0, 5.57690D0, 5.53870D0, 5.47300D0,
     6  5.52500D0, 5.58200D0, 5.64360D0, 5.67040D0, 6.15010D0,
     A  5.86380D0, 5.93890D0, 6.02150D0, 6.10770D0, 6.18430D0,
     7  6.25420D0, 5.42590D0, 6.82510D0, 7.54960D0, 7.86400D0,
     A  7.83350D0, 8.43820D0, 8.96700D0, 8.95870D0, 9.22550D0,
     8  10.4375D0, 6.10820D0, 7.41670D0, 7.28560D0, 8.41700D0,
     A  9.50000D0, 10.7485D0, 4.07270D0, 5.27840D0, 5.17000D0,
     9  6.30670D0, 5.89000D0, 6.19410D0, 6.26570D0, 6.02620D0,
     A  5.97380D0, 5.99150D0, 6.19790D0, 6.28170D0, 6.42000D0,
     1  6.50000D0, 6.58000D0, 6.65000D0, 4.90000D0/
C
C   First excitation energies of neutral atoms (in eV).
C   NIST Physical Reference Data.
C   The value 0.0D0 indicates that the experimental value for
C   the atom was not available.
C
        DIMENSION EEX1Z(103)
        DATA EEX1Z/ 10.20D0, 19.82D0,  1.85D0,  2.73D0,
     A    3.58D0,  1.26D0,  2.38D0,  1.97D0, 12.70D0,
     1   16.62D0,  2.10D0,  2.71D0,  3.14D0,  0.78D0,
     A    1.41D0,  1.15D0,  8.92D0, 11.55D0,  1.61D0,
     2    1.88D0,  1.43D0,  0.81D0,  0.26D0,  0.94D0,
     A    2.11D0,  0.86D0,  0.43D0,  0.01D0,  1.38D0,
     3    4.00D0,  3.07D0,  0.88D0,  1.31D0,  1.19D0,
     A    7.87D0,  9.91D0,  0.00D0,  0.00D0,  0.00D0,
     4    0.00D0,  0.00D0,  1.34D0,  0.00D0,  0.00D0,
     A    0.00D0,  0.00D0,  0.00D0,  3.73D0,  0.00D0,
     5    0.00D0,  0.00D0,  0.00D0,  0.00D0,  8.31D0,
     A    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     6    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     A    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     7    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     A    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     8    4.67D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     A    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     9    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     A    0.00D0,  0.00D0,  0.00D0,  0.00D0,  0.00D0,
     1    0.00D0,  0.00D0,  0.00D0,  0.00D0/
C
C   Nearest-neighbour distances (in cm) of the elements,
C   from Ch. Kittel, 'Introduction to Solid State Physics'.
C   5th ed. (John Wiley and Sons, New York, 1976).
C   The value -1.0D-8 indicates that the experimental value
C   for the element was not available.
C
        DIMENSION DNNEL(103)
        DATA DNNEL/    -1.000D-8,-1.000D-8, 3.124D-8, 2.220D-8,
     A     -1.000D-8, 1.540D-8,-1.000D-8,-1.000D-8, 1.440D-8,
     1     -1.000D-8, 3.822D-8, 3.200D-8, 2.860D-8, 2.350D-8,
     A     -1.000D-8,-1.000D-8,-1.000D-8,-1.000D-8, 4.752D-8,
     2      3.950D-8, 3.250D-8, 2.890D-8, 2.620D-8, 2.500D-8,
     A      2.240D-8, 2.480D-8, 2.500D-8, 2.490D-8, 2.560D-8,
     3      2.660D-8, 2.440D-8, 2.450D-8, 3.160D-8, 2.320D-8,
     A     -1.000D-8,-1.000D-8, 4.837D-8, 4.300D-8, 3.550D-8,
     4      3.170D-8, 2.860D-8, 2.720D-8, 2.710D-8, 2.650D-8,
     A      2.690D-8, 2.750D-8, 2.890D-8, 2.980D-8, 3.250D-8,
     5      2.810D-8, 2.910D-8, 2.860D-8, 3.540D-8,-1.000D-8,
     A      5.235D-8, 4.350D-8, 3.730D-8, 3.650D-8, 3.630D-8,
     6      3.660D-8,-1.000D-8, 3.590D-8, 3.960D-8, 3.580D-8,
     A      3.520D-8, 3.510D-8, 3.490D-8, 3.470D-8, 3.540D-8,
     7      3.880D-8, 3.430D-8, 3.130D-8, 2.860D-8, 2.740D-8,
     A      2.740D-8, 2.680D-8, 2.710D-8, 2.770D-8, 2.880D-8,
     8     -1.000D-8, 3.460D-8, 3.500D-8, 3.070D-8, 3.340D-8,
     A     -1.000D-8,-1.000D-8,-1.000D-8,-1.000D-8, 3.760D-8,
     9      3.600D-8, 3.210D-8, 2.750D-8, 2.620D-8, 3.100D-8,
     A      3.610D-8,-1.000D-8,-1.000D-8,-1.000D-8,-1.000D-8,
     1     -1.000D-8,-1.000D-8,-1.000D-8,-1.000D-8/
C
C  Atomic weights
C
        DIMENSION ELAW(103)
        DATA ELAW     /1.007900D0,4.002600D0,6.941000D0,9.012200D0,
     1    1.081100D1,1.200000D1,1.400670D1,1.599940D1,1.899840D1,
     2    2.017970D1,2.298980D1,2.430500D1,2.698150D1,2.808550D1,
     3    3.097380D1,3.206600D1,3.545270D1,3.994800D1,3.909830D1,
     4    3.996259D1,4.495590D1,4.786700D1,5.094150D1,5.199610D1,
     5    5.493800D1,5.584500D1,5.893320D1,5.869340D1,6.354600D1,
     6    6.539000D1,6.972300D1,7.261000D1,7.492160D1,7.896000D1,
     7    7.990400D1,8.380000D1,8.546780D1,8.762000D1,8.890590D1,
     8    9.122400D1,9.290640D1,9.594000D1,9.890630D1,1.010700D2,
     9    1.029055D2,1.064200D2,1.078682D2,1.124110D2,1.148180D2,
     1    1.187100D2,1.217600D2,1.276000D2,1.269045D2,1.312900D2,
     1    1.329054D2,1.373270D2,1.389055D2,1.401160D2,1.409076D2,
     2    1.442400D2,1.449127D2,1.503600D2,1.519640D2,1.572500D2,
     3    1.589253D2,1.625000D2,1.649303D2,1.672600D2,1.689342D2,
     4    1.730400D2,1.749670D2,1.784900D2,1.809479D2,1.838400D2,
     5    1.862070D2,1.902300D2,1.922170D2,1.950780D2,1.969666D2,
     6    2.005900D2,2.043833D2,2.079767D2,2.089804D2,2.089824D2,
     7    2.099871D2,2.220176D2,2.230197D2,2.260254D2,2.270277D2,
     8    2.320381D2,2.310359D2,2.380289D2,2.370482D2,2.440642D2,
     9    2.430614D2,2.470000D2,2.470000D2,2.510000D2,2.520000D2,
     1    2.570000D2,2.580000D2,2.590000D2,2.620000D2/
C
C   Phase shifts.
C
        PARAMETER (NDM=25000)
        COMMON/PHASES/DP(NDM),DM(NDM),NPH,ISUMP
        COMMON/PHASEI/DPJ(NDM),DMJ(NDM)
C
C   START TIMER
C
        CALL CPU_TIME(START)
C
C   Input data. Default model.
C
        IELEC =-1        ! electron
        IZ    = 82       ! lead-208
        NELEC = 0        ! just nucleus
        MNUCL = 2        ! sum of Gaussians charge distribution
        MELEC = 3        ! DF electron density
        MUFFIN= 0        ! free atom
        RMUF  = 0        ! free atom
        MEXCH = 0        ! FM exchange potential
        MCPOL = 0        ! no correlation-polarization
        VPOLA =-1.0D0    ! atomic polarizability
        VPOLB =-1.0D0    ! polariz. cutoff parameter
        MABS  = 0        ! no absorption
        VABSA = 2.0D0    ! absorption potential strength
        VABSD =-1.0D0    ! energy gap
        IHEF  = 0        ! high-energy factorization on
        ISOT  = 0        ! isotop indicator number  (=1 only for Ca-48)
        UNC  = 0         ! different forms of Vabs
C
  100   CONTINUE
        READ(5,'(A6,1X,A12)',END=9999) KWORD,BUFFER
        IF(KWORD.EQ.'IZ    ') THEN
            READ(BUFFER,*) IZ
            IF(IZ.LT.1.OR.IZ.GT.103) THEN
            WRITE(6,*) 'IZ =',IZ
            STOP 'Wrong atomic number'
            ENDIF
        ELSE IF(KWORD.EQ.'MNUCL ') THEN
            READ(BUFFER,*) MNUCL
            IF(MNUCL.LT.1.OR.MNUCL.GT.4) MNUCL=3
        ELSE IF(KWORD.EQ.'NELEC ') THEN
            READ(BUFFER,*) NELEC
            IF(NELEC.LT.0) NELEC=IZ
            IF(NELEC.GT.IZ) THEN
            WRITE(6,*) 'NELEC =',NELEC
            STOP 'Negative ion'
            ENDIF
        ELSE IF(KWORD.EQ.'MELEC ') THEN
            READ(BUFFER,*) MELEC
            IF(MELEC.LT.1.OR.MELEC.GT.5) MELEC=4
        ELSE IF(KWORD.EQ.'MUFFIN') THEN
            READ(BUFFER,*) MUFFIN
            IF(MUFFIN.NE.1) MUFFIN=0
        ELSE IF(KWORD.EQ.'RMUF  ') THEN
            READ(BUFFER,*) RMUF
        ELSE IF(KWORD.EQ.'IELEC ') THEN
            READ(BUFFER,*) IELEC
            IF(IELEC.NE.+1) IELEC=-1
        ELSE IF(KWORD.EQ.'MEXCH ') THEN
            READ(BUFFER,*) MEXCH
            IF(MEXCH.LT.0.OR.MEXCH.GT.3) MEXCH=1
        ELSE IF(KWORD.EQ.'MCPOL ') THEN
            READ(BUFFER,*) MCPOL
            IF(MCPOL.LT.0.OR.MCPOL.GT.2) MCPOL=0
        ELSE IF(KWORD.EQ.'VPOLA ') THEN
            READ(BUFFER,*) VPOLA
            IF(VPOLA.LT.-1.0D-35) VPOLA=ATPOL(IZ)
        ELSE IF(KWORD.EQ.'VPOLB ') THEN
            READ(BUFFER,*) VPOLB
            IF(VPOLB.LT.1.0D-10) VPOLB=-10.0D0
        ELSE IF(KWORD.EQ.'MABS  ') THEN
            READ(BUFFER,*) MABS
            IF(MABS.NE.1) MABS=0
        ELSE IF(KWORD.EQ.'VABSA ') THEN
            READ(BUFFER,*) VABSAI
            IF(VABSAI.GE.0.0D0) VABSA=VABSAI
        ELSE IF(KWORD.EQ.'VABSD ') THEN
            READ(BUFFER,*) VABSD
            IF(VABSD.LT.-1.0D-35) VABSD=-1.0D0
        ELSE IF(KWORD.EQ.'IHEF') THEN
            READ(BUFFER,*) IHEF
            IF(IHEF.NE.0.AND.IHEF.NE.2) IHEF=1
        ELSE IF(KWORD.EQ.'ISOT') THEN
            READ(BUFFER,*) ISOT
        ELSE IF(KWORD.EQ.'IFR') THEN
            READ(BUFFER,*) IFR
            IF(MABS.EQ.0) IFR=0
        ELSE IF(KWORD.EQ.'UNC') THEN
            READ(BUFFER,*) UNC
        ELSE IF(KWORD.EQ.'EV    ') THEN
            GO TO 200
        ELSE
            STOP 'Unrecognized keyword'
        ENDIF
        GO TO 100
C
C   Potential model parameters.
C
  200   CONTINUE
        IF(NELEC.EQ.1000) NELEC=IZ
C
        IF(NELEC.NE.IZ) MUFFIN=0
        IF(MUFFIN.EQ.1) THEN
            IF(RMUF.LT.1.0D-9) RMUF=0.5D0*DNNEL(IZ)
            IF(RMUF.LT.1.0D-9) STOP 'RMUF is too small'
        ELSE
            MUFFIN=0
            RMUF=200.0D-8
        ENDIF
C
        IF(IELEC.EQ.+1) MEXCH=0
C
        IF(MCPOL.EQ.1) THEN
            IF(VPOLA.LT.-1.0D-35) VPOLA=ATPOL(IZ)
            IF(VPOLA.LT.-1.0D-35) STOP 'VPOLA must be positive'
            IF(VPOLB.LT.1.0D-10) VPOLB=-10.0D0
        ELSE IF(MCPOL.EQ.2) THEN
            IF(VPOLA.LT.-1.0D-35) VPOLA=ATPOL(IZ)
            IF(VPOLA.LT.-1.0D-35) STOP 'VPOLA must be positive'
            IF(VPOLB.LT.1.0D-10) VPOLB=-10.0D0
        ELSE
            MCPOL=0
            VPOLA=0.0D0
            VPOLB=0.0D0
        ENDIF
C
        IF(MABS.EQ.1) THEN
            IF(VABSA.LT.-1.0D-35) STOP 'VABSA must be positive'
            IF(VABSD.LT.-1.0D-35) THEN
            IF(IELEC.EQ.-1) THEN
                VABSD=EEX1Z(IZ)
                IF(VABSD.LT.-1.0D-35) VABSD=0.0D0
            ELSE
                VABSD=MAX(0.0D0,EIONZ(IZ)-6.8D0)
            ENDIF
            ENDIF
        ELSE
            MABS=0
            VABSA=0.0D0
            VABSD=1.0D0
        ENDIF
        ECUT=MIN(20.0D3*IZ,2.0D6)
C
        OPEN(25,FILE='tcstable.dat')
        WRITE(25,1001)
 1001   FORMAT(1X,'#  Total cross section table (last run of',
     1         ' ''elscata'').', /1X,'#')
        IF(IELEC.EQ.-1) THEN
            WRITE(25,1002) IZ
 1002       FORMAT(1X,'#  Z =',I4,',   projectile: electron')
        ELSE
            WRITE(25,1003) IZ
 1003       FORMAT(1X,'#  Z =',I4,',   projectile: positron')
        ENDIF
        WRITE(25,1004)
 1004   FORMAT(1X,'#',/1X,'#   Energy',9X,'ECS',9X,'TCS1',9X,'TCS2',
     1         9X,'ABSCS',6X,'error',/1X,'#',4X,'(eV)',8X,'(cm**2)',6X,
     2         '(cm**2)',6X,'(cm**2)',6X,'(cm**2)',/1X,'#',74('-'))

  300   CONTINUE
        READ(BUFFER,*) EV
        WRITE(6,*) '   '

        EVLAB=EV
        EVLABGEV=EVLAB*1.0D-9
        WRITE(6,*) 'Etot_lab (eV)=',EVLAB
C
C   Convert Lab energy to CM (UR approximation)
C
        BEAMMASS=0.5109989461D-3
        TARGMASS=0.9314940954D0*ELAW(IZ)
        IF(IZ.EQ.20.AND.ISOT.EQ.1) THEN
            TARGMASS=0.9314940954D0*47.9525D0
        ENDIF

        SINVTARG=TARGMASS**2+2.0D0*TARGMASS*EVLABGEV+BEAMMASS**2
        ECM=(SINVTARG+BEAMMASS**2-TARGMASS**2)/(2.0D0*SQRT(SINVTARG))
        ECMKIN=ECM-BEAMMASS
        EV=ECMKIN*1.0D9

        WRITE(6,*) 'Ekin_CM (eV) =',EV
        WRITE(6,*) 'Etot_CM (eV) =',EV+BEAMMASS*1.0D9
        IF(EV.LT.10.0D0) STOP 'The kinetic energy is too small'
C
        IF (MABS.EQ.0) THEN
            PRINT '(/,A,/)',' Absorptive potential is off'
            OFILE4='NoVabs_'
            OFILE5=''
            OFILE6=''
            GO TO 400
        ELSE
            PRINT '(/,A,/)',' Absorptive potential is on'
            OFILE4=''
        ENDIF
C
C   Record the value of the Compton slope
C   used for this particular nucleus
C
        CALL COMPSLOPE(BP,BCOMP,DBCOMP,IZ,ISOT)
        WRITE(BUFFER,'(1P,I0)') NINT(BP)
        OFILE5='BP'//TRIM(ADJUSTL(BUFFER))//'_'
C
C   Record the model used for the parametrization
C   of the absorptive potential
C
        IF (UNC.EQ.0) THEN
            OFILE6='UNC0_'
        ELSE IF (UNC.EQ.1) THEN
            OFILE6='UNC1_'
        ELSE IF (UNC.EQ.2) THEN
            OFILE6='UNC2_'
        ELSE IF (UNC.EQ.3) THEN
            OFILE6='UNC3_'
        ELSE
            WRITE(6,*) 'Change the value for UNC --> 0...3'
            STOP
        ENDIF

 400    CONTINUE
C
C   Formatting the output file
C
        WRITE(BUFFER,'(1P,E12.5,I1)') EVLAB
        OFILE=BUFFER(2:2)//'p'//BUFFER(4:6)//'e'//BUFFER(11:12)
        WRITE(BUFFER,'(1P,I1.1)') MNUCL
        OFILE1='_m'//BUFFER(1:1)
        WRITE(BUFFER,'(1P,I0)') IZ
        OFILE2='Z'//TRIM(ADJUSTL(BUFFER))//'_'
        WRITE(BUFFER,'(1P,I0)') ISOT
        OFILE3='IS'//TRIM(ADJUSTL(BUFFER))//'_'
        OPEN(8,FILE='dcs_'//TRIM(ADJUSTL(OFILE4))//
     -  TRIM(ADJUSTL(OFILE5))//TRIM(ADJUSTL(OFILE2))//
     -  TRIM(ADJUSTL(OFILE3))//TRIM(ADJUSTL(OFILE6))//
     -  OFILE(1:8)//OFILE1(1:3)//'.dat')
C
        IF(MCPOL.NE.0) THEN
            IF(EV.GT.1.0D4) THEN
                WRITE(6,*) 'WARNING: For E>10 keV the correlation-polari',
     1                     'zation correction is switched off.'
                MCPOLC=0
                VPOLBC=0.0D0
            ELSE
                MCPOLC=MCPOL
                IF(VPOLB.LT.0.0D0) THEN
                    VPOLBC=0.25D0*SQRT(MAX(EV-50.0D0,16.0D0))
                ELSE
                    VPOLBC=VPOLB
                ENDIF
            ENDIF
        ELSE
            MCPOLC=0
            VPOLBC=0.0D0
        ENDIF
        IF(MABS.NE.0) THEN
            IF(EV.GT.1.0D10) THEN
                WRITE(6,*) 'WARNING: For E>10 GeV, the absorption correc',
     1                      'tion is switched off.'
                MABSC=0
            ELSE
                MABSC=MABS
            ENDIF
        ELSE
            MABSC=0
        ENDIF
C
C   Partial-wave analysis is implemented by calling the main
C   ELSEPA subroutine.
C
        CALL ELSEPA(IELEC,EV,IZ,NELEC,MNUCL,MELEC,MUFFIN,RMUF,
     1              MEXCH,MCPOLC,VPOLA,VPOLBC,MABSC,VABSA,VABSD,
     2              IHEF,8,0.0D0,ISOT,IFR,UNC)
C
        ERRM=0.0D0
        DO I=1,NTAB
            ERRM=MAX(ERRM,ERROR(I))
        ENDDO
        WRITE(25,1005) EV,ECS,TCS1,TCS2,ABCS,ERRM
 1005   FORMAT(1X,1P,5E13.5,E9.1)
        CLOSE(8)
C

        READ(5,'(A6,1X,A12)',END=9999) KWORD,BUFFER
        IF(KWORD.EQ.'EV    ') GO TO 300
C
 9999   CONTINUE
        CLOSE(25)
C
C   STOP TIMER
C
        CALL CPU_TIME(FINISH)
        WRITE(6,*) 'Calculation time=',FINISH-START,' s'
      END


c $Id: comres.f,v 1.1 2012/11/29 21:00:07 jwebb Exp $
c
cdes This file contains definitions for the collision term
c
      integer maxbar,maxbra,minbar
      integer offmeson,maxmeson,pimeson,maxbrm,minnuc,mindel
      integer maxbrs1,maxbrs2
      integer numnuc,numdel,nucleon,maxnuc,maxdel
      integer minmes,maxmes

      parameter (minnuc=1) ! lowest baryon particle ID
      parameter (minmes=100) ! lowest meson particle ID
corig      parameter (maxmes=132) ! hightest meson particle ID
c add 5 charmed mesons to array
      parameter (maxmes=137) ! hightest meson particle ID

c number of resonances of a kind
      parameter (numnuc=16) ! number of nucleon resonances
      parameter (numdel=10) ! number of delta resonances
c indices of minimal and maximal itype of a kind (redundant but nice)
      parameter (maxnuc=minnuc+numnuc-1) ! highest nucleon ID
      parameter (mindel=minnuc+maxnuc)   ! lowest delta ID
      parameter (maxdel=mindel+numdel-1) ! highest delta ID

c minres & maxres define the range of nonstable & nonstrange baryons
      integer minres,maxres
      parameter (minres=minnuc+1) ! lowest baryon resonance ID
      parameter (maxres=maxdel)   ! highest (nonstrange) baryon
                                  ! resonance ID

c strangenes.ne.0 baryon resonances
      integer minlam,minsig,mincas,minome
      integer numlam,numsig,numcas,numome
      integer maxlam,maxsig,maxcas,maxome
      parameter (numlam=13) ! number of lambda states
      parameter (numsig=9)  ! number of sigma states
      parameter (numcas=6)  ! number of cascade states
      parameter (numome=1)  ! number of omega states
      parameter (minlam=mindel+numdel)   ! ID of lowest lambda state
      parameter (maxlam=minlam+numlam-1) ! ID of highest lambda state
      parameter (minsig=minlam+numlam)   ! ID of lowest sigma state
      parameter (maxsig=minsig+numsig-1) ! ID of highest sigma state
      parameter (mincas=minsig+numsig)   ! ID of lowest cascade state
      parameter (maxcas=mincas+numcas-1) ! ID of highest cascade state
      parameter (minome=mincas+numcas)   ! ID of lowest omega state
      parameter (maxome=minome+numome-1) ! ID of highest omega state

c minbar & maxbar define the range of all baryons
      parameter (minbar=minnuc) ! ID of lowest baryon state
      parameter (maxbar=maxome) ! ID of highest baryon state

      parameter (offmeson=minmes) ! offset between zero and lowest
                                  ! meson state
      parameter (maxmeson=maxmes) ! ID of highest meson state
c... these variables are in principal obsolete and should be exchanged
c were referenced

c... avoid hard coded itypes
      integer itrho,itome,iteta,itkaon,itphi,itetapr
      parameter (itkaon=106)   ! ID of kaon
      parameter (itrho=104)    ! ID of rho meson
      parameter (itome=103)    ! ID of omega meson
      parameter (iteta=102)    ! ID of eta
      parameter (itphi=109)    ! ID of phi
      parameter (itetapr=107)  ! ID of eta'
      parameter (pimeson=101)  ! ID of $\pi$
      parameter (nucleon=minnuc) ! ID of nucleon

      integer itmin,itmax
      parameter (itmin=minnuc)  ! lowest defined ID
      parameter (itmax=maxmes)  ! highest defined ID
c
      parameter (maxbra=11)  ! decay channels for $s=0$ baryon resonances
corig      parameter (maxbrm=25) ! decay channels for meson resonances
c add 2 decay channels for D*
      parameter (maxbrm=27) ! decay channels for meson resonances
      parameter (maxbrs1=10)! decay channels for $s=1$ baryon resonances
      parameter (maxbrs2=3) ! decay channels for $s=2$ baryon resonances

c
       integer mlt2it(maxmes-minmes) ! meson IDs sorted by multipletts

      real*8 massoff,mresmin,mresmax
      parameter (massoff=1d-4)      ! offset for mass generation
      parameter (mresmin=1.0765d0)  ! minimum baryon resonance mass
      parameter (mresmax=5d0)       ! maximum baryon resonance mass

      character*45 versiontag
      common /versioning/ versiontag

      real*8 massres(minbar:maxbar),widres(minbar:maxbar)
      real*8 branmes(0:maxbrm,minmes+1:maxmes)
      real*8 branres(0:maxbra,minnuc+1:maxdel)
      real*8 branbs1(0:maxbrs1,minlam+1:maxsig)
      real*8 branbs2(0:maxbrs2,mincas+1:maxcas)
      integer Jres(minbar:maxbar)
      integer Jmes(minmes:maxmes)
      integer pares(minbar:maxbar),pames(minmes:maxmes)
      integer Isores(minbar:maxbar), Isomes(minmes:maxmes)
      integer brtype(4,0:maxbra),bmtype(4,0:maxbrm)
      integer bs1type(4,0:maxbrs1),bs2type(4,0:maxbrs2)
      real*8 massmes(minmes:maxmes)
      real*8 mmesmn(minmes:maxmes)
      real*8 widmes(minmes:maxmes)
      integer strres(minbar:maxbar),strmes(minmes:maxmes)
      integer chrmres(minbar:maxbar),chrmmes(minmes:maxmes)

      integer lbr(0:maxbra,minnuc+1:maxdel)
      integer lbs1(0:maxbrs1,minlam+1:maxsig)
      integer lbs2(0:maxbrs2,mincas+1:maxcas)
      integer lbm(0:maxbrm,minmes+1:maxmes)

      common /resonances/ massres,widres,massmes,widmes,mmesmn,
     ,                    branres,branmes,branbs1,branbs2,
     ,                    bs1type,bs2type,lbs1,lbs2,lbm,
     ,                    jres,jmes,lbr,brtype,pares,pames,
     ,                    bmtype,
     ,                    Isores,Isomes,strres,strmes,mlt2it,
     ,                    chrmres,chrmmes

c     massres   : baryon mass table
c     widres    : baryon decay width table
c     massmes   : meson mass table
c     widmes    : meson decay width table
c     mmesmn    : table of minimum masses for meson resonances
c     branres   : branching ratios for $s=0$ baryon resonances
c     branmes   : branching ratios for meson resonances
c     branbs1   : branching ratios for $s=1$ baryon resonances
c     branbs2   : branching ratios for $s=2$ baryon resonances
c     brtype    : definitions of the decay branches for $s=0$ baryon resonances
c     bmtype    : definitions of the decay branches for meson resonances
c     bs1type   : definitions of the decay branches for $s=1$ baryon resonances
c     bs2type   : definitions of the decay branches for $s=2$ baryon resonances
c     lbr       : decay angular momenta for $s=0$ baryon decays
c     lbm       : decay angular momenta for meson decays
c     lbs1      : decay angular momenta for $s=1$ baryon decays
c     lbs2      : decay angular momenta for $s=2$ baryon decays
c     jres      : spin table for baryons
c     jmes      : spin table for mesons
c     pares     : parity table for baryons
c     pames     : parity table for mesons
c     isores    : isospin table for baryons
c     isomes    : isospin table for mesons
c     strres    : strangeness table for baryons
c     strmes    : strangeness table for mesons
c
c
ccccccccccccccccccccc sigtab-declarations cccccccccccccccccccccccccccccccccc

      integer itblsz,nsigs,maxreac,maxpsig,sigver
c     VERSION NUMBER of SIGTAB
      parameter (sigver = 1000) ! version number for collision
                                ! term and tables
ccccccccccccccccccccccccccccccccccccccc
c

      parameter (maxreac = 14) ! maximum number of collision classes
      parameter (maxpsig = 12) ! maximum number of cross
                               ! sections per class
      parameter (nsigs = 10)   ! number of tabulated cross sections

      PARAMETER (ITBLSZ= 100)  ! table size of cross section tables

c
      integer sigmaLN(maxpsig,2,maxreac)
      integer sigmainf(nsigs,20)
      real*8 sigmascal(nsigs,5), sigmas(nsigs,itblsz)
c
      common/sigtabi/sigmaln,sigmainf
      common/sigtabr/sigmas,sigmascal

c     sigmaln   : pointer array connecting collision classes with cross sections
c     sigmainf  : information related to tabulated cross sections
c     sigmascal : information related to tabulated cross sections
c     sigmas    : tabulated cross sections


MODULE eosbn2
  USE dom_oce
  USE phycst
  USE stopar
  USE stopts
  USE in_out_manager
  USE lib_mpp
  USE lib_fortran
  USE prtctl
  USE lbclnk
  USE timing
  IMPLICIT NONE
  PRIVATE
  INTERFACE eos
    MODULE PROCEDURE eos_insitu, eos_insitu_pot, eos_insitu_2d
  END INTERFACE
  INTERFACE eos_rab
    MODULE PROCEDURE rab_3d, rab_2d, rab_0d
  END INTERFACE
  INTERFACE eos_fzp
    MODULE PROCEDURE eos_fzp_2d, eos_fzp_0d
  END INTERFACE
  PUBLIC :: eos
  PUBLIC :: bn2
  PUBLIC :: eos_rab
  PUBLIC :: eos_pt_from_ct
  PUBLIC :: eos_fzp
  PUBLIC :: eos_pen
  PUBLIC :: eos_init
  LOGICAL, PUBLIC :: ln_TEOS10
  LOGICAL, PUBLIC :: ln_EOS80
  LOGICAL, PUBLIC :: ln_SEOS
  LOGICAL, PUBLIC :: l_useCT
  INTEGER, PUBLIC :: neos
  INTEGER, PARAMETER :: np_teos10 = - 1
  INTEGER, PARAMETER :: np_eos80 = 0
  INTEGER, PARAMETER :: np_seos = 1
  REAL(KIND = wp) :: rn_a0 = 1.6550E-1_wp
  REAL(KIND = wp) :: rn_b0 = 7.6554E-1_wp
  REAL(KIND = wp) :: rn_lambda1 = 5.9520E-2_wp
  REAL(KIND = wp) :: rn_lambda2 = 5.4914E-4_wp
  REAL(KIND = wp) :: rn_mu1 = 1.4970E-4_wp
  REAL(KIND = wp) :: rn_mu2 = 1.1090E-5_wp
  REAL(KIND = wp) :: rn_nu = 2.4341E-3_wp
  REAL(KIND = wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS
  REAL(KIND = wp) :: EOS000, EOS100, EOS200, EOS300, EOS400, EOS500, EOS600
  REAL(KIND = wp) :: EOS010, EOS110, EOS210, EOS310, EOS410, EOS510
  REAL(KIND = wp) :: EOS020, EOS120, EOS220, EOS320, EOS420
  REAL(KIND = wp) :: EOS030, EOS130, EOS230, EOS330
  REAL(KIND = wp) :: EOS040, EOS140, EOS240
  REAL(KIND = wp) :: EOS050, EOS150
  REAL(KIND = wp) :: EOS060
  REAL(KIND = wp) :: EOS001, EOS101, EOS201, EOS301, EOS401
  REAL(KIND = wp) :: EOS011, EOS111, EOS211, EOS311
  REAL(KIND = wp) :: EOS021, EOS121, EOS221
  REAL(KIND = wp) :: EOS031, EOS131
  REAL(KIND = wp) :: EOS041
  REAL(KIND = wp) :: EOS002, EOS102, EOS202
  REAL(KIND = wp) :: EOS012, EOS112
  REAL(KIND = wp) :: EOS022
  REAL(KIND = wp) :: EOS003, EOS103
  REAL(KIND = wp) :: EOS013
  REAL(KIND = wp) :: ALP000, ALP100, ALP200, ALP300, ALP400, ALP500
  REAL(KIND = wp) :: ALP010, ALP110, ALP210, ALP310, ALP410
  REAL(KIND = wp) :: ALP020, ALP120, ALP220, ALP320
  REAL(KIND = wp) :: ALP030, ALP130, ALP230
  REAL(KIND = wp) :: ALP040, ALP140
  REAL(KIND = wp) :: ALP050
  REAL(KIND = wp) :: ALP001, ALP101, ALP201, ALP301
  REAL(KIND = wp) :: ALP011, ALP111, ALP211
  REAL(KIND = wp) :: ALP021, ALP121
  REAL(KIND = wp) :: ALP031
  REAL(KIND = wp) :: ALP002, ALP102
  REAL(KIND = wp) :: ALP012
  REAL(KIND = wp) :: ALP003
  REAL(KIND = wp) :: BET000, BET100, BET200, BET300, BET400, BET500
  REAL(KIND = wp) :: BET010, BET110, BET210, BET310, BET410
  REAL(KIND = wp) :: BET020, BET120, BET220, BET320
  REAL(KIND = wp) :: BET030, BET130, BET230
  REAL(KIND = wp) :: BET040, BET140
  REAL(KIND = wp) :: BET050
  REAL(KIND = wp) :: BET001, BET101, BET201, BET301
  REAL(KIND = wp) :: BET011, BET111, BET211
  REAL(KIND = wp) :: BET021, BET121
  REAL(KIND = wp) :: BET031
  REAL(KIND = wp) :: BET002, BET102
  REAL(KIND = wp) :: BET012
  REAL(KIND = wp) :: BET003
  REAL(KIND = wp) :: PEN000, PEN100, PEN200, PEN300, PEN400
  REAL(KIND = wp) :: PEN010, PEN110, PEN210, PEN310
  REAL(KIND = wp) :: PEN020, PEN120, PEN220
  REAL(KIND = wp) :: PEN030, PEN130
  REAL(KIND = wp) :: PEN040
  REAL(KIND = wp) :: PEN001, PEN101, PEN201
  REAL(KIND = wp) :: PEN011, PEN111
  REAL(KIND = wp) :: PEN021
  REAL(KIND = wp) :: PEN002, PEN102
  REAL(KIND = wp) :: PEN012
  REAL(KIND = wp) :: APE000, APE100, APE200, APE300
  REAL(KIND = wp) :: APE010, APE110, APE210
  REAL(KIND = wp) :: APE020, APE120
  REAL(KIND = wp) :: APE030
  REAL(KIND = wp) :: APE001, APE101
  REAL(KIND = wp) :: APE011
  REAL(KIND = wp) :: APE002
  REAL(KIND = wp) :: BPE000, BPE100, BPE200, BPE300
  REAL(KIND = wp) :: BPE010, BPE110, BPE210
  REAL(KIND = wp) :: BPE020, BPE120
  REAL(KIND = wp) :: BPE030
  REAL(KIND = wp) :: BPE001, BPE101
  REAL(KIND = wp) :: BPE011
  REAL(KIND = wp) :: BPE002
  CONTAINS
  SUBROUTINE eos_insitu(pts, prd, pdep)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: prd
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pdep
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zt, zh, zs, ztm
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    IF (ln_timing) CALL timing_start('eos-insitu')
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zh = pdep(ji, jj, jk) * r1_Z0
            zt = pts(ji, jj, jk, jp_tem) * r1_T0
            zs = SQRT(ABS(pts(ji, jj, jk, jp_sal) + rdeltaS) * r1_S0)
            ztm = tmask(ji, jj, jk)
            zn3 = EOS013 * zt + EOS103 * zs + EOS003
            zn2 = (EOS022 * zt + EOS112 * zs + EOS012) * zt + (EOS202 * zs + EOS102) * zs + EOS002
            zn1 = (((EOS041 * zt + EOS131 * zs + EOS031) * zt + (EOS221 * zs + EOS121) * zs + EOS021) * zt + ((EOS311 * zs + EOS211) * zs + EOS111) * zs + EOS011) * zt + (((EOS401 * zs + EOS301) * zs + EOS201) * zs + EOS101) * zs + EOS001
            zn0 = (((((EOS060 * zt + EOS150 * zs + EOS050) * zt + (EOS240 * zs + EOS140) * zs + EOS040) * zt + ((EOS330 * zs + EOS230) * zs + EOS130) * zs + EOS030) * zt + (((EOS420 * zs + EOS320) * zs + EOS220) * zs + EOS120) * zs + EOS020) * zt + ((((EOS510 * zs + EOS410) * zs + EOS310) * zs + EOS210) * zs + EOS110) * zs + EOS010) * zt + (((((EOS600 * zs + EOS500) * zs + EOS400) * zs + EOS300) * zs + EOS200) * zs + EOS100) * zs + EOS000
            zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
            prd(ji, jj, jk) = (zn * r1_rau0 - 1._wp) * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (np_seos)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zt = pts(ji, jj, jk, jp_tem) - 10._wp
            zs = pts(ji, jj, jk, jp_sal) - 35._wp
            zh = pdep(ji, jj, jk)
            ztm = tmask(ji, jj, jk)
            zn = - rn_a0 * (1._wp + 0.5_wp * rn_lambda1 * zt + rn_mu1 * zh) * zt + rn_b0 * (1._wp - 0.5_wp * rn_lambda2 * zs - rn_mu2 * zh) * zs - rn_nu * zt * zs
            prd(ji, jj, jk) = zn * r1_rau0 * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = prd, clinfo1 = ' eos-insitu  : ', kdim = jpk)
    IF (ln_timing) CALL timing_stop('eos-insitu')
  END SUBROUTINE eos_insitu
  SUBROUTINE eos_insitu_pot(pts, prd, prhop, pdep)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: prd
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: prhop
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pdep
    INTEGER :: ji, jj, jk, jsmp
    INTEGER :: jdof
    REAL(KIND = wp) :: zt, zh, zstemp, zs, ztm
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    REAL(KIND = wp), DIMENSION(:), ALLOCATABLE :: zn0_sto, zn_sto, zsign
    IF (ln_timing) CALL timing_start('eos-pot')
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      IF (ln_sto_eos) THEN
        ALLOCATE(zn0_sto(1 : 2 * nn_sto_eos))
        ALLOCATE(zn_sto(1 : 2 * nn_sto_eos))
        ALLOCATE(zsign(1 : 2 * nn_sto_eos))
        !$ACC KERNELS
        DO jsmp = 1, 2 * nn_sto_eos, 2
          zsign(jsmp) = 1._wp
          zsign(jsmp + 1) = - 1._wp
        END DO
        DO jk = 1, jpkm1
          DO jj = 1, jpj
            DO ji = 1, jpi
              DO jsmp = 1, nn_sto_eos * 2
                jdof = (jsmp + 1) / 2
                zh = pdep(ji, jj, jk) * r1_Z0
                zt = (pts(ji, jj, jk, jp_tem) + pts_ran(ji, jj, jk, jp_tem, jdof) * zsign(jsmp)) * r1_T0
                zstemp = pts(ji, jj, jk, jp_sal) + pts_ran(ji, jj, jk, jp_sal, jdof) * zsign(jsmp)
                zs = SQRT(ABS(zstemp + rdeltaS) * r1_S0)
                ztm = tmask(ji, jj, jk)
                zn3 = EOS013 * zt + EOS103 * zs + EOS003
                zn2 = (EOS022 * zt + EOS112 * zs + EOS012) * zt + (EOS202 * zs + EOS102) * zs + EOS002
                zn1 = (((EOS041 * zt + EOS131 * zs + EOS031) * zt + (EOS221 * zs + EOS121) * zs + EOS021) * zt + ((EOS311 * zs + EOS211) * zs + EOS111) * zs + EOS011) * zt + (((EOS401 * zs + EOS301) * zs + EOS201) * zs + EOS101) * zs + EOS001
                zn0_sto(jsmp) = (((((EOS060 * zt + EOS150 * zs + EOS050) * zt + (EOS240 * zs + EOS140) * zs + EOS040) * zt + ((EOS330 * zs + EOS230) * zs + EOS130) * zs + EOS030) * zt + (((EOS420 * zs + EOS320) * zs + EOS220) * zs + EOS120) * zs + EOS020) * zt + ((((EOS510 * zs + EOS410) * zs + EOS310) * zs + EOS210) * zs + EOS110) * zs + EOS010) * zt + (((((EOS600 * zs + EOS500) * zs + EOS400) * zs + EOS300) * zs + EOS200) * zs + EOS100) * zs + EOS000
                zn_sto(jsmp) = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0_sto(jsmp)
              END DO
              prhop(ji, jj, jk) = 0._wp
              prd(ji, jj, jk) = 0._wp
              DO jsmp = 1, nn_sto_eos * 2
                prhop(ji, jj, jk) = prhop(ji, jj, jk) + zn0_sto(jsmp)
                prd(ji, jj, jk) = prd(ji, jj, jk) + (zn_sto(jsmp) * r1_rau0 - 1._wp)
              END DO
              prhop(ji, jj, jk) = 0.5_wp * prhop(ji, jj, jk) * ztm / nn_sto_eos
              prd(ji, jj, jk) = 0.5_wp * prd(ji, jj, jk) * ztm / nn_sto_eos
            END DO
          END DO
        END DO
        !$ACC END KERNELS
        DEALLOCATE(zn0_sto, zn_sto, zsign)
      ELSE
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 1, jpj
            DO ji = 1, jpi
              zh = pdep(ji, jj, jk) * r1_Z0
              zt = pts(ji, jj, jk, jp_tem) * r1_T0
              zs = SQRT(ABS(pts(ji, jj, jk, jp_sal) + rdeltaS) * r1_S0)
              ztm = tmask(ji, jj, jk)
              zn3 = EOS013 * zt + EOS103 * zs + EOS003
              zn2 = (EOS022 * zt + EOS112 * zs + EOS012) * zt + (EOS202 * zs + EOS102) * zs + EOS002
              zn1 = (((EOS041 * zt + EOS131 * zs + EOS031) * zt + (EOS221 * zs + EOS121) * zs + EOS021) * zt + ((EOS311 * zs + EOS211) * zs + EOS111) * zs + EOS011) * zt + (((EOS401 * zs + EOS301) * zs + EOS201) * zs + EOS101) * zs + EOS001
              zn0 = (((((EOS060 * zt + EOS150 * zs + EOS050) * zt + (EOS240 * zs + EOS140) * zs + EOS040) * zt + ((EOS330 * zs + EOS230) * zs + EOS130) * zs + EOS030) * zt + (((EOS420 * zs + EOS320) * zs + EOS220) * zs + EOS120) * zs + EOS020) * zt + ((((EOS510 * zs + EOS410) * zs + EOS310) * zs + EOS210) * zs + EOS110) * zs + EOS010) * zt + (((((EOS600 * zs + EOS500) * zs + EOS400) * zs + EOS300) * zs + EOS200) * zs + EOS100) * zs + EOS000
              zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
              prhop(ji, jj, jk) = zn0 * ztm
              prd(ji, jj, jk) = (zn * r1_rau0 - 1._wp) * ztm
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END IF
    CASE (np_seos)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zt = pts(ji, jj, jk, jp_tem) - 10._wp
            zs = pts(ji, jj, jk, jp_sal) - 35._wp
            zh = pdep(ji, jj, jk)
            ztm = tmask(ji, jj, jk)
            zn = - rn_a0 * (1._wp + 0.5_wp * rn_lambda1 * zt) * zt + rn_b0 * (1._wp - 0.5_wp * rn_lambda2 * zs) * zs - rn_nu * zt * zs
            prhop(ji, jj, jk) = (rau0 + zn) * ztm
            zn = zn - (rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs) * zh
            prd(ji, jj, jk) = zn * r1_rau0 * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = prd, clinfo1 = ' eos-pot: ', tab3d_2 = prhop, clinfo2 = ' pot : ', kdim = jpk)
    IF (ln_timing) CALL timing_stop('eos-pot')
  END SUBROUTINE eos_insitu_pot
  SUBROUTINE eos_insitu_2d(pts, pdep, prd)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pdep
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(  OUT) :: prd
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zt, zh, zs
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    IF (ln_timing) CALL timing_start('eos2d')
    !$ACC KERNELS
    prd(:, :) = 0._wp
    !$ACC END KERNELS
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zh = pdep(ji, jj) * r1_Z0
          zt = pts(ji, jj, jp_tem) * r1_T0
          zs = SQRT(ABS(pts(ji, jj, jp_sal) + rdeltaS) * r1_S0)
          zn3 = EOS013 * zt + EOS103 * zs + EOS003
          zn2 = (EOS022 * zt + EOS112 * zs + EOS012) * zt + (EOS202 * zs + EOS102) * zs + EOS002
          zn1 = (((EOS041 * zt + EOS131 * zs + EOS031) * zt + (EOS221 * zs + EOS121) * zs + EOS021) * zt + ((EOS311 * zs + EOS211) * zs + EOS111) * zs + EOS011) * zt + (((EOS401 * zs + EOS301) * zs + EOS201) * zs + EOS101) * zs + EOS001
          zn0 = (((((EOS060 * zt + EOS150 * zs + EOS050) * zt + (EOS240 * zs + EOS140) * zs + EOS040) * zt + ((EOS330 * zs + EOS230) * zs + EOS130) * zs + EOS030) * zt + (((EOS420 * zs + EOS320) * zs + EOS220) * zs + EOS120) * zs + EOS020) * zt + ((((EOS510 * zs + EOS410) * zs + EOS310) * zs + EOS210) * zs + EOS110) * zs + EOS010) * zt + (((((EOS600 * zs + EOS500) * zs + EOS400) * zs + EOS300) * zs + EOS200) * zs + EOS100) * zs + EOS000
          zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
          prd(ji, jj) = zn * r1_rau0 - 1._wp
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(prd, 'T', 1.)
    CASE (np_seos)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zt = pts(ji, jj, jp_tem) - 10._wp
          zs = pts(ji, jj, jp_sal) - 35._wp
          zh = pdep(ji, jj)
          zn = - rn_a0 * (1._wp + 0.5_wp * rn_lambda1 * zt + rn_mu1 * zh) * zt + rn_b0 * (1._wp - 0.5_wp * rn_lambda2 * zs - rn_mu2 * zh) * zs - rn_nu * zt * zs
          prd(ji, jj) = zn * r1_rau0
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(prd, 'T', 1.)
    END SELECT
    IF (ln_ctl) CALL prt_ctl(tab2d_1 = prd, clinfo1 = ' eos2d: ')
    IF (ln_timing) CALL timing_stop('eos2d')
  END SUBROUTINE eos_insitu_2d
  SUBROUTINE rab_3d(pts, pab)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(  OUT) :: pab
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zt, zh, zs, ztm
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    IF (ln_timing) CALL timing_start('rab_3d')
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zh = gdept_n(ji, jj, jk) * r1_Z0
            zt = pts(ji, jj, jk, jp_tem) * r1_T0
            zs = SQRT(ABS(pts(ji, jj, jk, jp_sal) + rdeltaS) * r1_S0)
            ztm = tmask(ji, jj, jk)
            zn3 = ALP003
            zn2 = ALP012 * zt + ALP102 * zs + ALP002
            zn1 = ((ALP031 * zt + ALP121 * zs + ALP021) * zt + (ALP211 * zs + ALP111) * zs + ALP011) * zt + ((ALP301 * zs + ALP201) * zs + ALP101) * zs + ALP001
            zn0 = ((((ALP050 * zt + ALP140 * zs + ALP040) * zt + (ALP230 * zs + ALP130) * zs + ALP030) * zt + ((ALP320 * zs + ALP220) * zs + ALP120) * zs + ALP020) * zt + (((ALP410 * zs + ALP310) * zs + ALP210) * zs + ALP110) * zs + ALP010) * zt + ((((ALP500 * zs + ALP400) * zs + ALP300) * zs + ALP200) * zs + ALP100) * zs + ALP000
            zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
            pab(ji, jj, jk, jp_tem) = zn * r1_rau0 * ztm
            zn3 = BET003
            zn2 = BET012 * zt + BET102 * zs + BET002
            zn1 = ((BET031 * zt + BET121 * zs + BET021) * zt + (BET211 * zs + BET111) * zs + BET011) * zt + ((BET301 * zs + BET201) * zs + BET101) * zs + BET001
            zn0 = ((((BET050 * zt + BET140 * zs + BET040) * zt + (BET230 * zs + BET130) * zs + BET030) * zt + ((BET320 * zs + BET220) * zs + BET120) * zs + BET020) * zt + (((BET410 * zs + BET310) * zs + BET210) * zs + BET110) * zs + BET010) * zt + ((((BET500 * zs + BET400) * zs + BET300) * zs + BET200) * zs + BET100) * zs + BET000
            zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
            pab(ji, jj, jk, jp_sal) = zn / zs * r1_rau0 * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (np_seos)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zt = pts(ji, jj, jk, jp_tem) - 10._wp
            zs = pts(ji, jj, jk, jp_sal) - 35._wp
            zh = gdept_n(ji, jj, jk)
            ztm = tmask(ji, jj, jk)
            zn = rn_a0 * (1._wp + rn_lambda1 * zt + rn_mu1 * zh) + rn_nu * zs
            pab(ji, jj, jk, jp_tem) = zn * r1_rau0 * ztm
            zn = rn_b0 * (1._wp - rn_lambda2 * zs - rn_mu2 * zh) - rn_nu * zt
            pab(ji, jj, jk, jp_sal) = zn * r1_rau0 * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = pab(:, :, :, jp_tem), clinfo1 = ' rab_3d_t: ', tab3d_2 = pab(:, :, :, jp_sal), clinfo2 = ' rab_3d_s : ', kdim = jpk)
    IF (ln_timing) CALL timing_stop('rab_3d')
  END SUBROUTINE rab_3d
  SUBROUTINE rab_2d(pts, pdep, pab)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pdep
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpts), INTENT(  OUT) :: pab
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zt, zh, zs
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    IF (ln_timing) CALL timing_start('rab_2d')
    !$ACC KERNELS
    pab(:, :, :) = 0._wp
    !$ACC END KERNELS
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zh = pdep(ji, jj) * r1_Z0
          zt = pts(ji, jj, jp_tem) * r1_T0
          zs = SQRT(ABS(pts(ji, jj, jp_sal) + rdeltaS) * r1_S0)
          zn3 = ALP003
          zn2 = ALP012 * zt + ALP102 * zs + ALP002
          zn1 = ((ALP031 * zt + ALP121 * zs + ALP021) * zt + (ALP211 * zs + ALP111) * zs + ALP011) * zt + ((ALP301 * zs + ALP201) * zs + ALP101) * zs + ALP001
          zn0 = ((((ALP050 * zt + ALP140 * zs + ALP040) * zt + (ALP230 * zs + ALP130) * zs + ALP030) * zt + ((ALP320 * zs + ALP220) * zs + ALP120) * zs + ALP020) * zt + (((ALP410 * zs + ALP310) * zs + ALP210) * zs + ALP110) * zs + ALP010) * zt + ((((ALP500 * zs + ALP400) * zs + ALP300) * zs + ALP200) * zs + ALP100) * zs + ALP000
          zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
          pab(ji, jj, jp_tem) = zn * r1_rau0
          zn3 = BET003
          zn2 = BET012 * zt + BET102 * zs + BET002
          zn1 = ((BET031 * zt + BET121 * zs + BET021) * zt + (BET211 * zs + BET111) * zs + BET011) * zt + ((BET301 * zs + BET201) * zs + BET101) * zs + BET001
          zn0 = ((((BET050 * zt + BET140 * zs + BET040) * zt + (BET230 * zs + BET130) * zs + BET030) * zt + ((BET320 * zs + BET220) * zs + BET120) * zs + BET020) * zt + (((BET410 * zs + BET310) * zs + BET210) * zs + BET110) * zs + BET010) * zt + ((((BET500 * zs + BET400) * zs + BET300) * zs + BET200) * zs + BET100) * zs + BET000
          zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
          pab(ji, jj, jp_sal) = zn / zs * r1_rau0
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(pab(:, :, jp_tem), 'T', 1., pab(:, :, jp_sal), 'T', 1.)
    CASE (np_seos)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zt = pts(ji, jj, jp_tem) - 10._wp
          zs = pts(ji, jj, jp_sal) - 35._wp
          zh = pdep(ji, jj)
          zn = rn_a0 * (1._wp + rn_lambda1 * zt + rn_mu1 * zh) + rn_nu * zs
          pab(ji, jj, jp_tem) = zn * r1_rau0
          zn = rn_b0 * (1._wp - rn_lambda2 * zs - rn_mu2 * zh) - rn_nu * zt
          pab(ji, jj, jp_sal) = zn * r1_rau0
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(pab(:, :, jp_tem), 'T', 1., pab(:, :, jp_sal), 'T', 1.)
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
    IF (ln_ctl) CALL prt_ctl(tab2d_1 = pab(:, :, jp_tem), clinfo1 = ' rab_2d_t: ', tab2d_2 = pab(:, :, jp_sal), clinfo2 = ' rab_2d_s : ')
    IF (ln_timing) CALL timing_stop('rab_2d')
  END SUBROUTINE rab_2d
  SUBROUTINE rab_0d(pts, pdep, pab)
    REAL(KIND = wp), DIMENSION(jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), INTENT(IN   ) :: pdep
    REAL(KIND = wp), DIMENSION(jpts), INTENT(  OUT) :: pab
    REAL(KIND = wp) :: zt, zh, zs
    REAL(KIND = wp) :: zn, zn0, zn1, zn2, zn3
    IF (ln_timing) CALL timing_start('rab_0d')
    pab(:) = 0._wp
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      zh = pdep * r1_Z0
      zt = pts(jp_tem) * r1_T0
      zs = SQRT(ABS(pts(jp_sal) + rdeltaS) * r1_S0)
      zn3 = ALP003
      zn2 = ALP012 * zt + ALP102 * zs + ALP002
      zn1 = ((ALP031 * zt + ALP121 * zs + ALP021) * zt + (ALP211 * zs + ALP111) * zs + ALP011) * zt + ((ALP301 * zs + ALP201) * zs + ALP101) * zs + ALP001
      zn0 = ((((ALP050 * zt + ALP140 * zs + ALP040) * zt + (ALP230 * zs + ALP130) * zs + ALP030) * zt + ((ALP320 * zs + ALP220) * zs + ALP120) * zs + ALP020) * zt + (((ALP410 * zs + ALP310) * zs + ALP210) * zs + ALP110) * zs + ALP010) * zt + ((((ALP500 * zs + ALP400) * zs + ALP300) * zs + ALP200) * zs + ALP100) * zs + ALP000
      zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
      pab(jp_tem) = zn * r1_rau0
      zn3 = BET003
      zn2 = BET012 * zt + BET102 * zs + BET002
      zn1 = ((BET031 * zt + BET121 * zs + BET021) * zt + (BET211 * zs + BET111) * zs + BET011) * zt + ((BET301 * zs + BET201) * zs + BET101) * zs + BET001
      zn0 = ((((BET050 * zt + BET140 * zs + BET040) * zt + (BET230 * zs + BET130) * zs + BET030) * zt + ((BET320 * zs + BET220) * zs + BET120) * zs + BET020) * zt + (((BET410 * zs + BET310) * zs + BET210) * zs + BET110) * zs + BET010) * zt + ((((BET500 * zs + BET400) * zs + BET300) * zs + BET200) * zs + BET100) * zs + BET000
      zn = ((zn3 * zh + zn2) * zh + zn1) * zh + zn0
      pab(jp_sal) = zn / zs * r1_rau0
    CASE (np_seos)
      zt = pts(jp_tem) - 10._wp
      zs = pts(jp_sal) - 35._wp
      zh = pdep
      zn = rn_a0 * (1._wp + rn_lambda1 * zt + rn_mu1 * zh) + rn_nu * zs
      pab(jp_tem) = zn * r1_rau0
      zn = rn_b0 * (1._wp - rn_lambda2 * zs - rn_mu2 * zh) - rn_nu * zt
      pab(jp_sal) = zn * r1_rau0
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
    IF (ln_timing) CALL timing_stop('rab_0d')
  END SUBROUTINE rab_0d
  SUBROUTINE bn2(pts, pab, pn2)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pab
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: pn2
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zaw, zbw, zrw
    IF (ln_timing) CALL timing_start('bn2')
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zrw = (gdepw_n(ji, jj, jk) - gdept_n(ji, jj, jk)) / (gdept_n(ji, jj, jk - 1) - gdept_n(ji, jj, jk))
          zaw = pab(ji, jj, jk, jp_tem) * (1. - zrw) + pab(ji, jj, jk - 1, jp_tem) * zrw
          zbw = pab(ji, jj, jk, jp_sal) * (1. - zrw) + pab(ji, jj, jk - 1, jp_sal) * zrw
          pn2(ji, jj, jk) = grav * (zaw * (pts(ji, jj, jk - 1, jp_tem) - pts(ji, jj, jk, jp_tem)) - zbw * (pts(ji, jj, jk - 1, jp_sal) - pts(ji, jj, jk, jp_sal))) / e3w_n(ji, jj, jk) * wmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = pn2, clinfo1 = ' bn2  : ', kdim = jpk)
    IF (ln_timing) CALL timing_stop('bn2')
  END SUBROUTINE bn2
  FUNCTION eos_pt_from_ct(ctmp, psal) RESULT(ptmp)
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: ctmp
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: psal
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: ptmp
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zt, zs, ztm
    REAL(KIND = wp) :: zn, zd
    REAL(KIND = wp) :: zdeltaS, z1_S0, z1_T0
    IF (ln_timing) CALL timing_start('eos_pt_from_ct')
    !$ACC KERNELS
    zdeltaS = 5._wp
    z1_S0 = 0.875_wp / 35.16504_wp
    z1_T0 = 1._wp / 40._wp
    DO jj = 1, jpj
      DO ji = 1, jpi
        zt = ctmp(ji, jj) * z1_T0
        zs = SQRT(ABS(psal(ji, jj) + zdeltaS) * r1_S0)
        ztm = tmask(ji, jj, 1)
        zn = ((((- 2.1385727895E-01_wp * zt - 2.7674419971E-01_wp * zs + 1.0728094330_wp) * zt + (2.6366564313_wp * zs + 3.3546960647_wp) * zs - 7.8012209473_wp) * zt + ((1.8835586562_wp * zs + 7.3949191679_wp) * zs - 3.3937395875_wp) * zs - 5.6414948432_wp) * zt + (((3.5737370589_wp * zs - 1.5512427389E+01_wp) * zs + 2.4625741105E+01_wp) * zs + 1.9912291000E+01_wp) * zs - 3.2191146312E+01_wp) * zt + ((((5.7153204649E-01_wp * zs - 3.0943149543_wp) * zs + 9.3052495181_wp) * zs - 9.4528934807_wp) * zs + 3.1066408996_wp) * zs - 4.3504021262E-01_wp
        zd = (2.0035003456_wp * zt - 3.4570358592E-01_wp * zs + 5.6471810638_wp) * zt + (1.5393993508_wp * zs - 6.9394762624_wp) * zs + 1.2750522650E+01_wp
        ptmp(ji, jj) = (zt / z1_T0 + zn / zd) * ztm
      END DO
    END DO
    !$ACC END KERNELS
    IF (ln_timing) CALL timing_stop('eos_pt_from_ct')
  END FUNCTION eos_pt_from_ct
  SUBROUTINE eos_fzp_2d(psal, ptf, pdep)
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: psal
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ), OPTIONAL :: pdep
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(OUT  ) :: ptf
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zt, zs, z1_S0
    SELECT CASE (neos)
    CASE (np_teos10, np_seos)
      !$ACC KERNELS
      z1_S0 = 1._wp / 35.16504_wp
      DO jj = 1, jpj
        DO ji = 1, jpi
          zs = SQRT(ABS(psal(ji, jj)) * z1_S0)
          ptf(ji, jj) = ((((1.46873E-03_wp * zs - 9.64972E-03_wp) * zs + 2.28348E-02_wp) * zs - 3.12775E-02_wp) * zs + 2.07679E-02_wp) * zs - 5.87701E-02_wp
        END DO
      END DO
      ptf(:, :) = ptf(:, :) * psal(:, :)
      !$ACC END KERNELS
      IF (PRESENT(pdep)) ptf(:, :) = ptf(:, :) - 7.53E-4 * pdep(:, :)
    CASE (np_eos80)
      !$ACC KERNELS
      ptf(:, :) = (- 0.0575_wp + 1.710523E-3_wp * SQRT(psal(:, :)) - 2.154996E-4_wp * psal(:, :)) * psal(:, :)
      !$ACC END KERNELS
      IF (PRESENT(pdep)) ptf(:, :) = ptf(:, :) - 7.53E-4 * pdep(:, :)
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
  END SUBROUTINE eos_fzp_2d
  SUBROUTINE eos_fzp_0d(psal, ptf, pdep)
    REAL(KIND = wp), INTENT(IN ) :: psal
    REAL(KIND = wp), INTENT(IN ), OPTIONAL :: pdep
    REAL(KIND = wp), INTENT(OUT) :: ptf
    REAL(KIND = wp) :: zs
    SELECT CASE (neos)
    CASE (np_teos10, np_seos)
      zs = SQRT(ABS(psal) / 35.16504_wp)
      ptf = ((((1.46873E-03_wp * zs - 9.64972E-03_wp) * zs + 2.28348E-02_wp) * zs - 3.12775E-02_wp) * zs + 2.07679E-02_wp) * zs - 5.87701E-02_wp
      ptf = ptf * psal
      IF (PRESENT(pdep)) ptf = ptf - 7.53E-4 * pdep
    CASE (np_eos80)
      ptf = (- 0.0575_wp + 1.710523E-3_wp * SQRT(psal) - 2.154996E-4_wp * psal) * psal
      IF (PRESENT(pdep)) ptf = ptf - 7.53E-4 * pdep
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
  END SUBROUTINE eos_fzp_0d
  SUBROUTINE eos_pen(pts, pab_pe, ppen)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(IN   ) :: pts
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, jpts), INTENT(  OUT) :: pab_pe
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(  OUT) :: ppen
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zt, zh, zs, ztm
    REAL(KIND = wp) :: zn, zn0, zn1, zn2
    IF (ln_timing) CALL timing_start('eos_pen')
    SELECT CASE (neos)
    CASE (np_teos10, np_eos80)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zh = gdept_n(ji, jj, jk) * r1_Z0
            zt = pts(ji, jj, jk, jp_tem) * r1_T0
            zs = SQRT(ABS(pts(ji, jj, jk, jp_sal) + rdeltaS) * r1_S0)
            ztm = tmask(ji, jj, jk)
            zn2 = (PEN012) * zt + PEN102 * zs + PEN002
            zn1 = ((PEN021) * zt + PEN111 * zs + PEN011) * zt + (PEN201 * zs + PEN101) * zs + PEN001
            zn0 = ((((PEN040) * zt + PEN130 * zs + PEN030) * zt + (PEN220 * zs + PEN120) * zs + PEN020) * zt + ((PEN310 * zs + PEN210) * zs + PEN110) * zs + PEN010) * zt + (((PEN400 * zs + PEN300) * zs + PEN200) * zs + PEN100) * zs + PEN000
            zn = (zn2 * zh + zn1) * zh + zn0
            ppen(ji, jj, jk) = zn * zh * r1_rau0 * ztm
            zn2 = APE002
            zn1 = (APE011) * zt + APE101 * zs + APE001
            zn0 = (((APE030) * zt + APE120 * zs + APE020) * zt + (APE210 * zs + APE110) * zs + APE010) * zt + ((APE300 * zs + APE200) * zs + APE100) * zs + APE000
            zn = (zn2 * zh + zn1) * zh + zn0
            pab_pe(ji, jj, jk, jp_tem) = zn * zh * r1_rau0 * ztm
            zn2 = BPE002
            zn1 = (BPE011) * zt + BPE101 * zs + BPE001
            zn0 = (((BPE030) * zt + BPE120 * zs + BPE020) * zt + (BPE210 * zs + BPE110) * zs + BPE010) * zt + ((BPE300 * zs + BPE200) * zs + BPE100) * zs + BPE000
            zn = (zn2 * zh + zn1) * zh + zn0
            pab_pe(ji, jj, jk, jp_sal) = zn / zs * zh * r1_rau0 * ztm
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (np_seos)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zt = pts(ji, jj, jk, jp_tem) - 10._wp
            zs = pts(ji, jj, jk, jp_sal) - 35._wp
            zh = gdept_n(ji, jj, jk)
            ztm = tmask(ji, jj, jk)
            zn = 0.5_wp * zh * r1_rau0 * ztm
            ppen(ji, jj, jk) = (rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs) * zn
            pab_pe(ji, jj, jk, jp_tem) = - rn_a0 * rn_mu1 * zn
            pab_pe(ji, jj, jk, jp_sal) = rn_b0 * rn_mu2 * zn
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE DEFAULT
      IF (lwp) WRITE(numout, cform_err)
      IF (lwp) WRITE(numout, FMT = *) '          bad flag value for neos = ', neos
      nstop = nstop + 1
    END SELECT
    IF (ln_timing) CALL timing_stop('eos_pen')
  END SUBROUTINE eos_pen
  SUBROUTINE eos_init
    INTEGER :: ios
    INTEGER :: ioptio
    NAMELIST /nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, rn_a0, rn_b0, rn_lambda1, rn_mu1, rn_lambda2, rn_mu2, rn_nu
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, nameos, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'nameos in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, nameos, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'nameos in configuration namelist', lwp)
    IF (lwm) WRITE(numond, nameos)
    rau0 = 1026._wp
    rcp = 3991.86795711963_wp
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'eos_init : equation of state'
      WRITE(numout, FMT = *) '~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist nameos : Chosen the Equation Of Seawater (EOS)'
      WRITE(numout, FMT = *) '      TEOS-10 : rho=F(Conservative Temperature, Absolute  Salinity, depth)   ln_TEOS10 = ', ln_TEOS10
      WRITE(numout, FMT = *) '      EOS-80  : rho=F(Potential    Temperature, Practical Salinity, depth)   ln_EOS80  = ', ln_EOS80
      WRITE(numout, FMT = *) '      S-EOS   : rho=F(Conservative Temperature, Absolute  Salinity, depth)   ln_SEOS   = ', ln_SEOS
    END IF
    ioptio = 0
    IF (ln_teos10) THEN
      ioptio = ioptio + 1
      neos = np_teos10
    END IF
    IF (ln_eos80) THEN
      ioptio = ioptio + 1
      neos = np_eos80
    END IF
    IF (ln_seos) THEN
      ioptio = ioptio + 1
      neos = np_seos
    END IF
    IF (ioptio /= 1) CALL ctl_stop("Exactly one equation of state option must be selected")
    SELECT CASE (neos)
    CASE (np_teos10)
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   use of TEOS-10 equation of state (cons. temp. and abs. salinity)'
      l_useCT = .TRUE.
      rdeltaS = 32._wp
      r1_S0 = 0.875_wp / 35.16504_wp
      r1_T0 = 1._wp / 40._wp
      r1_Z0 = 1.E-4_wp
      EOS000 = 8.0189615746E+02_wp
      EOS100 = 8.6672408165E+02_wp
      EOS200 = - 1.7864682637E+03_wp
      EOS300 = 2.0375295546E+03_wp
      EOS400 = - 1.2849161071E+03_wp
      EOS500 = 4.3227585684E+02_wp
      EOS600 = - 6.0579916612E+01_wp
      EOS010 = 2.6010145068E+01_wp
      EOS110 = - 6.5281885265E+01_wp
      EOS210 = 8.1770425108E+01_wp
      EOS310 = - 5.6888046321E+01_wp
      EOS410 = 1.7681814114E+01_wp
      EOS510 = - 1.9193502195_wp
      EOS020 = - 3.7074170417E+01_wp
      EOS120 = 6.1548258127E+01_wp
      EOS220 = - 6.0362551501E+01_wp
      EOS320 = 2.9130021253E+01_wp
      EOS420 = - 5.4723692739_wp
      EOS030 = 2.1661789529E+01_wp
      EOS130 = - 3.3449108469E+01_wp
      EOS230 = 1.9717078466E+01_wp
      EOS330 = - 3.1742946532_wp
      EOS040 = - 8.3627885467_wp
      EOS140 = 1.1311538584E+01_wp
      EOS240 = - 5.3563304045_wp
      EOS050 = 5.4048723791E-01_wp
      EOS150 = 4.8169980163E-01_wp
      EOS060 = - 1.9083568888E-01_wp
      EOS001 = 1.9681925209E+01_wp
      EOS101 = - 4.2549998214E+01_wp
      EOS201 = 5.0774768218E+01_wp
      EOS301 = - 3.0938076334E+01_wp
      EOS401 = 6.6051753097_wp
      EOS011 = - 1.3336301113E+01_wp
      EOS111 = - 4.4870114575_wp
      EOS211 = 5.0042598061_wp
      EOS311 = - 6.5399043664E-01_wp
      EOS021 = 6.7080479603_wp
      EOS121 = 3.5063081279_wp
      EOS221 = - 1.8795372996_wp
      EOS031 = - 2.4649669534_wp
      EOS131 = - 5.5077101279E-01_wp
      EOS041 = 5.5927935970E-01_wp
      EOS002 = 2.0660924175_wp
      EOS102 = - 4.9527603989_wp
      EOS202 = 2.5019633244_wp
      EOS012 = 2.0564311499_wp
      EOS112 = - 2.1311365518E-01_wp
      EOS022 = - 1.2419983026_wp
      EOS003 = - 2.3342758797E-02_wp
      EOS103 = - 1.8507636718E-02_wp
      EOS013 = 3.7969820455E-01_wp
      ALP000 = - 6.5025362670E-01_wp
      ALP100 = 1.6320471316_wp
      ALP200 = - 2.0442606277_wp
      ALP300 = 1.4222011580_wp
      ALP400 = - 4.4204535284E-01_wp
      ALP500 = 4.7983755487E-02_wp
      ALP010 = 1.8537085209_wp
      ALP110 = - 3.0774129064_wp
      ALP210 = 3.0181275751_wp
      ALP310 = - 1.4565010626_wp
      ALP410 = 2.7361846370E-01_wp
      ALP020 = - 1.6246342147_wp
      ALP120 = 2.5086831352_wp
      ALP220 = - 1.4787808849_wp
      ALP320 = 2.3807209899E-01_wp
      ALP030 = 8.3627885467E-01_wp
      ALP130 = - 1.1311538584_wp
      ALP230 = 5.3563304045E-01_wp
      ALP040 = - 6.7560904739E-02_wp
      ALP140 = - 6.0212475204E-02_wp
      ALP050 = 2.8625353333E-02_wp
      ALP001 = 3.3340752782E-01_wp
      ALP101 = 1.1217528644E-01_wp
      ALP201 = - 1.2510649515E-01_wp
      ALP301 = 1.6349760916E-02_wp
      ALP011 = - 3.3540239802E-01_wp
      ALP111 = - 1.7531540640E-01_wp
      ALP211 = 9.3976864981E-02_wp
      ALP021 = 1.8487252150E-01_wp
      ALP121 = 4.1307825959E-02_wp
      ALP031 = - 5.5927935970E-02_wp
      ALP002 = - 5.1410778748E-02_wp
      ALP102 = 5.3278413794E-03_wp
      ALP012 = 6.2099915132E-02_wp
      ALP003 = - 9.4924551138E-03_wp
      BET000 = 1.0783203594E+01_wp
      BET100 = - 4.4452095908E+01_wp
      BET200 = 7.6048755820E+01_wp
      BET300 = - 6.3944280668E+01_wp
      BET400 = 2.6890441098E+01_wp
      BET500 = - 4.5221697773_wp
      BET010 = - 8.1219372432E-01_wp
      BET110 = 2.0346663041_wp
      BET210 = - 2.1232895170_wp
      BET310 = 8.7994140485E-01_wp
      BET410 = - 1.1939638360E-01_wp
      BET020 = 7.6574242289E-01_wp
      BET120 = - 1.5019813020_wp
      BET220 = 1.0872489522_wp
      BET320 = - 2.7233429080E-01_wp
      BET030 = - 4.1615152308E-01_wp
      BET130 = 4.9061350869E-01_wp
      BET230 = - 1.1847737788E-01_wp
      BET040 = 1.4073062708E-01_wp
      BET140 = - 1.3327978879E-01_wp
      BET050 = 5.9929880134E-03_wp
      BET001 = - 5.2937873009E-01_wp
      BET101 = 1.2634116779_wp
      BET201 = - 1.1547328025_wp
      BET301 = 3.2870876279E-01_wp
      BET011 = - 5.5824407214E-02_wp
      BET111 = 1.2451933313E-01_wp
      BET211 = - 2.4409539932E-02_wp
      BET021 = 4.3623149752E-02_wp
      BET121 = - 4.6767901790E-02_wp
      BET031 = - 6.8523260060E-03_wp
      BET002 = - 6.1618945251E-02_wp
      BET102 = 6.2255521644E-02_wp
      BET012 = - 2.6514181169E-03_wp
      BET003 = - 2.3025968587E-04_wp
      PEN000 = - 9.8409626043_wp
      PEN100 = 2.1274999107E+01_wp
      PEN200 = - 2.5387384109E+01_wp
      PEN300 = 1.5469038167E+01_wp
      PEN400 = - 3.3025876549_wp
      PEN010 = 6.6681505563_wp
      PEN110 = 2.2435057288_wp
      PEN210 = - 2.5021299030_wp
      PEN310 = 3.2699521832E-01_wp
      PEN020 = - 3.3540239802_wp
      PEN120 = - 1.7531540640_wp
      PEN220 = 9.3976864981E-01_wp
      PEN030 = 1.2324834767_wp
      PEN130 = 2.7538550639E-01_wp
      PEN040 = - 2.7963967985E-01_wp
      PEN001 = - 1.3773949450_wp
      PEN101 = 3.3018402659_wp
      PEN201 = - 1.6679755496_wp
      PEN011 = - 1.3709540999_wp
      PEN111 = 1.4207577012E-01_wp
      PEN021 = 8.2799886843E-01_wp
      PEN002 = 1.7507069098E-02_wp
      PEN102 = 1.3880727538E-02_wp
      PEN012 = - 2.8477365341E-01_wp
      APE000 = - 1.6670376391E-01_wp
      APE100 = - 5.6087643219E-02_wp
      APE200 = 6.2553247576E-02_wp
      APE300 = - 8.1748804580E-03_wp
      APE010 = 1.6770119901E-01_wp
      APE110 = 8.7657703198E-02_wp
      APE210 = - 4.6988432490E-02_wp
      APE020 = - 9.2436260751E-02_wp
      APE120 = - 2.0653912979E-02_wp
      APE030 = 2.7963967985E-02_wp
      APE001 = 3.4273852498E-02_wp
      APE101 = - 3.5518942529E-03_wp
      APE011 = - 4.1399943421E-02_wp
      APE002 = 7.1193413354E-03_wp
      BPE000 = 2.6468936504E-01_wp
      BPE100 = - 6.3170583896E-01_wp
      BPE200 = 5.7736640125E-01_wp
      BPE300 = - 1.6435438140E-01_wp
      BPE010 = 2.7912203607E-02_wp
      BPE110 = - 6.2259666565E-02_wp
      BPE210 = 1.2204769966E-02_wp
      BPE020 = - 2.1811574876E-02_wp
      BPE120 = 2.3383950895E-02_wp
      BPE030 = 3.4261630030E-03_wp
      BPE001 = 4.1079296834E-02_wp
      BPE101 = - 4.1503681096E-02_wp
      BPE011 = 1.7676120780E-03_wp
      BPE002 = 1.7269476440E-04_wp
    CASE (np_eos80)
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   use of EOS-80 equation of state (pot. temp. and pract. salinity)'
      l_useCT = .FALSE.
      rdeltaS = 20._wp
      r1_S0 = 1._wp / 40._wp
      r1_T0 = 1._wp / 40._wp
      r1_Z0 = 1.E-4_wp
      EOS000 = 9.5356891948E+02_wp
      EOS100 = 1.7136499189E+02_wp
      EOS200 = - 3.7501039454E+02_wp
      EOS300 = 5.1856810420E+02_wp
      EOS400 = - 3.7264470465E+02_wp
      EOS500 = 1.4302533998E+02_wp
      EOS600 = - 2.2856621162E+01_wp
      EOS010 = 1.0087518651E+01_wp
      EOS110 = - 1.3647741861E+01_wp
      EOS210 = 8.8478359933_wp
      EOS310 = - 7.2329388377_wp
      EOS410 = 1.4774410611_wp
      EOS510 = 2.0036720553E-01_wp
      EOS020 = - 2.5579830599E+01_wp
      EOS120 = 2.4043512327E+01_wp
      EOS220 = - 1.6807503990E+01_wp
      EOS320 = 8.3811577084_wp
      EOS420 = - 1.9771060192_wp
      EOS030 = 1.6846451198E+01_wp
      EOS130 = - 2.1482926901E+01_wp
      EOS230 = 1.0108954054E+01_wp
      EOS330 = - 6.2675951440E-01_wp
      EOS040 = - 8.0812310102_wp
      EOS140 = 1.0102374985E+01_wp
      EOS240 = - 4.8340368631_wp
      EOS050 = 1.2079167803_wp
      EOS150 = 1.1515380987E-01_wp
      EOS060 = - 2.4520288837E-01_wp
      EOS001 = 1.0748601068E+01_wp
      EOS101 = - 1.7817043500E+01_wp
      EOS201 = 2.2181366768E+01_wp
      EOS301 = - 1.6750916338E+01_wp
      EOS401 = 4.1202230403_wp
      EOS011 = - 1.5852644587E+01_wp
      EOS111 = - 7.6639383522E-01_wp
      EOS211 = 4.1144627302_wp
      EOS311 = - 6.6955877448E-01_wp
      EOS021 = 9.9994861860_wp
      EOS121 = - 1.9467067787E-01_wp
      EOS221 = - 1.2177554330_wp
      EOS031 = - 3.4866102017_wp
      EOS131 = 2.2229155620E-01_wp
      EOS041 = 5.9503008642E-01_wp
      EOS002 = 1.0375676547_wp
      EOS102 = - 3.4249470629_wp
      EOS202 = 2.0542026429_wp
      EOS012 = 2.1836324814_wp
      EOS112 = - 3.4453674320E-01_wp
      EOS022 = - 1.2548163097_wp
      EOS003 = 1.8729078427E-02_wp
      EOS103 = - 5.7238495240E-02_wp
      EOS013 = 3.8306136687E-01_wp
      ALP000 = - 2.5218796628E-01_wp
      ALP100 = 3.4119354654E-01_wp
      ALP200 = - 2.2119589983E-01_wp
      ALP300 = 1.8082347094E-01_wp
      ALP400 = - 3.6936026529E-02_wp
      ALP500 = - 5.0091801383E-03_wp
      ALP010 = 1.2789915300_wp
      ALP110 = - 1.2021756164_wp
      ALP210 = 8.4037519952E-01_wp
      ALP310 = - 4.1905788542E-01_wp
      ALP410 = 9.8855300959E-02_wp
      ALP020 = - 1.2634838399_wp
      ALP120 = 1.6112195176_wp
      ALP220 = - 7.5817155402E-01_wp
      ALP320 = 4.7006963580E-02_wp
      ALP030 = 8.0812310102E-01_wp
      ALP130 = - 1.0102374985_wp
      ALP230 = 4.8340368631E-01_wp
      ALP040 = - 1.5098959754E-01_wp
      ALP140 = - 1.4394226233E-02_wp
      ALP050 = 3.6780433255E-02_wp
      ALP001 = 3.9631611467E-01_wp
      ALP101 = 1.9159845880E-02_wp
      ALP201 = - 1.0286156825E-01_wp
      ALP301 = 1.6738969362E-02_wp
      ALP011 = - 4.9997430930E-01_wp
      ALP111 = 9.7335338937E-03_wp
      ALP211 = 6.0887771651E-02_wp
      ALP021 = 2.6149576513E-01_wp
      ALP121 = - 1.6671866715E-02_wp
      ALP031 = - 5.9503008642E-02_wp
      ALP002 = - 5.4590812035E-02_wp
      ALP102 = 8.6134185799E-03_wp
      ALP012 = 6.2740815484E-02_wp
      ALP003 = - 9.5765341718E-03_wp
      BET000 = 2.1420623987_wp
      BET100 = - 9.3752598635_wp
      BET200 = 1.9446303907E+01_wp
      BET300 = - 1.8632235232E+01_wp
      BET400 = 8.9390837485_wp
      BET500 = - 1.7142465871_wp
      BET010 = - 1.7059677327E-01_wp
      BET110 = 2.2119589983E-01_wp
      BET210 = - 2.7123520642E-01_wp
      BET310 = 7.3872053057E-02_wp
      BET410 = 1.2522950346E-02_wp
      BET020 = 3.0054390409E-01_wp
      BET120 = - 4.2018759976E-01_wp
      BET220 = 3.1429341406E-01_wp
      BET320 = - 9.8855300959E-02_wp
      BET030 = - 2.6853658626E-01_wp
      BET130 = 2.5272385134E-01_wp
      BET230 = - 2.3503481790E-02_wp
      BET040 = 1.2627968731E-01_wp
      BET140 = - 1.2085092158E-01_wp
      BET050 = 1.4394226233E-03_wp
      BET001 = - 2.2271304375E-01_wp
      BET101 = 5.5453416919E-01_wp
      BET201 = - 6.2815936268E-01_wp
      BET301 = 2.0601115202E-01_wp
      BET011 = - 9.5799229402E-03_wp
      BET111 = 1.0286156825E-01_wp
      BET211 = - 2.5108454043E-02_wp
      BET021 = - 2.4333834734E-03_wp
      BET121 = - 3.0443885826E-02_wp
      BET031 = 2.7786444526E-03_wp
      BET002 = - 4.2811838287E-02_wp
      BET102 = 5.1355066072E-02_wp
      BET012 = - 4.3067092900E-03_wp
      BET003 = - 7.1548119050E-04_wp
      PEN000 = - 5.3743005340_wp
      PEN100 = 8.9085217499_wp
      PEN200 = - 1.1090683384E+01_wp
      PEN300 = 8.3754581690_wp
      PEN400 = - 2.0601115202_wp
      PEN010 = 7.9263222935_wp
      PEN110 = 3.8319691761E-01_wp
      PEN210 = - 2.0572313651_wp
      PEN310 = 3.3477938724E-01_wp
      PEN020 = - 4.9997430930_wp
      PEN120 = 9.7335338937E-02_wp
      PEN220 = 6.0887771651E-01_wp
      PEN030 = 1.7433051009_wp
      PEN130 = - 1.1114577810E-01_wp
      PEN040 = - 2.9751504321E-01_wp
      PEN001 = - 6.9171176978E-01_wp
      PEN101 = 2.2832980419_wp
      PEN201 = - 1.3694684286_wp
      PEN011 = - 1.4557549876_wp
      PEN111 = 2.2969116213E-01_wp
      PEN021 = 8.3654420645E-01_wp
      PEN002 = - 1.4046808820E-02_wp
      PEN102 = 4.2928871430E-02_wp
      PEN012 = - 2.8729602515E-01_wp
      APE000 = - 1.9815805734E-01_wp
      APE100 = - 9.5799229402E-03_wp
      APE200 = 5.1430784127E-02_wp
      APE300 = - 8.3694846809E-03_wp
      APE010 = 2.4998715465E-01_wp
      APE110 = - 4.8667669469E-03_wp
      APE210 = - 3.0443885826E-02_wp
      APE020 = - 1.3074788257E-01_wp
      APE120 = 8.3359333577E-03_wp
      APE030 = 2.9751504321E-02_wp
      APE001 = 3.6393874690E-02_wp
      APE101 = - 5.7422790533E-03_wp
      APE011 = - 4.1827210323E-02_wp
      APE002 = 7.1824006288E-03_wp
      BPE000 = 1.1135652187E-01_wp
      BPE100 = - 2.7726708459E-01_wp
      BPE200 = 3.1407968134E-01_wp
      BPE300 = - 1.0300557601E-01_wp
      BPE010 = 4.7899614701E-03_wp
      BPE110 = - 5.1430784127E-02_wp
      BPE210 = 1.2554227021E-02_wp
      BPE020 = 1.2166917367E-03_wp
      BPE120 = 1.5221942913E-02_wp
      BPE030 = - 1.3893222263E-03_wp
      BPE001 = 2.8541225524E-02_wp
      BPE101 = - 3.4236710714E-02_wp
      BPE011 = 2.8711395266E-03_wp
      BPE002 = 5.3661089288E-04_wp
    CASE (np_seos)
      IF (lwp) THEN
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '   ==>>>   use of simplified eos:    '
        WRITE(numout, FMT = *) '              rhd(dT=T-10,dS=S-35,Z) = [-a0*(1+lambda1/2*dT+mu1*Z)*dT '
        WRITE(numout, FMT = *) '                                       + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS] / rau0'
        WRITE(numout, FMT = *) '              with the following coefficients :'
        WRITE(numout, FMT = *) '                 thermal exp. coef.    rn_a0      = ', rn_a0
        WRITE(numout, FMT = *) '                 saline  cont. coef.   rn_b0      = ', rn_b0
        WRITE(numout, FMT = *) '                 cabbeling coef.       rn_lambda1 = ', rn_lambda1
        WRITE(numout, FMT = *) '                 cabbeling coef.       rn_lambda2 = ', rn_lambda2
        WRITE(numout, FMT = *) '                 thermobar. coef.      rn_mu1     = ', rn_mu1
        WRITE(numout, FMT = *) '                 thermobar. coef.      rn_mu2     = ', rn_mu2
        WRITE(numout, FMT = *) '                 2nd cabbel. coef.     rn_nu      = ', rn_nu
        WRITE(numout, FMT = *) '              Caution: rn_beta0=0 incompatible with ddm parameterization '
      END IF
      l_useCT = .TRUE.
    CASE DEFAULT
      WRITE(ctmp1, FMT = *) '          bad flag value for neos = ', neos, '. You should never see this error'
      CALL ctl_stop(ctmp1)
    END SELECT
    rau0_rcp = rau0 * rcp
    r1_rau0 = 1._wp / rau0
    r1_rcp = 1._wp / rcp
    r1_rau0_rcp = 1._wp / rau0_rcp
    IF (lwp) THEN
      IF (l_useCT) THEN
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '   ==>>>   model uses Conservative Temperature'
        WRITE(numout, FMT = *) '           Important: model must be initialized with CT and SA fields'
      ELSE
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '   ==>>>   model does not use Conservative Temperature'
      END IF
    END IF
    IF (lwp) WRITE(numout, FMT = *)
    IF (lwp) WRITE(numout, FMT = *) '   Associated physical constant'
    IF (lwp) WRITE(numout, FMT = *) '      volumic mass of reference           rau0  = ', rau0, ' kg/m^3'
    IF (lwp) WRITE(numout, FMT = *) '      1. / rau0                        r1_rau0  = ', r1_rau0, ' m^3/kg'
    IF (lwp) WRITE(numout, FMT = *) '      ocean specific heat                 rcp   = ', rcp, ' J/Kelvin'
    IF (lwp) WRITE(numout, FMT = *) '      rau0 * rcp                       rau0_rcp = ', rau0_rcp
    IF (lwp) WRITE(numout, FMT = *) '      1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp
  END SUBROUTINE eos_init
END MODULE eosbn2


      SUBROUTINE DT_EMC2(Ip1,Ip2,Ip3,Ip4,Ip5,Mp,In1,In2,In3,In4,In5,Mn,
     &                   Mode,Ipos,Irej)

C***********************************************************************
C             MODE = 1   energy-momentum cons. check                   *
C                  = 2   flavor-cons. check                            *
C                  = 3   energy-momentum & flavor cons. check          *
C                  = 4   energy-momentum & charge cons. check          *
C                  = 5   energy-momentum & flavor & charge cons. check *
C This version dated 16.01.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION dum , TINY10 , ZERO
      INTEGER i , idum , In1 , In2 , In3 , In4 , In5 , Ip1 , Ip2 , Ip3 ,
     &        Ip4 , Ip5 , Ipos , Irej , irej1 , irej2 , irej3 , Mn ,
     &        Mode , Mp
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'

      Irej = 0
      irej1 = 0
      irej2 = 0
      irej3 = 0

      IF ( (Mode.EQ.1) .OR. (Mode.EQ.3) .OR. (Mode.EQ.4) .OR.
     &     (Mode.EQ.5) ) CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,idum,idum)
      IF ( (Mode.EQ.2) .OR. (Mode.EQ.3) .OR. (Mode.EQ.5) )
     &     CALL DT_EVTFLC(0,idum,1,idum,idum)
      IF ( (Mode.EQ.4) .OR. (Mode.EQ.5) )
     &     CALL DT_EVTCHG(idum,1,idum,idum)
      DO i = 1 , NHKk
         IF ( (ISThkk(i).EQ.Ip1) .OR. (ISThkk(i).EQ.Ip2) .OR.
     &        (ISThkk(i).EQ.Ip3) .OR. (ISThkk(i).EQ.Ip4) .OR.
     &        (ISThkk(i).EQ.Ip5) ) THEN
            IF ( (Mode.EQ.1) .OR. (Mode.EQ.3) .OR. (Mode.EQ.4) .OR.
     &           (Mode.EQ.5) ) CALL DT_EVTEMC(PHKk(1,i),PHKk(2,i),
     &           PHKk(3,i),PHKk(4,i),2,idum,idum)
            IF ( (Mode.EQ.2) .OR. (Mode.EQ.3) .OR. (Mode.EQ.5) )
     &           CALL DT_EVTFLC(IDHkk(i),Mp,2,idum,idum)
            IF ( (Mode.EQ.4) .OR. (Mode.EQ.5) )
     &           CALL DT_EVTCHG(IDHkk(i),2,idum,idum)
         END IF
         IF ( (ISThkk(i).EQ.In1) .OR. (ISThkk(i).EQ.In2) .OR.
     &        (ISThkk(i).EQ.In3) .OR. (ISThkk(i).EQ.In4) .OR.
     &        (ISThkk(i).EQ.In5) ) THEN
            IF ( (Mode.EQ.1) .OR. (Mode.EQ.3) .OR. (Mode.EQ.4) .OR.
     &           (Mode.EQ.5) ) CALL DT_EVTEMC(-PHKk(1,i),-PHKk(2,i),
     &           -PHKk(3,i),-PHKk(4,i),2,idum,idum)
            IF ( (Mode.EQ.2) .OR. (Mode.EQ.3) .OR. (Mode.EQ.5) )
     &           CALL DT_EVTFLC(IDHkk(i),Mn,-2,idum,idum)
            IF ( (Mode.EQ.4) .OR. (Mode.EQ.5) )
     &           CALL DT_EVTCHG(IDHkk(i),-2,idum,idum)
         END IF
      END DO
      IF ( (Mode.EQ.1) .OR. (Mode.EQ.3) .OR. (Mode.EQ.4) .OR.
     &     (Mode.EQ.5) ) CALL DT_EVTEMC(dum,dum,dum,dum,5,Ipos,irej1)
      IF ( (Mode.EQ.2) .OR. (Mode.EQ.3) .OR. (Mode.EQ.5) )
     &     CALL DT_EVTFLC(0,idum,3,Ipos,irej2)
      IF ( (Mode.EQ.4) .OR. (Mode.EQ.5) )
     &     CALL DT_EVTCHG(idum,3,Ipos,irej3)

      IF ( (irej1.NE.0) .OR. (irej2.NE.0) .OR. (irej3.NE.0) ) Irej = 1

      END SUBROUTINE


c*************************************************************************
c                            SYMBA4_MERGE.F
c*************************************************************************
c This subroutine checks to see if there are encounters
c
c             Input:
c                 t             ==>  current time (real scalar)
c                 dt            ==>  time step (real scalar)
c                 nbod          ==>  number of massive bodies (int scalar)
c                 ip1,ip2       ==>  The two bodies to check (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 xh,yh,zh      ==>  initial position in helio coord
c                                    (real arrays)
c                 vxb,vyb,vzb   ==>  initial velocity in helio coord
c                                    (real arrays)
c                 ireci         ==>  current recursion level (int scalar)
c                 irecl         ==>  maximum recursion level (int scalar)
c                 svdotrold     ==>  old radial velocity test
c                                   = .true. if i,j are receding
c                                   = .false is approaching
c                                     (logical*1 scalar)
c                 iecnt         ==>  The number of objects that each planet
c                                    is encountering (int*2 array)
c                 lemat         ==>  Matrix of encounters (logical*1 2d array)
c                 rpl           ==>  physical size of a planet.
c                                    (real array)
c             mergelst          ==>  list of mergers (int array)
c             mergecnt          ==>  count of mergers (int array)
c             rhill             ==>  Hill sphere of planet (real Scalar)
c             eoff              ==>  Energy offset (real scalar)
c                ielc           ==>  number of encounters (integer*2 scalar)
c                ielst          ==>  list of ecnounters (2D integer*2 array)
c
c             Output:  Changed only if a Megrer happens
c                 mass          ==>  mass of bodies (real array)
c                 xh,yh,zh      ==>  initial position in helio coord
c                                    (real arrays)
c                 vxb,vyb,vzb   ==>  initial velocity in helio coord
c                                    (real arrays)
c                 iecnt         ==>  The number of objects that each planet
c                                    is encountering (int*2 array)
c                 lemat         ==>  Matrix of encounters (logical*1 2d array)
c                 rpl           ==>  physical size of a planet.
c                                    (real array)
c             mergelst          ==>  list of mergers (int array)
c             mergecnt          ==>  count of mergers (int array)
c             rhill             ==>  Hill sphere of planet (real Scalar)
c             eoff              ==>  Energy offset (real scalar)
c                ielc           ==>  number of encounters (integer*2 scalar)
c                ielst          ==>  list of ecnounters (2D integer*2 array)
c
c Remarks:
c Authors:  Hal Levison
c Date:   1/2/97
c Last revision: 1/24/97
c

      subroutine symba4_merge(t,dt,nbod,ip1,ip2,mass,xh,yh,zh,vxb,
     &     vyb,vzb,ireci,irecl,svdotrold,lemat,iecnt,rpl,
     &     mergelst,mergecnt,rhill,eoff,ielc,ielst)

      include '../swift.inc'
      include 'symba4.inc'

c...  Inputs:
      integer nbod,ireci,irecl,ip1,ip2
      real*8 t,dt
      logical*1 svdotrold

c...  Inputs and Outputs:
      real*8 mass(nbod),xh(nbod),yh(nbod),zh(nbod),eoff
      real*8 vxb(nbod),vyb(nbod),vzb(nbod),rpl(nbod),rhill(nbod)
      integer*2 iecnt(NTPMAX)
      logical*1 lemat(NTPMAX,NTPMAX)
      integer mergelst(2,NTPMAX),mergecnt
      integer ip1l,ip2l
      integer*2 ielst(2,NTPMAXSQ),ielc

c...  Outputs

c...  Internals
      integer ialpha
      real*8 xr,yr,zr,vxr,vyr,vzr,vdotr,tcross2
      real*8 rlim,rlim2,rr2,massc,a,e,peri,dt2

c-----
c...  Executable code

      xr = xh(ip2) - xh(ip1)
      yr = yh(ip2) - yh(ip1)
      zr = zh(ip2) - zh(ip1)
      rr2 = xr**2 + yr**2 + zr**2

      rlim = rpl(ip1)+rpl(ip2)

      if(rlim.eq.0.0d0) RETURN  ! <======  NOTE !!!!!

      rlim2 = rlim*rlim

      if(rlim2.ge.rr2) then
         ip1l = ip1
         ip2l = ip2
         call discard_mass_merge(t,nbod,ip1l,ip2l,mass,xh,yh,zh,
     &        vxb,vyb,vzb,rpl,lemat,eoff,ielc,ielst,NTPMAXSQ)
         mergecnt = mergecnt + 1
         mergelst(1,mergecnt) = ip1l
         mergelst(2,mergecnt) = ip2l
         rhill(ip2l) = 0.0d0
         call util_hills1(mass(1),mass(ip1l),xh(ip1l),yh(ip1l),
     &        zh(ip1l),vxb(ip1l),vyb(ip1l),vzb(ip1l),rhill(ip1l))
         return      !   <=== NOTE !!!!!!!!!
      endif

      vxr = vxb(ip2) - vxb(ip1)
      vyr = vyb(ip2) - vyb(ip1)
      vzr = vzb(ip2) - vzb(ip1)
      vdotr = xr*vxr + yr*vyr + zr*vzr

      if( svdotrold .and. (vdotr.gt.0.0d0)) then

         tcross2 = rr2/(vxr**2+vyr**2+vzr**2)
         dt2 = dt*dt

         if(tcross2.le.dt2) then
            massc = mass(ip1) + mass(ip2)
            call orbel_xv2aeq(xr,yr,zr,vxr,vyr,vzr,massc,
     &           ialpha,a,e,peri)
            if( peri.lt.rlim) then
               ip1l = ip1
               ip2l = ip2
               call discard_mass_merge(t,nbod,ip1l,ip2l,mass,xh,
     &              yh,zh,vxb,vyb,vzb,rpl,lemat,eoff,ielc,
     &              ielst,NTPMAXSQ)
               mergecnt = mergecnt + 1
               mergelst(1,mergecnt) = ip1l
               mergelst(2,mergecnt) = ip2l
               rhill(ip2l) = 0.0d0
               call util_hills1(mass(1),mass(ip1l),xh(ip1l),yh(ip1l),
     &              zh(ip1l),vxb(ip1l),vyb(ip1l),vzb(ip1l),rhill(ip1l))
            endif
         endif
      endif

      return
      end                       ! symba4_merge
c------------------------------------------------------