!-------------------------------------- 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 e_intthm - Interpolate GZ,VT,HU on model grid.
*
#include "model_macros_f.h"
*
subroutine e_intthm 1,42
*
implicit none
*
*AUTHOR M. ROCH - july 95 - from intscal
*
*revision
* v2_31 - M. Desgagne
* v3_00 - Desgagne & Lee - Lam configuration
* v3_02 - Lee V. - added one more argument to e_bmfrd
* v3_02 - - correction to search for GZ at 1.0 eta/sg
* v3_12 - Winger K. - Use Anal_cond_L
* v3_12 - Winger & Dugas - Output TD for pressure level moisture
* v3_20 - Pellerin Pierre - To run off-line (surface)
* v3_21 - Dugas B. - replace TD by ES in pressure mode
* v3_22 - Lee V. - removed Trvs tracers
* v3_30 - Lee/Desgagne - new LAM IO, read from analysis files to
* produce BCS or 3DF files
* v3_31 - Bilodeau B. - offline mode
* v3_31 - Lee V - offline mode using 3DF files
*
*object
* Computes the ln of surface and top pressure given the topo
* (topography calculated on the model grid, phi,U or V), then
* project the geopotential, virtual temperature,
* specific humidity onto that grid
*
*arguments
*______________________________________________________________________
* | |
* NAME | DESCRIPTION |
*--------------------|-------------------------------------------------|
* Input only | |
* lat | vector of latitudes |
* lon | vector of longitudes |
*----------------------------------------------------------------------
*
*IMPLICITES
#include "e_fu.cdk"
#include "e_grids.cdk"
#include "e_anal.cdk"
#include "e_option.cdk"
#include "dcst.cdk"
#include "pilot.cdk"
#include "e_tr.cdk"
#include "e_schm.cdk"
#include "e_grdc.cdk"
#include "hgc.cdk"
*
integer e_rdhint3,e_bmfrd,e_liaccu
external e_rdhint3,e_bmfrd,e_liaccu
*
character*4 vtt,vhh
character*8 desc
character*6 inter
logical anyip_L,arret_L
integer i, j,k, ng, err, ip3,nis,njs
integer is,js,jn,iw,ie,jw,njw,niw,nisc,njsc
real pr1,pr2, dummy
real c1, c2, mul
real, dimension (:), allocatable:: tt,td,es,hu,p0,wk2,qqn,pipn,fin
real, dimension (:,:), allocatable :: ttn,hun
*
*---------------------------------------------------------------------
*
if (e_schm_offline_l) then
call e_intthm_offline( )
return
endif
c1 = Dcst_tcdk_8
c2 = 10. * Dcst_grav_8
vtt=vt//' '
vhh=vh//' '
*
if (Pil_bmf_L) then
nis=nifi
njs=njfi
else
nis=e_Grdc_ni
njs=e_Grdc_nj
endif
ng = nis*njs
*
allocate(tt(ng),td(ng),es(ng),hu(ng),p0(ng),wk2(ng))
*
write(6,1001)
*
* For searching the GZ,HU,TT,VT records,
* correct IP1 targets must be found
*
anyip_L = .false.
arret_L = .true.
if ( gletaanl .or. glsiganl .or. glhybanl ) then
write(6,*)
$ 'ANALYSIS IS IN SIGMA OR ETA OR HYBRID COORDINATES'
*
if (.not.Pil_bmf_L)
$ allocate(ttn(ng,lv),hun(ng,lv),fin(ng),qqn(ng),pipn(ng))
*
do k=1,lv
if (e_rdhint3 (hu,dstf_gid,nis,njs,'HU ',na(k),ip2a,
$ ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
*
anal_hav(1) = e_rdhint3 (tt,dstf_gid,nis,njs,vtt,na(k),
$ ip2a,ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6)
if (anal_hav(1).lt.0) goto 55
*
tt(:) = tt(:) + c1
*
if (vt.eq.'TT') call mfotvt (tt,tt,hu,ng,1,ng)
if (Pil_bmf_L) then
call e_bmfsplitxy2 (hu,nis,njs,'HU ',k,lv,pni,0,0,0)
call e_bmfsplitxy2 (tt,nis,njs,'VT ',k,lv,pni,0,0,0)
else
call e_fill_3df ( tt,ttn,nis,njs,lv,k,1.0,0.0)
call e_fill_3df ( hu,hun,nis,njs,lv,k,1.0,0.0)
endif
end do
*
if (Pil_bmf_L) then
err = e_bmfrd (dstf_gid, nis, njs, 'P0 ', 0., 100., -1,
$ 1, anyip_L,arret_L,'CUBIC')
else
err = e_rdhint3 (wk2,dstf_gid,nis,njs,'P0 ',na(k),
$ ip2a,ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6)
if (err.lt.0) goto 55
p0 (:) = wk2(:)*100.
qqn(:) = alog(p0(:))
endif
*
if (.not.Pil_bmf_L) then
err = e_rdhint3 (wk2,dstf_gid,nis,njs,'GZ ',na(lv),
$ ip2a,ip3a,' ',tva,.false.,.false.,'CUBIC',e_fu_anal,6)
if (err.lt.0) goto 55
* fill the bottom level for fin
call e_fill_3df ( wk2,fin,nis,njs,1,1,c2,0.0)
else if (anal_hav(1).eq.0) then
err = e_bmfrd (dstf_gid, nis, njs, 'GZ ', 0., c2,na,
$ lv, anyip_L,arret_L,'CUBIC' )
else
err = e_bmfrd (dstf_gid, nis, njs, 'GZ ', 0., c2,na(lv),
$ 1, anyip_L,arret_L,'CUBIC' )
err = e_rdhint3 (wk2,dstf_gid,nis,njs,'GZ ',na(lv),
$ ip2a,ip3a,' ',tva,.false.,.false.,'CUBIC',e_fu_anal,6)
wk2(:)=wk2(:)*c2
endif
*
if (.not.Pil_bmf_L) then
pipn(:)=exp(qqn(:)) - z_8(lv)
if (Pil_bcs_hollow_L) then
*
call e_write_bcs (ttn,nis,njs,
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_jn,e_grdc_njs,
$ e_grdc_iw,e_grdc_ie,e_grdc_niw,e_grdc_jw,e_grdc_njw,
$ lv, 'TT ',unf_casc)
call e_write_bcs (fin,nis,njs,
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_jn,e_grdc_njs,
$ e_grdc_iw,e_grdc_ie,e_grdc_niw,e_grdc_jw,e_grdc_njw,
$ 1 , 'PHI ',unf_casc)
call e_write_bcs (pipn,nis,njs,
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_jn,e_grdc_njs,
$ e_grdc_iw,e_grdc_ie,e_grdc_niw,e_grdc_jw,e_grdc_njw,
$ 1 , 'PIPT',unf_casc)
call e_write_bcs (hun,nis,njs,
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_jn,e_grdc_njs,
$ e_grdc_iw,e_grdc_ie,e_grdc_niw,e_grdc_jw,e_grdc_njw,
$ lv, 'HU ',unf_casc)
*
else
*
call e_write_3df ( ttn,nis,njs,lv,'TT ',unf_casc)
call e_write_3df ( fin,nis,njs,1,'PHI ',unf_casc)
call e_write_3df ( pipn,nis,njs,1,'PIPT',unf_casc)
call e_write_3df ( hun,nis,njs,lv,'HU ',unf_casc)
*
endif
endif
*
elseif ( glecmanl ) then
write(6,*) 'ANALYSIS IS ECMWF COORDINATES'
*
anal_hav(1)=1
*
do k=1,lv
ip3 = int(rna(k))
if (e_rdhint3 (hu,dstf_gid,nis,njs,'HU ',na(k),-1,
$ ip3,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
if (e_rdhint3 (tt,dstf_gid,nis,njs,vtt,na(k),-1,
$ ip3,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
do i=1,ng
tt(i) = tt(i) + c1
enddo
if (vt.eq.'TT') call mfotvt (tt,tt,hu,ng,1,ng)
call e_bmfsplitxy2 (hu,nis,njs,'HU ',k,lv,pni,0,0,0)
call e_bmfsplitxy2 (tt,nis,njs,'VT ',k,lv,pni,0,0,0)
end do
*
* For ECMWF analyses, the log of pressure (in pa) is stored in
* the variable 2P
*
if (e_rdhint3 (p0,dstf_gid,nis,njs,'2P ',-1,
$ -1,-1,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
do i=1,ng
p0(i) = exp(p0(i))
enddo
call e_bmfsplitxy2 (p0,nis,njs,'P0 ',1,1,pni,0,0,0)
err = e_bmfrd (dstf_gid, nis, njs, 'GZ ', 0., c2, -1,
$ 1, .true.,arret_L )
*
* read temperature and dew point temperature at the surface,
* transform into virtual
* temperature and specific humidity, store in TS, and HE
*
if (e_rdhint3 (tt,dstf_gid,nis,njs,'TS ',-1,
$ -1,-1,' ',' ',.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
if (e_rdhint3 (hu,dstf_gid,nis,njs,'TD ',-1,
$ -1,-1,' ',' ',.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
do i=1,ng
hu(i) = tt(i) - hu(i) ! dew point depression
tt(i) = tt(i) + c1
enddo
call mesahu(hu, hu, tt, 1, p0, 3, .true., Anal_cond, ng, 1, ng)
call mfotvt(tt, tt, hu, ng, 1, ng)
call e_bmfsplitxy2 (hu,nis,njs,'HE ',1,1,pni,0,0,0)
call e_bmfsplitxy2 (tt,nis,njs,'TE ',1,1,pni,0,0,0)
*
else
*
write(6,*)'ANALYSIS IS IN PRESSURE COORDINATES'
anal_hav(1) = e_bmfrd ( dstf_gid, nis, njs, 'GZ ', 0., 10.,
$ na,lv, anyip_L,arret_L,'CUBIC' )
if (vh.eq.'ES') then
err = e_bmfrd ( dstf_gid, nifi, njfi, vhh , 0., 1. ,
$ na,lv, anyip_L,arret_L,'CUBIC' )
elseif (vh.eq.'TD' .or.
$ vh.eq.'HU' .or.
$ vh.eq.'HR') then
do k=1,lv
*
if (vh.eq.'HU' .or.
$ vh.eq.'HR') then
if (e_rdhint3 (hu,dstf_gid,nifi,njfi,vhh,na(k),ip2a,
$ ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
elseif (vh.eq.'TD') then
if (e_rdhint3 (es,dstf_gid,nifi,njfi,vhh,na(k),ip2a,
$ ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
endif
*
if (e_rdhint3 (tt,dstf_gid,nifi,njfi,vtt,na(k),ip2a,
$ ip3a,' ',tva,.true.,.false.,'CUBIC',e_fu_anal,6).lt.0)
$ goto 55
*
do i=1,ng
tt(i) = tt(i) + c1
enddo
rna(k)=rna(k)*100.
*
if (vh.eq.'HU') then
call mhuaes( es, hu, tt, rna(k), dummy, 0,
$ vt.eq.'TT' , Anal_cond, ng, 1, ng )
elseif (vh.eq.'HR') then
call mhraes( es, hu, tt, rna(k), dummy, 0,
$ vt.eq.'TT' , Anal_cond, ng, 1, ng )
elseif (vh.eq.'TD') then
do i=1,ng
es(i) = max( tt(i)-td(i),0.0 )
enddo
endif
*
call e_bmfsplitxy2 (es,nifi,njfi,'ES ',k,lv,pni,0,0,0)
*
end do
endif
*
endif
*
anyip_L = .true.
do i=1,E_tr3d_ntr
E_trname_S(i)=E_tr3d_name_S(i)
if ( E_tr3d_name_S(i)(3:4).eq.'T1'.or.
% E_tr3d_name_S(i)(3:4).eq.'T0' )
% E_trname_S(i) = E_Tr3d_name_S(i)(1:2)//' '
enddo
*
do 80 i=1,E_tr3d_ntr
* For tracer variables, search does not have to be successful
arret_L = .false.
if (Pil_bmf_L) then
do k=1,lv
if (e_rdhint3 (hu,dstf_gid,nis,njs,
$ E_tr3d_name_S(i),na(k),ip2a,ip3a,' ',tva,
$ .true.,.false.,'CUBIC',e_fu_anal,6).ge.0) then
call e_bmfsplitxy2 (hu,nis,njs,E_trname_S(i),
$ k,lv,pni,0,0,0)
endif
enddo
else
* BCS or 3DF files
do k=1,lv
if (e_rdhint3 (wk2,dstf_gid,nis,njs,
$ E_tr3d_name_S(i),na(k),ip2a,ip3a,' ',tva,
$ .true.,.false.,'CUBIC',e_fu_anal,6).ge.0) then
call e_fill_3df ( wk2,hun,nis,njs,lv,k,1.0,0.0)
else
wk2(:)=E_tr3d_sval(i)
call e_fill_3df ( wk2,hun,nis,njs,lv,k,1.0,0.0)
endif
enddo
if (Pil_bcs_hollow_L) then
call e_write_bcs (hun,nis,njs,
$ e_grdc_is,e_grdc_nis,e_grdc_js,e_grdc_jn,e_grdc_njs,
$ e_grdc_iw,e_grdc_ie,e_grdc_niw,e_grdc_jw,e_grdc_njw,
$ lv, E_trname_S(i),unf_casc)
else
call e_write_3df ( hun,nis,njs,lv,E_trname_S(i),unf_casc)
endif
endif
80 continue
*
deallocate(tt,td,es,hu,wk2,p0)
if (.not.Pil_bmf_L) deallocate(ttn,hun,fin,qqn,pipn)
*
1001 format(/,'COMPUTE TT, HU and GZ (S/R E_INTTHM)',/,25('+'))
*
101 format ('|',2x,' ATMOSPHERIC FIELDS. VALID FOR:',1x,a16,1x,'|')
110 format ('|',2x,'Names',2x,'|',' STD ',
$ '| Start | Length | Mul | SEQ | H.INTRP |')
130 format ('|',9('-'),'+',5('-'),'+',8('-'),'+',8('-'),'+',5('-'),
$ '+',5('-'),'+',10('-'),'|')
*
return
55 call e_arret( 'e_intthm' )
*------------------------------------------------------------------
*
end