copyright (C) 2001 MSC-RPN COMM %%%MC2%%% ***s/r fullprw *subroutine fullprw ( prw, heigths, ng, lnk, levtyp ) 1,3 implicit none * character* (*) levtyp integer ng,lnk real prw(ng,lnk), heigths(ng,lnk) * #include "dynmem.cdk"
#include "topo.cdk"
#include "levels.cdk"
#include "yomdyn1.cdk"
* integer i,j,k,ktop(ng*lnk),kbot(ng*lnk) real posv(ng*lnk*2),hww(ng*(lnk+4)),tr2,wk1, $ hmom(ldni,ldnj,0:lnk),wk(ldni,ldnj,0:lnk),qs(ng,lnk), $ ovts(ng,lnk),prt(ng,lnk),dum1(ng*lnk),dum2(ng*lnk) pointer (patr2, tr2(ldni,ldnj,*)),(pawk1, wk1(ldni,ldnj,*)) * *---------------------------------------------------------------------- * patr2 = loc(prw (1,1)) pawk1 = loc(heigths(1,1)) * do k=1,lnk do j=1,ldnj do i=1,ldni wk1(i,j,k) = ht(i,j,k) end do end do end do * if (levtyp.eq.'P') then * do k = 0, lnk do j = 1, ldnj do i = 1, ldni wk (i,j,k) = ppp(i,j,k) * orts(i,j,k) hmom(i,j,k) = hm (i,j,k) end do end do end do * * * Vertical cubic interpolation on thermo. level * call posiz3
( posv,hww,hmom,heigths,ktop,kbot,ng,lnk,lnk+1 ) call vertint3
( prt,wk,posv,hww,ng,lnk,lnk+1 ) * * * Compute full pressure * call qntstar
( qs,dum1,dum2,ovts,heigths,heigths,ng,1,lnk ) * do k = 2, lnk do i = 1, ng prw(i,k) = exp (qs(i,k-1) + prt(i,k-1)) end do end do * do j = 1, ldnj do i = 1, ldni tr2(i,j,1) = exp(qstr(i,j,0) + wk(i,j,0)) end do end do * endif * if (levtyp.eq.'H') then * do k = lnk , 2, -1 do i = 1, ng heigths(i,k) = heigths(i,k-1) end do end do * do j=1,ldnj do i=1,ldni wk1(i,j,1) = hh0(i,j,1) end do end do * endif * *---------------------------------------------------------------------- return end