Line data Source code
1 0 : subroutine test_akima_sg
2 : use interp_2d_lib_sg
3 :
4 : ! Test for the RGBI3P_sg/RGSF3P_sg subroutine package
5 :
6 : ! Hiroshi Akima
7 : ! U.S. Department of Commerce, NTIA/ITS
8 : ! Version of 1995/08
9 :
10 : ! This program calls the RGBI3P_sg and RGSF3P_sg subroutines.
11 :
12 : ! This program requires no input data files.
13 :
14 : ! This program creates the TPRG3P data file. All elements of
15 : ! the DZI array in the data file are expected to be zero.
16 :
17 : ! Specification statements
18 : ! .. Parameters ..
19 : integer :: NXD,NYD,NXI
20 : real :: XIMN,XIMX
21 : integer :: NYI
22 : real :: YIMN,YIMX
23 : parameter (NXD=9,NYD=11,NXI=19,XIMN=-0.5,XIMX=8.5,NYI=23,YIMN=-0.5,YIMX=10.5)
24 :
25 : ! .. Local Scalars ..
26 0 : real :: ANXIM1,ANYIM1,DXI,DYI
27 : integer :: IER,ISEC,IXD,IXI,IXIMN,IXIMX,IYD,IYDR,IYI,IYIR,MD,NYDO2
28 : character(len=9) :: NMPR
29 : character(len=6) :: NMWF
30 :
31 : ! .. Local Arrays ..
32 0 : real :: DZI(NXI,NYI),WK(3,NXD,NYD),XD(NXD),XI(NXI),YD(NYD),YI(NYI),ZD(NXD,NYD),ZI(NXI,NYI),ZIE(NXI,NYI)
33 : character(len=9) :: NMSR(2)
34 : character(len=20) :: LBL(2)
35 :
36 : ! .. Intrinsic Functions ..
37 : INTRINSIC MOD,real
38 :
39 : ! Data statements
40 : DATA NMPR/'TPRG3P_sg'/,NMWF/'WFRG3P'/,NMSR/'RGBI3P_sg','RGSF3P_sg'/,LBL/'Calculated ZI Values','Differences '/
41 : DATA XD/0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0/
42 : DATA YD/0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0/
43 : DATA ZD/9*0.0,9*0.0,9*0.0,3.2,0.7,7*0.0,7.4,4.8,1.4,
44 : & 0.1,5*0.0,12.0,8.0,5.3,2.9,0.6,4*0.0,16.8,14.4,
45 : & 8.1,6.9,6.2,0.6,0.1,2*0.0,21.8,20.5,12.8,17.6,
46 : & 5.8,7.6,0.8,0.6,0.6,22.4,22.5,14.6,22.5,4.7,7.2,
47 : & 1.8,2.1,2.1,37.2,40.0,27.0,41.3,14.1,24.5,17.3,
48 : & 20.2,20.8,58.2,61.5,47.9,62.3,34.6,45.5,38.2,
49 : & 41.2,41.7/
50 : DATA ((ZIE(IXI,IYI),IXI=1,NXI),IYI=1,5)/-.847,-.533,
51 : & -.274,-.117,-.031,.000,.000,.000,.000,.000,.000,
52 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
53 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
54 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
55 : & .401,.250,.119,.043,.011,.000,.000,.000,.000,
56 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
57 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
58 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
59 : & .000,.000,-.665,-.376,-.143,-.033,-.007,.000,
60 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
61 : & .000,.000,.000,.000/
62 : DATA ((ZIE(IXI,IYI),IXI=1,NXI),IYI=6,10)/.000,.000,
63 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
64 : & .000,.000,.000,.000,.000,.000,.000,.000,2.449,
65 : & 1.368,.537,.149,.025,.000,.000,.000,.000,.000,
66 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
67 : & 5.083,3.200,1.642,.700,.187,.000,.000,.000,.000,
68 : & .000,.000,.000,.000,.000,.000,.000,.000,.000,
69 : & .000,6.588,5.234,3.878,2.542,1.188,.253,.026,
70 : & .026,.007,.000,.000,.000,.000,.000,.000,.000,
71 : & .000,.000,.000,8.017,7.400,6.400,4.800,2.963,
72 : & 1.400,.457,.100,.027,.000,.000,.000,.000,.000,
73 : & .000,.000,.000,.000,.000/
74 : DATA ((ZIE(IXI,IYI),IXI=1,NXI),IYI=11,15)/11.055,
75 : & 9.670,8.083,6.305,4.786,3.421,2.043,1.112,.565,
76 : & .131,-.019,.000,.000,.000,.000,.000,.000,.000,
77 : & .000,14.492,12.000,9.746,8.000,6.594,5.300,4.081,
78 : & 2.900,1.697,.600,.059,.000,.000,.000,.000,.000,
79 : & .000,.000,.000,15.999,14.376,12.657,10.774,8.620,
80 : & 6.659,5.291,4.392,3.926,3.005,1.223,.139,.051,
81 : & .025,.009,.000,.000,.000,-.005,15.525,16.800,
82 : & 16.749,14.400,10.956,8.100,6.735,6.900,7.298,
83 : & 6.200,3.010,.600,.248,.100,.024,.000,.006,.000,
84 : & -.025,15.876,19.280,20.563,17.856,13.242,10.219,
85 : & 10.577,11.999,10.170,7.053,5.198,3.543,1.831,
86 : & .350,-.130,.168,.408,.168,-.224/
87 : DATA ((ZIE(IXI,IYI),IXI=1,NXI),IYI=16,20)/17.700,
88 : & 21.800,23.531,20.500,15.087,12.800,15.817,17.600,
89 : & 11.477,5.800,6.988,7.600,4.410,.800,-.392,.600,
90 : & 1.261,.600,-.417,17.913,22.788,24.944,21.881,
91 : & 16.302,14.382,18.557,20.807,11.916,4.561,7.327,
92 : & 8.518,5.133,1.284,-.013,1.201,1.998,1.200,-.065,
93 : & 16.383,22.400,25.330,22.500,16.796,14.600,19.172,
94 : & 22.500,13.159,4.700,6.689,7.200,4.392,1.800,
95 : & 1.150,2.100,2.734,2.100,1.025,18.109,26.756,
96 : & 31.311,28.143,21.004,18.237,24.236,28.979,17.970,
97 : & 7.469,10.467,11.985,9.022,6.833,6.901,8.292,
98 : & 9.186,8.524,7.101,24.667,37.200,44.007,40.000,
99 : & 30.508,27.000,34.974,41.300,27.136,14.100,20.473,
100 : & 24.500,20.557,17.300,17.639,20.200,21.826,20.800,
101 : & 18.458/
102 : DATA ((ZIE(IXI,IYI),IXI=1,NXI),IYI=21,23)/33.414,
103 : & 48.009,56.017,51.561,40.817,36.922,45.856,52.860,
104 : & 37.376,23.200,30.839,36.192,31.969,28.037,28.437,
105 : & 31.604,33.579,32.332,29.561,44.842,58.200,65.537,
106 : & 61.500,51.657,47.900,55.899,62.300,47.891,34.600,
107 : & 41.239,45.500,41.479,38.200,38.591,41.200,42.823,
108 : & 41.700,39.192,58.284,68.917,74.644,71.333,63.413,
109 : & 60.125,66.293,71.400,59.129,47.725,52.451,54.592,
110 : & 50.842,48.483,48.639,50.142,51.089,50.200,48.268/
111 :
112 : ! Calculation
113 : ! Opens the output file and writes the input data.
114 : ! OPEN (6,FILE=NMWF)
115 0 : NYDO2 = NYD/2
116 0 : write (6,FMT=9000) NMPR
117 0 : write (6,FMT=9010) XD
118 0 : do IYDR = 1,NYD
119 0 : if (MOD(IYDR-1,NYDO2) <= 1) write (6,FMT='(1X)')
120 0 : IYD = NYD + 1 - IYDR
121 0 : write (6,FMT=9020) YD(IYD), (ZD(IXD,IYD),IXD=1,NXD)
122 : end do
123 : ! Program check for the RGBI3P_sg subroutine
124 : ! - Performs interpolation and calculates the differences.
125 0 : DXI = XIMX - XIMN
126 0 : ANXIM1 = NXI - 1
127 0 : do IXI = 1,NXI
128 0 : XI(IXI) = XIMN + DXI*real(IXI-1)/ANXIM1
129 : end do
130 0 : DYI = YIMX - YIMN
131 0 : ANYIM1 = NYI - 1
132 0 : do IYI = 1,NYI
133 0 : YI(IYI) = YIMN + DYI*real(IYI-1)/ANYIM1
134 : end do
135 0 : do IYI = 1,NYI
136 0 : do IXI = 1,NXI
137 0 : if (IXI == 1 .and. IYI == 1) then
138 0 : MD = 1
139 : else
140 0 : MD = 2
141 : end if
142 0 : CALL interp_RGBI3P_sg(MD,NXD,NYD,XD,YD,ZD,1,XI(IXI),YI(IYI),ZI(IXI,IYI),IER,WK)
143 0 : if (IER > 0) STOP 1
144 0 : DZI(IXI,IYI) = ZI(IXI,IYI) - ZIE(IXI,IYI)
145 : end do
146 : end do
147 : ! - Writes the calculated results.
148 0 : write (6,FMT=9030) NMPR,NMSR(1),LBL(1)
149 0 : do ISEC = 1,2
150 0 : if (ISEC == 1) then
151 0 : IXIMN = 1
152 0 : IXIMX = 11
153 : else
154 0 : IXIMN = 9
155 0 : IXIMX = NXI
156 : end if
157 0 : write (6,FMT=9040) (XI(IXI),IXI=IXIMN,IXIMX)
158 0 : do IYIR = 1,NYI
159 0 : IYI = NYI + 1 - IYIR
160 0 : write (6,FMT=9050) YI(IYI), (ZI(IXI,IYI),IXI=IXIMN,IXIMX)
161 : end do
162 : end do
163 : ! - Writes the differences.
164 0 : write (6,FMT=9030) NMPR,NMSR(1),LBL(2)
165 0 : do ISEC = 1,2
166 0 : if (ISEC == 1) then
167 0 : IXIMN = 1
168 0 : IXIMX = 11
169 : else
170 0 : IXIMN = 9
171 0 : IXIMX = NXI
172 : end if
173 0 : write (6,FMT=9060) (XI(IXI),IXI=IXIMN,IXIMX)
174 0 : do IYIR = 1,NYI
175 0 : IYI = NYI + 1 - IYIR
176 0 : write (6,FMT=9050) YI(IYI),(DZI(IXI,IYI),IXI=IXIMN,IXIMX)
177 : end do
178 : end do
179 : ! Program check for the RGSF3P_sg subroutine
180 : ! - Performs surface fitting and calculates the differences.
181 0 : MD = 1
182 0 : call interp_RGSF3P_sg(MD,NXD,NYD,XD,YD,ZD,NXI,XI,NYI,YI,ZI,IER,WK)
183 0 : if (IER > 0) STOP 1
184 0 : do IYI = 1,NYI
185 0 : do IXI = 1,NXI
186 0 : DZI(IXI,IYI) = ZI(IXI,IYI) - ZIE(IXI,IYI)
187 : end do
188 : end do
189 : ! - Writes the calculated results.
190 0 : write (6,FMT=9030) NMPR,NMSR(2),LBL(1)
191 0 : do ISEC = 1,2
192 0 : if (ISEC == 1) then
193 0 : IXIMN = 1
194 0 : IXIMX = 11
195 : else
196 0 : IXIMN = 9
197 0 : IXIMX = NXI
198 : end if
199 0 : write (6,FMT=9040) (XI(IXI),IXI=IXIMN,IXIMX)
200 0 : do IYIR = 1,NYI
201 0 : IYI = NYI + 1 - IYIR
202 0 : write (6,FMT=9050) YI(IYI), (ZI(IXI,IYI),IXI=IXIMN,IXIMX)
203 : end do
204 : end do
205 : ! - Writes the differences.
206 0 : write (6,FMT=9030) NMPR,NMSR(2),LBL(2)
207 0 : do ISEC = 1,2
208 0 : if (ISEC == 1) then
209 0 : IXIMN = 1
210 0 : IXIMX = 11
211 : else
212 0 : IXIMN = 9
213 0 : IXIMX = NXI
214 : end if
215 0 : write (6,FMT=9060) (XI(IXI),IXI=IXIMN,IXIMX)
216 0 : do IYIR = 1,NYI
217 0 : IYI = NYI + 1 - IYIR
218 0 : write (6,FMT=9050) YI(IYI),(DZI(IXI,IYI),IXI=IXIMN,IXIMX)
219 : end do
220 : end do
221 0 : return
222 : ! Format statements
223 : 9000 FORMAT (A9,7X,'Original Data',/,/,/,/,35X,'ZD(XD,YD)')
224 : 9010 FORMAT (4X,'YD XD=',/,7X,F8.1,2 (1X,3F6.1,F7.1),/)
225 : 9020 FORMAT (1X,F6.1,F8.1,2 (1X,3F6.1,F7.1))
226 : 9030 FORMAT (/,A9,3X,'Program Check for ',A9,3X,A20)
227 : 9040 FORMAT (1X,/,38X,'ZI(XI,YI)',/,2X,'YI',3X,'XI=',/,5X,3F15.10,2F15.10,2F15.10,2F15.10,2F15.10,/)
228 : 9050 FORMAT (F5.2,3F15.10,2F15.10,2F15.10,2F15.10,2F15.10)
229 : 9060 FORMAT (1X,/,38X,'DZI(XI,YI)',/,2X,'YI',3X,'XI=',/,5X,3F15.10,2F15.10,2F15.10,2F15.10,2F15.10,/)
230 : end subroutine test_akima_sg
|
