MODULE regr_lint_m USE assert_eq_m, ONLY: assert_eq USE assert_m, ONLY: assert USE interpolation, ONLY: hunt IMPLICIT NONE ! Purpose: Each procedure regrids by linear interpolation along dimension "ix" ! the input field "vs" to the output field "vt". ! Remark: ! * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt) ! Argument Type Description !------------------------------------------------------------------------------- ! INTEGER, INTENT(IN) :: ix Scalar dimension regridded <=rank(vs) ! REAL, INTENT(IN) :: vs(*) Rank>=1 source grid field values ! REAL, INTENT(IN) :: xs(:) Vector(ns) centers of source grid, asc. order ! REAL, INTENT(IN) :: xt(:) Vector(nt) centers of target grid, asc. order ! REAL, INTENT(OUT) :: vt(*) Rank>=1 regridded field INTERFACE regr_lint ! The procedures differ only from the rank of the input/output fields. MODULE PROCEDURE regr1_lint, regr2_lint, regr3_lint, & regr4_lint, regr5_lint END INTERFACE PRIVATE PUBLIC :: regr_lint CONTAINS !------------------------------------------------------------------------------- ! SUBROUTINE regr1_lint(ix, vs, xs, xt, vt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix REAL, INTENT(IN) :: vs(:) REAL, INTENT(IN) :: xs(:) REAL, INTENT(IN) :: xt(:) REAL, INTENT(OUT) :: vt(:) !------------------------------------------------------------------------------- ! Local variables: INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1" REAL :: r !------------------------------------------------------------------------------- CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt) is = -1 ! go immediately to bisection on first call to "hunt" DO it=1,SIZE(xt) CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1) r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb)) vt(it)=r*vs(isb)+(1.-r)*vs(isb+1) END DO END SUBROUTINE regr1_lint ! !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! SUBROUTINE regr2_lint(ix, vs, xs, xt, vt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix REAL, INTENT(IN) :: vs(:,:) REAL, INTENT(IN) :: xs(:) REAL, INTENT(IN) :: xt(:) REAL, INTENT(OUT) :: vt(:,:) !------------------------------------------------------------------------------- ! Local variables: INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1" REAL :: r !------------------------------------------------------------------------------- CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt) is = -1 ! go immediately to bisection on first call to "hunt" DO it=1,SIZE(xt) CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1) r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb)) IF(ix==1) vt(it,:)=r*vs(isb,:)+(1.-r)*vs(isb+1,:) IF(ix==2) vt(:,it)=r*vs(:,isb)+(1.-r)*vs(:,isb+1) END DO END SUBROUTINE regr2_lint ! !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! SUBROUTINE regr3_lint(ix, vs, xs, xt, vt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix REAL, INTENT(IN) :: vs(:,:,:) REAL, INTENT(IN) :: xs(:) REAL, INTENT(IN) :: xt(:) REAL, INTENT(OUT) :: vt(:,:,:) !------------------------------------------------------------------------------- ! Local variables: INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1" REAL :: r !------------------------------------------------------------------------------- CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt) is = -1 ! go immediately to bisection on first call to "hunt" DO it=1,SIZE(xt) CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1) r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb)) IF(ix==1) vt(it,:,:)=r*vs(isb,:,:)+(1.-r)*vs(isb+1,:,:) IF(ix==2) vt(:,it,:)=r*vs(:,isb,:)+(1.-r)*vs(:,isb+1,:) IF(ix==3) vt(:,:,it)=r*vs(:,:,isb)+(1.-r)*vs(:,:,isb+1) END DO END SUBROUTINE regr3_lint ! !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! SUBROUTINE regr4_lint(ix, vs, xs, xt, vt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix REAL, INTENT(IN) :: vs(:,:,:,:) REAL, INTENT(IN) :: xs(:) REAL, INTENT(IN) :: xt(:) REAL, INTENT(OUT) :: vt(:,:,:,:) !------------------------------------------------------------------------------- ! Local variables: INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1" REAL :: r !------------------------------------------------------------------------------- CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt) is = -1 ! go immediately to bisection on first call to "hunt" DO it=1,SIZE(xt) CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1) r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb)) IF(ix==1) vt(it,:,:,:)=r*vs(isb,:,:,:)+(1.-r)*vs(isb+1,:,:,:) IF(ix==2) vt(:,it,:,:)=r*vs(:,isb,:,:)+(1.-r)*vs(:,isb+1,:,:) IF(ix==3) vt(:,:,it,:)=r*vs(:,:,isb,:)+(1.-r)*vs(:,:,isb+1,:) IF(ix==4) vt(:,:,:,it)=r*vs(:,:,:,isb)+(1.-r)*vs(:,:,:,isb+1) END DO END SUBROUTINE regr4_lint ! !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! SUBROUTINE regr5_lint(ix, vs, xs, xt, vt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix REAL, INTENT(IN) :: vs(:,:,:,:,:) REAL, INTENT(IN) :: xs(:) REAL, INTENT(IN) :: xt(:) REAL, INTENT(OUT) :: vt(:,:,:,:,:) !------------------------------------------------------------------------------- ! Local variables: INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1" REAL :: r !------------------------------------------------------------------------------- CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt) is = -1 ! go immediately to bisection on first call to "hunt" DO it=1,SIZE(xt) CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1) r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb)) IF(ix==1) vt(it,:,:,:,:)=r*vs(isb,:,:,:,:)+(1.-r)*vs(isb+1,:,:,:,:) IF(ix==2) vt(:,it,:,:,:)=r*vs(:,isb,:,:,:)+(1.-r)*vs(:,isb+1,:,:,:) IF(ix==3) vt(:,:,it,:,:)=r*vs(:,:,isb,:,:)+(1.-r)*vs(:,:,isb+1,:,:) IF(ix==4) vt(:,:,:,it,:)=r*vs(:,:,:,isb,:)+(1.-r)*vs(:,:,:,isb+1,:) IF(ix==5) vt(:,:,:,:,it)=r*vs(:,:,:,:,isb)+(1.-r)*vs(:,:,:,:,isb+1) END DO END SUBROUTINE regr5_lint ! !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- ! SUBROUTINE check_size(ix,svs,svt,nxs,nxt,ns,nt) ! !------------------------------------------------------------------------------- ! Arguments: INTEGER, INTENT(IN) :: ix, svs(:), svt(:), nxs, nxt INTEGER, INTENT(OUT) :: ns, nt !------------------------------------------------------------------------------- ! Local variables: INTEGER :: rk, is CHARACTER(LEN=80) :: sub, msg !------------------------------------------------------------------------------- rk=SIZE(svs) WRITE(sub,'(a,2i0,a)')"regr",rk,ix,"_lint" CALL assert(ix>=1.AND.ix<=rk,TRIM(sub)//": ix exceeds fields rank") DO is=1,rk; IF(is==ix) CYCLE WRITE(msg,'(a,i1)')TRIM(sub)//" n",is CALL assert(svs(is)==svt(is),msg) END DO ns=assert_eq(svs(ix),nxs,TRIM(sub)//" ns") nt=assert_eq(svt(ix),nxt,TRIM(sub)//" nt") END SUBROUTINE check_size ! !------------------------------------------------------------------------------- END MODULE regr_lint_m ! !-------------------------------------------------------------------------------