GCC Code Coverage Report

Directory: ./
File: misc/regr_lint_m.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 0 60 0.0%
Branches: 0 172 0.0%
Line Branch Exec Source
1 MODULE regr_lint_m
2
3 USE assert_eq_m, ONLY: assert_eq
4 USE assert_m, ONLY: assert
5 USE interpolation, ONLY: hunt
6
7 IMPLICIT NONE
8
9 ! Purpose: Each procedure regrids by linear interpolation along dimension "ix"
10 ! the input field "vs" to the output field "vt".
11 ! Remark:
12 ! * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt)
13
14 ! Argument Type Description
15 !-------------------------------------------------------------------------------
16 ! INTEGER, INTENT(IN) :: ix Scalar dimension regridded <=rank(vs)
17 ! REAL, INTENT(IN) :: vs(*) Rank>=1 source grid field values
18 ! REAL, INTENT(IN) :: xs(:) Vector(ns) centers of source grid, asc. order
19 ! REAL, INTENT(IN) :: xt(:) Vector(nt) centers of target grid, asc. order
20 ! REAL, INTENT(OUT) :: vt(*) Rank>=1 regridded field
21
22 INTERFACE regr_lint
23 ! The procedures differ only from the rank of the input/output fields.
24 MODULE PROCEDURE regr1_lint, regr2_lint, regr3_lint, &
25 regr4_lint, regr5_lint
26 END INTERFACE
27
28 PRIVATE
29 PUBLIC :: regr_lint
30
31 CONTAINS
32
33
34 !-------------------------------------------------------------------------------
35 !
36 ✗ SUBROUTINE regr1_lint(ix, vs, xs, xt, vt)
37 !
38 !-------------------------------------------------------------------------------
39 ! Arguments:
40 INTEGER, INTENT(IN) :: ix
41 REAL, INTENT(IN) :: vs(:)
42 REAL, INTENT(IN) :: xs(:)
43 REAL, INTENT(IN) :: xt(:)
44 REAL, INTENT(OUT) :: vt(:)
45 !-------------------------------------------------------------------------------
46 ! Local variables:
47 INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
48 REAL :: r
49 !-------------------------------------------------------------------------------
50 ✗ CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
51 ✗ is = -1 ! go immediately to bisection on first call to "hunt"
52 ✗ DO it=1,SIZE(xt)
53 ✗ CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
54 ✗ r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
55 ✗ vt(it)=r*vs(isb)+(1.-r)*vs(isb+1)
56 END DO
57
58 ✗ END SUBROUTINE regr1_lint
59 !
60 !-------------------------------------------------------------------------------
61
62
63 !-------------------------------------------------------------------------------
64 !
65 ✗ SUBROUTINE regr2_lint(ix, vs, xs, xt, vt)
66 !
67 !-------------------------------------------------------------------------------
68 ! Arguments:
69 INTEGER, INTENT(IN) :: ix
70 REAL, INTENT(IN) :: vs(:,:)
71 REAL, INTENT(IN) :: xs(:)
72 REAL, INTENT(IN) :: xt(:)
73 REAL, INTENT(OUT) :: vt(:,:)
74 !-------------------------------------------------------------------------------
75 ! Local variables:
76 INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
77 REAL :: r
78 !-------------------------------------------------------------------------------
79 ✗ CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
80 ✗ is = -1 ! go immediately to bisection on first call to "hunt"
81 ✗ DO it=1,SIZE(xt)
82 ✗ CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
83 ✗ r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
84 ✗ IF(ix==1) vt(it,:)=r*vs(isb,:)+(1.-r)*vs(isb+1,:)
85 ✗ IF(ix==2) vt(:,it)=r*vs(:,isb)+(1.-r)*vs(:,isb+1)
86 END DO
87
88 ✗ END SUBROUTINE regr2_lint
89 !
90 !-------------------------------------------------------------------------------
91
92
93 !-------------------------------------------------------------------------------
94 !
95 ✗ SUBROUTINE regr3_lint(ix, vs, xs, xt, vt)
96 !
97 !-------------------------------------------------------------------------------
98 ! Arguments:
99 INTEGER, INTENT(IN) :: ix
100 REAL, INTENT(IN) :: vs(:,:,:)
101 REAL, INTENT(IN) :: xs(:)
102 REAL, INTENT(IN) :: xt(:)
103 REAL, INTENT(OUT) :: vt(:,:,:)
104 !-------------------------------------------------------------------------------
105 ! Local variables:
106 INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
107 REAL :: r
108 !-------------------------------------------------------------------------------
109 ✗ CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
110 ✗ is = -1 ! go immediately to bisection on first call to "hunt"
111 ✗ DO it=1,SIZE(xt)
112 ✗ CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
113 ✗ r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
114 ✗ IF(ix==1) vt(it,:,:)=r*vs(isb,:,:)+(1.-r)*vs(isb+1,:,:)
115 ✗ IF(ix==2) vt(:,it,:)=r*vs(:,isb,:)+(1.-r)*vs(:,isb+1,:)
116 ✗ IF(ix==3) vt(:,:,it)=r*vs(:,:,isb)+(1.-r)*vs(:,:,isb+1)
117 END DO
118
119 ✗ END SUBROUTINE regr3_lint
120 !
121 !-------------------------------------------------------------------------------
122
123
124 !-------------------------------------------------------------------------------
125 !
126 ✗ SUBROUTINE regr4_lint(ix, vs, xs, xt, vt)
127 !
128 !-------------------------------------------------------------------------------
129 ! Arguments:
130 INTEGER, INTENT(IN) :: ix
131 REAL, INTENT(IN) :: vs(:,:,:,:)
132 REAL, INTENT(IN) :: xs(:)
133 REAL, INTENT(IN) :: xt(:)
134 REAL, INTENT(OUT) :: vt(:,:,:,:)
135 !-------------------------------------------------------------------------------
136 ! Local variables:
137 INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
138 REAL :: r
139 !-------------------------------------------------------------------------------
140 ✗ CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
141 ✗ is = -1 ! go immediately to bisection on first call to "hunt"
142 ✗ DO it=1,SIZE(xt)
143 ✗ CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
144 ✗ r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
145 ✗ IF(ix==1) vt(it,:,:,:)=r*vs(isb,:,:,:)+(1.-r)*vs(isb+1,:,:,:)
146 ✗ IF(ix==2) vt(:,it,:,:)=r*vs(:,isb,:,:)+(1.-r)*vs(:,isb+1,:,:)
147 ✗ IF(ix==3) vt(:,:,it,:)=r*vs(:,:,isb,:)+(1.-r)*vs(:,:,isb+1,:)
148 ✗ IF(ix==4) vt(:,:,:,it)=r*vs(:,:,:,isb)+(1.-r)*vs(:,:,:,isb+1)
149 END DO
150
151 ✗ END SUBROUTINE regr4_lint
152 !
153 !-------------------------------------------------------------------------------
154
155
156 !-------------------------------------------------------------------------------
157 !
158 ✗ SUBROUTINE regr5_lint(ix, vs, xs, xt, vt)
159 !
160 !-------------------------------------------------------------------------------
161 ! Arguments:
162 INTEGER, INTENT(IN) :: ix
163 REAL, INTENT(IN) :: vs(:,:,:,:,:)
164 REAL, INTENT(IN) :: xs(:)
165 REAL, INTENT(IN) :: xt(:)
166 REAL, INTENT(OUT) :: vt(:,:,:,:,:)
167 !-------------------------------------------------------------------------------
168 ! Local variables:
169 INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
170 REAL :: r
171 !-------------------------------------------------------------------------------
172 ✗ CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
173 ✗ is = -1 ! go immediately to bisection on first call to "hunt"
174 ✗ DO it=1,SIZE(xt)
175 ✗ CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
176 ✗ r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
177 ✗ IF(ix==1) vt(it,:,:,:,:)=r*vs(isb,:,:,:,:)+(1.-r)*vs(isb+1,:,:,:,:)
178 ✗ IF(ix==2) vt(:,it,:,:,:)=r*vs(:,isb,:,:,:)+(1.-r)*vs(:,isb+1,:,:,:)
179 ✗ IF(ix==3) vt(:,:,it,:,:)=r*vs(:,:,isb,:,:)+(1.-r)*vs(:,:,isb+1,:,:)
180 ✗ IF(ix==4) vt(:,:,:,it,:)=r*vs(:,:,:,isb,:)+(1.-r)*vs(:,:,:,isb+1,:)
181 ✗ IF(ix==5) vt(:,:,:,:,it)=r*vs(:,:,:,:,isb)+(1.-r)*vs(:,:,:,:,isb+1)
182 END DO
183
184 ✗ END SUBROUTINE regr5_lint
185 !
186 !-------------------------------------------------------------------------------
187
188
189 !-------------------------------------------------------------------------------
190 !
191 ✗ SUBROUTINE check_size(ix,svs,svt,nxs,nxt,ns,nt)
192 !
193 !-------------------------------------------------------------------------------
194 ! Arguments:
195 INTEGER, INTENT(IN) :: ix, svs(:), svt(:), nxs, nxt
196 INTEGER, INTENT(OUT) :: ns, nt
197 !-------------------------------------------------------------------------------
198 ! Local variables:
199 INTEGER :: rk, is
200 CHARACTER(LEN=80) :: sub, msg
201 !-------------------------------------------------------------------------------
202 ✗ rk=SIZE(svs)
203 ✗ WRITE(sub,'(a,2i0,a)')"regr",rk,ix,"_lint"
204 ✗ CALL assert(ix>=1.AND.ix<=rk,TRIM(sub)//": ix exceeds fields rank")
205 ✗ DO is=1,rk; IF(is==ix) CYCLE
206 ✗ WRITE(msg,'(a,i1)')TRIM(sub)//" n",is
207 ✗ CALL assert(svs(is)==svt(is),msg)
208 END DO
209 ✗ ns=assert_eq(svs(ix),nxs,TRIM(sub)//" ns")
210 ✗ nt=assert_eq(svt(ix),nxt,TRIM(sub)//" nt")
211
212 ✗ END SUBROUTINE check_size
213 !
214 !-------------------------------------------------------------------------------
215
216 END MODULE regr_lint_m
217 !
218 !-------------------------------------------------------------------------------
219
220