125
126
128
129
130
131 integer, intent(in) :: ng, tile, kout, nout
132# ifdef ADJUST_BOUNDARY
133 integer, intent(in) :: LBij, UBij
134# endif
135 integer, intent(in) :: LBi, UBi, LBj, UBj
136
137
138
139 integer :: Fcount, i, j, gfactor, gtype, status
140# ifdef SOLVE3D
141 integer :: itrc, k
142# endif
143
144 real(dp) :: scale
145
146 character (len=*), parameter :: MyFile = &
147 & __FILE__//", wrt_hessian_nf90"
148
149 sourcefile=myfile
150
151
152
153
154
155 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
156
157
158
159
160# if defined WRITE_WATER && defined MASKING
161 gfactor=-1
162# else
163 gfactor=1
164# endif
165
166
167
168 hss(ng)%Rindex=hss(ng)%Rindex+1
169 fcount=hss(ng)%Fcount
170 hss(ng)%Nrec(fcount)=hss(ng)%Nrec(fcount)+1
171
172
173
174# ifdef SOLVE3D
175# ifdef NESTING
176 IF (master) WRITE (stdout,10) kout, nout, hss(ng)%Rindex, ng
177# else
178 IF (master) WRITE (stdout,10) kout, nout, hss(ng)%Rindex
179# endif
180# else
181# ifdef NESTING
182 IF (master) WRITE (stdout,10) kout, hss(ng)%Rindex, ng
183# else
184 IF (master) WRITE (stdout,10) kout, hss(ng)%Rindex
185# endif
186# endif
187
188
189
191 & trim(vname(1,idtime)), time(ng:), &
192 & (/hss(ng)%Rindex/), (/1/), &
193 & ncid = hss(ng)%ncid, &
194 & varid = hss(ng)%Vid(idtime))
195 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
196
197
198
199 scale=1.0_dp
200 gtype=gfactor*r2dvar
201 status=nf_fwrite2d(ng, iadm, hss(ng)%ncid, idfsur, &
202 & hss(ng)%Vid(idfsur), &
203 & hss(ng)%Rindex, gtype, &
204 & lbi, ubi, lbj, ubj, scale, &
205# ifdef MASKING
206 & grid(ng) % rmask, &
207# endif
208 & ocean(ng)% ad_zeta(:,:,kout))
209 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
210 IF (master) THEN
211 WRITE (stdout,20) trim(vname(1,idfsur)), hss(ng)%Rindex
212 END IF
213 exit_flag=3
214 ioerror=status
215 RETURN
216 END IF
217
218# ifdef ADJUST_BOUNDARY
219
220
221
222 IF (any(lobc(:,isfsur,ng))) THEN
223 scale=1.0_dp
224 status=nf_fwrite2d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
225 & vname(1,idsbry(isfsur)), &
226 & hss(ng)%Vid(idsbry(isfsur)), &
227 & hss(ng)%Rindex, r2dvar, &
228 & lbij, ubij, nbrec(ng), scale, &
229 & boundary(ng) % ad_zeta_obc(lbij:,:,:, &
230 & kout))
231 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
232 IF (master) THEN
233 WRITE (stdout,20) trim(vname(1,idsbry(isfsur))), &
234 & hss(ng)%Rindex
235 END IF
236 exit_flag=3
237 ioerror=status
238 RETURN
239 END IF
240 END IF
241# endif
242
243
244
245 scale=1.0_dp
246 gtype=gfactor*u2dvar
247 status=nf_fwrite2d(ng, iadm, hss(ng)%ncid, idubar, &
248 & hss(ng)%Vid(idubar), &
249 & hss(ng)%Rindex, gtype, &
250 & lbi, ubi, lbj, ubj, scale, &
251# ifdef MASKING
252 & grid(ng) % umask_full, &
253# endif
254 & ocean(ng) % ad_ubar(:,:,kout))
255 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
256 IF (master) THEN
257 WRITE (stdout,20) trim(vname(1,idubar)), hss(ng)%Rindex
258 END IF
259 exit_flag=3
260 ioerror=status
261 RETURN
262 END IF
263
264# ifdef ADJUST_BOUNDARY
265
266
267
268 IF (any(lobc(:,isubar,ng))) THEN
269 scale=1.0_dp
270 status=nf_fwrite2d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
271 & vname(1,idsbry(isubar)), &
272 & hss(ng)%Vid(idsbry(isubar)), &
273 & hss(ng)%Rindex, u2dvar, &
274 & lbij, ubij, nbrec(ng), scale, &
275 & boundary(ng) % ad_ubar_obc(lbij:,:,:, &
276 & kout))
277 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
278 IF (master) THEN
279 WRITE (stdout,20) trim(vname(1,idsbry(isubar))), &
280 & hss(ng)%Rindex
281 END IF
282 exit_flag=3
283 ioerror=status
284 RETURN
285 END IF
286 END IF
287# endif
288
289
290
291 scale=1.0_dp
292 gtype=gfactor*v2dvar
293 status=nf_fwrite2d(ng, iadm, hss(ng)%ncid, idvbar, &
294 & hss(ng)%Vid(idvbar), &
295 & hss(ng)%Rindex, gtype, &
296 & lbi, ubi, lbj, ubj, scale, &
297# ifdef MASKING
298 & grid(ng) % vmask_full, &
299# endif
300 & ocean(ng) % ad_vbar(:,:,kout))
301 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
302 IF (master) THEN
303 WRITE (stdout,20) trim(vname(1,idvbar)), hss(ng)%Rindex
304 END IF
305 exit_flag=3
306 ioerror=status
307 RETURN
308 END IF
309
310# ifdef ADJUST_BOUNDARY
311
312
313
314 IF (any(lobc(:,isvbar,ng))) THEN
315 scale=1.0_dp
316 status=nf_fwrite2d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
317 & vname(1,idsbry(isvbar)), &
318 & hss(ng)%Vid(idsbry(isvbar)), &
319 & hss(ng)%Rindex, v2dvar, &
320 & lbij, ubij, nbrec(ng), scale, &
321 & boundary(ng) % ad_vbar_obc(lbij:,:,:, &
322 & kout))
323 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
324 IF (master) THEN
325 WRITE (stdout,20) trim(vname(1,idsbry(isvbar))), &
326 & hss(ng)%Rindex
327 END IF
328 exit_flag=3
329 ioerror=status
330 RETURN
331 END IF
332 END IF
333# endif
334
335# ifdef SOLVE3D
336
337
338
339 scale=1.0_dp
340 gtype=gfactor*u3dvar
341 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, iduvel, &
342 & hss(ng)%Vid(iduvel), &
343 & hss(ng)%Rindex, gtype, &
344 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
345# ifdef MASKING
346 & grid(ng) % umask_full, &
347# endif
348 & ocean(ng) % ad_u(:,:,:,nout))
349 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
350 IF (master) THEN
351 WRITE (stdout,20) trim(vname(1,iduvel)), hss(ng)%Rindex
352 END IF
353 exit_flag=3
354 ioerror=status
355 RETURN
356 END IF
357
358# ifdef ADJUST_BOUNDARY
359
360
361
362 IF (any(lobc(:,isuvel,ng))) THEN
363 scale=1.0_dp
364 status=nf_fwrite3d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
365 & vname(1,idsbry(isuvel)), &
366 & hss(ng)%Vid(idsbry(isuvel)), &
367 & hss(ng)%Rindex, u3dvar, &
368 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
369 & boundary(ng) % ad_u_obc(lbij:,:,:,:, &
370 & nout))
371 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
372 IF (master) THEN
373 WRITE (stdout,20) trim(vname(1,idsbry(isuvel))), &
374 & hss(ng)%Rindex
375 END IF
376 exit_flag=3
377 ioerror=status
378 RETURN
379 END IF
380 END IF
381# endif
382
383
384
385 scale=1.0_dp
386 gtype=gfactor*v3dvar
387 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, idvvel, &
388 & hss(ng)%Vid(idvvel), &
389 & hss(ng)%Rindex, gtype, &
390 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
391# ifdef MASKING
392 & grid(ng) % vmask_full, &
393# endif
394 & ocean(ng) % ad_v(:,:,:,nout))
395 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
396 IF (master) THEN
397 WRITE (stdout,20) trim(vname(1,idvvel)), hss(ng)%Rindex
398 END IF
399 exit_flag=3
400 ioerror=status
401 RETURN
402 END IF
403
404# ifdef ADJUST_BOUNDARY
405
406
407
408 IF (any(lobc(:,isvvel,ng))) THEN
409 scale=1.0_dp
410 status=nf_fwrite3d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
411 & vname(1,idsbry(isvvel)), &
412 & hss(ng)%Vid(idsbry(isvvel)), &
413 & hss(ng)%Rindex, v3dvar, &
414 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
415 & boundary(ng) % ad_v_obc(lbij:,:,:,:, &
416 & nout))
417 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
418 IF (master) THEN
419 WRITE (stdout,20) trim(vname(1,idsbry(isvvel))), &
420 & hss(ng)%Rindex
421 END IF
422 exit_flag=3
423 ioerror=status
424 RETURN
425 END IF
426 END IF
427# endif
428
429
430
431 DO itrc=1,nt(ng)
432 scale=1.0_dp
433 gtype=gfactor*r3dvar
434 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, idtvar(itrc), &
435 & hss(ng)%Tid(itrc), &
436 & hss(ng)%Rindex, gtype, &
437 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
438# ifdef MASKING
439 & grid(ng) % rmask, &
440# endif
441 & ocean(ng) % ad_t(:,:,:,nout,itrc))
442 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
443 IF (master) THEN
444 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), &
445 & hss(ng)%Rindex
446 END IF
447 exit_flag=3
448 ioerror=status
449 RETURN
450 END IF
451 END DO
452
453# ifdef ADJUST_BOUNDARY
454
455
456
457 DO itrc=1,nt(ng)
458 IF (any(lobc(:,istvar(itrc),ng))) THEN
459 scale=1.0_dp
460 status=nf_fwrite3d_bry(ng, iadm, hss(ng)%name, hss(ng)%ncid, &
461 & vname(1,idsbry(istvar(itrc))), &
462 & hss(ng)%Vid(idsbry(istvar(itrc))), &
463 & hss(ng)%Rindex, r3dvar, &
464 & lbij, ubij, 1, n(ng), nbrec(ng), &
465 & scale, &
466 & boundary(ng) % ad_t_obc(lbij:,:,:,:, &
467 & nout,itrc))
468 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
469 IF (master) THEN
470 WRITE (stdout,20) trim(vname(1,idsbry(istvar(itrc)))), &
471 & hss(ng)%Rindex
472 END IF
473 exit_flag=3
474 ioerror=status
475 RETURN
476 END IF
477 END IF
478 END DO
479# endif
480
481# ifdef ADJUST_STFLUX
482
483
484
485
486
487 DO itrc=1,nt(ng)
488 IF (lstflux(itrc,ng)) THEN
489 scale=1.0_dp
490 gtype=gfactor*r3dvar
491 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, idtsur(itrc), &
492 & hss(ng)%Vid(idtsur(itrc)), &
493 & hss(ng)%Rindex, gtype, &
494 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
495# ifdef MASKING
496 & grid(ng) % rmask, &
497# endif
498 & forces(ng) % ad_tflux(:,:,:,kout,itrc))
499 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
500 IF (master) THEN
501 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
502 & hss(ng)%Rindex
503 END IF
504 exit_flag=3
505 ioerror=status
506 RETURN
507 END IF
508 END IF
509 END DO
510# endif
511# endif
512# ifdef ADJUST_WSTRESS
513
514
515
516
517
518 scale=1.0_dp
519 gtype=gfactor*u3dvar
520 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, idusms, &
521 & hss(ng)%Vid(idusms), &
522 & hss(ng)%Rindex, gtype, &
523 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
524# ifdef MASKING
525 & grid(ng) % umask, &
526# endif
527 & forces(ng) % ad_ustr(:,:,:,kout))
528 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
529 IF (master) THEN
530 WRITE (stdout,20) trim(vname(1,idusms)), hss(ng)%Rindex
531 END IF
532 exit_flag=3
533 ioerror=status
534 RETURN
535 END IF
536
537
538
539 scale=1.0_dp
540 gtype=gfactor*v3dvar
541 status=nf_fwrite3d(ng, iadm, hss(ng)%ncid, idvsms, &
542 & hss(ng)%Vid(idvsms), &
543 & hss(ng)%Rindex, gtype, &
544 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
545# ifdef MASKING
546 & grid(ng) % vmask, &
547# endif
548 & forces(ng) % ad_vstr(:,:,:,kout))
549 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
550 IF (master) THEN
551 WRITE (stdout,20) trim(vname(1,idvsms)), hss(ng)%Rindex
552 END IF
553 exit_flag=3
554 ioerror=status
555 RETURN
556 END IF
557# endif
558
559
560
561
562
563
564 CALL netcdf_sync (ng, iadm, hss(ng)%name, hss(ng)%ncid)
565 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
566
567 10 FORMAT (2x,'WRT_HESSIAN_NF90 - writing Hessian', t42, &
568# ifdef SOLVE3D
569# ifdef NESTING
570 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
571# else
572 & 'fields (Index=',i1,',',i1,') in record = ',i0)
573# endif
574# else
575# ifdef NESTING
576 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
577# else
578 & 'fields (Index=',i1,') in record = ',i0)
579# endif
580# endif
581 20 FORMAT (/,' WRT_HESSIAN_NF90 - error while writing variable: ',a, &
582 & /,20x,'into Hessian NetCDF file for time record: ',i0)
583
584 RETURN
subroutine, public netcdf_sync(ng, model, ncname, ncid)