source: trunk/WRF.COMMON/WRFV3/external/io_esmf/ext_esmf_write_field.F90 @ 3567

Last change on this file since 3567 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 15.9 KB
Line 
1
2!TODO:  remove duplication between ext_esmf_read_field and
3!TODO:  ext_esmf_write_field
4
5!TODO:  how to deal with time?  (via current ESMF_Clock)
6!TODO:  to begin, use it as an error check...
7
8
9!--- write_field
10SUBROUTINE ext_esmf_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
11                                  DomainDesc , MemoryOrder , Stagger , DimNames ,              &
12                                  DomainStart , DomainEnd ,                                    &
13                                  MemoryStart , MemoryEnd ,                                    &
14                                  PatchStart , PatchEnd ,                                      &
15                                  Status )
16  USE module_ext_esmf
17  IMPLICIT NONE
18  INTEGER       ,INTENT(IN)    :: DataHandle
19  CHARACTER*(*) ,intent(inout) :: DateStr
20  CHARACTER*(*) ,intent(inout) :: VarName
21  integer       ,intent(inout) :: FieldType
22  integer       ,intent(inout) :: Comm
23  integer       ,intent(inout) :: IOComm
24  integer       ,intent(inout) :: DomainDesc
25  character*(*) ,intent(inout) :: MemoryOrder
26  character*(*) ,intent(inout) :: Stagger
27  character*(*) ,intent(inout) :: DimNames(*)
28  integer       ,intent(inout) :: DomainStart(*), DomainEnd(*)
29  integer       ,intent(inout) :: MemoryStart(*), MemoryEnd(*)
30  integer       ,intent(inout) :: PatchStart(*),  PatchEnd(*)
31  REAL          ,INTENT(INOUT) :: Field(*)
32  integer       ,intent(out)   :: Status
33  ! Local declarations
34  INTEGER :: ids,ide,jds,jde,kds,kde
35  INTEGER :: ims,ime,jms,jme,kms,kme
36  INTEGER :: ips,ipe,jps,jpe,kps,kpe
37  TYPE(ESMF_State), POINTER :: exportstate
38  TYPE(ESMF_Field) :: tmpField
39  TYPE(ESMF_Array) :: tmpArray
40  TYPE(ESMF_ArraySpec) :: arrayspec
41!  TYPE(ESMF_DataKind) :: esmf_kind
42  INTEGER :: esmf_kind
43  TYPE(ESMF_RelLoc) :: horzRelloc
44  REAL(ESMF_KIND_R4), POINTER :: data_esmf_real_ptr(:,:)
45  REAL(ESMF_KIND_R4), POINTER :: tmp_esmf_r4_ptr(:,:)
46  INTEGER(ESMF_KIND_I4), POINTER :: data_esmf_int_ptr(:,:)
47  INTEGER, PARAMETER :: esmf_rank = 2
48  INTEGER :: DomainEndFull(esmf_rank), idefull, jdefull, ict, i, j
49  INTEGER :: PatchEndFull(esmf_rank), ipefull, jpefull
50  ! esmf_counts is redundant.  remove it as soon as ESMF_ArrayCreate no
51  ! longer requires it
52  INTEGER :: esmf_counts(esmf_rank)
53  INTEGER :: rc, debug_level
54  LOGICAL, EXTERNAL :: has_char
55  character*256 mess
56
57  CALL get_wrf_debug_level( debug_level )
58
59  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
60    CALL wrf_error_fatal("ext_esmf_write_field: invalid data handle" )
61  ENDIF
62  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
63    CALL wrf_error_fatal("ext_esmf_write_field: DataHandle not opened" )
64  ENDIF
65  IF ( .NOT. opened_for_write( DataHandle ) ) THEN
66    CALL wrf_error_fatal("ext_esmf_write_field: DataHandle not opened for write" )
67  ENDIF
68
69write(mess,*)'ext_esmf_write_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
70call wrf_debug( 300, TRIM(mess) )
71
72  IF      ( FieldType .EQ. WRF_REAL ) THEN
73    esmf_kind = ESMF_KIND_R4
74  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
75    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_DOUBLE not yet supported')
76  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
77    esmf_kind = ESMF_KIND_I4
78!TODO:  implement this (below)
79    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_INTEGER not yet implemented')
80  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
81    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_LOGICAL not yet supported')
82  ENDIF
83
84  ims = MemoryStart(1) ; ime = MemoryEnd(1)
85  jms = MemoryStart(2) ; jme = MemoryEnd(2)
86  kms = MemoryStart(3) ; kme = MemoryEnd(3)
87
88  ips = PatchStart(1) ; ipe = PatchEnd(1)
89  jps = PatchStart(2) ; jpe = PatchEnd(2)
90  kps = PatchStart(3) ; kpe = PatchEnd(3)
91
92  ids = DomainStart(1) ; ide = DomainEnd(1)
93  jds = DomainStart(2) ; jde = DomainEnd(2)
94  kds = DomainStart(3) ; kde = DomainEnd(3)
95
96  ! For now, treat all arrays as 2D... 
97!TODO:  Eventually, use ../io_netcdf subroutines Transpose() and reorder()
98!TODO:  (and etc.) to handle general array ranks and index orderings. 
99!TODO:  Some copies of these exist in ../../frame/module_io.F. 
100!TODO:  Then use ESMF_ArrayDataMap class to handle index mapping. 
101  IF ( kms /= kme ) THEN
102    CALL wrf_error_fatal( 'ext_esmf_write_field:  rank > 2 not yet supported')
103  ENDIF
104
105! The non-staggered variables come in at one-less than
106! domain dimensions, but io_esmf is currently hacked to use full
107! domain spec, so adjust if not staggered.
108!TODO:  Remove EndFull hackery once ESMF can support staggered
109!TODO:  grids in regional models.  (This hack works around the current
110!TODO:  need to use only larger staggered dimensions for ESMF_Arrays.) 
111  CALL ioesmf_endfullhack( esmf_rank, DomainEnd, PatchEnd, Stagger, &
112                           DomainEndFull, PatchEndFull )
113  idefull = DomainEndFull(1)
114  jdefull = DomainEndFull(2)
115  ipefull = PatchEndFull(1)
116  jpefull = PatchEndFull(2)
117
118write(mess,*) ' ext_esmf_write_field: okay_to_write: ', DataHandle, okay_to_write(DataHandle)
119call wrf_debug( 300, TRIM(mess) )
120
121  ! case 1: the file is opened for write but not committed ("training")
122  IF ( .NOT. okay_to_write( DataHandle ) )  THEN
123
124    ! Training:  build the ESMF export state
125write(mess,*) ' ext_esmf_write_field: TRAINING WRITE:  DataHandle = ', DataHandle
126call wrf_debug( 300, TRIM(mess) )
127
128    ! First, build the ESMF_Grid for this DataHandle, if it does not
129    ! already exist
130write(0,*)__FILE__,__LINE__,'ext_esmf_write_field Stagger',TRIM(Stagger)
131write(0,*)__FILE__,__LINE__,'ext_esmf_write_field VarName',TRIM(VarName)
132write(0,*)__FILE__,__LINE__,'ext_esmf_write_field DomainEnd ', DomainEnd(1:esmf_rank)
133write(0,*)__FILE__,__LINE__,'ext_esmf_write_field PatchEnd  ', PatchEnd(1:esmf_rank)
134    CALL ioesmf_create_grid( DataHandle, esmf_rank, MemoryOrder, Stagger,      &
135                             DomainStart(1:esmf_rank), DomainEnd(1:esmf_rank), &
136                             MemoryStart(1:esmf_rank), MemoryEnd(1:esmf_rank), &
137                             PatchStart(1:esmf_rank), PatchEnd(1:esmf_rank) )
138    ! Grab the current exportState and add to it...
139    CALL ESMF_ExportStateGetCurrent( exportstate, rc )
140    IF ( rc /= ESMF_SUCCESS ) THEN
141      CALL wrf_error_fatal("ext_esmf_write_field, training:  ESMF_ExportStateGetCurrent failed" )
142    ENDIF
143! BEGIN DOESNOTWORK
144! The following code does not work for reasons as-yet unknown. 
145! A likely suspect is lbounds and ubounds which fail in other interfaces in
146! ESMF 2.2.0rp1 ... 
147    ! Build ESMF objects... 
148    ! Build an ESMF_ArraySpec.  The use of ESMF_ArraySpec and ESMF_Array
149    ! objects allows some of the code that follows to be type-kind-independent. 
150
151    ! Build an ESMF_Array
152    ! Implementation note:  since we do not yet have full control over how
153    ! ESMF chooses to lay out a "patch" within "memory", we must copy by
154    ! hand.  (Reasons include lack of support in ESMF for asymmetric halos,
155    ! addition of "extra" rows/columns to optimize alignment on some machines,
156    ! handling of periodic boundary conditions, etc.)  Thus, there
157    ! is no point in using larger "memory" sizes to build the array -- patch
158    ! is fine.  Also, since we must copy anyway, might as well let ESMF manage
159    ! the memory for simplicity. 
160!TODO:  Once ESMF can match WRF memory-patch mapping, replace this with a more
161!TODO:  efficient solution that does not require a copy. 
162!TODO:  esmf_counts is redundant.  Remove it as soon as ESMF_ArrayCreate no
163!TODO:  longer requires it. 
164!    esmf_counts(1:esmf_rank) = DomainEndFull(1:esmf_rank) - &
165!                               DomainStart(1:esmf_rank) + 1
166!    tmpArray = ESMF_ArrayCreate(arrayspec, counts=esmf_counts,      &
167!                                lbounds=DomainStart(1:esmf_rank),   &
168!                                ubounds=DomainEndFull(1:esmf_rank), &
169!                                rc=rc)
170!    IF ( rc /= ESMF_SUCCESS ) THEN
171!      WRITE(mess,*) ' ext_esmf_write_field: ESMF_ArrayCreate failed, rc = ', rc
172!      CALL wrf_error_fatal( TRIM(mess) )
173!    ENDIF
174    ! Determine grid staggering for this Field
175!    IF ( has_char( Stagger, 'x' ) .AND. has_char( Stagger, 'y' ) ) THEN
176!      CALL wrf_error_fatal( &
177!        "ext_esmf_write_field:  ESMF does not yet support XY staggering for C-grid" )
178!    ELSE IF ( has_char( Stagger, 'x' ) ) THEN
179!      horzrelloc=ESMF_CELL_WFACE
180!    ELSE IF ( has_char( Stagger, 'y' ) ) THEN
181!      horzrelloc=ESMF_CELL_SFACE
182!    ELSE
183!      horzrelloc=ESMF_CELL_CENTER
184!    ENDIF
185    ! Build an ESMF_Field
186    ! Note:  though it is counter-intuitive, ESMF uses
187    ! shallow-copy-masquerading-as-reference to implement the
188    ! pseudo-equivalent of POINTER assignment under-the-hood.  What this means
189    ! here is that it is OK to pass deep object tmpArray into
190    ! ESMF_FieldCreate() and then return from this subroutine.  Even though
191    ! tmpArray goes out of scope, it is OK.  However, if tmpArray were to be
192    ! modified after this call, the changes would not be guaranteed to always
193    ! appear in tmpField.  It works that way now, but ESMF Core team has
194    ! plans that may make it break in the future.  Build-it, attach-it,
195    ! flush-it will work.  Build-it, attach-it, modify-it, flush-it may not
196    ! always work. 
197    ! Note:  unique Field name is required by ESMF_StateAdd(). 
198!TODO:  use CF "standard_name" once the WRF Registry supports it
199!    tmpField = ESMF_FieldCreate( grid( DataHandle )%ptr, tmpArray,          &
200!                                 copyflag=ESMF_DATA_REF,                    &
201!                                 horzrelloc=horzrelloc, name=TRIM(VarName), &
202!                                 rc=rc )
203! END DOESNOTWORK
204!TODO:  Compute horzrelloc from Stagger as above once ESMF supports staggering
205    horzrelloc=ESMF_CELL_CENTER
206!TODO:  Add code for other data types here... 
207!    ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) )
208    ALLOCATE( tmp_esmf_r4_ptr(ips:ipe,jps:jpe) )
209    CALL wrf_debug ( 100, 'ext_esmf_write_field: calling ESMF_FieldCreate' )
210    tmpField = ESMF_FieldCreate(         &
211                 grid( DataHandle )%ptr, &
212                 tmp_esmf_r4_ptr,        &
213                 copyflag=ESMF_DATA_REF, &
214                 staggerloc=ESMF_STAGGERLOC_CENTER,    &
215                 name=TRIM(VarName),     &
216                 rc=rc )
217    IF ( rc /= ESMF_SUCCESS ) THEN
218      WRITE(mess,*) ' ext_esmf_write_field: ESMF_FieldCreate failed, rc = ', rc
219      CALL wrf_error_fatal( TRIM(mess) )
220    ENDIF
221    CALL wrf_debug ( 100, 'ext_esmf_write_field: back from ESMF_FieldCreate' )
222    WRITE(mess,*) 'ext_esmf_write_field: tmp_esmf_r4_ptr(',        &
223      LBOUND(tmp_esmf_r4_ptr,1),':',UBOUND(tmp_esmf_r4_ptr,1),',', &
224      LBOUND(tmp_esmf_r4_ptr,2),':',UBOUND(tmp_esmf_r4_ptr,2),')'
225    CALL wrf_debug ( 100 , TRIM(mess) )
226    ! Add the Field to the export state... 
227!TODO:  for now, just build ESMF_Fields and stuff them in
228!TODO:  later, use a single ESMF_Bundle
229    CALL ESMF_StateAdd( exportstate, tmpField, rc=rc )
230    IF ( rc /= ESMF_SUCCESS ) THEN
231      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateAddfailed" )
232    ENDIF
233write(mess,*) ' ext_esmf_write_field: END TRAINING WRITE:  DataHandle = ', DataHandle
234call wrf_debug( 300, TRIM(mess) )
235
236  ! case 2: opened for write and committed
237  ELSE IF ( okay_to_write( DataHandle ) )  THEN
238
239write(mess,*) ' ext_esmf_write_field: ACTUAL WRITE:  DataHandle = ', DataHandle
240call wrf_debug( 300, TRIM(mess) )
241
242    ! write:  insert data into the ESMF export state
243    ! Grab the current exportState
244    CALL ESMF_ExportStateGetCurrent( exportstate, rc )
245    IF ( rc /= ESMF_SUCCESS ) THEN
246      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_ExportStateGetCurrent failed" )
247    ENDIF
248    ! grab the Field
249    CALL ESMF_StateGet( exportstate, itemName=TRIM(VarName), &
250                             field=tmpfield, rc=rc )
251    IF ( rc /= ESMF_SUCCESS ) THEN
252      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateGetfailed" )
253    ENDIF
254
255CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 1' )
256IF ( 100 .LE. debug_level ) THEN
257  CALL ESMF_FieldPrint( tmpField, rc=rc )
258ENDIF
259CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 1' )
260
261    ! grab a pointer to the export state data and copy data from Field
262    IF      ( FieldType .EQ. WRF_REAL ) THEN
263      CALL ESMF_FieldGet( tmpField, 0, data_esmf_real_ptr, rc=rc )
264      IF ( rc /= ESMF_SUCCESS ) THEN
265        CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_FieldGetDataPointer(r4) failed" )
266      ENDIF
267      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_real_ptr,1) ) .OR. &
268           ( PatchEnd(1) /= UBOUND(data_esmf_real_ptr,1) ) .OR. &
269           ( PatchStart(2)   /= LBOUND(data_esmf_real_ptr,2) ) .OR. &
270           ( PatchEnd(2) /= UBOUND(data_esmf_real_ptr,2) ) ) THEN
271        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',          &
272          __FILE__ ,                                                         &
273          ', line ',                                                         &
274          __LINE__ ,                                                         &
275          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',      &
276                                 PatchStart(2),':',PatchEnd(2),          &
277          ', data_esmf_real_ptr(BOUNDS) = ',                                 &
278          LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
279          LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
280        CALL wrf_error_fatal ( TRIM(mess) )
281      ENDIF
282
283WRITE( mess,* ) 'DEBUG:  ext_esmf_write_field:  ips:ipe,jps:jpe = ', &
284  ips,':',ipe,',',jps,':',jpe,                                       &
285  ', data_esmf_real_ptr(BOUNDS) = ',                                 &
286  LBOUND(data_esmf_real_ptr,1),':',UBOUND(data_esmf_real_ptr,1),',', &
287  LBOUND(data_esmf_real_ptr,2),':',UBOUND(data_esmf_real_ptr,2)
288CALL wrf_debug( 300, TRIM(mess) )
289
290      CALL ioesmf_insert_data_real( Field, data_esmf_real_ptr,            &
291                                    ips, ipe, jps, jpe, kps, kpe, &
292                                    ims, ime, jms, jme, kms, kme )
293    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
294      CALL ESMF_FieldGet( tmpField, 0, data_esmf_int_ptr, rc=rc )
295      IF ( rc /= ESMF_SUCCESS ) THEN
296        CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_FieldGetDataPointer(i4) failed" )
297      ENDIF
298      IF ( ( PatchStart(1)   /= LBOUND(data_esmf_int_ptr,1) ) .OR. &
299           ( PatchEnd(1) /= UBOUND(data_esmf_int_ptr,1) ) .OR. &
300           ( PatchStart(2)   /= LBOUND(data_esmf_int_ptr,2) ) .OR. &
301           ( PatchEnd(2) /= UBOUND(data_esmf_int_ptr,2) ) ) THEN
302        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',        &
303          __FILE__ ,                                                       &
304          ', line ',                                                       &
305          __LINE__ ,                                                       &
306          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',    &
307                                 PatchStart(2),':',PatchEnd(2),        &
308          ', data_esmf_int_ptr(BOUNDS) = ',                                &
309          LBOUND(data_esmf_int_ptr,1),':',UBOUND(data_esmf_int_ptr,1),',', &
310          LBOUND(data_esmf_int_ptr,2),':',UBOUND(data_esmf_int_ptr,2)
311        CALL wrf_error_fatal ( TRIM(mess) )
312      ENDIF
313      CALL ioesmf_insert_data_int( Field, data_esmf_int_ptr,             &
314                                   ips, ipe, jps, jpe, kps, kpe, &
315                                   ims, ime, jms, jme, kms, kme )
316    ENDIF
317write(mess,*) ' ext_esmf_write_field: END ACTUAL WRITE:  DataHandle = ', DataHandle
318call wrf_debug( 300, TRIM(mess) )
319
320  ENDIF
321
322CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 2' )
323IF ( 100 .LE. debug_level ) THEN
324  CALL ESMF_FieldPrint( tmpField, rc=rc )
325ENDIF
326CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 2' )
327
328  Status = 0
329
330  RETURN
331
332END SUBROUTINE ext_esmf_write_field
333
Note: See TracBrowser for help on using the repository browser.