ROMS
Loading...
Searching...
No Matches
read_fltpar.F
Go to the documentation of this file.
1#include "cppdefs.h"
2#ifdef FLOATS
3 SUBROUTINE read_fltpar (model, inp, out, Lwrite)
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This routine reads and reports floats input parameters. !
13! !
14!=======================================================================
15!
16 USE mod_param
17 USE mod_parallel
18 USE mod_floats
19 USE mod_iounits
20 USE mod_ncparam
21 USE mod_scalars
22!
23 USE inp_decode_mod
24!
25 USE strings_mod, ONLY : founderror
26!
27 implicit none
28!
29! Imported variable declarations
30!
31 logical, intent(in) :: Lwrite
32!
33 integer, intent(in) :: model, inp, out
34!
35! Local variable declarations.
36!
37 integer :: Npts, Nval
38 integer :: i, j, igrid, mc, nc, ng, status
39
40 integer, dimension(Ngrids) :: ncount, nentry
41
42 integer, allocatable :: Fcoor(:,:), Fcount(:,:), Ftype(:,:)
43!
44 real(r8) :: xfloat, yfloat, zfloat
45
46 real(dp), dimension(nRval) :: Rval
47
48 real(r8), allocatable :: Ft0(:,:), Fx0(:,:), Fy0(:,:), Fz0(:,:)
49 real(r8), allocatable :: Fdt(:,:), Fdx(:,:), Fdy(:,:), Fdz(:,:)
50!
51 character (len=1 ), parameter :: blank = ' '
52
53 character (len=35 ) :: frmt
54 character (len=40 ) :: KeyWord
55 character (len=256) :: fname, line
56 character (len=256), dimension(nCval) :: Cval
57
58 character (len=*), parameter :: MyFile = &
59 & __FILE__
60!
61!-----------------------------------------------------------------------
62! Read in initial float locations.
63!-----------------------------------------------------------------------
64!
65! Allocate floats parameters that do not depend on the number of
66! floats, Nfloats(ng).
67!
68 CALL allocate_floats (.false.)
69!
70! Notice I added one when allocating local scratch arrays to avoid
71! out of bounds in some compilers when reading the last blank line
72! which signal termination of input data.
73!
74 DO WHILE (.true.)
75 READ (inp,'(a)',err=20,END=30) line
76 status=decode_line(line, keyword, nval, cval, rval)
77 IF (status.gt.0) THEN
78 SELECT CASE (trim(keyword))
79 CASE ('Lfloats')
80 npts=load_l(nval, cval, ngrids, lfloats)
81 CASE ('Fprint')
82 npts=load_l(nval, cval, ngrids, fprint)
83 CASE ('FRREC')
84 npts=load_i(nval, rval, ngrids, frrec)
85 CASE ('FBIONAM')
86 DO i=1,len(fbionam)
87 fbionam(i:i)=blank
88 END DO
89 fbionam=trim(adjustl(cval(nval)))
90 CASE ('NFLOATS')
91 npts=load_i(nval, rval, ngrids, nfloats)
92 CASE ('POS')
93 npts=nfloats(1)+1
94 IF (ngrids.gt.1) npts=maxval(nfloats)+1
95 IF (.not.allocated(fcoor)) THEN
96 allocate ( fcoor(npts,ngrids) )
97 dmem(1)=dmem(1)+real(npts*ngrids,r8)
98 END IF
99 IF (.not.allocated(fcount)) THEN
100 allocate ( fcount(npts,ngrids) )
101 dmem(1)=dmem(1)+real(npts*ngrids,r8)
102 END IF
103 IF (.not.allocated(ftype)) THEN
104 allocate ( ftype(npts,ngrids) )
105 dmem(1)=dmem(1)+real(npts*ngrids,r8)
106 END IF
107 IF (.not.allocated(ft0)) THEN
108 allocate ( ft0(npts,ngrids) )
109 dmem(1)=dmem(1)+real(npts*ngrids,r8)
110 END IF
111 IF (.not.allocated(fx0)) THEN
112 allocate ( fx0(npts,ngrids) )
113 dmem(1)=dmem(1)+real(npts*ngrids,r8)
114 END IF
115 IF (.not.allocated(fy0)) THEN
116 allocate ( fy0(npts,ngrids) )
117 dmem(1)=dmem(1)+real(npts*ngrids,r8)
118 END IF
119 IF (.not.allocated(fz0)) THEN
120 allocate ( fz0(npts,ngrids) )
121 dmem(1)=dmem(1)+real(npts*ngrids,r8)
122 END IF
123 IF (.not.allocated(fdt)) THEN
124 allocate ( fdt(npts,ngrids) )
125 dmem(1)=dmem(1)+real(npts*ngrids,r8)
126 END IF
127 IF (.not.allocated(fdx)) THEN
128 allocate ( fdx(npts,ngrids) )
129 dmem(1)=dmem(1)+real(npts*ngrids,r8)
130 END IF
131 IF (.not.allocated(fdy)) THEN
132 allocate ( fdy(npts,ngrids) )
133 dmem(1)=dmem(1)+real(npts*ngrids,r8)
134 END IF
135 IF (.not.allocated(fdz)) THEN
136 allocate ( fdz(npts,ngrids) )
137 dmem(1)=dmem(1)+real(npts*ngrids,r8)
138 END IF
139 CALL allocate_floats (.true.) ! allocate DRIFTER structure
140 ncount(1:ngrids)=0
141 nentry(1:ngrids)=0
142 DO WHILE (.true.)
143 READ (inp,*,err=30,END=30) igrid, &
144 & fcoor(nentry(igrid)+1,igrid), &
145 & ftype(nentry(igrid)+1,igrid), &
146 & fcount(nentry(igrid)+1,igrid), &
147 & ft0(nentry(igrid)+1,igrid), &
148 & fx0(nentry(igrid)+1,igrid), &
149 & fy0(nentry(igrid)+1,igrid), &
150 & fz0(nentry(igrid)+1,igrid), &
151 & fdt(nentry(igrid)+1,igrid), &
152 & fdx(nentry(igrid)+1,igrid), &
153 & fdy(nentry(igrid)+1,igrid), &
154 & fdz(nentry(igrid)+1,igrid)
155 IF (igrid.gt.ngrids) THEN
156 IF (master) WRITE (out,60) fposnam
157 exit_flag=4
158 RETURN
159 END IF
160 ncount(igrid)=ncount(igrid)+ &
161 & fcount(nentry(igrid)+1,igrid)
162 nentry(igrid)=nentry(igrid)+1
163 END DO
164 END SELECT
165 END IF
166 END DO
167 20 IF (master) WRITE (out,70) line
168 exit_flag=4
169 RETURN
170 30 CONTINUE
171!
172! Turn off the processing of floats if not running long enough to
173! create a floats file (LdefFLT=.FALSE. because nFLT < ntimes or
174! nFLT = 0 when nrrec = 0).
175!
176 DO ng=1,ngrids
177 IF (.not.ldefflt(ng).and.lfloats(ng)) THEN
178 lfloats(ng)=.false.
179 END IF
180 END DO
181!
182!-----------------------------------------------------------------------
183! Report input parameters.
184!-----------------------------------------------------------------------
185!
186 IF (master.and.lwrite) THEN
187 DO ng=1,ngrids
188 IF (lfloats(ng).and.fprint(ng)) THEN
189 IF (ncount(ng).ne.nfloats(ng)) THEN
190 WRITE (stdout,80) ncount(ng), nfloats(ng)
191 exit_flag=4
192 RETURN
193 END IF
194 WRITE (out,90) ng
195 DO i=1,nentry(ng)
196 IF (.not.spherical.and.(fcoor(i,ng).eq.0)) THEN
197 frmt='(i1,i2,i5,f10.4,2f8.2,f8.2,4f9.3)'
198 ELSE
199 frmt='(i1,i2,i5,f10.4,3f8.2,4f9.3)'
200 END IF
201 WRITE (out,frmt) fcoor(i,ng), ftype(i,ng), fcount(i,ng), &
202 & ft0(i,ng), fx0(i,ng), fy0(i,ng), &
203 & fz0(i,ng), fdt(i,ng), fdx(i,ng), &
204 & fdy(i,ng), fdz(i,ng)
205 END DO
206 WRITE (out,100) nfloats(ng), &
207 & 'Nfloats', &
208 & 'Number of float trajectories to compute.'
209 END IF
210 END DO
211 END IF
212
213# ifdef FLOAT_BIOLOGY
214 fname=fbionam
215 IF (.not.find_file(1, out, fname, 'FBIONAM')) THEN
216 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
217 ELSE
218 IF (master.and.lwrite) THEN
219 WRITE (out,120) 'biological floats behavior File: ', &
220 & trim(fname)
221 END IF
222 END IF
223# endif
224!
225!-----------------------------------------------------------------------
226! Process initial float locations.
227!-----------------------------------------------------------------------
228!
229! Set time of float release (seconds after model initialization) and
230! initial float horizontal positions (grid units). Fill the initial
231! vertical level or depth position.
232!
233 DO ng=1,ngrids
234 mc=0
235 nc=0
236 IF (lfloats(ng)) THEN
237 DO i=1,nentry(ng)
238 IF (fcount(i,ng).eq.1) THEN
239 nc=nc+1
240 drifter(ng)%Tinfo(itstr,nc)=(dstart+ft0(i,ng))*day2sec
241 drifter(ng)%Tinfo(izgrd,nc)=fz0(i,ng)
242 drifter(ng)%Ftype(nc)=ftype(i,ng)
243 IF (fcoor(i,ng).eq.0) THEN
244 drifter(ng)%Tinfo(ixgrd,nc)=fx0(i,ng)
245 drifter(ng)%Tinfo(iygrd,nc)=fy0(i,ng)
246 ELSE
247 mc=mc+1
248 drifter(ng)%Flon(mc)=fx0(i,ng)
249 drifter(ng)%Flat(mc)=fy0(i,ng)
250 drifter(ng)%Findex(mc)=nc
251 END IF
252 ELSE IF (fcount(i,ng).gt.1) THEN
253 DO j=1,fcount(i,ng)
254 nc=nc+1
255 IF (fdt(i,ng).gt.0.0_r8) THEN
256 drifter(ng)%Tinfo(itstr,nc)=(dstart+ft0(i,ng)+ &
257 & real(j-1,r8)*fdt(i,ng))* &
258 & day2sec
259 drifter(ng)%Tinfo(izgrd,nc)=fz0(i,ng)
260 drifter(ng)%Ftype(nc)=ftype(i,ng)
261 IF (fcoor(i,ng).eq.0) THEN
262 drifter(ng)%Tinfo(ixgrd,nc)=fx0(i,ng)
263 drifter(ng)%Tinfo(iygrd,nc)=fy0(i,ng)
264 ELSE
265 mc=mc+1
266 drifter(ng)%Flon(mc)=fx0(i,ng)
267 drifter(ng)%Flat(mc)=fy0(i,ng)
268 drifter(ng)%Findex(mc)=nc
269 END IF
270 ELSE
271 drifter(ng)%Tinfo(itstr,nc)=(dstart+ft0(i,ng))*day2sec
272 IF (fdz(i,ng).eq.0.0_r8) THEN
273 drifter(ng)%Tinfo(izgrd,nc)=fz0(i,ng)
274 ELSE
275 IF (fz0(i,ng).gt.0.0_r8) THEN
276 zfloat=fz0(i,ng)+real(j-1,r8)*fdz(i,ng)
277 drifter(ng)%Tinfo(izgrd,nc)=min(max(0.0_r8, &
278 & zfloat), &
279 & real(n(ng),r8))
280 ELSE
281 drifter(ng)%Tinfo(izgrd,nc)=fz0(i,ng)+ &
282 & real(j-1,r8)*fdz(i,ng)
283 END IF
284 END IF
285 drifter(ng)%Ftype(nc)=ftype(i,ng)
286 IF (fcoor(i,ng).eq.0) THEN
287 xfloat=fx0(i,ng)+real(j-1,r8)*fdx(i,ng)
288 yfloat=fy0(i,ng)+real(j-1,r8)*fdy(i,ng)
289 drifter(ng)%Tinfo(ixgrd,nc)=xfloat
290 drifter(ng)%Tinfo(iygrd,nc)=yfloat
291 ELSE
292 mc=mc+1
293 drifter(ng)%Flon(mc)=fx0(i,ng)+ &
294 & real(j-1,r8)*fdx(i,ng)
295 drifter(ng)%Flat(mc)=fy0(i,ng)+ &
296 & real(j-1,r8)*fdy(i,ng)
297 drifter(ng)%Findex(mc)=nc
298 END IF
299 END IF
300 END DO
301 END IF
302 END DO
303 drifter(ng)%Findex(0)=mc
304 END IF
305 END DO
306!
307! Deallocate local arrays.
308!
309 IF (allocated(fcoor)) deallocate ( fcoor )
310 IF (allocated(fcount)) deallocate ( fcount )
311 IF (allocated(ftype)) deallocate ( ftype )
312 IF (allocated(ft0)) deallocate ( ft0 )
313 IF (allocated(fx0)) deallocate ( fx0 )
314 IF (allocated(fy0)) deallocate ( fy0 )
315 IF (allocated(fz0)) deallocate ( fz0 )
316 IF (allocated(fdt)) deallocate ( fdt )
317 IF (allocated(fdx)) deallocate ( fdx )
318 IF (allocated(fdy)) deallocate ( fdy )
319 IF (allocated(fdz)) deallocate ( fdz )
320!
321 60 FORMAT (/,' READ_FltPar - Error while reading floats', &
322 & ' locations in input script: ',a)
323 70 FORMAT (/,' READ_FltPar - Error while processing line: ',/,a)
324 80 FORMAT (/,' READ_FltPar - Inconsistent number of floats to', &
325 & ' process: ', 2i6,/,18x,'change input script.')
326 90 FORMAT (/,/,' Floats Initial Locations, Grid: ',i2.2, &
327 & /, ' ==================================',/,/, &
328 & 15x,'Ft0',5x,'Fx0',5x,'Fy0',5x,'Fz0', &
329 & 6x,'Fdt',6x,'Fdx',6x,'Fdy',6x,'Fdz',/)
330 100 FORMAT (/,1x,i10,2x,a,t30,a)
331 110 FORMAT (/,' READ_FltPar - Grid ', i2.2, &
332 & ', could not find input file: ', a)
333 120 FORMAT (/,2x,a,a)
334
335 RETURN
336 END SUBROUTINE read_fltpar
337#else
338 SUBROUTINE read_fltpar
339 END SUBROUTINE read_fltpar
340#endif
inp_decode_mod
Definition inp_decode.F:2
mod_floats
Definition mod_floats.F:2
mod_floats::allocate_floats
subroutine, public allocate_floats(ldrifter)
Definition mod_floats.F:143
mod_iounits
Definition mod_iounits.F:2
mod_iounits::err
type(t_io), dimension(:), allocatable err
Definition mod_iounits.F:207
mod_ncparam
Definition mod_ncparam.F:2
mod_parallel
Definition mod_parallel.F:2
mod_param
Definition mod_param.F:2
mod_scalars
Definition mod_scalars.F:2
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
read_fltpar
subroutine read_fltpar(model, inp, out, lwrite)
Definition read_fltpar.F:4