source: trunk/WRF.COMMON/WRFV2/external/io_int/io_int.F90 @ 3567

Last change on this file since 3567 was 11, checked in by aslmd, 14 years ago

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