!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r prgen - interpolation (general) on a given pressure level
*
#include "model_macros_f.h"
*
subroutine prgen (F_out , F_in , F_deriv , F_wlnph, 16
% F_pres, Nkout, F_cubic_L, DIST_DIM, Nk)
*
#include "impnone.cdk"
*
integer DIST_DIM,Nk,Nkout
logical F_cubic_L
real F_pres(Nkout), F_out(DIST_SHAPE,Nkout), F_in(DIST_SHAPE,Nk),
$ F_deriv(DIST_SHAPE,Nk), F_wlnph(DIST_SHAPE,Nk)
*
*author
* alain patoine - after intfev (efr)
*
*revision
* v2_00 - Lee V. - initial MPI version (from prgen v1_03)
* v3_00 - Desgagne & Lee - Lam configuration
* v3_21 - Lee V. - Output Optimization
*
*object
* see id section
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_out O - output field on the requested pressure level
* F_in I - input field on eta levels
* F_deriv I - vertical derivative of input field with respect
* to log of hydrostatic pressure
* F_wlnph I - log of hydrostatic pressure on the eta levels of
* the model
* F_pres I - pressure level requested
* F_cubic_L I - .true. for cubic interpolation
* - .false. for linear interpolation
*
*implicits
#include "glb_ld.cdk"
*
**
integer i, j, k, kk,pnk, pnkm, pnindex(l_ni)
real prlprso, prd, pre, prr, prfm0, prfm1, prfm2, prfm3, prfl2
real*8 invprd
*
* ---------------------------------------------------------------
*
!$omp parallel private(i,k,kk,pnk,pnkm,pnindex,prlprso,
!$omp$ prd,pre,prr,prfm0,prfm1,prfm2,prfm3,prfl2,invprd)
!$omp do
do 600 j= 1, l_nj
do 500 kk=1, Nkout
prlprso = log(F_pres(kk))
*
do i= 1, l_ni
pnindex(i) = 0
enddo
*
do k=1,l_nk
do i= 1, l_ni
if ( prlprso .gt. F_wlnph(i,j,k) ) pnindex(i) = k
enddo
enddo
*
do i= 1, l_ni
*********************************************************************
* *
* If: output pressure < hydrostatic pressure on the *
* first level of the model *
* *
* Then: upward extrapolation *
* *
*********************************************************************
if ( pnindex(i) .eq. 0 ) then
*
prd = prlprso - F_wlnph(i,j,1)
*
F_out(i,j,kk) = F_in(i,j,1) + prd * F_deriv(i,j,1)
*
*********************************************************************
* *
* If: output pressure > hydrostatic pressure on the *
* last level of the model *
* *
* Then: downward extrapolation *
* *
* We put in F_out the value of F_in on the lowest level of the model*
* *
*********************************************************************
else if (pnindex(i) .eq. l_nk ) then
*
F_out(i,j,kk)= F_in(i,j,l_nk)
*********************************************************************
* *
* Else, interpolate between appropriate levels. *
* *
*********************************************************************
*
else
pnk = pnindex(i) + 1
pnkm= pnindex(i)
*
prd = F_wlnph(i,j,pnk) - F_wlnph(i,j,pnkm)
invprd = prd
invprd = 1.0/invprd
*
pre = prlprso - 0.5 * (F_wlnph(i,j,pnk) + F_wlnph(i,j,pnkm))
*
prfm0 = 0.5 * ( F_in(i,j,pnk) + F_in(i,j,pnkm) )
*
prfm1 = ( F_in(i,j,pnk) - F_in(i,j,pnkm) ) * invprd
*
if ( F_cubic_L ) then
*
prr = 0.125 * prd * prd - 0.5 * pre * pre
*
prfm2 = ( F_deriv(i,j,pnk) - F_deriv(i,j,pnkm) ) * invprd
*
prfm3 = F_deriv(i,j,pnk) + F_deriv(i,j,pnkm)
prfm3 = ( prfm3 - prfm1 - prfm1 ) * invprd *invprd
*
prfl2 = prfm2 + 2.0 * pre * prfm3
*
F_out(i,j,kk)= prfm0 + pre * prfm1 - prr * prfl2
*
else
*
F_out(i,j,kk)= prfm0 + pre * prfm1
*
endif
*
endif
*
end do
*
* ---------------------------------------------------------------
*
500 enddo
600 enddo
!$omp enddo
!$omp end parallel
return
end