kmppm.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!----------------------------------------------------------------------- 
!BOP
! !ROUTINE:  kmppm --- Perform piecewise parabolic method in vertical
!
! !INTERFACE:
      subroutine kmppm(dm, a4, itot, lmt)

! !USES:
      use precision

      implicit none

! !INPUT PARAMETERS:
      real(r8)    dm(*)     ! ??????
      integer     itot      ! Total Longitudes
      integer lmt           ! 0: Standard PPM constraint
                            ! 1: Improved full monotonicity constraint (Lin)
                            ! 2: Positive definite constraint
                            ! 3: do nothing (return immediately)

! !INPUT/OUTPUT PARAMETERS:
      real(r8)    a4(4,*)   ! ???????
                            ! AA <-- a4(1,i)
                            ! AL <-- a4(2,i)
                            ! AR <-- a4(3,i)
                            ! A6 <-- a4(4,i)

! !DESCRIPTION:
!
!    Writes a standard set of data to the history buffer. 
!
! !REVISION HISTORY: 
!    00.04.24   Lin       Last modification
!    01.03.26   Sawyer    Added ProTeX documentation
!
!EOP
!-----------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
      real(r8)       r12
      parameter (r12 = 1./12.)

      real(r8) qmp

      integer i
      real(r8) da1, da2, a6da
      real(r8) fmin
!-----------------------------------------------------------------------

      if ( lmt .eq. 3 ) return

      if(lmt .eq. 0) then
! Standard PPM constraint
      do i=1,itot
      if(dm(i) .eq. 0.) then
         a4(2,i) = a4(1,i)
         a4(3,i) = a4(1,i)
         a4(4,i) = 0.
      else
         da1  = a4(3,i) - a4(2,i)
         da2  = da1**2
         a6da = a4(4,i)*da1
         if(a6da .lt. -da2) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         elseif(a6da .gt. da2) then
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
      endif
      enddo

      elseif (lmt .eq. 1) then

! Improved full monotonicity constraint (Lin)
! Note: no need to provide first guess of A6 <-- a4(4,i)
      do i=1, itot
           qmp = 2.*dm(i)
         a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp)
         a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp)
         a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) )
      enddo

      elseif (lmt .eq. 2) then

! Positive definite constraint
      do i=1,itot
      if( abs(a4(3,i)-a4(2,i)) .lt. -a4(4,i) ) then
      fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12
         if( fmin .lt. 0. ) then
         if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then
            a4(3,i) = a4(1,i)
            a4(2,i) = a4(1,i)
            a4(4,i) = 0.
         elseif(a4(3,i) .gt. a4(2,i)) then
            a4(4,i) = 3.*(a4(2,i)-a4(1,i))
            a4(3,i) = a4(2,i) - a4(4,i)
         else
            a4(4,i) = 3.*(a4(3,i)-a4(1,i))
            a4(2,i) = a4(3,i) - a4(4,i)
         endif
         endif
      endif
      enddo

      endif

      return
!EOC
      end subroutine kmppm
!-----------------------------------------------------------------------