copyright (C) 2001 MSC-RPN COMM %%%MC2%%%
*** s/r s_rdhint -- read and perform horizontal interpolation of scalars
*
integer function s_rdhint ( f, xp, yp, ni, nj, nomvar, date, 11
$ ip1, ip2, ip3, etik, typvar, anyip, interp, un1, stdo)
*
implicit none
*
character* (*) nomvar,interp,etik,typvar
logical anyip
integer ni, nj, date,ip1, ip2, ip3, un1, stdo
real f(*)
real*8 xp(*), yp(*)
*
*author
* Michel Desgagne - January 2001
*
*revision
* v2_21 - Desgagne M. - initial version
*
*implicites
#include "grd.cdk"
*
* NOTES: will return s_rdhint= -1 if nomvar is not found or if
* a problem occurs
* s_rdhint= 0 if nomvar is found with specified
* ip123 and no horizontal interpolation
* is required
* s_rdhint= 1 if nomvar is found and horizontal
* interpolation is performed
* s_rdhint= 2 if nomvar is found with no specific
* ip123 and no horizontal interpolation
* is required
**
integer fstinf,fstprm,fstluk
external fstinf,fstprm,fstluk
*
character*1 typ, grd
character*2 var
character*8 lab
character*256 intyp
logical tr_ip,must_interpo
integer dte, det, ipas, p1, p2, p3, g1, g2, g3, g4, bit,
$ dty, swa, lng, dlf, ubc, ex1, ex2, ex3
integer i,key,ni1,nj1,nk1,nic,njc,nkc,err,iunit,cnt
integer src_gid,ezqkdef,ezdefset,ezsetopt,ezsint
real r1,r2
real , dimension (:) , allocatable :: w1,xps,yps,xp_p
logical must_interpo_s
integer un_s,nic_s,njc_s,g1_s,g2_s,g3_s
data un_s,nic_s,njc_s,g1_s,g2_s,g3_s /-1,-1,-1,-1,-1,-1/
data must_interpo /.false./
save un_s,nic_s,njc_s,g1_s,g2_s,g3_s,must_interpo_s
*
*--------------------------------------------------------------------
*
s_rdhint = -1
key = fstinf(un1,ni1,nj1,nk1,date,etik,ip1,ip2,ip3,typvar,nomvar)
tr_ip = key.ge.0
*
if ( (.not.tr_ip) .and. (anyip) ) then
write(stdo,1000) nomvar,ip1,ip2,ip3
key = fstinf(un1,ni1,nj1,nk1,date,etik,-1,-1,-1,typvar,nomvar)
endif
if (key .lt. 0) then
write(stdo,2000) nomvar,ip1,ip2,ip3,date
return
endif
*
allocate (w1(ni1*nj1))
err = fstluk( w1, key, ni1,nj1,nk1)
err = fstprm (key, DTE, DET, IPAS, ni1, nj1, nk1, BIT, DTY, P1,
$ P2, P3, TYP, VAR, LAB, GRD, G1, G2, G3, G4, SWA,
$ LNG, DLF, UBC, EX1, EX2, EX3)
nic = ni1
njc = nj1
*
must_interpo = .false.
iunit = 0
if ((grd.ne.'Z').and.(grd.ne.'#')) then
must_interpo = .true.
else
if ((nic.ne.ni).or.(njc.ne.nj)) then
must_interpo = .true.
else
if ( (un_s.eq.un1).and.(nic_s.eq.nic).and.(njc_s.eq.njc)
$ .and.(g1_s.eq.g1 ).and.(g2_s .eq.g2 ).and.(g3_s .eq.g3 )
$ ) then
must_interpo = must_interpo_s
else
key = fstinf(un1,ni1,nj1,nk1,-1,etik,g1,g2,g3,' ','>>')
if ((key.lt.0).or.(ni1.ne.nic)) then
write(stdo,4000) nomvar
return
endif
allocate (xps(ni1))
err = fstluk( xps, key, ni1,nj1,nk1)
key = fstinf(un1,ni1,nj1,nk1,-1,etik,g1,g2,g3,' ','^^')
if ((key.lt.0).or.(nj1.ne.njc)) then
write (stdo,4010) nomvar
return
endif
allocate (yps(nj1))
err = fstluk( yps, key, ni1,nj1,nk1)
cnt = 0
do i=1,nic
if (abs((xps(i)-xp(i))/xps(i)).gt.1.e-5) then
must_interpo=.true.
cnt = cnt + 1
endif
end do
if (must_interpo.and.(real(cnt)/real(nic).le.0.2)) then
must_interpo=.false.
do i=1,nic
if (abs((xps(i)-xp(i))/xps(i)).gt.1.e-4)
$ must_interpo=.true.
end do
endif
if (must_interpo) goto 777
cnt = 0
do i=1,njc
r1 = yps(i)+91.
r2 = yp (i)+91.
if (abs((r1-r2)/r1).gt.1.e-5) then
must_interpo=.true.
cnt = cnt + 1
endif
end do
if (must_interpo.and.(real(cnt)/real(njc).le.0.2)) then
must_interpo=.false.
do i=1,njc
r1 = yps(i)+91.
r2 = yp (i)+91.
if (abs((r1-r2)/r1).gt.1.e-4)
$ must_interpo=.true.
end do
endif
777 deallocate (xps,yps)
un_s = un1
nic_s= nic
njc_s= njc
g1_s = g1
g2_s = g2
g3_s = g3
must_interpo_s = must_interpo
endif
endif
iunit = un1
end if
*
if ( must_interpo ) then
*
src_gid = ezqkdef(nic, njc, GRD, g1, g2, g3, g4, iunit)
err = ezdefset(Grd_id, src_gid )
err = ezsetopt('INTERP_DEGREE', interp)
*
write(stdo,9000) nomvar,ip1,ip2,ip3,interp
err = ezsint(f, w1)
s_rdhint = 1
*
else
*
s_rdhint = 0
write(stdo,5000) nomvar,ip1,ip2,ip3
if (.not.tr_ip) s_rdhint = 2
*
do i=1,ni*nj
f(i) = w1(i)
enddo
*
endif
*
999 deallocate (w1)
*
1000 format ( ' Warning: ',a2,' not found with ip123=', i10,2i5,/,
$ ' Will try to locate it with no specific ip123')
2000 format (/' Missing field: ',a2,' for ip1,ip3=:',i10,2i5,i12/)
4000 format (/' Can t find >> record describing ',a2,
$ ' grid -- ABORT --'/)
4010 format (/' Can t find ^^ record describing ',a2,
$ ' grid -- ABORT --'/)
5000 format (' NO horizontal interpolation: ',a2,' for ip123=',i10,2i5,
$ ' (S/R s_rdhint)')
9000 format (' Horizontal interpolation: ',a2,' for ip123=',i10,2i5,
$ ' TYPE: ',a8,' (S/R s_rdhint)')
*
*---------------------------------------------------------------------
*
return
end