ROMS
Loading...
Searching...
No Matches
esmf_coupler.h
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE esmf_coupler_mod
3
4#if defined MODEL_COUPLING && defined ESMF_LIB && !defined CMEPS
5!
6!git $Id$
7!=======================================================================
8! Copyright (c) 2002-2025 The ROMS Group !
9! Licensed under a MIT/X style license Hernan G. Arango !
10! See License_ROMS.md Ufuk Utku Turuncoglu !
11!=======================================================================
12! !
13! This module includes the coupler routines for the computation, !
14! execution, and release of the connectors between source and !
15! destination fields. It uses ESMF/NUOPC regrid operators for !
16! interpolation with or without extrapolation support. !
17! !
18! Coupler_SetServices Sets coupler shared-object entry points !
19! using NUOPC generic methods for the !
20! computation, execution, and release of !
21! RouteHandle connectors. !
22! !
23! Coupler_ComputeRH Computes coupler RouteHandle connectors !
24! for interpolation between source and !
25! destination fields. !
26! !
27! Coupler_ExecuteRH Uses coupler RouteHandle connectors to !
28! perform the regridding interpolation !
29! between source and destination fields. !
30! !
31! Coupler_ReleaseRH Releases coupler RouteHandle connectors. !
32! !
33! Coupler_AdjustField Adjust regrid field to ensure global !
34! area integral conservation over the !
35! matched regions. !
36! !
37! Coupler_AreaIntegral Computes source or destination global !
38! area integral over the matched regions. !
39! !
40! Coupler_FieldCreate Creates and initializes and new field !
41! using specified input field attributes !
42! and mask. !
43! !
44! Coupler_FindUnmapped Modifies mask associated with regrid !
45! field to split masked and unmasked grid !
46! cells during regridding with extrapolation !
47! support. !
48! !
49! ESMF: Earth System Modeling Framework (Version 7 or higher) !
50! https://www.earthsystemcog.org/projects/esmf !
51! !
52! NUOPC: National Unified Operational Prediction Capability !
53! https://www.earthsystemcog.org/projects/nuopc !
54! !
55!=======================================================================
56!
57 USE esmf
58 USE nuopc
59 USE nuopc_connector, ONLY: &
60 & nuopc_setservices => setservices, &
61 & nuopc_label_computerh => label_computeroutehandle, &
62 & nuopc_label_executerh => label_executeroutehandle, &
63 & nuopc_label_releaserh => label_releaseroutehandle, &
64 & nuopc_connectorget, &
65 & nuopc_connectorset
66!
67 USE mod_esmf_esm ! ESM coupling structures and variables
68!
69 implicit none
70!
71 PUBLIC :: coupler_setservices
72
73 PRIVATE :: coupler_computerh
74 PRIVATE :: coupler_executerh
75 PRIVATE :: coupler_releaserh
76!
77 PRIVATE :: coupler_adjustfield
78 PRIVATE :: coupler_areaintegral
79 PRIVATE :: coupler_fieldcreate
80 PRIVATE :: coupler_findunmapped
81!
82 CONTAINS
83!
84 SUBROUTINE coupler_setservices (coupler, rc)
85!
86!=======================================================================
87! !
88! Sets the coupler shared-object entry points using NUOPC generic !
89! methods for the computation, execution, and release of RouteHandle !
90! connectors between source (srcFields) and destination (dstFields) !
91! fields. !
92! !
93!=======================================================================
94!
95! Imported variable declarations.
96!
97 integer, intent(out) :: rc
98!
99 character (len=*), parameter :: myfile = &
100 & __FILE__//", Coupler_SetServices"
101
102 character (ESMF_MAXSTR) :: cname
103!
104 TYPE (esmf_cplcomp) :: coupler
105!
106!-----------------------------------------------------------------------
107! Initialize return code flag to success state (no error).
108!-----------------------------------------------------------------------
109!
110 rc=esmf_success
111!
112!-----------------------------------------------------------------------
113! Querry coupler component.
114!-----------------------------------------------------------------------
115!
116 CALL esmf_cplcompget (coupler, &
117 & name=cname, &
118 & rc=rc)
119 IF (esmf_logfounderror(rctocheck=rc, &
120 & msg=esmf_logerr_passthru, &
121 & line=__line__, &
122 & file=myfile)) THEN
123 RETURN
124 END IF
125!
126 IF (esm_track) THEN
127 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_SetServices for ' &
128 & // trim(cname), ', PET', petrank
129 FLUSH (trac)
130 END IF
131!
132!-----------------------------------------------------------------------
133! Register generic methods.
134!-----------------------------------------------------------------------
135!
136 CALL nuopc_compderive (coupler, &
137 & nuopc_setservices, &
138 & rc=rc)
139 IF (esmf_logfounderror(rctocheck=rc, &
140 & msg=esmf_logerr_passthru, &
141 & line=__line__, &
142 & file=myfile)) THEN
143 RETURN
144 END IF
145!
146!-----------------------------------------------------------------------
147! Attach specializing methods.
148!-----------------------------------------------------------------------
149!
150! Set shared-object entry point for the communication RouteHandle used
151! in the data transfer between connectors.
152!
153 CALL nuopc_compspecialize (coupler, &
154 & speclabel=nuopc_label_computerh, &
155 & specroutine=coupler_computerh, &
156 & rc=rc)
157 IF (esmf_logfounderror(rctocheck=rc, &
158 & msg=esmf_logerr_passthru, &
159 & line=__line__, &
160 & file=myfile)) THEN
161 RETURN
162 END IF
163!
164! Set shared-object entry point to execute connector operations between
165! source (srcFields) and destination (dstFields) data.
166!
167 CALL nuopc_compspecialize (coupler, &
168 & speclabel=nuopc_label_executerh, &
169 & specroutine=coupler_executerh, &
170 & rc=rc)
171 IF (esmf_logfounderror(rctocheck=rc, &
172 & msg=esmf_logerr_passthru, &
173 & line=__line__, &
174 & file=myfile)) THEN
175 RETURN
176 END IF
177!
178! Set share-object entry point for the release of connector operations.
179!
180 CALL nuopc_compspecialize (coupler, &
181 & speclabel=nuopc_label_releaserh, &
182 & specroutine=coupler_releaserh, &
183 & rc=rc)
184 IF (esmf_logfounderror(rctocheck=rc, &
185 & msg=esmf_logerr_passthru, &
186 & line=__line__, &
187 & file=myfile)) THEN
188 RETURN
189 END IF
190!
191 IF (esm_track) THEN
192 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_SetServices for ' &
193 & // trim(cname), ', PET', petrank
194 FLUSH (trac)
195 END IF
196!
197 RETURN
198 END SUBROUTINE coupler_setservices
199!
200 SUBROUTINE coupler_computerh (coupler, rc)
201!
202!=======================================================================
203! !
204! Sets coupler RouteHandle connectors between source (srcFields) and !
205! destination (dstFields) fields for ESMF/NUOPC regridding operators !
206! with or without extrapolation support. !
207! !
208!=======================================================================
209!
210! Imported variable declarations.
211!
212 integer, intent(out) :: rc
213!
214 TYPE (esmf_cplcomp) :: coupler
215!
216! Local variable declarations.
217!
218 logical :: rh1exist, rh2exist
219!
220 integer :: i, ic, j, localpet, petcount, mycomm, ncplsets
221 integer :: isrc, idst, idsrc, iddst, grsrc, grdst
222 integer :: etsrc, etdst, itsrc, itdst
223 integer :: srccount, dstcount, itemcount, srcterm
224!
225 integer (i4b) :: srcmaskval, dstmaskval
226 integer (i4b) :: landvalue(1), seavalue(1)
227!
228 integer (i4b), allocatable, dimension(:,:) :: tlw, tuw
229!
230 character (len=*), parameter :: myfile = &
231 & __FILE__//", Coupler_ComputeRH"
232
233 character (ESMF_MAXSTR) :: msgstring
234 character (ESMF_MAXSTR) :: cname, dname, fname, rname, sname
235!
236 character (ESMF_MAXSTR), pointer :: cplsetlist(:) => null()
237 character (ESMF_MAXSTR), pointer :: dstlist(:) => null()
238 character (ESMF_MAXSTR), pointer :: srclist(:) => null()
239!
240 TYPE (esmf_extrapmethod_flag) :: extrapmethod
241 TYPE (esmf_field) :: dstfield, srcfield, tmpfield
242 TYPE (esmf_fieldbundle) :: dstfields, srcfields
243 TYPE (esmf_fieldstatus_flag) :: fieldstatus
244 TYPE (esmf_regridmethod_flag) :: regridmethod
245 TYPE (esmf_routehandle) :: routehandle
246 TYPE (esmf_state) :: state
247 TYPE (esmf_unmappedaction_flag) :: unmap
248 TYPE (esmf_vm) :: vm
249!
250!-----------------------------------------------------------------------
251! Initialize return code flag to success state (no error).
252!-----------------------------------------------------------------------
253!
254 rc=esmf_success
255!
256!-----------------------------------------------------------------------
257! Querry coupler component.
258!-----------------------------------------------------------------------
259!
260! Querry the coupler for the Virtual Machine (VM) parallel environmemt.
261!
262 CALL esmf_cplcompget (coupler, &
263 & name=cname, &
264 & vm=vm, &
265 & rc=rc)
266 IF (esmf_logfounderror(rctocheck=rc, &
267 & msg=esmf_logerr_passthru, &
268 & line=__line__, &
269 & file=myfile)) THEN
270 RETURN
271 END IF
272!
273 IF (esm_track) THEN
274 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_ComputeRH for ' &
275 & // trim(cname), ', PET', petrank
276 FLUSH (trac)
277 END IF
278!
279! Get current parallel node rank and number of nodes.
280!
281 CALL esmf_vmget (vm, &
282 & localpet=localpet, &
283 & petcount=petcount, &
284 & mpicommunicator=mycomm, &
285 & rc=rc)
286 IF (esmf_logfounderror(rctocheck=rc, &
287 & msg=esmf_logerr_passthru, &
288 & line=__line__, &
289 & file=myfile)) THEN
290 RETURN
291 END IF
292!
293! Set source and destination couple model indices.
294!
295 DO i=1,nmodels
296 DO j=1,nmodels
297 IF ((connectors(i,j)%IsActive).and. &
298 & (trim(connectors(i,j)%name).eq.trim(cname))) THEN
299 isrc=i
300 idst=j
301 END if
302 END DO
303 END DO
304!
305!-----------------------------------------------------------------------
306! Exchange land-sea mask flag.
307!-----------------------------------------------------------------------
308!
309 landvalue(1)=models(isrc)%LandValue
310 CALL esmf_vmbroadcast (vm, &
311 & bcstdata=landvalue, &
312 & count=1, &
313 & rootpet=0, &
314 & rc=rc)
315 IF (esmf_logfounderror(rctocheck=rc, &
316 & msg=esmf_logerr_passthru, &
317 & line=__line__, &
318 & file=myfile)) THEN
319 RETURN
320 END IF
321 models(isrc)%LandValue=landvalue(1)
322!
323 seavalue(1)=models(isrc)%SeaValue
324 CALL esmf_vmbroadcast (vm, &
325 & bcstdata=seavalue, &
326 & count=1, &
327 & rootpet=0, &
328 & rc=rc)
329 IF (esmf_logfounderror(rctocheck=rc, &
330 & msg=esmf_logerr_passthru, &
331 & line=__line__, &
332 & file=myfile)) THEN
333 RETURN
334 END IF
335 models(isrc)%SeaValue=seavalue(1)
336!
337 landvalue(1)=models(idst)%LandValue
338 CALL esmf_vmbroadcast (vm, &
339 & bcstdata=landvalue, &
340 & count=1, &
341 & rootpet=0, &
342 & rc=rc)
343 IF (esmf_logfounderror(rctocheck=rc, &
344 & msg=esmf_logerr_passthru, &
345 & line=__line__, &
346 & file=myfile)) THEN
347 RETURN
348 END IF
349 models(idst)%LandValue=landvalue(1)
350!
351 seavalue(1)=models(idst)%SeaValue
352 CALL esmf_vmbroadcast (vm, &
353 & bcstdata=seavalue, &
354 & count=1, &
355 & rootpet=0, &
356 & rc=rc)
357 IF (esmf_logfounderror(rctocheck=rc, &
358 & msg=esmf_logerr_passthru, &
359 & line=__line__, &
360 & file=myfile)) THEN
361 RETURN
362 END IF
363 models(idst)%SeaValue=seavalue(1)
364!
365!-----------------------------------------------------------------------
366! Set source and destination masks for connector according to the
367! connector interaction flag.
368!-----------------------------------------------------------------------
369!
370 SELECT CASE (connectors(isrc,idst)%MaskInteraction)
371 CASE (overocean)
372 srcmaskval=models(isrc)%LandValue
373 dstmaskval=models(idst)%LandValue
374 CASE (overland)
375 srcmaskval=models(isrc)%SeaValue
376 dstmaskval=models(idst)%SeaValue
377 END SELECT
378!
379!-----------------------------------------------------------------------
380! Get coupled set list for connector (Cname).
381!-----------------------------------------------------------------------
382!
383 IF ( associated(cplsetlist) ) nullify (cplsetlist)
384 CALL nuopc_connectorget (coupler, &
385 & cplsetlist=cplsetlist, &
386 & rc=rc)
387 IF (esmf_logfounderror(rctocheck=rc, &
388 & msg=esmf_logerr_passthru, &
389 & line=__line__, &
390 & file=myfile)) THEN
391 RETURN
392 END IF
393 ncplsets=SIZE(cplsetlist)
394!
395!-----------------------------------------------------------------------
396! Inquire size of source and destination field bundles.
397!-----------------------------------------------------------------------
398!
399 cplset_loop : DO ic=1,ncplsets
400!
401! Get source and destination fields for each coupled set.
402!
403 CALL nuopc_connectorget (coupler, &
404 & srcfields=srcfields, &
405 & dstfields=dstfields, &
406 & state=state, &
407 & cplset=cplsetlist(ic), &
408 & rc=rc)
409 IF (esmf_logfounderror(rctocheck=rc, &
410 & msg=esmf_logerr_passthru, &
411 & line=__line__, &
412 & file=myfile)) THEN
413 RETURN
414 END IF
415!
416 CALL esmf_fieldbundleget (srcfields, &
417 & fieldcount=srccount, &
418 & rc=rc)
419 IF (esmf_logfounderror(rctocheck=rc, &
420 & msg=esmf_logerr_passthru, &
421 & line=__line__, &
422 & file=myfile)) THEN
423 RETURN
424 END IF
425!
426 CALL esmf_fieldbundleget (dstfields, &
427 & fieldcount=dstcount, &
428 & rc=rc)
429 IF (esmf_logfounderror(rctocheck=rc, &
430 & msg=esmf_logerr_passthru, &
431 & line=__line__, &
432 & file=myfile)) THEN
433 RETURN
434 END IF
435!
436 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
437 WRITE (cplout,10) localpet, isrc, idst, &
438 & srcmaskval, dstmaskval, &
439 & trim(cplsetlist(ic)), &
440 & trim(connectors(isrc,idst)%name)
441 END IF
442!
443!-----------------------------------------------------------------------
444! Get source and destination fields.
445!-----------------------------------------------------------------------
446!
447 define : IF ((srccount.eq.dstcount).and.(dstcount.gt. 0)) THEN
448!
449! Allocate.
450!
451 allocate ( srclist(srccount) )
452 allocate ( dstlist(dstcount) )
453!
454! Get source and destination fields.
455!
456 CALL esmf_fieldbundleget (srcfields, &
457 & fieldnamelist=srclist, &
458 & rc=rc)
459 IF (esmf_logfounderror(rctocheck=rc, &
460 & msg=esmf_logerr_passthru, &
461 & line=__line__, &
462 & file=myfile)) THEN
463 RETURN
464 END IF
465!
466 CALL esmf_fieldbundleget (dstfields, &
467 & fieldnamelist=dstlist, &
468 & rc=rc)
469 IF (esmf_logfounderror(rctocheck=rc, &
470 & msg=esmf_logerr_passthru, &
471 & line=__line__, &
472 & file=myfile)) THEN
473 RETURN
474 END IF
475!
476!=======================================================================
477! Create connector RootHandlers for two step interpolation.
478!=======================================================================
479!
480 create : DO i=1,srccount
481!
482! Get source and destination field index.
483!
484 idsrc=field_index(models(isrc)%ExportField, srclist(i))
485 iddst=field_index(models(idst)%ImportField, dstlist(i))
486!
487! Get field name. Both source and destination should have the same
488! short name.
489!
490 fname=trim(models(isrc)%ExportField(idsrc)%short_name)
491!
492! Get regrid method for interpolation.
493!
494 itsrc=models(isrc)%ExportField(idsrc)%itype
495 itdst=models(idst)%ImportField(iddst)%itype
496!
497 IF (itsrc.NE.itdst) THEN
498 WRITE (msgstring,'(a)') trim(cname)// &
499 & ': SRC and DST field interpolation type does not match!'
500 CALL esmf_logwrite (trim(msgstring), esmf_logmsg_error)
501 RETURN
502 END IF
503!
504! Get extrapolation method for unmapped destination points.
505!
506 etsrc=models(isrc)%ExportField(idsrc)%etype
507 etdst=models(idst)%ImportField(iddst)%etype
508!
509 IF (etsrc.NE.etdst) THEN
510 WRITE (msgstring,'(a)') trim(cname)// &
511 & ': SRC and DST field extrapolation type does not match!'
512 CALL esmf_logwrite (trim(msgstring), esmf_logmsg_error)
513 RETURN
514 END IF
515!
516! Get grid type.
517!
518 grsrc=models(isrc)%ExportField(idsrc)%gtype
519 grdst=models(idst)%ImportField(iddst)%gtype
520!
521! Get source field object from bundle.
522!
523 CALL esmf_fieldbundleget (srcfields, &
524 & trim(fname), &
525 & field=srcfield, &
526 & rc=rc)
527 IF (esmf_logfounderror(rctocheck=rc, &
528 & msg=esmf_logerr_passthru, &
529 & line=__line__, &
530 & file=myfile)) THEN
531 RETURN
532 END IF
533!
534 CALL esmf_fieldget (srcfield, &
535 & status=fieldstatus, &
536 & rc=rc)
537 IF (esmf_logfounderror(rctocheck=rc, &
538 & msg=esmf_logerr_passthru, &
539 & line=__line__, &
540 & file=myfile)) THEN
541 RETURN
542 END IF
543!
544 IF (fieldstatus.ne.esmf_fieldstatus_complete) THEN
545 rc=esmf_rc_obj_bad
546 IF (localpet.eq.0) THEN
547 IF (fieldstatus.eq.esmf_fieldstatus_empty) THEN
548 msgstring='ESMF_FIELDSTATUS_EMPTY'
549 ELSE IF (fieldstatus.eq.esmf_fieldstatus_gridset) THEN
550 msgstring='ESMF_FIELDSTATUS_GRIDSET'
551 END IF
552 WRITE (cplout,20) 'Source Field: ', trim(fname), &
553 & trim(msgstring)
554 END IF
555 IF (esmf_logfounderror(rctocheck=rc, &
556 & msg=esmf_logerr_passthru, &
557 & line=__line__, &
558 & file=myfile)) THEN
559 RETURN
560 END IF
561 END IF
562!
563 IF (debuglevel.gt.1) THEN
564 CALL esmf_fieldprint (srcfield, rc=rc)
565 IF (esmf_logfounderror(rctocheck=rc, &
566 & msg=esmf_logerr_passthru, &
567 & line=__line__, &
568 & file=myfile)) THEN
569 RETURN
570 END IF
571 END IF
572!
573! Get destination field object from bundle.
574!
575 CALL esmf_fieldbundleget (dstfields, &
576 & trim(fname), &
577 & field=dstfield, &
578 & rc=rc)
579 IF (esmf_logfounderror(rctocheck=rc, &
580 & msg=esmf_logerr_passthru, &
581 & line=__line__, &
582 & file=myfile)) THEN
583 RETURN
584 END IF
585!
586 CALL esmf_fieldget (dstfield, &
587 & status=fieldstatus, &
588 & rc=rc)
589 IF (esmf_logfounderror(rctocheck=rc, &
590 & msg=esmf_logerr_passthru, &
591 & line=__line__, &
592 & file=myfile)) THEN
593 RETURN
594 END IF
595!
596 IF (fieldstatus.ne.esmf_fieldstatus_complete) THEN
597 rc=esmf_rc_obj_bad
598 IF (localpet.eq.0) THEN
599 IF (fieldstatus.eq.esmf_fieldstatus_empty) THEN
600 msgstring='ESMF_FIELDSTATUS_EMPTY'
601 ELSE IF (fieldstatus.eq.esmf_fieldstatus_gridset) THEN
602 msgstring='ESMF_FIELDSTATUS_GRIDSET'
603 END IF
604 WRITE (cplout,20) 'Destination Field: ', trim(fname), &
605 & trim(msgstring)
606 END IF
607 IF (esmf_logfounderror(rctocheck=rc, &
608 & msg=esmf_logerr_passthru, &
609 & line=__line__, &
610 & file=myfile)) THEN
611 RETURN
612 END IF
613 END IF
614!
615 IF (debuglevel.gt.1) THEN
616 CALL esmf_fieldprint (dstfield, rc=rc)
617 IF (esmf_logfounderror(rctocheck=rc, &
618 & msg=esmf_logerr_passthru, &
619 & line=__line__, &
620 & file=myfile)) THEN
621 RETURN
622 END IF
623 END IF
624!
625!-----------------------------------------------------------------------
626! REGRIDDING: Set RouteHandle for two-steps extrapolation.
627!-----------------------------------------------------------------------
628!
629 querry : IF (etsrc.eq.e2steps) THEN
630!
631! Check 1st RouteHandle. If the source field is the DATA component,
632! there is a RouteHandle for each export field. Examples:
633!
634! rh_Center_Corner_BLIN_WRF_01-TO-ROMS_01 source WRF_01
635! rh_SST_Center_Corner_BLIN_DATA-TO-ROMS_01 source DATA
636!
637 IF (isrc.eq.idata) THEN
638 rname='rh_'//trim(srclist(i))//'_'// &
639 & trim(gridtype(grsrc ))//'_'// &
640 & trim(gridtype(grdst ))//'_'// &
641 & trim(intrptype(ibilin))//'_'// &
642 & trim(extrptype(etsrc ))//'_'// &
643 & trim(cplsetlist(ic))//'_'// &
644 & trim(cname)
645 ELSE
646 rname='rh_'// &
647 & trim(gridtype(grsrc ))//'_'// &
648 & trim(gridtype(grdst ))//'_'// &
649 & trim(intrptype(ibilin))//'_'// &
650 & trim(extrptype(etsrc ))//'_'// &
651 & trim(cplsetlist(ic))//'_'// &
652 & trim(cname)
653 END IF
654!
655 CALL esmf_stateget (state, &
656 & itemsearch=trim(rname), &
657 & itemcount=itemcount, &
658 & rc=rc)
659 IF (esmf_logfounderror(rctocheck=rc, &
660 & msg=esmf_logerr_passthru, &
661 & line=__line__, &
662 & file=myfile)) THEN
663 RETURN
664 END IF
665!
666 IF (itemcount.le.0) THEN
667 rh1exist=.false.
668 ELSE
669 rh1exist=.true.
670 END IF
671 rh2exist=.false.
672!
673! Debug: report exchanged fields before regridding.
674!
675 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
676 WRITE (cplout,30) trim(cplsetlist(ic)), trim(cname), &
677 & trim(models(isrc)%ExportField(idsrc)%short_name), &
678 & trim(gridtype(models(isrc)%ExportField(idsrc)%gtype)), &
679 & trim(models(idst)%ImportField(iddst)%short_name), &
680 & trim(gridtype(models(idst)%ImportField(iddst)%gtype)), &
681 & trim(intrptype(models(isrc)%ExportField(idsrc)%itype)), &
682 & rh1exist, rh2exist
683 FLUSH (cplout)
684 END IF
685!
686! Create 1st RouteHandle.
687!
688 IF (.not.rh1exist) THEN
689 unmap=esmf_unmappedaction_ignore
690 regridmethod=esmf_regridmethod_bilinear
691!
692 srcterm=0
693!
694 CALL esmf_fieldregridstore (srcfield=srcfield, &
695 & dstfield=dstfield, &
696 & srcmaskvalues=(/srcmaskval/), &
697 & dstmaskvalues=(/dstmaskval/), &
698 & unmappedaction=unmap, &
699 & routehandle=routehandle, &
700 & regridmethod=regridmethod, &
701 & ignoredegenerate=.true., &
702 & srctermprocessing=srcterm, &
703 & rc=rc)
704 IF (esmf_logfounderror(rctocheck=rc, &
705 & msg=esmf_logerr_passthru, &
706 & line=__line__, &
707 & file=myfile)) THEN
708 RETURN
709 END IF
710!
711! Set name to 1st RouteHandle.
712!
713 CALL esmf_routehandleset (routehandle, &
714 & name=trim(rname), &
715 & rc=rc)
716 IF (esmf_logfounderror(rctocheck=rc, &
717 & msg=esmf_logerr_passthru, &
718 & line=__line__, &
719 & file=myfile)) THEN
720 RETURN
721 END IF
722!
723! Add 1st RouteHandle to the state.
724!
725 CALL esmf_stateadd (state, &
726 & (/ routehandle /), &
727 & rc=rc)
728 IF (esmf_logfounderror(rctocheck=rc, &
729 & msg=esmf_logerr_passthru, &
730 & line=__line__, &
731 & file=myfile)) THEN
732 RETURN
733 END IF
734!
735! Debug: report successful computation of regridding 1st RouteHandle.
736!
737 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
738 WRITE (cplout,40) trim(rname)
739 FLUSH (cplout)
740 END IF
741 END IF
742!
743! Check 2nd routehandle (i.e. rh_Center_Corner_NS2D_ATM-OCN).
744!
745! rh_Center_Corner_NS2D_WRF_01-TO-ROMS_01 source WRF_01 component
746! rh_SST_Center_Corner_NS2D_DATA-TO-ROMS_01 source DATA component
747!
748 IF (isrc.eq.idata) THEN
749 rname='rh_'//trim(srclist(i))//'_'// &
750 & trim(gridtype(grsrc ))//'_'// &
751 & trim(gridtype(grdst ))//'_'// &
752 & trim(intrptype(instod))//'_'// &
753 & trim(extrptype(etsrc ))//'_'// &
754 & trim(cplsetlist(ic))//'_'// &
755 & trim(cname)
756 ELSE
757 rname='rh_'// &
758 & trim(gridtype(grsrc ))//'_'// &
759 & trim(gridtype(grdst ))//'_'// &
760 & trim(intrptype(instod))//'_'// &
761 & trim(extrptype(etsrc ))//'_'// &
762 & trim(cplsetlist(ic))//'_'// &
763 & trim(cname)
764 END IF
765!
766 CALL esmf_stateget (state, &
767 & itemsearch=trim(rname), &
768 & itemcount=itemcount, &
769 & rc=rc)
770 IF (esmf_logfounderror(rctocheck=rc, &
771 & msg=esmf_logerr_passthru, &
772 & line=__line__, &
773 & file=myfile)) THEN
774 RETURN
775 END IF
776!
777 IF (itemcount.le.0) THEN
778 rh2exist=.false.
779 ELSE
780 rh2exist=.true.
781 END IF
782!
783! Create temporary field in destination grid.
784!
785 IF (.not.rh2exist) THEN
786 tmpfield=coupler_fieldcreate(dstfield, 'temp_field', &
787 & 1.0_dp, -1_i4b, rc)
788!
789! Modify grid mask to split masked and unmasked grid cells.
790!
791 CALL coupler_findunmapped (srcfield, dstfield, &
792 & srcmaskval, dstmaskval, &
793 & isrc, idst, rc)
794 IF (esmf_logfounderror(rctocheck=rc, &
795 & msg=esmf_logerr_passthru, &
796 & line=__line__, &
797 & file=myfile)) THEN
798 RETURN
799 END IF
800!
801! Create 2nd RouteHandle.
802!
803 unmap=esmf_unmappedaction_ignore
804 regridmethod=esmf_regridmethod_nearest_stod
805!
806 srcterm=0
807!
808 CALL esmf_fieldregridstore (srcfield=tmpfield, &
809 & dstfield=dstfield, &
810 & srcmaskvalues=(/dstmaskval, &
811 & unmapped_mask/), &
812 & dstmaskvalues=(/dstmaskval, &
813 & mapped_mask/), &
814 & unmappedaction=unmap, &
815 & routehandle=routehandle, &
816 & regridmethod=regridmethod, &
817 & srctermprocessing=srcterm, &
818 & ignoredegenerate=.true., &
819 & rc=rc)
820 IF (esmf_logfounderror(rctocheck=rc, &
821 & msg=esmf_logerr_passthru, &
822 & line=__line__, &
823 & file=myfile)) THEN
824 RETURN
825 END IF
826!
827! Add name to 2nd RouteHandle.
828!
829 CALL esmf_routehandleset (routehandle, &
830 & name=trim(rname), &
831 & rc=rc)
832 IF (esmf_logfounderror(rctocheck=rc, &
833 & msg=esmf_logerr_passthru, &
834 & line=__line__, &
835 & file=myfile)) THEN
836 RETURN
837 END IF
838!
839! Add 2nd RouteHandle to the state.
840!
841 CALL esmf_stateadd (state, &
842 & (/ routehandle /), &
843 & rc=rc)
844 IF (esmf_logfounderror(rctocheck=rc, &
845 & msg=esmf_logerr_passthru, &
846 & line=__line__, &
847 & file=myfile)) THEN
848 RETURN
849 END IF
850!
851! Delete temporary field.
852!
853 CALL esmf_fielddestroy (tmpfield, rc=rc)
854 IF (esmf_logfounderror(rctocheck=rc, &
855 & msg=esmf_logerr_passthru, &
856 & line=__line__, &
857 & file=myfile)) THEN
858 RETURN
859 END IF
860!
861! Debug: report successful computation of regridding 2nd RouteHandle.
862!
863 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
864 WRITE (cplout,40) trim(rname)
865 FLUSH (cplout)
866 END IF
867 END IF
868!
869!-----------------------------------------------------------------------
870! REGRIDDING: create RouteHandle for one-step interpolation
871! (native extrapolation of unmapped points is possible)
872!-----------------------------------------------------------------------
873!
874 ELSE
875!
876 IF (isrc.eq.idata) THEN
877 rname='rh_'//trim(srclist(i))//'_'// &
878 & trim(gridtype(grsrc))//'_'// &
879 & trim(gridtype(grdst))//'_'// &
880 & trim(intrptype(itsrc))//'_'// &
881 & trim(extrptype(etsrc))//'_'// &
882 & trim(cplsetlist(ic))//'_'// &
883 & trim(cname)
884 ELSE
885 rname='rh_'// &
886 & trim(gridtype(grsrc))//'_'// &
887 & trim(gridtype(grdst))//'_'// &
888 & trim(intrptype(itsrc))//'_'// &
889 & trim(extrptype(etsrc))//'_'// &
890 & trim(cplsetlist(ic))//'_'// &
891 & trim(cname)
892 END IF
893!
894 CALL esmf_stateget (state, &
895 & itemsearch=trim(rname), &
896 & itemcount=itemcount, &
897 & rc=rc)
898 IF (esmf_logfounderror(rctocheck=rc, &
899 & msg=esmf_logerr_passthru, &
900 & line=__line__, &
901 & file=myfile)) THEN
902 RETURN
903 END IF
904!
905 IF (itemcount.le.0) THEN
906 rh1exist=.false.
907 ELSE
908 rh1exist=.true.
909 END IF
910 rh2exist=.false.
911!
912! Debug: report exchanged fields before regridding.
913!
914 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
915 WRITE (cplout,30) trim(cplsetlist(ic)), trim(cname), &
916 & trim(models(isrc)%ExportField(idsrc)%short_name), &
917 & trim(gridtype(models(isrc)%ExportField(idsrc)%gtype)), &
918 & trim(models(idst)%ImportField(iddst)%short_name), &
919 & trim(gridtype(models(idst)%ImportField(iddst)%gtype)), &
920 & trim(intrptype(models(isrc)%ExportField(idsrc)%itype)), &
921 & rh1exist, rh2exist
922 FLUSH (cplout)
923 END IF
924!
925! Regrid method from source to destination.
926!
927 IF (.not.rh1exist) THEN
928 unmap=esmf_unmappedaction_ignore
929 IF (itsrc.eq.ibilin) THEN
930 regridmethod=esmf_regridmethod_bilinear
931 ELSE IF (itsrc.eq.ipatch) THEN
932 regridmethod=esmf_regridmethod_patch
933 ELSE IF (itsrc.eq.iconsv1) THEN
934 regridmethod=esmf_regridmethod_conserve
935 ELSE IF (itsrc.eq.instod) THEN
936 regridmethod=esmf_regridmethod_nearest_stod
937 ELSE IF (itsrc.eq.indtos) THEN
938 regridmethod=esmf_regridmethod_nearest_dtos
939 ELSE
940 WRITE (msgstring,'(a)') trim(cname)//': selected '// &
941 & 'interpolation type is not supported! '// &
942 & intrptype(itsrc)
943 CALL esmf_logwrite (trim(msgstring),esmf_logmsg_error)
944 CALL esmf_finalize (endflag=esmf_end_abort)
945 END IF
946!
947 IF (etsrc.eq.enone) THEN
948 extrapmethod=esmf_extrapmethod_none
949 ELSE IF (etsrc.eq.exstod) THEN
950 extrapmethod=esmf_extrapmethod_nearest_stod
951 ELSE IF (etsrc.eq.eidavg) THEN
952 extrapmethod=esmf_extrapmethod_nearest_idavg
953 ELSE IF (etsrc.eq.ecreep) THEN
954 extrapmethod=esmf_extrapmethod_creep
955 ELSE
956 WRITE (msgstring,'(a)') trim(cname)//': selected '// &
957 & 'extrapolation type is not supported! '// &
958 & extrptype(etsrc)
959 CALL esmf_logwrite (trim(msgstring),esmf_logmsg_error)
960 CALL esmf_finalize (endflag=esmf_end_abort)
961 END IF
962!
963 srcterm=0
964!
965 SELECT CASE (cmodel(isrc))
966 CASE ('ROMS')
967 landvalue(1)=models(isrc)%LandValue
968 CALL esmf_fieldregridstore (srcfield=srcfield, &
969 & dstfield=dstfield, &
970 & srcmaskvalues=landvalue, &
971 & unmappedaction=unmap, &
972 & routehandle=routehandle, &
973 & regridmethod=regridmethod, &
974 & extrapmethod=extrapmethod, &
975 & extrapnumlevels=extrapnumlevels, &
976 & srctermprocessing=srcterm, &
977 & ignoredegenerate=.true., &
978 & rc=rc)
979 IF (esmf_logfounderror(rctocheck=rc, &
980 & msg=esmf_logerr_passthru, &
981 & line=__line__, &
982 & file=myfile)) THEN
983 RETURN
984 END IF
985 CASE ('DATA')
986 landvalue(1)=models(isrc)%LandValue
987 CALL esmf_fieldregridstore (srcfield=srcfield, &
988 & dstfield=dstfield, &
989 & srcmaskvalues=landvalue, &
990 & unmappedaction=unmap, &
991 & routehandle=routehandle, &
992 & regridmethod=regridmethod, &
993 & extrapmethod=extrapmethod, &
994 & extrapnumlevels=extrapnumlevels, &
995 & srctermprocessing=srcterm, &
996 & ignoredegenerate=.true., &
997 & rc=rc)
998 IF (esmf_logfounderror(rctocheck=rc, &
999 & msg=esmf_logerr_passthru, &
1000 & line=__line__, &
1001 & file=myfile)) THEN
1002 RETURN
1003 END IF
1004 CASE DEFAULT
1005 landvalue(1)=models(isrc)%LandValue
1006 CALL esmf_fieldregridstore (srcfield=srcfield, &
1007 & dstfield=dstfield, &
1008 & srcmaskvalues=landvalue, &
1009 & unmappedaction=unmap, &
1010 & routehandle=routehandle, &
1011 & regridmethod=regridmethod, &
1012 & extrapmethod=extrapmethod, &
1013 & extrapnumlevels=extrapnumlevels, &
1014 & srctermprocessing=srcterm, &
1015 & ignoredegenerate=.true., &
1016 & rc=rc)
1017 IF (esmf_logfounderror(rctocheck=rc, &
1018 & msg=esmf_logerr_passthru, &
1019 & line=__line__, &
1020 & file=myfile)) THEN
1021 RETURN
1022 END IF
1023 END SELECT
1024!
1025! Add name to RouteHandle.
1026!
1027 CALL esmf_routehandleset (routehandle, &
1028 & name=trim(rname), &
1029 & rc=rc)
1030 IF (esmf_logfounderror(rctocheck=rc, &
1031 & msg=esmf_logerr_passthru, &
1032 & line=__line__, &
1033 & file=myfile)) THEN
1034 RETURN
1035 END IF
1036!
1037! Add RouteHandle to the state.
1038!
1039 CALL esmf_stateadd (state, &
1040 & (/ routehandle /), &
1041 & rc=rc)
1042 IF (esmf_logfounderror(rctocheck=rc, &
1043 & msg=esmf_logerr_passthru, &
1044 & line=__line__, &
1045 & file=myfile)) THEN
1046 RETURN
1047 END IF
1048 rh1exist=.true.
1049!
1050! Debug: report successful computation of regridding 1st RouteHandle.
1051!
1052 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
1053 WRITE (cplout,40) trim(rname)
1054 END IF
1055 END IF
1056
1057 END IF querry
1058 END DO create
1059 END IF define
1060 END DO cplset_loop
1061!
1062 IF (esm_track) THEN
1063 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_ComputeRH for ' &
1064 & // trim(cname), ', PET', petrank
1065 FLUSH (trac)
1066 END IF
1067 IF (debuglevel.gt.0) FLUSH (cplout)
1068!
1069 10 FORMAT (4x,'RouteHandle - PET = ',i0,' iSrc = ',i0,' iDst = ',i0, &
1070 & ' srcMask = ',i0,' dstMask = ',i0,', cplSet = ',a,', ',a)
1071 20 FORMAT (' Coupler_ComputerRH - ',a, &
1072 & '''',a,''' has an incorrect status',/,22x,a)
1073 30 FORMAT (4x,'RouteHandle - ESMF: ',a,', ',a,', ',a, &
1074 & ' [',a,'] to ',a,' [',a,']',' >> ',a, ' - ',l1,' - ',l1)
1075 40 FORMAT (18x,'Computed interpolant ''',a,''', sucessfully')
1076!
1077 RETURN
1078 END SUBROUTINE coupler_computerh
1079!
1080 SUBROUTINE coupler_executerh (coupler, rc)
1081!
1082!=======================================================================
1083! !
1084! Performs the interpolation between source and destination fields. !
1085! It uses REGRID with or without extrapolation support. !
1086! !
1087!=======================================================================
1088!
1089 USE strings_mod, ONLY : lowercase
1090!
1091! Imported variable declarations.
1092!
1093 integer, intent(out) :: rc
1094!
1095 TYPE (esmf_cplcomp) :: coupler
1096!
1097! Local variable declarations.
1098!
1099 logical :: isvalid
1100!
1101 integer :: localpet, petcount, mycomm
1102 integer :: i, ic, is, j, srccount, dstcount, ncplsets
1103 integer :: isrc, idst, idsrc, iddst, grsrc, grdst
1104 integer :: etsrc, etdst, itsrc, itdst
1105!
1106 real (dp) :: src_total, dst_total, rel_error
1107!
1108 real (dp), dimension(:,:), pointer :: ptr2d => null()
1109!
1110 character (len=*), parameter :: myfile = &
1111 & __FILE__//", Coupler_ExecuteRH"
1112
1113 character (len=19 ) :: dstfilestring, srcfilestring
1114 character (ESMF_MAXSTR) :: msgstring, cname, fname, rname
1115 character (ESMF_MAXSTR) :: dsttimestring, srctimestring
1116 character (ESMF_MAXSTR) :: dstfile, srcfile
1117!
1118 character (ESMF_MAXSTR), pointer :: cplsetlist(:) => null()
1119 character (ESMF_MAXSTR), pointer :: dstlist(:) => null()
1120 character (ESMF_MAXSTR), pointer :: srclist(:) => null()
1121!
1122 TYPE (esmf_field) :: srcfield, dstfield, tmpfield
1123 TYPE (esmf_fieldbundle) :: dstfields, srcfields
1124 TYPE (esmf_routehandle) :: routehandle
1125 TYPE (esmf_state) :: state
1126 TYPE (esmf_time) :: dsttime, srctime
1127 TYPE (esmf_vm) :: vm
1128!
1129!-----------------------------------------------------------------------
1130! Initialize return code flag to success state (no error).
1131!-----------------------------------------------------------------------
1132!
1133 rc=esmf_success
1134!
1135!-----------------------------------------------------------------------
1136! Query coupler component.
1137!-----------------------------------------------------------------------
1138!
1139! Querry the coupler for the Virtual Machine (VM) parallel environmemt.
1140!
1141 CALL esmf_cplcompget (coupler, &
1142 & name=cname, &
1143 & vm=vm, &
1144 & rc=rc)
1145 IF (esmf_logfounderror(rctocheck=rc, &
1146 & msg=esmf_logerr_passthru, &
1147 & line=__line__, &
1148 & file=myfile)) THEN
1149 RETURN
1150 END IF
1151!
1152 IF (esm_track) THEN
1153 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_ExecuteRH for ' &
1154 & // trim(cname), ', PET', petrank
1155 FLUSH (trac)
1156 END IF
1157!
1158! Get current parallel node rank and number of nodes.
1159!
1160 CALL esmf_vmget (vm, &
1161 & localpet=localpet, &
1162 & petcount=petcount, &
1163 & mpicommunicator=mycomm, &
1164 & rc=rc)
1165 IF (esmf_logfounderror(rctocheck=rc, &
1166 & msg=esmf_logerr_passthru, &
1167 & line=__line__, &
1168 & file=myfile)) THEN
1169 RETURN
1170 END IF
1171!
1172! Set source and destination couple model indices.
1173!
1174 DO i=1,nmodels
1175 DO j=1,nmodels
1176 IF ((connectors(i,j)%IsActive).and. &
1177 & (trim(connectors(i,j)%name).eq.trim(cname))) THEN
1178 isrc=i
1179 idst=j
1180 END IF
1181 END DO
1182 END DO
1183!
1184!-----------------------------------------------------------------------
1185! Get coupled set list for connector (Cname).
1186!-----------------------------------------------------------------------
1187!
1188 IF ( associated(cplsetlist) ) nullify (cplsetlist)
1189 CALL nuopc_connectorget (coupler, &
1190 & cplsetlist=cplsetlist, &
1191 & rc=rc)
1192 IF (esmf_logfounderror(rctocheck=rc, &
1193 & msg=esmf_logerr_passthru, &
1194 & line=__line__, &
1195 & file=myfile)) THEN
1196 RETURN
1197 END IF
1198 ncplsets=SIZE(cplsetlist)
1199!
1200!-----------------------------------------------------------------------
1201! Inquire about source and destination fields.
1202!-----------------------------------------------------------------------
1203!
1204 cplset_loop : DO ic=1,ncplsets
1205!
1206! Get source and destination fields for each coupled set.
1207!
1208 CALL nuopc_connectorget (coupler, &
1209 & srcfields=srcfields, &
1210 & dstfields=dstfields, &
1211 & state=state, &
1212 & cplset=cplsetlist(ic), &
1213 & rc=rc)
1214 IF (esmf_logfounderror(rctocheck=rc, &
1215 & msg=esmf_logerr_passthru, &
1216 & line=__line__, &
1217 & file=myfile)) THEN
1218 RETURN
1219 END IF
1220!
1221! Number of source fields.
1222!
1223 CALL esmf_fieldbundleget (srcfields, &
1224 & fieldcount=srccount, &
1225 & rc=rc)
1226 IF (esmf_logfounderror(rctocheck=rc, &
1227 & msg=esmf_logerr_passthru, &
1228 & line=__line__, &
1229 & file=myfile)) THEN
1230 RETURN
1231 END IF
1232!
1233! Number of destination fields.
1234!
1235 CALL esmf_fieldbundleget (dstfields, &
1236 & fieldcount=dstcount, &
1237 & rc=rc)
1238 IF (esmf_logfounderror(rctocheck=rc, &
1239 & msg=esmf_logerr_passthru, &
1240 & line=__line__, &
1241 & file=myfile)) THEN
1242 RETURN
1243 END IF
1244!
1245! Source fields names.
1246!
1247 allocate ( srclist(srccount) )
1248
1249 CALL esmf_fieldbundleget (srcfields, &
1250 & fieldnamelist=srclist, &
1251 & rc=rc)
1252 IF (esmf_logfounderror(rctocheck=rc, &
1253 & msg=esmf_logerr_passthru, &
1254 & line=__line__, &
1255 & file=myfile)) THEN
1256 RETURN
1257 END IF
1258!
1259! Destination fields names.
1260!
1261 allocate ( dstlist(dstcount) )
1262
1263 CALL esmf_fieldbundleget (dstfields, &
1264 & fieldnamelist=dstlist, &
1265 & rc=rc)
1266 IF (esmf_logfounderror(rctocheck=rc, &
1267 & msg=esmf_logerr_passthru, &
1268 & line=__line__, &
1269 & file=myfile)) THEN
1270 RETURN
1271 END IF
1272!
1273!=======================================================================
1274! Interpolate or extrapolate between source and destination fields.
1275!=======================================================================
1276!
1277 exchange : DO i=1,srccount
1278!
1279! Set source and destination field index.
1280!
1281 idsrc=field_index(models(isrc)%ExportField, srclist(i))
1282 iddst=field_index(models(idst)%ImportField, dstlist(i))
1283!
1284! Get field name. Both source and destination should have the same
1285! short name.
1286!
1287 fname=trim(models(isrc)%ExportField(idsrc)%short_name)
1288!
1289! Set interpolation type.
1290!
1291 itsrc=models(isrc)%ExportField(idsrc)%itype
1292 itdst=models(idst)%ImportField(iddst)%itype
1293!
1294 IF (itsrc.ne.itdst) THEN
1295 WRITE (msgstring,'(a)') trim(cname)// &
1296 & ': SRC and DST field interpolation type does not match!'
1297 CALL esmf_logwrite (trim(msgstring), esmf_logmsg_error)
1298 RETURN
1299 END IF
1300!
1301! Get extrapolation method for unmapped destination points.
1302!
1303 etsrc=models(isrc)%ExportField(idsrc)%etype
1304 etdst=models(idst)%ImportField(iddst)%etype
1305!
1306 IF (etsrc.NE.etdst) THEN
1307 WRITE (msgstring,'(a)') trim(cname)// &
1308 & ': SRC and DST field extrapolation type does not match!'
1309 CALL esmf_logwrite (trim(msgstring), esmf_logmsg_error)
1310 RETURN
1311 END IF
1312!
1313! Set grid type.
1314!
1315 grsrc=models(isrc)%ExportField(idsrc)%gtype
1316 grdst=models(idst)%ImportField(iddst)%gtype
1317!
1318! Get source field object from bundle.
1319!
1320 CALL esmf_fieldbundleget (srcfields, &
1321 & trim(fname), &
1322 & field=srcfield, &
1323 & rc=rc)
1324 IF (esmf_logfounderror(rctocheck=rc, &
1325 & msg=esmf_logerr_passthru, &
1326 & line=__line__, &
1327 & file=myfile)) THEN
1328 RETURN
1329 END IF
1330!
1331! Get destination field object from bundle.
1332!
1333 CALL esmf_fieldbundleget (dstfields, &
1334 & trim(fname), &
1335 & field=dstfield, &
1336 & rc=rc)
1337 IF (esmf_logfounderror(rctocheck=rc, &
1338 & msg=esmf_logerr_passthru, &
1339 & line=__line__, &
1340 & file=myfile)) THEN
1341 RETURN
1342 END IF
1343!
1344!-----------------------------------------------------------------------
1345! Perform REGRID with two-steps extrapolation.
1346!-----------------------------------------------------------------------
1347!
1348 querry : IF (etsrc.eq.e2steps) THEN
1349!
1350! Check 1st RouteHandle. If the source field is the DATA component,
1351! there is a RouteHandle for each export field. Examples:
1352!
1353! rh_Center_Corner_BLIN_ATM-TO-ROMS_01 (source ATM component)
1354! rh_SST_Center_Corner_BLIN_DATA-TO-ROMS_01 (source DATA component)
1355!
1356 IF (isrc.eq.idata) THEN
1357 rname='rh_'//trim(srclist(i))//'_'// &
1358 & trim(gridtype(grsrc ))//'_'// &
1359 & trim(gridtype(grdst ))//'_'// &
1360 & trim(intrptype(ibilin))//'_'// &
1361 & trim(extrptype(etsrc ))//'_'// &
1362 & trim(cplsetlist(ic))//'_'// &
1363 & trim(cname)
1364 ELSE
1365 rname='rh_'// &
1366 & trim(gridtype(grsrc ))//'_'// &
1367 & trim(gridtype(grdst ))//'_'// &
1368 & trim(intrptype(ibilin))//'_'// &
1369 & trim(extrptype(etsrc ))//'_'// &
1370 & trim(cplsetlist(ic))//'_'// &
1371 & trim(cname)
1372 END IF
1373!
1374 CALL esmf_stateget (state, &
1375 & trim(rname), &
1376 & routehandle, &
1377 & rc=rc)
1378 IF (esmf_logfounderror(rctocheck=rc, &
1379 & msg=esmf_logerr_passthru, &
1380 & line=__line__, &
1381 & file=myfile)) THEN
1382 RETURN
1383 END IF
1384!
1385! Create temporary field in destination grid.
1386!
1387 tmpfield=coupler_fieldcreate(dstfield, &
1388 & fname, &
1389 & missing_dp, -1, rc)
1390 IF (esmf_logfounderror(rctocheck=rc, &
1391 & msg=esmf_logerr_passthru, &
1392 & line=__line__, &
1393 & file=myfile)) THEN
1394 RETURN
1395 END IF
1396!
1397! Perform 1st REGRID operation.
1398!
1399 CALL esmf_fieldregrid (srcfield, &
1400 & tmpfield, &
1401 & routehandle, &
1402 & zeroregion=esmf_region_select, &
1403 & termorderflag=esmf_termorder_srcseq, &
1404 & rc=rc)
1405 IF (esmf_logfounderror(rctocheck=rc, &
1406 & msg=esmf_logerr_passthru, &
1407 & line=__line__, &
1408 & file=myfile)) THEN
1409 RETURN
1410 END IF
1411!
1412! Copy content from temporary field to destination field.
1413!
1414 CALL esmf_fieldcopy (dstfield, &
1415 & tmpfield, &
1416 & rc=rc)
1417 IF (esmf_logfounderror(rctocheck=rc, &
1418 & msg=esmf_logerr_passthru, &
1419 & line=__line__, &
1420 & file=myfile)) THEN
1421 RETURN
1422 END IF
1423!
1424! Get 2nd RouteHandle from state.
1425!
1426 IF (isrc.eq.idata) THEN
1427 rname='rh_'//trim(srclist(i)) //'_'// &
1428 & trim(gridtype(grsrc ))//'_'// &
1429 & trim(gridtype(grdst ))//'_'// &
1430 & trim(intrptype(instod))//'_'// &
1431 & trim(extrptype(etsrc ))//'_'// &
1432 & trim(cplsetlist(ic))//'_'// &
1433 & trim(cname)
1434 ELSE
1435 rname='rh_'// &
1436 & trim(gridtype(grsrc ))//'_'// &
1437 & trim(gridtype(grdst ))//'_'// &
1438 & trim(intrptype(instod))//'_'// &
1439 & trim(extrptype(etsrc ))//'_'// &
1440 & trim(cplsetlist(ic))//'_'// &
1441 & trim(cname)
1442 END IF
1443!
1444 CALL esmf_stateget (state, &
1445 & trim(rname), &
1446 & routehandle, &
1447 & rc=rc)
1448 IF (esmf_logfounderror(rctocheck=rc, &
1449 & msg=esmf_logerr_passthru, &
1450 & line=__line__, &
1451 & file=myfile)) THEN
1452 RETURN
1453 END IF
1454!
1455! Perform 2nd REGRID operation to fill unmapped grid points.
1456!
1457 CALL esmf_fieldregrid (tmpfield, &
1458 & dstfield, &
1459 & routehandle, &
1460 & zeroregion=esmf_region_select, &
1461 & termorderflag=esmf_termorder_srcseq, &
1462 & rc=rc)
1463 IF (esmf_logfounderror(rctocheck=rc, &
1464 & msg=esmf_logerr_passthru, &
1465 & line=__line__, &
1466 & file=myfile)) THEN
1467 RETURN
1468 END IF
1469!
1470 CALL esmf_fielddestroy (tmpfield, rc=rc)
1471 IF (esmf_logfounderror(rctocheck=rc, &
1472 & msg=esmf_logerr_passthru, &
1473 & line=__line__, &
1474 & file=myfile)) THEN
1475 RETURN
1476 END IF
1477!
1478! If integral adjustment is activated, calculate integral.
1479!
1480 IF (models(isrc)%ExportField(idsrc)% &
1481 & enable_integral_adj) THEN
1482 src_total=0.0_dp
1483 src_total=coupler_areaintegral(vm, &
1484 & srcfield, &
1485 & (/unmapped_mask, mapped_mask/), &
1486 & rc)
1487 IF (esmf_logfounderror(rctocheck=rc, &
1488 & msg=esmf_logerr_passthru, &
1489 & line=__line__, &
1490 & file=myfile)) THEN
1491 RETURN
1492 END IF
1493!
1494 IF (localpet.eq.0) THEN
1495 WRITE (cplout,10) &
1496 & localpet, 'SRC. INTEGRAL', src_total, &
1497 & trim(models(isrc)%ExportField(idsrc)%short_name)
1498 END IF
1499!
1500 dst_total=0.0_dp
1501 dst_total=coupler_areaintegral(vm, &
1502 & dstfield, &
1503 & (/unmapped_mask, mapped_mask/), &
1504 & rc)
1505 IF (esmf_logfounderror(rctocheck=rc, &
1506 & msg=esmf_logerr_passthru, &
1507 & line=__line__, &
1508 & file=myfile)) THEN
1509 RETURN
1510 END IF
1511!
1512 IF (localpet.eq.0) THEN
1513 WRITE (cplout,10) &
1514 & localpet, 'DST. INTEGRAL', dst_total, &
1515 & trim(models(isrc)%ExportField(idsrc)%short_name)
1516 rel_error=0.0_dp
1517 IF (src_total.ne.0.0_dp) THEN
1518 rel_error=(dst_total-src_total)/src_total
1519 END IF
1520 WRITE (cplout,10) &
1521 & localpet, 'RELATIVE ERROR 1', rel_error, &
1522 & trim(models(isrc)%ExportField(idsrc)%short_name)
1523 END IF
1524!
1525! Adjust destination field based on calculated integral.
1526!
1527 CALL coupler_adjustfield (vm, &
1528 & dstfield, &
1529 & (/unmapped_mask, mapped_mask/), &
1530 & dst_total-src_total, &
1531 & rc)
1532 IF (esmf_logfounderror(rctocheck=rc, &
1533 & msg=esmf_logerr_passthru, &
1534 & line=__line__, &
1535 & file=myfile)) THEN
1536 RETURN
1537 END IF
1538!
1539 dst_total=0.0_dp
1540 dst_total=coupler_areaintegral(vm, &
1541 & dstfield, &
1542 & (/unmapped_mask, mapped_mask/), &
1543 & rc)
1544 IF (esmf_logfounderror(rctocheck=rc, &
1545 & msg=esmf_logerr_passthru, &
1546 & line=__line__, &
1547 & file=myfile)) THEN
1548 RETURN
1549 END IF
1550!
1551 IF (localpet.eq.0) THEN
1552 WRITE (cplout,10) &
1553 & localpet, 'DST. INTEGRAL (CORR)', dst_total, &
1554 & trim(models(isrc)%ExportField(idsrc)%short_name)
1555 rel_error=0.0_dp
1556 IF (src_total.ne.0.0_dp) THEN
1557 rel_error=(dst_total-src_total)/src_total
1558 END IF
1559 WRITE (cplout,10) &
1560 & localpet, 'RELATIVE ERROR 2', rel_error, &
1561 & trim(models(isrc)%ExportField(idsrc)%short_name)
1562 END IF
1563 END IF
1564!
1565!-----------------------------------------------------------------------
1566! Perform REGRID without extrapolation support.
1567!-----------------------------------------------------------------------
1568!
1569 ELSE
1570!
1571! Get RouteHandle from state.
1572!
1573 IF (isrc.eq.idata) THEN
1574 rname='rh_'//trim(srclist(i))//'_'// &
1575 & trim(gridtype(grsrc))//'_'// &
1576 & trim(gridtype(grdst))//'_'// &
1577 & trim(intrptype(itsrc))//'_'// &
1578 & trim(extrptype(etsrc))//'_'// &
1579 & trim(cplsetlist(ic))//'_'// &
1580 & trim(cname)
1581 ELSE
1582 rname='rh_'// &
1583 & trim(gridtype(grsrc))//'_'// &
1584 & trim(gridtype(grdst))//'_'// &
1585 & trim(intrptype(itsrc))//'_'// &
1586 & trim(extrptype(etsrc))//'_'// &
1587 & trim(cplsetlist(ic))//'_'// &
1588 & trim(cname)
1589 END IF
1590!
1591 CALL esmf_stateget (state, &
1592 & trim(rname), &
1593 & routehandle, &
1594 & rc=rc)
1595 IF (esmf_logfounderror(rctocheck=rc, &
1596 & msg=esmf_logerr_passthru, &
1597 & line=__line__, &
1598 & file=myfile)) THEN
1599 RETURN
1600 END IF
1601!
1602! Perform REGRID operation.
1603!
1604 CALL esmf_fieldregrid (srcfield, &
1605 & dstfield, &
1606 & routehandle, &
1607 & zeroregion=esmf_region_select, &
1608 & termorderflag=esmf_termorder_srcseq, &
1609 & rc=rc)
1610 IF (esmf_logfounderror(rctocheck=rc, &
1611 & msg=esmf_logerr_passthru, &
1612 & line=__line__, &
1613 & file=myfile)) THEN
1614 RETURN
1615 END IF
1616!
1617 END IF querry
1618!
1619!-----------------------------------------------------------------------
1620! Debugging: report exchanged fields.
1621!-----------------------------------------------------------------------
1622!
1623 IF ((debuglevel.gt.0).and.(localpet.eq.0)) THEN
1624 WRITE (cplout,20) &
1625 trim(cplsetlist(ic)), trim(cname), &
1626 & trim(models(isrc)%ExportField(idsrc)%short_name), &
1627 & trim(gridtype(models(isrc)%ExportField(idsrc)%gtype)), &
1628 & trim(models(idst)%ImportField(iddst)%short_name), &
1629 & trim(gridtype(models(idst)%ImportField(iddst)%gtype)), &
1630 & trim(intrptype(models(isrc)%ExportField(idsrc)%itype))
1631 END IF
1632!
1633!-----------------------------------------------------------------------
1634! Debugging: print out import/export fields time stamp information.
1635!-----------------------------------------------------------------------
1636!
1637 IF (debuglevel.gt.2) THEN
1638 CALL nuopc_gettimestamp (srcfield, &
1639 & isvalid = isvalid, &
1640 & time = srctime, &
1641 & rc = rc)
1642 IF (esmf_logfounderror(rctocheck=rc, &
1643 & msg=esmf_logerr_passthru, &
1644 & line=__line__, &
1645 & file=myfile)) THEN
1646 RETURN
1647 END IF
1648!
1649 IF (isvalid) THEN
1650 CALL esmf_timeget (srctime, &
1651 & timestringisofrac = srctimestring, &
1652 & rc=rc)
1653 IF (esmf_logfounderror(rctocheck=rc, &
1654 & msg=esmf_logerr_passthru, &
1655 & line=__line__, &
1656 & file=myfile)) THEN
1657 RETURN
1658 END IF
1659 is=index(srctimestring, 'T') ! remove 'T'
1660 IF (is.gt.0) srctimestring(is:is)=' '
1661 srcfilestring=srctimestring(1:19)
1662 ELSE
1663 srcfilestring='0000-00-00 00:00:00'
1664 END IF
1665 srcfilestring(11:11)='_'
1666 srcfilestring(14:14)='.'
1667 srcfilestring(17:17)='.'
1668!
1669 CALL nuopc_gettimestamp (dstfield, &
1670 & isvalid = isvalid, &
1671 & time = dsttime, &
1672 & rc = rc)
1673 IF (esmf_logfounderror(rctocheck=rc, &
1674 & msg=esmf_logerr_passthru, &
1675 & line=__line__, &
1676 & file=myfile)) THEN
1677 RETURN
1678 END IF
1679!
1680 IF (isvalid) THEN
1681 CALL esmf_timeget (dsttime, &
1682 & timestringisofrac = dsttimestring, &
1683 & rc=rc)
1684 IF (esmf_logfounderror(rctocheck=rc, &
1685 & msg=esmf_logerr_passthru, &
1686 & line=__line__, &
1687 & file=myfile)) THEN
1688 RETURN
1689 END IF
1690 is=index(dsttimestring, 'T') ! remove 'T'
1691 IF (is.gt.0) dsttimestring(is:is)=' '
1692 dstfilestring=dsttimestring(1:19)
1693 ELSE
1694 dstfilestring='0000-00-00 00:00:00'
1695 END IF
1696 dstfilestring(11:11)='_'
1697 dstfilestring(14:14)='.'
1698 dstfilestring(17:17)='.'
1699!
1700 IF (localpet.eq.0) THEN
1701 WRITE (cplout,30) trim(srctimestring), &
1702 & trim(dsttimestring), &
1703 & trim(models(isrc)%ExportField(idsrc)%short_name), &
1704 & trim(models(idst)%ImportField(iddst)%short_name)
1705 END IF
1706 END IF
1707!
1708!-----------------------------------------------------------------------
1709! Debugging: write data into NetCDF file. It uses the source field
1710! time stamp in both source and destination NetCDF files for easy
1711! matching of files. Usually, the time stamps between source and
1712! destination fields is different.
1713!-----------------------------------------------------------------------
1714!
1715 IF ((debuglevel.ge.3).and. &
1716 & models(isrc)%ExportField(idsrc)%debug_write) THEN
1717 WRITE (srcfile,40) 'src_'//trim(srclist(i))//'_'// &
1718 & trim(cplsetlist(ic))//'_'// &
1719 & trim(lowercase(cname)), &
1720 & trim(srcfilestring)
1721 CALL esmf_fieldwrite (srcfield, &
1722 & trim(srcfile), &
1723 & variablename=trim(srclist(i)), &
1724 & overwrite=.true., &
1725 & rc=rc)
1726 IF (esmf_logfounderror(rctocheck=rc, &
1727 & msg=esmf_logerr_passthru, &
1728 & line=__line__, &
1729 & file=myfile)) THEN
1730 RETURN
1731 END IF
1732 END IF
1733!
1734 IF ((debuglevel.ge.3).and. &
1735 & models(idst)%ImportField(iddst)%debug_write) THEN
1736 WRITE (dstfile,40) 'dst_'//trim(dstlist(i))//'_'// &
1737 & trim(cplsetlist(ic))//'_'// &
1738 & trim(lowercase(cname)), &
1739 & trim(srcfilestring)
1740 CALL esmf_fieldwrite (dstfield, &
1741 & trim(dstfile), &
1742 & variablename=trim(dstlist(i)), &
1743 & overwrite=.true., &
1744 & rc=rc)
1745 IF (esmf_logfounderror(rctocheck=rc, &
1746 & msg=esmf_logerr_passthru, &
1747 & line=__line__, &
1748 & file=myfile)) THEN
1749 RETURN
1750 END IF
1751 END IF
1752!
1753 END DO exchange
1754!
1755!-----------------------------------------------------------------------
1756! Deallocate temporary arrays
1757!-----------------------------------------------------------------------
1758!
1759 deallocate (srclist)
1760 deallocate (dstlist)
1761 END DO cplset_loop
1762!
1763 IF (esm_track) THEN
1764 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_ExecuteRH for ' &
1765 & // trim(cname), ', PET', petrank
1766 FLUSH (trac)
1767 END IF
1768 IF (debuglevel.gt.0) FLUSH (cplout)
1769!
1770 10 FORMAT (3x,'ESMF Coupler - PET(',i3.3,') - ',a,' = ',e14.5, &
1771 & ' (',a,')')
1772 20 FORMAT (3x,'ESMF Coupler - ',a,', ',a,': Regridded ',a, &
1773 & ' [',a,'] to ',a,' [',a,']',' >> ',a)
1774 30 FORMAT (18x,'(SRC TimeStamp = ',a,', DST TimeStamp = ',a,')', &
1775 & 2x,a,' to ',a)
1776 40 FORMAT (a,'_',a,'.nc')
1777!
1778 RETURN
1779 END SUBROUTINE coupler_executerh
1780!
1781 SUBROUTINE coupler_releaserh (coupler, rc)
1782!
1783!=======================================================================
1784! !
1785! Releases coupler RouteHandle connectors between source (srcFields) !
1786! and destination (dstFields) fields. !
1787! !
1788!=======================================================================
1789!
1790! Imported variable declarations.
1791!
1792 integer, intent(out) :: rc
1793!
1794 TYPE (esmf_cplcomp) :: coupler
1795!
1796! Local variable declarations.
1797!
1798 logical :: rhexist, rh1exist, rh2exist
1799!
1800 integer :: i, ic, j, localpet, petcount, mycomm
1801 integer :: itemcount, srccount, dstcount, ncplsets
1802 integer :: isrc, idst, idsrc, iddst, grsrc, grdst
1803 integer :: etsrc, etdst, itsrc, itdst
1804!
1805 character (len=*), parameter :: myfile = &
1806 & __FILE__//", Coupler_ReleaseRH"
1807
1808 character(ESMF_MAXSTR) :: cname, rname
1809
1810 character (ESMF_MAXSTR), pointer :: cplsetlist(:) => null()
1811 character (ESMF_MAXSTR), pointer :: dstlist(:) => null()
1812 character (ESMF_MAXSTR), pointer :: srclist(:) => null()
1813!
1814 TYPE (esmf_vm) :: vm
1815 TYPE (esmf_state) :: state
1816 TYPE (esmf_fieldbundle) :: srcfields, dstfields
1817 TYPE (esmf_routehandle) :: routehandle
1818!
1819!-----------------------------------------------------------------------
1820! Initialize return code flag to success state (no error).
1821!-----------------------------------------------------------------------
1822!
1823 IF (esm_track) THEN
1824 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_ReleaseRH', &
1825 & ', PET', petrank
1826 FLUSH (trac)
1827 END IF
1828 rc=esmf_success
1829!
1830!-----------------------------------------------------------------------
1831! Query coupler component.
1832!-----------------------------------------------------------------------
1833!
1834! Querry the coupler for the Virtual Machine (VM) parallel environmemt.
1835!
1836 CALL esmf_cplcompget (coupler, &
1837 & name=cname, &
1838 & vm=vm, &
1839 & rc=rc)
1840 IF (esmf_logfounderror(rctocheck=rc, &
1841 & msg=esmf_logerr_passthru, &
1842 & line=__line__, &
1843 & file=myfile)) THEN
1844 RETURN
1845 END IF
1846!
1847! Get current parallel node rank and number of nodes.
1848!
1849 CALL esmf_vmget (vm, &
1850 & localpet=localpet, &
1851 & petcount=petcount, &
1852 & mpicommunicator=mycomm, &
1853 & rc=rc)
1854 IF (esmf_logfounderror(rctocheck=rc, &
1855 & msg=esmf_logerr_passthru, &
1856 & line=__line__, &
1857 & file=myfile)) THEN
1858 RETURN
1859 END IF
1860!
1861! Set source and destination couple model indices.
1862!
1863 DO i=1,nmodels
1864 DO j=1,nmodels
1865 IF ((connectors(i,j)%IsActive).and. &
1866 & (trim(connectors(i,j)%name).eq.trim(cname))) THEN
1867 isrc=i
1868 idst=j
1869 END if
1870 END DO
1871 END DO
1872!
1873!-----------------------------------------------------------------------
1874! Get coupled set list for connector (Cname).
1875!-----------------------------------------------------------------------
1876!
1877 IF ( associated(cplsetlist) ) nullify (cplsetlist)
1878 CALL nuopc_connectorget (coupler, &
1879 & cplsetlist=cplsetlist, &
1880 & rc=rc)
1881 IF (esmf_logfounderror(rctocheck=rc, &
1882 & msg=esmf_logerr_passthru, &
1883 & line=__line__, &
1884 & file=myfile)) THEN
1885 RETURN
1886 END IF
1887 ncplsets=SIZE(cplsetlist)
1888!
1889!-----------------------------------------------------------------------
1890! Inquire about source and destination fields.
1891!-----------------------------------------------------------------------
1892!
1893 cplset_loop : DO ic=1,ncplsets
1894!
1895! Get source and destination fields for each coupled set.
1896!
1897 CALL nuopc_connectorget (coupler, &
1898 & srcfields=srcfields, &
1899 & dstfields=dstfields, &
1900 & state=state, &
1901 & cplset=cplsetlist(ic), &
1902 & rc=rc)
1903 IF (esmf_logfounderror(rctocheck=rc, &
1904 & msg=esmf_logerr_passthru, &
1905 & line=__line__, &
1906 & file=myfile)) THEN
1907 RETURN
1908 END IF
1909!
1910! Number of source fields.
1911!
1912 CALL esmf_fieldbundleget (srcfields, &
1913 & fieldcount=srccount, &
1914 & rc=rc)
1915 IF (esmf_logfounderror(rctocheck=rc, &
1916 & msg=esmf_logerr_passthru, &
1917 & line=__line__, &
1918 & file=myfile)) THEN
1919 RETURN
1920 END IF
1921!
1922! Number of destination fields.
1923!
1924 CALL esmf_fieldbundleget (dstfields, &
1925 & fieldcount=dstcount, &
1926 & rc=rc)
1927 IF (esmf_logfounderror(rctocheck=rc, &
1928 & msg=esmf_logerr_passthru, &
1929 & line=__line__, &
1930 & file=myfile)) THEN
1931 RETURN
1932 END IF
1933!
1934! Source fields names.
1935!
1936 allocate ( srclist(srccount) )
1937
1938 CALL esmf_fieldbundleget (srcfields, &
1939 & fieldnamelist=srclist, &
1940 & rc=rc)
1941 IF (esmf_logfounderror(rctocheck=rc, &
1942 & msg=esmf_logerr_passthru, &
1943 & line=__line__, &
1944 & file=myfile)) THEN
1945 RETURN
1946 END IF
1947!
1948! Destination fields names.
1949!
1950 allocate ( dstlist(dstcount) )
1951
1952 CALL esmf_fieldbundleget (dstfields, &
1953 & fieldnamelist=dstlist, &
1954 & rc=rc)
1955 IF (esmf_logfounderror(rctocheck=rc, &
1956 & msg=esmf_logerr_passthru, &
1957 & line=__line__, &
1958 & file=myfile)) THEN
1959 RETURN
1960 END IF
1961!
1962!=======================================================================
1963! Release coupling connector RouteHandle between source and destination
1964! fields.
1965!=======================================================================
1966!
1967 exchange : DO i=1,srccount
1968!
1969! Set source and destination field index.
1970!
1971 idsrc=field_index(models(isrc)%ExportField, srclist(i))
1972 iddst=field_index(models(idst)%ImportField, dstlist(i))
1973!
1974! Set interpolation type.
1975!
1976 itsrc=models(isrc)%ExportField(idsrc)%itype
1977 itdst=models(idst)%ImportField(iddst)%itype
1978!
1979! Get extrapolation method for unmapped destination points.
1980!
1981 etsrc=models(isrc)%ExportField(idsrc)%etype
1982 etdst=models(idst)%ImportField(iddst)%etype
1983!
1984! Set grid type.
1985!
1986 grsrc=models(isrc)%ExportField(idsrc)%gtype
1987 grdst=models(idst)%ImportField(iddst)%gtype
1988!
1989!-----------------------------------------------------------------------
1990! Release RouteHandle for REGRID with two-steps extrapolation.
1991!-----------------------------------------------------------------------
1992!
1993 querry : IF (etsrc.eq.e2steps) THEN
1994!
1995! Check 1st RouteHandle (i.e. rh_Center_Corner_BLIN_ATM-OCN).
1996!
1997 IF (isrc.eq.idata) THEN
1998 rname='rh_'//trim(srclist(i))//'_'// &
1999 & trim(gridtype(grsrc ))//'_'// &
2000 & trim(gridtype(grdst ))//'_'// &
2001 & trim(intrptype(ibilin))//'_'// &
2002 & trim(extrptype(etsrc ))//'_'// &
2003 & trim(cplsetlist(ic))//'_'// &
2004 & trim(cname)
2005 ELSE
2006 rname='rh_'// &
2007 & trim(gridtype(grsrc ))//'_'// &
2008 & trim(gridtype(grdst ))//'_'// &
2009 & trim(intrptype(ibilin))//'_'// &
2010 & trim(extrptype(etsrc ))//'_'// &
2011 & trim(cplsetlist(ic))//'_'// &
2012 & trim(cname)
2013 END IF
2014!
2015 CALL esmf_stateget (state, &
2016 & itemsearch=trim(rname), &
2017 & itemcount=itemcount, &
2018 & rc=rc)
2019 IF (esmf_logfounderror(rctocheck=rc, &
2020 & msg=esmf_logerr_passthru, &
2021 & line=__line__, &
2022 & file=myfile)) THEN
2023 RETURN
2024 END IF
2025!
2026 IF (itemcount.le.0) THEN
2027 rh1exist=.false.
2028 ELSE
2029 rh1exist=.true.
2030 END IF
2031!
2032! Release 1st RouteHandle.
2033!
2034 IF (rh1exist) THEN
2035 CALL esmf_stateget (state, &
2036 & trim(rname), &
2037 & routehandle, &
2038 & rc=rc)
2039 IF (esmf_logfounderror(rctocheck=rc, &
2040 & msg=esmf_logerr_passthru, &
2041 & line=__line__, &
2042 & file=myfile)) THEN
2043 RETURN
2044 END IF
2045!
2046 CALL esmf_fieldbundleregridrelease (routehandle, &
2047 & rc=rc)
2048 IF (esmf_logfounderror(rctocheck=rc, &
2049 & msg=esmf_logerr_passthru, &
2050 & line=__line__, &
2051 & file=myfile)) THEN
2052 RETURN
2053 END IF
2054 END IF
2055!
2056! Check 2nd RouteHandle (i.e. rh_Center_Corner_NS2D_ATM-OCN).
2057!
2058 IF (isrc.eq.idata) THEN
2059 rname='rh_'//trim(srclist(i))//'_'// &
2060 & trim(gridtype(grsrc ))//'_'// &
2061 & trim(gridtype(grdst ))//'_'// &
2062 & trim(intrptype(instod))//'_'// &
2063 & trim(extrptype(etsrc ))//'_'// &
2064 & trim(cplsetlist(ic))//'_'// &
2065 & trim(cname)
2066 ELSE
2067 rname='rh_'// &
2068 & trim(gridtype(grsrc ))//'_'// &
2069 & trim(gridtype(grdst ))//'_'// &
2070 & trim(intrptype(instod))//'_'// &
2071 & trim(extrptype(etsrc ))//'_'// &
2072 & trim(cplsetlist(ic))//'_'// &
2073 & trim(cname)
2074 END IF
2075!
2076 CALL esmf_stateget (state, &
2077 & itemsearch=trim(rname), &
2078 & itemcount=itemcount, &
2079 & rc=rc)
2080 IF (esmf_logfounderror(rctocheck=rc, &
2081 & msg=esmf_logerr_passthru, &
2082 & line=__line__, &
2083 & file=myfile)) THEN
2084 RETURN
2085 END IF
2086!
2087 IF (itemcount.le.0) THEN
2088 rh2exist=.false.
2089 ELSE
2090 rh2exist=.true.
2091 END IF
2092!
2093! Release 2nd RouteHandle.
2094!
2095 IF (rh2exist) THEN
2096 CALL esmf_stateget (state, &
2097 & trim(rname), &
2098 & routehandle, &
2099 & rc=rc)
2100 IF (esmf_logfounderror(rctocheck=rc, &
2101 & msg=esmf_logerr_passthru, &
2102 & line=__line__, &
2103 & file=myfile)) THEN
2104 RETURN
2105 END IF
2106!
2107 CALL esmf_fieldbundleregridrelease (routehandle, &
2108 & rc=rc)
2109 IF (esmf_logfounderror(rctocheck=rc, &
2110 & msg=esmf_logerr_passthru, &
2111 & line=__line__, &
2112 & file=myfile)) THEN
2113 RETURN
2114 END IF
2115 END IF
2116!
2117!-----------------------------------------------------------------------
2118! Release RouteHandle for REGRID without extrapolation support.
2119!-----------------------------------------------------------------------
2120!
2121 ELSE
2122!
2123! Check RouteHandle for one step interpolation.
2124!
2125 IF (isrc.eq.idata) THEN
2126 rname='rh_'//trim(srclist(i))//'_'// &
2127 & trim(gridtype(grsrc))//'_'// &
2128 & trim(gridtype(grdst))//'_'// &
2129 & trim(intrptype(itsrc))//'_'// &
2130 & trim(extrptype(etsrc))//'_'// &
2131 & trim(cplsetlist(ic))//'_'// &
2132 & trim(cname)
2133 ELSE
2134 rname='rh_'// &
2135 & trim(gridtype(grsrc))//'_'// &
2136 & trim(gridtype(grdst))//'_'// &
2137 & trim(intrptype(itsrc))//'_'// &
2138 & trim(extrptype(etsrc))//'_'// &
2139 & trim(cplsetlist(ic))//'_'// &
2140 & trim(cname)
2141 END IF
2142!
2143 CALL esmf_stateget (state, &
2144 & itemsearch=trim(rname), &
2145 & itemcount=itemcount, &
2146 & rc=rc)
2147 IF (esmf_logfounderror(rctocheck=rc, &
2148 & msg=esmf_logerr_passthru, &
2149 & line=__line__, &
2150 & file=myfile)) THEN
2151 RETURN
2152 END IF
2153!
2154 IF (itemcount.le.0) THEN
2155 rhexist=.false.
2156 ELSE
2157 rhexist=.true.
2158 END IF
2159!
2160! Release RouteHandle.
2161!
2162 IF (rhexist) THEN
2163 CALL esmf_stateget (state, &
2164 & trim(rname), &
2165 & routehandle, &
2166 & rc=rc)
2167 IF (esmf_logfounderror(rctocheck=rc, &
2168 & msg=esmf_logerr_passthru, &
2169 & line=__line__, &
2170 & file=myfile)) THEN
2171 RETURN
2172 END IF
2173!
2174 CALL esmf_fieldbundleregridrelease (routehandle, &
2175 & rc=rc)
2176 IF (esmf_logfounderror(rctocheck=rc, &
2177 & msg=esmf_logerr_passthru, &
2178 & line=__line__, &
2179 & file=myfile)) THEN
2180 RETURN
2181 END IF
2182 END IF
2183!
2184 END IF querry
2185 END DO exchange
2186 END DO cplset_loop
2187!
2188 IF (esm_track) THEN
2189 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_ReleaseRH', &
2190 & ', PET', petrank
2191 FLUSH (trac)
2192 END IF
2193!
2194 RETURN
2195 END SUBROUTINE coupler_releaserh
2196!
2197 SUBROUTINE coupler_adjustfield (vm, field, maskval, error, rc)
2198!
2199!=======================================================================
2200! !
2201! Adjusts regrid field to ensure global area integral conservation !
2202! over the matched regions. The destination field is adjusted using !
2203! the global error of the area integrated difference between !
2204! destination and source field over the matched regions: !
2205! !
2206! field = field - error/Area !
2207! !
2208! where !
2209! !
2210! error = SumDstArea - SumSrcArea !
2211! !
2212!=======================================================================
2213!
2214! Imported variable declarations.
2215!
2216 integer (i4b), intent(in) :: maskval(:)
2217 integer, intent(out) :: rc
2218!
2219 real (dp), intent(in) :: error
2220!
2221 TYPE (esmf_vm), intent(in) :: vm
2222 TYPE (esmf_field), intent(inout) :: field
2223!
2224! Local variable declarations.
2225!
2226 integer :: i, j
2227 integer :: localde, localdecount, localpet, petcount, mycomm
2228 integer :: clbnd(2), cubnd(2)
2229!
2230 integer (i4b), pointer :: ptrmask(:,:) => null()
2231!
2232 real (dp) :: myareasum(1), areasum(1)
2233 real (dp) :: error_unit
2234!
2235 real (dp), pointer :: ptrfield(:,:) => null()
2236 real (dp), pointer :: ptrarea(:,:) => null()
2237!
2238 character (len=*), parameter :: myfile = &
2239 & __FILE__//", Coupler_AdjustedField"
2240
2241 character(ESMF_MAXSTR) :: fname
2242!
2243 TYPE (esmf_grid) :: grid
2244 TYPE (esmf_staggerloc) :: sloc
2245!
2246!-----------------------------------------------------------------------
2247! Initialize.
2248!-----------------------------------------------------------------------
2249!
2250! Set return code flag to success state (no error).
2251!
2252 IF (esm_track) THEN
2253 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_AdjustField', &
2254 & ', PET', petrank
2255 FLUSH (trac)
2256 END IF
2257 rc=esmf_success
2258!
2259! Integral.
2260!
2261 myareasum(1)=0.0_dp
2262!
2263!-----------------------------------------------------------------------
2264! Querry the Virtual Machine (VM) parallel environmemt for the mpi
2265! communicator handle and current node rank.
2266!-----------------------------------------------------------------------
2267!
2268 CALL esmf_vmget (vm, &
2269 & localpet=localpet, &
2270 & petcount=petcount, &
2271 & mpicommunicator=mycomm, &
2272 & rc=rc)
2273 IF (esmf_logfounderror(rctocheck=rc, &
2274 & msg=esmf_logerr_passthru, &
2275 & line=__line__, &
2276 & file=myfile)) THEN
2277 RETURN
2278 END IF
2279!
2280!-----------------------------------------------------------------------
2281! Query input field.
2282!-----------------------------------------------------------------------
2283!
2284 CALL esmf_fieldget (field, &
2285 & grid=grid, &
2286 & name=fname, &
2287 & staggerloc=sloc, &
2288 & rc=rc)
2289 IF (esmf_logfounderror(rctocheck=rc, &
2290 & msg=esmf_logerr_passthru, &
2291 & line=__line__, &
2292 & file=myfile)) THEN
2293 RETURN
2294 END IF
2295!
2296! Get number of local decomposition elements (DEs) in the grid.
2297!
2298 CALL esmf_gridget (grid, &
2299 & localdecount=localdecount, &
2300 & rc=rc)
2301 IF (esmf_logfounderror(rctocheck=rc, &
2302 & msg=esmf_logerr_passthru, &
2303 & line=__line__, &
2304 & file=myfile)) THEN
2305 RETURN
2306 END IF
2307!
2308! Get field pointer.
2309!
2310 de_loop1 : DO localde=0,localdecount-1
2311 CALL esmf_fieldget (field, &
2312 & localde=localde, &
2313 & farrayptr=ptrfield, &
2314 & computationallbound=clbnd, &
2315 & computationalubound=cubnd, &
2316 & rc=rc)
2317 IF (esmf_logfounderror(rctocheck=rc, &
2318 & msg=esmf_logerr_passthru, &
2319 & line=__line__, &
2320 & file=myfile)) THEN
2321 RETURN
2322 END IF
2323!
2324! Get area pointer from grid.
2325!
2326 CALL esmf_gridgetitem (grid, &
2327 & esmf_griditem_area, &
2328 & staggerloc=sloc, &
2329 & localde=localde, &
2330 & farrayptr=ptrarea, &
2331 & rc=rc)
2332 IF (esmf_logfounderror(rctocheck=rc, &
2333 & msg=esmf_logerr_passthru, &
2334 & line=__line__, &
2335 & file=myfile)) THEN
2336 RETURN
2337 END IF
2338!
2339! Get mask pointer from grid.
2340!
2341 CALL esmf_gridgetitem (grid, &
2342 & esmf_griditem_mask, &
2343 & staggerloc=sloc, &
2344 & localde=localde, &
2345 & farrayptr=ptrmask, &
2346 & rc=rc)
2347 IF (esmf_logfounderror(rctocheck=rc, &
2348 & msg=esmf_logerr_passthru, &
2349 & line=__line__, &
2350 & file=myfile)) THEN
2351 RETURN
2352 END IF
2353!
2354!-----------------------------------------------------------------------
2355! Calculate total area of matched region
2356!-----------------------------------------------------------------------
2357!
2358 clbnd(1)=lbound(ptrmask, dim=1)
2359 cubnd(1)=ubound(ptrmask, dim=1)
2360 clbnd(2)=lbound(ptrmask, dim=2)
2361 cubnd(2)=ubound(ptrmask, dim=2)
2362!
2363 DO j=clbnd(2),cubnd(2)
2364 DO i=clbnd(1),cubnd(1)
2365 IF (any(ptrmask(i,j).eq.maskval)) THEN
2366 myareasum(1)=myareasum(1)+ptrarea(i,j)
2367 END IF
2368 END DO
2369 END DO
2370!
2371!-----------------------------------------------------------------------
2372! Nullify pointer to make sure that it does not point on a random
2373! part in the memory.
2374!-----------------------------------------------------------------------
2375!
2376 IF (associated(ptrarea)) THEN
2377 nullify (ptrarea)
2378 END IF
2379 IF (associated(ptrmask)) THEN
2380 nullify (ptrmask)
2381 END IF
2382 END DO de_loop1
2383!
2384!-----------------------------------------------------------------------
2385! Collect calculated total area from PETs
2386!-----------------------------------------------------------------------
2387!
2388 areasum(1)=0.0_dp
2389 CALL esmf_vmallreduce (vm, &
2390 & myareasum, &
2391 & areasum, 1, &
2392 & esmf_reduce_sum, &
2393 & rc=rc)
2394 IF (esmf_logfounderror(rctocheck=rc, &
2395 & msg=esmf_logerr_passthru, &
2396 & line=__line__, &
2397 & file=myfile)) THEN
2398 RETURN
2399 END IF
2400!
2401!-----------------------------------------------------------------------
2402! Calculate error per unit area.
2403!-----------------------------------------------------------------------
2404!
2405 error_unit=error/areasum(1)
2406 IF (localpet.eq.0) THEN
2407 WRITE (cplout,10) localpet, areasum(1), error_unit, trim(fname)
2408 10 FORMAT (' PET(',i3.3,') - AVGERAGE DIFF = ',2e14.5,' (',a,')')
2409 END IF
2410!
2411!-----------------------------------------------------------------------
2412! Adjust field using the global error of the area integrated
2413! difference between source and destination field.
2414!-----------------------------------------------------------------------
2415!
2416 de_loop2 : DO localde=0,localdecount-1
2417!
2418! Get field pointers
2419!
2420 CALL esmf_fieldget (field, &
2421 & localde=localde, &
2422 & farrayptr=ptrfield, &
2423 & computationallbound=clbnd, &
2424 & computationalubound=cubnd, &
2425 & rc=rc)
2426 IF (esmf_logfounderror(rctocheck=rc, &
2427 & msg=esmf_logerr_passthru, &
2428 & line=__line__, &
2429 & file=myfile)) THEN
2430 RETURN
2431 END IF
2432!
2433! Get mask pointer from grid.
2434!
2435 CALL esmf_gridgetitem (grid, &
2436 & esmf_griditem_mask, &
2437 & staggerloc=sloc, &
2438 & localde=localde, &
2439 & farrayptr=ptrmask, &
2440 & rc=rc)
2441 IF (esmf_logfounderror(rctocheck=rc, &
2442 & msg=esmf_logerr_passthru, &
2443 & line=__line__, &
2444 & file=myfile)) THEN
2445 RETURN
2446 END IF
2447!
2448! Adjust input destination field.
2449!
2450 DO j=clbnd(2),cubnd(2)
2451 DO i=clbnd(1),cubnd(1)
2452 IF (any(ptrmask(i,j).eq.maskval)) THEN
2453 ptrfield(i,j)=ptrfield(i,j)-error_unit
2454 END IF
2455 END DO
2456 END DO
2457!
2458!-----------------------------------------------------------------------
2459! Nullify pointer to make sure that it does not point on a random
2460! part in the memory.
2461!-----------------------------------------------------------------------
2462!
2463 IF (associated(ptrfield)) THEN
2464 nullify (ptrfield)
2465 END IF
2466 IF (associated(ptrmask)) THEN
2467 nullify (ptrmask)
2468 END IF
2469 END DO de_loop2
2470!
2471 IF (esm_track) THEN
2472 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_AdjustField', &
2473 & ', PET', petrank
2474 FLUSH (trac)
2475 END IF
2476!
2477 RETURN
2478 END SUBROUTINE coupler_adjustfield
2479!
2480 FUNCTION coupler_areaintegral (vm, field, maskval, rc)
2481!
2482!=======================================================================
2483! !
2484! Computes source or destination field global area integral over the !
2485! matched regions (cells having the specified mask values, maskval). !
2486! !
2487!=======================================================================
2488!
2489! Imported variable declarations.
2490!
2491 integer (i4b), intent(in) :: maskval(:)
2492 integer, intent(out) :: rc
2493!
2494 real (dp) :: coupler_areaintegral
2495!
2496 TYPE (esmf_field), intent(in) :: field
2497 TYPE (esmf_vm), intent(in) :: vm
2498!
2499! Local variable declarations.
2500!
2501 integer :: i, j
2502 integer :: localde, localdecount, localpet, petcount, mycomm
2503 integer :: clbnd(2), cubnd(2)
2504!
2505 integer (i4b), pointer :: ptrmask(:,:) => null()
2506!
2507 real (dp) :: myareasum(1), areasum(1)
2508!
2509 real (dp), pointer :: ptrfield(:,:) => null()
2510 real (dp), pointer :: ptrarea(:,:) => null()
2511!
2512 character (len=*), parameter :: myfile = &
2513 & __FILE__//", Coupler_AreaIntegral"
2514
2515 character (ESMF_MAXSTR) :: fname
2516!
2517 TYPE (esmf_grid) :: grid
2518 TYPE (esmf_staggerloc) :: sloc
2519!
2520!-----------------------------------------------------------------------
2521! Initialize.
2522!-----------------------------------------------------------------------
2523!
2524! Set return code flag to success state (no error).
2525!
2526 IF (esm_track) THEN
2527 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_AreaIntegral', &
2528 & ', PET', petrank
2529 FLUSH (trac)
2530 END IF
2531 rc=esmf_success
2532!
2533! Integral.
2534!
2535 coupler_areaintegral=0.0_dp
2536 myareasum(1)=0.0_dp
2537!
2538!-----------------------------------------------------------------------
2539! Querry the Virtual Machine (VM) parallel environmemt for the mpi
2540! communicator handle and current node rank.
2541!-----------------------------------------------------------------------
2542!
2543 CALL esmf_vmget (vm, &
2544 & localpet=localpet, &
2545 & petcount=petcount, &
2546 & mpicommunicator=mycomm, &
2547 & rc=rc)
2548 IF (esmf_logfounderror(rctocheck=rc, &
2549 & msg=esmf_logerr_passthru, &
2550 & line=__line__, &
2551 & file=myfile)) THEN
2552 RETURN
2553 END IF
2554!
2555!-----------------------------------------------------------------------
2556! Query input field.
2557!-----------------------------------------------------------------------
2558!
2559 CALL esmf_fieldget (field, &
2560 & grid=grid, &
2561 & name=fname, &
2562 & staggerloc=sloc, &
2563 & rc=rc)
2564 IF (esmf_logfounderror(rctocheck=rc, &
2565 & msg=esmf_logerr_passthru, &
2566 & line=__line__, &
2567 & file=myfile)) THEN
2568 RETURN
2569 END IF
2570!
2571! Get number of local decomposition elements (DEs) in the grid.
2572!
2573 CALL esmf_gridget (grid, &
2574 & localdecount=localdecount, &
2575 & rc=rc)
2576 IF (esmf_logfounderror(rctocheck=rc, &
2577 & msg=esmf_logerr_passthru, &
2578 & line=__line__, &
2579 & file=myfile)) THEN
2580 RETURN
2581 END IF
2582!
2583! Get field pointer.
2584!
2585 de_loop : DO localde=0,localdecount-1
2586 CALL esmf_fieldget (field, &
2587 & localde=localde, &
2588 & farrayptr=ptrfield, &
2589 & computationallbound=clbnd, &
2590 & computationalubound=cubnd, &
2591 & rc=rc)
2592 IF (esmf_logfounderror(rctocheck=rc, &
2593 & msg=esmf_logerr_passthru, &
2594 & line=__line__, &
2595 & file=myfile)) THEN
2596 RETURN
2597 END IF
2598!
2599! Get area pointer from grid.
2600!
2601 CALL esmf_gridgetitem (grid, &
2602 & esmf_griditem_area, &
2603 & staggerloc=sloc, &
2604 & localde=localde, &
2605 & farrayptr=ptrarea, &
2606 & rc=rc)
2607 IF (esmf_logfounderror(rctocheck=rc, &
2608 & msg=esmf_logerr_passthru, &
2609 & line=__line__, &
2610 & file=myfile)) THEN
2611 RETURN
2612 END IF
2613!
2614! Get mask pointer from grid.
2615!
2616 CALL esmf_gridgetitem (grid, &
2617 & esmf_griditem_mask, &
2618 & staggerloc=sloc, &
2619 & localde=localde, &
2620 & farrayptr=ptrmask, &
2621 & rc=rc)
2622 IF (esmf_logfounderror(rctocheck=rc, &
2623 & msg=esmf_logerr_passthru, &
2624 & line=__line__, &
2625 & file=myfile)) THEN
2626 RETURN
2627 END IF
2628!
2629!-----------------------------------------------------------------------
2630! Calculate field area integral for each local DE and PET.
2631!-----------------------------------------------------------------------
2632!
2633 DO j=clbnd(2),cubnd(2)
2634 DO i=clbnd(1),cubnd(1)
2635 IF (any(ptrmask(i,j).eq.maskval)) THEN
2636 myareasum(1)=myareasum(1)+ptrfield(i,j)*ptrarea(i,j)
2637 END IF
2638 END DO
2639 END DO
2640!
2641!-----------------------------------------------------------------------
2642! Nullify pointer to make sure that it does not point on a random
2643! part in the memory.
2644!-----------------------------------------------------------------------
2645!
2646 IF (associated(ptrfield)) THEN
2647 nullify (ptrfield)
2648 END IF
2649 IF (associated(ptrarea)) THEN
2650 nullify (ptrarea)
2651 END IF
2652 IF (associated(ptrmask)) THEN
2653 nullify (ptrmask)
2654 END IF
2655 END DO de_loop
2656!
2657!-----------------------------------------------------------------------
2658! Debugging: write sum of each PETs
2659!-----------------------------------------------------------------------
2660!
2661 IF (debuglevel.gt.2) THEN
2662 WRITE (cplout,10) localpet, localde, myareasum(1), trim(fname)
2663 10 FORMAT (' PET(',i3.3,') - DE(',i2.2,') - Area Integral = ', &
2664 & e14.5,' (',a,')')
2665 CALL esmf_vmbarrier (vm, rc=rc)
2666 IF (esmf_logfounderror(rctocheck=rc, &
2667 & msg=esmf_logerr_passthru, &
2668 & line=__line__, &
2669 & file=myfile)) THEN
2670 RETURN
2671 END IF
2672 END IF
2673!
2674!-----------------------------------------------------------------------
2675! Collect fiels area integral from each PET and calculate global value.
2676!-----------------------------------------------------------------------
2677!
2678 CALL esmf_vmallreduce (vm, &
2679 & myareasum, areasum, 1, &
2680 & esmf_reduce_sum, &
2681 & rc=rc)
2682 IF (esmf_logfounderror(rctocheck=rc, &
2683 & msg=esmf_logerr_passthru, &
2684 & line=__line__, &
2685 & file=myfile)) THEN
2686 RETURN
2687 END IF
2688!
2689 coupler_areaintegral=areasum(1)
2690!
2691!-----------------------------------------------------------------------
2692! Debugging: report global area integral.
2693!-----------------------------------------------------------------------
2694!
2695 IF (debuglevel.eq.1) THEN
2696 IF (localpet.eq.0) THEN
2697 WRITE (cplout,20) localpet, areasum(1), trim(fname)
2698 20 FORMAT (' PET(',i3.3,') - Global Area Integral = ',e14.5, &
2699 & ' (',a,')')
2700 END IF
2701 CALL esmf_vmbarrier (vm, rc=rc)
2702 IF (esmf_logfounderror(rctocheck=rc, &
2703 & msg=esmf_logerr_passthru, &
2704 & line=__line__, &
2705 & file=myfile)) THEN
2706 RETURN
2707 END IF
2708 END IF
2709!
2710 IF (esm_track) THEN
2711 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_AreaIntegral', &
2712 & ', PET', petrank
2713 FLUSH (trac)
2714 END IF
2715 IF (debuglevel.gt.0) FLUSH (cplout)
2716!
2717 RETURN
2718 END FUNCTION coupler_areaintegral
2719!
2720 FUNCTION coupler_fieldcreate (field, Fname, IniVal, dstLandMask, &
2721 & rc)
2722!
2723!=======================================================================
2724! !
2725! Creates and initializes a new field using input field attributes. !
2726! Masked grid cells are set to missing value (MISSING_dp). !
2727! !
2728!=======================================================================
2729!
2730! Imported variable declarations.
2731!
2732 integer (i4b), intent(in) :: dstlandmask
2733 integer, intent(out) :: rc
2734!
2735 real (dp), intent(in) :: inival
2736!
2737 character (len=*), intent(in) :: fname
2738!
2739 TYPE (esmf_field), intent(in) :: field
2740 TYPE (esmf_field) :: coupler_fieldcreate
2741!
2742! Local variable declarations.
2743!
2744 integer :: i, j, localde, localdecount
2745 integer :: clbnd(2), cubnd(2)
2746!
2747 integer (i4b), pointer :: msk2d(:,:) => null()
2748 integer (i4b), allocatable :: tlw(:,:), tuw(:,:)
2749!
2750 real (dp), pointer :: ptr2d(:,:) => null()
2751!
2752 character (len=*), parameter :: myfile = &
2753 & __FILE__//", Coupler_FieldCreate"
2754!
2755 TYPE (esmf_grid) :: grid
2756 TYPE (esmf_distgrid) :: distgrid
2757 TYPE (esmf_arrayspec) :: arrayspec
2758 TYPE (esmf_staggerloc) :: staggerloc
2759!
2760!-----------------------------------------------------------------------
2761! Initialize return code flag to success state (no error).
2762!-----------------------------------------------------------------------
2763!
2764 rc=esmf_success
2765 IF (esm_track) THEN
2766 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_FieldCreate', &
2767 & ', PET', petrank
2768 FLUSH (trac)
2769 END IF
2770!
2771!-----------------------------------------------------------------------
2772! Query input field.
2773!-----------------------------------------------------------------------
2774!
2775 CALL esmf_fieldget (field, &
2776 & arrayspec=arrayspec, &
2777 & grid=grid, &
2778 & staggerloc=staggerloc, &
2779 & rc=rc)
2780 IF (esmf_logfounderror(rctocheck=rc, &
2781 & msg=esmf_logerr_passthru, &
2782 & line=__line__, &
2783 & file=myfile)) THEN
2784 RETURN
2785 END IF
2786!
2787! Get information about field associated grid.
2788!
2789 CALL esmf_gridget (grid, &
2790 & distgrid=distgrid, &
2791 & localdecount=localdecount, &
2792 & rc=rc)
2793 IF (esmf_logfounderror(rctocheck=rc, &
2794 & msg=esmf_logerr_passthru, &
2795 & line=__line__, &
2796 & file=myfile)) THEN
2797 RETURN
2798 END IF
2799!
2800! Get lower and upper bound of halo region.
2801!
2802 IF (.not.allocated(tlw)) THEN
2803 allocate ( tlw(2,localdecount) )
2804 END IF
2805 IF (.not.allocated(tuw)) THEN
2806 allocate ( tuw(2,localdecount) )
2807 END IF
2808!
2809 CALL esmf_fieldget (field, &
2810 & totallwidth=tlw, &
2811 & totaluwidth=tuw, &
2812 & rc=rc)
2813 IF (esmf_logfounderror(rctocheck=rc, &
2814 & msg=esmf_logerr_passthru, &
2815 & line=__line__, &
2816 & file=myfile)) THEN
2817 RETURN
2818 END IF
2819!
2820!-----------------------------------------------------------------------
2821! Create new field using input field attributes.
2822!-----------------------------------------------------------------------
2823!
2824 IF (localdecount.eq.1) THEN
2825 coupler_fieldcreate=esmf_fieldcreate(grid, &
2826 & arrayspec, &
2827 & staggerloc=staggerloc, &
2828 & totallwidth=tlw(:,1), &
2829 & totaluwidth=tuw(:,1), &
2830 & name=trim(fname), &
2831 & rc=rc)
2832 IF (esmf_logfounderror(rctocheck=rc, &
2833 & msg=esmf_logerr_passthru, &
2834 & line=__line__, &
2835 & file=myfile)) THEN
2836 RETURN
2837 END IF
2838 ELSE
2839 coupler_fieldcreate=esmf_fieldcreate(grid, &
2840 & arrayspec, &
2841 & staggerloc=staggerloc, &
2842 & name=trim(fname), &
2843 & rc=rc)
2844 IF (esmf_logfounderror(rctocheck=rc, &
2845 & msg=esmf_logerr_passthru, &
2846 & line=__line__, &
2847 & file=myfile)) THEN
2848 RETURN
2849 END IF
2850 END IF
2851!
2852! Get pointer from new field.
2853
2854 de_loop : DO localde=0,localdecount-1
2855 CALL esmf_fieldget (coupler_fieldcreate, &
2856 & localde=localde, &
2857 & farrayptr=ptr2d, &
2858 & computationallbound=clbnd, &
2859 & computationalubound=cubnd, &
2860 & rc=rc)
2861 IF (esmf_logfounderror(rctocheck=rc, &
2862 & msg=esmf_logerr_passthru, &
2863 & line=__line__, &
2864 & file=myfile)) THEN
2865 RETURN
2866 END IF
2867!
2868! Get mask pointer from grid.
2869!
2870 CALL esmf_gridgetitem (grid, &
2871 & esmf_griditem_mask, &
2872 & staggerloc=staggerloc, &
2873 & localde=localde, &
2874 & farrayptr=msk2d, &
2875 & rc=rc)
2876 IF (esmf_logfounderror(rctocheck=rc, &
2877 & msg=esmf_logerr_passthru, &
2878 & line=__line__, &
2879 & file=myfile)) THEN
2880 RETURN
2881 END IF
2882!
2883! Initialize pointer to new field. Masked grid cells are set to
2884! missing value.
2885!
2886 DO j=clbnd(2),cubnd(2)
2887 DO i=clbnd(1),cubnd(1)
2888 IF (msk2d(i,j).ne.dstlandmask) THEN
2889 ptr2d(i,j)=inival
2890 ELSE
2891 ptr2d(i,j)=missing_dp
2892 END IF
2893 END DO
2894 END DO
2895!
2896! Nullify pointers to make sure that it does not point to a random
2897! part in the memory.
2898!
2899 IF (associated(ptr2d)) THEN
2900 nullify (ptr2d)
2901 END IF
2902 IF (associated(msk2d)) THEN
2903 nullify (msk2d)
2904 END IF
2905 END DO de_loop
2906!
2907!-----------------------------------------------------------------------
2908! Deallocate local arrays.
2909!-----------------------------------------------------------------------
2910!
2911 IF (allocated(tlw)) THEN
2912 deallocate (tlw)
2913 END IF
2914 IF (allocated(tuw)) THEN
2915 deallocate (tuw)
2916 END IF
2917!
2918!-----------------------------------------------------------------------
2919! Check consistency of the created field.
2920!-----------------------------------------------------------------------
2921!
2922 CALL esmf_fieldvalidate (coupler_fieldcreate, rc=rc)
2923 IF (esmf_logfounderror(rctocheck=rc, &
2924 & msg=esmf_logerr_passthru, &
2925 & line=__line__, &
2926 & file=myfile)) THEN
2927 RETURN
2928 END IF
2929!
2930 IF (esm_track) THEN
2931 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_FieldCreate', &
2932 & ', PET', petrank
2933 FLUSH (trac)
2934 END IF
2935!
2936 RETURN
2937 END FUNCTION coupler_fieldcreate
2938!
2939 SUBROUTINE coupler_findunmapped (srcField, dstField, &
2940 & srcLandMask, dstLandMask, &
2941 & srcMId, dstMId, rc)
2942!
2943!=======================================================================
2944! !
2945! Modifies the grid mask associated with the destination field to !
2946! split the masked and unmasked grid cells. It is used during !
2947! regridding with extrapolation support. !
2948! !
2949!=======================================================================
2950!
2951! Imported variable declarations.
2952!
2953 integer (i4b), intent(in) :: srclandmask, dstlandmask
2954 integer, intent(in) :: srcmid, dstmid
2955!
2956 integer, intent(out) :: rc
2957!
2958 TYPE (esmf_field), intent(in) :: srcfield, dstfield
2959!
2960! Local variable declarations.
2961!
2962 integer :: i, j, k, srctermprocessing
2963 integer :: localde, localdecount
2964 integer :: clbnd(2), cubnd(2)
2965!
2966 integer (i4b), pointer :: msk2d(:,:) => null()
2967!
2968 real (dp) :: inival
2969!
2970 real (dp), pointer :: bdy2d(:,:) => null()
2971 real (dp), pointer :: ptr2d(:,:) => null()
2972!
2973 character (len=*), parameter :: myfile = &
2974 & __FILE__//", Coupler_FindUnmapped"
2975
2976 character (ESMF_MAXSTR) :: fname
2977!
2978 TYPE (esmf_grid) :: grid
2979 TYPE (esmf_field) :: afield, bfield, cfield
2980 TYPE (esmf_unmappedaction_flag) :: unmap
2981 TYPE (esmf_regridmethod_flag) :: regridmethod
2982 TYPE (esmf_routehandle) :: routehandle
2983 TYPE (esmf_staggerloc) :: sloc
2984!
2985!-----------------------------------------------------------------------
2986! Initialize return code flag to success state (no error).
2987!-----------------------------------------------------------------------
2988!
2989 IF (esm_track) THEN
2990 WRITE (trac,'(a,a,i0)') '==> Entering Coupler_FindUnmapped', &
2991 & ', PET', petrank
2992 FLUSH (trac)
2993 END IF
2994 rc=esmf_success
2995!
2996!-----------------------------------------------------------------------
2997! Create dummy fields.
2998!-----------------------------------------------------------------------
2999!
3000 fname='const_1'
3001 inival=1.0_dp
3002 afield=coupler_fieldcreate(srcfield, fname, inival, &
3003 & srclandmask, rc)
3004 IF (esmf_logfounderror(rctocheck=rc, &
3005 & msg=esmf_logerr_passthru, &
3006 & line=__line__, &
3007 & file=myfile)) THEN
3008 RETURN
3009 END IF
3010!
3011 fname='const_2'
3012 inival=missing_dp
3013 bfield=coupler_fieldcreate(dstfield, fname, inival, &
3014 & dstlandmask, rc)
3015 IF (esmf_logfounderror(rctocheck=rc, &
3016 & msg=esmf_logerr_passthru, &
3017 & line=__line__, &
3018 & file=myfile)) THEN
3019 RETURN
3020 END IF
3021!
3022 fname='const_3'
3023 inival=0.0_dp
3024 cfield=coupler_fieldcreate(dstfield, fname, inival, &
3025 & -1_i4b, rc)
3026 IF (esmf_logfounderror(rctocheck=rc, &
3027 & msg=esmf_logerr_passthru, &
3028 & line=__line__, &
3029 & file=myfile)) THEN
3030 RETURN
3031 END IF
3032!
3033!-----------------------------------------------------------------------
3034! Create 1st RouteHandle, which is used to find the boundary of the
3035! destination grid.
3036!-----------------------------------------------------------------------
3037!
3038 unmap=esmf_unmappedaction_ignore
3039 IF (iatmos.eq.srcmid) THEN ! HGA why Iatmos?
3040 regridmethod=esmf_regridmethod_nearest_stod
3041 ELSE
3042 regridmethod=esmf_regridmethod_nearest_dtos
3043 END IF
3044!
3045 srctermprocessing=0
3046!
3047 CALL esmf_fieldregridstore (srcfield=afield, &
3048 & dstfield=bfield, &
3049 & srcmaskvalues=(/srclandmask/), &
3050 & dstmaskvalues=(/dstlandmask/), &
3051 & unmappedaction=unmap, &
3052 & routehandle=routehandle, &
3053 & regridmethod=regridmethod, &
3054 & srctermprocessing=srctermprocessing, &
3055 & ignoredegenerate=.true., &
3056 & rc=rc)
3057 IF (esmf_logfounderror(rctocheck=rc, &
3058 & msg=esmf_logerr_passthru, &
3059 & line=__line__, &
3060 & file=myfile)) THEN
3061 RETURN
3062 END IF
3063!
3064!-----------------------------------------------------------------------
3065! Perform REGRID using 1st RouteHandle.
3066!-----------------------------------------------------------------------
3067!
3068 CALL esmf_fieldregrid (afield, &
3069 & bfield, &
3070 & routehandle, &
3071 & zeroregion=esmf_region_empty, &
3072 & termorderflag=esmf_termorder_srcseq, &
3073 & rc=rc)
3074 IF (esmf_logfounderror(rctocheck=rc, &
3075 & msg=esmf_logerr_passthru, &
3076 & line=__line__, &
3077 & file=myfile)) THEN
3078 RETURN
3079 END IF
3080!
3081!-----------------------------------------------------------------------
3082! Create 2nd RouteHandle, which is used to find the unmapped grid
3083! cells.
3084!-----------------------------------------------------------------------
3085!
3086 unmap=esmf_unmappedaction_ignore
3087 regridmethod=esmf_regridmethod_bilinear
3088!
3089 CALL esmf_fieldregridstore (srcfield=afield, &
3090 & dstfield=cfield, &
3091 & srcmaskvalues=(/srclandmask/), &
3092 & dstmaskvalues=(/dstlandmask/), &
3093 & unmappedaction=unmap, &
3094 & routehandle=routehandle, &
3095 & regridmethod=regridmethod, &
3096 & srctermprocessing=srctermprocessing, &
3097 & ignoredegenerate=.true., &
3098 & rc=rc)
3099 IF (esmf_logfounderror(rctocheck=rc, &
3100 & msg=esmf_logerr_passthru, &
3101 & line=__line__, &
3102 & file=myfile)) THEN
3103 RETURN
3104 END IF
3105!
3106!-----------------------------------------------------------------------
3107! Perform REGRID using 2nd RouteHandle.
3108!-----------------------------------------------------------------------
3109!
3110 CALL esmf_fieldregrid (afield, &
3111 & cfield, &
3112 & routehandle, &
3113 & zeroregion=esmf_region_total, &
3114 & termorderflag=esmf_termorder_srcseq, &
3115 & rc=rc)
3116 IF (esmf_logfounderror(rctocheck=rc, &
3117 & msg=esmf_logerr_passthru, &
3118 & line=__line__, &
3119 & file=myfile)) THEN
3120 RETURN
3121 END IF
3122!
3123!-----------------------------------------------------------------------
3124! Query regridded field.
3125!-----------------------------------------------------------------------
3126!
3127 CALL esmf_fieldget (cfield, &
3128 & grid=grid, &
3129 & staggerloc=sloc, &
3130 & rc=rc)
3131 IF (esmf_logfounderror(rctocheck=rc, &
3132 & msg=esmf_logerr_passthru, &
3133 & line=__line__, &
3134 & file=myfile)) THEN
3135 RETURN
3136 END IF
3137!
3138! Get number of local decomposition elements (DEs) in the grid.
3139! Usually, a single DE is associated with each Persistent Execution
3140! Thread (PETs). Thus, localDEcount=1.
3141!
3142 CALL esmf_gridget (grid, &
3143 & localdecount=localdecount, &
3144 & rc=rc)
3145 IF (esmf_logfounderror(rctocheck=rc, &
3146 & msg=esmf_logerr_passthru, &
3147 & line=__line__, &
3148 & file=myfile)) THEN
3149 RETURN
3150 END IF
3151!
3152! Get pointer from fields.
3153!
3154 de_loop : DO localde=0,localdecount-1
3155 CALL esmf_fieldget (bfield, &
3156 & localde=localde, &
3157 & farrayptr=bdy2d, &
3158 & rc=rc)
3159 IF (esmf_logfounderror(rctocheck=rc, &
3160 & msg=esmf_logerr_passthru, &
3161 & line=__line__, &
3162 & file=myfile)) THEN
3163 RETURN
3164 END IF
3165!
3166 CALL esmf_fieldget (cfield, &
3167 & localde=localde, &
3168 & farrayptr=ptr2d, &
3169 & computationallbound=clbnd, &
3170 & computationalubound=cubnd, &
3171 & rc=rc)
3172 IF (esmf_logfounderror(rctocheck=rc, &
3173 & msg=esmf_logerr_passthru, &
3174 & line=__line__, &
3175 & file=myfile)) THEN
3176 RETURN
3177 END IF
3178!
3179! Get mask pointer from grid.
3180!
3181 CALL esmf_gridgetitem (grid, &
3182 & esmf_griditem_mask, &
3183 & staggerloc=sloc, &
3184 & localde=localde, &
3185 & farrayptr=msk2d, &
3186 & rc=rc)
3187 IF (esmf_logfounderror(rctocheck=rc, &
3188 & msg=esmf_logerr_passthru, &
3189 & line=__line__, &
3190 & file=myfile)) THEN
3191 RETURN
3192 END IF
3193!
3194! Modify masking to split mapped and unmapped grid cells.
3195!
3196 DO j=clbnd(2),cubnd(2)
3197 DO i=clbnd(1),cubnd(1)
3198 IF ((bdy2d(i,j).lt.tol_dp).and. &
3199 & (msk2d(i,j).ne.dstlandmask)) THEN
3200 IF (ptr2d(i,j).lt.0.5_dp) THEN
3201 msk2d(i,j)=unmapped_mask
3202 ELSE
3203 msk2d(i,j)=mapped_mask
3204 END IF
3205 END IF
3206 END DO
3207 END DO
3208!
3209! Nullify pointer to make sure that it does not point on a random
3210! part in the memory.
3211!
3212 IF (associated(ptr2d)) THEN
3213 nullify (ptr2d)
3214 END IF
3215 IF (associated(bdy2d)) THEN
3216 nullify (bdy2d)
3217 END IF
3218 IF (associated(msk2d)) THEN
3219 nullify (msk2d)
3220 END IF
3221 END DO de_loop
3222!
3223!-----------------------------------------------------------------------
3224! Remove temporary fields.
3225!-----------------------------------------------------------------------
3226!
3227 CALL esmf_fielddestroy (afield, rc=rc)
3228 IF (esmf_logfounderror(rctocheck=rc, &
3229 & msg=esmf_logerr_passthru, &
3230 & line=__line__, &
3231 & file=myfile)) THEN
3232 RETURN
3233 END IF
3234!
3235 CALL esmf_fielddestroy (bfield, rc=rc)
3236 IF (esmf_logfounderror(rctocheck=rc, &
3237 & msg=esmf_logerr_passthru, &
3238 & line=__line__, &
3239 & file=myfile)) THEN
3240 RETURN
3241 END IF
3242!
3243 CALL esmf_fielddestroy (cfield, rc=rc)
3244 IF (esmf_logfounderror(rctocheck=rc, &
3245 & msg=esmf_logerr_passthru, &
3246 & line=__line__, &
3247 & file=myfile)) THEN
3248 RETURN
3249 END IF
3250!
3251 IF (esm_track) THEN
3252 WRITE (trac,'(a,a,i0)') '<== Exiting Coupler_FindUnmapped', &
3253 & ', PET', petrank
3254 FLUSH (trac)
3255 END IF
3256!
3257 RETURN
3258 END SUBROUTINE coupler_findunmapped
3259!
3260#endif
3261 END MODULE esmf_coupler_mod
esmf_coupler_mod
Definition esmf_coupler.h:2
esmf_coupler_mod::coupler_computerh
subroutine, private coupler_computerh(coupler, rc)
Definition esmf_coupler.h:201
esmf_coupler_mod::coupler_executerh
subroutine, private coupler_executerh(coupler, rc)
Definition esmf_coupler.h:1081
esmf_coupler_mod::coupler_findunmapped
subroutine, private coupler_findunmapped(srcfield, dstfield, srclandmask, dstlandmask, srcmid, dstmid, rc)
Definition esmf_coupler.h:2942
esmf_coupler_mod::coupler_releaserh
subroutine, private coupler_releaserh(coupler, rc)
Definition esmf_coupler.h:1782
esmf_coupler_mod::coupler_adjustfield
subroutine, private coupler_adjustfield(vm, field, maskval, error, rc)
Definition esmf_coupler.h:2198
esmf_coupler_mod::coupler_areaintegral
real(dp) function, private coupler_areaintegral(vm, field, maskval, rc)
Definition esmf_coupler.h:2481
esmf_coupler_mod::coupler_setservices
subroutine, public coupler_setservices(coupler, rc)
Definition esmf_coupler.h:85
esmf_coupler_mod::coupler_fieldcreate
type(esmf_field) function, private coupler_fieldcreate(field, fname, inival, dstlandmask, rc)
Definition esmf_coupler.h:2722
mod_esmf_esm
Definition mod_esmf_esm.F:2
mod_esmf_esm::connectors
type(esm_conn), dimension(:,:), allocatable, target connectors
Definition mod_esmf_esm.F:377
mod_esmf_esm::extrapnumlevels
integer extrapnumlevels
Definition mod_esmf_esm.F:615
mod_esmf_esm::unmapped_mask
integer(i4b), parameter unmapped_mask
Definition mod_esmf_esm.F:673
mod_esmf_esm::instod
integer, parameter instod
Definition mod_esmf_esm.F:580
mod_esmf_esm::trac
integer trac
Definition mod_esmf_esm.F:543
mod_esmf_esm::exstod
integer, parameter exstod
Definition mod_esmf_esm.F:595
mod_esmf_esm::ecreep
integer, parameter ecreep
Definition mod_esmf_esm.F:597
mod_esmf_esm::ibilin
integer, parameter ibilin
Definition mod_esmf_esm.F:576
mod_esmf_esm::ipatch
integer, parameter ipatch
Definition mod_esmf_esm.F:577
mod_esmf_esm::debuglevel
integer debuglevel
Definition mod_esmf_esm.F:527
mod_esmf_esm::overland
integer, parameter overland
Definition mod_esmf_esm.F:619
mod_esmf_esm::mapped_mask
integer(i4b), parameter mapped_mask
Definition mod_esmf_esm.F:672
mod_esmf_esm::indtos
integer, parameter indtos
Definition mod_esmf_esm.F:581
mod_esmf_esm::eidavg
integer, parameter eidavg
Definition mod_esmf_esm.F:596
mod_esmf_esm::missing_dp
real(dp), parameter missing_dp
Definition mod_esmf_esm.F:675
mod_esmf_esm::cplout
integer cplout
Definition mod_esmf_esm.F:656
mod_esmf_esm::gridtype
character(len=6), dimension(0:4) gridtype
Definition mod_esmf_esm.F:566
mod_esmf_esm::iatmos
integer iatmos
Definition mod_esmf_esm.F:434
mod_esmf_esm::esm_track
logical esm_track
Definition mod_esmf_esm.F:542
mod_esmf_esm::enone
integer, parameter enone
Definition mod_esmf_esm.F:594
mod_esmf_esm::field_index
integer function, public field_index(fnames, fvalue)
Definition mod_esmf_esm.F:1083
mod_esmf_esm::intrptype
character(len=4), dimension(0:6) intrptype
Definition mod_esmf_esm.F:583
mod_esmf_esm::extrptype
character(len=4), dimension(0:4) extrptype
Definition mod_esmf_esm.F:600
mod_esmf_esm::idata
integer idata
Definition mod_esmf_esm.F:435
mod_esmf_esm::overocean
integer, parameter overocean
Definition mod_esmf_esm.F:620
mod_esmf_esm::e2steps
integer, parameter e2steps
Definition mod_esmf_esm.F:598
mod_esmf_esm::nmodels
integer nmodels
Definition mod_esmf_esm.F:413
mod_esmf_esm::cmodel
character(len=10), dimension(:), allocatable cmodel
Definition mod_esmf_esm.F:446
mod_esmf_esm::tol_dp
real(dp), parameter tol_dp
Definition mod_esmf_esm.F:679
mod_esmf_esm::petrank
integer petrank
Definition mod_esmf_esm.F:481
mod_esmf_esm::models
type(esm_model), dimension(:), allocatable, target models
Definition mod_esmf_esm.F:360
mod_esmf_esm::iconsv1
integer, parameter iconsv1
Definition mod_esmf_esm.F:578
strings_mod
Definition strings.F:2
strings_mod::lowercase
character(len(sinp)) function, public lowercase(sinp)
Definition strings.F:531