source: trunk/WRF.COMMON/WRFV3/external/io_int/io_int.F90 @ 2759

Last change on this file since 2759 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: 59.1 KB
Line 
1! (old comment from when this file was a template)
2! This is a template for adding a package-dependent implemetnation of
3! the I/O API.  You can use the name xxx since that is already set up
4! as a placeholder in module_io.F, md_calls.m4, and the Registry, or
5! you can change the name here and in those other places.  For additional
6! information on adding a package to WRF, see the latest version of the
7! WRF Design and Implementation Document 1.1 (Draft). June 21, 2001
8!
9! Uses header manipulation routines in module_io_quilt.F
10!
11
12MODULE module_ext_internal
13
14  USE module_internal_header_util
15
16  INTEGER, PARAMETER :: int_num_handles = 99
17  LOGICAL, DIMENSION(int_num_handles) :: okay_for_io, int_handle_in_use, okay_to_commit
18  INTEGER, DIMENSION(int_num_handles) :: int_num_bytes_to_write
19! first_operation is set to .TRUE. when a new handle is allocated
20! or when open-for-write or open-for-read are committed.  It is set
21! to .FALSE. when the first field is read or written. 
22  LOGICAL, DIMENSION(int_num_handles) :: first_operation
23! TBH:  file_status is checked by routines that call the WRF IOAPI.  It is not
24! TBH:  yet cleanly integrated with okay_for_io, int_handle_in_use,
25! TBH:  okay_to_commit.  Fix this later... 
26  INTEGER, DIMENSION(int_num_handles) :: file_status
27! TBH:  This flag goes along with file_status and is set as early as possible. 
28  LOGICAL, DIMENSION(int_num_handles) :: file_read_only
29  CHARACTER*128, DIMENSION(int_num_handles) :: CurrentDateInFile
30  REAL, POINTER    :: int_local_output_buffer(:)
31  INTEGER          :: int_local_output_cursor
32
33  INTEGER, PARAMETER           :: onebyte = 1
34  INTEGER comm_io_servers, iserver, hdrbufsize, obufsize
35  INTEGER itypesize, rtypesize, typesize
36  INTEGER, DIMENSION(512)     :: hdrbuf
37  INTEGER, DIMENSION(int_num_handles)       :: handle
38  INTEGER, DIMENSION(512, int_num_handles)  :: open_file_descriptors
39
40  CHARACTER*132 last_next_var( int_num_handles )
41
42  CONTAINS
43
44    LOGICAL FUNCTION int_valid_handle( handle )
45      IMPLICIT NONE
46      INTEGER, INTENT(IN) ::  handle
47      int_valid_handle = ( handle .ge. 8 .and. handle .le. int_num_handles )
48    END FUNCTION int_valid_handle
49
50    SUBROUTINE int_get_fresh_handle( retval )
51#include "wrf_io_flags.h"
52      INTEGER i, retval
53      retval = -1
54! dont use first 8 handles
55      DO i = 8, int_num_handles
56        IF ( .NOT. int_handle_in_use(i) )  THEN
57          retval = i
58          GOTO 33
59        ENDIF
60      ENDDO
6133    CONTINUE
62      IF ( retval < 0 )  THEN
63        CALL wrf_error_fatal("io_int.F90: int_get_fresh_handle() can not get new handle")
64      ENDIF
65      int_handle_in_use(i) = .TRUE.
66      first_operation(i) = .TRUE.
67      file_status(i) = WRF_FILE_NOT_OPENED
68      NULLIFY ( int_local_output_buffer )
69    END SUBROUTINE int_get_fresh_handle
70
71    SUBROUTINE release_handle( i )
72#include "wrf_io_flags.h"
73      INTEGER, INTENT(IN) :: i
74      IF ( i .LT. 8 .OR. i .GT. int_num_handles ) RETURN
75      IF ( .NOT. int_handle_in_use(i) ) RETURN
76      int_handle_in_use(i) = .FALSE.
77      RETURN
78    END SUBROUTINE release_handle
79
80     
81
82    !--- ioinit
83    SUBROUTINE init_module_ext_internal
84      IMPLICIT NONE
85      INTEGER i
86      CALL wrf_sizeof_integer( itypesize )
87      CALL wrf_sizeof_real   ( rtypesize )
88      DO i = 1, int_num_handles
89         last_next_var( i ) = ' '
90      ENDDO
91    END SUBROUTINE init_module_ext_internal
92
93! Returns .TRUE. iff it is OK to write time-independent domain metadata to the
94! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
95! returned. 
96LOGICAL FUNCTION int_ok_to_put_dom_ti( DataHandle )
97#include "wrf_io_flags.h"
98    INTEGER, INTENT(IN) :: DataHandle
99    CHARACTER*256 :: fname
100    INTEGER :: filestate
101    INTEGER :: Status
102    LOGICAL :: dryrun, first_output, retval
103    call ext_int_inquire_filename( DataHandle, fname, filestate, Status )
104    IF ( Status /= 0 ) THEN
105      retval = .FALSE.
106    ELSE
107      dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
108      first_output = int_is_first_operation( DataHandle )
109      ! Note that we want to REPLICATE time-independent domain metadata in the
110      ! output files so the metadata is available during reads.  Fortran
111      ! unformatted I/O must be sequential because we don't have fixed record
112      ! lengths. 
113      ! retval = .NOT. dryrun .AND. first_output
114      retval = .NOT. dryrun
115    ENDIF
116    int_ok_to_put_dom_ti = retval
117    RETURN
118END FUNCTION int_ok_to_put_dom_ti
119
120! Returns .TRUE. iff it is OK to read time-independent domain metadata from the
121! file referenced by DataHandle.  If DataHandle is invalid, .FALSE. is
122! returned. 
123LOGICAL FUNCTION int_ok_to_get_dom_ti( DataHandle )
124#include "wrf_io_flags.h"
125    INTEGER, INTENT(IN) :: DataHandle
126    CHARACTER*256 :: fname
127    INTEGER :: filestate
128    INTEGER :: Status
129    LOGICAL :: dryrun, retval
130    call ext_int_inquire_filename( DataHandle, fname, filestate, Status )
131    IF ( Status /= 0 ) THEN
132      retval = .FALSE.
133    ELSE
134      dryrun       = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
135      retval = .NOT. dryrun
136    ENDIF
137    int_ok_to_get_dom_ti = retval
138    RETURN
139END FUNCTION int_ok_to_get_dom_ti
140
141! Returns .TRUE. iff nothing has been read from or written to the file
142! referenced by DataHandle.  If DataHandle is invalid, .FALSE. is returned. 
143LOGICAL FUNCTION int_is_first_operation( DataHandle )
144    INTEGER, INTENT(IN) :: DataHandle
145    LOGICAL :: retval
146    retval = .FALSE.
147    IF ( int_valid_handle ( DataHandle ) ) THEN
148      IF ( int_handle_in_use( DataHandle ) ) THEN
149        retval = first_operation( DataHandle )
150      ENDIF
151    ENDIF
152    int_is_first_operation = retval
153    RETURN
154END FUNCTION int_is_first_operation
155
156END MODULE module_ext_internal
157
158SUBROUTINE ext_int_ioinit( SysDepInfo, Status )
159  USE module_ext_internal
160  IMPLICIT NONE
161  CHARACTER*(*), INTENT(IN) :: SysDepInfo
162  INTEGER Status
163  CALL init_module_ext_internal
164END SUBROUTINE ext_int_ioinit
165
166!--- open_for_write
167SUBROUTINE ext_int_open_for_write( FileName , Comm_compute, Comm_io, SysDepInfo, &
168                                   DataHandle , Status )
169  USE module_ext_internal
170  IMPLICIT NONE
171  INCLUDE 'intio_tags.h'
172  CHARACTER*(*) :: FileName
173  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
174  CHARACTER*(*) :: SysDepInfo
175  INTEGER ,       INTENT(OUT) :: DataHandle
176  INTEGER ,       INTENT(OUT) :: Status
177
178  CALL ext_int_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
179                                     DataHandle , Status )
180  IF ( Status .NE. 0 ) RETURN
181  CALL ext_int_open_for_write_commit( DataHandle , Status )
182  RETURN
183END SUBROUTINE ext_int_open_for_write
184
185!--- open_for_write_begin
186SUBROUTINE ext_int_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, &
187                                         DataHandle , Status )
188  USE module_ext_internal
189  IMPLICIT NONE
190  INCLUDE 'intio_tags.h'
191#include "wrf_io_flags.h"
192  CHARACTER*(*) :: FileName
193  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
194  CHARACTER*(*) :: SysDepInfo
195  INTEGER ,       INTENT(OUT) :: DataHandle
196  INTEGER ,       INTENT(OUT) :: Status
197  INTEGER i, tasks_in_group, ierr, comm_io_group
198  REAL dummy
199  INTEGER io_form
200  CHARACTER*256 :: fname
201
202  CALL int_get_fresh_handle(i)
203  okay_for_io(i) = .false.
204  DataHandle = i
205
206  io_form = 100 ! dummy value
207  fname = TRIM(FileName)
208  CALL int_gen_ofwb_header( open_file_descriptors(1,i), hdrbufsize, itypesize, &
209                            fname,SysDepInfo,io_form,DataHandle )
210
211  OPEN ( unit=DataHandle, file=TRIM(FileName), form='unformatted', iostat=Status )
212
213  file_status(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
214  file_read_only(DataHandle) = .FALSE.
215
216  Status = 0
217  RETURN 
218END SUBROUTINE ext_int_open_for_write_begin
219
220!--- open_for_write_commit
221SUBROUTINE ext_int_open_for_write_commit( DataHandle , Status )
222  USE module_ext_internal
223  IMPLICIT NONE
224  INCLUDE 'intio_tags.h'
225#include "wrf_io_flags.h"
226  INTEGER ,       INTENT(IN ) :: DataHandle
227  INTEGER ,       INTENT(OUT) :: Status
228  REAL dummy
229
230  IF ( int_valid_handle ( DataHandle ) ) THEN
231    IF ( int_handle_in_use( DataHandle ) ) THEN
232      okay_for_io( DataHandle ) = .true.
233    ENDIF
234  ENDIF
235
236  first_operation( DataHandle ) = .TRUE.
237  file_status(DataHandle) = WRF_FILE_OPENED_FOR_WRITE
238
239  Status = 0
240
241  RETURN 
242END SUBROUTINE ext_int_open_for_write_commit
243
244!--- open_for_read
245SUBROUTINE ext_int_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
246                               DataHandle , Status )
247  USE module_ext_internal
248  IMPLICIT NONE
249#include "wrf_io_flags.h"
250  CHARACTER*(*) :: FileName
251  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
252  CHARACTER*(*) :: SysDepInfo
253  INTEGER ,       INTENT(OUT) :: DataHandle
254  INTEGER ,       INTENT(OUT) :: Status
255  INTEGER i
256  CHARACTER*256 :: fname
257
258  CALL int_get_fresh_handle(i)
259  DataHandle = i
260  CurrentDateInFile(i) = ""
261  fname = TRIM(FileName)
262
263  CALL int_gen_ofr_header( open_file_descriptors(1,i), hdrbufsize, itypesize, &
264                            fname,SysDepInfo,DataHandle )
265
266  OPEN ( unit=DataHandle, status="old", file=TRIM(FileName), form='unformatted', iostat=Status )
267  okay_for_io(DataHandle) = .true.
268  file_status(DataHandle) = WRF_FILE_OPENED_FOR_READ
269  file_read_only(DataHandle) = .TRUE.
270
271  RETURN 
272END SUBROUTINE ext_int_open_for_read
273
274!--- inquire_opened
275SUBROUTINE ext_int_inquire_opened ( DataHandle, FileName , FileStatus, Status )
276  USE module_ext_internal
277  IMPLICIT NONE
278#include "wrf_io_flags.h"
279  INTEGER ,       INTENT(IN)  :: DataHandle
280  CHARACTER*(*) :: FileName
281  INTEGER ,       INTENT(OUT) :: FileStatus
282  INTEGER ,       INTENT(OUT) :: Status
283  CHARACTER*256 :: fname
284
285  Status = 0
286
287  CALL ext_int_inquire_filename ( DataHandle, fname, FileStatus, Status )
288  IF ( fname /= TRIM(FileName) ) THEN
289    FileStatus = WRF_FILE_NOT_OPENED
290  ENDIF
291
292  Status = 0
293 
294  RETURN
295END SUBROUTINE ext_int_inquire_opened
296
297!--- inquire_filename
298SUBROUTINE ext_int_inquire_filename ( DataHandle, FileName , FileStatus, Status )
299  USE module_ext_internal
300  IMPLICIT NONE
301#include "wrf_io_flags.h"
302  INTEGER ,       INTENT(IN)  :: DataHandle
303  CHARACTER*(*) :: FileName
304  INTEGER ,       INTENT(OUT) :: FileStatus
305  INTEGER ,       INTENT(OUT) :: Status
306  CHARACTER *4096   SysDepInfo
307  INTEGER locDataHandle
308  CHARACTER*256 :: fname
309  INTEGER io_form
310  Status = 0
311  SysDepInfo = ""
312  FileStatus = WRF_FILE_NOT_OPENED
313  FileName = ""
314  IF ( int_valid_handle( DataHandle ) ) THEN
315    IF ( int_handle_in_use( DataHandle ) ) THEN
316      ! Note that the formats for these headers differ. 
317      IF ( file_read_only(DataHandle) ) THEN
318        CALL int_get_ofr_header( open_file_descriptors(1,DataHandle), hdrbufsize, itypesize, &
319                                 fname,SysDepInfo,locDataHandle )
320      ELSE
321        CALL int_get_ofwb_header( open_file_descriptors(1,DataHandle), hdrbufsize, itypesize, &
322                                  fname,SysDepInfo,io_form,locDataHandle )
323      ENDIF
324      FileName = TRIM(fname)
325      FileStatus = file_status(DataHandle)
326    ENDIF
327  ENDIF
328  Status = 0
329END SUBROUTINE ext_int_inquire_filename
330
331!--- sync
332SUBROUTINE ext_int_iosync ( DataHandle, Status )
333  USE module_ext_internal
334  IMPLICIT NONE
335  INTEGER ,       INTENT(IN)  :: DataHandle
336  INTEGER ,       INTENT(OUT) :: Status
337
338  Status = 0
339  RETURN
340END SUBROUTINE ext_int_iosync
341
342!--- close
343SUBROUTINE ext_int_ioclose ( DataHandle, Status )
344  USE module_ext_internal
345  IMPLICIT NONE
346  INTEGER DataHandle, Status
347
348  IF ( int_valid_handle (DataHandle) ) THEN
349    IF ( int_handle_in_use( DataHandle ) ) THEN
350      CLOSE ( DataHandle )
351    ENDIF
352    CALL release_handle(DataHandle)
353  ENDIF
354
355  Status = 0
356
357  RETURN
358END SUBROUTINE ext_int_ioclose
359
360!--- ioexit
361SUBROUTINE ext_int_ioexit( Status )
362
363  USE module_ext_internal
364  IMPLICIT NONE
365  INCLUDE 'intio_tags.h'
366  INTEGER ,       INTENT(OUT) :: Status
367  INTEGER                     :: DataHandle
368  INTEGER i,ierr
369  REAL dummy
370
371  RETURN 
372END SUBROUTINE ext_int_ioexit
373
374!--- get_next_time
375SUBROUTINE ext_int_get_next_time ( DataHandle, DateStr, Status )
376  USE module_ext_internal
377  IMPLICIT NONE
378  INCLUDE 'intio_tags.h'
379  INTEGER ,       INTENT(IN)  :: DataHandle
380  CHARACTER*(*) :: DateStr
381  INTEGER ,       INTENT(OUT) :: Status
382  INTEGER         code
383  CHARACTER*132   locElement, dummyvar
384  INTEGER istat
385
386!local
387  INTEGER                        :: locDataHandle
388  CHARACTER*132                  :: locDateStr
389  CHARACTER*132                  :: locData
390  CHARACTER*132                  :: locVarName
391  integer                        :: locFieldType
392  integer                        :: locComm
393  integer                        :: locIOComm
394  integer                        :: locDomainDesc
395  character*132                  :: locMemoryOrder
396  character*132                  :: locStagger
397  character*132 , dimension (3)  :: locDimNames
398  integer ,dimension(3)          :: locDomainStart, locDomainEnd
399  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
400  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
401  integer loccode
402
403  character*132 mess
404  integer ii,jj,kk,myrank
405  INTEGER inttypesize, realtypesize
406  REAL, DIMENSION(1)    :: Field  ! dummy
407
408  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
409    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_time: invalid data handle" )
410  ENDIF
411  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
412    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_time: DataHandle not opened" )
413  ENDIF
414  inttypesize = itypesize
415  realtypesize = rtypesize
416  DO WHILE ( .TRUE. )
417    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
418    IF ( istat .EQ. 0 ) THEN
419      code = hdrbuf(2)
420      IF ( code .EQ. int_field ) THEN
421        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
422                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
423                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
424                                 locDomainStart , locDomainEnd ,                                    &
425                                 locMemoryStart , locMemoryEnd ,                                    &
426                                 locPatchStart , locPatchEnd )
427        IF ( TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle) ) ) THEN  ! control break, return this date
428          DateStr = TRIM(locDateStr)
429          CurrentDateInFile(DataHandle) = TRIM(DateStr)
430          BACKSPACE ( unit=DataHandle )
431          Status = 0
432          GOTO 7717
433        ELSE
434          READ( unit=DataHandle, iostat=istat )
435        ENDIF
436      ELSE IF ( code .EQ. int_dom_td_char ) THEN
437        CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
438                              locDataHandle, locDateStr, locElement, locData, loccode )
439        IF ( TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle) ) ) THEN  ! control break, return this date
440          DateStr = TRIM(locDateStr)
441          CurrentDateInFile(DataHandle) = TRIM(DateStr)
442          BACKSPACE ( unit=DataHandle )
443          Status = 0
444          GOTO 7717
445        ELSE
446          READ( unit=DataHandle, iostat=istat )
447        ENDIF
448      ENDIF
449    ELSE
450      Status = 1
451      GOTO 7717
452    ENDIF
453  ENDDO
4547717 CONTINUE
455
456  RETURN
457END SUBROUTINE ext_int_get_next_time
458
459!--- set_time
460SUBROUTINE ext_int_set_time ( DataHandle, DateStr, Status )
461  USE module_ext_internal
462  IMPLICIT NONE
463  INCLUDE 'intio_tags.h'
464  INTEGER ,       INTENT(IN)  :: DataHandle
465  CHARACTER*(*) :: DateStr
466  INTEGER ,       INTENT(OUT) :: Status
467
468  CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,        &
469                               DataHandle, "TIMESTAMP", "", TRIM(DateStr), int_set_time )
470  WRITE( unit=DataHandle ) hdrbuf
471  Status = 0
472  RETURN
473END SUBROUTINE ext_int_set_time
474
475!--- get_var_info
476SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
477                              DomainStart , DomainEnd , WrfType, Status )
478  USE module_ext_internal
479  IMPLICIT NONE
480  INCLUDE 'intio_tags.h'
481  integer               ,intent(in)     :: DataHandle
482  character*(*)         ,intent(in)     :: VarName
483  integer               ,intent(out)    :: NDim
484  character*(*)         ,intent(out)    :: MemoryOrder
485  character*(*)         ,intent(out)    :: Stagger
486  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
487  integer               ,intent(out)    :: WrfType
488  integer               ,intent(out)    :: Status
489
490!local
491  INTEGER                        :: locDataHandle
492  CHARACTER*132                  :: locDateStr
493  CHARACTER*132                  :: locVarName
494  integer                        :: locFieldType
495  integer                        :: locComm
496  integer                        :: locIOComm
497  integer                        :: locDomainDesc
498  character*132                  :: locMemoryOrder
499  character*132                  :: locStagger
500  character*132 , dimension (3)  :: locDimNames
501  integer ,dimension(3)          :: locDomainStart, locDomainEnd
502  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
503  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
504
505  character*132 mess
506  integer ii,jj,kk,myrank
507  INTEGER inttypesize, realtypesize, istat, code
508  REAL, DIMENSION(1)    :: Field   ! dummy
509
510  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
511    CALL wrf_error_fatal("io_int.F90: ext_int_get_var_info: invalid data handle" )
512  ENDIF
513  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
514    CALL wrf_error_fatal("io_int.F90: ext_int_get_var_info: DataHandle not opened" )
515  ENDIF
516  inttypesize = itypesize
517  realtypesize = rtypesize
518  DO WHILE ( .TRUE. )
519    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
520    IF ( istat .EQ. 0 ) THEN
521      code = hdrbuf(2)
522      IF ( code .EQ. int_field ) THEN
523        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
524                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
525                                 locDomainDesc , MemoryOrder , locStagger , locDimNames ,              &
526                                 locDomainStart , locDomainEnd ,                                    &
527                                 locMemoryStart , locMemoryEnd ,                                    &
528                                 locPatchStart , locPatchEnd )
529       
530        IF ( LEN(TRIM(MemoryOrder)) .EQ. 3 ) THEN
531          NDim = 3
532        ELSE IF ( LEN(TRIM(MemoryOrder)) .EQ. 2 ) THEN
533          NDim = 2
534        ELSE IF ( TRIM(MemoryOrder) .EQ. '0' ) THEN
535          NDim = 0
536        ELSE
537          NDim = 1
538        ENDIF
539        Stagger = locStagger
540        DomainStart(1:3) = locDomainStart(1:3)
541        DomainEnd(1:3) = locDomainEnd(1:3)
542        WrfType = locFieldType
543        BACKSPACE ( unit=DataHandle )
544        Status = 0
545        GOTO 7717
546      ENDIF
547    ELSE
548      Status = 1
549      GOTO 7717
550    ENDIF
551  ENDDO
5527717 CONTINUE
553
554RETURN
555END SUBROUTINE ext_int_get_var_info
556
557!--- get_next_var
558SUBROUTINE ext_int_get_next_var ( DataHandle, VarName, Status )
559  USE module_ext_internal
560  IMPLICIT NONE
561  include 'intio_tags.h'
562  include 'wrf_status_codes.h'
563  INTEGER ,       INTENT(IN)  :: DataHandle
564  CHARACTER*(*) :: VarName
565  INTEGER ,       INTENT(OUT) :: Status
566
567!local
568  INTEGER                        :: locDataHandle
569  CHARACTER*132                  :: locDateStr
570  CHARACTER*132                  :: locVarName
571  integer                        :: locFieldType
572  integer                        :: locComm
573  integer                        :: locIOComm
574  integer                        :: locDomainDesc
575  character*132                  :: locMemoryOrder
576  character*132                  :: locStagger
577  character*132 , dimension (3)  :: locDimNames
578  integer ,dimension(3)          :: locDomainStart, locDomainEnd
579  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
580  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
581
582character*128 locElement, strData, dumstr
583integer loccode, loccount
584integer idata(128)
585real    rdata(128)
586
587  character*132 mess
588  integer ii,jj,kk,myrank
589  INTEGER inttypesize, realtypesize, istat, code
590  REAL, DIMENSION(1)    :: Field  ! dummy
591
592  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
593    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: invalid data handle" )
594  ENDIF
595  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
596    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: DataHandle not opened" )
597  ENDIF
598  inttypesize = itypesize
599  realtypesize = rtypesize
600  DO WHILE ( .TRUE. )
6017727 CONTINUE
602    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
603    IF ( istat .EQ. 0 ) THEN
604      code = hdrbuf(2)
605#if 1
606      IF ( code .EQ. int_dom_ti_char ) THEN
607        CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
608                                         locDataHandle, locElement, dumstr, strData, loccode )
609      ENDIF
610      IF ( code .EQ. int_dom_ti_integer ) THEN
611        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
612                                locDataHandle, locElement, iData, loccount, code )
613      ENDIF
614      IF ( code .EQ. int_dom_ti_real ) THEN
615        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
616                                locDataHandle, locElement, rData, loccount, code )
617      ENDIF
618#endif
619      IF ( code .EQ. int_field ) THEN
620        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
621                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
622                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
623                                 locDomainStart , locDomainEnd ,                                    &
624                                 locMemoryStart , locMemoryEnd ,                                    &
625                                 locPatchStart , locPatchEnd )
626
627        IF (TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle))) THEN
628          Status = WRF_WARN_VAR_EOF !-6 ! signal past last var in time frame
629          BACKSPACE ( unit=DataHandle )
630          last_next_var( DataHandle )  = ""
631          GOTO 7717
632        ELSE
633          VarName = TRIM(locVarName)
634          IF ( last_next_var( DataHandle )  .NE. VarName ) THEN
635            BACKSPACE ( unit=DataHandle )
636            last_next_var( DataHandle )  = VarName
637          ELSE
638            READ( unit=DataHandle, iostat=istat )
639            GOTO 7727
640          ENDIF
641          Status = 0
642          GOTO 7717
643        ENDIF
644      ELSE
645        GOTO 7727
646      ENDIF
647    ELSE
648      Status = 1
649      GOTO 7717
650    ENDIF
651  ENDDO
6527717 CONTINUE
653  RETURN
654END SUBROUTINE ext_int_get_next_var
655
656!--- get_dom_ti_real
657SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element,   Data, Count, Outcount, Status )
658  USE module_ext_internal
659  IMPLICIT NONE
660  INCLUDE 'intio_tags.h'
661  INTEGER ,       INTENT(IN)  :: DataHandle
662  CHARACTER*(*) :: Element
663  REAL ,          INTENT(OUT) :: Data(*)
664  INTEGER ,       INTENT(IN)  :: Count
665  INTEGER ,       INTENT(OUT) :: Outcount
666  INTEGER ,       INTENT(OUT) :: Status
667  INTEGER loccount, code, istat, locDataHandle
668  CHARACTER*132                :: locElement, mess
669  LOGICAL keepgoing
670
671  Status = 0
672  IF ( int_valid_handle( DataHandle ) ) THEN
673    IF ( int_handle_in_use( DataHandle ) ) THEN
674     ! Do nothing unless it is time to read time-independent domain metadata.
675     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
676      keepgoing = .true.
677      DO WHILE ( keepgoing )
678        READ( unit=DataHandle , iostat = istat ) hdrbuf
679        IF ( istat .EQ. 0 ) THEN
680          code = hdrbuf(2)
681          IF ( code .EQ. int_dom_ti_real ) THEN
682            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
683                                    locDataHandle, locElement, Data, loccount, code )
684            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
685              IF ( loccount .GT. Count ) THEN
686                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_real: loccount .GT. Count' )
687              ENDIF
688              keepgoing = .false. ;  Status = 0
689            ENDIF
690          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_logical .OR. &
691                            code .EQ. int_dom_ti_char    .OR. code .EQ. int_dom_ti_double  .OR. &
692                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_logical .OR. &
693                            code .EQ. int_dom_td_char    .OR. code .EQ. int_dom_td_double  .OR. &
694                            code .EQ. int_dom_td_real                                  ) ) THEN
695            BACKSPACE ( unit=DataHandle )
696            keepgoing = .false. ; Status = 2
697          ENDIF
698        ELSE
699          keepgoing = .false. ; Status = 1
700        ENDIF
701      ENDDO
702     ENDIF
703    ENDIF
704  ENDIF
705RETURN
706END SUBROUTINE ext_int_get_dom_ti_real
707
708!--- put_dom_ti_real
709SUBROUTINE ext_int_put_dom_ti_real ( DataHandle,Element,   Data, Count,  Status )
710  USE module_ext_internal
711  IMPLICIT NONE
712  INCLUDE 'intio_tags.h'
713  INTEGER ,       INTENT(IN)  :: DataHandle
714  CHARACTER*(*) :: Element
715  REAL ,          INTENT(IN) :: Data(*)
716  INTEGER ,       INTENT(IN)  :: Count
717  INTEGER ,       INTENT(OUT) :: Status
718  REAL dummy
719!
720
721  IF ( int_valid_handle( DataHandle ) ) THEN
722    IF ( int_handle_in_use( DataHandle ) ) THEN
723      ! Do nothing unless it is time to write time-independent domain metadata.
724      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
725        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
726                                DataHandle, Element, Data, Count, int_dom_ti_real )
727        WRITE( unit=DataHandle ) hdrbuf
728      ENDIF
729    ENDIF
730  ENDIF
731  Status = 0
732RETURN
733END SUBROUTINE ext_int_put_dom_ti_real
734
735!--- get_dom_ti_double
736SUBROUTINE ext_int_get_dom_ti_double ( DataHandle,Element,   Data, Count, Outcount, Status )
737  USE module_ext_internal
738  IMPLICIT NONE
739  INTEGER ,       INTENT(IN)  :: DataHandle
740  CHARACTER*(*) :: Element
741  real*8 ,            INTENT(OUT) :: Data(*)
742  INTEGER ,       INTENT(IN)  :: Count
743  INTEGER ,       INTENT(OUT)  :: OutCount
744  INTEGER ,       INTENT(OUT) :: Status
745  ! Do nothing unless it is time to read time-independent domain metadata.
746  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
747    CALL wrf_error_fatal('ext_int_get_dom_ti_double not supported yet')
748  ENDIF
749RETURN
750END SUBROUTINE ext_int_get_dom_ti_double
751
752!--- put_dom_ti_double
753SUBROUTINE ext_int_put_dom_ti_double ( DataHandle,Element,   Data, Count,  Status )
754  USE module_ext_internal
755  IMPLICIT NONE
756  INTEGER ,       INTENT(IN)  :: DataHandle
757  CHARACTER*(*) :: Element
758  real*8 ,            INTENT(IN) :: Data(*)
759  INTEGER ,       INTENT(IN)  :: Count
760  INTEGER ,       INTENT(OUT) :: Status
761  ! Do nothing unless it is time to write time-independent domain metadata.
762  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
763    CALL wrf_error_fatal('ext_int_put_dom_ti_double not supported yet')
764  ENDIF
765RETURN
766END SUBROUTINE ext_int_put_dom_ti_double
767
768!--- get_dom_ti_integer
769SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element,   Data, Count, Outcount, Status )
770  USE module_ext_internal
771  IMPLICIT NONE
772  INCLUDE 'intio_tags.h'
773  INTEGER ,       INTENT(IN)  :: DataHandle
774  CHARACTER*(*) :: Element
775  integer ,            INTENT(OUT) :: Data(*)
776  INTEGER ,       INTENT(IN)  :: Count
777  INTEGER ,       INTENT(OUT)  :: OutCount
778  INTEGER ,       INTENT(OUT) :: Status
779  INTEGER loccount, code, istat, locDataHandle
780  CHARACTER*132   locElement, mess
781  LOGICAL keepgoing
782
783  Status = 0
784  IF ( int_valid_handle( DataHandle ) ) THEN
785    IF ( int_handle_in_use( DataHandle ) ) THEN
786     ! Do nothing unless it is time to read time-independent domain metadata.
787     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
788      keepgoing = .true.
789      DO WHILE ( keepgoing )
790        READ( unit=DataHandle , iostat = istat ) hdrbuf
791        IF ( istat .EQ. 0 ) THEN
792          code = hdrbuf(2)
793          IF ( code .EQ. int_dom_ti_integer ) THEN
794            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
795                                    locDataHandle, locElement, Data, loccount, code )
796            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
797              IF ( loccount .GT. Count ) THEN
798                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_integer: loccount .GT. Count' )
799              ENDIF
800              keepgoing = .false. ;  Status = 0
801            ENDIF
802
803          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR.   code .EQ. int_dom_ti_logical .OR. &
804                            code .EQ. int_dom_ti_char    .OR.   code .EQ. int_dom_ti_double  .OR. &
805                            code .EQ. int_dom_td_real    .OR.   code .EQ. int_dom_td_logical .OR. &
806                            code .EQ. int_dom_td_char    .OR.   code .EQ. int_dom_td_double  .OR. &
807                            code .EQ. int_dom_td_integer )                                           ) THEN
808            BACKSPACE ( unit=DataHandle )
809            keepgoing = .false. ; Status = 1
810          ENDIF
811        ELSE
812          keepgoing = .false. ; Status = 1
813        ENDIF
814      ENDDO
815     ENDIF
816    ENDIF
817  ENDIF
818RETURN
819END SUBROUTINE ext_int_get_dom_ti_integer
820
821!--- put_dom_ti_integer
822SUBROUTINE ext_int_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  Status )
823  USE module_ext_internal
824  IMPLICIT NONE
825  INCLUDE 'intio_tags.h'
826  INTEGER ,       INTENT(IN)  :: DataHandle
827  CHARACTER*(*) :: Element
828  INTEGER ,       INTENT(IN) :: Data(*)
829  INTEGER ,       INTENT(IN)  :: Count
830  INTEGER ,       INTENT(OUT) :: Status
831  REAL dummy
832!
833  IF ( int_valid_handle ( Datahandle ) ) THEN
834    IF ( int_handle_in_use( DataHandle ) ) THEN
835      ! Do nothing unless it is time to write time-independent domain metadata.
836      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
837        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, itypesize, &
838                                DataHandle, Element, Data, Count, int_dom_ti_integer )
839        WRITE( unit=DataHandle ) hdrbuf
840      ENDIF
841    ENDIF
842  ENDIF
843  Status = 0
844RETURN
845END SUBROUTINE ext_int_put_dom_ti_integer
846
847!--- get_dom_ti_logical
848SUBROUTINE ext_int_get_dom_ti_logical ( DataHandle,Element,   Data, Count, Outcount, Status )
849  USE module_ext_internal
850  IMPLICIT NONE
851  INTEGER ,       INTENT(IN)  :: DataHandle
852  CHARACTER*(*) :: Element
853  logical ,            INTENT(OUT) :: Data(*)
854  INTEGER ,       INTENT(IN)  :: Count
855  INTEGER ,       INTENT(OUT)  :: OutCount
856  INTEGER ,       INTENT(OUT) :: Status
857  ! Do nothing unless it is time to read time-independent domain metadata.
858  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
859    CALL wrf_message('ext_int_get_dom_ti_logical not supported yet')
860  ENDIF
861RETURN
862END SUBROUTINE ext_int_get_dom_ti_logical
863
864!--- put_dom_ti_logical
865SUBROUTINE ext_int_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  Status )
866  USE module_ext_internal
867  IMPLICIT NONE
868  INTEGER ,       INTENT(IN)  :: DataHandle
869  CHARACTER*(*) :: Element
870  logical ,            INTENT(IN) :: Data(*)
871  INTEGER ,       INTENT(IN)  :: Count
872  INTEGER ,       INTENT(OUT) :: Status
873  ! Do nothing unless it is time to write time-independent domain metadata.
874  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
875    CALL wrf_message('ext_int_put_dom_ti_logical not supported yet')
876  ENDIF
877RETURN
878END SUBROUTINE ext_int_put_dom_ti_logical
879
880!--- get_dom_ti_char
881SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
882  USE module_ext_internal
883  IMPLICIT NONE
884  INCLUDE 'intio_tags.h'
885  INTEGER ,       INTENT(IN)  :: DataHandle
886  CHARACTER*(*) :: Element
887  CHARACTER*(*) :: Data
888  INTEGER ,       INTENT(OUT) :: Status
889  INTEGER istat, code, i
890  CHARACTER*79 dumstr, locElement
891  INTEGER locDataHandle
892  LOGICAL keepgoing
893
894  Status = 0
895  IF ( int_valid_handle( DataHandle ) ) THEN
896    IF ( int_handle_in_use( DataHandle ) ) THEN
897     ! Do nothing unless it is time to read time-independent domain metadata.
898     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
899      keepgoing = .true.
900      DO WHILE ( keepgoing )
901        READ( unit=DataHandle , iostat = istat ) hdrbuf
902
903        IF ( istat .EQ. 0 ) THEN
904          code = hdrbuf(2)
905          IF ( code .EQ. int_dom_ti_char ) THEN
906            CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
907                                         locDataHandle, locElement, dumstr, Data, code )
908            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
909              keepgoing = .false. ;  Status = 0
910            ENDIF
911          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR. code .EQ. int_dom_ti_logical .OR. &
912                            code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_double  .OR. &
913                            code .EQ. int_dom_td_real    .OR. code .EQ. int_dom_td_logical .OR. &
914                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_double  .OR. &
915                            code .EQ. int_dom_td_char                                             ) ) THEN
916            BACKSPACE ( unit=DataHandle )
917            keepgoing = .false. ; Status = 1
918          ENDIF
919        ELSE
920          keepgoing = .false. ; Status = 1
921        ENDIF
922      ENDDO
923     ENDIF
924    ENDIF
925  ENDIF
926RETURN
927END SUBROUTINE ext_int_get_dom_ti_char
928
929!--- put_dom_ti_char
930SUBROUTINE ext_int_put_dom_ti_char ( DataHandle, Element,  Data,  Status )
931  USE module_ext_internal
932  IMPLICIT NONE
933  INCLUDE 'intio_tags.h'
934  INTEGER ,       INTENT(IN)  :: DataHandle
935  CHARACTER*(*) :: Element
936  CHARACTER*(*) :: Data
937  INTEGER ,       INTENT(OUT) :: Status
938  INTEGER i
939  REAL dummy
940  INTEGER                 :: Count
941
942  IF ( int_valid_handle ( Datahandle ) ) THEN
943    IF ( int_handle_in_use( DataHandle ) ) THEN
944      ! Do nothing unless it is time to write time-independent domain metadata.
945      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
946        CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
947                                     DataHandle, Element, "", Data, int_dom_ti_char )
948        WRITE( unit=DataHandle ) hdrbuf
949      ENDIF
950    ENDIF
951  ENDIF
952  Status = 0
953RETURN
954END SUBROUTINE ext_int_put_dom_ti_char
955
956!--- get_dom_td_real
957SUBROUTINE ext_int_get_dom_td_real ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
958  IMPLICIT NONE
959  INTEGER ,       INTENT(IN)  :: DataHandle
960  CHARACTER*(*) :: Element
961  CHARACTER*(*) :: DateStr
962  real ,            INTENT(OUT) :: Data(*)
963  INTEGER ,       INTENT(IN)  :: Count
964  INTEGER ,       INTENT(OUT)  :: OutCount
965  INTEGER ,       INTENT(OUT) :: Status
966RETURN
967END SUBROUTINE ext_int_get_dom_td_real
968
969!--- put_dom_td_real
970SUBROUTINE ext_int_put_dom_td_real ( DataHandle,Element, DateStr,  Data, Count,  Status )
971  IMPLICIT NONE
972  INTEGER ,       INTENT(IN)  :: DataHandle
973  CHARACTER*(*) :: Element
974  CHARACTER*(*) :: DateStr
975  real ,            INTENT(IN) :: Data(*)
976  INTEGER ,       INTENT(IN)  :: Count
977  INTEGER ,       INTENT(OUT) :: Status
978RETURN
979END SUBROUTINE ext_int_put_dom_td_real
980
981!--- get_dom_td_double
982SUBROUTINE ext_int_get_dom_td_double ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
983  IMPLICIT NONE
984  INTEGER ,       INTENT(IN)  :: DataHandle
985  CHARACTER*(*) :: Element
986  CHARACTER*(*) :: DateStr
987  real*8 ,            INTENT(OUT) :: Data(*)
988  INTEGER ,       INTENT(IN)  :: Count
989  INTEGER ,       INTENT(OUT)  :: OutCount
990  INTEGER ,       INTENT(OUT) :: Status
991    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
992RETURN
993END SUBROUTINE ext_int_get_dom_td_double
994
995!--- put_dom_td_double
996SUBROUTINE ext_int_put_dom_td_double ( DataHandle,Element, DateStr,  Data, Count,  Status )
997  IMPLICIT NONE
998  INTEGER ,       INTENT(IN)  :: DataHandle
999  CHARACTER*(*) :: Element
1000  CHARACTER*(*) :: DateStr
1001  real*8 ,            INTENT(IN) :: Data(*)
1002  INTEGER ,       INTENT(IN)  :: Count
1003  INTEGER ,       INTENT(OUT) :: Status
1004    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
1005RETURN
1006END SUBROUTINE ext_int_put_dom_td_double
1007
1008!--- get_dom_td_integer
1009SUBROUTINE ext_int_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
1010  IMPLICIT NONE
1011  INTEGER ,       INTENT(IN)  :: DataHandle
1012  CHARACTER*(*) :: Element
1013  CHARACTER*(*) :: DateStr
1014  integer ,            INTENT(OUT) :: Data(*)
1015  INTEGER ,       INTENT(IN)  :: Count
1016  INTEGER ,       INTENT(OUT)  :: OutCount
1017  INTEGER ,       INTENT(OUT) :: Status
1018RETURN
1019END SUBROUTINE ext_int_get_dom_td_integer
1020
1021!--- put_dom_td_integer
1022SUBROUTINE ext_int_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count,  Status )
1023  IMPLICIT NONE
1024  INTEGER ,       INTENT(IN)  :: DataHandle
1025  CHARACTER*(*) :: Element
1026  CHARACTER*(*) :: DateStr
1027  integer ,            INTENT(IN) :: Data(*)
1028  INTEGER ,       INTENT(IN)  :: Count
1029  INTEGER ,       INTENT(OUT) :: Status
1030RETURN
1031END SUBROUTINE ext_int_put_dom_td_integer
1032
1033!--- get_dom_td_logical
1034SUBROUTINE ext_int_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
1035  IMPLICIT NONE
1036  INTEGER ,       INTENT(IN)  :: DataHandle
1037  CHARACTER*(*) :: Element
1038  CHARACTER*(*) :: DateStr
1039  logical ,            INTENT(OUT) :: Data(*)
1040  INTEGER ,       INTENT(IN)  :: Count
1041  INTEGER ,       INTENT(OUT)  :: OutCount
1042  INTEGER ,       INTENT(OUT) :: Status
1043RETURN
1044END SUBROUTINE ext_int_get_dom_td_logical
1045
1046!--- put_dom_td_logical
1047SUBROUTINE ext_int_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count,  Status )
1048  IMPLICIT NONE
1049  INTEGER ,       INTENT(IN)  :: DataHandle
1050  CHARACTER*(*) :: Element
1051  CHARACTER*(*) :: DateStr
1052  logical ,            INTENT(IN) :: Data(*)
1053  INTEGER ,       INTENT(IN)  :: Count
1054  INTEGER ,       INTENT(OUT) :: Status
1055RETURN
1056END SUBROUTINE ext_int_put_dom_td_logical
1057
1058!--- get_dom_td_char
1059SUBROUTINE ext_int_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
1060  USE module_ext_internal
1061  IMPLICIT NONE
1062  INCLUDE 'intio_tags.h'
1063  INTEGER ,       INTENT(IN)  :: DataHandle
1064  CHARACTER*(*) :: Element
1065  CHARACTER*(*) :: Data, DateStr
1066  INTEGER ,       INTENT(OUT) :: Status
1067  INTEGER istat, code, i
1068  CHARACTER*79 dumstr, locElement, locDatestr
1069  INTEGER locDataHandle
1070  LOGICAL keepgoing
1071
1072  IF ( int_valid_handle( DataHandle ) ) THEN
1073    IF ( int_handle_in_use( DataHandle ) ) THEN
1074      keepgoing = .true.
1075      DO WHILE ( keepgoing )
1076        READ( unit=DataHandle , iostat = istat ) hdrbuf
1077
1078        IF ( istat .EQ. 0 ) THEN
1079          code = hdrbuf(2)
1080          IF ( code .EQ. int_dom_td_char ) THEN
1081            CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
1082                                         locDataHandle, locDateStr, locElement, Data, code )
1083            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
1084              keepgoing = .false. ;  Status = 0
1085            ENDIF
1086          ELSE
1087            BACKSPACE ( unit=DataHandle )
1088            keepgoing = .false. ; Status = 1
1089          ENDIF
1090        ELSE
1091          keepgoing = .false. ; Status = 1
1092        ENDIF
1093      ENDDO
1094    ENDIF
1095  ENDIF
1096RETURN
1097END SUBROUTINE ext_int_get_dom_td_char
1098
1099!--- put_dom_td_char
1100SUBROUTINE ext_int_put_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
1101  USE module_ext_internal
1102  IMPLICIT NONE
1103  INCLUDE 'intio_tags.h'
1104  INTEGER ,       INTENT(IN)  :: DataHandle
1105  CHARACTER*(*) :: Element
1106  CHARACTER*(*) :: Data, DateStr
1107  INTEGER ,       INTENT(OUT) :: Status
1108  INTEGER i
1109  REAL dummy
1110  INTEGER                 :: Count
1111  IF ( int_valid_handle ( Datahandle ) ) THEN
1112    IF ( int_handle_in_use( DataHandle ) ) THEN
1113      CALL int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize,  &
1114                                   DataHandle, DateStr, Element, Data, int_dom_td_char )
1115      WRITE( unit=DataHandle ) hdrbuf
1116    ENDIF
1117  ENDIF
1118  Status = 0
1119RETURN
1120END SUBROUTINE ext_int_put_dom_td_char
1121
1122!--- get_var_ti_real
1123SUBROUTINE ext_int_get_var_ti_real ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1124  IMPLICIT NONE
1125  INTEGER ,       INTENT(IN)  :: DataHandle
1126  CHARACTER*(*) :: Element
1127  CHARACTER*(*) :: VarName
1128  real ,            INTENT(OUT) :: Data(*)
1129  INTEGER ,       INTENT(IN)  :: Count
1130  INTEGER ,       INTENT(OUT)  :: OutCount
1131  INTEGER ,       INTENT(OUT) :: Status
1132RETURN
1133END SUBROUTINE ext_int_get_var_ti_real
1134
1135!--- put_var_ti_real
1136SUBROUTINE ext_int_put_var_ti_real ( DataHandle,Element,  Varname, Data, Count,  Status )
1137  IMPLICIT NONE
1138  INTEGER ,       INTENT(IN)  :: DataHandle
1139  CHARACTER*(*) :: Element
1140  CHARACTER*(*) :: VarName
1141  real ,            INTENT(IN) :: Data(*)
1142  INTEGER ,       INTENT(IN)  :: Count
1143  INTEGER ,       INTENT(OUT) :: Status
1144RETURN
1145END SUBROUTINE ext_int_put_var_ti_real
1146
1147!--- get_var_ti_double
1148SUBROUTINE ext_int_get_var_ti_double ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1149  IMPLICIT NONE
1150  INTEGER ,       INTENT(IN)  :: DataHandle
1151  CHARACTER*(*) :: Element
1152  CHARACTER*(*) :: VarName
1153  real*8 ,            INTENT(OUT) :: Data(*)
1154  INTEGER ,       INTENT(IN)  :: Count
1155  INTEGER ,       INTENT(OUT)  :: OutCount
1156  INTEGER ,       INTENT(OUT) :: Status
1157    CALL wrf_error_fatal('ext_int_get_var_ti_double not supported yet')
1158RETURN
1159END SUBROUTINE ext_int_get_var_ti_double
1160
1161!--- put_var_ti_double
1162SUBROUTINE ext_int_put_var_ti_double ( DataHandle,Element,  Varname, Data, Count,  Status )
1163  IMPLICIT NONE
1164  INTEGER ,       INTENT(IN)  :: DataHandle
1165  CHARACTER*(*) :: Element
1166  CHARACTER*(*) :: VarName
1167  real*8 ,            INTENT(IN) :: Data(*)
1168  INTEGER ,       INTENT(IN)  :: Count
1169  INTEGER ,       INTENT(OUT) :: Status
1170    CALL wrf_error_fatal('ext_int_put_var_ti_double not supported yet')
1171RETURN
1172END SUBROUTINE ext_int_put_var_ti_double
1173
1174!--- get_var_ti_integer
1175SUBROUTINE ext_int_get_var_ti_integer ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1176  IMPLICIT NONE
1177  INTEGER ,       INTENT(IN)  :: DataHandle
1178  CHARACTER*(*) :: Element
1179  CHARACTER*(*) :: VarName
1180  integer ,            INTENT(OUT) :: Data(*)
1181  INTEGER ,       INTENT(IN)  :: Count
1182  INTEGER ,       INTENT(OUT)  :: OutCount
1183  INTEGER ,       INTENT(OUT) :: Status
1184RETURN
1185END SUBROUTINE ext_int_get_var_ti_integer
1186
1187!--- put_var_ti_integer
1188SUBROUTINE ext_int_put_var_ti_integer ( DataHandle,Element,  Varname, Data, Count,  Status )
1189  IMPLICIT NONE
1190  INTEGER ,       INTENT(IN)  :: DataHandle
1191  CHARACTER*(*) :: Element
1192  CHARACTER*(*) :: VarName
1193  integer ,            INTENT(IN) :: Data(*)
1194  INTEGER ,       INTENT(IN)  :: Count
1195  INTEGER ,       INTENT(OUT) :: Status
1196RETURN
1197END SUBROUTINE ext_int_put_var_ti_integer
1198
1199!--- get_var_ti_logical
1200SUBROUTINE ext_int_get_var_ti_logical ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1201  IMPLICIT NONE
1202  INTEGER ,       INTENT(IN)  :: DataHandle
1203  CHARACTER*(*) :: Element
1204  CHARACTER*(*) :: VarName
1205  logical ,            INTENT(OUT) :: Data(*)
1206  INTEGER ,       INTENT(IN)  :: Count
1207  INTEGER ,       INTENT(OUT)  :: OutCount
1208  INTEGER ,       INTENT(OUT) :: Status
1209RETURN
1210END SUBROUTINE ext_int_get_var_ti_logical
1211
1212!--- put_var_ti_logical
1213SUBROUTINE ext_int_put_var_ti_logical ( DataHandle,Element,  Varname, Data, Count,  Status )
1214  IMPLICIT NONE
1215  INTEGER ,       INTENT(IN)  :: DataHandle
1216  CHARACTER*(*) :: Element
1217  CHARACTER*(*) :: VarName
1218  logical ,            INTENT(IN) :: Data(*)
1219  INTEGER ,       INTENT(IN)  :: Count
1220  INTEGER ,       INTENT(OUT) :: Status
1221RETURN
1222END SUBROUTINE ext_int_put_var_ti_logical
1223
1224!--- get_var_ti_char
1225SUBROUTINE ext_int_get_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
1226  USE module_ext_internal
1227  IMPLICIT NONE
1228  INCLUDE 'intio_tags.h'
1229  INTEGER ,       INTENT(IN)  :: DataHandle
1230  CHARACTER*(*) :: Element
1231  CHARACTER*(*) :: VarName
1232  CHARACTER*(*) :: Data
1233  INTEGER ,       INTENT(OUT) :: Status
1234  INTEGER locDataHandle, code
1235  CHARACTER*132 locElement, locVarName
1236  IF ( int_valid_handle (DataHandle) ) THEN
1237    IF ( int_handle_in_use( DataHandle ) ) THEN
1238      READ( unit=DataHandle ) hdrbuf
1239      IF ( hdrbuf(2) .EQ. int_var_ti_char ) THEN
1240        CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
1241                                locDataHandle, locElement, locVarName, Data, code )
1242        IF ( .NOT. ( code .EQ. int_var_ti_real    .OR.   code .EQ. int_var_ti_logical .OR. &
1243                     code .EQ. int_var_ti_char    .OR.   code .EQ. int_var_ti_double ) ) THEN
1244            BACKSPACE ( unit=DataHandle )
1245            Status = 1
1246            return
1247        ENDIF
1248      ELSE
1249        BACKSPACE ( unit=DataHandle )
1250        Status = 1
1251        return
1252      ENDIF
1253    ELSE
1254      Status = 1
1255      return
1256    ENDIF
1257  ELSE
1258    Status = 1
1259    return
1260  ENDIF
1261  Status = 0
1262RETURN
1263END SUBROUTINE ext_int_get_var_ti_char
1264
1265!--- put_var_ti_char
1266SUBROUTINE ext_int_put_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
1267  USE module_ext_internal
1268  IMPLICIT NONE
1269  INCLUDE 'intio_tags.h'
1270  INTEGER ,       INTENT(IN)  :: DataHandle
1271  CHARACTER*(*) :: Element
1272  CHARACTER*(*) :: VarName
1273  CHARACTER*(*) :: Data
1274  INTEGER ,       INTENT(OUT) :: Status
1275  REAL dummy
1276  INTEGER                 :: Count
1277  IF ( int_valid_handle (DataHandle) ) THEN
1278    IF ( int_handle_in_use( DataHandle ) ) THEN
1279      CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
1280                              DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char )
1281      WRITE( unit=DataHandle ) hdrbuf
1282    ENDIF
1283  ENDIF
1284  Status = 0
1285RETURN
1286END SUBROUTINE ext_int_put_var_ti_char
1287
1288!--- get_var_td_real
1289SUBROUTINE ext_int_get_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1290  IMPLICIT NONE
1291  INTEGER ,       INTENT(IN)  :: DataHandle
1292  CHARACTER*(*) :: Element
1293  CHARACTER*(*) :: DateStr
1294  CHARACTER*(*) :: VarName
1295  real ,            INTENT(OUT) :: Data(*)
1296  INTEGER ,       INTENT(IN)  :: Count
1297  INTEGER ,       INTENT(OUT)  :: OutCount
1298  INTEGER ,       INTENT(OUT) :: Status
1299RETURN
1300END SUBROUTINE ext_int_get_var_td_real
1301
1302!--- put_var_td_real
1303SUBROUTINE ext_int_put_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1304  IMPLICIT NONE
1305  INTEGER ,       INTENT(IN)  :: DataHandle
1306  CHARACTER*(*) :: Element
1307  CHARACTER*(*) :: DateStr
1308  CHARACTER*(*) :: VarName
1309  real ,            INTENT(IN) :: Data(*)
1310  INTEGER ,       INTENT(IN)  :: Count
1311  INTEGER ,       INTENT(OUT) :: Status
1312RETURN
1313END SUBROUTINE ext_int_put_var_td_real
1314
1315!--- get_var_td_double
1316SUBROUTINE ext_int_get_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1317  IMPLICIT NONE
1318  INTEGER ,       INTENT(IN)  :: DataHandle
1319  CHARACTER*(*) :: Element
1320  CHARACTER*(*) :: DateStr
1321  CHARACTER*(*) :: VarName
1322  real*8 ,            INTENT(OUT) :: Data(*)
1323  INTEGER ,       INTENT(IN)  :: Count
1324  INTEGER ,       INTENT(OUT)  :: OutCount
1325  INTEGER ,       INTENT(OUT) :: Status
1326    CALL wrf_error_fatal('ext_int_get_var_td_double not supported yet')
1327RETURN
1328END SUBROUTINE ext_int_get_var_td_double
1329
1330!--- put_var_td_double
1331SUBROUTINE ext_int_put_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1332  IMPLICIT NONE
1333  INTEGER ,       INTENT(IN)  :: DataHandle
1334  CHARACTER*(*) :: Element
1335  CHARACTER*(*) :: DateStr
1336  CHARACTER*(*) :: VarName
1337  real*8 ,            INTENT(IN) :: Data(*)
1338  INTEGER ,       INTENT(IN)  :: Count
1339  INTEGER ,       INTENT(OUT) :: Status
1340    CALL wrf_error_fatal('ext_int_put_var_td_double not supported yet')
1341RETURN
1342END SUBROUTINE ext_int_put_var_td_double
1343
1344!--- get_var_td_integer
1345SUBROUTINE ext_int_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1346  IMPLICIT NONE
1347  INTEGER ,       INTENT(IN)  :: DataHandle
1348  CHARACTER*(*) :: Element
1349  CHARACTER*(*) :: DateStr
1350  CHARACTER*(*) :: VarName
1351  integer ,            INTENT(OUT) :: Data(*)
1352  INTEGER ,       INTENT(IN)  :: Count
1353  INTEGER ,       INTENT(OUT)  :: OutCount
1354  INTEGER ,       INTENT(OUT) :: Status
1355RETURN
1356END SUBROUTINE ext_int_get_var_td_integer
1357
1358!--- put_var_td_integer
1359SUBROUTINE ext_int_put_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1360  IMPLICIT NONE
1361  INTEGER ,       INTENT(IN)  :: DataHandle
1362  CHARACTER*(*) :: Element
1363  CHARACTER*(*) :: DateStr
1364  CHARACTER*(*) :: VarName
1365  integer ,            INTENT(IN) :: Data(*)
1366  INTEGER ,       INTENT(IN)  :: Count
1367  INTEGER ,       INTENT(OUT) :: Status
1368RETURN
1369END SUBROUTINE ext_int_put_var_td_integer
1370
1371!--- get_var_td_logical
1372SUBROUTINE ext_int_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1373  IMPLICIT NONE
1374  INTEGER ,       INTENT(IN)  :: DataHandle
1375  CHARACTER*(*) :: Element
1376  CHARACTER*(*) :: DateStr
1377  CHARACTER*(*) :: VarName
1378  logical ,            INTENT(OUT) :: Data(*)
1379  INTEGER ,       INTENT(IN)  :: Count
1380  INTEGER ,       INTENT(OUT)  :: OutCount
1381  INTEGER ,       INTENT(OUT) :: Status
1382RETURN
1383END SUBROUTINE ext_int_get_var_td_logical
1384
1385!--- put_var_td_logical
1386SUBROUTINE ext_int_put_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1387  IMPLICIT NONE
1388  INTEGER ,       INTENT(IN)  :: DataHandle
1389  CHARACTER*(*) :: Element
1390  CHARACTER*(*) :: DateStr
1391  CHARACTER*(*) :: VarName
1392  logical ,            INTENT(IN) :: Data(*)
1393  INTEGER ,       INTENT(IN)  :: Count
1394  INTEGER ,       INTENT(OUT) :: Status
1395RETURN
1396END SUBROUTINE ext_int_put_var_td_logical
1397
1398!--- get_var_td_char
1399SUBROUTINE ext_int_get_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
1400  IMPLICIT NONE
1401  INTEGER ,       INTENT(IN)  :: DataHandle
1402  CHARACTER*(*) :: Element
1403  CHARACTER*(*) :: DateStr
1404  CHARACTER*(*) :: VarName
1405  CHARACTER*(*) :: Data
1406  INTEGER ,       INTENT(OUT) :: Status
1407RETURN
1408END SUBROUTINE ext_int_get_var_td_char
1409
1410!--- put_var_td_char
1411SUBROUTINE ext_int_put_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
1412  IMPLICIT NONE
1413  INTEGER ,       INTENT(IN)  :: DataHandle
1414  CHARACTER*(*) :: Element
1415  CHARACTER*(*) :: DateStr
1416  CHARACTER*(*) :: VarName
1417  CHARACTER*(*) :: Data
1418  INTEGER ,       INTENT(OUT) :: Status
1419RETURN
1420END SUBROUTINE ext_int_put_var_td_char
1421
1422!--- read_field
1423SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
1424                            DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1425                            DomainStart , DomainEnd ,                                    &
1426                            MemoryStart , MemoryEnd ,                                    &
1427                            PatchStart , PatchEnd ,                                      &
1428                            Status )
1429  USE module_ext_internal
1430  IMPLICIT NONE
1431#include "wrf_io_flags.h"
1432  include 'intio_tags.h'
1433  INTEGER ,       INTENT(IN)    :: DataHandle
1434  CHARACTER*(*) :: DateStr
1435  CHARACTER*(*) :: VarName
1436  integer                       ,intent(inout)    :: FieldType
1437  integer                       ,intent(inout) :: Comm
1438  integer                       ,intent(inout) :: IOComm
1439  integer                       ,intent(inout)    :: DomainDesc
1440  character*(*)                 ,intent(inout)    :: MemoryOrder
1441  character*(*)                 ,intent(inout)    :: Stagger
1442  character*(*) , dimension (*) ,intent(inout)    :: DimNames
1443  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
1444  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
1445  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
1446  integer                       ,intent(out)   :: Status
1447
1448!local
1449  INTEGER                        :: locDataHandle
1450  CHARACTER*132                  :: locDateStr
1451  CHARACTER*132                  :: locVarName
1452  integer                        :: locFieldType
1453  integer                        :: locComm
1454  integer                        :: locIOComm
1455  integer                        :: locDomainDesc
1456  character*132                  :: locMemoryOrder
1457  character*132                  :: locStagger
1458  character*132 , dimension (3)  :: locDimNames
1459  integer ,dimension(3)          :: locDomainStart, locDomainEnd
1460  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
1461  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
1462
1463  character*132 mess
1464
1465  integer ii,jj,kk,myrank
1466
1467
1468  REAL, DIMENSION(*)    :: Field
1469
1470  INTEGER inttypesize, realtypesize, istat, code
1471
1472  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
1473    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: invalid data handle" )
1474  ENDIF
1475  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
1476    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: DataHandle not opened" )
1477  ENDIF
1478
1479  inttypesize = itypesize
1480  realtypesize = rtypesize
1481
1482  DO WHILE ( .TRUE. )
1483    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
1484    IF ( istat .EQ. 0 ) THEN
1485      code = hdrbuf(2)
1486      IF ( code .EQ. int_field ) THEN
1487        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
1488                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
1489                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
1490                                 locDomainStart , locDomainEnd ,                                    &
1491                                 locMemoryStart , locMemoryEnd ,                                    &
1492                                 locPatchStart , locPatchEnd )
1493        IF ( TRIM(locVarName) .EQ. TRIM(VarName) ) THEN
1494          IF      ( FieldType .EQ. WRF_REAL ) THEN
1495            CALL rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1496          ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1497            CALL ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1498          ELSE
1499            CALL wrf_message('io_int.F90: ext_int_read_field: types other than WRF_REAL not supported yet')
1500            READ( unit=DataHandle )
1501          ENDIF
1502        ELSE
1503          WRITE(mess,*)'ext_int_read_field: ',TRIM(locVarName),' NE ',TRIM(VarName)
1504          CALL wrf_message(mess)
1505          READ( unit=DataHandle )
1506        ENDIF
1507        Status = 0
1508        GOTO 7717
1509      ENDIF
1510    ELSE
1511      Status = 1
1512      GOTO 7717
1513    ENDIF
1514  ENDDO
1515
15167717 CONTINUE
1517
1518  first_operation( DataHandle ) = .FALSE.
1519  RETURN
1520
1521END SUBROUTINE ext_int_read_field
1522
1523!--- write_field
1524SUBROUTINE ext_int_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
1525                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1526                             DomainStart , DomainEnd ,                                    &
1527                             MemoryStart , MemoryEnd ,                                    &
1528                             PatchStart , PatchEnd ,                                      &
1529                             Status )
1530  USE module_ext_internal
1531  IMPLICIT NONE
1532#include "wrf_io_flags.h"
1533  INTEGER ,       INTENT(IN)    :: DataHandle
1534  CHARACTER*(*) :: DateStr
1535  CHARACTER*(*) :: VarName
1536  integer                       ,intent(in)    :: FieldType
1537  integer                       ,intent(inout) :: Comm
1538  integer                       ,intent(inout) :: IOComm
1539  integer                       ,intent(in)    :: DomainDesc
1540  character*(*)                 ,intent(in)    :: MemoryOrder
1541  character*(*)                 ,intent(in)    :: Stagger
1542  character*(*) , dimension (*) ,intent(in)    :: DimNames
1543  integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
1544  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
1545  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
1546  integer                       ,intent(out)   :: Status
1547
1548  integer ii,jj,kk,myrank
1549
1550!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1551!                   MemoryStart(2):MemoryEnd(2), &
1552!                   MemoryStart(3):MemoryEnd(3) ) :: Field
1553
1554  REAL, DIMENSION(*)    :: Field
1555
1556  INTEGER inttypesize, realtypesize
1557
1558  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
1559    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: invalid data handle" )
1560  ENDIF
1561  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
1562    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: DataHandle not opened" )
1563  ENDIF
1564
1565  inttypesize = itypesize
1566  realtypesize = rtypesize
1567  IF      ( FieldType .EQ. WRF_REAL .OR. FieldType .EQ. WRF_DOUBLE) THEN
1568    typesize = rtypesize
1569  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
1570    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_DOUBLE not yet supported')
1571  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1572    typesize = itypesize
1573  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
1574    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_LOGICAL not yet supported')
1575  ENDIF
1576
1577  IF ( okay_for_io( DataHandle ) ) THEN
1578
1579    CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
1580                             DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
1581                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1582                             DomainStart , DomainEnd ,                                    &
1583                             MemoryStart , MemoryEnd ,                                    &
1584                             PatchStart , PatchEnd )
1585    WRITE( unit=DataHandle ) hdrbuf
1586    IF      ( FieldType .EQ. WRF_REAL ) THEN
1587      CALL rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1588    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1589      CALL ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1590    ENDIF
1591  ENDIF
1592  first_operation( DataHandle ) = .FALSE.
1593  Status = 0
1594  RETURN
1595END SUBROUTINE ext_int_write_field
1596
1597SUBROUTINE rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1598  INTEGER ,       INTENT(IN)    :: DataHandle
1599  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1600  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1601  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1602                   MemoryStart(2):MemoryEnd(2), &
1603                   MemoryStart(3):MemoryEnd(3) ) :: Field
1604  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1605  RETURN
1606END SUBROUTINE rfieldwrite
1607
1608SUBROUTINE ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1609  INTEGER ,       INTENT(IN)    :: DataHandle
1610  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1611  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1612  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1613                      MemoryStart(2):MemoryEnd(2), &
1614                      MemoryStart(3):MemoryEnd(3) ) :: Field
1615  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1616  RETURN
1617END SUBROUTINE ifieldwrite
1618
1619SUBROUTINE rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1620  INTEGER ,       INTENT(IN)    :: DataHandle
1621  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1622  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1623  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1624                   MemoryStart(2):MemoryEnd(2), &
1625                   MemoryStart(3):MemoryEnd(3) ) :: Field
1626  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1627  RETURN
1628END SUBROUTINE rfieldread
1629
1630SUBROUTINE ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1631  INTEGER ,       INTENT(IN)    :: DataHandle
1632  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1633  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1634  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1635                      MemoryStart(2):MemoryEnd(2), &
1636                      MemoryStart(3):MemoryEnd(3) ) :: Field
1637  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1638  RETURN
1639END SUBROUTINE ifieldread
1640
Note: See TracBrowser for help on using the repository browser.