regrd2.f File Reference

Go to the source code of this file.

Functions/Subroutines
program	regrd2
	Part of the NADCON5 NADCON5 Core Library , regrid data. More...
subroutine	bquad1 (h, gla, glo, ival)
subroutine	bquad2 (z, gla, glo, val)
real function	qterp1 (x, if0, if1, if2)
real function	qterp2 (x, f0, f1, f2)
subroutine	r1 (lin, h, nla, nlo)
subroutine	r2 (lin, z, nla, nlo)

Function/Subroutine Documentation

subroutine bquad1	(	integer, dimension(nla,nlo)	h,
			gla,
			glo,
			ival
	)

Definition at line 169 of file regrd2.f.

Referenced by regrd2().

*** compute biquadratic interpolation, integer version
*** logic not tested for '0/360 meridian wraparound'

      implicit double precision(a-h,o-z)
      integer h(nla,nlo)
      real*4 x,y,fx0,fx1,fx2,val,qterp1,qterp2
      external qterp1,qterp2
      common/gstuff/glamn,dgla,glamx,glomn,dglo,glomx,nla,nlo,nclip

      if(gla.lt.glamn.or.gla.gt.glamx.or.
     *   glo.lt.glomn.or.glo.gt.glomx) then
        nclip=nclip+1
        ival=2147483647
      else

*** within grid boundaries, get indicies in the grid

        ix=(glo-glomn)/dglo+1.d0
        ix1=ix+1
        ix2=ix+2

*** check if edge collision

    1   if(ix2.gt.nlo)then
          ix =ix -1
          ix1=ix1-1
          ix2=ix2-1
          go to 1
        endif

        x=(glo-dglo*(ix-1)-glomn)/dglo

*** move grid to get nearer center of 3 x 3

        if(x.lt.0.5.and.ix.gt.1)then
          ix =ix -1
          ix1=ix1-1
          ix2=ix2-1
          x=x+1.
        endif
        if(x.lt.0..or.x.gt.2.) stop 55555

*** now do it for y

        jy=(gla-glamn)/dgla+1.d0
        jy1=jy+1
        jy2=jy+2
    2   if(jy2.gt.nla)then
          jy =jy -1
          jy1=jy1-1
          jy2=jy2-1
          go to 2
        endif
        y=(gla-dgla*(jy-1)-glamn)/dgla
        if(y.lt.0.5.and.jy.gt.1)then
          jy =jy -1
          jy1=jy1-1
          jy2=jy2-1
          y=y+1.
        endif
        if(y.lt.0..or.y.gt.2.) stop 33333

        fx0=qterp1(x, h(jy ,ix ), h(jy ,ix1), h(jy ,ix2))
        fx1=qterp1(x, h(jy1,ix ), h(jy1,ix1), h(jy1,ix2))
        fx2=qterp1(x, h(jy2,ix ), h(jy2,ix1), h(jy2,ix2))
        val=qterp2(y, fx0       , fx1       , fx2       )
        ival=nint(val)
      endif

      return

Here is the caller graph for this function:

subroutine bquad2	(	real*4, dimension(nla,nlo)	z,
			gla,
			glo,
			val
	)

Definition at line 242 of file regrd2.f.

Referenced by regrd2().

*** compute biquadratic interpolation, floating point version
*** logic not tested for '0/360 meridian wraparound'

      implicit double precision(a-h,o-z)
      real*4 z(nla,nlo)
      real*4 x,y,fx0,fx1,fx2,qterp2
      external qterp2
      common/gstuff/glamn,dgla,glamx,glomn,dglo,glomx,nla,nlo,nclip

      if(gla.lt.glamn.or.gla.gt.glamx.or.
     *   glo.lt.glomn.or.glo.gt.glomx) then
        nclip=nclip+1
        val=1.d30
      else

*** within grid boundaries, get indicies in the grid

        ix=(glo-glomn)/dglo+1.d0
        ix1=ix+1
        ix2=ix+2

*** check if edge collision

    1   if(ix2.gt.nlo)then
          ix =ix -1
          ix1=ix1-1
          ix2=ix2-1
          go to 1
        endif

        x=(glo-dglo*(ix-1)-glomn)/dglo

*** move grid to get nearer center of 3 x 3

        if(x.lt.0.5.and.ix.gt.1)then
          ix =ix -1
          ix1=ix1-1
          ix2=ix2-1
          x=x+1.
        endif
        if(x.lt.0..or.x.gt.2.) stop 66666

*** now do it for y

        jy=(gla-glamn)/dgla+1.d0
        jy1=jy+1
        jy2=jy+2
    2   if(jy2.gt.nla)then
          jy =jy -1
          jy1=jy1-1
          jy2=jy2-1
          go to 2
        endif
        y=(gla-dgla*(jy-1)-glamn)/dgla
        if(y.lt.0.5.and.jy.gt.1)then
          jy =jy -1
          jy1=jy1-1
          jy2=jy2-1
          y=y+1.
        endif
        if(y.lt.0..or.y.gt.2.) stop 44444

        fx0=     qterp2(x, z(jy ,ix ), z(jy ,ix1), z(jy ,ix2))
        fx1=     qterp2(x, z(jy1,ix ), z(jy1,ix1), z(jy1,ix2))
        fx2=     qterp2(x, z(jy2,ix ), z(jy2,ix1), z(jy2,ix2))
        val=dble(qterp2(y, fx0       , fx1       , fx2       ))
      endif

      return

Here is the caller graph for this function:

real function qterp1	(		x,
			if0,
			if1,
			if2
	)

Definition at line 314 of file regrd2.f.

*** linear quadratic interpolation from equally spaced values
*** uses newton-gregory forward polynomial
*** x ranges from 0 thru 2.  (thus s = x)

*** forward differences

      idf0 =if1 -if0
      idf1 =if2 -if1
      id2f0=idf1-idf0

      qterp1=if0 + x*idf0 + 0.5*x*(x-1.)*id2f0

      return

real function qterp2	(		x,
			f0,
			f1,
			f2
	)

Definition at line 330 of file regrd2.f.

*** linear quadratic interpolation from equally spaced values
*** uses newton-gregory forward polynomial
*** x ranges from 0 thru 2.  (thus s = x)

*** forward differences

      df0 =f1 -f0
      df1 =f2 -f1
      d2f0=df1-df0

      qterp2=f0 + x*df0 + 0.5*x*(x-1.)*d2f0

      return

subroutine r1	(		lin,
		integer, dimension(nla,nlo)	h,
			nla,
			nlo
	)

Definition at line 346 of file regrd2.f.

Referenced by regrd2().

***  read records south to north (elements are west to east)

      implicit double precision(a-h,o-z)
      integer h(nla,nlo)

      do 1 i=1,nla
    1 read(lin) (h(i,j),j=1,nlo)

      return

Here is the caller graph for this function:

subroutine r2	(		lin,
		real*4, dimension(nla,nlo)	z,
			nla,
			nlo
	)

Definition at line 358 of file regrd2.f.

Referenced by regrd2().

***  read records south to north (elements are west to east)

      implicit double precision(a-h,o-z)
      real*4 z(nla,nlo)

      do 1 i=1,nla
    1 read(lin) (z(i,j),j=1,nlo)

      return

Here is the caller graph for this function: