source: lmdz_wrf/trunk/WRFV3/external/io_int/io_int.F90 @ 1393

Last change on this file since 1393 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 60.3 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      else
547          WRITE(mess,*)'skipping a code=',code,' in ext_int_get_var_info'
548          CALL wrf_message(mess)
549      ENDIF
550    ELSE
551      Status = 1
552      GOTO 7717
553    ENDIF
554  ENDDO
5557717 CONTINUE
556
557RETURN
558END SUBROUTINE ext_int_get_var_info
559
560!--- get_next_var
561SUBROUTINE ext_int_get_next_var ( DataHandle, VarName, Status )
562  USE module_ext_internal
563  IMPLICIT NONE
564  include 'intio_tags.h'
565  include 'wrf_status_codes.h'
566  INTEGER ,       INTENT(IN)  :: DataHandle
567  CHARACTER*(*) :: VarName
568  INTEGER ,       INTENT(OUT) :: Status
569
570!local
571  INTEGER                        :: locDataHandle
572  CHARACTER*132                  :: locDateStr
573  CHARACTER*132                  :: locVarName
574  integer                        :: locFieldType
575  integer                        :: locComm
576  integer                        :: locIOComm
577  integer                        :: locDomainDesc
578  character*132                  :: locMemoryOrder
579  character*132                  :: locStagger
580  character*132 , dimension (3)  :: locDimNames
581  integer ,dimension(3)          :: locDomainStart, locDomainEnd
582  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
583  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
584
585character*128 locElement, strData, dumstr
586integer loccode, loccount
587integer idata(128)
588real    rdata(128)
589
590  character*132 mess
591  integer ii,jj,kk,myrank
592  INTEGER inttypesize, realtypesize, istat, code
593  REAL, DIMENSION(1)    :: Field  ! dummy
594
595  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
596    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: invalid data handle" )
597  ENDIF
598  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
599    CALL wrf_error_fatal("io_int.F90: ext_int_get_next_var: DataHandle not opened" )
600  ENDIF
601  inttypesize = itypesize
602  realtypesize = rtypesize
603  DO WHILE ( .TRUE. )
6047727 CONTINUE
605    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
606    IF ( istat .EQ. 0 ) THEN
607      code = hdrbuf(2)
608#if 1
609      IF ( code .EQ. int_dom_ti_char ) THEN
610        CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
611                                         locDataHandle, locElement, dumstr, strData, loccode )
612      ENDIF
613      IF ( code .EQ. int_dom_ti_integer ) THEN
614        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
615                                locDataHandle, locElement, iData, loccount, code )
616      ENDIF
617      IF ( code .EQ. int_dom_ti_real ) THEN
618        CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
619                                locDataHandle, locElement, rData, loccount, code )
620      ENDIF
621#endif
622      IF ( code .EQ. int_field ) THEN
623        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
624                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
625                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
626                                 locDomainStart , locDomainEnd ,                                    &
627                                 locMemoryStart , locMemoryEnd ,                                    &
628                                 locPatchStart , locPatchEnd )
629
630        IF (TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle))) THEN
631          Status = WRF_WARN_VAR_EOF !-6 ! signal past last var in time frame
632          BACKSPACE ( unit=DataHandle )
633          last_next_var( DataHandle )  = ""
634          GOTO 7717
635        ELSE
636          VarName = TRIM(locVarName)
637          IF ( last_next_var( DataHandle )  .NE. VarName ) THEN
638            BACKSPACE ( unit=DataHandle )
639            last_next_var( DataHandle )  = VarName
640          ELSE
641            READ( unit=DataHandle, iostat=istat )
642            GOTO 7727
643          ENDIF
644          Status = 0
645          GOTO 7717
646        ENDIF
647      ELSE
648        GOTO 7727
649      ENDIF
650    ELSE
651      Status = 1
652      GOTO 7717
653    ENDIF
654  ENDDO
6557717 CONTINUE
656  RETURN
657END SUBROUTINE ext_int_get_next_var
658
659!--- get_dom_ti_real
660SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element,   Data, Count, Outcount, Status )
661  USE module_ext_internal
662  IMPLICIT NONE
663  INCLUDE 'intio_tags.h'
664  INTEGER ,       INTENT(IN)  :: DataHandle
665  CHARACTER*(*) :: Element
666  REAL ,          INTENT(OUT) :: Data(*)
667  INTEGER ,       INTENT(IN)  :: Count
668  INTEGER ,       INTENT(OUT) :: Outcount
669  INTEGER ,       INTENT(OUT) :: Status
670  INTEGER loccount, code, istat, locDataHandle
671  CHARACTER*132                :: locElement, mess
672  LOGICAL keepgoing
673
674  Status = 0
675  IF ( int_valid_handle( DataHandle ) ) THEN
676    IF ( int_handle_in_use( DataHandle ) ) THEN
677     ! Do nothing unless it is time to read time-independent domain metadata.
678     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
679      keepgoing = .true.
680      DO WHILE ( keepgoing )
681        READ( unit=DataHandle , iostat = istat ) hdrbuf
682        IF ( istat .EQ. 0 ) THEN
683          code = hdrbuf(2)
684          IF ( code .EQ. int_dom_ti_real ) THEN
685            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
686                                    locDataHandle, locElement, Data, loccount, code )
687            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
688              IF ( loccount .GT. Count ) THEN
689                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_real: loccount .GT. Count' )
690              ENDIF
691              keepgoing = .false. ;  Status = 0
692            ENDIF
693          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_logical .OR. &
694                            code .EQ. int_dom_ti_char    .OR. code .EQ. int_dom_ti_double  .OR. &
695                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_logical .OR. &
696                            code .EQ. int_dom_td_char    .OR. code .EQ. int_dom_td_double  .OR. &
697                            code .EQ. int_dom_td_real                                  ) ) THEN
698            BACKSPACE ( unit=DataHandle )
699            keepgoing = .false. ; Status = 2
700          ENDIF
701        ELSE
702          keepgoing = .false. ; Status = 1
703        ENDIF
704      ENDDO
705     ENDIF
706    ENDIF
707  ENDIF
708RETURN
709END SUBROUTINE ext_int_get_dom_ti_real
710
711!--- put_dom_ti_real
712SUBROUTINE ext_int_put_dom_ti_real ( DataHandle,Element,   Data, Count,  Status )
713  USE module_ext_internal
714  IMPLICIT NONE
715  INCLUDE 'intio_tags.h'
716  INTEGER ,       INTENT(IN)  :: DataHandle
717  CHARACTER*(*) :: Element
718  REAL ,          INTENT(IN) :: Data(*)
719  INTEGER ,       INTENT(IN)  :: Count
720  INTEGER ,       INTENT(OUT) :: Status
721  REAL dummy
722!
723
724  IF ( int_valid_handle( DataHandle ) ) THEN
725    IF ( int_handle_in_use( DataHandle ) ) THEN
726      ! Do nothing unless it is time to write time-independent domain metadata.
727      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
728        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
729                                DataHandle, Element, Data, Count, int_dom_ti_real )
730        WRITE( unit=DataHandle ) hdrbuf
731      ENDIF
732    ENDIF
733  ENDIF
734  Status = 0
735RETURN
736END SUBROUTINE ext_int_put_dom_ti_real
737
738!--- get_dom_ti_double
739SUBROUTINE ext_int_get_dom_ti_double ( DataHandle,Element,   Data, Count, Outcount, Status )
740  USE module_ext_internal
741  IMPLICIT NONE
742  INTEGER ,       INTENT(IN)  :: DataHandle
743  CHARACTER*(*) :: Element
744  real*8 ,            INTENT(OUT) :: Data(*)
745  INTEGER ,       INTENT(IN)  :: Count
746  INTEGER ,       INTENT(OUT)  :: OutCount
747  INTEGER ,       INTENT(OUT) :: Status
748  ! Do nothing unless it is time to read time-independent domain metadata.
749  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
750    CALL wrf_error_fatal('ext_int_get_dom_ti_double not supported yet')
751  ENDIF
752RETURN
753END SUBROUTINE ext_int_get_dom_ti_double
754
755!--- put_dom_ti_double
756SUBROUTINE ext_int_put_dom_ti_double ( DataHandle,Element,   Data, Count,  Status )
757  USE module_ext_internal
758  IMPLICIT NONE
759  INTEGER ,       INTENT(IN)  :: DataHandle
760  CHARACTER*(*) :: Element
761  real*8 ,            INTENT(IN) :: Data(*)
762  INTEGER ,       INTENT(IN)  :: Count
763  INTEGER ,       INTENT(OUT) :: Status
764  ! Do nothing unless it is time to write time-independent domain metadata.
765  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
766    CALL wrf_error_fatal('ext_int_put_dom_ti_double not supported yet')
767  ENDIF
768RETURN
769END SUBROUTINE ext_int_put_dom_ti_double
770
771!--- get_dom_ti_integer
772SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element,   Data, Count, Outcount, Status )
773  USE module_ext_internal
774  IMPLICIT NONE
775  INCLUDE 'intio_tags.h'
776  INTEGER ,       INTENT(IN)  :: DataHandle
777  CHARACTER*(*) :: Element
778  integer ,            INTENT(OUT) :: Data(*)
779  INTEGER ,       INTENT(IN)  :: Count
780  INTEGER ,       INTENT(OUT)  :: OutCount
781  INTEGER ,       INTENT(OUT) :: Status
782  INTEGER loccount, code, istat, locDataHandle
783  CHARACTER*132   locElement, mess
784  LOGICAL keepgoing
785
786  Status = 0
787  IF ( int_valid_handle( DataHandle ) ) THEN
788    IF ( int_handle_in_use( DataHandle ) ) THEN
789     ! Do nothing unless it is time to read time-independent domain metadata.
790     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
791      keepgoing = .true.
792      DO WHILE ( keepgoing )
793        READ( unit=DataHandle , iostat = istat ) hdrbuf
794        IF ( istat .EQ. 0 ) THEN
795          code = hdrbuf(2)
796          IF ( code .EQ. int_dom_ti_integer ) THEN
797            CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, &
798                                    locDataHandle, locElement, Data, loccount, code )
799            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
800              IF ( loccount .GT. Count ) THEN
801                CALL wrf_error_fatal( 'io_int.F90: ext_int_get_dom_ti_integer: loccount .GT. Count' )
802              ENDIF
803              keepgoing = .false. ;  Status = 0
804            ENDIF
805
806          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR.   code .EQ. int_dom_ti_logical .OR. &
807                            code .EQ. int_dom_ti_char    .OR.   code .EQ. int_dom_ti_double  .OR. &
808                            code .EQ. int_dom_td_real    .OR.   code .EQ. int_dom_td_logical .OR. &
809                            code .EQ. int_dom_td_char    .OR.   code .EQ. int_dom_td_double  .OR. &
810                            code .EQ. int_dom_td_integer )                                           ) THEN
811            BACKSPACE ( unit=DataHandle )
812            keepgoing = .false. ; Status = 1
813          ENDIF
814        ELSE
815          keepgoing = .false. ; Status = 1
816        ENDIF
817      ENDDO
818     ENDIF
819    ENDIF
820  ENDIF
821RETURN
822END SUBROUTINE ext_int_get_dom_ti_integer
823
824!--- put_dom_ti_integer
825SUBROUTINE ext_int_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  Status )
826  USE module_ext_internal
827  IMPLICIT NONE
828  INCLUDE 'intio_tags.h'
829  INTEGER ,       INTENT(IN)  :: DataHandle
830  CHARACTER*(*) :: Element
831  INTEGER ,       INTENT(IN) :: Data(*)
832  INTEGER ,       INTENT(IN)  :: Count
833  INTEGER ,       INTENT(OUT) :: Status
834  REAL dummy
835!
836  IF ( int_valid_handle ( Datahandle ) ) THEN
837    IF ( int_handle_in_use( DataHandle ) ) THEN
838      ! Do nothing unless it is time to write time-independent domain metadata.
839      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
840        CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, itypesize, &
841                                DataHandle, Element, Data, Count, int_dom_ti_integer )
842        WRITE( unit=DataHandle ) hdrbuf
843      ENDIF
844    ENDIF
845  ENDIF
846  Status = 0
847RETURN
848END SUBROUTINE ext_int_put_dom_ti_integer
849
850!--- get_dom_ti_logical
851SUBROUTINE ext_int_get_dom_ti_logical ( DataHandle,Element,   Data, Count, Outcount, Status )
852  USE module_ext_internal
853  IMPLICIT NONE
854  INTEGER ,       INTENT(IN)  :: DataHandle
855  CHARACTER*(*) :: Element
856  logical ,            INTENT(OUT) :: Data(*)
857  INTEGER ,       INTENT(IN)  :: Count
858  INTEGER ,       INTENT(OUT)  :: OutCount
859  INTEGER ,       INTENT(OUT) :: Status
860  ! Do nothing unless it is time to read time-independent domain metadata.
861  IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
862    CALL wrf_message('ext_int_get_dom_ti_logical not supported yet')
863  ENDIF
864RETURN
865END SUBROUTINE ext_int_get_dom_ti_logical
866
867!--- put_dom_ti_logical
868SUBROUTINE ext_int_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  Status )
869  USE module_ext_internal
870  IMPLICIT NONE
871  INTEGER ,       INTENT(IN)  :: DataHandle
872  CHARACTER*(*) :: Element
873  logical ,            INTENT(IN) :: Data(*)
874  INTEGER ,       INTENT(IN)  :: Count
875  INTEGER ,       INTENT(OUT) :: Status
876  ! Do nothing unless it is time to write time-independent domain metadata.
877  IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
878    CALL wrf_message('ext_int_put_dom_ti_logical not supported yet')
879  ENDIF
880RETURN
881END SUBROUTINE ext_int_put_dom_ti_logical
882
883!--- get_dom_ti_char
884SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
885  USE module_ext_internal
886  IMPLICIT NONE
887  INCLUDE 'intio_tags.h'
888  INTEGER ,       INTENT(IN)  :: DataHandle
889  CHARACTER*(*) :: Element
890  CHARACTER*(*) :: Data
891  INTEGER ,       INTENT(OUT) :: Status
892  INTEGER istat, code, i
893  CHARACTER*79 dumstr, locElement
894  INTEGER locDataHandle
895  LOGICAL keepgoing
896
897  Status = 0
898  IF ( int_valid_handle( DataHandle ) ) THEN
899    IF ( int_handle_in_use( DataHandle ) ) THEN
900     ! Do nothing unless it is time to read time-independent domain metadata.
901     IF ( int_ok_to_get_dom_ti( DataHandle ) ) THEN
902      keepgoing = .true.
903      DO WHILE ( keepgoing )
904        READ( unit=DataHandle , iostat = istat ) hdrbuf
905
906        IF ( istat .EQ. 0 ) THEN
907          code = hdrbuf(2)
908          IF ( code .EQ. int_dom_ti_char ) THEN
909            CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
910                                         locDataHandle, locElement, dumstr, Data, code )
911            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
912              keepgoing = .false. ;  Status = 0
913            ENDIF
914          ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real    .OR. code .EQ. int_dom_ti_logical .OR. &
915                            code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_double  .OR. &
916                            code .EQ. int_dom_td_real    .OR. code .EQ. int_dom_td_logical .OR. &
917                            code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_double  .OR. &
918                            code .EQ. int_dom_td_char                                             ) ) THEN
919            BACKSPACE ( unit=DataHandle )
920            keepgoing = .false. ; Status = 1
921          ENDIF
922        ELSE
923          keepgoing = .false. ; Status = 1
924        ENDIF
925      ENDDO
926     ENDIF
927    ENDIF
928  ENDIF
929RETURN
930END SUBROUTINE ext_int_get_dom_ti_char
931
932!--- put_dom_ti_char
933SUBROUTINE ext_int_put_dom_ti_char ( DataHandle, Element,  Data,  Status )
934  USE module_ext_internal
935  IMPLICIT NONE
936  INCLUDE 'intio_tags.h'
937  INTEGER ,       INTENT(IN)  :: DataHandle
938  CHARACTER*(*) :: Element
939  CHARACTER*(*) :: Data
940  INTEGER ,       INTENT(OUT) :: Status
941  INTEGER i
942  REAL dummy
943  INTEGER                 :: Count
944
945  IF ( int_valid_handle ( Datahandle ) ) THEN
946    IF ( int_handle_in_use( DataHandle ) ) THEN
947      ! Do nothing unless it is time to write time-independent domain metadata.
948      IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN
949        CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
950                                     DataHandle, Element, "", Data, int_dom_ti_char )
951        WRITE( unit=DataHandle ) hdrbuf
952      ENDIF
953    ENDIF
954  ENDIF
955  Status = 0
956RETURN
957END SUBROUTINE ext_int_put_dom_ti_char
958
959!--- get_dom_td_real
960SUBROUTINE ext_int_get_dom_td_real ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
961  IMPLICIT NONE
962  INTEGER ,       INTENT(IN)  :: DataHandle
963  CHARACTER*(*) :: Element
964  CHARACTER*(*) :: DateStr
965  real ,            INTENT(OUT) :: Data(*)
966  INTEGER ,       INTENT(IN)  :: Count
967  INTEGER ,       INTENT(OUT)  :: OutCount
968  INTEGER ,       INTENT(OUT) :: Status
969RETURN
970END SUBROUTINE ext_int_get_dom_td_real
971
972!--- put_dom_td_real
973SUBROUTINE ext_int_put_dom_td_real ( DataHandle,Element, DateStr,  Data, Count,  Status )
974  IMPLICIT NONE
975  INTEGER ,       INTENT(IN)  :: DataHandle
976  CHARACTER*(*) :: Element
977  CHARACTER*(*) :: DateStr
978  real ,            INTENT(IN) :: Data(*)
979  INTEGER ,       INTENT(IN)  :: Count
980  INTEGER ,       INTENT(OUT) :: Status
981RETURN
982END SUBROUTINE ext_int_put_dom_td_real
983
984!--- get_dom_td_double
985SUBROUTINE ext_int_get_dom_td_double ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
986  IMPLICIT NONE
987  INTEGER ,       INTENT(IN)  :: DataHandle
988  CHARACTER*(*) :: Element
989  CHARACTER*(*) :: DateStr
990  real*8 ,            INTENT(OUT) :: Data(*)
991  INTEGER ,       INTENT(IN)  :: Count
992  INTEGER ,       INTENT(OUT)  :: OutCount
993  INTEGER ,       INTENT(OUT) :: Status
994    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
995RETURN
996END SUBROUTINE ext_int_get_dom_td_double
997
998!--- put_dom_td_double
999SUBROUTINE ext_int_put_dom_td_double ( DataHandle,Element, DateStr,  Data, Count,  Status )
1000  IMPLICIT NONE
1001  INTEGER ,       INTENT(IN)  :: DataHandle
1002  CHARACTER*(*) :: Element
1003  CHARACTER*(*) :: DateStr
1004  real*8 ,            INTENT(IN) :: Data(*)
1005  INTEGER ,       INTENT(IN)  :: Count
1006  INTEGER ,       INTENT(OUT) :: Status
1007    CALL wrf_error_fatal('ext_int_get_dom_td_double not supported yet')
1008RETURN
1009END SUBROUTINE ext_int_put_dom_td_double
1010
1011!--- get_dom_td_integer
1012SUBROUTINE ext_int_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
1013  IMPLICIT NONE
1014  INTEGER ,       INTENT(IN)  :: DataHandle
1015  CHARACTER*(*) :: Element
1016  CHARACTER*(*) :: DateStr
1017  integer ,            INTENT(OUT) :: Data(*)
1018  INTEGER ,       INTENT(IN)  :: Count
1019  INTEGER ,       INTENT(OUT)  :: OutCount
1020  INTEGER ,       INTENT(OUT) :: Status
1021RETURN
1022END SUBROUTINE ext_int_get_dom_td_integer
1023
1024!--- put_dom_td_integer
1025SUBROUTINE ext_int_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, Count,  Status )
1026  IMPLICIT NONE
1027  INTEGER ,       INTENT(IN)  :: DataHandle
1028  CHARACTER*(*) :: Element
1029  CHARACTER*(*) :: DateStr
1030  integer ,            INTENT(IN) :: Data(*)
1031  INTEGER ,       INTENT(IN)  :: Count
1032  INTEGER ,       INTENT(OUT) :: Status
1033RETURN
1034END SUBROUTINE ext_int_put_dom_td_integer
1035
1036!--- get_dom_td_logical
1037SUBROUTINE ext_int_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
1038  IMPLICIT NONE
1039  INTEGER ,       INTENT(IN)  :: DataHandle
1040  CHARACTER*(*) :: Element
1041  CHARACTER*(*) :: DateStr
1042  logical ,            INTENT(OUT) :: Data(*)
1043  INTEGER ,       INTENT(IN)  :: Count
1044  INTEGER ,       INTENT(OUT)  :: OutCount
1045  INTEGER ,       INTENT(OUT) :: Status
1046RETURN
1047END SUBROUTINE ext_int_get_dom_td_logical
1048
1049!--- put_dom_td_logical
1050SUBROUTINE ext_int_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, Count,  Status )
1051  IMPLICIT NONE
1052  INTEGER ,       INTENT(IN)  :: DataHandle
1053  CHARACTER*(*) :: Element
1054  CHARACTER*(*) :: DateStr
1055  logical ,            INTENT(IN) :: Data(*)
1056  INTEGER ,       INTENT(IN)  :: Count
1057  INTEGER ,       INTENT(OUT) :: Status
1058RETURN
1059END SUBROUTINE ext_int_put_dom_td_logical
1060
1061!--- get_dom_td_char
1062SUBROUTINE ext_int_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
1063  USE module_ext_internal
1064  IMPLICIT NONE
1065  INCLUDE 'intio_tags.h'
1066  INTEGER ,       INTENT(IN)  :: DataHandle
1067  CHARACTER*(*) :: Element
1068  CHARACTER*(*) :: Data, DateStr
1069  INTEGER ,       INTENT(OUT) :: Status
1070  INTEGER istat, code, i
1071  CHARACTER*79 dumstr, locElement, locDatestr
1072  INTEGER locDataHandle
1073  LOGICAL keepgoing
1074
1075  IF ( int_valid_handle( DataHandle ) ) THEN
1076    IF ( int_handle_in_use( DataHandle ) ) THEN
1077      keepgoing = .true.
1078      DO WHILE ( keepgoing )
1079        READ( unit=DataHandle , iostat = istat ) hdrbuf
1080
1081        IF ( istat .EQ. 0 ) THEN
1082          code = hdrbuf(2)
1083          IF ( code .EQ. int_dom_td_char ) THEN
1084            CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
1085                                         locDataHandle, locDateStr, locElement, Data, code )
1086            IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN
1087              keepgoing = .false. ;  Status = 0
1088            ENDIF
1089          ELSE
1090            BACKSPACE ( unit=DataHandle )
1091            keepgoing = .false. ; Status = 1
1092          ENDIF
1093        ELSE
1094          keepgoing = .false. ; Status = 1
1095        ENDIF
1096      ENDDO
1097    ENDIF
1098  ENDIF
1099RETURN
1100END SUBROUTINE ext_int_get_dom_td_char
1101
1102!--- put_dom_td_char
1103SUBROUTINE ext_int_put_dom_td_char ( DataHandle,Element, DateStr,  Data,  Status )
1104  USE module_ext_internal
1105  IMPLICIT NONE
1106  INCLUDE 'intio_tags.h'
1107  INTEGER ,       INTENT(IN)  :: DataHandle
1108  CHARACTER*(*) :: Element
1109  CHARACTER*(*) :: Data, DateStr
1110  INTEGER ,       INTENT(OUT) :: Status
1111  INTEGER i
1112  REAL dummy
1113  INTEGER                 :: Count
1114  IF ( int_valid_handle ( Datahandle ) ) THEN
1115    IF ( int_handle_in_use( DataHandle ) ) THEN
1116      CALL int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize,  &
1117                                   DataHandle, DateStr, Element, Data, int_dom_td_char )
1118      WRITE( unit=DataHandle ) hdrbuf
1119    ENDIF
1120  ENDIF
1121  Status = 0
1122RETURN
1123END SUBROUTINE ext_int_put_dom_td_char
1124
1125!--- get_var_ti_real
1126SUBROUTINE ext_int_get_var_ti_real ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1127  IMPLICIT NONE
1128  INTEGER ,       INTENT(IN)  :: DataHandle
1129  CHARACTER*(*) :: Element
1130  CHARACTER*(*) :: VarName
1131  real ,            INTENT(OUT) :: Data(*)
1132  INTEGER ,       INTENT(IN)  :: Count
1133  INTEGER ,       INTENT(OUT)  :: OutCount
1134  INTEGER ,       INTENT(OUT) :: Status
1135RETURN
1136END SUBROUTINE ext_int_get_var_ti_real
1137
1138!--- put_var_ti_real
1139SUBROUTINE ext_int_put_var_ti_real ( DataHandle,Element,  Varname, Data, Count,  Status )
1140  IMPLICIT NONE
1141  INTEGER ,       INTENT(IN)  :: DataHandle
1142  CHARACTER*(*) :: Element
1143  CHARACTER*(*) :: VarName
1144  real ,            INTENT(IN) :: Data(*)
1145  INTEGER ,       INTENT(IN)  :: Count
1146  INTEGER ,       INTENT(OUT) :: Status
1147RETURN
1148END SUBROUTINE ext_int_put_var_ti_real
1149
1150!--- get_var_ti_double
1151SUBROUTINE ext_int_get_var_ti_double ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1152  IMPLICIT NONE
1153  INTEGER ,       INTENT(IN)  :: DataHandle
1154  CHARACTER*(*) :: Element
1155  CHARACTER*(*) :: VarName
1156  real*8 ,            INTENT(OUT) :: Data(*)
1157  INTEGER ,       INTENT(IN)  :: Count
1158  INTEGER ,       INTENT(OUT)  :: OutCount
1159  INTEGER ,       INTENT(OUT) :: Status
1160    CALL wrf_error_fatal('ext_int_get_var_ti_double not supported yet')
1161RETURN
1162END SUBROUTINE ext_int_get_var_ti_double
1163
1164!--- put_var_ti_double
1165SUBROUTINE ext_int_put_var_ti_double ( DataHandle,Element,  Varname, Data, Count,  Status )
1166  IMPLICIT NONE
1167  INTEGER ,       INTENT(IN)  :: DataHandle
1168  CHARACTER*(*) :: Element
1169  CHARACTER*(*) :: VarName
1170  real*8 ,            INTENT(IN) :: Data(*)
1171  INTEGER ,       INTENT(IN)  :: Count
1172  INTEGER ,       INTENT(OUT) :: Status
1173    CALL wrf_error_fatal('ext_int_put_var_ti_double not supported yet')
1174RETURN
1175END SUBROUTINE ext_int_put_var_ti_double
1176
1177!--- get_var_ti_integer
1178SUBROUTINE ext_int_get_var_ti_integer ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1179  USE module_ext_internal
1180  IMPLICIT NONE
1181#include "intio_tags.h"
1182  INTEGER ,       INTENT(IN)  :: DataHandle
1183  CHARACTER*(*) :: Element
1184  CHARACTER*(*) :: VarName
1185  integer ,            INTENT(OUT) :: Data(*)
1186  INTEGER ,       INTENT(IN)  :: Count
1187  INTEGER ,       INTENT(OUT)  :: OutCount
1188  INTEGER ,       INTENT(OUT) :: Status
1189  INTEGER locDataHandle, code
1190  CHARACTER*132 locElement, locVarName
1191  IF ( int_valid_handle (DataHandle) ) THEN
1192     IF ( int_handle_in_use( DataHandle ) ) THEN
1193        READ( unit=DataHandle ) hdrbuf
1194        code=hdrbuf(2)
1195        IF ( code .NE. int_var_ti_integer ) THEN
1196           BACKSPACE ( unit=DataHandle )
1197           write(*,*) 'unexpected code=',code,' in ext_int_get_var_ti_integer'
1198           Status = 1
1199           return
1200        ENDIF
1201        CALL int_get_ti_header_integer_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
1202             locDataHandle, locElement, locVarName, Data, Outcount, code )
1203     ELSE
1204        Status = 1
1205        write(*,*) 'int_handle_in_use(DataHandle)=.False. in ext_int_get_var_ti_integer'
1206        return
1207     ENDIF
1208  ELSE
1209     Status = 1
1210     write(*,*) 'int_valid_handle(DataHandle)=.False. in ext_int_get_var_ti_integer'
1211     return
1212  ENDIF
1213  Status = 0
1214RETURN
1215END SUBROUTINE ext_int_get_var_ti_integer
1216
1217!--- put_var_ti_integer
1218SUBROUTINE ext_int_put_var_ti_integer ( DataHandle,Element,  Varname, Data, Count,  Status )
1219  USE module_ext_internal
1220  IMPLICIT NONE
1221#include "intio_tags.h"
1222  INTEGER ,       INTENT(IN)  :: DataHandle
1223  CHARACTER*(*) :: Element
1224  CHARACTER*(*) :: VarName
1225  integer ,            INTENT(IN) :: Data(*)
1226  INTEGER ,       INTENT(IN)  :: Count
1227  INTEGER ,       INTENT(OUT) :: Status
1228  IF ( int_valid_handle (DataHandle) ) THEN
1229    IF ( int_handle_in_use( DataHandle ) ) THEN
1230      CALL int_gen_ti_header_integer_varname( hdrbuf, hdrbufsize, itypesize,4,  &
1231                              DataHandle, TRIM(Element), TRIM(VarName), Data, Count, &
1232                              int_var_ti_integer )
1233      WRITE( unit=DataHandle ) hdrbuf
1234    ENDIF
1235  ENDIF
1236  Status = 0
1237RETURN
1238END SUBROUTINE ext_int_put_var_ti_integer
1239
1240!--- get_var_ti_logical
1241SUBROUTINE ext_int_get_var_ti_logical ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
1242  IMPLICIT NONE
1243  INTEGER ,       INTENT(IN)  :: DataHandle
1244  CHARACTER*(*) :: Element
1245  CHARACTER*(*) :: VarName
1246  logical ,            INTENT(OUT) :: Data(*)
1247  INTEGER ,       INTENT(IN)  :: Count
1248  INTEGER ,       INTENT(OUT)  :: OutCount
1249  INTEGER ,       INTENT(OUT) :: Status
1250RETURN
1251END SUBROUTINE ext_int_get_var_ti_logical
1252
1253!--- put_var_ti_logical
1254SUBROUTINE ext_int_put_var_ti_logical ( DataHandle,Element,  Varname, Data, Count,  Status )
1255  IMPLICIT NONE
1256  INTEGER ,       INTENT(IN)  :: DataHandle
1257  CHARACTER*(*) :: Element
1258  CHARACTER*(*) :: VarName
1259  logical ,            INTENT(IN) :: Data(*)
1260  INTEGER ,       INTENT(IN)  :: Count
1261  INTEGER ,       INTENT(OUT) :: Status
1262RETURN
1263END SUBROUTINE ext_int_put_var_ti_logical
1264
1265!--- get_var_ti_char
1266SUBROUTINE ext_int_get_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  INTEGER locDataHandle, code
1276  CHARACTER*132 locElement, locVarName
1277  IF ( int_valid_handle (DataHandle) ) THEN
1278    IF ( int_handle_in_use( DataHandle ) ) THEN
1279      READ( unit=DataHandle ) hdrbuf
1280       code=hdrbuf(2)
1281       IF ( code .NE. int_var_ti_char ) THEN
1282          BACKSPACE ( unit=DataHandle )
1283          Status = 1
1284          return
1285       ENDIF
1286       CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
1287            locDataHandle, locElement, locVarName, Data, code )
1288    ELSE
1289       Status = 1
1290       return
1291    ENDIF
1292 ELSE
1293    Status = 1
1294    return
1295 ENDIF
1296  Status = 0
1297RETURN
1298END SUBROUTINE ext_int_get_var_ti_char
1299
1300!--- put_var_ti_char
1301SUBROUTINE ext_int_put_var_ti_char ( DataHandle,Element,  Varname, Data,  Status )
1302  USE module_ext_internal
1303  IMPLICIT NONE
1304  INCLUDE 'intio_tags.h'
1305  INTEGER ,       INTENT(IN)  :: DataHandle
1306  CHARACTER*(*) :: Element
1307  CHARACTER*(*) :: VarName
1308  CHARACTER*(*) :: Data
1309  INTEGER ,       INTENT(OUT) :: Status
1310  REAL dummy
1311  INTEGER                 :: Count
1312  IF ( int_valid_handle (DataHandle) ) THEN
1313    IF ( int_handle_in_use( DataHandle ) ) THEN
1314      CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize,  &
1315                              DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char )
1316      WRITE( unit=DataHandle ) hdrbuf
1317    ENDIF
1318  ENDIF
1319  Status = 0
1320RETURN
1321END SUBROUTINE ext_int_put_var_ti_char
1322
1323!--- get_var_td_real
1324SUBROUTINE ext_int_get_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1325  IMPLICIT NONE
1326  INTEGER ,       INTENT(IN)  :: DataHandle
1327  CHARACTER*(*) :: Element
1328  CHARACTER*(*) :: DateStr
1329  CHARACTER*(*) :: VarName
1330  real ,            INTENT(OUT) :: Data(*)
1331  INTEGER ,       INTENT(IN)  :: Count
1332  INTEGER ,       INTENT(OUT)  :: OutCount
1333  INTEGER ,       INTENT(OUT) :: Status
1334RETURN
1335END SUBROUTINE ext_int_get_var_td_real
1336
1337!--- put_var_td_real
1338SUBROUTINE ext_int_put_var_td_real ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1339  IMPLICIT NONE
1340  INTEGER ,       INTENT(IN)  :: DataHandle
1341  CHARACTER*(*) :: Element
1342  CHARACTER*(*) :: DateStr
1343  CHARACTER*(*) :: VarName
1344  real ,            INTENT(IN) :: Data(*)
1345  INTEGER ,       INTENT(IN)  :: Count
1346  INTEGER ,       INTENT(OUT) :: Status
1347RETURN
1348END SUBROUTINE ext_int_put_var_td_real
1349
1350!--- get_var_td_double
1351SUBROUTINE ext_int_get_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1352  IMPLICIT NONE
1353  INTEGER ,       INTENT(IN)  :: DataHandle
1354  CHARACTER*(*) :: Element
1355  CHARACTER*(*) :: DateStr
1356  CHARACTER*(*) :: VarName
1357  real*8 ,            INTENT(OUT) :: Data(*)
1358  INTEGER ,       INTENT(IN)  :: Count
1359  INTEGER ,       INTENT(OUT)  :: OutCount
1360  INTEGER ,       INTENT(OUT) :: Status
1361    CALL wrf_error_fatal('ext_int_get_var_td_double not supported yet')
1362RETURN
1363END SUBROUTINE ext_int_get_var_td_double
1364
1365!--- put_var_td_double
1366SUBROUTINE ext_int_put_var_td_double ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1367  IMPLICIT NONE
1368  INTEGER ,       INTENT(IN)  :: DataHandle
1369  CHARACTER*(*) :: Element
1370  CHARACTER*(*) :: DateStr
1371  CHARACTER*(*) :: VarName
1372  real*8 ,            INTENT(IN) :: Data(*)
1373  INTEGER ,       INTENT(IN)  :: Count
1374  INTEGER ,       INTENT(OUT) :: Status
1375    CALL wrf_error_fatal('ext_int_put_var_td_double not supported yet')
1376RETURN
1377END SUBROUTINE ext_int_put_var_td_double
1378
1379!--- get_var_td_integer
1380SUBROUTINE ext_int_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1381  IMPLICIT NONE
1382  INTEGER ,       INTENT(IN)  :: DataHandle
1383  CHARACTER*(*) :: Element
1384  CHARACTER*(*) :: DateStr
1385  CHARACTER*(*) :: VarName
1386  integer ,            INTENT(OUT) :: Data(*)
1387  INTEGER ,       INTENT(IN)  :: Count
1388  INTEGER ,       INTENT(OUT)  :: OutCount
1389  INTEGER ,       INTENT(OUT) :: Status
1390RETURN
1391END SUBROUTINE ext_int_get_var_td_integer
1392
1393!--- put_var_td_integer
1394SUBROUTINE ext_int_put_var_td_integer ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1395  IMPLICIT NONE
1396  INTEGER ,       INTENT(IN)  :: DataHandle
1397  CHARACTER*(*) :: Element
1398  CHARACTER*(*) :: DateStr
1399  CHARACTER*(*) :: VarName
1400  integer ,            INTENT(IN) :: Data(*)
1401  INTEGER ,       INTENT(IN)  :: Count
1402  INTEGER ,       INTENT(OUT) :: Status
1403RETURN
1404END SUBROUTINE ext_int_put_var_td_integer
1405
1406!--- get_var_td_logical
1407SUBROUTINE ext_int_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count, Outcount, Status )
1408  IMPLICIT NONE
1409  INTEGER ,       INTENT(IN)  :: DataHandle
1410  CHARACTER*(*) :: Element
1411  CHARACTER*(*) :: DateStr
1412  CHARACTER*(*) :: VarName
1413  logical ,            INTENT(OUT) :: Data(*)
1414  INTEGER ,       INTENT(IN)  :: Count
1415  INTEGER ,       INTENT(OUT)  :: OutCount
1416  INTEGER ,       INTENT(OUT) :: Status
1417RETURN
1418END SUBROUTINE ext_int_get_var_td_logical
1419
1420!--- put_var_td_logical
1421SUBROUTINE ext_int_put_var_td_logical ( DataHandle,Element,  DateStr,Varname, Data, Count,  Status )
1422  IMPLICIT NONE
1423  INTEGER ,       INTENT(IN)  :: DataHandle
1424  CHARACTER*(*) :: Element
1425  CHARACTER*(*) :: DateStr
1426  CHARACTER*(*) :: VarName
1427  logical ,            INTENT(IN) :: Data(*)
1428  INTEGER ,       INTENT(IN)  :: Count
1429  INTEGER ,       INTENT(OUT) :: Status
1430RETURN
1431END SUBROUTINE ext_int_put_var_td_logical
1432
1433!--- get_var_td_char
1434SUBROUTINE ext_int_get_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
1435  IMPLICIT NONE
1436  INTEGER ,       INTENT(IN)  :: DataHandle
1437  CHARACTER*(*) :: Element
1438  CHARACTER*(*) :: DateStr
1439  CHARACTER*(*) :: VarName
1440  CHARACTER*(*) :: Data
1441  INTEGER ,       INTENT(OUT) :: Status
1442RETURN
1443END SUBROUTINE ext_int_get_var_td_char
1444
1445!--- put_var_td_char
1446SUBROUTINE ext_int_put_var_td_char ( DataHandle,Element,  DateStr,Varname, Data,  Status )
1447  IMPLICIT NONE
1448  INTEGER ,       INTENT(IN)  :: DataHandle
1449  CHARACTER*(*) :: Element
1450  CHARACTER*(*) :: DateStr
1451  CHARACTER*(*) :: VarName
1452  CHARACTER*(*) :: Data
1453  INTEGER ,       INTENT(OUT) :: Status
1454RETURN
1455END SUBROUTINE ext_int_put_var_td_char
1456
1457!--- read_field
1458SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
1459                            DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1460                            DomainStart , DomainEnd ,                                    &
1461                            MemoryStart , MemoryEnd ,                                    &
1462                            PatchStart , PatchEnd ,                                      &
1463                            Status )
1464  USE module_ext_internal
1465  IMPLICIT NONE
1466#include "wrf_io_flags.h"
1467  include 'intio_tags.h'
1468  INTEGER ,       INTENT(IN)    :: DataHandle
1469  CHARACTER*(*) :: DateStr
1470  CHARACTER*(*) :: VarName
1471  integer                       ,intent(inout)    :: FieldType
1472  integer                       ,intent(inout) :: Comm
1473  integer                       ,intent(inout) :: IOComm
1474  integer                       ,intent(inout)    :: DomainDesc
1475  character*(*)                 ,intent(inout)    :: MemoryOrder
1476  character*(*)                 ,intent(inout)    :: Stagger
1477  character*(*) , dimension (*) ,intent(inout)    :: DimNames
1478  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
1479  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
1480  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
1481  integer                       ,intent(out)   :: Status
1482
1483!local
1484  INTEGER                        :: locDataHandle
1485  CHARACTER*132                  :: locDateStr
1486  CHARACTER*132                  :: locVarName
1487  integer                        :: locFieldType
1488  integer                        :: locComm
1489  integer                        :: locIOComm
1490  integer                        :: locDomainDesc
1491  character*132                  :: locMemoryOrder
1492  character*132                  :: locStagger
1493  character*132 , dimension (3)  :: locDimNames
1494  integer ,dimension(3)          :: locDomainStart, locDomainEnd
1495  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
1496  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
1497
1498  character*132 mess
1499
1500  integer ii,jj,kk,myrank
1501
1502
1503  REAL, DIMENSION(*)    :: Field
1504
1505  INTEGER inttypesize, realtypesize, istat, code
1506
1507  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
1508    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: invalid data handle" )
1509  ENDIF
1510  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
1511    CALL wrf_error_fatal("io_int.F90: ext_int_read_field: DataHandle not opened" )
1512  ENDIF
1513
1514  inttypesize = itypesize
1515  realtypesize = rtypesize
1516
1517  DO WHILE ( .TRUE. )
1518    READ( unit=DataHandle, iostat=istat ) hdrbuf   ! this is okay as long as no other record type has data that follows
1519    IF ( istat .EQ. 0 ) THEN
1520      code = hdrbuf(2)
1521      IF ( code .EQ. int_field ) THEN
1522        CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
1523                                 locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm,  &
1524                                 locDomainDesc , locMemoryOrder , locStagger , locDimNames ,              &
1525                                 locDomainStart , locDomainEnd ,                                    &
1526                                 locMemoryStart , locMemoryEnd ,                                    &
1527                                 locPatchStart , locPatchEnd )
1528        IF ( TRIM(locVarName) .EQ. TRIM(VarName) ) THEN
1529          IF      ( FieldType .EQ. WRF_REAL ) THEN
1530            CALL rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1531          ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1532            CALL ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1533          ELSE
1534            CALL wrf_message('io_int.F90: ext_int_read_field: types other than WRF_REAL not supported yet')
1535            READ( unit=DataHandle )
1536          ENDIF
1537        ELSE
1538          WRITE(mess,*)'ext_int_read_field: ',TRIM(locVarName),' NE ',TRIM(VarName)
1539          CALL wrf_message(mess)
1540          READ( unit=DataHandle )
1541        ENDIF
1542        Status = 0
1543        GOTO 7717
1544      ENDIF
1545    ELSE
1546      Status = 1
1547      GOTO 7717
1548    ENDIF
1549  ENDDO
1550
15517717 CONTINUE
1552
1553  first_operation( DataHandle ) = .FALSE.
1554  RETURN
1555
1556END SUBROUTINE ext_int_read_field
1557
1558!--- write_field
1559SUBROUTINE ext_int_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
1560                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1561                             DomainStart , DomainEnd ,                                    &
1562                             MemoryStart , MemoryEnd ,                                    &
1563                             PatchStart , PatchEnd ,                                      &
1564                             Status )
1565  USE module_ext_internal
1566  IMPLICIT NONE
1567#include "wrf_io_flags.h"
1568  INTEGER ,       INTENT(IN)    :: DataHandle
1569  CHARACTER*(*) :: DateStr
1570  CHARACTER*(*) :: VarName
1571  integer                       ,intent(in)    :: FieldType
1572  integer                       ,intent(inout) :: Comm
1573  integer                       ,intent(inout) :: IOComm
1574  integer                       ,intent(in)    :: DomainDesc
1575  character*(*)                 ,intent(in)    :: MemoryOrder
1576  character*(*)                 ,intent(in)    :: Stagger
1577  character*(*) , dimension (*) ,intent(in)    :: DimNames
1578  integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
1579  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
1580  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
1581  integer                       ,intent(out)   :: Status
1582
1583  integer ii,jj,kk,myrank
1584
1585!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1586!                   MemoryStart(2):MemoryEnd(2), &
1587!                   MemoryStart(3):MemoryEnd(3) ) :: Field
1588
1589  REAL, DIMENSION(*)    :: Field
1590
1591  INTEGER inttypesize, realtypesize
1592
1593  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
1594    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: invalid data handle" )
1595  ENDIF
1596  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
1597    CALL wrf_error_fatal("io_int.F90: ext_int_write_field: DataHandle not opened" )
1598  ENDIF
1599
1600  inttypesize = itypesize
1601  realtypesize = rtypesize
1602  IF      ( FieldType .EQ. WRF_REAL .OR. FieldType .EQ. WRF_DOUBLE) THEN
1603    typesize = rtypesize
1604  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
1605    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_DOUBLE not yet supported')
1606  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1607    typesize = itypesize
1608  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
1609    CALL wrf_error_fatal( 'io_int.F90: ext_int_write_field, WRF_LOGICAL not yet supported')
1610  ENDIF
1611
1612  IF ( okay_for_io( DataHandle ) ) THEN
1613
1614    CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize,           &
1615                             DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm,  &
1616                             DomainDesc , MemoryOrder , Stagger , DimNames ,              &
1617                             DomainStart , DomainEnd ,                                    &
1618                             MemoryStart , MemoryEnd ,                                    &
1619                             PatchStart , PatchEnd )
1620    WRITE( unit=DataHandle ) hdrbuf
1621    IF      ( FieldType .EQ. WRF_REAL ) THEN
1622      CALL rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1623    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1624      CALL ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1625    ENDIF
1626  ENDIF
1627  first_operation( DataHandle ) = .FALSE.
1628  Status = 0
1629  RETURN
1630END SUBROUTINE ext_int_write_field
1631
1632SUBROUTINE rfieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1633  INTEGER ,       INTENT(IN)    :: DataHandle
1634  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1635  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1636  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1637                   MemoryStart(2):MemoryEnd(2), &
1638                   MemoryStart(3):MemoryEnd(3) ) :: Field
1639  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1640  RETURN
1641END SUBROUTINE rfieldwrite
1642
1643SUBROUTINE ifieldwrite( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1644  INTEGER ,       INTENT(IN)    :: DataHandle
1645  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1646  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1647  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1648                      MemoryStart(2):MemoryEnd(2), &
1649                      MemoryStart(3):MemoryEnd(3) ) :: Field
1650  WRITE( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1651  RETURN
1652END SUBROUTINE ifieldwrite
1653
1654SUBROUTINE rfieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1655  INTEGER ,       INTENT(IN)    :: DataHandle
1656  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1657  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1658  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1659                   MemoryStart(2):MemoryEnd(2), &
1660                   MemoryStart(3):MemoryEnd(3) ) :: Field
1661  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1662  RETURN
1663END SUBROUTINE rfieldread
1664
1665SUBROUTINE ifieldread( DataHandle, Field, MemoryStart, MemoryEnd, PatchStart, PatchEnd )
1666  INTEGER ,       INTENT(IN)    :: DataHandle
1667  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
1668  INTEGER ,DIMENSION(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
1669  INTEGER, DIMENSION( MemoryStart(1):MemoryEnd(1), &
1670                      MemoryStart(2):MemoryEnd(2), &
1671                      MemoryStart(3):MemoryEnd(3) ) :: Field
1672  READ( unit=DataHandle ) Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3))
1673  RETURN
1674END SUBROUTINE ifieldread
1675
Note: See TracBrowser for help on using the repository browser.