       MODULE PRMTS
       INTEGER MAXF,MAXG,MAXFM,MAXFN,SHELL,SWITCH
       PARAMETER(SHELL=30)  ! This gives us up to omega = 10.
!      SHELL=SHELL+1 if grad. min. or hfs
!      SHELL=SHELL+2*L, L - angular momentum
!      max(SHELL)=2*6+6 = 18 in quad
!      max(SHELL)=2*9+6 = 24 in sixr
!      max(SHELL)=2*12+6= 30 in octr

       PARAMETER(MAXG=(7+SHELL)*(8+SHELL)*(9+SHELL)/6-1)
       PARAMETER(MAXFN=((1+SHELL)*(2+SHELL)*(3+SHELL)*(4+SHELL)*(5+SHELL)*(6+SHELL))/720)
!      PARAMETER(MAXFM=((1+SHELL)*(2+SHELL)*(3+SHELL)*(4+SHELL)*(5+SHELL))/120)
       PARAMETER(MAXF = MAXFN) ! if SWITCH=0
!      PARAMETER(MAXF = MAXFN+6*MAXFM)  ! if SWITCH=1
!      PARAMETER(MAXF = MAXFN+12*MAXFM) ! if SWITCH=2
       END MODULE PRMTS

c gamma(l,m,n); l,m,n >=-2; l+m+n<=sm
      subroutine p_g(tg,a,b,c,sm)
       USE PRMTS
       IMPLICIT NONE

       integer sm

       ! macierz wspolczynnikow gamma w artykule
       real*16 tg(0:MAXG)

       ! macierze B oraz A w artykule
       real*16 tb(0:MAXG)
       real*16  yg1(0:200,0:200,2)
       real*16  yg2(0:200,2)
       real*16 a,b,c,p

       ! aktualna powloka

       integer sc

       !  identyfikator funkcji idx zwracajacej indeks w tablicy tg,tb

       integer idx
       integer l,m,n
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	!write (*,*) "Test 4"

       call p_tb(sm,tb,a,b,c)

       do sc=0,sm

        if (sc==0) then
         tg(idx(0,0,0)) = 1/(a+b)/(b+c)/(c+a)

         goto 10
        endif

        do l=0, sc
         do m=0, sc-l

          n=sc-(l+m)

          tg(idx(l,m,n))=1/(a+b)*tb(idx(l,m,n))

          if (l>0) then
           tg(idx(l,m,n))=tg(idx(l,m,n))
     -     +1/(a+b)*l*tg(idx(l-1,m,n))
          endif

          if (m>0) then
           tg(idx(l,m,n))=tg(idx(l,m,n))
     -     +1/(a+b)*m*tg(idx(l,m-1,n))
          endif

          enddo
         enddo
 10      continue
        enddo
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
! to powinno byc z kodu Korobova

        call ygam(a,b,c,yg1,sm+2,sm+2,2)
        do m=0,sm+1
         do n=0,sm+1-m
          tg(idx(-1,m,n))=yg1(m,n,1)
         enddo
        enddo
        do m=0,sm+2
         do n=0,sm+2-m
          tg(idx(-2,m,n))=yg1(m,n,2)
         enddo
        enddo

        call ygam(b,a,c,yg1,sm+2,sm+2,2)
        do m=0,sm+1
         do n=0,sm+1-m
          tg(idx(m,-1,n))=yg1(m,n,1)
         enddo
        enddo
        do m=0,sm+2
         do n=0,sm+2-m
          tg(idx(m,-2,n))=yg1(m,n,2)
         enddo
        enddo

        call ygam(c,b,a,yg1,sm+2,sm+2,2)
        do m=0,sm+1
         do n=0,sm+1-m
          tg(idx(n,m,-1))=yg1(m,n,1)
         enddo
        enddo
        do m=0,sm+2
         do n=0,sm+2-m
          tg(idx(n,m,-2))=yg1(m,n,2)
         enddo
        enddo
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c        p=b;b=c;c=p

        call ygam1s(a,b,c,yg2,sm+3)
        do n=0,sm+2
         tg(idx(-1,-1,n))= yg2(n,1)
        enddo
        do n=0,sm+3
         tg(idx(-2,-1,n))= yg2(n,2)
        enddo
        call ygam1s(b,a,c,yg2,sm+3)
        do n=0,sm+3
         tg(idx(-1,-2,n))= yg2(n,2)
        enddo

        call ygam1s(c,b,a,yg2,sm+3)
        do n=0,sm+2
         tg(idx(n,-1,-1))= yg2(n,1)
        enddo
        do n=0,sm+3
         tg(idx(n,-1,-2))= yg2(n,2)
        enddo

        call ygam1s(b,c,a,yg2,sm+3)
        do n=0,sm+3
         tg(idx(n,-2,-1))= yg2(n,2)
        enddo

        call ygam1s(a,c,b,yg2,sm+3)
        do n=0,sm+2
         tg(idx(-1,n,-1))= yg2(n,1)
        enddo
        do n=0,sm+3
         tg(idx(-2,n,-1))= yg2(n,2)
        enddo

        call ygam1s(c,a,b,yg2,sm+3)
        do n=0,sm+3
         tg(idx(-1,n,-2))= yg2(n,2)
        enddo

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

 20     continue
       end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

