| 2 |
michaesp |
1 |
PROGRAM select
|
|
|
2 |
|
|
|
3 |
c **************************************************************
|
|
|
4 |
c * Select trajectories from LSL file *
|
|
|
5 |
c * Michael Sprenger / January, February 2008 *
|
|
|
6 |
c **************************************************************
|
|
|
7 |
|
|
|
8 |
implicit none
|
|
|
9 |
|
|
|
10 |
c --------------------------------------------------------------
|
|
|
11 |
c Declaration of parameters
|
|
|
12 |
c --------------------------------------------------------------
|
|
|
13 |
|
|
|
14 |
c Maximum number of columns per trajectory
|
|
|
15 |
integer maxcol
|
|
|
16 |
parameter (maxcol=100)
|
|
|
17 |
|
|
|
18 |
c Maximum number of commands
|
|
|
19 |
integer maxcmd
|
|
|
20 |
parameter (maxcmd=10000)
|
|
|
21 |
|
|
|
22 |
c --------------------------------------------------------------
|
|
|
23 |
c Declaration of variables
|
|
|
24 |
c --------------------------------------------------------------
|
|
|
25 |
|
|
|
26 |
c Input and output files
|
|
|
27 |
character*120 inp_lslfile ! Input lsl file
|
|
|
28 |
character*120 out_lslfile ! Output lsl file
|
|
|
29 |
character*120 inp_criteria ! Input file with criteria
|
|
|
30 |
integer inpmode ! Format of input file
|
|
|
31 |
integer outmode ! Format of output file
|
|
|
32 |
character*80 outformat ! Trajectory/Boolean/Index of output
|
|
|
33 |
character*80 regionf ! Name of the regionfile
|
|
|
34 |
|
|
|
35 |
c Trajectories
|
|
|
36 |
integer ntim ! Number of times
|
|
|
37 |
integer ncol ! Number of columns (including time...)
|
|
|
38 |
integer ntrainp,ntraout ! Number of trajectories
|
|
|
39 |
character*80 vars(maxcol) ! Names of trajectory columns
|
|
|
40 |
integer basetime(6) ! Base time of trajectory (first line in lsl)
|
|
|
41 |
real,allocatable, dimension (:,:,:) :: trainp ! Input trajectories
|
|
|
42 |
real,allocatable, dimension (:,:,:) :: traout ! Output trajectories
|
|
|
43 |
integer,allocatable,dimension (:) :: selflag ! Flag for selection
|
|
|
44 |
real,allocatable, dimension (:) :: time ! Times of the trajectory
|
|
|
45 |
integer,allocatable,dimension (:,:) :: trigger ! Trigger column
|
|
|
46 |
integer itrigger ! Column index for trigger
|
|
|
47 |
character*80 addtrigger ! Flag whether to add trigger column
|
|
|
48 |
|
|
|
49 |
c Command stack
|
|
|
50 |
real cmd(maxcmd) ! Decoded slection criterion
|
|
|
51 |
integer ncmd ! Number of commands
|
|
|
52 |
|
|
|
53 |
c Common block for initialisation of polygon check
|
|
|
54 |
real tlonv(2000),vlat_c(2000),vlon_c(2000)
|
|
|
55 |
real xlat_c,xlon_c
|
|
|
56 |
integer ibndry,nv_c
|
|
|
57 |
data ibndry/0/
|
|
|
58 |
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
|
|
|
59 |
|
|
|
60 |
c Auxiliary variables
|
|
|
61 |
integer stat ! Logical (state) variable
|
|
|
62 |
integer fid,fod,fcr ! File identifier for input and output
|
|
|
63 |
integer i,j,k ! Index counter
|
|
|
64 |
integer isok ! Flag for selected trajectory
|
|
|
65 |
real param(1000) ! List of parameters
|
|
|
66 |
integer nparam ! Number of parameters
|
|
|
67 |
character*80 specialstr ! Name of special command
|
|
|
68 |
integer len
|
|
|
69 |
integer,allocatable,dimension (:) :: trigger1 ! Trigger column
|
|
|
70 |
real,allocatable,dimension (:,:) :: trainp1 ! A single trajectory
|
|
|
71 |
character ch
|
|
|
72 |
|
|
|
73 |
c --------------------------------------------------------------
|
|
|
74 |
c Preparations
|
|
|
75 |
c --------------------------------------------------------------
|
|
|
76 |
|
|
|
77 |
c Write start message
|
|
|
78 |
print*,'========================================================='
|
|
|
79 |
print*,' *** START OF PROGRAM SELECT ***'
|
|
|
80 |
print*
|
|
|
81 |
|
|
|
82 |
c Read parameter file
|
|
|
83 |
open(10,file='select.param')
|
|
|
84 |
read(10,*) inp_lslfile
|
|
|
85 |
read(10,*) out_lslfile
|
|
|
86 |
read(10,*) outformat
|
|
|
87 |
read(10,*) inp_criteria
|
|
|
88 |
read(10,*) ntrainp
|
|
|
89 |
read(10,*) ntim
|
|
|
90 |
read(10,*) ncol
|
|
|
91 |
read(10,*) regionf
|
|
|
92 |
read(10,*) addtrigger
|
|
|
93 |
close(10)
|
|
|
94 |
|
|
|
95 |
c Set the formats of the input and output files
|
|
|
96 |
call mode_tra(inpmode,inp_lslfile)
|
|
|
97 |
if (inpmode.eq.-1) inpmode=1
|
|
|
98 |
call mode_tra(outmode,out_lslfile)
|
|
|
99 |
if ( (outmode.eq.-1).and.(outformat.ne.'startf') ) then
|
|
|
100 |
outmode=1
|
|
|
101 |
endif
|
|
|
102 |
|
|
|
103 |
c Allocate memory for a single trajectory
|
|
|
104 |
allocate(trainp(ntrainp,ntim,ncol),stat=stat)
|
|
|
105 |
if (stat.ne.0) stop '*** error allocating array trainp ***'
|
|
|
106 |
allocate(time(ntim),stat=stat)
|
|
|
107 |
if (stat.ne.0) stop '*** error allocating array time ***'
|
|
|
108 |
allocate(selflag(ntrainp),stat=stat)
|
|
|
109 |
if (stat.ne.0) stop '*** error allocating array selflag ***'
|
|
|
110 |
allocate(trigger(ntrainp,ntim),stat=stat)
|
|
|
111 |
if (stat.ne.0) stop '*** error allocating array trigger ***'
|
|
|
112 |
allocate(trigger1(ntim),stat=stat)
|
|
|
113 |
if (stat.ne.0) stop '*** error allocating array trigger1 ***'
|
|
|
114 |
allocate(trainp1(ntim,ncol),stat=stat)
|
|
|
115 |
if (stat.ne.0) stop '*** error allocating array trainp1 ***'
|
|
|
116 |
|
|
|
117 |
c Read the input trajectory file
|
|
|
118 |
call ropen_tra(fid,inp_lslfile,ntrainp,ntim,ncol,
|
|
|
119 |
> basetime,vars,inpmode)
|
|
|
120 |
call read_tra (fid,trainp,ntrainp,ntim,ncol,inpmode)
|
|
|
121 |
call close_tra(fid,inpmode)
|
|
|
122 |
|
|
|
123 |
c Check that first four columns correspond to time,lon,lat,p
|
|
|
124 |
if ( (vars(1).ne.'time' ).or.
|
|
|
125 |
> (vars(2).ne.'x' ).and.(vars(2).ne.'lon' ).or.
|
|
|
126 |
> (vars(3).ne.'y' ).and.(vars(3).ne.'lat' ).or.
|
|
|
127 |
> (vars(4).ne.'z' ).and.(vars(4).ne.'p' ) )
|
|
|
128 |
>then
|
|
|
129 |
print*,' ERROR: problem with input trajectories ...'
|
|
|
130 |
stop
|
|
|
131 |
endif
|
|
|
132 |
|
|
|
133 |
c Get the trajectory times from first trajectory
|
|
|
134 |
do i=1,ntim
|
|
|
135 |
time(i)=trainp(1,i,1)
|
|
|
136 |
enddo
|
|
|
137 |
|
|
|
138 |
c Init the trigger field - first check whether it is already available
|
|
|
139 |
itrigger = 0
|
|
|
140 |
do i=1,ncol
|
|
|
141 |
if ( vars(i).eq.'TRIGGER' ) itrigger = i
|
|
|
142 |
enddo
|
|
|
143 |
|
|
|
144 |
if ( itrigger.ne.0 ) then
|
|
|
145 |
do i=1,ntrainp
|
|
|
146 |
do j=1,ntim
|
|
|
147 |
trigger(i,j) = nint( trainp(i,j,itrigger) )
|
|
|
148 |
enddo
|
|
|
149 |
enddo
|
|
|
150 |
else
|
|
|
151 |
do i=1,ntrainp
|
|
|
152 |
do j=1,ntim
|
|
|
153 |
trigger(i,j) = 0
|
|
|
154 |
enddo
|
|
|
155 |
enddo
|
|
|
156 |
endif
|
|
|
157 |
|
|
|
158 |
c Write some info about the trajectory
|
|
|
159 |
print*,'---- INPUT PARAMETERS -----------------------------------'
|
|
|
160 |
write(*,*)
|
|
|
161 |
write(*,*) 'Input file : ',trim(inp_lslfile)
|
|
|
162 |
write(*,*) 'Output file : ',trim(out_lslfile)
|
|
|
163 |
write(*,*) 'Output format : ',trim(outformat)
|
|
|
164 |
write(*,*) 'Criteria file : ',trim(inp_criteria)
|
|
|
165 |
write(*,*) '# tra : ',ntrainp
|
|
|
166 |
write(*,*) '# time : ',ntim
|
|
|
167 |
write(*,*) '# col : ',ncol
|
|
|
168 |
write(*,*) 'Region file : ',trim(regionf)
|
|
|
169 |
write(*,*) 'Add trigger : ',trim(addtrigger)
|
|
|
170 |
|
|
|
171 |
print*
|
|
|
172 |
print*,'---- INPUT TRAJECTORY FILE ------------------------------'
|
|
|
173 |
print*
|
|
|
174 |
write(*,'(1x,a12,i4,a10)') 'Vars : ',1,trim(vars(1))
|
|
|
175 |
do i=2,ncol
|
|
|
176 |
write(*,'(1x,a12,i4,a10)') ' ',i,trim(vars(i))
|
|
|
177 |
enddo
|
|
|
178 |
print*
|
|
|
179 |
write(*,'(1x,a12,i4,f10.2)') 'Time : ',1,time(1)
|
|
|
180 |
do i=2,ntim
|
|
|
181 |
write(*,'(1x,a12,i4,f10.2)') ' ',i,time(i)
|
|
|
182 |
enddo
|
|
|
183 |
print*
|
|
|
184 |
write(*,'(1x,a12,i4,i10)') 'Base date : ',1,basetime(1)
|
|
|
185 |
write(*,'(1x,a12,i4,i10)') ' ',2,basetime(2)
|
|
|
186 |
write(*,'(1x,a12,i4,i10)') ' ',3,basetime(3)
|
|
|
187 |
write(*,'(1x,a12,i4,i10)') ' ',4,basetime(4)
|
|
|
188 |
write(*,'(1x,a12,i4,i10)') ' ',5,basetime(5)
|
|
|
189 |
print*
|
|
|
190 |
write(*,'(1x,a12,i4,i10)') 'Time range : ',6,basetime(6)
|
|
|
191 |
print*
|
|
|
192 |
if ( itrigger.ne.0 ) then
|
|
|
193 |
print*,'TRIGGER FIELD FOUND IN COLUMN ',itrigger
|
|
|
194 |
print*
|
|
|
195 |
endif
|
|
|
196 |
|
|
|
197 |
c Read and decode the selection criterion
|
|
|
198 |
fcr = 10
|
|
|
199 |
open(fcr,file=inp_criteria)
|
|
|
200 |
ncmd=maxcmd
|
|
|
201 |
call decode(fcr,cmd,ncmd,vars,ncol,time,ntim,regionf)
|
|
|
202 |
close(fcr)
|
|
|
203 |
|
|
|
204 |
print*
|
|
|
205 |
print*,'---- PSEUDO CODE FOR SELECTION --------------------------'
|
|
|
206 |
print*
|
|
|
207 |
call dumpcode(cmd,ncmd,vars,ncol,time,ntim)
|
|
|
208 |
|
|
|
209 |
c --------------------------------------------------------------
|
|
|
210 |
c Loop over all trajectories - selection
|
|
|
211 |
c --------------------------------------------------------------
|
|
|
212 |
|
|
|
213 |
c Prepare string and parameters for SPECIAL commands
|
|
|
214 |
if ( cmd(1).eq.0 ) then
|
|
|
215 |
|
|
|
216 |
c Get command string
|
|
|
217 |
j = 2
|
|
|
218 |
len = nint(cmd(j))
|
|
|
219 |
specialstr = ''
|
|
|
220 |
do k=1,len
|
|
|
221 |
j = j + 1
|
|
|
222 |
specialstr = trim(specialstr)//char(nint(cmd(j)))
|
|
|
223 |
enddo
|
|
|
224 |
|
|
|
225 |
c Get paramters
|
|
|
226 |
j = j + 1
|
|
|
227 |
nparam = nint(cmd(j))
|
|
|
228 |
do k=1,nparam
|
|
|
229 |
j = j + 1
|
|
|
230 |
param(k) = cmd(j)
|
|
|
231 |
enddo
|
|
|
232 |
|
|
|
233 |
endif
|
|
|
234 |
|
|
|
235 |
c Init the counter for selected trajectories
|
|
|
236 |
ntraout = 0
|
|
|
237 |
|
|
|
238 |
c Loop over all trajectories
|
|
|
239 |
do i=1,ntrainp
|
|
|
240 |
|
|
|
241 |
c Copy a single trajectory to <trainp1> and <trigger1>
|
|
|
242 |
do j=1,ntim
|
|
|
243 |
do k=1,ncol
|
|
|
244 |
trainp1(j,k) = trainp(i,j,k)
|
|
|
245 |
enddo
|
|
|
246 |
trigger1(j) = trigger(i,j)
|
|
|
247 |
enddo
|
|
|
248 |
|
|
|
249 |
C Skip the trajectory if missing data are found for positions
|
|
|
250 |
isok = 1
|
|
|
251 |
do j=1,ntim
|
|
|
252 |
if ( trainp1(j,4).lt.0. ) isok = 0
|
|
|
253 |
enddo
|
|
|
254 |
|
|
|
255 |
c Decide whether the trajectory is selected (handle SPECIAL commands)
|
|
|
256 |
if ( isok.eq.1 ) then
|
|
|
257 |
if (cmd(1).ne.0 ) then
|
|
|
258 |
call select_tra (isok,cmd,ncmd,trainp1,trigger1,ntim,ncol)
|
|
|
259 |
|
|
|
260 |
else
|
|
|
261 |
call special (isok,specialstr,trainp1,ntim,ncol,
|
|
|
262 |
> vars,time,param,nparam)
|
|
|
263 |
endif
|
|
|
264 |
endif
|
|
|
265 |
|
|
|
266 |
c The trigger might be changed in the selection - copy it
|
|
|
267 |
do j=1,ntim
|
|
|
268 |
trigger(i,j) = trigger1(j)
|
|
|
269 |
enddo
|
|
|
270 |
|
|
|
271 |
c Set flag for selected trajectories
|
|
|
272 |
if (isok.eq.1) then
|
|
|
273 |
selflag(i) = 1
|
|
|
274 |
ntraout = ntraout + 1
|
|
|
275 |
else
|
|
|
276 |
selflag(i) = 0
|
|
|
277 |
endif
|
|
|
278 |
|
|
|
279 |
enddo
|
|
|
280 |
|
|
|
281 |
c --------------------------------------------------------------
|
|
|
282 |
c Write output trajectories
|
|
|
283 |
c --------------------------------------------------------------
|
|
|
284 |
|
|
|
285 |
c ------ Write output trajectories -----------------------------
|
|
|
286 |
if ( outformat.eq.'trajectory' ) then
|
|
|
287 |
|
|
|
288 |
|
|
|
289 |
c Define the trigger field if it is not yet defined
|
|
|
290 |
if ( ( addtrigger.eq.'-trigger' ).and.(itrigger.eq.0) ) then
|
|
|
291 |
ncol = ncol + 1
|
|
|
292 |
vars(ncol) = 'TRIGGER'
|
|
|
293 |
itrigger = ncol
|
|
|
294 |
endif
|
|
|
295 |
|
|
|
296 |
c Allocate memory for output trajectory
|
|
|
297 |
allocate(traout(ntraout,ntim,ncol),stat=stat)
|
|
|
298 |
if (stat.ne.0) stop '*** error allocating array apply ***'
|
|
|
299 |
|
|
|
300 |
c Set output trajectories
|
|
|
301 |
j = 0
|
|
|
302 |
do i=1,ntrainp
|
|
|
303 |
if (selflag(i).eq.1) then
|
|
|
304 |
j = j + 1
|
|
|
305 |
traout(j,1:ntim,1:ncol) = trainp(i,1:ntim,1:ncol)
|
|
|
306 |
if ( itrigger.ne.0 ) then
|
|
|
307 |
traout(j,1:ntim,itrigger) = real(trigger(i,1:ntim))
|
|
|
308 |
endif
|
|
|
309 |
endif
|
|
|
310 |
enddo
|
|
|
311 |
|
|
|
312 |
c Write trajectories
|
|
|
313 |
call wopen_tra(fod,out_lslfile,ntraout,ntim,ncol,
|
|
|
314 |
> basetime,vars,outmode)
|
|
|
315 |
call write_tra(fod,traout,ntraout,ntim,ncol,outmode)
|
|
|
316 |
call close_tra(fod,outmode)
|
|
|
317 |
|
|
|
318 |
c ------ Write index list -------------------------------------
|
|
|
319 |
elseif ( outformat.eq.'index' ) then
|
|
|
320 |
|
|
|
321 |
open(10,file=out_lslfile)
|
|
|
322 |
do i=1,ntrainp
|
|
|
323 |
if ( selflag(i).eq.1) write(10,*) i
|
|
|
324 |
enddo
|
|
|
325 |
close(10)
|
|
|
326 |
|
|
|
327 |
c ------ Write boolean list -----------------------------------
|
|
|
328 |
elseif ( outformat.eq.'boolean' ) then
|
|
|
329 |
|
|
|
330 |
open(10,file=out_lslfile)
|
|
|
331 |
do i=1,ntrainp
|
|
|
332 |
write(10,'(i1)') selflag(i)
|
|
|
333 |
enddo
|
|
|
334 |
close(10)
|
|
|
335 |
|
|
|
336 |
c ------ Write count -------------------------------------------
|
|
|
337 |
elseif ( outformat.eq.'count' ) then
|
|
|
338 |
|
|
|
339 |
open(10,file=out_lslfile)
|
|
|
340 |
write(10,'(i7)') ntraout
|
|
|
341 |
close(10)
|
|
|
342 |
|
|
|
343 |
c ------ Write starting positions -----------------------------
|
|
|
344 |
elseif ( outformat.eq.'startf' ) then
|
|
|
345 |
|
|
|
346 |
c Allocate memory for output trajectory
|
|
|
347 |
allocate(traout(ntraout,1,ncol),stat=stat)
|
|
|
348 |
if (stat.ne.0) stop '*** error allocating array apply ***'
|
|
|
349 |
|
|
|
350 |
c Set output trajectories
|
|
|
351 |
j = 0
|
|
|
352 |
do i=1,ntrainp
|
|
|
353 |
if (selflag(i).eq.1) then
|
|
|
354 |
j = j + 1
|
|
|
355 |
traout(j,1,:) = trainp(i,1,:)
|
|
|
356 |
endif
|
|
|
357 |
enddo
|
|
|
358 |
|
|
|
359 |
c Write trajectories
|
|
|
360 |
if (outmode.ne.-1) then
|
|
|
361 |
|
|
|
362 |
call wopen_tra(fod,out_lslfile,ntraout,1,ncol,
|
|
|
363 |
> basetime,vars,outmode)
|
|
|
364 |
call write_tra(fod,traout,ntraout,1,ncol,outmode)
|
|
|
365 |
call close_tra(fod,outmode)
|
|
|
366 |
|
|
|
367 |
c Output as a triple list (corresponding to <startf> file)
|
|
|
368 |
else
|
|
|
369 |
|
|
|
370 |
fid = 10
|
|
|
371 |
open(fid,file=out_lslfile)
|
|
|
372 |
do i=1,ntraout
|
|
|
373 |
write(fid,'(3f10.3)') traout(i,1,2), ! longitude
|
|
|
374 |
> traout(i,1,3), ! latitude
|
|
|
375 |
> traout(i,1,4) ! pressure
|
|
|
376 |
enddo
|
|
|
377 |
close(fid)
|
|
|
378 |
|
|
|
379 |
endif
|
|
|
380 |
|
|
|
381 |
endif
|
|
|
382 |
|
|
|
383 |
c Write some status information, and end of program message
|
|
|
384 |
print*
|
|
|
385 |
print*,'---- STATUS INFORMATION --------------------------------'
|
|
|
386 |
print*
|
|
|
387 |
print*,' # input trajectories : ',ntrainp
|
|
|
388 |
print*,' # output trajectories : ',ntraout
|
|
|
389 |
print*
|
|
|
390 |
print*,' *** END OF PROGRAM SELECT ***'
|
|
|
391 |
print*,'========================================================='
|
|
|
392 |
|
|
|
393 |
stop
|
|
|
394 |
|
|
|
395 |
c Exception handling
|
|
|
396 |
100 stop 'select: First column in input trajectory must be <time>'
|
|
|
397 |
101 stop 'select: Input trajectory file is empty'
|
|
|
398 |
|
|
|
399 |
end
|
|
|
400 |
|
|
|
401 |
c --------------------------------------------------------------
|
|
|
402 |
c Dump the command list
|
|
|
403 |
c --------------------------------------------------------------
|
|
|
404 |
|
|
|
405 |
subroutine dumpcode(out,n,vars,nvars,times,ntimes)
|
|
|
406 |
|
|
|
407 |
c Write the command list to screen. The command list is decoded
|
|
|
408 |
c by call to <decode>
|
|
|
409 |
|
|
|
410 |
implicit none
|
|
|
411 |
|
|
|
412 |
c Declaration of subroutine parameters
|
|
|
413 |
integer n
|
|
|
414 |
real out(n)
|
|
|
415 |
integer nvars
|
|
|
416 |
character*80 vars(nvars)
|
|
|
417 |
integer ntimes
|
|
|
418 |
real times(ntimes)
|
|
|
419 |
|
|
|
420 |
c A single command
|
|
|
421 |
character*80 cmd
|
|
|
422 |
character*80 var,mode,strtim
|
|
|
423 |
integer nval
|
|
|
424 |
integer ntim
|
|
|
425 |
integer ivar,imode,icmd,itime
|
|
|
426 |
|
|
|
427 |
c Auxiliary variables
|
|
|
428 |
integer i,j
|
|
|
429 |
|
|
|
430 |
c Loop through the complete list
|
|
|
431 |
i=0
|
|
|
432 |
100 if (i.lt.n) then
|
|
|
433 |
|
|
|
434 |
write(*,*) '---------------------------------------'
|
|
|
435 |
|
|
|
436 |
c Get command
|
|
|
437 |
i=i+1
|
|
|
438 |
icmd=nint(out(i))
|
|
|
439 |
|
|
|
440 |
c Special handling of SPECIAL commands
|
|
|
441 |
if ( icmd.eq.0 ) then
|
|
|
442 |
|
|
|
443 |
c Write 'header' for SPECIAL command
|
|
|
444 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),'SPECIAL'
|
|
|
445 |
|
|
|
446 |
c Write command string
|
|
|
447 |
i = i + 1
|
|
|
448 |
icmd = nint(out(i))
|
|
|
449 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),'LEN(CMD)'
|
|
|
450 |
do j=1,icmd
|
|
|
451 |
i = i + 1
|
|
|
452 |
ivar = nint(out(i))
|
|
|
453 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),char(ivar)
|
|
|
454 |
enddo
|
|
|
455 |
|
|
|
456 |
c Write parameters
|
|
|
457 |
i = i + 1
|
|
|
458 |
nval = nint(out(i))
|
|
|
459 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),'#PARAMETER'
|
|
|
460 |
do j=1,nval
|
|
|
461 |
i=i+1
|
|
|
462 |
if ( var.ne.'INPOLYGON' ) then
|
|
|
463 |
write(*,'(i5,f15.4)') i,out(i)
|
|
|
464 |
else
|
|
|
465 |
write(*,'(i5,f15.4,a2)') i,out(i),char(nint(out(i)))
|
|
|
466 |
endif
|
|
|
467 |
enddo
|
|
|
468 |
|
|
|
469 |
c Nothing else to do - exit
|
|
|
470 |
goto 200
|
|
|
471 |
|
|
|
472 |
endif
|
|
|
473 |
|
|
|
474 |
c Set the command
|
|
|
475 |
if (icmd.eq. 1) cmd='GT'
|
|
|
476 |
if (icmd.eq. 2) cmd='LT'
|
|
|
477 |
if (icmd.eq. 3) cmd='IN'
|
|
|
478 |
if (icmd.eq. 4) cmd='OUT'
|
|
|
479 |
if (icmd.eq. 5) cmd='EQ'
|
|
|
480 |
if (icmd.eq. 6) cmd='TRUE'
|
|
|
481 |
if (icmd.eq. 7) cmd='FALSE'
|
|
|
482 |
if (icmd.eq. 8) cmd='ALL'
|
|
|
483 |
if (icmd.eq. 9) cmd='ANY'
|
|
|
484 |
if (icmd.eq. 10) cmd='NONE'
|
|
|
485 |
if (icmd.eq. -1) cmd='BEGIN'
|
|
|
486 |
if (icmd.eq. -2) cmd='END'
|
|
|
487 |
if (icmd.eq. -3) cmd='AND'
|
|
|
488 |
if (icmd.eq. -4) cmd='OR'
|
|
|
489 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(cmd)
|
|
|
490 |
if (icmd.lt.0) goto 100
|
|
|
491 |
|
|
|
492 |
c Get variable
|
|
|
493 |
i=i+1
|
|
|
494 |
ivar=nint(out(i))
|
|
|
495 |
if ( ivar.eq. -1 ) then
|
|
|
496 |
var = 'DIST'
|
|
|
497 |
elseif ( ivar.eq. -2 ) then
|
|
|
498 |
var = 'DIST0'
|
|
|
499 |
elseif ( ivar.eq. -3 ) then
|
|
|
500 |
var = 'INPOLYGON'
|
|
|
501 |
elseif ( ivar.eq. -4 ) then
|
|
|
502 |
var = 'INBOX'
|
|
|
503 |
elseif ( ivar.eq. -5 ) then
|
|
|
504 |
var = 'INCIRCLE'
|
|
|
505 |
elseif ( ivar.eq. -6 ) then
|
|
|
506 |
var = 'INREGION'
|
|
|
507 |
elseif ( ivar.eq. -7 ) then
|
|
|
508 |
var = 'TRIGGER'
|
|
|
509 |
else
|
|
|
510 |
var=vars(ivar)
|
|
|
511 |
endif
|
|
|
512 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(var)
|
|
|
513 |
|
|
|
514 |
c Get variable mode
|
|
|
515 |
i=i+1
|
|
|
516 |
imode=nint(out(i))
|
|
|
517 |
if (imode.eq.1) mode='VALUE'
|
|
|
518 |
if (imode.eq.2) mode='MEAN'
|
|
|
519 |
if (imode.eq.3) mode='MAX'
|
|
|
520 |
if (imode.eq.4) mode='MIN'
|
|
|
521 |
if (imode.eq.5) mode='VAR'
|
|
|
522 |
if (imode.eq.6) mode='SUM'
|
|
|
523 |
if (imode.eq.7) mode='CHANGE'
|
|
|
524 |
if (imode.eq.8) mode='DIFF'
|
|
|
525 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(mode)
|
|
|
526 |
|
|
|
527 |
c Get values
|
|
|
528 |
i=i+1
|
|
|
529 |
nval=nint(out(i))
|
|
|
530 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),'#PARAMETER'
|
|
|
531 |
do j=1,nval
|
|
|
532 |
i=i+1
|
|
|
533 |
|
|
|
534 |
if ( var.ne.'INPOLYGON' ) then
|
|
|
535 |
write(*,'(i5,f15.4)') i,out(i)
|
|
|
536 |
else
|
|
|
537 |
write(*,'(i5,f15.4,a2)') i,out(i),char(nint(out(i)))
|
|
|
538 |
endif
|
|
|
539 |
enddo
|
|
|
540 |
|
|
|
541 |
c Get times
|
|
|
542 |
i=i+1
|
|
|
543 |
ntim=nint(out(i))
|
|
|
544 |
write(*,'(i5,f15.4,7x,7x,a6)') i,out(i),'#TIMES'
|
|
|
545 |
do j=1,ntim
|
|
|
546 |
i=i+1
|
|
|
547 |
write(*,'(i5,f15.4,f7.0)') i,out(i),times(nint(out(i)))
|
|
|
548 |
enddo
|
|
|
549 |
|
|
|
550 |
c Get time mode
|
|
|
551 |
i=i+1
|
|
|
552 |
itime=nint(out(i))
|
|
|
553 |
if (itime.eq.1) strtim='ALL'
|
|
|
554 |
if (itime.eq.2) strtim='ANY'
|
|
|
555 |
if (itime.eq.3) strtim='NONE'
|
|
|
556 |
if (itime.lt.0) strtim='TRIGGER'
|
|
|
557 |
|
|
|
558 |
if ( strtim.ne.'TRIGGER' ) then
|
|
|
559 |
write(*,'(i5,f15.4,10x,a10)') i,out(i),trim(strtim)
|
|
|
560 |
else
|
|
|
561 |
write(*,'(i5,f15.4,10x,a10,a3,i3)') i,out(i),trim(strtim),
|
|
|
562 |
> ' ->',abs(itime)
|
|
|
563 |
endif
|
|
|
564 |
|
|
|
565 |
goto 100
|
|
|
566 |
|
|
|
567 |
endif
|
|
|
568 |
|
|
|
569 |
c Exit point
|
|
|
570 |
200 continue
|
|
|
571 |
|
|
|
572 |
write(*,*) '---------------------------------------'
|
|
|
573 |
|
|
|
574 |
end
|
|
|
575 |
|
|
|
576 |
|
|
|
577 |
c --------------------------------------------------------------
|
|
|
578 |
c Read and decode a selection set
|
|
|
579 |
c --------------------------------------------------------------
|
|
|
580 |
|
|
|
581 |
subroutine decode(fid,out,n,vars,nvars,times,ntimes,regionf)
|
|
|
582 |
|
|
|
583 |
c A selection file is opened with file id <fid> and transformed
|
|
|
584 |
c into a set of commands applied to the trajectories. On input
|
|
|
585 |
c <n> sets the maximum dimension of <out>, on output it gives the
|
|
|
586 |
c total length of the command string. The output is a list of
|
|
|
587 |
c commands with the following format:
|
|
|
588 |
c
|
|
|
589 |
c out(i) = Command
|
|
|
590 |
c out(i+1) = Column index of variable
|
|
|
591 |
c out(i+2) = Mode for variable
|
|
|
592 |
c out(i+3) = Number of parameters (n)
|
|
|
593 |
c out(i+4:i+4+n) = Parameters
|
|
|
594 |
c out(i+5+n) = Number of times
|
|
|
595 |
c out(i+6+n:i+6+n+m) = List of time indices (m)
|
|
|
596 |
c out(i+7+n+m) = Time mode
|
|
|
597 |
c
|
|
|
598 |
c For SPECIAL commands (to be coded in <special.f>) the format is:
|
|
|
599 |
c
|
|
|
600 |
c out(i) = Length of command string (n)
|
|
|
601 |
c out(i+1:i+n) = Command string
|
|
|
602 |
c out(i+n+1) = Number of parameters (m)
|
|
|
603 |
c out(i+n+2:i+n+1+m) = List of parameters
|
|
|
604 |
c
|
|
|
605 |
c The following coding is used
|
|
|
606 |
c
|
|
|
607 |
c Command Variable mode Time mode
|
|
|
608 |
c ---------- ------------- ---------
|
|
|
609 |
c GT 1 VALUE 1 ALL 1
|
|
|
610 |
c LT 2 MEAN 2 ANY 2
|
|
|
611 |
c IN 3 MAX 3 NONE 3
|
|
|
612 |
c OUT 4 MIN 4 TRIGGER -i (i the trigger index)
|
|
|
613 |
c EQ 5 VAR 5
|
|
|
614 |
c BEGIN -1 SUM 6
|
|
|
615 |
c END -2 CHANGE 7
|
|
|
616 |
c AND -3 DIFF 8
|
|
|
617 |
c OR -4
|
|
|
618 |
c TRUE 6
|
|
|
619 |
c FALSE 7
|
|
|
620 |
c SPECIAL 0
|
|
|
621 |
c ALL 8 (TRIGGER)
|
|
|
622 |
c ANY 9 (TRIGGER)
|
|
|
623 |
c NONE 10 (TRIGGER)
|
|
|
624 |
|
|
|
625 |
|
|
|
626 |
c Several "implicit variables" are supported - out(i+1):
|
|
|
627 |
c
|
|
|
628 |
c DIST -1 : Path length of the trajectory
|
|
|
629 |
c DIST0 -2 : Distance from starting position
|
|
|
630 |
c INPOLYGON -3 : Specified polygon region
|
|
|
631 |
c INBOX -4 : Longitude/latitude rectangle
|
|
|
632 |
c INCIRCLE -5 : Within a specified radius
|
|
|
633 |
c INREGION -6 : Within a specified rehion on the region file
|
|
|
634 |
c TRIGGER -7 : Trigger field
|
|
|
635 |
c
|
|
|
636 |
c For the special commands BEGIN, END, AND and OR, only one field
|
|
|
637 |
c in <out> is used.
|
|
|
638 |
|
|
|
639 |
implicit none
|
|
|
640 |
|
|
|
641 |
c Declaration of subroutine parameters
|
|
|
642 |
integer fid
|
|
|
643 |
integer n
|
|
|
644 |
real out(n)
|
|
|
645 |
integer nvars
|
|
|
646 |
character*80 vars(nvars)
|
|
|
647 |
integer ntimes
|
|
|
648 |
real times(ntimes)
|
|
|
649 |
character*80 regionf
|
|
|
650 |
|
|
|
651 |
c Numerical epsilon
|
|
|
652 |
real eps
|
|
|
653 |
parameter (eps=0.001)
|
|
|
654 |
|
|
|
655 |
c A single command term
|
|
|
656 |
character*80 cmd
|
|
|
657 |
character*80 var,mode
|
|
|
658 |
integer nval
|
|
|
659 |
real val(1000)
|
|
|
660 |
integer ntim
|
|
|
661 |
real tim(1000)
|
|
|
662 |
character*80 tmode
|
|
|
663 |
|
|
|
664 |
c Specification of a polygon
|
|
|
665 |
character*80 filename
|
|
|
666 |
integer pn ! Number of entries in lat/lon poly
|
|
|
667 |
real latpoly(1000) ! List of polygon latitudes
|
|
|
668 |
real lonpoly(1000) ! List of polygon longitudes
|
|
|
669 |
real loninpoly,latinpoly ! Lon/lat inside polygon
|
|
|
670 |
|
|
|
671 |
c Specification of a region
|
|
|
672 |
real xcorner(4)
|
|
|
673 |
real ycorner(4)
|
|
|
674 |
integer iregion
|
|
|
675 |
character*80 string
|
|
|
676 |
|
|
|
677 |
c Transformation to UPN (handling of logical operators)
|
|
|
678 |
integer nlogical
|
|
|
679 |
integer ilogical(n)
|
|
|
680 |
real tmp(n)
|
|
|
681 |
integer mlogical
|
|
|
682 |
integer isor
|
|
|
683 |
|
|
|
684 |
c Auxiliary variables
|
|
|
685 |
integer i,j
|
|
|
686 |
integer j1,j2
|
|
|
687 |
integer flag(ntimes)
|
|
|
688 |
integer count
|
|
|
689 |
integer ok
|
|
|
690 |
integer itrigger
|
|
|
691 |
|
|
|
692 |
c Common block for initialisation of polygon check
|
|
|
693 |
real tlonv(1000),vlat_c(1000),vlon_c(1000)
|
|
|
694 |
real xlat_c,xlon_c
|
|
|
695 |
integer ibndry,nv_c
|
|
|
696 |
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
|
|
|
697 |
|
|
|
698 |
c ------ Decode single commands ---------------------
|
|
|
699 |
|
|
|
700 |
c Reset the filename for polygons
|
|
|
701 |
filename='nil'
|
|
|
702 |
|
|
|
703 |
c Reset the counter for logical commands
|
|
|
704 |
nlogical=0
|
|
|
705 |
|
|
|
706 |
c Loop through all commands
|
|
|
707 |
100 continue
|
|
|
708 |
|
|
|
709 |
c Read next command (handle special cases)
|
|
|
710 |
read(fid,*) cmd
|
|
|
711 |
|
|
|
712 |
c Special handling of SPECIAL commands
|
|
|
713 |
if ( cmd.eq.'SPECIAL' ) then
|
|
|
714 |
|
|
|
715 |
c Set the flag for SPECIAL command
|
|
|
716 |
n = 1
|
|
|
717 |
out(n) = 0.
|
|
|
718 |
|
|
|
719 |
c Read the command string
|
|
|
720 |
read(fid,*) var
|
|
|
721 |
|
|
|
722 |
c Add the command string
|
|
|
723 |
n = n + 1
|
|
|
724 |
out(n) = len_trim(var)
|
|
|
725 |
do j=1,len_trim(var)
|
|
|
726 |
n = n + 1
|
|
|
727 |
out(n) = ichar(var(j:j))
|
|
|
728 |
enddo
|
|
|
729 |
|
|
|
730 |
c Read the parameters
|
|
|
731 |
read(fid,*) nval
|
|
|
732 |
read(fid,*) (val(i),i=1,nval)
|
|
|
733 |
|
|
|
734 |
c Add the parameters
|
|
|
735 |
n = n + 1
|
|
|
736 |
out(n)=real(nval)
|
|
|
737 |
do i=1,nval
|
|
|
738 |
n=n+1
|
|
|
739 |
out(n)=val(i)
|
|
|
740 |
enddo
|
|
|
741 |
|
|
|
742 |
c Goto exit point - nothing more top do
|
|
|
743 |
goto 350
|
|
|
744 |
|
|
|
745 |
endif
|
|
|
746 |
|
|
|
747 |
c Handle structure commands
|
|
|
748 |
if ( cmd.eq.'BEGIN') then
|
|
|
749 |
out(1)=-1.
|
|
|
750 |
n=1
|
|
|
751 |
nlogical=1
|
|
|
752 |
ilogical(1)=n
|
|
|
753 |
goto 200
|
|
|
754 |
elseif ( cmd.eq.'AND' ) then
|
|
|
755 |
n=n+1
|
|
|
756 |
out(n)=-3.
|
|
|
757 |
nlogical=nlogical+1
|
|
|
758 |
ilogical(nlogical)=n
|
|
|
759 |
goto 200
|
|
|
760 |
elseif ( cmd.eq.'OR' ) then
|
|
|
761 |
n=n+1
|
|
|
762 |
out(n)=-4.
|
|
|
763 |
nlogical=nlogical+1
|
|
|
764 |
ilogical(nlogical)=n
|
|
|
765 |
goto 200
|
|
|
766 |
elseif ( cmd.eq.'END' ) then
|
|
|
767 |
n=n+1
|
|
|
768 |
out(n)=-2.
|
|
|
769 |
nlogical=nlogical+1
|
|
|
770 |
ilogical(nlogical)=n
|
|
|
771 |
goto 300
|
|
|
772 |
endif
|
|
|
773 |
|
|
|
774 |
c Read other fields associated with the command
|
|
|
775 |
read(fid,*) var,mode
|
|
|
776 |
|
|
|
777 |
c Read parameter
|
|
|
778 |
if ( var.eq.'INPOLYGON' ) then
|
|
|
779 |
read(fid,*) nval
|
|
|
780 |
read(fid,*) filename
|
|
|
781 |
filename = trim(filename)
|
|
|
782 |
else
|
|
|
783 |
read(fid,*) nval
|
|
|
784 |
read(fid,*) (val(i),i=1,nval)
|
|
|
785 |
endif
|
|
|
786 |
|
|
|
787 |
c Read times
|
|
|
788 |
read(fid,*) ntim
|
|
|
789 |
read(fid,*) (tim(i),i=1,ntim)
|
|
|
790 |
read(fid,*) tmode
|
|
|
791 |
|
|
|
792 |
c Bring CAPITAL "TIME,LAT,LON,P" into "time,lat,lon,p"
|
|
|
793 |
if (var.eq.'TIME') var='time'
|
|
|
794 |
if (var.eq.'LAT' ) var='lat'
|
|
|
795 |
if (var.eq.'LON' ) var='lon'
|
|
|
796 |
if (var.eq.'P' ) var='p'
|
|
|
797 |
|
|
|
798 |
c If the time mode is 'TRIGGER', all times of a trajectory
|
|
|
799 |
c must be considered
|
|
|
800 |
if ( tmode.eq.'TRIGGER' ) then
|
|
|
801 |
itrigger = nint(tim(1))
|
|
|
802 |
ntim = 1
|
|
|
803 |
tim(1) = -999.
|
|
|
804 |
endif
|
|
|
805 |
|
|
|
806 |
c Special times: transform into real time
|
|
|
807 |
do i=1,ntim
|
|
|
808 |
if ( abs(tim(i)+996.).lt.eps ) tim(i)=times(1)
|
|
|
809 |
if ( abs(tim(i)+995.).lt.eps ) tim(i)=times(ntimes)
|
|
|
810 |
enddo
|
|
|
811 |
|
|
|
812 |
c Check whether times are valid
|
|
|
813 |
ok=0
|
|
|
814 |
do i=1,ntim
|
|
|
815 |
if ( (abs(tim(i)+994.).gt.eps).and.
|
|
|
816 |
> (abs(tim(i)+999.).gt.eps) )
|
|
|
817 |
> then
|
|
|
818 |
do j=1,ntimes
|
|
|
819 |
if ( abs(tim(i)-times(j)).lt.eps ) then
|
|
|
820 |
ok=ok+1
|
|
|
821 |
endif
|
|
|
822 |
enddo
|
|
|
823 |
else
|
|
|
824 |
ok=ok+1
|
|
|
825 |
endif
|
|
|
826 |
enddo
|
|
|
827 |
if (ok.ne.ntim) goto 400
|
|
|
828 |
|
|
|
829 |
c Select all times which are included in the criterion
|
|
|
830 |
do i=1,ntimes
|
|
|
831 |
flag(i)=0
|
|
|
832 |
enddo
|
|
|
833 |
i=1
|
|
|
834 |
150 if (i.le.ntim) then
|
|
|
835 |
|
|
|
836 |
c A list of times
|
|
|
837 |
if ( (abs(tim(i)+994.).lt.eps) ) then
|
|
|
838 |
j1=0
|
|
|
839 |
do j=1,ntimes
|
|
|
840 |
if ( abs(tim(i-1)-times(j)).lt.eps ) then
|
|
|
841 |
j1=j
|
|
|
842 |
endif
|
|
|
843 |
enddo
|
|
|
844 |
j2=0
|
|
|
845 |
do j=1,ntimes
|
|
|
846 |
if ( abs(tim(i+1)-times(j)).lt.eps ) then
|
|
|
847 |
j2=j
|
|
|
848 |
endif
|
|
|
849 |
enddo
|
|
|
850 |
if ( (j1.eq.0).or.(j2.eq.0) ) goto 400
|
|
|
851 |
do j=j1,j2
|
|
|
852 |
flag(j)=1
|
|
|
853 |
enddo
|
|
|
854 |
i=i+1
|
|
|
855 |
|
|
|
856 |
c Explicitly given time value
|
|
|
857 |
else
|
|
|
858 |
do j=1,ntimes
|
|
|
859 |
if ( abs(tim(i)-times(j)).lt.eps ) then
|
|
|
860 |
flag(j)=1
|
|
|
861 |
endif
|
|
|
862 |
enddo
|
|
|
863 |
|
|
|
864 |
endif
|
|
|
865 |
|
|
|
866 |
i=i+1
|
|
|
867 |
goto 150
|
|
|
868 |
|
|
|
869 |
endif
|
|
|
870 |
|
|
|
871 |
c Write command identifier
|
|
|
872 |
n=n+1
|
|
|
873 |
if (cmd.eq.'GT' ) out(n)= 1.
|
|
|
874 |
if (cmd.eq.'LT' ) out(n)= 2.
|
|
|
875 |
if (cmd.eq.'IN' ) out(n)= 3.
|
|
|
876 |
if (cmd.eq.'OUT' ) out(n)= 4.
|
|
|
877 |
if (cmd.eq.'EQ' ) out(n)= 5.
|
|
|
878 |
if (cmd.eq.'TRUE' ) out(n)= 6.
|
|
|
879 |
if (cmd.eq.'FALSE' ) out(n)= 7.
|
|
|
880 |
if (cmd.eq.'ALL ' ) out(n)= 8.
|
|
|
881 |
if (cmd.eq.'ANY ' ) out(n)= 9.
|
|
|
882 |
if (cmd.eq.'NONE ' ) out(n)=10.
|
|
|
883 |
|
|
|
884 |
c Write index for variable - force implicit trigger
|
|
|
885 |
ok=0
|
|
|
886 |
do j=1,nvars
|
|
|
887 |
if (vars(j).eq.var) ok=j
|
|
|
888 |
enddo
|
|
|
889 |
|
|
|
890 |
if (var.eq.'TRIGGER') ok = 0
|
|
|
891 |
|
|
|
892 |
if (ok.eq.0) then
|
|
|
893 |
if (var.eq.'DIST') then
|
|
|
894 |
ok = -1
|
|
|
895 |
elseif (var.eq.'DIST0') then
|
|
|
896 |
ok = -2
|
|
|
897 |
elseif (var.eq.'INPOLYGON') then
|
|
|
898 |
ok = -3
|
|
|
899 |
elseif (var.eq.'INBOX') then
|
|
|
900 |
ok = -4
|
|
|
901 |
elseif (var.eq.'INCIRCLE') then
|
|
|
902 |
ok = -5
|
|
|
903 |
elseif (var.eq.'INREGION') then
|
|
|
904 |
ok = -6
|
|
|
905 |
elseif (var.eq.'TRIGGER') then
|
|
|
906 |
ok = -7
|
|
|
907 |
else
|
|
|
908 |
goto 400
|
|
|
909 |
endif
|
|
|
910 |
endif
|
|
|
911 |
n=n+1
|
|
|
912 |
out(n)=real(ok)
|
|
|
913 |
|
|
|
914 |
c Write mode for variable
|
|
|
915 |
ok=0
|
|
|
916 |
if (mode.eq.'VALUE' ) ok=1
|
|
|
917 |
if (mode.eq.'MEAN' ) ok=2
|
|
|
918 |
if (mode.eq.'MAX' ) ok=3
|
|
|
919 |
if (mode.eq.'MIN' ) ok=4
|
|
|
920 |
if (mode.eq.'VAR' ) ok=5
|
|
|
921 |
if (mode.eq.'SUM' ) ok=6
|
|
|
922 |
if (mode.eq.'CHANGE' ) ok=7
|
|
|
923 |
if (mode.eq.'DIFF' ) ok=8
|
|
|
924 |
if (ok.eq.0) goto 400
|
|
|
925 |
n=n+1
|
|
|
926 |
out(n)=real(ok)
|
|
|
927 |
|
|
|
928 |
c Write the parameter values: INPOLYGON
|
|
|
929 |
if ( var.eq.'INPOLYGON' ) then
|
|
|
930 |
|
|
|
931 |
n = n+1
|
|
|
932 |
out(n) = len_trim(filename)
|
|
|
933 |
do j=1,len_trim(filename)
|
|
|
934 |
n = n + 1
|
|
|
935 |
out(n) = ichar(filename(j:j))
|
|
|
936 |
enddo
|
|
|
937 |
|
|
|
938 |
c Write parameter value: INREGION
|
|
|
939 |
elseif ( var.eq.'INREGION' ) then
|
|
|
940 |
|
|
|
941 |
iregion = nint(val(1))
|
|
|
942 |
|
|
|
943 |
open(fid+1,file=regionf)
|
|
|
944 |
|
|
|
945 |
50 read(fid+1,*,end=51) string
|
|
|
946 |
|
|
|
947 |
if ( string(1:1).ne.'#' ) then
|
|
|
948 |
call regionsplit(string,i,xcorner,ycorner)
|
|
|
949 |
if ( i.eq.iregion ) goto 52
|
|
|
950 |
endif
|
|
|
951 |
|
|
|
952 |
goto 50
|
|
|
953 |
|
|
|
954 |
51 close(fid+1)
|
|
|
955 |
|
|
|
956 |
print*,' ERROR: region ',iregion,' not found on ',
|
|
|
957 |
> trim(regionf)
|
|
|
958 |
stop
|
|
|
959 |
|
|
|
960 |
52 continue
|
|
|
961 |
|
|
|
962 |
n = n + 1
|
|
|
963 |
out(n) = 8 ! Number of parameters
|
|
|
964 |
do i=1,4
|
|
|
965 |
n = n + 1
|
|
|
966 |
out(n) = xcorner(i)
|
|
|
967 |
enddo
|
|
|
968 |
do i=1,4
|
|
|
969 |
n = n + 1
|
|
|
970 |
out(n) = ycorner(i)
|
|
|
971 |
enddo
|
|
|
972 |
|
|
|
973 |
c Write parameter values: all other cases
|
|
|
974 |
else
|
|
|
975 |
n=n+1
|
|
|
976 |
out(n)=real(nval)
|
|
|
977 |
do i=1,nval
|
|
|
978 |
n=n+1
|
|
|
979 |
out(n)=val(i)
|
|
|
980 |
enddo
|
|
|
981 |
endif
|
|
|
982 |
|
|
|
983 |
c All times are selected
|
|
|
984 |
if ( abs(tim(1)+999.).lt.eps ) then
|
|
|
985 |
n=n+1
|
|
|
986 |
out(n)=real(ntimes)
|
|
|
987 |
do i=1,ntimes
|
|
|
988 |
n=n+1
|
|
|
989 |
out(n)=real(i)
|
|
|
990 |
enddo
|
|
|
991 |
|
|
|
992 |
c A selection of times is given
|
|
|
993 |
else
|
|
|
994 |
count=0
|
|
|
995 |
do i=1,ntimes
|
|
|
996 |
count=count+flag(i)
|
|
|
997 |
enddo
|
|
|
998 |
n=n+1
|
|
|
999 |
out(n)=real(count)
|
|
|
1000 |
do i=1,ntimes
|
|
|
1001 |
if (flag(i).eq.1) then
|
|
|
1002 |
n=n+1
|
|
|
1003 |
out(n)=real(i)
|
|
|
1004 |
endif
|
|
|
1005 |
enddo
|
|
|
1006 |
endif
|
|
|
1007 |
|
|
|
1008 |
c Write the time mode
|
|
|
1009 |
if ( tmode.eq.'ALL') then
|
|
|
1010 |
n=n+1
|
|
|
1011 |
out(n)=1.
|
|
|
1012 |
elseif ( tmode.eq.'ANY') then
|
|
|
1013 |
n=n+1
|
|
|
1014 |
out(n)=2.
|
|
|
1015 |
elseif ( tmode.eq.'NONE') then
|
|
|
1016 |
n=n+1
|
|
|
1017 |
out(n)=3.
|
|
|
1018 |
elseif ( tmode.eq.'TRIGGER') then
|
|
|
1019 |
n=n+1
|
|
|
1020 |
out(n)=-real(itrigger)
|
|
|
1021 |
endif
|
|
|
1022 |
|
|
|
1023 |
c End loop: handle single command
|
|
|
1024 |
200 continue
|
|
|
1025 |
goto 100
|
|
|
1026 |
|
|
|
1027 |
c End loop: loop over all commands
|
|
|
1028 |
300 continue
|
|
|
1029 |
|
|
|
1030 |
c ------ Read polygon file, if requested -----------
|
|
|
1031 |
if ( filename.ne.'nil' ) then
|
|
|
1032 |
|
|
|
1033 |
print*
|
|
|
1034 |
print*,
|
|
|
1035 |
> '---- POLYGON --------------------------------------------'
|
|
|
1036 |
|
|
|
1037 |
print*
|
|
|
1038 |
print*,'Filename = ',trim(filename)
|
|
|
1039 |
print*
|
|
|
1040 |
|
|
|
1041 |
c Read list of polygon coordinates from file
|
|
|
1042 |
pn = 0
|
|
|
1043 |
open(fid+1,file=filename)
|
|
|
1044 |
read(fid+1,*) loninpoly,latinpoly
|
|
|
1045 |
print*,'Inside (lon/lat) =',loninpoly,latinpoly
|
|
|
1046 |
print*
|
|
|
1047 |
510 continue
|
|
|
1048 |
pn = pn + 1
|
|
|
1049 |
read(fid+1,*,end=511) lonpoly(pn),
|
|
|
1050 |
> latpoly(pn)
|
|
|
1051 |
|
|
|
1052 |
print*,pn,lonpoly(pn),latpoly(pn)
|
|
|
1053 |
|
|
|
1054 |
goto 510
|
|
|
1055 |
511 continue
|
|
|
1056 |
pn = pn - 1
|
|
|
1057 |
close(fid+1)
|
|
|
1058 |
|
|
|
1059 |
c Define the polygon boundaries
|
|
|
1060 |
call DefSPolyBndry(latpoly,lonpoly,pn,latinpoly,loninpoly)
|
|
|
1061 |
|
|
|
1062 |
endif
|
|
|
1063 |
|
|
|
1064 |
c ------ Transform to UPN --------------------------
|
|
|
1065 |
|
|
|
1066 |
c Check whether logical commands are ok
|
|
|
1067 |
mlogical=nint(out(ilogical(1)))
|
|
|
1068 |
if ( mlogical.ne.-1) goto 400
|
|
|
1069 |
mlogical=nint(out(ilogical(nlogical)))
|
|
|
1070 |
if ( mlogical.ne.-2) goto 400
|
|
|
1071 |
|
|
|
1072 |
c No transformation necessary if only one command
|
|
|
1073 |
if (nlogical.eq.2) goto 350
|
|
|
1074 |
|
|
|
1075 |
c Copy the output to temporary list
|
|
|
1076 |
do i=1,n
|
|
|
1077 |
tmp(i)=out(i)
|
|
|
1078 |
enddo
|
|
|
1079 |
|
|
|
1080 |
c Set BEGIN statement
|
|
|
1081 |
n=1
|
|
|
1082 |
out(n)=-1.
|
|
|
1083 |
|
|
|
1084 |
c Reorder commands and transform to UPN
|
|
|
1085 |
isor=0
|
|
|
1086 |
do i=1,nlogical-1
|
|
|
1087 |
|
|
|
1088 |
c Get the logical command
|
|
|
1089 |
mlogical=nint(out(ilogical(i)))
|
|
|
1090 |
|
|
|
1091 |
c Connecting OR
|
|
|
1092 |
if (mlogical.eq.-4) then
|
|
|
1093 |
if (isor.eq.1) then
|
|
|
1094 |
n=n+1
|
|
|
1095 |
out(n)=-4.
|
|
|
1096 |
else
|
|
|
1097 |
isor=1
|
|
|
1098 |
endif
|
|
|
1099 |
endif
|
|
|
1100 |
|
|
|
1101 |
c Put the command onto the stack
|
|
|
1102 |
do j=ilogical(i)+1,ilogical(i+1)-1
|
|
|
1103 |
n=n+1
|
|
|
1104 |
out(n)=tmp(j)
|
|
|
1105 |
enddo
|
|
|
1106 |
|
|
|
1107 |
c Connecting AND operator
|
|
|
1108 |
if ( mlogical.eq.-3 ) then
|
|
|
1109 |
n=n+1
|
|
|
1110 |
out(n)=-3.
|
|
|
1111 |
endif
|
|
|
1112 |
|
|
|
1113 |
enddo
|
|
|
1114 |
|
|
|
1115 |
c Set final connecting OR
|
|
|
1116 |
if (isor.eq.1) then
|
|
|
1117 |
n=n+1
|
|
|
1118 |
out(n)=-4.
|
|
|
1119 |
endif
|
|
|
1120 |
|
|
|
1121 |
c Set END statement
|
|
|
1122 |
n=n+1
|
|
|
1123 |
out(n)=-2.
|
|
|
1124 |
|
|
|
1125 |
c ------ Exit point ---------------------------------
|
|
|
1126 |
|
|
|
1127 |
350 continue
|
|
|
1128 |
return
|
|
|
1129 |
|
|
|
1130 |
c ----- Exception handling --------------------------
|
|
|
1131 |
400 print*,'Invalid selection criterion... Stop'
|
|
|
1132 |
stop
|
|
|
1133 |
|
|
|
1134 |
end
|
|
|
1135 |
|
|
|
1136 |
|
|
|
1137 |
c --------------------------------------------------------------
|
|
|
1138 |
c Decide whether a trajectory is selected or not
|
|
|
1139 |
c --------------------------------------------------------------
|
|
|
1140 |
|
|
|
1141 |
subroutine select_tra (select,cmd,n,tra,trigger,ntim,ncol)
|
|
|
1142 |
|
|
|
1143 |
c Decide whether a single trajectory is selected (<select=1>) or
|
|
|
1144 |
c is not selected <select=0> according to the selection criterion
|
|
|
1145 |
c given in <cmd(ncmd)>. The selection criterion <cmd(ncmd)> is
|
|
|
1146 |
c returned from the call to the subroutine <decode>. The trajectory
|
|
|
1147 |
c is given in <tra(ntim,ncol)> where <ntim> is the number of times
|
|
|
1148 |
c and <ncol> is the number of columns.
|
|
|
1149 |
c
|
|
|
1150 |
c Important note: the structure of <tra(ntim,ncol)> must match to the
|
|
|
1151 |
c call parameter <vars,nvars,times,ntimes> in subroutine <decode>.
|
|
|
1152 |
|
|
|
1153 |
implicit none
|
|
|
1154 |
|
|
|
1155 |
c Declaration of subroutine parameters
|
|
|
1156 |
integer select
|
|
|
1157 |
integer n
|
|
|
1158 |
real cmd(n)
|
|
|
1159 |
integer ntim,ncol
|
|
|
1160 |
real tra(ntim,ncol)
|
|
|
1161 |
integer trigger(ntim)
|
|
|
1162 |
|
|
|
1163 |
c Numerical epsilon (for test of equality)
|
|
|
1164 |
real eps
|
|
|
1165 |
parameter (eps=0.000001)
|
|
|
1166 |
|
|
|
1167 |
c A single command and the associated field
|
|
|
1168 |
integer icmd,ivar,imode,itime,nsel,nval
|
|
|
1169 |
integer time(ntim)
|
|
|
1170 |
real param(100)
|
|
|
1171 |
real var (ntim)
|
|
|
1172 |
integer intvar(ntim)
|
|
|
1173 |
|
|
|
1174 |
c Boolean values for a single time, a single command and build-up
|
|
|
1175 |
integer stack(100)
|
|
|
1176 |
integer nstack
|
|
|
1177 |
integer istrue(ntim)
|
|
|
1178 |
integer decision
|
|
|
1179 |
|
|
|
1180 |
c Auxiliary variables
|
|
|
1181 |
integer i,j,k
|
|
|
1182 |
real tmp,mea
|
|
|
1183 |
integer istack1,istack2
|
|
|
1184 |
real lat0,lon0,lat1,lon1
|
|
|
1185 |
real length(ntim)
|
|
|
1186 |
integer flag
|
|
|
1187 |
real dist
|
|
|
1188 |
real xcorner(4),ycorner(4)
|
|
|
1189 |
integer iparam
|
|
|
1190 |
character ch
|
|
|
1191 |
|
|
|
1192 |
c Common block for initialisation of polygon check
|
|
|
1193 |
real tlonv(1000),vlat_c(1000),vlon_c(1000)
|
|
|
1194 |
real xlat_c,xlon_c
|
|
|
1195 |
integer ibndry,nv_c
|
|
|
1196 |
common /spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
|
|
|
1197 |
|
|
|
1198 |
c Externals
|
|
|
1199 |
real sdis ! Spherical distance
|
|
|
1200 |
external sdis
|
|
|
1201 |
integer inregion ! Boolean flag for regions
|
|
|
1202 |
external inregion
|
|
|
1203 |
|
|
|
1204 |
c Reset the decision stack (with locical values)
|
|
|
1205 |
nstack=0
|
|
|
1206 |
|
|
|
1207 |
c Loop through the complete command list
|
|
|
1208 |
i=0
|
|
|
1209 |
100 if (i.lt.n) then
|
|
|
1210 |
|
|
|
1211 |
c --- Get the command -------------------------------
|
|
|
1212 |
i=i+1
|
|
|
1213 |
icmd=nint(cmd(i))
|
|
|
1214 |
|
|
|
1215 |
c --- Handle structural commands (BEGIN, END, AND, OR)
|
|
|
1216 |
|
|
|
1217 |
c Handle BEGIN statement
|
|
|
1218 |
if ( icmd.eq.-1) then
|
|
|
1219 |
nstack=0
|
|
|
1220 |
goto 200
|
|
|
1221 |
endif
|
|
|
1222 |
|
|
|
1223 |
c Handle END statement
|
|
|
1224 |
if (icmd.eq.-2) then
|
|
|
1225 |
goto 300
|
|
|
1226 |
endif
|
|
|
1227 |
|
|
|
1228 |
c Handle AND statement
|
|
|
1229 |
if (icmd.eq.-3) then
|
|
|
1230 |
istack1=stack(nstack)
|
|
|
1231 |
nstack=nstack-1
|
|
|
1232 |
istack2=stack(nstack)
|
|
|
1233 |
if ((istack1.eq.1).and.(istack2.eq.1)) then
|
|
|
1234 |
stack(nstack)=1
|
|
|
1235 |
else
|
|
|
1236 |
stack(nstack)=0
|
|
|
1237 |
endif
|
|
|
1238 |
goto 200
|
|
|
1239 |
endif
|
|
|
1240 |
|
|
|
1241 |
c Handle OR statement
|
|
|
1242 |
if (icmd.eq.-4) then
|
|
|
1243 |
istack1=stack(nstack)
|
|
|
1244 |
nstack=nstack-1
|
|
|
1245 |
istack2=stack(nstack)
|
|
|
1246 |
if ((istack1.eq.1).or.(istack2.eq.1)) then
|
|
|
1247 |
stack(nstack)=1
|
|
|
1248 |
else
|
|
|
1249 |
stack(nstack)=0
|
|
|
1250 |
endif
|
|
|
1251 |
goto 200
|
|
|
1252 |
endif
|
|
|
1253 |
|
|
|
1254 |
c --- Get all command details (parameters, modes, times)
|
|
|
1255 |
|
|
|
1256 |
c Get variable (<ivar> gets the column index in <tra>)
|
|
|
1257 |
i=i+1
|
|
|
1258 |
ivar=nint(cmd(i))
|
|
|
1259 |
|
|
|
1260 |
c Get variable mode
|
|
|
1261 |
i=i+1
|
|
|
1262 |
imode=nint(cmd(i))
|
|
|
1263 |
|
|
|
1264 |
c Get parameter values
|
|
|
1265 |
i=i+1
|
|
|
1266 |
nval=nint(cmd(i))
|
|
|
1267 |
do j=1,nval
|
|
|
1268 |
i=i+1
|
|
|
1269 |
param(j)=cmd(i)
|
|
|
1270 |
enddo
|
|
|
1271 |
|
|
|
1272 |
c Get times (<time(j)> gets the row indices of <tra>)
|
|
|
1273 |
i=i+1
|
|
|
1274 |
nsel=nint(cmd(i))
|
|
|
1275 |
do j=1,nsel
|
|
|
1276 |
i=i+1
|
|
|
1277 |
time(j)=nint(cmd(i))
|
|
|
1278 |
enddo
|
|
|
1279 |
|
|
|
1280 |
c Get time mode
|
|
|
1281 |
i=i+1
|
|
|
1282 |
itime=nint(cmd(i))
|
|
|
1283 |
|
|
|
1284 |
c --- Prepare field values for analysis -----------
|
|
|
1285 |
|
|
|
1286 |
c Implicit variable: DIST
|
|
|
1287 |
if ( ivar.eq. -1 ) then
|
|
|
1288 |
length(1) = 0.
|
|
|
1289 |
do j=2,ntim
|
|
|
1290 |
lon0 = tra(j-1,2)
|
|
|
1291 |
lat0 = tra(j-1,3)
|
|
|
1292 |
lon1 = tra(j ,2)
|
|
|
1293 |
lat1 = tra(j ,3)
|
|
|
1294 |
length(j) = length(j-1) + sdis(lon0,lat0,lon1,lat1)
|
|
|
1295 |
enddo
|
|
|
1296 |
do j=1,nsel
|
|
|
1297 |
var(j) = length( time(j) )
|
|
|
1298 |
enddo
|
|
|
1299 |
|
|
|
1300 |
|
|
|
1301 |
c Implict variable: DIST0
|
|
|
1302 |
elseif ( ivar.eq. -2 ) then
|
|
|
1303 |
do j=1,nsel
|
|
|
1304 |
lon0 = tra(1 ,2)
|
|
|
1305 |
lat0 = tra(1 ,3)
|
|
|
1306 |
lon1 = tra(time(j),2)
|
|
|
1307 |
lat1 = tra(time(j),3)
|
|
|
1308 |
var(j) = sdis(lon0,lat0,lon1,lat1)
|
|
|
1309 |
enddo
|
|
|
1310 |
|
|
|
1311 |
c Implict variable: INPOLYGON
|
|
|
1312 |
elseif ( ivar.eq. -3 ) then
|
|
|
1313 |
do j=1,nsel
|
|
|
1314 |
lon1 = tra(time(j),2)
|
|
|
1315 |
lat1 = tra(time(j),3)
|
|
|
1316 |
call LctPtRelBndry(lat1,lon1,flag)
|
|
|
1317 |
if ( (flag.eq.1).or.(flag.eq.2) ) then
|
|
|
1318 |
var(j) = 1.
|
|
|
1319 |
else
|
|
|
1320 |
var(j) = 0.
|
|
|
1321 |
endif
|
|
|
1322 |
enddo
|
|
|
1323 |
|
|
|
1324 |
c Implict variable: INBOX
|
|
|
1325 |
elseif ( ivar.eq. -4 ) then
|
|
|
1326 |
do j=1,nsel
|
|
|
1327 |
lon1 = tra(time(j),2)
|
|
|
1328 |
lat1 = tra(time(j),3)
|
|
|
1329 |
if ( ( lon1.ge.param(1) ).and. ! lonmin
|
|
|
1330 |
> ( lon1.le.param(2) ).and. ! lonmax
|
|
|
1331 |
> ( lat1.ge.param(3) ).and. ! latmin
|
|
|
1332 |
> ( lat1.le.param(4) ) ) ! latmax
|
|
|
1333 |
> then
|
|
|
1334 |
var(j) = 1
|
|
|
1335 |
else
|
|
|
1336 |
var(j) = 0
|
|
|
1337 |
endif
|
|
|
1338 |
enddo
|
|
|
1339 |
|
|
|
1340 |
c Implict variable: INCIRCLE (lonc=param(1),latc=param(2),radius=param(3))
|
|
|
1341 |
elseif ( ivar.eq. -5 ) then
|
|
|
1342 |
do j=1,nsel
|
|
|
1343 |
lon1 = tra(time(j),2)
|
|
|
1344 |
lat1 = tra(time(j),3)
|
|
|
1345 |
|
|
|
1346 |
dist = sdis( lon1,lat1,param(1),param(2) )
|
|
|
1347 |
|
|
|
1348 |
if ( dist.le.param(3) ) then
|
|
|
1349 |
var(j) = 1
|
|
|
1350 |
else
|
|
|
1351 |
var(j) = 0
|
|
|
1352 |
endif
|
|
|
1353 |
enddo
|
|
|
1354 |
|
|
|
1355 |
c Implict variable: INREGION (xcorner=param(1..4),ycorner=param(5..8) )
|
|
|
1356 |
elseif ( ivar.eq.-6 ) then
|
|
|
1357 |
|
|
|
1358 |
do j=1,4
|
|
|
1359 |
xcorner(j) = param(j )
|
|
|
1360 |
ycorner(j) = param(j+4)
|
|
|
1361 |
enddo
|
|
|
1362 |
|
|
|
1363 |
do j=1,nsel
|
|
|
1364 |
lon1 = tra(time(j),2)
|
|
|
1365 |
lat1 = tra(time(j),3)
|
|
|
1366 |
var(j) = inregion (lon1,lat1,xcorner,ycorner)
|
|
|
1367 |
enddo
|
|
|
1368 |
|
|
|
1369 |
c Implict variable: TRIGGER
|
|
|
1370 |
elseif ( ivar.eq. -7 ) then
|
|
|
1371 |
do j=1,nsel
|
|
|
1372 |
intvar(j) = trigger( time(j) )
|
|
|
1373 |
enddo
|
|
|
1374 |
|
|
|
1375 |
|
|
|
1376 |
c Explicit variable (column index <ivar>)
|
|
|
1377 |
else
|
|
|
1378 |
do j=1,nsel
|
|
|
1379 |
var(j) = tra(time(j),ivar)
|
|
|
1380 |
enddo
|
|
|
1381 |
|
|
|
1382 |
endif
|
|
|
1383 |
|
|
|
1384 |
c Take MEAN of the variable (mean of selected times)
|
|
|
1385 |
if (imode.eq.2) then
|
|
|
1386 |
tmp=0.
|
|
|
1387 |
do j=1,nsel
|
|
|
1388 |
tmp=tmp+var(j)
|
|
|
1389 |
enddo
|
|
|
1390 |
var(1)=tmp/real(nsel)
|
|
|
1391 |
nsel=1
|
|
|
1392 |
|
|
|
1393 |
c Take MAX of the variable (maximum of selected times)
|
|
|
1394 |
elseif (imode.eq.3) then
|
|
|
1395 |
tmp=var(1)
|
|
|
1396 |
do j=2,nsel
|
|
|
1397 |
if (var(j).gt.tmp) tmp=var(j)
|
|
|
1398 |
enddo
|
|
|
1399 |
var(1)=tmp
|
|
|
1400 |
nsel=1
|
|
|
1401 |
|
|
|
1402 |
c Take MIN of the variable (minimum of selected times)
|
|
|
1403 |
elseif (imode.eq.4) then
|
|
|
1404 |
tmp=var(1)
|
|
|
1405 |
do j=2,nsel
|
|
|
1406 |
if (var(j).lt.tmp) tmp=var(j)
|
|
|
1407 |
enddo
|
|
|
1408 |
var(1)=tmp
|
|
|
1409 |
nsel=1
|
|
|
1410 |
|
|
|
1411 |
c Take VAR of the variable (variance over all selected times)
|
|
|
1412 |
elseif (imode.eq.5) then
|
|
|
1413 |
tmp=0.
|
|
|
1414 |
do j=1,nsel
|
|
|
1415 |
tmp=tmp+var(j)
|
|
|
1416 |
enddo
|
|
|
1417 |
mea=tmp/real(nsel)
|
|
|
1418 |
do j=1,nsel
|
|
|
1419 |
tmp=tmp+(var(j)-mea)**2
|
|
|
1420 |
enddo
|
|
|
1421 |
var(1)=1./real(nsel-1)*tmp
|
|
|
1422 |
nsel=1
|
|
|
1423 |
|
|
|
1424 |
c Take SUM of the variable (sum over all selected times)
|
|
|
1425 |
elseif (imode.eq.6) then
|
|
|
1426 |
tmp=0.
|
|
|
1427 |
do j=1,nsel
|
|
|
1428 |
tmp=tmp+var(j)
|
|
|
1429 |
enddo
|
|
|
1430 |
var(1)=tmp
|
|
|
1431 |
nsel=1
|
|
|
1432 |
|
|
|
1433 |
c Take CHANGE of the variable (change between first and last time)
|
|
|
1434 |
elseif (imode.eq.7) then
|
|
|
1435 |
var(1)=abs(var(1)-var(nsel))
|
|
|
1436 |
nsel=1
|
|
|
1437 |
|
|
|
1438 |
c Take DIFF of the variable (first minus last time)
|
|
|
1439 |
elseif (imode.eq.8) then
|
|
|
1440 |
var(1)=var(1)-var(nsel)
|
|
|
1441 |
nsel=1
|
|
|
1442 |
|
|
|
1443 |
endif
|
|
|
1444 |
|
|
|
1445 |
c --- Apply the operators to the single values ---
|
|
|
1446 |
|
|
|
1447 |
do j=1,nsel
|
|
|
1448 |
|
|
|
1449 |
c GT
|
|
|
1450 |
if (icmd.eq.1) then
|
|
|
1451 |
if (var(j).gt.param(1)) then
|
|
|
1452 |
istrue(j)=1
|
|
|
1453 |
else
|
|
|
1454 |
istrue(j)=0
|
|
|
1455 |
endif
|
|
|
1456 |
|
|
|
1457 |
c LT
|
|
|
1458 |
elseif (icmd.eq.2) then
|
|
|
1459 |
if (var(j).lt.param(1)) then
|
|
|
1460 |
istrue(j)=1
|
|
|
1461 |
else
|
|
|
1462 |
istrue(j)=0
|
|
|
1463 |
endif
|
|
|
1464 |
|
|
|
1465 |
c IN
|
|
|
1466 |
elseif (icmd.eq.3) then
|
|
|
1467 |
if ( (var(j).gt.param(1)).and.
|
|
|
1468 |
> (var(j).lt.param(2)) )
|
|
|
1469 |
> then
|
|
|
1470 |
istrue(j)=1
|
|
|
1471 |
else
|
|
|
1472 |
istrue(j)=0
|
|
|
1473 |
endif
|
|
|
1474 |
|
|
|
1475 |
c OUT
|
|
|
1476 |
elseif (icmd.eq.4) then
|
|
|
1477 |
if ( (var(j).lt.param(1)).or.
|
|
|
1478 |
> (var(j).gt.param(2)) )
|
|
|
1479 |
> then
|
|
|
1480 |
istrue(j)=1
|
|
|
1481 |
else
|
|
|
1482 |
istrue(j)=0
|
|
|
1483 |
endif
|
|
|
1484 |
|
|
|
1485 |
c EQ
|
|
|
1486 |
elseif (icmd.eq.5) then
|
|
|
1487 |
if (abs(var(j)-param(1)).lt.eps) then
|
|
|
1488 |
istrue(j)=1
|
|
|
1489 |
else
|
|
|
1490 |
istrue(j)=0
|
|
|
1491 |
endif
|
|
|
1492 |
|
|
|
1493 |
c TRUE
|
|
|
1494 |
elseif (icmd.eq.6) then
|
|
|
1495 |
if (abs(var(j)).lt.eps) then
|
|
|
1496 |
istrue(j)=0
|
|
|
1497 |
else
|
|
|
1498 |
istrue(j)=1
|
|
|
1499 |
endif
|
|
|
1500 |
|
|
|
1501 |
c FALSE
|
|
|
1502 |
elseif (icmd.eq.7) then
|
|
|
1503 |
if (abs(var(j)).lt.eps) then
|
|
|
1504 |
istrue(j)=1
|
|
|
1505 |
else
|
|
|
1506 |
istrue(j)=0
|
|
|
1507 |
endif
|
|
|
1508 |
|
|
|
1509 |
c ALL
|
|
|
1510 |
elseif (icmd.eq.8) then
|
|
|
1511 |
istrue(j) = 1
|
|
|
1512 |
do k=1,nval
|
|
|
1513 |
iparam = nint(param(k))-1
|
|
|
1514 |
if (btest(intvar(j),iparam).eqv..false.) then
|
|
|
1515 |
istrue(j) = 0
|
|
|
1516 |
endif
|
|
|
1517 |
enddo
|
|
|
1518 |
|
|
|
1519 |
c ANY
|
|
|
1520 |
elseif (icmd.eq.9) then
|
|
|
1521 |
istrue(j) = 0
|
|
|
1522 |
do k=1,nval
|
|
|
1523 |
iparam = nint(param(k))-1
|
|
|
1524 |
if (btest(intvar(j),iparam).eqv..true.) then
|
|
|
1525 |
istrue(j) = 1
|
|
|
1526 |
endif
|
|
|
1527 |
enddo
|
|
|
1528 |
|
|
|
1529 |
c NONE
|
|
|
1530 |
elseif (icmd.eq.10) then
|
|
|
1531 |
istrue(j) = 1
|
|
|
1532 |
do k=1,nval
|
|
|
1533 |
iparam = nint(param(k))-1
|
|
|
1534 |
if (btest(intvar(j),iparam).eqv..true.) then
|
|
|
1535 |
istrue(j) = 0
|
|
|
1536 |
endif
|
|
|
1537 |
enddo
|
|
|
1538 |
|
|
|
1539 |
endif
|
|
|
1540 |
|
|
|
1541 |
enddo
|
|
|
1542 |
|
|
|
1543 |
c --- Determine the overall boolean value ----------
|
|
|
1544 |
|
|
|
1545 |
c ALL
|
|
|
1546 |
if (itime.eq.1) then
|
|
|
1547 |
decision=1
|
|
|
1548 |
do j=1,nsel
|
|
|
1549 |
if (istrue(j).eq.0) then
|
|
|
1550 |
decision=0
|
|
|
1551 |
goto 110
|
|
|
1552 |
endif
|
|
|
1553 |
enddo
|
|
|
1554 |
110 continue
|
|
|
1555 |
|
|
|
1556 |
c ANY
|
|
|
1557 |
elseif (itime.eq.2) then
|
|
|
1558 |
decision=0
|
|
|
1559 |
do j=1,nsel
|
|
|
1560 |
if (istrue(j).eq.1) then
|
|
|
1561 |
decision=1
|
|
|
1562 |
goto 120
|
|
|
1563 |
endif
|
|
|
1564 |
enddo
|
|
|
1565 |
120 continue
|
|
|
1566 |
|
|
|
1567 |
c NONE
|
|
|
1568 |
elseif (itime.eq.3) then
|
|
|
1569 |
decision=1
|
|
|
1570 |
do j=1,nsel
|
|
|
1571 |
if (istrue(j).eq.1) then
|
|
|
1572 |
decision=0
|
|
|
1573 |
goto 130
|
|
|
1574 |
endif
|
|
|
1575 |
enddo
|
|
|
1576 |
130 continue
|
|
|
1577 |
|
|
|
1578 |
c TRIGGER
|
|
|
1579 |
elseif (itime.lt.0) then
|
|
|
1580 |
decision=1
|
|
|
1581 |
do j=1,nsel
|
|
|
1582 |
if (istrue(j).eq.1) then
|
|
|
1583 |
trigger(j) = ior( trigger(j), 2**(abs(itime)-1) )
|
|
|
1584 |
endif
|
|
|
1585 |
enddo
|
|
|
1586 |
|
|
|
1587 |
endif
|
|
|
1588 |
|
|
|
1589 |
c --- Put the new boolean value onto the stack
|
|
|
1590 |
|
|
|
1591 |
nstack=nstack+1
|
|
|
1592 |
stack(nstack)=decision
|
|
|
1593 |
|
|
|
1594 |
c Exit point for loop
|
|
|
1595 |
200 continue
|
|
|
1596 |
goto 100
|
|
|
1597 |
|
|
|
1598 |
endif
|
|
|
1599 |
|
|
|
1600 |
c Return the decision (selected or non-selected)
|
|
|
1601 |
300 continue
|
|
|
1602 |
|
|
|
1603 |
select=stack(1)
|
|
|
1604 |
|
|
|
1605 |
end
|
|
|
1606 |
|
|
|
1607 |
|
|
|
1608 |
c --------------------------------------------------------------------------
|
|
|
1609 |
c Split a region string and get corners of the domain
|
|
|
1610 |
c --------------------------------------------------------------------------
|
|
|
1611 |
|
|
|
1612 |
subroutine regionsplit(string,iregion,xcorner,ycorner)
|
|
|
1613 |
|
|
|
1614 |
c The region string comes either as <lonw,lone,lats,latn> or as <lon1,lat1,
|
|
|
1615 |
c lon2,lat2,lon3,lat3,lon4,lat4>: split it into ints components and get the
|
|
|
1616 |
c four coordinates for the region
|
|
|
1617 |
|
|
|
1618 |
implicit none
|
|
|
1619 |
|
|
|
1620 |
c Declaration of subroutine parameters
|
|
|
1621 |
character*80 string
|
|
|
1622 |
real xcorner(4),ycorner(4)
|
|
|
1623 |
integer iregion
|
|
|
1624 |
|
|
|
1625 |
c Local variables
|
|
|
1626 |
integer i,n
|
|
|
1627 |
integer il,ir
|
|
|
1628 |
real subfloat (80)
|
|
|
1629 |
integer stat
|
|
|
1630 |
integer len
|
|
|
1631 |
|
|
|
1632 |
c ------- Split the string
|
|
|
1633 |
i = 1
|
|
|
1634 |
n = 0
|
|
|
1635 |
stat = 0
|
|
|
1636 |
il = 1
|
|
|
1637 |
len = len_trim(string)
|
|
|
1638 |
|
|
|
1639 |
100 continue
|
|
|
1640 |
|
|
|
1641 |
c Find start of a substring
|
|
|
1642 |
do while ( stat.eq.0 )
|
|
|
1643 |
if ( string(i:i).ne.' ' ) then
|
|
|
1644 |
stat = 1
|
|
|
1645 |
il = i
|
|
|
1646 |
else
|
|
|
1647 |
i = i + 1
|
|
|
1648 |
endif
|
|
|
1649 |
enddo
|
|
|
1650 |
|
|
|
1651 |
c Find end of substring
|
|
|
1652 |
do while ( stat.eq.1 )
|
|
|
1653 |
if ( ( string(i:i).eq.' ' ) .or. ( i.eq.len ) ) then
|
|
|
1654 |
stat = 2
|
|
|
1655 |
ir = i
|
|
|
1656 |
else
|
|
|
1657 |
i = i + 1
|
|
|
1658 |
endif
|
|
|
1659 |
enddo
|
|
|
1660 |
|
|
|
1661 |
c Convert the substring into a number
|
|
|
1662 |
if ( stat.eq.2 ) then
|
|
|
1663 |
n = n + 1
|
|
|
1664 |
read(string(il:ir),*) subfloat(n)
|
|
|
1665 |
stat = 0
|
|
|
1666 |
endif
|
|
|
1667 |
|
|
|
1668 |
if ( i.lt.len ) goto 100
|
|
|
1669 |
|
|
|
1670 |
|
|
|
1671 |
c -------- Get the region number
|
|
|
1672 |
|
|
|
1673 |
iregion = nint(subfloat(1))
|
|
|
1674 |
|
|
|
1675 |
c -------- Get the corners of the region
|
|
|
1676 |
|
|
|
1677 |
if ( n.eq.5 ) then ! lonw(2),lone(3),lats(4),latn(5)
|
|
|
1678 |
|
|
|
1679 |
xcorner(1) = subfloat(2)
|
|
|
1680 |
ycorner(1) = subfloat(4)
|
|
|
1681 |
|
|
|
1682 |
xcorner(2) = subfloat(3)
|
|
|
1683 |
ycorner(2) = subfloat(4)
|
|
|
1684 |
|
|
|
1685 |
xcorner(3) = subfloat(3)
|
|
|
1686 |
ycorner(3) = subfloat(5)
|
|
|
1687 |
|
|
|
1688 |
xcorner(4) = subfloat(2)
|
|
|
1689 |
ycorner(4) = subfloat(5)
|
|
|
1690 |
|
|
|
1691 |
elseif ( n.eq.9 ) then ! lon1,lat1,lon2,lat2,lon3,lon4,lat4
|
|
|
1692 |
|
|
|
1693 |
xcorner(1) = subfloat(2)
|
|
|
1694 |
ycorner(1) = subfloat(3)
|
|
|
1695 |
|
|
|
1696 |
xcorner(2) = subfloat(4)
|
|
|
1697 |
ycorner(2) = subfloat(5)
|
|
|
1698 |
|
|
|
1699 |
xcorner(3) = subfloat(6)
|
|
|
1700 |
ycorner(3) = subfloat(7)
|
|
|
1701 |
|
|
|
1702 |
xcorner(4) = subfloat(8)
|
|
|
1703 |
ycorner(4) = subfloat(9)
|
|
|
1704 |
|
|
|
1705 |
else
|
|
|
1706 |
|
|
|
1707 |
print*,' ERROR: invalid region specification '
|
|
|
1708 |
print*,' ',trim(string)
|
|
|
1709 |
stop
|
|
|
1710 |
|
|
|
1711 |
endif
|
|
|
1712 |
|
|
|
1713 |
|
|
|
1714 |
end
|
|
|
1715 |
|
|
|
1716 |
c --------------------------------------------------------------------------
|
|
|
1717 |
c Decide whether lat/lon point is in or out of region
|
|
|
1718 |
c --------------------------------------------------------------------------
|
|
|
1719 |
|
|
|
1720 |
integer function inregion (lon,lat,xcorner,ycorner)
|
|
|
1721 |
|
|
|
1722 |
c Decide whether point (lon/lat) is in the region specified by <xcorner(1..4),
|
|
|
1723 |
c ycorner(1..4).
|
|
|
1724 |
|
|
|
1725 |
implicit none
|
|
|
1726 |
|
|
|
1727 |
c Declaration of subroutine parameters
|
|
|
1728 |
real lon,lat
|
|
|
1729 |
real xcorner(4),ycorner(4)
|
|
|
1730 |
|
|
|
1731 |
c Local variables
|
|
|
1732 |
integer flag
|
|
|
1733 |
real xmin,xmax,ymin,ymax
|
|
|
1734 |
integer i
|
|
|
1735 |
|
|
|
1736 |
c Reset the flag
|
|
|
1737 |
flag = 0
|
|
|
1738 |
|
|
|
1739 |
c Set some boundaries
|
|
|
1740 |
xmax = xcorner(1)
|
|
|
1741 |
xmin = xcorner(1)
|
|
|
1742 |
ymax = ycorner(1)
|
|
|
1743 |
ymin = ycorner(1)
|
|
|
1744 |
do i=2,4
|
|
|
1745 |
if (xcorner(i).lt.xmin) xmin = xcorner(i)
|
|
|
1746 |
if (xcorner(i).gt.xmax) xmax = xcorner(i)
|
|
|
1747 |
if (ycorner(i).lt.ymin) ymin = ycorner(i)
|
|
|
1748 |
if (ycorner(i).gt.ymax) ymax = ycorner(i)
|
|
|
1749 |
enddo
|
|
|
1750 |
|
|
|
1751 |
c Do the tests - set flag=1 if all tests pased
|
|
|
1752 |
if (lon.lt.xmin) goto 970
|
|
|
1753 |
if (lon.gt.xmax) goto 970
|
|
|
1754 |
if (lat.lt.ymin) goto 970
|
|
|
1755 |
if (lat.gt.ymax) goto 970
|
|
|
1756 |
|
|
|
1757 |
if ((lon-xcorner(1))*(ycorner(2)-ycorner(1))-
|
|
|
1758 |
> (lat-ycorner(1))*(xcorner(2)-xcorner(1)).gt.0.) goto 970
|
|
|
1759 |
if ((lon-xcorner(2))*(ycorner(3)-ycorner(2))-
|
|
|
1760 |
> (lat-ycorner(2))*(xcorner(3)-xcorner(2)).gt.0.) goto 970
|
|
|
1761 |
if ((lon-xcorner(3))*(ycorner(4)-ycorner(3))-
|
|
|
1762 |
> (lat-ycorner(3))*(xcorner(4)-xcorner(3)).gt.0.) goto 970
|
|
|
1763 |
if ((lon-xcorner(4))*(ycorner(1)-ycorner(4))-
|
|
|
1764 |
> (lat-ycorner(4))*(xcorner(1)-xcorner(4)).gt.0.) goto 970
|
|
|
1765 |
|
|
|
1766 |
flag = 1
|
|
|
1767 |
|
|
|
1768 |
c Return the value
|
|
|
1769 |
970 continue
|
|
|
1770 |
|
|
|
1771 |
inregion = flag
|
|
|
1772 |
|
|
|
1773 |
return
|
|
|
1774 |
|
|
|
1775 |
end
|
|
|
1776 |
|
|
|
1777 |
|
|
|
1778 |
c --------------------------------------------------------------------------
|
|
|
1779 |
c Spherical distance between lat/lon points
|
|
|
1780 |
c --------------------------------------------------------------------------
|
|
|
1781 |
|
|
|
1782 |
real function sdis(xp,yp,xq,yq)
|
|
|
1783 |
c
|
|
|
1784 |
c calculates spherical distance (in km) between two points given
|
|
|
1785 |
c by their spherical coordinates (xp,yp) and (xq,yq), respectively.
|
|
|
1786 |
c
|
|
|
1787 |
real re
|
|
|
1788 |
parameter (re=6370.)
|
|
|
1789 |
real pi180
|
|
|
1790 |
parameter (pi180=3.14159/180.)
|
|
|
1791 |
real xp,yp,xq,yq,arg
|
|
|
1792 |
|
|
|
1793 |
arg=sin(pi180*yp)*sin(pi180*yq)+
|
|
|
1794 |
> cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
|
|
|
1795 |
if (arg.lt.-1.) arg=-1.
|
|
|
1796 |
if (arg.gt.1.) arg=1.
|
|
|
1797 |
|
|
|
1798 |
sdis=re*acos(arg)
|
|
|
1799 |
|
|
|
1800 |
end
|
|
|
1801 |
|
|
|
1802 |
|
|
|
1803 |
c ****************************************************************
|
|
|
1804 |
c * Given some spherical polygon S and some point X known to be *
|
|
|
1805 |
c * located inside S, these routines will determine if an arbit- *
|
|
|
1806 |
c * -rary point P lies inside S, outside S, or on its boundary. *
|
|
|
1807 |
c * The calling program must first call DefSPolyBndry to define *
|
|
|
1808 |
c * the boundary of S and the point X. Any subsequent call to *
|
|
|
1809 |
c * subroutine LctPtRelBndry will determine if some point P lies *
|
|
|
1810 |
c * inside or outside S, or on its boundary. (Usually *
|
|
|
1811 |
c * DefSPolyBndry is called once, then LctPrRelBndry is called *
|
|
|
1812 |
c * many times). *
|
|
|
1813 |
c * *
|
|
|
1814 |
c * REFERENCE: Bevis, M. and Chatelain, J.-L. (1989) *
|
|
|
1815 |
c * Maflaematical Geology, vol 21. *
|
|
|
1816 |
c * VERSION 1.0 *
|
|
|
1817 |
c ****************************************************************
|
|
|
1818 |
|
|
|
1819 |
Subroutine DefSPolyBndry(vlat,vlon,nv,xlat, xlon)
|
|
|
1820 |
|
|
|
1821 |
c ****************************************************************
|
|
|
1822 |
c * This mmn entry point is used m define ~e spheric~ polygon S *
|
|
|
1823 |
c * and the point X. *
|
|
|
1824 |
c * ARGUMENTS: *
|
|
|
1825 |
c * vlat,vlon (sent) ... vectors containing the latitude and *
|
|
|
1826 |
c * longitude of each vertex of the *
|
|
|
1827 |
c * spherical polygon S. The ith.vertex is *
|
|
|
1828 |
c * located at [vlat(i),vlon(i)]. *
|
|
|
1829 |
c * nv (sent) ... the number of vertices and sides in the *
|
|
|
1830 |
c * spherical polygon S *
|
|
|
1831 |
c * xlat,xlon (sent) ... latitude and longitude of some point X *
|
|
|
1832 |
c * located inside S. X must not be located *
|
|
|
1833 |
c * on any great circle that includes two *
|
|
|
1834 |
c * vertices of S. *
|
|
|
1835 |
c * *
|
|
|
1836 |
c * UNITS AND SIGN CONVENTION: *
|
|
|
1837 |
c * Latitudes and longitudes are specified in degrees. *
|
|
|
1838 |
c * Latitudes are positive to the north and negative to the *
|
|
|
1839 |
c * south. *
|
|
|
1840 |
c * Longitudes are positive to the east and negative to the *
|
|
|
1841 |
c * west. *
|
|
|
1842 |
c * *
|
|
|
1843 |
c * VERTEX ENUMERATION: *
|
|
|
1844 |
c * The vertices of S should be numbered sequentially around the *
|
|
|
1845 |
c * border of the spherical polygon. Vertex 1 lies between vertex*
|
|
|
1846 |
c * nv and vertex 2. Neighbouring vertices must be seperated by *
|
|
|
1847 |
c * less than 180 degrees. (In order to generate a polygon side *
|
|
|
1848 |
c * whose arc length equals or exceeds 180 degrees simply *
|
|
|
1849 |
c * introduce an additional (pseudo)vertex). Having chosen *
|
|
|
1850 |
c * vertex 1, the user may number the remaining vertices in *
|
|
|
1851 |
c * either direction. However if the user wishes to use the *
|
|
|
1852 |
c * subroutine SPA to determine the area of the polygon S (Bevis *
|
|
|
1853 |
c * & Cambareri, 1987, Math. Geol., v.19, p. 335-346) then he or *
|
|
|
1854 |
c * she must follow the convention whereby in moving around the *
|
|
|
1855 |
c * polygon border in the direction of increasing vertex number *
|
|
|
1856 |
c * clockwise bends occur at salient vertices. A vertex is *
|
|
|
1857 |
c * salient if the interior angle is less than 180 degrees. *
|
|
|
1858 |
c * (In the case of a convex polygon this convention implies *
|
|
|
1859 |
c * that vertices are numbered in clockwise sequence). *
|
|
|
1860 |
c ****************************************************************
|
|
|
1861 |
|
|
|
1862 |
implicit none
|
|
|
1863 |
|
|
|
1864 |
integer mxnv,nv
|
|
|
1865 |
|
|
|
1866 |
c ----------------------------------------------------------------
|
|
|
1867 |
c Edit next statement to increase maximum number of vertices that
|
|
|
1868 |
c may be used to define the spherical polygon S
|
|
|
1869 |
c The value of parameter mxnv in subroutine LctPtRelBndry must match
|
|
|
1870 |
c that of parameter mxnv in this subroutine, as assigned above.
|
|
|
1871 |
c ----------------------------------------------------------------
|
|
|
1872 |
parameter (mxnv=2000)
|
|
|
1873 |
|
|
|
1874 |
real vlat(nv),vlon(nv),xlat,xlon,dellon
|
|
|
1875 |
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
|
|
|
1876 |
integer i,ibndry,nv_c,ip
|
|
|
1877 |
|
|
|
1878 |
data ibndry/0/
|
|
|
1879 |
|
|
|
1880 |
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
|
|
|
1881 |
|
|
|
1882 |
if (nv.gt.mxnv) then
|
|
|
1883 |
print *,'nv exceeds maximum allowed value'
|
|
|
1884 |
print *,'adjust parameter mxnv in subroutine DefSPolyBndry'
|
|
|
1885 |
stop
|
|
|
1886 |
endif
|
|
|
1887 |
|
|
|
1888 |
ibndry=1 ! boundary defined at least once (flag)
|
|
|
1889 |
nv_c=nv ! copy for named common
|
|
|
1890 |
xlat_c=xlat ! . . . .
|
|
|
1891 |
xlon_c=xlon !
|
|
|
1892 |
|
|
|
1893 |
do i=1,nv
|
|
|
1894 |
vlat_c(i)=vlat(i) ! "
|
|
|
1895 |
vlon_c(i)=vlon(i) !
|
|
|
1896 |
|
|
|
1897 |
call TrnsfmLon(xlat,xlon,vlat(i),vlon(i),tlonv(i))
|
|
|
1898 |
|
|
|
1899 |
if (i.gt.1) then
|
|
|
1900 |
ip=i-1
|
|
|
1901 |
else
|
|
|
1902 |
ip=nv
|
|
|
1903 |
endif
|
|
|
1904 |
|
|
|
1905 |
if ((vlat(i).eq.vlat(ip)).and.(vlon(i).eq.vlon(ip))) then
|
|
|
1906 |
print *,'DefSPolyBndry detects user error:'
|
|
|
1907 |
print *,'vertices ',i,' and ',ip,' are not distinct'
|
|
|
1908 |
print*,'lat ',i,ip,vlat(i),vlat(ip)
|
|
|
1909 |
print*,'lon ',i,ip,vlon(i),vlon(ip)
|
|
|
1910 |
stop
|
|
|
1911 |
endif
|
|
|
1912 |
|
|
|
1913 |
if (tlonv(i).eq.tlonv(ip)) then
|
|
|
1914 |
print *,'DefSPolyBndry detects user error:'
|
|
|
1915 |
print *,'vertices ',i,' & ',ip,' on same gt. circle as X'
|
|
|
1916 |
stop
|
|
|
1917 |
endif
|
|
|
1918 |
|
|
|
1919 |
if (vlat(i).eq.(-vlat(ip))) then
|
|
|
1920 |
dellon=vlon(i)-vlon(ip)
|
|
|
1921 |
if (dellon.gt.+180.) dellon=dellon-360.
|
|
|
1922 |
if (dellon.lt.-180.) dellon=dellon-360.
|
|
|
1923 |
if ((dellon.eq.+180.0).or.(dellon.eq.-180.0)) then
|
|
|
1924 |
print *,'DefSPolyBndry detects user error:'
|
|
|
1925 |
print *,'vertices ',i,' and ',ip,' are antipodal'
|
|
|
1926 |
stop
|
|
|
1927 |
endif
|
|
|
1928 |
endif
|
|
|
1929 |
enddo
|
|
|
1930 |
|
|
|
1931 |
return
|
|
|
1932 |
|
|
|
1933 |
end
|
|
|
1934 |
|
|
|
1935 |
|
|
|
1936 |
c ****************************************************************
|
|
|
1937 |
|
|
|
1938 |
Subroutine LctPtRelBndry(plat,plon,location)
|
|
|
1939 |
|
|
|
1940 |
c ****************************************************************
|
|
|
1941 |
|
|
|
1942 |
c ****************************************************************
|
|
|
1943 |
c * This routine is used to see if some point P is located *
|
|
|
1944 |
c * inside, outside or on the boundary of the spherical polygon *
|
|
|
1945 |
c * S previously defined by a call to subroutine DefSPolyBndry. *
|
|
|
1946 |
c * There is a single restriction on point P: it must not be *
|
|
|
1947 |
c * antipodal to the point X defined in the call to DefSPolyBndry*
|
|
|
1948 |
c * (ie.P and X cannot be seperated by exactly 180 degrees). *
|
|
|
1949 |
c * ARGUMENTS: *
|
|
|
1950 |
c * plat,plon (sent)... the latitude and longitude of point P *
|
|
|
1951 |
c * location (returned)... specifies the location of P: *
|
|
|
1952 |
c * location=0 implies P is outside of S *
|
|
|
1953 |
c * location=1 implies P is inside of S *
|
|
|
1954 |
c * location=2 implies P on boundary of S *
|
|
|
1955 |
c * location=3 implies user error (P is *
|
|
|
1956 |
c * antipodal to X) *
|
|
|
1957 |
c * UNFfS AND SIGN CONVENTION: *
|
|
|
1958 |
c * Latitudes and longitudes are specified in degrees. *
|
|
|
1959 |
c * Latitudes are positive to the north and negative to the *
|
|
|
1960 |
c * south. *
|
|
|
1961 |
c * Longitudes are positive to the east and negative to the *
|
|
|
1962 |
c * west. *
|
|
|
1963 |
c ****************************************************************
|
|
|
1964 |
|
|
|
1965 |
implicit none
|
|
|
1966 |
|
|
|
1967 |
integer mxnv
|
|
|
1968 |
|
|
|
1969 |
c ----------------------------------------------------------------
|
|
|
1970 |
c The statement below must match that in subroutine DefSPolyBndry
|
|
|
1971 |
c ----------------------------------------------------------------
|
|
|
1972 |
|
|
|
1973 |
parameter (mxnv=2000)
|
|
|
1974 |
|
|
|
1975 |
real tlonv(mxnv),vlat_c(mxnv),vlon_c(mxnv),xlat_c,xlon_c
|
|
|
1976 |
real plat,plon,vAlat,vAlon,vBlat,vBlon,tlonA,tlonB,tlonP
|
|
|
1977 |
real tlon_X,tlon_P,tlon_B,dellon
|
|
|
1978 |
integer i,ibndry,nv_c,location,icross,ibrngAB,ibrngAP,ibrngPB
|
|
|
1979 |
integer ibrng_BX,ibrng_BP,istrike
|
|
|
1980 |
|
|
|
1981 |
common/spolybndry/vlat_c,vlon_c,nv_c,xlat_c,xlon_c,tlonv,ibndry
|
|
|
1982 |
|
|
|
1983 |
if (ibndry.eq.0) then ! user has never defined the bndry
|
|
|
1984 |
print*,'Subroutine LctPtRelBndry detects user error:'
|
|
|
1985 |
print*,'Subroutine DefSPolyBndry must be called before'
|
|
|
1986 |
print*,'subroutine LctPtRelBndry can be called'
|
|
|
1987 |
stop
|
|
|
1988 |
endif
|
|
|
1989 |
|
|
|
1990 |
if (plat.eq.(-xlat_c)) then
|
|
|
1991 |
dellon=plon-xlon_c
|
|
|
1992 |
if (dellon.lt.(-180.)) dellon=dellon+360.
|
|
|
1993 |
if (dellon.gt.+180.) dellon=dellon-360.
|
|
|
1994 |
if ((dellon.eq.+180.0).or.(dellon.eq.-180.)) then
|
|
|
1995 |
print*,'Warning: LctPtRelBndry detects case P antipodal
|
|
|
1996 |
> to X'
|
|
|
1997 |
print*,'location of P relative to S is undetermined'
|
|
|
1998 |
location=3
|
|
|
1999 |
return
|
|
|
2000 |
endif
|
|
|
2001 |
endif
|
|
|
2002 |
|
|
|
2003 |
location=0 ! default ( P is outside S)
|
|
|
2004 |
icross=0 ! initialize counter
|
|
|
2005 |
|
|
|
2006 |
if ((plat.eq.xlat_c).and.(plon.eq.xlon_c)) then
|
|
|
2007 |
location=1
|
|
|
2008 |
return
|
|
|
2009 |
endif
|
|
|
2010 |
|
|
|
2011 |
|
|
|
2012 |
call TrnsfmLon (xlat_c,xlon_c,plat,plon,tlonP)
|
|
|
2013 |
|
|
|
2014 |
do i=1,nv_c ! start of loop over sides of S
|
|
|
2015 |
|
|
|
2016 |
vAlat=vlat_c(i)
|
|
|
2017 |
vAlon=vlon_c(i)
|
|
|
2018 |
tlonA=tlonv(i)
|
|
|
2019 |
|
|
|
2020 |
if (i.lt.nv_c) then
|
|
|
2021 |
vBlat=vlat_c(i+1)
|
|
|
2022 |
vBlon=vlon_c(i+1)
|
|
|
2023 |
tlonB=tlonv(i+1)
|
|
|
2024 |
else
|
|
|
2025 |
vBlat=vlat_c(1)
|
|
|
2026 |
vBlon=vlon_c(1)
|
|
|
2027 |
tlonB=tlonv(1)
|
|
|
2028 |
endif
|
|
|
2029 |
|
|
|
2030 |
istrike=0
|
|
|
2031 |
|
|
|
2032 |
if (tlonP.eq.tlonA) then
|
|
|
2033 |
istrike=1
|
|
|
2034 |
else
|
|
|
2035 |
call EastOrWest(tlonA,tlonB,ibrngAB)
|
|
|
2036 |
call EastOrWest(tlonA,tlonP,ibrngAP)
|
|
|
2037 |
call EastOrWest(tlonP,tlonB,ibrngPB)
|
|
|
2038 |
|
|
|
2039 |
|
|
|
2040 |
if((ibrngAP.eq.ibrngAB).and.(ibrngPB.eq.ibrngAB)) istrike=1
|
|
|
2041 |
endif
|
|
|
2042 |
|
|
|
2043 |
|
|
|
2044 |
if (istrike.eq.1) then
|
|
|
2045 |
|
|
|
2046 |
if ((plat.eq.vAlat).and.(plon.eq.vAlon)) then
|
|
|
2047 |
location=2 ! P lies on a vertex of S
|
|
|
2048 |
return
|
|
|
2049 |
endif
|
|
|
2050 |
call TrnsfmLon(vAlat,vAlon,xlat_c,xlon_c,tlon_X)
|
|
|
2051 |
call TrnsfmLon(vAlat,vAlon,vBlat,vBlon,tlon_B)
|
|
|
2052 |
call TrnsfmLon(vAlat,vAlon,plat,plon,tlon_P)
|
|
|
2053 |
|
|
|
2054 |
if (tlon_P.eq.tlon_B) then
|
|
|
2055 |
location=2 ! P lies on side of S
|
|
|
2056 |
return
|
|
|
2057 |
else
|
|
|
2058 |
call EastOrWest(tlon_B,tlon_X,ibrng_BX)
|
|
|
2059 |
call EastOrWest(tlon_B,tlon_P,ibrng_BP)
|
|
|
2060 |
if(ibrng_BX.eq.(-ibrng_BP)) icross=icross+1
|
|
|
2061 |
endif
|
|
|
2062 |
|
|
|
2063 |
endif
|
|
|
2064 |
enddo ! end of loop over the sides of S
|
|
|
2065 |
|
|
|
2066 |
|
|
|
2067 |
c if the arc XP crosses the boundary S an even number of times then P
|
|
|
2068 |
c is in S
|
|
|
2069 |
|
|
|
2070 |
if (mod(icross,2).eq.0) location=1
|
|
|
2071 |
|
|
|
2072 |
return
|
|
|
2073 |
|
|
|
2074 |
end
|
|
|
2075 |
|
|
|
2076 |
|
|
|
2077 |
c ****************************************************************
|
|
|
2078 |
|
|
|
2079 |
subroutine TrnsfmLon(plat,plon,qlat,qlon,tranlon)
|
|
|
2080 |
|
|
|
2081 |
c ****************************************************************
|
|
|
2082 |
c * This subroutine is required by subroutines DefSPolyBndry & *
|
|
|
2083 |
c * LctPtRelBndry. It finds the 'longitude' of point Q in a *
|
|
|
2084 |
c * geographic coordinate system for which point P acts as a *
|
|
|
2085 |
c * 'north pole'. SENT: plat,plon,qlat,qlon, in degrees. *
|
|
|
2086 |
c * RETURNED: tranlon, in degrees. *
|
|
|
2087 |
c ****************************************************************
|
|
|
2088 |
|
|
|
2089 |
implicit none
|
|
|
2090 |
|
|
|
2091 |
real pi,dtr,plat,plon,qlat,qlon,tranlon,t,b
|
|
|
2092 |
parameter (pi=3.141592654,dtr=pi/180.0)
|
|
|
2093 |
|
|
|
2094 |
if (plat.eq.90.) then
|
|
|
2095 |
tranlon=qlon
|
|
|
2096 |
else
|
|
|
2097 |
t=sin((qlon-plon)*dtr)*cos(qlat*dtr)
|
|
|
2098 |
b=sin(dtr*qlat)*cos(plat*dtr)-cos(qlat*dtr)*sin(plat*dtr)
|
|
|
2099 |
> *cos((qlon-plon)*dtr)
|
|
|
2100 |
tranlon=atan2(t,b)/dtr
|
|
|
2101 |
endif
|
|
|
2102 |
|
|
|
2103 |
return
|
|
|
2104 |
end
|
|
|
2105 |
|
|
|
2106 |
c ****************************************************************
|
|
|
2107 |
|
|
|
2108 |
subroutine EastOrWest(clon,dlon,ibrng)
|
|
|
2109 |
|
|
|
2110 |
c ****************************************************************
|
|
|
2111 |
c * This subroutine is required by subroutine LctPtRelBndry. *
|
|
|
2112 |
c * This routine determines if in travelling the shortest path *
|
|
|
2113 |
c * from point C (at longitude clon) to point D (at longitude *
|
|
|
2114 |
c * dlon) one is heading east, west or neither. *
|
|
|
2115 |
c * SENT: clon,dlon; in degrees. RETURNED: ibrng *
|
|
|
2116 |
c * (1=east,-1=west, 0=neither). *
|
|
|
2117 |
c ****************************************************************
|
|
|
2118 |
|
|
|
2119 |
implicit none
|
|
|
2120 |
real clon,dlon,del
|
|
|
2121 |
integer ibrng
|
|
|
2122 |
del=dlon-clon
|
|
|
2123 |
if (del.gt.180.) del=del-360.
|
|
|
2124 |
if (del.lt.-180.) del=del+360.
|
|
|
2125 |
if ((del.gt.0.0).and.(del.ne.180.)) then
|
|
|
2126 |
ibrng=-1 ! (D is west of C)
|
|
|
2127 |
elseif ((del.lt.0.0).and.(del.ne.-180.)) then
|
|
|
2128 |
ibrng=+1 ! (D is east of C)
|
|
|
2129 |
else
|
|
|
2130 |
ibrng=0 ! (D north or south of C)
|
|
|
2131 |
endif
|
|
|
2132 |
return
|
|
|
2133 |
end
|