93
94
96
97
98
99 integer, intent(in) :: ng, tile
100 integer, intent(in) :: LBi, UBi, LBj, UBj
101
102
103
104 integer :: i, j, k, itrc
105 integer :: Fcount, gfactor, gtype, status, varid
106
107 real(dp) :: scale
108
109 character (len=*), parameter :: MyFile = &
110 & __FILE__//", wrt_dai_nf90"
111
112# include "set_bounds.h"
113
114 sourcefile=myfile
115
116
117
118
119
120 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
121
122
123
124 gfactor=1
125
126
127
128 dai(ng)%Rindex=dai(ng)%Rindex+1
129 fcount=dai(ng)%Fcount
130 dai(ng)%Nrec(fcount)=dai(ng)%Nrec(fcount)+1
131
132
133
134
135 dai(ng)%Rindex=mod(dai(ng)%Rindex-1,2)+1
136
137
138
139# ifdef SOLVE3D
140# ifdef NESTING
141 IF (master) WRITE (stdout,10) kout, nout, dai(ng)%Rindex, ng
142# else
143 IF (master) WRITE (stdout,10) kout, nout, dai(ng)%Rindex
144# endif
145# else
146# ifdef NESTING
147 IF (master) WRITE (stdout,10) kout, dai(ng)%Rindex, ng
148# else
149 IF (master) WRITE (stdout,10) kout, dai(ng)%Rindex
150# endif
151# endif
152
153# ifdef SOLVE3D
154
155
156
157 scale=1.0_dp
158 gtype=gfactor*r3dvar
159 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idpthr, &
160 & dai(ng)%Vid(idpthr), &
161 & 0, gtype, &
162 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
163# ifdef MASKING
164 & grid(ng) % rmask, &
165# endif
166 & grid(ng) % z0_r, &
167 & setfillval = .false.)
168 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
169 IF (master) THEN
170 WRITE (stdout,20) trim(vname(1,idpthr))
171 END IF
172 exit_flag=3
173 ioerror=status
174 RETURN
175 END IF
176
177
178
179 scale=1.0_dp
180 gtype=gfactor*u3dvar
181 DO k=1,n(ng)
182 DO j=jstr-1,jend+1
183 DO i=istru-1,iend+1
184 grid(ng)%z_v(i,j,k)=0.5_r8*(grid(ng)%z0_r(i-1,j,k)+ &
185 & grid(ng)%z0_r(i ,j,k))
186 END DO
187 END DO
188 END DO
189 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idpthu, &
190 & dai(ng)%Vid(idpthu), &
191 & 0, gtype, &
192 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
193# ifdef MASKING
194 & grid(ng) % umask, &
195# endif
196 & grid(ng) % z_v, &
197 & setfillval = .false.)
198 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
199 IF (master) THEN
200 WRITE (stdout,20) trim(vname(1,idpthu))
201 END IF
202 exit_flag=3
203 ioerror=status
204 RETURN
205 END IF
206
207
208
209 scale=1.0_dp
210 gtype=gfactor*v3dvar
211 DO k=1,n(ng)
212 DO j=jstrv-1,jend+1
213 DO i=istr-1,iend+1
214 grid(ng)%z_v(i,j,k)=0.5_r8*(grid(ng)%z0_r(i,j-1,k)+ &
215 & grid(ng)%z0_r(i,j ,k))
216 END DO
217 END DO
218 END DO
219 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idpthv, &
220 & dai(ng)%Vid(idpthv), &
221 & 0, gtype, &
222 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
223# ifdef MASKING
224 & grid(ng) % vmask, &
225# endif
226 & grid(ng) % z_v, &
227 & setfillval = .false.)
228 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
229 IF (master) THEN
230 WRITE (stdout,20) trim(vname(1,idpthv))
231 END IF
232 exit_flag=3
233 ioerror=status
234 RETURN
235 END IF
236
237
238
239 scale=1.0_dp
240 gtype=gfactor*w3dvar
241 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idpthw, &
242 & dai(ng)%Vid(idpthw), &
243 & 0, gtype, &
244 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
245# ifdef MASKING
246 & grid(ng) % rmask, &
247# endif
248 & grid(ng) % z0_w, &
249 & setfillval = .false.)
250 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
251 IF (master) THEN
252 WRITE (stdout,20) trim(vname(1,idpthw))
253 END IF
254 exit_flag=3
255 ioerror=status
256 RETURN
257 END IF
258# endif
259
260
261
263 & trim(vname(1,idtime)), time(ng:), &
264 & (/dai(ng)%Rindex/), (/1/), &
265 & ncid = dai(ng)%ncid, &
266 & varid = dai(ng)%Vid(idtime))
267 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
268
269
270
271 scale=1.0_dp
272 gtype=gfactor*r2dvar
273 status=nf_fwrite2d(ng, inlm, dai(ng)%ncid, idfsur, &
274 & dai(ng)%Vid(idfsur), &
275 & dai(ng)%Rindex, gtype, &
276 & lbi, ubi, lbj, ubj, scale, &
277# ifdef MASKING
278 & grid(ng) % rmask, &
279# endif
280# if defined R4DVAR || defined SPLIT_R4DVAR
281# ifdef WET_DRY
282 & ocean(ng) % tl_zeta(:,:,kout), &
283 & setfillval = .false.)
284# else
285 & ocean(ng) % tl_zeta(:,:,kout))
286# endif
287# else
288# ifdef WET_DRY
289 & ocean(ng) % zeta(:,:,kout), &
290 & setfillval = .false.)
291# else
292 & ocean(ng) % zeta(:,:,kout))
293# endif
294# endif
295 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
296 IF (master) THEN
297 WRITE (stdout,30) trim(vname(1,idfsur)), dai(ng)%Rindex
298 END IF
299 exit_flag=3
300 ioerror=status
301 RETURN
302 END IF
303
304
305
306 scale=1.0_dp
307 gtype=gfactor*u2dvar
308 status=nf_fwrite2d(ng, inlm, dai(ng)%ncid, idubar, &
309 & dai(ng)%Vid(idubar), &
310 & dai(ng)%Rindex, gtype, &
311 & lbi, ubi, lbj, ubj, scale, &
312# ifdef MASKING
313 & grid(ng) % umask_full, &
314# endif
315# if defined R4DVAR || defined SPLIT_R4DVAR
316 & ocean(ng) % tl_ubar(:,:,kout))
317# else
318 & ocean(ng) % ubar(:,:,kout))
319# endif
320 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
321 IF (master) THEN
322 WRITE (stdout,30) trim(vname(1,idubar)), dai(ng)%Rindex
323 END IF
324 exit_flag=3
325 ioerror=status
326 RETURN
327 END IF
328
329
330
331 scale=1.0_dp
332 gtype=gfactor*v2dvar
333 status=nf_fwrite2d(ng, inlm, dai(ng)%ncid, idvbar, &
334 & dai(ng)%Vid(idvbar), &
335 & dai(ng)%Rindex, gtype, &
336 & lbi, ubi, lbj, ubj, scale, &
337# ifdef MASKING
338 & grid(ng) % vmask_full, &
339# endif
340# if defined R4DVAR || defined SPLIT_R4DVAR
341 & ocean(ng) % tl_vbar(:,:,kout))
342# else
343 & ocean(ng) % vbar(:,:,kout))
344# endif
345 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
346 IF (master) THEN
347 WRITE (stdout,30) trim(vname(1,idvbar)), dai(ng)%Rindex
348 END IF
349 exit_flag=3
350 ioerror=status
351 RETURN
352 END IF
353
354# ifdef SOLVE3D
355
356
357
358 scale=1.0_dp
359 gtype=gfactor*u3dvar
360 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, iduvel, &
361 & dai(ng)%Vid(iduvel), &
362 & dai(ng)%Rindex, gtype, &
363 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
364# ifdef MASKING
365 & grid(ng) % umask_full, &
366# endif
367# if defined R4DVAR || defined SPLIT_R4DVAR
368 & ocean(ng) % tl_u(:,:,:,nout))
369# else
370 & ocean(ng) % u(:,:,:,nout))
371# endif
372 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
373 IF (master) THEN
374 WRITE (stdout,30) trim(vname(1,iduvel)), dai(ng)%Rindex
375 END IF
376 exit_flag=3
377 ioerror=status
378 RETURN
379 END IF
380
381
382
383 scale=1.0_dp
384 gtype=gfactor*v3dvar
385 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idvvel, &
386 & dai(ng)%Vid(idvvel), &
387 & dai(ng)%Rindex, gtype, &
388 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
389# ifdef MASKING
390 & grid(ng) % vmask_full, &
391# endif
392# if defined R4DVAR || defined SPLIT_R4DVAR
393 & ocean(ng) % tl_v(:,:,:,nout))
394# else
395 & ocean(ng) % v(:,:,:,nout))
396# endif
397 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
398 IF (master) THEN
399 WRITE (stdout,30) trim(vname(1,idvvel)), dai(ng)%Rindex
400 END IF
401 exit_flag=3
402 ioerror=status
403 RETURN
404 END IF
405
406
407
408 DO itrc=1,nt(ng)
409 scale=1.0_dp
410 gtype=gfactor*r3dvar
411 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idtvar(itrc), &
412 & dai(ng)%Tid(itrc), &
413 & dai(ng)%Rindex, gtype, &
414 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
415# ifdef MASKING
416 & grid(ng) % rmask, &
417# endif
418# if defined R4DVAR || defined SPLIT_R4DVAR
419 & ocean(ng) % tl_t(:,:,:,nout,itrc))
420# else
421 & ocean(ng) % t(:,:,:,nout,itrc))
422# endif
423 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
424 IF (master) THEN
425 WRITE (stdout,30) trim(vname(1,idtvar(itrc))), dai(ng)%Rindex
426 END IF
427 exit_flag=3
428 ioerror=status
429 RETURN
430 END IF
431 END DO
432
433
434
435 scale=1.0_dp
436 gtype=gfactor*w3dvar
437 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idvvis, &
438 & dai(ng)%Vid(idvvis), &
439 & dai(ng)%Rindex, gtype, &
440 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
441# ifdef MASKING
442 & grid(ng) % rmask, &
443# endif
444 & mixing(ng) % Akv, &
445 & setfillval = .false.)
446 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
447 IF (master) THEN
448 WRITE (stdout,30) trim(vname(1,idvvis)), dai(ng)%Rindex
449 END IF
450 exit_flag=3
451 ioerror=status
452 RETURN
453 END IF
454
455
456
457 scale=1.0_dp
458 gtype=gfactor*w3dvar
459 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idtdif, &
460 & dai(ng)%Vid(idtdif), &
461 & dai(ng)%Rindex, gtype, &
462 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
463# ifdef MASKING
464 & grid(ng) % rmask, &
465# endif
466 & mixing(ng) % Akt(:,:,:,itemp), &
467 & setfillval = .false.)
468 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
469 IF (master) THEN
470 WRITE (stdout,30) trim(vname(1,idtdif)), dai(ng)%Rindex
471 END IF
472 exit_flag=3
473 ioerror=status
474 RETURN
475 END IF
476
477# ifdef SALINITY
478
479
480
481 scale=1.0_dp
482 gtype=gfactor*w3dvar
483 status=nf_fwrite3d(ng, inlm, dai(ng)%ncid, idsdif, &
484 & dai(ng)%Vid(idsdif), &
485 & dai(ng)%Rindex, gtype, &
486 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
487# ifdef MASKING
488 & grid(ng) % rmask, &
489# endif
490 & mixing(ng) % Akt(:,:,:,isalt), &
491 & setfillval = .false.)
492 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
493 IF (master) THEN
494 WRITE (stdout,30) trim(vname(1,idsdif)), dai(ng)%Rindex
495 END IF
496 exit_flag=3
497 ioerror=status
498 RETURN
499 END IF
500# endif
501# endif
502
503
504
505
506
507 CALL netcdf_sync (ng, inlm, dai(ng)%name, dai(ng)%ncid)
508 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
509
510 10 FORMAT (2x,'WRT_DAI_NF90 - writing DA INI/RST', t42, &
511# ifdef SOLVE3D
512# ifdef NESTING
513 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
514# else
515 & 'fields (Index=',i1,',',i1,') in record = ',i0)
516# endif
517# else
518# ifdef NESTING
519 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
520# else
521 & 'fields (Index=',i1,') in record = ',i0)
522# endif
523# endif
524 20 FORMAT (/,' WRT_DAI_NF90 - error while writing variable: ',a, &
525 & /,11x,'into DA initial/restart NetCDF file.')
526 30 FORMAT (/,' WRT_DAI_NF90 - error while writing variable: ',a, &
527 & /,11x,'into DA initial/rstart NetCDF file for time ', &
528 & 'record: ',i0)
529
530 RETURN
subroutine, public netcdf_sync(ng, model, ncname, ncid)