! wyliczanie elementow beta

      subroutine p_tb(sm,tb,a,b,c)
       use prmts
       IMPLICIT NONE
       real*16 a,b,c
       real*16 tb(0:MAXG)

       integer sm,sc
       integer l,m,n,idx
       real*16 ta(0:sm+3)

       do sc=0,sm

        if (sc==0) then
         tb(idx(0,0,0))=1/((a+c)*(b+c))
         ta(0) = 1/(b+c)
         goto 20
        endif

        ta(sc) = ta(sc-1)*sc/(b+c)

        do l=0,sc
         do m=0,sc-l
          n=sc-(l+m)
          if (n>0) then
           tb(idx(l,m,n))= 1/(a+c)*n*tb(idx(l,m,n-1))
          else
           tb(idx(l,m,n))=0
          endif

          if (l==0) then
           if (n==0) then
            tb(idx(l,m,n))=tb(idx(l,m,n))
     -      +1/(b+c)*m*tb(idx(l,m-1,n))
           else
            tb(idx(l,m,n))=tb(idx(l,m,n))
     -      +1/(a+c)*ta(m+n)
           endif
          else
           tb(idx(l,m,n))=tb(idx(l,m,n))+1/(a+c)*l*tb(idx(l-1,m,n))
          endif

c          write(*,*) 'tb(lmn):',l,' ',m,' ',n,' ',tb(idx(l,m,n))

         enddo
        enddo
 20     continue
       enddo

       return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c    idx(n1,n2,n3) -> N; ni >=-2

      integer function idx(n1,n2,n3)
      USE PRMTS
      IMPLICIT NONE
      integer n1,n2,n3,nx,sum

      if ((n1<-2).or.(n2<-2).or.(n3<-2))then
       idx=0
       return
      endif

       nx  = n1+2
       sum = nx+1
       nx  = nx+n2+2
       sum = sum + (nx*(1 + nx))/2
       nx  = nx+n3+2
       sum = sum + (nx*(1 + nx)*(2 + nx))/6
       idx = sum

       if (idx>MAXG) then
        write(*,*) 'ZAKRES MAXG:',MAXG,idx,n1,n2,n3
        STOP 'too small MAXG'
       endif

       return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


      SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*  -- Modified by R. Clint Whaley for ATLAS Fortran77 LAPACK interface,
*     1999
*
*     .. Scalar Arguments ..
      CHARACTER TRANS
      INTEGER   INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER IPIV( * )
      COMPLEX A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  CGETRS solves a system of linear equations
