copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
***s/r e_gettopo_h
subroutine e_gettopo_h ( topo_h ) 2,6
implicit none
*
real topo_h(*)
*
*AUTHOR M. Desgagne November 2003
*
*IMPLICIT
#include "lcldim.cdk"
#include "yomdyn.cdk"
#include "yomdyn1.cdk"
#include "grd.cdk"
#include "rec.cdk"
#include "hinterpo.cdk"
#include "filename.cdk"
#include "topo.cdk"
*
integer fnom,fstouv,fstfrm,fclos,s_rdhint,longueur
external fnom,fstouv,fstfrm,fclos,s_rdhint,longueur
character*2 typvar
character*8 etk
integer i,ier,err_me,iun,deln
real wk(Grd_ni*Grd_nj),nudif
*---------------------------------------------------------------------
*
write (6,1001) geophy(1:longueur(geophy))
*
iun = 0
ier = fnom (iun,geophy ,'RND+OLD+R/O',0)
ier = fstouv (iun,'RND')
if (ier.lt.0) then
write (6,1002) geophy(1:longueur(geophy))
stop
endif
*
etk = ' '
typvar = ' '
err_me = s_rdhint
(wk,xpx,ypx,Grd_ni,Grd_nj,'ME',-1,-1,
$ -1,-1,etk,typvar,.false.,hint_ntr,iun,6)
*
if (err_me.ge.0) then
*
if (topo_flt_coef_mc2ntr.gt.0.) then
call xyfilt
( topo_h, wk, topo_flt_coef_mc2ntr,
$ Grd_ni,Grd_nj,1, Grd_ni,Grd_nj,1 )
do i=1,Grd_ni*Grd_nj
wk(i) = topo_h(i)
end do
endif
*
if (topo_flt_nu.gt.0) then
nudif=topo_flt_nu
998 do i=1,Grd_ni*Grd_nj
topo_h(i) = wk(i)
wk(i) = 0.0
end do
do i=2,topo_flt_deln,2
call smth2d_pil
(wk,topo_h,Grd_ni,Grd_nj,1,0.25)
end do
nudif=nudif-0.25
if (nudif.gt.0.0) goto 998
endif
*
do i=1,Grd_ni*Grd_nj
topo_h(i) = max(0.,wk(i)*real(gnmtn))
end do
*
call dc_topo
(topo_h,maxhh01_h,maxhh02_h,Grd_ni,Grd_nj)
call statfld
( topo_h,'ME', 1, "e_gettopo_h", .false.,1,Grd_ni,
$ 1,Grd_nj,1,1,1,1,Grd_ni,Grd_nj,1)
call statfld
( topo_h(Grd_ni*Grd_nj+1),'ME', 2, "e_gettopo_h",
$ .false.,1,Grd_ni,1,Grd_nj,1,1,1,1,Grd_ni,Grd_nj,1)
else
write (6,1005) 'ME'
stop
endif
*
ier = fstfrm (iun)
ier = fclos (iun)
*
1001 format (/' PROCESSING TARGET TOPOGRAPHY FROM FILE: ',a)
1002 format ( ' FILE: ',a,' NOT AVAILABLE --- ABORT ---'/)
1005 format (' TARGET TOPOGRAPHY: 'a,' NOT AVAILABLE --- ABORT ---'/)
*---------------------------------------------------------------------
*
return
end
*