ROMS
Loading...
Searching...
No Matches
read_couplepar.F
Go to the documentation of this file.
1#include "cppdefs.h"
2#if defined MODEL_COUPLING && defined MCT_LIB
3 SUBROUTINE read_couplepar (model)
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 multiple model coupling input !
13! parameters. !
14! !
15!=======================================================================
16!
17 USE mod_param
18 USE mod_parallel
19 USE mod_coupler
20 USE mod_iounits
21 USE mod_scalars
22!
23 USE inp_decode_mod
24# ifdef DISTRIBUTE
25!
26 USE distribute_mod, ONLY : mp_bcasts
27# endif
28!
29 implicit none
30!
31! Imported variable declarations.
32!
33 integer, intent(in) :: model
34!
35! Local variable declarations.
36!
37 logical :: Lwrite
38 logical :: Lvalue(1)
39!
40 integer :: Npts, Nval, i, ic, io_err, j, inp, ng, out, status
41 integer :: Ivalue(1)
42!
43 real(r8), dimension(nRval) :: Rval
44
45 real(r8), allocatable :: MyRval(:)
46!
47 character (len=40 ) :: KeyWord
48 character (len=256) :: io_errmsg, line
49 character (len=256) :: Cname
50 character (len=256), dimension(nCval) :: Cval
51!
52!-----------------------------------------------------------------------
53! Determine coupling standard input file name. In distributed-memory,
54! this name is assigned at the executtion command line and processed
55! with the Unix routine GETARG. The ROMS input parameter script
56! name is specified in this coupling script.
57!-----------------------------------------------------------------------
58!
59# ifdef DISTRIBUTE
60 lwrite=master
61 inp=1
62 out=stdout
63!
64 IF (myrank.eq.0) CALL my_getarg (1,cname)
65 CALL mp_bcasts (1, model, cname)
66 IF (myrank.eq.0) THEN
67 WRITE(stdout,*) 'Coupled Input File name = ', trim(cname)
68 END IF
69 OPEN (inp, file=trim(cname), form='formatted', status='old', &
70 & iostat=io_err, iomsg=io_errmsg)
71 IF (io_err.ne.0) THEN
72 IF (myrank.eq.0) WRITE (stdout,10) trim(io_errmsg)
73 exit_flag=5
74 RETURN
75 10 FORMAT (/,' READ_COUPLEPAR - Unable to open coupling input', &
76 & ' script.',/18x,'ERROR: ',a,/, &
77 & /,18x,'In distributed-memory applications, the input', &
78 & /,18x,'script file is processed in parallel. The Unix', &
79 & /,18x,'routine GETARG is used to get script file name.',&
80 & /,18x,'For example, in MPI applications make sure that',&
81 & /,18x,'command line is something like:',/, &
82 & /,18x,'mpirun -np 4 romsM coupling.in',/, &
83 & /,18x,'and not',/, &
84 & /,18x,'mpirun -np 4 romsM < coupling.in',/)
85 END IF
86# else
87 lwrite=master
88 inp=stdinp
89 out=stdout
90# endif
91!
92!-----------------------------------------------------------------------
93! Read in multiple models coupling parameters. Then, load input
94! data into module. Take into account nested grid configurations.
95!-----------------------------------------------------------------------
96!
97 DO WHILE (.true.)
98 READ (inp,'(a)',err=20,END=30) line
99 status=decode_line(line, keyword, nval, cval, rval)
100 IF (status.gt.0) THEN
101 SELECT CASE (trim(keyword))
102 CASE ('Nmodels')
103 npts=load_i(nval, rval, 1, ivalue)
104 nmodels=ivalue(1)
105 IF (.not.allocated(myrval) ) THEN
106 allocate ( myrval(nmodels) )
107 END IF
108 IF (.not.allocated(orderlabel) ) THEN
109 allocate ( orderlabel(nmodels) )
110 END IF
111 IF (.not.allocated(nthreads) ) THEN
112 allocate ( nthreads(nmodels) )
113 nthreads=0
114 END IF
115 IF (.not.allocated(timeinterval) ) THEN
116 allocate ( timeinterval(nmodels,nmodels) )
117 timeinterval=0.0_r8
118 END IF
119 IF (.not.allocated(inpname) ) THEN
120 allocate ( inpname(nmodels) )
121 END IF
122 IF (.not.allocated(nexport) ) THEN
123 allocate ( nexport(nmodels) )
124 nexport=0
125 END IF
126 IF (.not.allocated(nimport) ) THEN
127 allocate ( nimport(nmodels) )
128 nimport=0
129 END IF
130 CASE ('Lreport')
131 npts=load_l(nval, cval, 1, lvalue)
132 lreport=lvalue(1)
133 CASE ('OrderLabel')
134 DO i=1,nmodels
135 IF (i.eq.nval) THEN
136 orderlabel(i)=trim(adjustl(cval(nval)))
137 IF (index(trim(orderlabel(i)),'ocean').ne.0) THEN
138 iocean=i
139 ELSE IF (index(trim(orderlabel(i)),'waves').ne.0) THEN
140 iwaves=i
141 ELSE IF (index(trim(orderlabel(i)),'atmos').ne.0) THEN
142 iatmos=i
143 END IF
144 END IF
145 END DO
146 CASE ('Nthreads(ocean)')
147 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
148 npts=load_i(nval, rval, 1, ivalue)
149 nthreads(iocean)=ivalue(1)
150 END IF
151 CASE ('Nthreads(waves)')
152 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
153 npts=load_i(nval, rval, 1, ivalue)
154 nthreads(iwaves)=ivalue(1)
155 END IF
156 CASE ('Nthreads(atmos)')
157 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
158 npts=load_i(nval, rval, 1, ivalue)
159 nthreads(iatmos)=ivalue(1)
160 END IF
161 CASE ('TimeInterval')
162 npts=load_r(nval, rval, nmodels, myrval)
163 ic=0
164 DO j=1,nmodels
165 DO i=1,nmodels
166 IF (i.gt.j) THEN
167 ic=ic+1
168 timeinterval(i,j)=myrval(ic)
169 timeinterval(j,i)=myrval(ic)
170 END IF
171 END DO
172 END DO
173 CASE ('INPname(ocean)')
174 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
175 inpname(iocean)=trim(adjustl(cval(nval)))
176 iname=trim(inpname(iocean))
177 END IF
178 CASE ('INPname(waves)')
179 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
180 inpname(iwaves)=trim(adjustl(cval(nval)))
181 END IF
182 CASE ('INPname(atmos)')
183 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
184 inpname(iatmos)=trim(adjustl(cval(nval)))
185 END IF
186 CASE ('CPLname')
187 cplname=trim(adjustl(cval(nval)))
188 CASE ('Nexport(ocean)')
189 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
190 npts=load_i(nval, rval, 1, ivalue)
191 nexport(iocean)=ivalue(1)
192 END IF
193 CASE ('Nexport(waves)')
194 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
195 npts=load_i(nval, rval, 1, ivalue)
196 nexport(iwaves)=ivalue(1)
197 END IF
198 CASE ('Nexport(atmos)')
199 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
200 npts=load_i(nval, rval, 1, ivalue)
201 nexport(iatmos)=ivalue(1)
202 END IF
203 CASE ('Export(ocean)')
204 IF (.not.allocated(export)) THEN
205 allocate ( export(nmodels) )
206 DO i=1,nmodels
207 allocate ( export(i)%code(max(1,nexport(i))) )
208 export(i)%code=' '
209 END DO
210 END IF
211 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
212 IF (nval.le.nexport(iocean)) THEN
213 export(iocean)%code(nval)=trim(adjustl(cval(nval)))
214 END IF
215 END IF
216 CASE ('Export(waves)')
217 IF (.not.allocated(export)) THEN
218 allocate ( export(nmodels) )
219 DO i=1,nmodels
220 allocate ( export(i)%code(max(1,nexport(i))) )
221 export(i)%code=' '
222 END DO
223 END IF
224 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
225 IF (nval.le.nexport(iwaves)) THEN
226 export(iwaves)%code(nval)=trim(adjustl(cval(nval)))
227 END IF
228 END IF
229 CASE ('Export(atmos)')
230 IF (.not.allocated(export)) THEN
231 allocate ( export(nmodels) )
232 DO i=1,nmodels
233 allocate ( export(i)%code(max(1,nexport(i))) )
234 export(i)%code=' '
235 END DO
236 END IF
237 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
238 IF (nval.le.nexport(iatmos)) THEN
239 export(iatmos)%code(nval)=trim(adjustl(cval(nval)))
240 END IF
241 END IF
242 CASE ('Nimport(ocean)')
243 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
244 npts=load_i(nval, rval, 1, ivalue)
245 nimport(iocean)=ivalue(1)
246 END IF
247 CASE ('Nimport(waves)')
248 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
249 npts=load_i(nval, rval, 1, ivalue)
250 nimport(iwaves)=ivalue(1)
251 END IF
252 CASE ('Nimport(atmos)')
253 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
254 npts=load_i(nval, rval, 1, ivalue)
255 nimport(iatmos)=ivalue(1)
256 END IF
257 CASE ('Import(ocean)')
258 IF (.not.allocated(import)) THEN
259 allocate ( import(nmodels) )
260 DO i=1,nmodels
261 allocate ( import(i)%code(max(1,nimport(i))) )
262 import(i)%code=' '
263 END DO
264 END IF
265 IF ((0.lt.iocean).and.(iocean.le.nmodels)) THEN
266 IF (nval.le.nimport(iocean)) THEN
267 import(iocean)%code(nval)=trim(adjustl(cval(nval)))
268 END IF
269 END IF
270 CASE ('Import(waves)')
271 IF (.not.allocated(import)) THEN
272 allocate ( import(nmodels) )
273 DO i=1,nmodels
274 allocate ( import(i)%code(max(1,nimport(i))) )
275 import(i)%code=' '
276 END DO
277 END IF
278 IF ((0.lt.iwaves).and.(iwaves.le.nmodels)) THEN
279 IF (nval.le.nimport(iwaves)) THEN
280 import(iwaves)%code(nval)=trim(adjustl(cval(nval)))
281 END IF
282 END IF
283 CASE ('Import(atmos)')
284 IF (.not.allocated(import)) THEN
285 allocate ( import(nmodels) )
286 DO i=1,nmodels
287 allocate ( import(i)%code(max(1,nimport(i))) )
288 import(i)%code=' '
289 END DO
290 END IF
291 IF ((0.lt.iatmos).and.(iatmos.le.nmodels)) THEN
292 IF (nval.le.nimport(iatmos)) THEN
293 import(iatmos)%code(nval)=trim(adjustl(cval(nval)))
294 END IF
295 END IF
296 END SELECT
297 END IF
298 END DO
299 20 IF (master) WRITE (out,40) line
300 exit_flag=4
301 RETURN
302 30 CLOSE (inp)
303!
304 40 FORMAT (/,' READ_CouplePar - Error while processing line: ',/,a)
305!
306 RETURN
307 END SUBROUTINE read_couplepar
308#else
309 SUBROUTINE read_couplepar
310 END SUBROUTINE read_couplepar
311#endif
distribute_mod::mp_bcasts
Definition distribute.F:101
my_getarg
subroutine my_getarg(iarg, carg)
Definition mp_routines.F:28
distribute_mod
Definition distribute.F:3
inp_decode_mod
Definition inp_decode.F:2
mod_coupler
Definition mod_coupler.F:2
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdinp
integer stdinp
Definition mod_iounits.F:194
mod_iounits::err
type(t_io), dimension(:), allocatable err
Definition mod_iounits.F:207
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_parallel
Definition mod_parallel.F:2
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_parallel::myrank
integer myrank
Definition mod_parallel.F:157
mod_param
Definition mod_param.F:2
mod_scalars
Definition mod_scalars.F:2
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
read_couplepar
subroutine read_couplepar(model)
Definition read_couplepar.F:4