wrfv2_fire/external/io_int/io_int.F90

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