*     A * X = B,  A**T * X = B,  or  A**H * X = B
*  with a general N-by-N matrix A using the LU factorization computed
*  by CGETRF.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B     (No transpose)
*          = 'T':  A**T * X = B  (Transpose)
*          = 'C':  A**H * X = B  (Conjugate transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) COMPLEX array, dimension (LDA,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by CGETRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from CGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     ..
*     .. Local Scalars ..
      LOGICAL NOTRAN
      INTEGER ITRAN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ATL_F77WRAP_CGETRS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRS', -INFO )
         RETURN
      END IF
*
      IF (NOTRAN) THEN
         ITRAN = ATLASNOTRANS
      ELSE IF ( LSAME(TRANS, 'C') ) THEN
         ITRAN = ATLASCONJTRANS
      ELSE
         ITRAN = ATLASTRANS
      ENDIF
*
      CALL ATL_F77WRAP_CGETRS( ITRAN, N, NRHS, A, LDA, IPIV, B, LDB )
*
      RETURN
      END


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0
real(dp), parameter :: stop_time = 1000.0

real(dp), parameter :: CFL = 0.9

real(dp), parameter :: beta = 0.8

real(dp), parameter :: dt_checkpoint = 1e2

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

real(dp), parameter :: dt_analyze = 1e-2

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 1.0

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: zlim(2) = diameter * ((/0.0,1.0/) - 0.5)

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

real(dp), parameter :: dens0 = 1.0_dp
real(dp), parameter :: pres0 = 1.0_dp

real(dp), parameter :: velx0 = 0.0_dp
real(dp), parameter :: vely0 = 0.0_dp
real(dp), parameter :: velz0 = 0.0_dp

real(dp), parameter :: kappa = 7.0_dp/5.0_dp

!! amplitudes
real(dp), parameter :: d0 = 1.0_dp, d1 = 1.0_dp * 0.35_dp, d2 = 1.0_dp * 0.24_dp, d3 = 1.0_dp * 0.12_dp, d4 = 0.0_dp ! 44;
real(dp), parameter :: u0 = 0.1_dp, u1 = 1.0_dp * 0.13_dp, u2 = 1.0_dp * 0.12_dp, u3 = 1.0_dp * 0.11_dp, u4 = 0.0_dp ! 31;
real(dp), parameter :: v0 = 0.2_dp, v1 = 1.0_dp * 0.14_dp, v2 = 1.0_dp * 0.13_dp, v3 = 1.0_dp * 0.14_dp, v4 = 0.0_dp ! 24;
real(dp), parameter :: w0 = 0.3_dp, w1 = 1.0_dp * 0.11_dp, w2 = 1.0_dp * 0.11_dp, w3 = 1.0_dp * 0.12_dp, w4 = 0.0_dp ! 12;
real(dp), parameter :: p0 = 1.0_dp, p1 = 1.0_dp * 0.23_dp, p2 = 1.0_dp * 0.19_dp, p3 = 1.0_dp * 0.21_dp, p4 = 0.0_dp ! 23;

!! frequencies
real(dp), parameter :: df1 = 1.0_dp, df2 = 2.0_dp, df3 = 3.0_dp, df4 = 1.0_dp;
real(dp), parameter :: uf1 = 1.0_dp, uf2 = 2.0_dp, uf3 = 3.0_dp, uf4 = 1.0_dp;
real(dp), parameter :: vf1 = 1.0_dp, vf2 = 2.0_dp, vf3 = 3.0_dp, vf4 = 1.0_dp;
real(dp), parameter :: wf1 = 1.0_dp, wf2 = 2.0_dp, wf3 = 3.0_dp, wf4 = 1.0_dp;
real(dp), parameter :: pf1 = 1.0_dp, pf2 = 2.0_dp, pf3 = 3.0_dp, pf4 = 1.0_dp;

real(dp), parameter :: L = 1.0_dp;

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

integer, parameter :: mesh_minlevel = 2
integer, parameter :: mesh_maxlevel = 3

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


      SUBROUTINE DCZ2CCM(PS,PHIS,TV,P0,HYAM,HYBM,HYAI,HYBI,MLON,NLAT,
     +                  KLEV,KLEV1,Z2,PMLN,HYPDLN,HYALPH,ZSLICE,HYBA,
     +                  HYBB,PTERM,TV2)
c c c implicit none

C NCL: z2 = cz2ccm (ps,phis,tv,p0,hyam,hybm,hyai,hybi)

      INTEGER MLON,NLAT,KLEV
      DOUBLE PRECISION PS(MLON,NLAT),PHIS(MLON,NLAT),TV(MLON,NLAT,KLEV),
     +                 P0,HYAM(KLEV),HYBM(KLEV),HYAI(KLEV1),HYBI(KLEV1)

C Array to hold 2D tv values
      DOUBLE PRECISION TV2(MLON,KLEV)

C OUTPUT: geopotential at midlayer
      DOUBLE PRECISION Z2(MLON,NLAT,KLEV)

C logs of midpoint pressures
C log p layer thickness
C distance from interface to level
C calculated Z for vertical slice
C Hybrid coord coeffs: =1 interface
C Hybrid coord coeffs: =2 midlayer
C vertical scratch space
      DOUBLE PRECISION PMLN(MLON,KLEV+1),HYPDLN(MLON,KLEV),
     +                 HYALPH(MLON,KLEV),ZSLICE(MLON,KLEV),
     +                 HYBA(2,KLEV+1),HYBB(2,KLEV+1),PTERM(MLON,KLEV)

      DOUBLE PRECISION ZMSG,HPRB
      INTEGER KL,ML,NL

C Scratch arrays

      ZMSG = 1.D+36
C Hybrid base pressure (pascals)
      HPRB = P0

      DO I = 1,KLEV
          DO J = 1,NLAT
              DO K = 1,MLON
C initilize to zero.
                  Z2(K,J,I) = 0.0D0
              END DO
          END DO
      END DO
      DO I = 1,KLEV
          DO K = 1,MLON
              HYPDLN(K,I) = 0.0D0
              HYALPH(K,I) = 0.0D0
              ZSLICE(K,I) = 0.0D0
              PTERM(K,I) = 0.0D0
          END DO
      END DO

      DO I = 1,KLEV + 1
          DO K = 1,2
              HYBA(K,I) = 0.0D0
              HYBB(K,I) = 0.0D0
          END DO
      END DO
C copy to temporary arrays

C required by "cz2"
      DO KL = 1,KLEV + 1
C interface=1
          HYBA(1,KL) = HYAI(KL)
          HYBB(1,KL) = HYBI(KL)
      END DO

      DO KL = 1,KLEV
C mid-points=2
          HYBA(2,KL+1) = HYAM(KL)
          HYBB(2,KL+1) = HYBM(KL)
      END DO

C one vertical slice (mlon,klev) at atime

      DO NL = 1,NLAT
          DO J = 1,KLEV
              DO I = 1,MLON
                  TV2(I,J) = TV(I,NL,J)
              END DO
          END DO

          CALL DCZ2(PS(1,NL),PHIS(1,NL),TV2,HPRB,HYBA,HYBB,KLEV,MLON,
     +             MLON,PMLN,HYPDLN,HYALPH,PTERM,ZSLICE)

          DO KL = 1,KLEV
              DO ML = 1,MLON
                  Z2(ML,NL,KL) = ZSLICE(ML,KL)
              END DO
          END DO
C end nl
      END DO

      RETURN
      END
c +++
      SUBROUTINE DCZ2(PS,PHIS,TV,HPRB,HYBA,HYBB,KMAX,IDIM,IMAX,PMLN,
     +               HYPDLN,HYALPH,PTERM,Z2)
c-----------------------------------------------------------------------
c
c       File:   /u3/ccmproc2/src/src/cz2.F  (7169 bytes)
c       Date:   Wed Oct 25 14:17:31 1995
c       Author: CCM Processor <ccmproc2@sol>
c
c       From:   inderf
c       Calls:  ** none **
c       Blocks: ** none **
c
c-----------------------------------------------------------------------
c
c       Purpose:
c         To compute geopotential height for a CCM2 hybrid coordinate
c         vertical slice.  Since the vertical integration matrix is a
c         function of latitude and longitude, it is not explicitly
c         computed as for sigma coordinates.  The integration algorithm
c         is derived from Boville's mods in the ibm file hybrid 1mods
c         (6/17/88).  All vertical slice arrays are oriented top to
c         bottom as in CCM2.  This field is on full model levels (aka
c         "midpoints") not half levels.
c
c       Equation references are to "Hybrid Coordinates for CCM1"
c
c----------------------------Code History-------------------------------
c
c       Original: Jun 25 1991  L Buja
c       Upgrades: Apr 21 1993  L Buja
c                     Truesdale reports difference from CCM2 Z2.
c                     - Make pterm a scratch array (was automatic)
c                     - Make g0=9.80616 (was 9.81).  This appears to
c                        affect only the lowest layer.
c       Change  : Feb    1999: D Shea
c                     NCL changes + error
c                     - The "Invert vertical loop" has to have
c                        the argument checked for >0.0
c
c-----------------------------------------------------------------------
      IMPLICIT NONE
c-----------------------------Parameters--------------------------------
c
      DOUBLE PRECISION R,G0,RBYG
      PARAMETER (R=287.04D0,G0=9.80616D0,RBYG=R/G0)
c
c-----------------------------Arguments---------------------------------
c
c Input
c
C Longitude dimension
      INTEGER IDIM
C Number of vertical levels
      INTEGER KMAX
C Surface pressure           (pascals)
      DOUBLE PRECISION PS(IDIM)
C Surface geoptential
      DOUBLE PRECISION PHIS(IDIM)
C Virtual temperature, top to bottom
      DOUBLE PRECISION TV(IDIM,KMAX)
C Hybrid base pressure       (pascals)
      DOUBLE PRECISION HPRB
C Hybrid coord coeffs for base pressure
      DOUBLE PRECISION HYBA(2,KMAX+1)
C  ground to top, first subscript:

C  = 1 for layer interfaces

C  = 2 for layer midpoints

C  Lowest level is ground for both layer

C    locations

C Hybrid coord coeffs for surf pressure
      DOUBLE PRECISION HYBB(2,KMAX+1)
C   (in same format as hyba)

C Num of longitude points to compute
      INTEGER IMAX
C vertical slice scratch space used to
      DOUBLE PRECISION PMLN(IDIM,KMAX+1)
C   hold logs of midpoint pressures

C Vertical slice scratch space used to
      DOUBLE PRECISION HYPDLN(IDIM,KMAX)
C   hold log p layer thichkess

C Vertical slice scratch space used to
      DOUBLE PRECISION HYALPH(IDIM,KMAX)
C hold distance from interface to level

C during vertical integration

C Note: These scratch vertical slices

C       are used to improve computaional

C       efficiency

C Vertical scratch space.
      DOUBLE PRECISION PTERM(IDIM,KMAX)
C TEMPORARY
      DOUBLE PRECISION ARG
c
c Output
c
C Geopotential height, top to bottom
      DOUBLE PRECISION Z2(IDIM,KMAX)
c
c--------------------------Local variables------------------------------
c
C indexes
      INTEGER I,K,L,NUM
c
c-----------------------------------------------------------------------
c
      DATA NUM/0/

      NUM = NUM + 1
c
c       All arrays except hyba, hybb are oriented top to bottom

c       Compute intermediate quantities using scratch space
c       pmln(i,k+1) is pressure at the midpoint of layer k

      DO I = 1,IMAX
          PMLN(I,1) = DLOG(HPRB*HYBA(2,KMAX)+PS(I)*HYBB(1,KMAX))
          PMLN(I,KMAX+1) = DLOG(HPRB*HYBA(2,1)+PS(I)*HYBB(1,1))
      END DO

c       Invert vertical loop
c       Compute top only if top interface pressure is nonzero.
c       Implemented by setting loop limit klim
c
c       hyba, hybb are bottom to top, starting at ground.
c       pmln(i,k) is the mid-point pressure of layer k.
c       SHEA MODIFICATION

      DO K = KMAX + 1,1,-1
          DO I = 1,IMAX
c DJS     pmln(i,k) = alog(hprb*hyba(2,kmax-k+2)+ps(i)*hybb(2,kmax-k+2))
              ARG = HPRB*HYBA(2,KMAX-K+2) + PS(I)*HYBB(2,KMAX-K+2)
              IF (ARG.GT.0.D0) THEN
                  PMLN(I,K) = DLOG(ARG)
              ELSE
                  PMLN(I,K) = 0.0D0
              END IF
          END DO
      END DO
c
c       Initialize Z2 to sum of ground height and thickness of
c        top half-layer  (i.e. (phi)sfc in equation 1.14)

c       (Z2(i,1)=top  ->  Z2(i,kmax)=bottom

C*PL*ERROR* Comment line too long
c       Eq 3.a.109.2  where l=K,k<K  h(k,l) = 1/2 * ln [  p(k+1) / p(k) ]

      DO K = 2,KMAX - 1
          DO I = 1,IMAX
              PTERM(I,K) = RBYG*TV(I,K)*0.5D0* (PMLN(I,K+1)-PMLN(I,K-1))
          END DO
      END DO

C 3.a.109.2
      DO K = 1,KMAX - 1
          DO I = 1,IMAX
              Z2(I,K) = PHIS(I)/G0 + RBYG*TV(I,K)*0.5D0*
     +                  (PMLN(I,K+1)-PMLN(I,K))
          END DO
      END DO

c       Eq 3.a.109.5  where l=K,k=K  h(k,l) = ln [ pi / (p(k)) ]

      K = KMAX
C 3.a.109.5
      DO I = 1,IMAX
          Z2(I,K) = PHIS(I)/G0 + RBYG*TV(I,K)*
     +              (DLOG(PS(I)*HYBB(1,1))-PMLN(I,K))

      END DO

c       Eq 3.a.109.4  where l=K,k<K  h(k,l) = 1/2*ln[pi*pi/(p(k-1)*p(k))

C 3.a.109.4
      DO K = 1,KMAX - 1
          L = KMAX
          DO I = 1,IMAX
              Z2(I,K) = Z2(I,K) + RBYG*TV(I,L)*
     +                  (DLOG(PS(I)*HYBB(1,1))-0.5D0*
     +                  (PMLN(I,L-1)+PMLN(I,L)))
          END DO
      END DO

c       Add thickness of the remaining full layers
c        (i.e., integrate from ground to highest layer interface)

c       Eqs 1.14 & 3.a.109.3 where l>K, k<K
c                                h(k,l) = 1/2 * ln [ p(l+1)/p(l-1) ]

C 3.a.109.3
      DO K = 1,KMAX - 2
          DO L = K + 1,KMAX - 1
              DO I = 1,IMAX
                  Z2(I,K) = Z2(I,K) + PTERM(I,L)
              END DO
          END DO
      END DO

      RETURN
      END


MODULE constants
    IMPLICIT NONE
    PUBLIC
    CHARACTER(LEN=9), PARAMETER :: nl_name = "input.nl"
    CHARACTER(LEN=1), PARAMETER :: u_name = "u"
    CHARACTER(LEN=1), PARAMETER :: x_name = "X"
    DOUBLE PRECISION, PARAMETER :: G = 6.6743e-10
END MODULE


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details
C=======================================================================
      subroutine limits(ndim, numnp, cord)
C=======================================================================
      REAL CORD(NUMNP, NDIM)

      call minmax(numnp, cord(1,1), xmin, xmax)
      call minmax(numnp, cord(1,2), ymin, ymax)
      if (ndim .eq. 3) then
        call minmax(numnp, cord(1,3), zmin, zmax)
      else
        zmin = 0
        zmax = 0
      end if

      WRITE (*, *) ' '
      WRITE (*, *) 'Mesh Limits: '
      WRITE (*, 10000) 'X', XMIN, 'X', XMAX, XMAX-XMIN
      IF (NDIM .GE. 2) THEN
        WRITE (*, 10000) 'Y', YMIN, 'Y', YMAX, YMAX-YMIN
      ENDIF
      IF (NDIM .EQ. 3) THEN
         WRITE (*, 10000) 'Z', ZMIN, 'Z', ZMAX, ZMAX-ZMIN
      END IF
10000 FORMAT( ' Min ',A1,' = ',1PE16.9,', Max ',A1,' = ',
     &     1PE16.9,', Range = ',1PE16.9)
      return
      end