Tests.f90

Tests.f90 provides Fortran code examples for many XMDF APIs.
00001 MODULE TestDatasets
00002 
00003 USE Xmdf
00004 
00005 CHARACTER(LEN=*), PARAMETER :: DATASETS_LOCATION = 'Datasets'
00006 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_LOCATION = 'Scalars/ScalarA'
00007 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_LOCATION_FULL = 'Datasets/Scalars/ScalarA'
00008 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_LOCATION = 'Scalars/ScalarB'
00009 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_LOCATION = 'Vectors/Vector2D_A'
00010 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_LOCATION = 'Vectors/Vector2D_B'
00011 
00012 CONTAINS
00013 ! ---------------------------------------------------------------------------
00014 ! FUNCTION  tdEditScalarAValues
00015 ! PURPOSE   
00016 ! NOTES     
00017 ! ---------------------------------------------------------------------------
00018 SUBROUTINE TD_EDIT_SCALAR_A_VALUES(a_Filename, a_Compression, error)
00019   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00020   INTEGER, INTENT(IN) :: a_Compression
00021   INTEGER, INTENT(OUT) :: error
00022   INTEGER xFileId, xScalarId
00023   INTEGER, PARAMETER :: editNumValues = 3
00024   INTEGER  editTimestep
00025   INTEGER, DIMENSION(editNumValues) :: indices
00026   REAL, DIMENSION(editNumValues) :: new_values
00027 
00028   CALL TD_WRITE_SCALAR_A(a_Filename, a_Compression, error)
00029   if (error < 0) then
00030     return
00031   endif
00032 
00033     ! open the file and edit the values  
00034   CALL XF_OPEN_FILE(a_Filename, .FALSE., xFileId, error)
00035   if (error < 0) then
00036     return
00037   endif
00038 
00039   CALL XF_OPEN_GROUP(xFileId, SCALAR_A_LOCATION_FULL, xScalarId, error);
00040   if (error < 0) then
00041     CALL XF_CLOSE_FILE(xFileId, error)
00042     return
00043   endif
00044   
00045     ! Edit values in timestep 1, make index 1 = 4, index 5 = 40,
00046     ! and index 10 = 400
00047   editTimestep = 1
00048   indices(1) = 1;
00049   indices(2) = 5;
00050   indices(3) = 10;
00051   new_values(1) = 4.0;
00052   new_values(2) = 40.0;
00053   new_values(3) = 400.0;
00054 
00055   CALL XF_CHANGE_SCALAR_VALUES_TIMESTEP_FLOAT(xScalarId, editTimestep, editNumValues, &
00056                                indices, new_values, error)
00057   if (error < 0) then
00058     CALL XF_CLOSE_GROUP(xScalarId, error)
00059     CALL XF_CLOSE_FILE(xFileId, error)
00060     return
00061   endif
00062 
00063 !  RDJ - Technically we shouldn't have to close and reopen a file that we are 
00064 !        editing but it seems to fix a crash that the tests are having.
00065 !  CALL XF_CLOSE_GROUP(xScalarId, error)
00066 !  CALL XF_CLOSE_FILE(xFileId, error)
00067 !    ! open the file and edit the values  
00068 !  CALL XF_OPEN_FILE(a_Filename, .FALSE., xFileId, error)
00069 !  if (error < 0) then
00070 !    return
00071 !  endif
00072 !
00073 !  CALL XF_OPEN_GROUP(xFileId, SCALAR_A_LOCATION_FULL, xScalarId, error);
00074 !  if (error < 0) then
00075 !    CALL XF_CLOSE_FILE(xFileId, error)
00076 !    return
00077 !  endif
00078 
00079     ! Edit values in timestep 2, make index 2 = 6, index 3 = 60, and 
00080     ! index 9 = 600
00081   editTimestep = 2
00082   indices(1) = 2
00083   indices(2) = 3
00084   indices(3) = 9
00085   new_values(1) = -6.0
00086   new_values(2) = 60.0
00087   new_values(3) = 6000.0
00088 
00089   CALL XF_CHANGE_SCALAR_VALUES_TIMESTEP_FLOAT(xScalarId, editTimestep, editNumValues, &
00090                                indices, new_values, error)
00091   if (error < 0) then
00092     CALL XF_CLOSE_GROUP(xScalarId, error)
00093     CALL XF_CLOSE_FILE(xFileId, error)
00094     return
00095   endif
00096 
00097   CALL XF_CLOSE_GROUP(xScalarId, error)
00098   CALL XF_CLOSE_FILE(xFileId, error)
00099 
00100   return
00101 END SUBROUTINE
00102 ! tdEditScalarAValues
00103 
00104 ! ---------------------------------------------------------------------------
00105 ! FUNCTION  tdReadScalarAIndices
00106 ! PURPOSE   
00107 ! NOTES     
00108 ! ---------------------------------------------------------------------------
00109 SUBROUTINE TD_READ_SCALAR_A_INDICES (a_Filename, a_nIndices, a_indices, error)
00110   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00111   INTEGER, INTENT(IN) :: a_nIndices
00112   INTEGER, DIMENSION(*), INTENT(IN) :: a_indices
00113   INTEGER, INTENT(OUT) :: error
00114   INTEGER     xFileId, xDsetsId, xScalarAId
00115   INTEGER     nTimesteps
00116   REAL, ALLOCATABLE, DIMENSION(:) ::  fValues
00117   INTEGER     nValues
00118   INTEGER     id, i, j
00119 
00120   ! open the file
00121   CALL XF_OPEN_FILE(a_Filename, .TRUE., xFileId, error)
00122   if (error < 0) then
00123     return
00124   endif
00125 
00126   ! open the dataset group
00127   CALL XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, error)
00128   if (error >= 0) then
00129     CALL XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, error)
00130   endif
00131   if (error < 0) then
00132     return
00133   endif
00134 
00135   ! Find out the number of timesteps in the file
00136   CALL XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, error)
00137   if (error < 0) then
00138     return
00139   endif
00140   if (nTimesteps < 1) then
00141     error = -1
00142     return
00143   endif
00144 
00145   ! Read the values for the index
00146   nValues = nTimesteps*a_nIndices
00147   allocate(fValues(nValues))
00148   CALL XF_READ_SCALAR_VALUES_AT_INDICES_FLOAT(xScalarAId, a_nIndices, a_indices, 1, &
00149                                             nTimesteps, fValues, error)
00150   if (error < 0) then
00151     return
00152   endif
00153 
00154   ! output the data
00155   WRITE(*,*) ''
00156   WRITE(*,*) 'Reading scalar A indices'
00157   id = 1;
00158   do i = 1, nTimesteps
00159     WRITE(*,*) 'Timestep: ', i
00160     do j = 1, a_nIndices
00161       WRITE(*,*) 'index:', a_indices(j), ' value: ', fValues(id)
00162       id = id + 1
00163     enddo
00164   enddo
00165   WRITE(*,*) ''
00166 
00167   deallocate(fValues)
00168 
00169   return
00170 
00171 END SUBROUTINE
00172 ! TD_READ_SCALARA_INDICES
00173 
00174 ! --------------------------------------------------------------------------
00175 ! FUNCTION tdReadDatasets
00176 ! PURPOSE  Read a dataset group from an XMDF file and output information to
00177 !          to a text file
00178 ! NOTES    
00179 ! --------------------------------------------------------------------------
00180 RECURSIVE SUBROUTINE TD_READ_DATASETS (a_xGroupId, a_FileUnit, error)
00181 INTEGER, INTENT(IN) :: a_xGroupId
00182 INTEGER, INTENT(IN)        :: a_FileUnit
00183 INTEGER, INTENT(OUT)       :: error
00184 INTEGER                   nPaths, nMaxPathLength, j
00185 CHARACTER, ALLOCATABLE, DIMENSION(:) :: Paths
00186 CHARACTER(LEN=500)       IndividualPath
00187 INTEGER                   nStatus, i
00188 INTEGER            xScalarId, xVectorId, xMultiId
00189 INTEGER                   nMultiDatasets
00190 
00191 xScalarId = NONE
00192 xVectorId = NONE
00193 
00194 nMultiDatasets = 0
00195 nPaths = 0
00196 nMaxPathLength = 0
00197 
00198   ! Look for scalar datasets
00199 call XF_GET_SCALAR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus)
00200 if (nStatus >= 0 .AND. nPaths > 0) then
00201   allocate(Paths(nPaths*nMaxPathLength))
00202   call XF_GET_SCALAR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, &
00203                                                                          error)
00204 endif
00205 if (nStatus < 0) then
00206   error = -1
00207   return
00208 endif
00209 
00210   ! Output number and paths to scalar datasets
00211 WRITE(a_FileUnit,*) 'Number of Scalars ', nPaths
00212 do i=2, nPaths
00213   IndividualPath = ''
00214   do j=1, nMaxPathLength-1
00215     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00216   enddo
00217   WRITE(a_FileUnit,*) 'Reading scalar: ', IndividualPath(1:nMaxPathLength-1)
00218   call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00219                                                            xScalarId, nStatus)
00220   if (nStatus < 0) then
00221     error = -1
00222   return
00223   endif
00224 
00225   call TDI_READ_SCALAR(xScalarId, a_FileUnit, nStatus)
00226   call XF_CLOSE_GROUP(xScalarId, error)
00227   if (nStatus < 0) then
00228     WRITE(*,*) 'Error reading scalar dataset.'
00229     error = -1
00230   return
00231   endif
00232 enddo
00233 
00234 if (allocated(Paths)) deallocate(Paths)
00235   ! Look for vector datasets
00236 call XF_GET_VECTOR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus)
00237 if (nStatus >= 0 .AND. nPaths > 0) then
00238   allocate(Paths(nPaths*nMaxPathLength))
00239   call XF_GET_VECTOR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, error)
00240 endif
00241 if (nStatus < 0) then
00242   error = -1
00243   return
00244 endif
00245 
00246   ! Output number and paths to scalar datasets
00247 WRITE(a_FileUnit,*) 'Number of Vectors ', nPaths
00248 do i=2, nPaths
00249   do j=1, nMaxPathLength-1
00250     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00251   enddo
00252   WRITE(a_FileUnit,*) 'Reading Vector: ', &
00253                       IndividualPath(1:nMaxPathLength-1)
00254   call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00255                                                           xVectorId, nStatus)
00256   if (nStatus < 0) then
00257     error = -1
00258   return
00259   endif
00260   call TDI_READ_VECTOR(xVectorId, a_FileUnit, nStatus)
00261   call XF_CLOSE_GROUP(xVectorId, error)
00262   if (nStatus < 0) then
00263     WRITE(*,*) 'Error reading vector dataset.'
00264     error = -1
00265   return
00266   endif
00267 enddo
00268 
00269 if (allocated(Paths)) deallocate(Paths)
00270 
00271 ! find multidataset folders
00272 call XF_GET_GRP_PTHS_SZ_MLT_DSETS(a_xGroupId, nMultiDatasets, &
00273                                                       nMaxPathLength, nStatus)
00274 if (nStatus >= 0 .AND. nMultiDatasets > 0) then
00275   allocate(Paths(nMultiDatasets*nMaxPathLength))
00276   call XF_GET_ALL_GRP_PATHS_MLT_DSETS(a_xGroupId, nMultiDatasets, &
00277                                                  nMaxPathLength, Paths, error)
00278   if (nStatus < 0) then
00279     error = -1
00280     return
00281   endif
00282 
00283   ! Output number and paths to multidatasets
00284   WRITE(a_FileUnit,*) 'Number of Multidatasets ', nMultiDatasets
00285   do i=2, nMultiDatasets
00286     IndividualPath = ''
00287     do j=1, nMaxPathLength-1
00288       IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00289     enddo
00290     WRITE(a_FileUnit,*) 'Reading multidataset: ', &
00291                                              IndividualPath(1:nMaxPathLength-1)
00292     call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00293                                                            xMultiId, nStatus)
00294     if (nStatus < 0) then
00295       error = -1
00296     return
00297     endif
00298 
00299     call TD_READ_DATASETS(xMultiId, a_FileUnit, nStatus)
00300     call XF_CLOSE_GROUP(xMultiId, error)
00301     if (nStatus < 0) then
00302       WRITE(*,*) 'Error reading multidatasets.'
00303       error = -1
00304     return
00305     endif
00306   enddo
00307 endif
00308 if (allocated(Paths)) deallocate(Paths)
00309 
00310 error = 1
00311 return
00312 
00313 END SUBROUTINE
00314 !tdReadDatasets
00315 ! --------------------------------------------------------------------------
00316 ! FUNCTION tdReadActivityScalarAIndex
00317 ! PURPOSE  Read all timestep values for a particular index
00318 ! NOTES    
00319 ! --------------------------------------------------------------------------
00320 SUBROUTINE TD_READ_ACTIVITY_SCALAR_A_INDEX(a_Filename, a_Index, error)
00321 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00322 INTEGER, INTENT(IN)   :: a_Index
00323 INTEGER, INTENT(OUT)  :: error
00324 INTEGER                  status
00325 INTEGER           xFileId, xDsetsId, xScalarAId
00326 INTEGER                  nTimesteps, i
00327 INTEGER, ALLOCATABLE  :: bActive(:)
00328 
00329 xFileId = NONE
00330 xDsetsId = NONE
00331 xScalarAId = NONE
00332 
00333   ! open the file
00334 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
00335 if (status < 0) then
00336   error = -1
00337   return
00338 endif
00339 
00340   ! open the dataset group
00341 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00342 if (status >= 0) then
00343   call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status)
00344 endif
00345 if (status < 0) then
00346   error = status
00347   return
00348 endif
00349 
00350   ! Find out the number of timesteps in the file
00351 CALL XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status)
00352 if (status < 0) then
00353   error = status
00354   return
00355 endif
00356 
00357 if (nTimesteps < 1) then
00358   error = -1
00359   return
00360 endif
00361 
00362   ! Read the values for the index
00363 allocate(bActive(nTimesteps))
00364 call XF_READ_ACTIVE_VALS_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, &
00365                                        bActive, status)
00366   ! output the data
00367 WRITE(*,*) ''
00368 WRITE(*,*) 'Reading activity for scalar A slice at index: ', a_Index
00369 do i=1, nTimesteps
00370   WRITE(*,*) bActive(i), ' '
00371 enddo
00372 
00373 deallocate(bActive)
00374 
00375 error = status
00376 return
00377 
00378 END SUBROUTINE
00379 ! tdReadActivityScalarAIndex
00380 
00381 ! --------------------------------------------------------------------------
00382 ! FUNCTION tdReadScalarAIndex
00383 ! PURPOSE  Read all timestep values for a particular index
00384 ! NOTES    
00385 ! --------------------------------------------------------------------------
00386 SUBROUTINE TD_READ_SCALAR_A_INDEX (a_Filename, a_Index, error)
00387 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00388 INTEGER, INTENT(IN)   :: a_Index
00389 INTEGER, INTENT(OUT)  :: error
00390 INTEGER              status
00391 INTEGER       xFileId, xDsetsId, xScalarAId
00392 INTEGER              nTimesteps, i
00393 REAL, ALLOCATABLE :: fValues(:)
00394 
00395 xFileId = NONE
00396 xDsetsId = NONE
00397 xScalarAId = NONE
00398 
00399   ! open the file
00400 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
00401 if (status < 0) then
00402   error = -1
00403   return
00404 endif
00405 
00406   ! open the dataset group
00407 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00408 if (status >= 0) then
00409   call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status)
00410 endif
00411 if (status < 0) then
00412   error = status
00413   return
00414 endif
00415 
00416   ! Find out the number of timesteps in the file
00417 call XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status)
00418 if (status < 0) then
00419   error = status
00420   return
00421 endif
00422 
00423 if (nTimesteps < 1) then
00424   error = -1
00425   return
00426 endif
00427 
00428   ! Read the values for the index
00429 allocate (fValues(nTimesteps))
00430 call XF_READ_SCALAR_VALUES_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, &
00431                                      fValues, status)
00432 
00433   ! output the data
00434 WRITE(*,*) ''
00435 WRITE(*,*) 'Reading scalar A slice at index: ', a_Index
00436 do i=1, nTimesteps
00437   WRITE(*,*) fValues(i), ' '
00438 enddo
00439 
00440 deallocate(fValues)
00441 
00442 error = status
00443 return
00444 
00445 END SUBROUTINE
00446 ! tdReadScalarAtIndex
00447 
00448 ! --------------------------------------------------------------------------
00449 ! FUNCTION tdWriteScalarA
00450 ! PURPOSE  Write scalar Dataset to an HDF5 File
00451 ! NOTES    This tests dynamic data sets, and activity
00452 !          This dataset is dynamic concentrations (mg/L) with output times
00453 !          in minutes.
00454 !          Dataset is for a mesh and so nActive is the number of elements
00455 !          which is not the same as the nValues which would be number of nodes
00456 !          reads/writes a reference time in julian days
00457 ! --------------------------------------------------------------------------
00458 SUBROUTINE TD_WRITE_SCALAR_A (a_Filename, a_Compression, error)
00459   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00460   INTEGER, INTENT(IN)          :: a_Compression
00461   INTEGER, INTENT(OUT)         :: error
00462   INTEGER      xFileId, xDsetsId, xScalarAId, xCoordId
00463   INTEGER      nValues, nTimes, nActive
00464   REAL(DOUBLE) dTime, dJulianReftime
00465   INTEGER      iTimestep, iActive, iHpgnZone
00466   REAL         fValues(10) ! nValues
00467   INTEGER*1    bActivity(10) ! activity
00468   INTEGER      i, status
00469 
00470   ! initialize the data
00471   nValues = 10
00472   nTimes = 3
00473   nActive = 8
00474   dTime = 0.0
00475 
00476   ! 5th item in data set is always inactive, others active
00477   do iActive = 1, nActive
00478     bActivity(iActive) = 1
00479   enddo 
00480   bActivity(6) = 0
00481 
00482 
00483   ! create the file
00484   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00485   if (error .LT. 0) then
00486       ! close the file
00487     call XF_CLOSE_FILE(xFileId, error)
00488     return
00489   endif
00490 
00491   ! create the group where we will put all the datasets 
00492   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00493   if (status < 0) then
00494     call XF_CLOSE_FILE(xFileId, error)
00495     error = -1
00496   return
00497   endif
00498 
00499   ! Create the scalar A dataset group
00500   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', &
00501               TS_HOURS, a_Compression, xScalarAId, status)
00502   if (status .LT. 0) then
00503       ! close the dataset
00504     call XF_CLOSE_GROUP(xScalarAId, error)
00505     call XF_CLOSE_GROUP(xDsetsId, error)
00506     call XF_CLOSE_FILE(xFileId, error)
00507     error = status
00508     return 
00509   endif
00510 
00511   ! Add in a reftime.  This is a julian day for:
00512   ! noon July 1, 2003
00513   dJulianReftime = 2452822.0;
00514   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
00515   if (status < 0) then
00516     call XF_CLOSE_GROUP(xScalarAId, error)
00517     call XF_CLOSE_GROUP(xDsetsId, error)
00518     call XF_CLOSE_FILE(xFileId, error)
00519   endif
00520 
00521   ! Loop through timesteps adding them to the file
00522   do iTimestep = 1, nTimes
00523     ! We will have an 0.5 hour timestep
00524     dTime = iTimestep * 0.5
00525 
00526     fValues(1) = dTime
00527     do i = 2, nValues
00528       fValues(i) = fValues(i-1)*2.5
00529     end do
00530 
00531     ! write the dataset array values
00532     call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, error)
00533     if (error .GE. 0) then
00534       ! write activity array
00535       call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, error)
00536     end if 
00537   enddo
00538 
00539   ! Write Coordinate file - for ScalarA, we will set the coordinate system
00540   !   to be Geographic HPGN, with HPGN settings written to the file.
00541   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00542   if (status < 0) then
00543     call XF_CLOSE_GROUP(xScalarAId, error)
00544     call XF_CLOSE_GROUP(xDsetsId, error)
00545     call XF_CLOSE_FILE(xFileId, error)
00546     error = -1
00547   return
00548   endif
00549 
00550     ! set HPGN Zone for test
00551   iHpgnZone = 29   ! Utah
00552     ! Write Coordinate Information to file
00553   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
00554   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00555   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00556   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00557 
00558     ! write additional information
00559   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
00560 
00561   call XF_CLOSE_GROUP(xCoordId, error)
00562   xCoordId = 0;
00563 
00564   ! close the dataset
00565   call XF_CLOSE_GROUP(xScalarAId, error)
00566   call XF_CLOSE_GROUP(xDsetsId, error)
00567   call XF_CLOSE_FILE(xFileId, error)
00568 
00569   return
00570 END SUBROUTINE
00571 ! tdWriteScalarA
00572 
00573 ! --------------------------------------------------------------------------
00574 ! FUNCTION tdWriteScalarAPIECES
00575 ! PURPOSE  Write scalar Dataset to an HDF5 File
00576 ! NOTES    This tests dynamic data sets, and activity
00577 !          This dataset is dynamic concentrations (mg/L) with output times
00578 !          in minutes.
00579 !          Dataset is for a mesh and so nActive is the number of elements
00580 !          which is not the same as the nValues which would be number of nodes
00581 !          reads/writes a reference time in julian days
00582 ! --------------------------------------------------------------------------
00583 SUBROUTINE TD_WRITE_SCALAR_A_PIECES (a_Filename, a_Compression, error)
00584   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00585   INTEGER, INTENT(IN)          :: a_Compression
00586   INTEGER, INTENT(OUT)         :: error
00587   INTEGER      xFileId, xDsetsId, xScalarAId, xCoordId
00588   INTEGER      nValues, nTimes, nActive
00589   REAL(DOUBLE) dTime, dJulianReftime
00590   INTEGER      iTimestep, iActive, iHpgnZone
00591   REAL         fValues(10) ! nValues
00592   INTEGER*1    bActivity(10) ! activity
00593   INTEGER      i, status
00594   REAL         minvalue, maxvalue
00595   INTEGER      timestepId
00596   INTEGER      activeTs
00597 
00598   ! initialize the data
00599   nValues = 10
00600   nTimes = 3
00601   nActive = 8
00602   dTime = 0.0
00603 
00604   ! 5th item in data set is always inactive, others active
00605   do iActive = 1, nActive
00606     bActivity(iActive) = 1
00607   enddo 
00608   bActivity(6) = 0
00609 
00610 
00611   ! create the file
00612   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00613   if (error .LT. 0) then
00614       ! close the file
00615     call XF_CLOSE_FILE(xFileId, error)
00616     return
00617   endif
00618 
00619   ! create the group where we will put all the datasets 
00620   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00621   if (status < 0) then
00622     call XF_CLOSE_FILE(xFileId, error)
00623     error = -1
00624   return
00625   endif
00626 
00627   ! Create the scalar A dataset group
00628   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', &
00629               TS_HOURS, a_Compression, xScalarAId, status)
00630   if (status .LT. 0) then
00631       ! close the dataset
00632     call XF_CLOSE_GROUP(xScalarAId, error)
00633     call XF_CLOSE_GROUP(xDsetsId, error)
00634     call XF_CLOSE_FILE(xFileId, error)
00635     error = status
00636     return 
00637   endif
00638 
00639   ! Add in a reftime.  This is a julian day for:
00640   ! noon July 1, 2003
00641   dJulianReftime = 2452822.0;
00642   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
00643   if (status < 0) then
00644     call XF_CLOSE_GROUP(xScalarAId, error)
00645     call XF_CLOSE_GROUP(xDsetsId, error)
00646     call XF_CLOSE_FILE(xFileId, error)
00647   endif
00648 
00649   ! Loop through timesteps adding them to the file
00650   do iTimestep = 1, nTimes
00651     ! We will have an 0.5 hour timestep
00652     dTime = iTimestep * 0.5
00653 
00654     fValues(1) = dTime
00655     minvalue = fValues(1)
00656     maxvalue = fValues(1)
00657     do i = 2, nValues
00658       fValues(i) = fValues(i-1)*2.5
00659       minvalue = min(minvalue, fValues(i))
00660       maxvalue = max(maxvalue, fValues(i))
00661     end do
00662 
00663     ! write the dataset array values
00664     call XF_INITIALIZE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, minvalue, &
00665             maxvalue, timestepId, error)
00666     
00667     ! write data in pairs
00668     do i = 1, nValues, +2
00669       call XF_WRITE_SCALAR_TIMESTEP_PORTION(xScalarAId, timestepId, 2, i, &
00670                                         fValues(i), error)
00671     enddo
00672 
00673     if (error .GE. 0) then
00674       ! write activity array
00675       call XF_INITIALIZE_ACTIVITY_TIMESTEP(xScalarAId, nActive, activeTs, error)
00676       
00677       do i = 1, nActive, +2
00678         call XF_WRITE_ACTIVITY_TIMESTEP_PORTION(xScalarAId, activeTs, 2, &
00679                 i, bActivity(i), error)
00680       enddo
00681       
00682     end if 
00683   enddo
00684 
00685   ! Write Coordinate file - for ScalarA, we will set the coordinate system
00686   !   to be Geographic HPGN, with HPGN settings written to the file.
00687   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00688   if (status < 0) then
00689     call XF_CLOSE_GROUP(xScalarAId, error)
00690     call XF_CLOSE_GROUP(xDsetsId, error)
00691     call XF_CLOSE_FILE(xFileId, error)
00692     error = -1
00693   return
00694   endif
00695 
00696     ! set HPGN Zone for test
00697   iHpgnZone = 29   ! Utah
00698     ! Write Coordinate Information to file
00699   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
00700   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00701   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00702   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00703 
00704     ! write additional information
00705   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
00706 
00707   call XF_CLOSE_GROUP(xCoordId, error)
00708   xCoordId = 0;
00709 
00710   ! close the dataset
00711   call XF_CLOSE_GROUP(xScalarAId, error)
00712   call XF_CLOSE_GROUP(xDsetsId, error)
00713   call XF_CLOSE_FILE(xFileId, error)
00714 
00715   return
00716 END SUBROUTINE
00717 ! tdWriteScalarAPieces
00718 
00719 ! --------------------------------------------------------------------------
00720 ! FUNCTION tdWriteScalarAPIECESAltMinMax
00721 ! PURPOSE  Write scalar Dataset to an HDF5 File
00722 ! NOTES    This tests dynamic data sets, and activity
00723 !          This dataset is dynamic concentrations (mg/L) with output times
00724 !          in minutes.
00725 !          Dataset is for a mesh and so nActive is the number of elements
00726 !          which is not the same as the nValues which would be number of nodes
00727 !          reads/writes a reference time in julian days
00728 ! --------------------------------------------------------------------------
00729 SUBROUTINE TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX (a_Filename, a_Compression, error)
00730   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00731   INTEGER, INTENT(IN)          :: a_Compression
00732   INTEGER, INTENT(OUT)         :: error
00733   INTEGER      xFileId, xDsetsId, xScalarAId, xCoordId
00734   INTEGER      nValues, nTimes, nActive
00735   REAL(DOUBLE) dTime, dJulianReftime
00736   INTEGER      iTimestep, iActive, iHpgnZone
00737   REAL         fValues(10) ! nValues
00738   INTEGER*1    bActivity(10) ! activity
00739   INTEGER      i, status
00740   REAL         minvalue, maxvalue
00741   INTEGER      timestepId
00742   INTEGER      activeTs
00743 
00744   ! initialize the data
00745   nValues = 10
00746   nTimes = 3
00747   nActive = 8
00748   dTime = 0.0
00749 
00750   ! 5th item in data set is always inactive, others active
00751   do iActive = 1, nActive
00752     bActivity(iActive) = 1
00753   enddo 
00754   bActivity(6) = 0
00755 
00756 
00757   ! create the file
00758   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00759   if (error .LT. 0) then
00760       ! close the file
00761     call XF_CLOSE_FILE(xFileId, error)
00762     return
00763   endif
00764 
00765   ! create the group where we will put all the datasets 
00766   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00767   if (status < 0) then
00768     call XF_CLOSE_FILE(xFileId, error)
00769     error = -1
00770   return
00771   endif
00772 
00773   ! Create the scalar A dataset group
00774   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', &
00775               TS_HOURS, a_Compression, xScalarAId, status)
00776   if (status .LT. 0) then
00777       ! close the dataset
00778     call XF_CLOSE_GROUP(xScalarAId, error)
00779     call XF_CLOSE_GROUP(xDsetsId, error)
00780     call XF_CLOSE_FILE(xFileId, error)
00781     error = status
00782     return 
00783   endif
00784 
00785   ! Add in a reftime.  This is a julian day for:
00786   ! noon July 1, 2003
00787   dJulianReftime = 2452822.0;
00788   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
00789   if (status < 0) then
00790     call XF_CLOSE_GROUP(xScalarAId, error)
00791     call XF_CLOSE_GROUP(xDsetsId, error)
00792     call XF_CLOSE_FILE(xFileId, error)
00793   endif
00794 
00795   ! Loop through timesteps adding them to the file
00796   do iTimestep = 1, nTimes
00797     ! We will have an 0.5 hour timestep
00798     dTime = iTimestep * 0.5
00799 
00800     fValues(1) = dTime
00801     minvalue = fValues(1)
00802     maxvalue = fValues(1)
00803     do i = 2, nValues
00804       fValues(i) = fValues(i-1)*2.5
00805       minvalue = min(minvalue, fValues(i))
00806       maxvalue = max(maxvalue, fValues(i))
00807     end do
00808 
00809     ! write the dataset array values
00810     call XF_INITIALIZE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, minvalue, &
00811             maxvalue, timestepId, error)
00812     
00813     ! write data in pairs
00814     do i = 1, nValues, +2
00815       call XF_WRITE_SCALAR_TIMESTEP_PORTION(xScalarAId, timestepId, 2, i, &
00816                                         fValues(i), error)
00817     enddo
00818     
00819     minvalue = 0.1111*timestepId
00820     maxvalue = 1111*timestepId
00821     call XF_SET_DATASET_TIMESTEP_MIN_MAX(xScalarAId, timestepId, minvalue, &
00822             maxvalue, error)
00823 
00824     if (error .GE. 0) then
00825       ! write activity array
00826       call XF_INITIALIZE_ACTIVITY_TIMESTEP(xScalarAId, nActive, activeTs, error)
00827       
00828       do i = 1, nActive, +2
00829         call XF_WRITE_ACTIVITY_TIMESTEP_PORTION(xScalarAId, activeTs, 2, &
00830                 i, bActivity(i), error)
00831       enddo
00832       
00833     end if 
00834   enddo
00835 
00836   ! Write Coordinate file - for ScalarA, we will set the coordinate system
00837   !   to be Geographic HPGN, with HPGN settings written to the file.
00838   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00839   if (status < 0) then
00840     call XF_CLOSE_GROUP(xScalarAId, error)
00841     call XF_CLOSE_GROUP(xDsetsId, error)
00842     call XF_CLOSE_FILE(xFileId, error)
00843     error = -1
00844   return
00845   endif
00846 
00847     ! set HPGN Zone for test
00848   iHpgnZone = 29   ! Utah
00849     ! Write Coordinate Information to file
00850   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
00851   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00852   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00853   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00854 
00855     ! write additional information
00856   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
00857 
00858   call XF_CLOSE_GROUP(xCoordId, error)
00859   xCoordId = 0;
00860 
00861   ! close the dataset
00862   call XF_CLOSE_GROUP(xScalarAId, error)
00863   call XF_CLOSE_GROUP(xDsetsId, error)
00864   call XF_CLOSE_FILE(xFileId, error)
00865 
00866   return
00867 END SUBROUTINE
00868 ! TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX
00869 
00870 
00871 ! --------------------------------------------------------------------------
00872 ! FUNCTION TD_WRITE_SCALAR_B
00873 ! PURPOSE  Write scalar Dataset to an HDF5 File
00874 ! NOTES    This tests dynamic data sets, and activity
00875 !          This dataset is dynamic concentrations (mg/L) with output times
00876 !          in minutes.
00877 !          Dataset is for a mesh and so nActive is the number of elements
00878 !          which is not the same as the nValues which would be number of nodes
00879 !          reads/writes a reference time in julian days
00880 ! --------------------------------------------------------------------------
00881 SUBROUTINE TD_WRITE_SCALAR_B (a_Filename, a_Compression, a_Overwrite, error)
00882   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00883   INTEGER, INTENT(IN)          :: a_Compression
00884   LOGICAL, INTENT(IN)          :: a_Overwrite
00885   INTEGER, INTENT(OUT)         :: error
00886   INTEGER      xFileId, xDsetsId, xScalarBId, xCoordId
00887   INTEGER      nValues, nTimes, nActive
00888   REAL(DOUBLE) dTime, dJulianReftime
00889   INTEGER      iTimestep, iActive
00890   REAL         fValues(10) ! nValues
00891   INTEGER*1    bActivity(10) ! activity
00892   INTEGER      i, status
00893 
00894   ! initialize the data
00895   nValues = 10
00896   nTimes = 3
00897   nActive = 8
00898   dTime = 0.0
00899   i = 0
00900 
00901   ! 5th item in data set is always inactive, others active
00902   do iActive = 1, nActive
00903     bActivity(iActive) = 1
00904   enddo 
00905   bActivity(6) = 0
00906 
00907   if (a_Overwrite) then
00908       ! open the already-existing file
00909     call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status)
00910     if (status < 0) then
00911       error = -1
00912       return
00913     endif
00914       ! open the group where we have all the datasets
00915     call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00916     if (status < 0) then
00917       call XF_CLOSE_FILE(xFileId, error)
00918       error = -1
00919       return
00920     endif
00921   else
00922       ! create the file
00923     call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00924     if (error .LT. 0) then
00925         ! close the file
00926       call XF_CLOSE_FILE(xFileId, error)
00927       return
00928     endif
00929 
00930       ! create the group where we will put all the datasets 
00931     call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00932     if (status < 0) then
00933       call XF_CLOSE_FILE(xFileId, error)
00934       error = -1
00935     return
00936     endif
00937   endif
00938 
00939   ! Create/Overwrite the scalar B dataset group
00940   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_B_LOCATION, 'mg/L', &
00941               TS_HOURS, a_Compression, xScalarBId, status)
00942   if (status < 0) then
00943       ! close the dataset
00944     call XF_CLOSE_GROUP(xScalarBId, error)
00945     call XF_CLOSE_GROUP(xDsetsId, error)
00946     call XF_CLOSE_FILE(xFileId, error)
00947     error = status
00948     return 
00949   endif
00950 
00951   ! Add in a reftime.  This is a julian day for:
00952   ! noon July 1, 2003
00953   dJulianReftime = 2452822.0;
00954   call XF_WRITE_REFTIME(xScalarBId, dJulianReftime, status)
00955   if (status < 0) then
00956     call XF_CLOSE_GROUP(xScalarBId, error)
00957     call XF_CLOSE_GROUP(xDsetsId, error)
00958     call XF_CLOSE_FILE(xFileId, error)
00959   endif
00960 
00961   if (.NOT. a_Overwrite) then
00962       ! Loop through timesteps adding them to the file
00963     do iTimestep = 1, nTimes
00964         ! We will have an 0.5 hour timestep
00965       dTime = iTimestep * 0.5
00966 
00967       fValues(1) = dTime
00968       do i = 2, nValues
00969         fValues(i) = fValues(i-1)*2.5
00970       end do
00971 
00972         ! write the dataset array values
00973       call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error)
00974       if (error .GE. 0) then
00975           ! write activity array
00976         call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error)
00977       end if
00978       if (error < 0) then
00979           call XF_CLOSE_GROUP(xScalarBId, error)
00980           call XF_CLOSE_GROUP(xDsetsId, error)
00981           call XF_CLOSE_FILE(xFileId, error)
00982       endif
00983     enddo
00984   else
00985       ! Loop through timesteps adding them to the file
00986     do iTimestep = 1, nTimes
00987         ! We will have an 1.5 hour timestep
00988       dTime = iTimestep * 1.5
00989 
00990       fValues(1) = dTime
00991       do i = 2, nValues
00992         fValues(i) = fValues(i-1)*1.5
00993       end do
00994 
00995         ! write the dataset array values
00996       call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error)
00997       if (error .GE. 0) then
00998           ! write activity array
00999         call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error)
01000       end if
01001       if (error < 0) then
01002           call XF_CLOSE_GROUP(xScalarBId, error)
01003           call XF_CLOSE_GROUP(xDsetsId, error)
01004           call XF_CLOSE_FILE(xFileId, error)
01005       endif
01006     enddo
01007   endif
01008 
01009   if (.NOT. a_Overwrite) then
01010     ! Write Coordinate file - for ScalarB, we will set the coordinate system
01011     !   to be UTM, with UTM Zone settings written to the file.
01012     call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01013     if (status < 0) then
01014       call XF_CLOSE_GROUP(xScalarBId, error)
01015       call XF_CLOSE_GROUP(xDsetsId, error)
01016       call XF_CLOSE_FILE(xFileId, error)
01017     error = -1
01018     return
01019     endif
01020 
01021      ! Write Coord Info to file
01022     call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
01023     call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01024 
01025     call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01026     call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01027 
01028       ! write additional information - we'll use the max value for this test
01029     call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
01030 
01031     call XF_CLOSE_GROUP(xCoordId, error)
01032     xCoordId = 0
01033   endif
01034 
01035   ! close the dataset
01036   call XF_CLOSE_GROUP(xScalarBId, error)
01037   call XF_CLOSE_GROUP(xDsetsId, error)
01038   call XF_CLOSE_FILE(xFileId, error)
01039 
01040   error = 1
01041   return
01042 END SUBROUTINE
01043 ! tdWriteScalarB
01044 !------------------------------------------------------------------------------
01045 !  FUNCTION TD_WRITE_COORDS_TO_MULTI
01046 !  PURPOSE  Write coordinate system to a multidataset file
01047 !  NOTES
01048 !------------------------------------------------------------------------------
01049 SUBROUTINE TD_WRITE_COORDS_TO_MULTI (a_xFileId, error)
01050 INTEGER, INTENT(IN) :: a_xFileId
01051 INTEGER, INTENT(OUT)       :: error
01052 INTEGER    xCoordId
01053 INTEGER           status
01054 
01055   ! Write Coordinate file - for Multidatasets, we will set the coordinate system
01056   !   to be UTM, with UTM Zone settings written to the file.
01057   call XF_CREATE_COORDINATE_GROUP(a_xFileId, xCoordId, status)
01058   if (status < 0) then
01059     error = status
01060   return
01061   endif
01062 
01063     ! Write Coord Info to file
01064   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
01065   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01066 
01067   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01068   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01069 
01070     ! write additional information - we'll use the max value for this test
01071   call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
01072 
01073   call XF_CLOSE_GROUP(xCoordId, error)
01074   xCoordId = 0
01075 
01076   return
01077 END SUBROUTINE
01078 
01079 ! --------------------------------------------------------------------------
01080 ! FUNCTION tdWriteScalarAToMulti
01081 ! PURPOSE  Write scalar Dataset to an HDF5 File
01082 ! NOTES    This tests dynamic data sets, and activity
01083 !          This dataset is dynamic concentrations (mg/L) with output times
01084 !          in minutes.
01085 !          Dataset is for a mesh and so nActive is the number of elements
01086 !          which is not the same as the nValues which would be number of nodes
01087 !          reads/writes a reference time in julian days
01088 ! --------------------------------------------------------------------------
01089 SUBROUTINE TD_WRITE_SCALAR_A_TO_MULTI (a_GroupID, status)
01090  ! CHARACTER(LEN=*), INTENT(IN) :: a_Filename
01091  ! INTEGER, INTENT(IN)          :: a_Compression
01092  ! INTEGER, INTENT(OUT)         :: error
01093   INTEGER      xFileId, xDsetsId, xScalarAId
01094   INTEGER      a_GroupID
01095   INTEGER      nValues, nTimes, nActive
01096   REAL(DOUBLE) dTime, dJulianReftime
01097   INTEGER      iTimestep, iActive
01098   REAL         fValues(10) ! nValues
01099   INTEGER*1    bActivity(10) ! activity
01100   INTEGER      i, status
01101 
01102   ! initialize the data
01103   nValues = 10
01104   nTimes  = 3
01105   nActive = 8
01106   dTime   = 0.0
01107 
01108   ! 5th item in data set is always inactive, others active
01109   do iActive = 1, nActive
01110     bActivity(iActive) = 1
01111   enddo 
01112   bActivity(6) = 0
01113 
01114   ! Create the scalar A dataset group
01115   call XF_CREATE_SCALAR_DATASET(a_GroupID, SCALAR_A_LOCATION, 'mg/L', &
01116               TS_HOURS, NONE, xScalarAId, status)
01117   if (status .LT. 0) then
01118       ! close the dataset
01119     call XF_CLOSE_GROUP(xScalarAId, status)
01120     call XF_CLOSE_GROUP(xDsetsId, status)
01121     call XF_CLOSE_FILE(xFileId, status)
01122     return 
01123   endif
01124 
01125   ! Add in a reftime.  This is a julian day for:
01126   ! noon July 1, 2003
01127   dJulianReftime = 2452822.0;
01128   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
01129   if (status < 0) then
01130     call XF_CLOSE_GROUP(xScalarAId, status)
01131     call XF_CLOSE_GROUP(xDsetsId, status)
01132     call XF_CLOSE_FILE(xFileId, status)
01133   endif
01134 
01135   ! Loop through timesteps adding them to the file
01136   do iTimestep = 1, nTimes
01137     ! We will have an 0.5 hour timestep
01138     dTime = iTimestep * 0.5
01139 
01140     fValues(1) = dTime
01141     do i = 2, nValues
01142       fValues(i) = fValues(i-1)*2.5
01143     end do
01144 
01145     ! write the dataset array values
01146     call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, status)
01147     if (status .GE. 0) then
01148       ! write activity array
01149       call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, status)
01150     end if 
01151   enddo
01152 
01153   ! close the dataset
01154   call XF_CLOSE_GROUP(xScalarAId, status)
01155   !call XF_CLOSE_GROUP(a_GroupID, status)
01156   !call XF_CLOSE_FILE(a_FileID, status)
01157 
01158   return
01159 END SUBROUTINE
01160 ! tdWriteScalarAToMulti
01161 ! --------------------------------------------------------------------------
01162 ! FUNCTION tdReadVector2DAIndex
01163 ! PURPOSE  Read all timestep values for a particular index
01164 ! NOTES    
01165 ! --------------------------------------------------------------------------
01166 SUBROUTINE TD_READ_VECTOR2D_A_INDEX (a_Filename, a_Index, error)
01167 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
01168 INTEGER, INTENT(IN)   :: a_Index
01169 INTEGER, INTENT(OUT)  :: error
01170 INTEGER           status
01171 INTEGER    xFileId, xDsetsId, xVector2DA
01172 INTEGER           nTimesteps, i
01173 REAL, ALLOCATABLE     :: fValues(:)
01174 
01175 xFileId = NONE
01176 xDsetsId = NONE
01177 xVector2DA = NONE
01178 
01179   ! open the file
01180 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
01181 if (status < 0) then
01182   error = -1
01183   return
01184 endif
01185 
01186   ! open the dataset group
01187 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01188 if (status >= 0) then
01189   call XF_OPEN_GROUP(xDsetsId, VECTOR2D_A_LOCATION, xVector2DA, status)
01190 endif
01191 if (status < 0) then
01192   error = status
01193   return
01194 endif
01195 
01196   ! Find out the number of timesteps in the file
01197 call XF_GET_DATASET_NUM_TIMES(xVector2DA, nTimesteps, status)
01198 if (status < 0) then
01199   error = status
01200   return
01201 endif
01202 
01203 if (nTimesteps < 1) then
01204   error = -1
01205   return
01206 endif
01207 
01208   ! Read the values for the index
01209 allocate(fValues(nTimesteps*2))
01210 call XF_READ_VECTOR_VALUES_AT_INDEX(xVector2DA, a_Index, 1, nTimesteps, 2, &
01211                                      fValues, status)
01212 
01213   ! output the data
01214 WRITE(*,*) ''
01215 WRITE(*,*) 'Reading vector 2D A slice at index: ', a_Index
01216 do i=1, nTimesteps
01217   WRITE(*,*) fValues(i*2-1), ' ', fValues(i*2)
01218 enddo
01219 WRITE(*,*) ''
01220 
01221 deallocate(fValues)
01222 
01223 error = status
01224 return
01225 
01226 END SUBROUTINE
01227 !tdReadVector2DAIndex
01228 
01229 ! --------------------------------------------------------------------------
01230 ! FUNCTION tdWriteVector2D_A
01231 ! PURPOSE  Write scalar Dataset to an HDF5 File
01232 ! NOTES    This tests dynamic data sets, and activity
01233 !          This dataset is dynamic concentrations (mg/L) with output times
01234 !          in minutes.
01235 !          Dataset is for a mesh and so nActive is the number of elements
01236 !          which is not the same as the nValues which would be number of nodes
01237 !          reads/writes a reference time in julian days
01238 ! --------------------------------------------------------------------------
01239 SUBROUTINE TD_WRITE_VECTOR2D_A (a_Filename, a_Compression, error)
01240   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
01241   INTEGER, INTENT(IN)          :: a_Compression
01242   INTEGER, INTENT(OUT)         :: error
01243   INTEGER      xFileId, xDsetsId, xVector2D_A, xCoordId
01244   INTEGER      nValues, nTimes, nComponents, nActive
01245   REAL(DOUBLE) dTime
01246   INTEGER      iTimestep, iActive
01247   REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues
01248   INTEGER*1    bActivity(100) ! activity
01249   INTEGER      i, j, status
01250   INTEGER      iHpgnZone
01251 
01252   ! initialize the data
01253   nComponents = 2
01254   nValues = 100
01255   nTimes = 6
01256   nActive = 75
01257   dTime = 0.0
01258 
01259   ! 5th item in data set is always inactive, others active
01260   bActivity(1) = 0
01261   do iActive = 2, nActive
01262     if (mod(iActive-1, 3) == 0) then
01263       bActivity(iActive) = 0
01264     else
01265     bActivity(iActive) = 1
01266   endif
01267   enddo
01268 
01269   ! create the file
01270   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
01271   if (error .LT. 0) then
01272     ! close the dataset
01273     call XF_CLOSE_FILE(xFileId, error)
01274     return
01275   endif
01276 
01277   ! create the group where we will put all the datasets 
01278   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01279   if (status < 0) then
01280     call XF_CLOSE_FILE(xFileId, error)
01281     error = -1
01282   return
01283   endif
01284 
01285   ! Create the vector dataset group
01286   call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_A_LOCATION, 'ft/s', &
01287               TS_SECONDS, a_Compression, xVector2D_A, status)
01288   if (status .LT. 0) then
01289       ! close the dataset
01290     call XF_CLOSE_GROUP(xVector2D_A, error)
01291     call XF_CLOSE_GROUP(xDsetsId, error)
01292     call XF_CLOSE_FILE(xFileId, error)
01293     error = status
01294     return 
01295   endif
01296 
01297   ! Loop through timesteps adding them to the file
01298   do iTimestep = 1, nTimes
01299     ! We will have an 0.5 hour timestep
01300     dTime = iTimestep * 0.5
01301 
01302     do i = 1, nValues
01303       do j = 1, nComponents
01304         fValues(j,i) = ((i-1)*nComponents + j)*dTime
01305       end do
01306     end do
01307 
01308     ! write the dataset array values
01309     call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, &
01310                                   fValues, error)
01311     if (error .GE. 0) then
01312       ! write activity array
01313       call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, error)
01314     end if 
01315   enddo
01316 
01317   ! Write Coordinate file - for Vector2D_A, we will set the coordinate system
01318   !   to be Geographic HPGN, with HPGN settings written to the file.
01319   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01320   if (status < 0) then
01321     call XF_CLOSE_GROUP(xVector2D_A, error)
01322     call XF_CLOSE_GROUP(xDsetsId, error)
01323     call XF_CLOSE_FILE(xFileId, error)
01324   error = -1
01325   return
01326   endif
01327 
01328     ! set HPGN info for test
01329   iHpgnZone = 29   ! Utah
01330 
01331   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
01332   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01333   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01334   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01335 
01336     ! write additional information
01337   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
01338 
01339   call XF_CLOSE_GROUP(xCoordId, error)
01340   xCoordId = 0
01341 
01342   ! close the dataset
01343   call XF_CLOSE_GROUP(xVector2D_A, error)
01344   call XF_CLOSE_GROUP(xDsetsId, error)
01345   call XF_CLOSE_FILE(xFileId, error)
01346 
01347   return
01348 END SUBROUTINE
01349 ! tdWriteVector2D_A
01350 
01351 ! --------------------------------------------------------------------------
01352 ! FUNCTION tdWriteVector2D_A_PIECES
01353 ! PURPOSE  Write scalar Dataset to an HDF5 File
01354 ! NOTES    This tests dynamic data sets, and activity
01355 !          This dataset is dynamic concentrations (mg/L) with output times
01356 !          in minutes.
01357 !          Dataset is for a mesh and so nActive is the number of elements
01358 !          which is not the same as the nValues which would be number of nodes
01359 !          reads/writes a reference time in julian days
01360 ! --------------------------------------------------------------------------
01361 SUBROUTINE TD_WRITE_VECTOR2D_A_PIECES (a_Filename, a_Compression, error)
01362   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
01363   INTEGER, INTENT(IN)          :: a_Compression
01364   INTEGER, INTENT(OUT)         :: error
01365   INTEGER      xFileId, xDsetsId, xVector2D_A, xCoordId
01366   INTEGER      nValues, nTimes, nComponents, nActive
01367   REAL(DOUBLE) dTime
01368   INTEGER      iTimestep, iActive
01369   REAL*4, DIMENSION(2, 100) :: fValues ! nComponents, nValues
01370   INTEGER*1    bActivity(100) ! activity
01371   INTEGER      i, j, status
01372   INTEGER      iHpgnZone
01373   INTEGER      nValuesToWrite, nComponentsToWrite, startComponent
01374   REAL*4       minvalue, maxvalue
01375   INTEGER      timeId
01376   REAL*8       mag
01377 
01378   ! initialize the data
01379   nComponents = 2
01380   nValues = 100
01381   nTimes = 6
01382   nActive = 75
01383   dTime = 0.0
01384 
01385   ! 5th item in data set is always inactive, others active
01386   bActivity(1) = 0
01387   do iActive = 2, nActive
01388     if (mod(iActive-1, 3) == 0) then
01389       bActivity(iActive) = 0
01390     else
01391     bActivity(iActive) = 1
01392   endif
01393   enddo
01394 
01395   ! create the file
01396   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
01397   if (error .LT. 0) then
01398     ! close the dataset
01399     call XF_CLOSE_FILE(xFileId, error)
01400     return
01401   endif
01402 
01403   ! create the group where we will put all the datasets 
01404   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01405   if (status < 0) then
01406     call XF_CLOSE_FILE(xFileId, error)
01407     error = -1
01408   return
01409   endif
01410 
01411   ! Create the vector dataset group
01412   call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_A_LOCATION, 'ft/s', &
01413               TS_SECONDS, a_Compression, xVector2D_A, status)
01414   if (status .LT. 0) then
01415       ! close the dataset
01416     call XF_CLOSE_GROUP(xVector2D_A, error)
01417     call XF_CLOSE_GROUP(xDsetsId, error)
01418     call XF_CLOSE_FILE(xFileId, error)
01419     error = status
01420     return 
01421   endif
01422 
01423   ! Loop through timesteps adding them to the file
01424   do iTimestep = 1, nTimes
01425     ! We will have an 0.5 hour timestep
01426     dTime = iTimestep * 0.5
01427 
01428     do i = 1, nValues
01429       do j = 1, nComponents
01430         fValues(j,i) = ((i-1)*nComponents + j)*dTime
01431       end do
01432     end do
01433 
01434     minvalue = 99999.0
01435     maxvalue = 0.0
01436     do i = 1, nValues
01437       mag = 0.0
01438       do j = 1, nComponents
01439         mag = mag + fValues(j, i)**2
01440       end do
01441       mag = mag**0.5
01442      
01443       minvalue = min(minvalue, mag)
01444       maxvalue = max(maxvalue, mag)
01445     end do
01446 
01447     ! write the dataset array values
01448     call XF_INITIALIZE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, &
01449             minvalue, maxvalue, timeId, error)
01450     
01451     nValuesToWrite = 2
01452     nComponentsToWrite = 2
01453     startComponent = 1
01454     
01455     do i = 1, nValues, +2
01456       call XF_WRITE_VECTOR_TIMESTEP_PORTION(xVector2D_A, timeId, nValuesToWrite, &
01457               nComponentsToWrite, i, startComponent, fValues(1, i), error)
01458     enddo
01459 
01460     if (error .GE. 0) then
01461       ! write activity array
01462       call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, error)
01463     end if 
01464   enddo
01465 
01466   ! Write Coordinate file - for Vector2D_A, we will set the coordinate system
01467   !   to be Geographic HPGN, with HPGN settings written to the file.
01468   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01469   if (status < 0) then
01470     call XF_CLOSE_GROUP(xVector2D_A, error)
01471     call XF_CLOSE_GROUP(xDsetsId, error)
01472     call XF_CLOSE_FILE(xFileId, error)
01473   error = -1
01474   return
01475   endif
01476 
01477     ! set HPGN info for test
01478   iHpgnZone = 29   ! Utah
01479 
01480   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
01481   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01482   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01483   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01484 
01485     ! write additional information
01486   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
01487 
01488   call XF_CLOSE_GROUP(xCoordId, error)
01489   xCoordId = 0
01490 
01491   ! close the dataset
01492   call XF_CLOSE_GROUP(xVector2D_A, error)
01493   call XF_CLOSE_GROUP(xDsetsId, error)
01494   call XF_CLOSE_FILE(xFileId, error)
01495 
01496   return
01497 END SUBROUTINE
01498 ! tdWriteVector2D_A_PIECES
01499 
01500 ! --------------------------------------------------------------------------
01501 ! FUNCTION TD_WRITE_VECTOR2D_B
01502 ! PURPOSE  Write scalar Dataset to an HDF5 File
01503 ! NOTES    This tests dynamic data sets, and activity
01504 !          This dataset is dynamic concentrations (mg/L) with output times
01505 !          in minutes.
01506 !          Dataset is for a mesh and so nActive is the number of elements
01507 !          which is not the same as the nValues which would be number of nodes
01508 !          reads/writes a reference time in julian days
01509 ! --------------------------------------------------------------------------
01510 SUBROUTINE TD_WRITE_VECTOR2D_B (a_Filename, a_Compression, a_Overwrite, error)
01511   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
01512   INTEGER, INTENT(IN)          :: a_Compression
01513   LOGICAL, INTENT(IN)          :: a_Overwrite
01514   INTEGER, INTENT(OUT)         :: error
01515   INTEGER      xFileId, xDsetsId, xVector2D_B, xCoordId
01516   INTEGER      nValues, nTimes, nComponents, nActive
01517   REAL(DOUBLE) dTime
01518   INTEGER      iTimestep, iActive
01519   REAL, DIMENSION(2, 100) :: fValues
01520   INTEGER*1    bActivity(100)
01521   INTEGER      i, j, status
01522 
01523     ! initialize the data
01524   nComponents = 2
01525   nValues = 100
01526   nTimes = 6
01527   nActive = 75
01528   dTime = 0.0
01529 
01530     ! 5th item in data set is always inactive, others active
01531   bActivity(1) = 0
01532   do iActive = 2, nActive
01533     if (mod(iActive-1, 3) == 0) then
01534       bActivity(iActive) = 0
01535     else
01536       bActivity(iActive) = 1
01537     endif
01538   enddo
01539 
01540   if (a_Overwrite) then
01541       ! open the already-existing file
01542     call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status)
01543     if (status < 0) then
01544       error = -1
01545       return
01546     endif
01547       ! open the group where we have all the datasets
01548     call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01549     if (status < 0) then
01550       call XF_CLOSE_FILE(xFileId, error)
01551       error = -1
01552       return
01553     endif
01554   else
01555       ! create the file
01556     call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
01557     if (error .LT. 0) then
01558         ! close the dataset
01559       call XF_CLOSE_FILE(xFileId, error)
01560       return
01561     endif
01562 
01563       ! create the group where we will put all the datasets 
01564     call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01565     if (status < 0) then
01566       call XF_CLOSE_FILE(xFileId, error)
01567       error = -1
01568       return
01569     endif
01570   endif
01571 
01572     ! Create/Overwrite the vector dataset group
01573   call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_B_LOCATION, 'ft/s', &
01574                                 TS_SECONDS, a_Compression, xVector2D_B, status)
01575   if (status .LT. 0) then
01576       ! close the dataset
01577     call XF_CLOSE_GROUP(xVector2D_B, error)
01578     call XF_CLOSE_GROUP(xDsetsId, error)
01579     call XF_CLOSE_FILE(xFileId, error)
01580     error = status
01581     return 
01582   endif
01583 
01584   if (.NOT. a_Overwrite) then
01585       ! Loop through timesteps adding them to the file
01586     do iTimestep = 1, nTimes
01587         ! We will have an 0.5 hour timestep
01588       dTime = iTimestep * 0.5
01589       do i = 1, nValues
01590         do j = 1, nComponents
01591           fValues(j,i) = ((i-1)*nComponents + j)*dTime
01592         end do
01593       end do
01594         ! write the dataset array values
01595       call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, &
01596                                     fValues, error)
01597       if (error .GE. 0) then
01598           ! write activity array
01599         call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error)
01600       end if
01601       if (error < 0) then
01602         call XF_CLOSE_GROUP(xVector2D_B, error)
01603         call XF_CLOSE_GROUP(xDsetsId, error)
01604         call XF_CLOSE_FILE(xFileId, error)
01605       endif
01606     enddo
01607   else
01608       ! Loop through timesteps adding them to the file
01609     do iTimestep = 1, nTimes
01610         ! We will have an 1.5 hour timestep
01611       dTime = iTimestep * 1.5
01612       do i = 1, nValues
01613         do j = 1, nComponents
01614           fValues(j,i) = ((i-1)*nComponents + j)*dTime
01615         end do
01616       end do
01617         ! write the dataset array values
01618       call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, &
01619                                     fValues, error)
01620       if (error .GE. 0) then
01621           ! write activity array
01622         call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error)
01623       end if
01624       if (error < 0) then
01625         call XF_CLOSE_GROUP(xVector2D_B, error)
01626         call XF_CLOSE_GROUP(xDsetsId, error)
01627         call XF_CLOSE_FILE(xFileId, error)
01628       endif
01629     enddo
01630   endif
01631 
01632   if (.NOT. a_Overwrite) then
01633     ! Write Coordinate file - for ScalarB, we will set the coordinate system
01634     !   to be UTM, with UTM Zone settings written to the file.
01635     call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01636     if (status < 0) then
01637       call XF_CLOSE_GROUP(xVector2D_B, error)
01638       call XF_CLOSE_GROUP(xDsetsId, error)
01639       call XF_CLOSE_FILE(xFileId, error)
01640     error = -1
01641     return
01642     endif
01643 
01644       ! write the coordinate data to the file
01645     call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
01646     call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01647     call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01648     call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01649 
01650       ! write additional information - we'll use the max UTM zone for the test
01651     call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
01652 
01653     call XF_CLOSE_GROUP(xCoordId, error)
01654     xCoordId = 0
01655   endif
01656 
01657   ! close the dataset
01658   call XF_CLOSE_GROUP(xVector2D_B, error)
01659   call XF_CLOSE_GROUP(xDsetsId, error)
01660   call XF_CLOSE_FILE(xFileId, error)
01661 
01662   return
01663 END SUBROUTINE
01664 ! tdWriteVector2D_B
01665 
01666 ! --------------------------------------------------------------------------
01667 ! FUNCTION tdWriteVector2D_AToMulti
01668 ! PURPOSE  Write scalar Dataset to an HDF5 File
01669 ! NOTES    This tests dynamic data sets, and activity
01670 !          This dataset is dynamic concentrations (mg/L) with output times
01671 !          in minutes.
01672 !          Dataset is for a mesh and so nActive is the number of elements
01673 !          which is not the same as the nValues which would be number of nodes
01674 !          reads/writes a reference time in julian days
01675 ! --------------------------------------------------------------------------
01676 SUBROUTINE TD_WRITE_VECTOR2D_A_TO_MULTI (a_FileID, a_GroupID, status)
01677   INTEGER      xVector2D_A
01678   INTEGER      a_FileID, a_GroupID
01679   INTEGER      nValues, nTimes, nComponents, nActive
01680   REAL(DOUBLE) dTime
01681   INTEGER      iTimestep, iActive
01682   REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues
01683   INTEGER*1    bActivity(100) ! activity
01684   INTEGER      i, j, status
01685 
01686   ! initialize the data
01687   nComponents = 2
01688   nValues = 100
01689   nTimes = 6
01690   nActive = 75
01691   dTime = 0.0
01692 
01693   ! 5th item in data set is always inactive, others active
01694   bActivity(1) = 0
01695   do iActive = 2, nActive
01696     if (mod(iActive-1, 3) == 0) then
01697       bActivity(iActive) = 0
01698     else
01699     bActivity(iActive) = 1
01700   endif
01701   enddo
01702 
01703   ! Create the vector dataset group
01704   call XF_CREATE_VECTOR_DATASET(a_GroupID, VECTOR2D_A_LOCATION, 'ft/s', &
01705               TS_SECONDS, NONE, xVector2D_A, status)
01706   if (status .LT. 0) then
01707       ! close the dataset
01708     call XF_CLOSE_GROUP(xVector2D_A, status)
01709     call XF_CLOSE_GROUP(a_GroupID, status)
01710     call XF_CLOSE_FILE(a_FileID, status)
01711     return 
01712   endif
01713 
01714   ! Loop through timesteps adding them to the file
01715   do iTimestep = 1, nTimes
01716     ! We will have an 0.5 hour timestep
01717     dTime = iTimestep * 0.5
01718 
01719     do i = 1, nValues
01720       do j = 1, nComponents
01721         fValues(j,i) = ((i-1)*nComponents + j)*dTime
01722       end do
01723     end do
01724 
01725     ! write the dataset array values
01726     call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, &
01727                                   fValues, status)
01728     if (status .GE. 0) then
01729       ! write activity array
01730       call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, status)
01731     end if 
01732   enddo
01733 
01734   ! close the dataset
01735   call XF_CLOSE_GROUP(xVector2D_A, status)
01736   return
01737 END SUBROUTINE
01738 ! tdWriteVector2D_AToMulti
01739 ! --------------------------------------------------------------------------
01740 ! FUNCTION tdiReadScalar
01741 ! PURPOSE  Read a scalar from an XMDF file and output information to
01742 !          to a text file
01743 ! NOTES    
01744 ! --------------------------------------------------------------------------
01745 SUBROUTINE TDI_READ_SCALAR (a_xScalarId, FileUnit, error)
01746   INTEGER, INTENT(IN) ::  a_xScalarId
01747   INTEGER, INTENT(IN) ::         FileUnit
01748   INTEGER, INTENT(OUT) :: error
01749   INTEGER             nTimes, nValues, nActive
01750   LOGICAL*2             bUseReftime
01751   INTEGER             iTime
01752   CHARACTER(LEN=100)   TimeUnits
01753   REAL(DOUBLE), ALLOCATABLE :: Times(:)
01754   REAL, ALLOCATABLE         :: Values(:), Minimums(:), Maximums(:)
01755   INTEGER, ALLOCATABLE      :: Active(:)
01756   REAL(DOUBLE)                 Reftime
01757 nTimes = NONE
01758 nValues = NONE
01759 nActive = None
01760 
01761   ! read the time units
01762   call XF_GET_DATASET_TIME_UNITS(a_xScalarId, TimeUnits, error)
01763   if (error < 0) return
01764 
01765   WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits))
01766 
01767   ! see if we are using a reftime
01768   call XF_USE_REFTIME (a_xScalarId, bUseReftime, error)
01769   if (error < 0) then
01770     return
01771   endif
01772   if (bUseReftime) then
01773     call XF_READ_REFTIME (a_xScalarId, Reftime, error)
01774     if (error < 0) then
01775       return
01776   endif
01777     WRITE(FileUnit,*) 'Reftime: ', Reftime
01778   endif
01779 
01780   ! read in the number of values and number of active values
01781   call XF_GET_DATASET_NUMVALS(a_xScalarId, nValues, error)
01782   if (error .GE. 0) then
01783     call XF_GET_DATASET_NUMACTIVE(a_xScalarId, nActive, error)
01784   endif
01785   if (error .LT. 0) return 
01786 
01787   if (nValues <= 0) then
01788     WRITE(FileUnit, *) 'No data to read in.'
01789     error = -1
01790     return 
01791   endif
01792 
01793   ! read in the number of times
01794   call XF_GET_DATASET_NUM_TIMES(a_xScalarId, nTimes, error)
01795   if (error < 0) then
01796     return 
01797   endif
01798 
01799   ! Read in the individual time values
01800   allocate(Times(nTimes))
01801 
01802   call XF_GET_DATASET_TIMES(a_xScalarId, nTimes, Times, error)
01803   if (error < 0) return 
01804 
01805   ! Read in the minimum and maximum values
01806   allocate(Minimums(nTimes))
01807   allocate(Maximums(nTimes))
01808 
01809   call XF_GET_DATASET_MINS(a_xScalarId, nTimes, Minimums, error)
01810   if (error >= 0) then
01811     call XF_GET_DATASET_MAXS(a_xScalarId, nTimes, Maximums, error)
01812   endif
01813   if (error < 0) then
01814     deallocate(Times)
01815     deallocate(Minimums)
01816     deallocate(Maximums)
01817     return
01818   endif
01819 
01820   allocate(Values(nValues))
01821   if (nActive .GT. 0) then
01822     allocate(Active(nActive))
01823   endif
01824 
01825   WRITE(FileUnit,*) 'Number Timesteps: ', nTimes
01826   WRITE(FileUnit,*) 'Number Values: ', nValues
01827   WRITE(FileUnit,*) 'Number Active: ', nActive
01828   WRITE(FileUnit,*) ''
01829 
01830   ! loop through the timesteps, read the values and active values and write
01831   ! them to the text file
01832   do iTime = 1, nTimes
01833     call XF_READ_SCALAR_VALUES_TIMESTEP(a_xScalarId, iTime, nValues, Values, error)
01834     if (error >= 0 .AND. nActive > 0) then
01835       call XF_READ_ACTIVITY_TIMESTEP(a_xScalarId, iTime, nActive, Active, error)
01836     endif
01837 
01838     ! Write the time, min, max, values and active values to the text output
01839     ! file.
01840     WRITE(FileUnit,*) 'Timestep at  ', Times(iTime)
01841     WRITE(FileUnit,*) 'Min: ', Minimums(iTime)
01842     WRITE(FileUnit,*) 'Max: ', Maximums(iTime)
01843 
01844     WRITE(FileUnit,*) 'Values:'
01845     WRITE(FileUnit,*) Values(1:nValues)
01846     WRITE(FileUnit,*) ''
01847 
01848     WRITE(FileUnit,*) 'Activity:'
01849     WRITE(FileUnit,*) Active(1:nActive)
01850     WRITE(FileUnit,*) ''
01851   end do
01852 
01853   if (allocated(Times)) then
01854     deallocate(Times)
01855   endif
01856   
01857   if (allocated(Minimums)) then
01858     deallocate(Minimums)
01859   endif
01860 
01861   if (allocated(Maximums)) then
01862     deallocate(Maximums)
01863   endif
01864 
01865   if (allocated(Values)) then
01866     deallocate(Values)
01867   endif
01868 
01869   if (allocated(Active)) then
01870     deallocate(Active)
01871   endif
01872 
01873   return
01874 END SUBROUTINE
01875 ! tdiReadScalar
01876 
01877 ! --------------------------------------------------------------------------
01878 ! FUNCTION TDI_READ_VECTOR
01879 ! PURPOSE  Read a vector from an XMDF file and output information to
01880 !          to a text file
01881 ! NOTES    
01882 ! --------------------------------------------------------------------------
01883 SUBROUTINE TDI_READ_VECTOR (a_xVectorId, FileUnit, error)
01884   INTEGER, INTENT(IN) ::  a_xVectorId
01885   INTEGER, INTENT(IN) ::         FileUnit
01886   INTEGER, INTENT(OUT) :: error
01887   INTEGER             nTimes, nValues, nActive, nComponents
01888   INTEGER             iTime, i
01889   LOGICAL*2            bUseReftime
01890   CHARACTER(LEN=100)   TimeUnits
01891   REAL(DOUBLE), ALLOCATABLE :: Times(:)
01892   REAL, ALLOCATABLE, DIMENSION (:, :) :: Values
01893   REAL, ALLOCATABLE         :: Minimums(:), Maximums(:)
01894   INTEGER, ALLOCATABLE      :: Active(:)
01895   REAL(DOUBLE)                 Reftime
01896 
01897 nTimes = NONE
01898 nValues = NONE
01899 nActive = NONE
01900 nComponents = NONE
01901 
01902   ! read the time units
01903   call XF_GET_DATASET_TIME_UNITS(a_xVectorId, TimeUnits, error)
01904   if (error < 0) return
01905 
01906   WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits))
01907 
01908   ! see if we are using a reftime
01909   call XF_USE_REFTIME (a_xVectorId, bUseReftime, error)
01910   if (error < 0) then
01911     return
01912   endif
01913   if (bUseReftime) then
01914     call XF_READ_REFTIME (a_xVectorId, Reftime, error)
01915     if (error < 0) then
01916       return
01917   endif
01918     WRITE(FileUnit,*) 'Reftime: ', Reftime
01919   endif
01920 
01921   ! read in the number of values and number of active values
01922   call XF_GET_DATASET_NUMVALS(a_xVectorId, nValues, error)
01923   if (error .GE. 0) then
01924     call XF_GET_DATASET_NUMCOMPONENTS(a_xVectorId, nComponents, error)
01925     if (error .GE. 0) then
01926       call XF_GET_DATASET_NUMACTIVE(a_xVectorId, nActive, error)
01927     endif
01928   endif
01929   if (error .LT. 0) return 
01930 
01931   if (nValues <= 0) then
01932     WRITE(FileUnit, *) 'No data to read in.'
01933     error = -1
01934     return 
01935   endif
01936 
01937   ! read in the number of times
01938   call XF_GET_DATASET_NUM_TIMES(a_xVectorId, nTimes, error)
01939   if (error < 0) then
01940     return 
01941   endif
01942 
01943   ! Read in the individual time values
01944   allocate(Times(nTimes))
01945 
01946   call XF_GET_DATASET_TIMES(a_xVectorId, nTimes, Times, error)
01947   if (error < 0) return 
01948 
01949   ! Read in the minimum and maximum values
01950   allocate(Minimums(nTimes))
01951   allocate(Maximums(nTimes))
01952 
01953   call XF_GET_DATASET_MINS(a_xVectorId, nTimes, Minimums, error)
01954   if (error >= 0) then
01955     call XF_GET_DATASET_MAXS(a_xVectorId, nTimes, Maximums, error)
01956   endif
01957   if (error < 0) then
01958     deallocate(Times)
01959     deallocate(Minimums)
01960     deallocate(Maximums)
01961     return
01962   endif
01963 
01964   allocate(Values(nComponents, nValues))
01965   if (nActive .GT. 0) then
01966     allocate(Active(nActive))
01967   endif
01968 
01969   WRITE(FileUnit,*) 'Number Timesteps: ', nTimes
01970   WRITE(FileUnit,*) 'Number Values: ', nValues
01971   WRITE(FileUnit,*) 'Number Components: ', nComponents
01972   WRITE(FileUnit,*) 'Number Active: ', nActive
01973 
01974   ! loop through the timesteps, read the values and active values and write
01975   ! them to the text file
01976   do iTime = 1, nTimes
01977     call XF_READ_VECTOR_VALUES_TIMESTEP(a_xVectorId, iTime, nValues, &
01978                                         nComponents, Values, error)
01979     if (error >= 0 .AND. nActive > 0) then
01980       call XF_READ_ACTIVITY_TIMESTEP(a_xVectorId, iTime, nActive, Active, error)
01981     endif
01982 
01983     ! Write the time, min, max, values and active values to the text output
01984     ! file.
01985   WRITE(FileUnit,*) ''
01986     WRITE(FileUnit,*) 'Timestep at  ', Times(iTime)
01987     WRITE(FileUnit,*) 'Min: ', Minimums(iTime)
01988     WRITE(FileUnit,*) 'Max: ', Maximums(iTime)
01989 
01990     WRITE(FileUnit,*) 'Values:'
01991     do i=1, nValues
01992       WRITE(FileUnit,*) Values(1:nComponents,i:i)
01993     enddo
01994     WRITE(FileUnit,*) ''
01995 
01996     WRITE(FileUnit,*) 'Activity:'
01997     WRITE(FileUnit,*) Active(1:nActive)
01998     WRITE(FileUnit,*) ''    
01999   WRITE(FileUnit,*) ''    
02000 
02001   end do
02002 
02003   if (allocated(Times)) then
02004     deallocate(Times)
02005   endif
02006   
02007   if (allocated(Minimums)) then
02008     deallocate(Minimums)
02009   endif
02010 
02011   if (allocated(Maximums)) then
02012     deallocate(Maximums)
02013   endif
02014 
02015   if (allocated(Values)) then
02016     deallocate(Values)
02017   endif
02018 
02019   if (allocated(Active)) then
02020     deallocate(Active)
02021   endif
02022 
02023   return
02024 END SUBROUTINE
02025 ! tdiReadVector
02026 
02027 END MODULE TestDatasets
TestDatasets.f90 tests datasets
00001 MODULE TestGeomPaths
00002 
00003 USE TestDatasets
00004 USE Xmdf
00005 USE ErrorDefinitions
00006 USE XmdfDefs
00007 
00008 CONTAINS
00009 
00010 SUBROUTINE TM_READ_TEST_PATHS(Filename, OutFilename, error)
00011   CHARACTER(LEN=*), INTENT(IN) :: Filename, OutFilename
00012   INTEGER, INTENT(OUT)         :: error
00013   INTEGER                         OutUnit  
00014   INTEGER               :: xFileId, xGroupId
00015   INTEGER                         nGroups, nMaxPathLength, nDims, nPaths, nTimes
00016   INTEGER                         i, j, nStatus
00017   CHARACTER,ALLOCATABLE        :: Paths(:)
00018   REAL(DOUBLE), ALLOCATABLE    :: times(:), locs(:)
00019   REAL(DOUBLE)                    Nullval
00020   CHARACTER(LEN=BIG_STRING_SIZE) :: IndividualPath
00021   INTEGER                           StartLoc
00022   INTEGER, DIMENSION(2)        :: PathIndices
00023   INTEGER                         iTime, iPath
00024 
00025   ! open the XMDF file 
00026   CALL XF_OPEN_FILE(Filename, .FALSE., xFileId, nStatus)
00027   if (nStatus < 0) then
00028    WRITE(*) 'Unable to open XMDF file TM_READ_TEST_PATHS.'
00029     error = nStatus;
00030     return
00031   endif
00032 
00033   ! open the Output file 
00034   OutUnit = 79
00035   OPEN(UNIT=OutUnit, FILE=OutFilename, STATUS='REPLACE', ACTION='WRITE', &
00036      IOSTAT = error)
00037   if (OutUnit == 0) then
00038     call XF_CLOSE_FILE(xFileId, error)
00039     error = -1
00040     return
00041   endif
00042 
00043   ! find the geomotric path groups
00044   ! Get the number and paths of datasets in the file.
00045   CALL XF_GRP_PTHS_SZ_FOR_GEOM_PTHS(xFileId, nGroups,             &
00046                                               nMaxPathLength, nStatus)
00047   if (nStatus >= 0 .AND. nGroups > 0) then
00048     allocate (Paths(nMaxPathLength*nGroups))
00049     CALL XF_GRP_PTHS_FOR_GEOM_PTHS(xFileId, nGroups,                &
00050                                          nMaxPathLength, Paths, nStatus)
00051   endif
00052   if (nStatus < 0) then
00053     CALL XF_CLOSE_FILE(xFileId, nStatus)
00054   error = -1
00055     return
00056   endif
00057   ! Report the number and paths to individual geom paths groups in the file.
00058   WRITE(OutUnit,*) 'Number of geometric paths in file: ', nGroups
00059 
00060   do i = 1, nGroups 
00061     StartLoc = (i-1)*nMaxPathLength + 1
00062   IndividualPath = ''
00063   do j = 1, nMaxPathLength - 1
00064     IndividualPath(j:j) = Paths(StartLoc+j-1)
00065   enddo
00066     WRITE(OutUnit,*) 'Reading particles in group: ', &
00067                                      IndividualPath(1:LEN_TRIM(IndividualPath))
00068 
00069     CALL XF_OPEN_GROUP(xFileId, IndividualPath, xGroupId, nStatus)
00070     if (nStatus >= 0) then
00071       ! read the dimensionality of the paths
00072       CALL XF_GET_PATH_DIMENSIONALITY(xGroupId, nDims, nStatus)
00073       if (nStatus >= 0) then
00074         WRITE(OutUnit,*) 'Group dimensionality:', nDims
00075         ! read the number of paths
00076         CALL XF_GET_NUMBER_OF_PATHS(xGroupId, nPaths, nStatus)
00077         if (nStatus >= 0) then
00078           WRITE(OutUnit,*) 'Number of paths in group:', nPaths
00079           ! read the number of timesteps
00080           CALL XF_GET_NUMBER_OF_TIMES(xGroupId, nTimes, nStatus)
00081           if (nStatus >= 0) then
00082             WRITE(OutUnit,*) 'Number of timesteps in group:', nTimes
00083             ! allocate times array
00084       allocate(times(nTimes))
00085             CALL XF_GET_PATH_TIMES_ARRAY(xGroupId, nTimes, times, nStatus)
00086             if (nStatus >= 0) then
00087                 ! get space for the data location values
00088               allocate(locs(nPaths*nDims))
00089                 ! read null value 
00090               CALL XF_GET_PATH_NULL_VAL(xGroupId, NullVal, nStatus)
00091               if (nStatus >= 0) then
00092                 WRITE(OutUnit,*) 'Null value:', NullVal
00093                 do iTime=1, nTimes
00094                   WRITE(OutUnit,*) 'Timestep: ', times(iTime)
00095                     ! read the data for this timestep
00096                   CALL XF_READ_PATH_LOCATIONS_AT_TIME(xGroupId, iTime,    &
00097                                                      1, nPaths, locs, nStatus)
00098                   if (nStatus >= 0) then
00099                       ! write  the data for this timestep
00100                     WRITE(OutUnit,*) '  X        Y'
00101                     if (nDims == 3) then
00102                       WRITE(OutUnit,*) '       Z'
00103                     endif
00104                     WRITE(OutUnit,*) ''
00105                     do j=1, nPaths 
00106                       if (locs(j*nDims) == NullVal) then
00107                         WRITE(OutUnit,*) 'Particle not active yet'
00108                       else 
00109                         WRITE(OutUnit,*) locs((j-1)*nDims+1), ' ', locs((j-1)*nDims+2)
00110                         if (nDims == 3) then
00111                           WRITE(OutUnit,*) ' ', locs((j-1)*nDims+3)
00112                         endif
00113                         WRITE(OutUnit,*) ''
00114                       endif
00115                     enddo ! Loop through the paths
00116                   endif ! if timestep read
00117                 enddo ! Loop through timesteps
00118               endif ! if null value read
00119               if (allocated(locs)) deallocate (locs)
00120             endif ! if we get get the times array
00121                     ! get space for the data location values - 1 particle 
00122                     ! all times
00123         allocate(locs(nTimes*nDims))
00124             do iPath=1, nPaths
00125                 ! read the values for this particle for all timesteps
00126               CALL XF_READ_PATH_LOCS_FOR_PART(xGroupId, iPath, &
00127                                    1, nTimes, locs, nStatus)
00128               if (nStatus >= 0) then
00129                 ! write  the data for this path
00130                 WRITE(OutUnit,*) 'Time       X        Y'
00131                 if (nDims == 3) then
00132                   WRITE(OutUnit,*) '        Z'
00133                 endif
00134                 WRITE(OutUnit, *) ''
00135                 do j=1, nTimes
00136                   if (locs((j-1)*nDims+1) .NE. NullVal) then
00137                     WRITE(OutUnit,*) times(j), ' ', locs((j-1)*nDims + 1), ' ', &
00138                             locs((j-1)*nDims+2)
00139                     if (nDims == 3) then
00140                       WRITE(OutUnit,*) ' ', locs((j-1)*nDims+3)
00141                     endif
00142                     WRITE(OutUnit,*) ''
00143                   endif
00144                 enddo ! Loop through the times
00145               endif ! if read path locations for particle
00146             enddo ! Loop through the paths
00147             if (allocated(locs)) deallocate(locs)
00148           endif ! if allocation of locs suceeded
00149                 ! get space for the data location values - 2 particle 
00150                 ! all times
00151       allocate(locs(nTimes*nDims*2))
00152           PathIndices(1) = 1
00153           PathIndices(2) = nPaths                
00154           CALL XF_READ_PATH_LOCS_FOR_PARTS(xGroupId, 2,    &
00155                               PathIndices, 1, nTimes, locs, nStatus)
00156           if (nStatus >= 0) then
00157             ! write  the data for these 2 paths
00158             if (nDims == 3) then
00159               WRITE(OutUnit,*) 'Timestep       X1        Y1        Z1        Xn        Yn        Zn'
00160             else
00161               WRITE(OutUnit,*) 'Timestep       X1        Y1        Xn        Yn'
00162             endif
00163             do j=1, nTimes
00164               if (nDims == 3) then
00165                 WRITE(OutUnit,*) times(j), ' ', locs((j-1)*2*nDims+1), ' ',  &
00166              locs((j-1)*2*nDims+2),' ', locs((j-1)*2*nDims+3),' ',       &
00167            locs((j-1)*2*nDims+4), locs((j-1)*2*nDims+5), ' ',locs((j-1)*2*nDims+6)
00168               else
00169                 WRITE(OutUnit,*) times(j),' ', locs((j-1)*2*nDims + 1), ' ',         &
00170                            locs((j-1)*2*nDims+2), ' ',locs((j-1)*2*nDims+3)
00171               endif
00172       enddo
00173         else
00174           WRITE(*,*) 'Error reading path locations for multiple particles'
00175         endif
00176       endif
00177           if (allocated(locs)) deallocate(locs)
00178           if (allocated(times)) deallocate(times)
00179           CALL XF_CLOSE_GROUP(xGroupId, nStatus)
00180         if (nStatus < 0) then
00181           WRITE(*)'Error reading geometric paths..'
00182         endif
00183       endif
00184   endif
00185   enddo ! loop through groups
00186     ! free the paths
00187   if (allocated(Paths)) deallocate(Paths)
00188     ! close the files
00189   close(OutUnit)
00190   CALL XF_CLOSE_FILE(xFileId, nStatus)
00191   error = nStatus;
00192   return
00193 
00194 END SUBROUTINE
00195 ! tmReadTestPaths 
00196 
00197 SUBROUTINE TM_WRITE_TEST_PATHS(Filename, Compression, error)
00198   CHARACTER(LEN=*), INTENT(IN) :: Filename
00199   INTEGER, INTENT(IN)         :: Compression
00200   INTEGER, INTENT(OUT)         :: error 
00201   INTEGER                      nPaths
00202   REAL(DOUBLE), DIMENSION(6)   :: pLocs
00203   REAL, DIMENSION(2)           :: pSpeeds
00204   REAL(DOUBLE)                 NullVal
00205 
00206   REAL                         NullValSinglePrec
00207   INTEGER               xFileId, xPathGroupId, xSpeedId, xPropGroupId
00208   INTEGER                      status
00209   REAL(DOUBLE)                 Timeval
00210 
00211   nPaths = 0
00212   NullVal = -99999.9d0
00213   NullValSinglePrec = -99999.9
00214 
00215   ! create the file
00216   call XF_CREATE_FILE(Filename, .TRUE., xFileId, status)
00217   if (status < 0) then
00218     error = -1
00219     return
00220   endif
00221 
00222   ! create the group to store the particle paths 
00223   call XF_CREATE_GEOMETRIC_PATH_GROUP(xFileId, "particles", &
00224            'abcdefglasdfjoaieur', Compression, xPathGroupId, NullVal, status)
00225   if (status < 0) then
00226     error = -1
00227     return
00228   endif
00229 
00230   ! create the data set to store the speed 
00231   call XF_CREATE_SCALAR_DSET_EXTNDBL(xPathGroupId, 'Vmag', 'm/s', &
00232              TS_SECONDS, NullValSinglePrec, Compression, xSpeedId, status)
00233   if (status < 0) then
00234     error = -1
00235     return
00236   endif
00237 
00238   call XF_CREATE_PROPERTY_GROUP(xSpeedId, xPropGroupId, status)
00239   if (status < 0) then
00240     call XF_CLOSE_GROUP(xSpeedId, status)
00241     error = -1
00242     return
00243   endif
00244   call XF_WRITE_PROPERTY_FLOAT(xPropGroupId, PROP_NULL_VALUE, 1, &
00245                                NullValSinglePrec, -1, status)
00246   call XF_CLOSE_GROUP(xPropGroupId, status)
00247 
00248   ! Setup the arrays for the path group at timestep 0 
00249   ! particle location at the first timestep
00250   nPaths = 1
00251   pLocs(1) = 1.0
00252   pLocs(2) = 2.0
00253   pLocs(3) = 3.0
00254   
00255     ! store the particles for the first timestep
00256   Timeval = 0.0
00257   call XF_WRITE_PARTICLE_TIMESTEP(xPathGroupId, 3, Timeval, nPaths, pLocs, status)
00258   if (status < 0) then
00259     error = -1
00260     return 
00261   endif
00262    ! set up and store the speed at timestep 0
00263   pSpeeds(1) = 1.1
00264   Timeval = 0.0
00265   call XF_WRITE_SCALAR_TIMESTEP(xSpeedId, Timeval, 1, pSpeeds, status) 
00266   if (status < 0) then
00267     error = -1
00268     return
00269   endif
00270 
00271   ! Setup the arrays for the path group at timestep 1 
00272   ! particle location at the first timestep
00273   pLocs(1) = 4.0
00274   pLocs(2) = 5.0
00275   pLocs(3) = 6.0
00276   
00277   ! store the particles for the second timestep
00278   Timeval = 1.0
00279   call XF_WRITE_PARTICLE_TIMESTEP(xPathGroupId, 3, Timeval, nPaths, pLocs, status)
00280   if (status < 0) then
00281     error = -1
00282     return
00283   endif
00284   
00285   ! set up and store the speed at timestep 2
00286   pSpeeds(1) = 1.2
00287   call XF_WRITE_SCALAR_TIMESTEP(xSpeedId, Timeval, 1, pSpeeds, status) 
00288   if (status < 0) then
00289     error = -1
00290     return
00291   endif
00292 
00293   ! Setup the arrays for the path group at timestep 3-add a particle
00294   ! particle location at the first timestep
00295   nPaths = 2
00296   pLocs(1) = 7.0
00297   pLocs(2) = 8.0
00298   pLocs(3) = 9.0
00299   pLocs(4) = -1.0
00300   pLocs(5) = -2.0
00301   pLocs(6) = -3.0
00302   
00303   ! store the particles for the timestep 3
00304   Timeval = 2.0
00305   call XF_WRITE_PARTICLE_TIMESTEP(xPathGroupId, 3, Timeval, nPaths, pLocs, status)
00306   if (status < 0) then
00307     error = -1
00308     return
00309   endif
00310 
00311   ! extend the data set for speed
00312   call XF_EXTEND_SCALAR_DATASET(xSpeedId, 2, status)
00313   if (status < 0) then
00314     error = -1
00315     return
00316   endif
00317 
00318   ! set up and store the speed at timestep 4
00319   pSpeeds(1) = 1.3
00320   pSpeeds(2) = 2.1
00321   call XF_WRITE_SCALAR_TIMESTEP(xSpeedId, Timeval, 2, pSpeeds, status) 
00322   if (status < 0) then
00323     error = -1
00324     return
00325   endif
00326 
00327   ! Setup the arrays for the path group at timestep 3-inactive particle(static)
00328   ! particle location at the first timestep
00329   pLocs(1) = 7.0
00330   pLocs(2) = 8.0
00331   pLocs(3) = 9.0
00332   pLocs(4) = -4.0
00333   pLocs(5) = -5.0
00334   pLocs(6) = -6.0
00335   
00336   ! store the particles for timestep 4
00337   Timeval = 3.0
00338   call XF_WRITE_PARTICLE_TIMESTEP(xPathGroupId, 3, Timeval, nPaths, pLocs, status)
00339   if (status < 0) then
00340     error = -1
00341     return
00342   endif
00343 
00344   ! set up and store the speed at timestep 4
00345   pSpeeds(1) = NullVal
00346   pSpeeds(2) = 2.2
00347   call XF_WRITE_SCALAR_TIMESTEP(xSpeedId, Timeval, 2, pSpeeds, status) 
00348   if (status < 0) then
00349     error = -1
00350     return
00351   endif
00352 
00353   ! close the resources
00354   call XF_CLOSE_GROUP(xSpeedId, status)
00355   call XF_CLOSE_GROUP(xPathGroupId, status)
00356   call XF_CLOSE_FILE(xFileId, status)
00357 
00358   error = 1
00359   return
00360 END SUBROUTINE
00361 
00362 END MODULE TestGeomPaths
TestGeomPaths.f90 tests geometry paths
00001 MODULE TestGrid
00002 
00003 USE ErrorDefinitions
00004 USE XmdfDefs
00005 USE Xmdf
00006 
00007 CHARACTER(LEN=*),PARAMETER :: GRID_CART2D_GROUP_NAME = 'Grid Cart2D Group'
00008 CHARACTER(LEN=*),PARAMETER :: GRID_CURV2D_GROUP_NAME = 'Grid Curv2D Group'
00009 CHARACTER(LEN=*),PARAMETER :: GRID_CART3D_GROUP_NAME = 'Grid Cart3D Group'
00010 
00011 CONTAINS
00012 
00013 !****************************
00014 ! ---------------------------------------------------------------------------
00015 ! FUNCTION  TG_READ_GRID
00016 ! PURPOSE   Read a grid and write data to a text file
00017 ! NOTES     
00018 ! ---------------------------------------------------------------------------
00019 SUBROUTINE  TG_READ_GRID(a_Id, a_Outfile, error)
00020 INTEGER, INTENT(IN) :: a_Id
00021 INTEGER, INTENT(IN)        :: a_Outfile
00022 INTEGER, INTENT(OUT)       :: error
00023 INTEGER nGridType, nExtrudeType, nDims, nCellsI, nCellsJ
00024 INTEGER nCellsK, nLayers, nOrientation, nValsI, nValsJ
00025 INTEGER nValsK, nExtrudeVals, nCompOrigin, nUDir
00026 CHARACTER(265) strGridType, strExtrudeType
00027 LOGICAL*2 bDefined
00028 REAL(DOUBLE) dOrigin(3), dBearing, dDip, dRoll
00029 REAL(DOUBLE), ALLOCATABLE :: dExtrudeVals(:), dCoordI(:), dCoordJ(:)
00030 REAL(DOUBLE), ALLOCATABLE :: dCoordK(:)
00031 INTEGER i
00032 
00033 nGridType = 0
00034 nExtrudeType = 0
00035 nDims = 0
00036 nCellsI = 0
00037 nCellsJ = 0
00038 nCellsK = 0
00039 nLayers = 0
00040 nOrientation = 0
00041 nValsI = 0
00042 nValsJ = 0
00043 nValsK = 0
00044 nExtrudeVals = 0
00045 nCompOrigin = 1
00046 nUDir = 1
00047 bDefined = .FALSE.
00048 dBearing = 0.0
00049 dDip = 0.0
00050 dRoll =0.0
00051 i = 0
00052 error = 1
00053 
00054   ! Grid type
00055 call XF_GET_GRID_TYPE(a_Id, nGridType, error)
00056 if (error < 0) then
00057   return
00058 endif
00059 SELECT CASE (nGridType) 
00060   CASE (GRID_TYPE_CARTESIAN)
00061     strGridType = 'Cartesian'
00062   CASE (GRID_TYPE_CURVILINEAR)
00063     strGridType = 'Curvilinear'
00064   CASE (GRID_TYPE_CARTESIAN_EXTRUDED)
00065     strGridType = 'Cartesian extruded'
00066   CASE (GRID_TYPE_CURVILINEAR_EXTRUDED)
00067     strGridType = 'Curvilinear extruded'
00068   CASE DEFAULT
00069     WRITE(*,*) 'Invalid grid type'
00070     error = -1
00071 END SELECT
00072 WRITE(a_Outfile,*) 'The grid type is: ', strGridType(1:LEN_TRIM(strGridType))
00073 
00074   ! Number of dimensions
00075 call XF_GET_NUMBER_OF_DIMENSIONS(a_Id, nDims, error)
00076 if (error .LT. 0) then
00077   return
00078 endif
00079 if (nDims == 2) then
00080   WRITE(a_Outfile,*) 'The grid is two-dimensional'
00081 elseif (nDims == 3) then
00082   WRITE(a_Outfile,*) 'The grid is three-dimensional'
00083 else
00084   WRITE(*,*) 'The grid dimensions are invalid'
00085   error = -1
00086 endif
00087 
00088   ! Extrusion type if applicable
00089 if (nGridType .EQ. GRID_TYPE_CARTESIAN_EXTRUDED .OR. &
00090     nGridType .EQ. GRID_TYPE_CURVILINEAR_EXTRUDED) then
00091   call XF_GET_EXTRUSION_TYPE(a_Id, nExtrudeType, error)
00092   if (error < 0) then
00093     return
00094   endif
00095   SELECT CASE (nExtrudeType)
00096     case (EXTRUDE_SIGMA)
00097       strExtrudeType = 'Sigma stretch'
00098     case (EXTRUDE_CARTESIAN)
00099       strExtrudeType = 'Cartesian'
00100     case (EXTRUDE_CURV_AT_CORNERS)
00101       strExtrudeType = 'Curvilinear at Corners'
00102     case (EXTRUDE_CURV_AT_CELLS)
00103       strExtrudeType = 'Curvilinear at Cells'
00104   END SELECT
00105   WRITE(a_Outfile,*) 'The grid is extruding using: ', &
00106                      strExtrudeType(1:LEN_TRIM(strExtrudeType))
00107 endif
00108 
00109   ! Origin
00110 call XF_ORIGIN_DEFINED(a_Id, bDefined, error)
00111 if (error < 0) then
00112   return
00113 endif
00114 if (bDefined) then
00115   call XF_GET_ORIGIN(a_Id, dOrigin(1), dOrigin(2), dOrigin(3), error)
00116   if (error < 0) then
00117     return
00118   endif
00119   WRITE(a_Outfile,*) 'The grid origin is ', dOrigin(1), ' ',&
00120                       dOrigin(2), ' ', dOrigin(3)
00121 endif
00122   
00123   ! Orientation
00124 call XF_GET_ORIENTATION(a_Id, nOrientation, error)
00125 if (error < 0) then
00126   return
00127 endif
00128 if (nOrientation == ORIENTATION_RIGHT_HAND) then
00129   WRITE(a_Outfile,*) 'The grid has a right hand orientation'
00130 elseif (nOrientation == ORIENTATION_LEFT_HAND) then
00131   WRITE(a_Outfile,*) 'The grid has a left hand orientation'
00132 else 
00133   WRITE(*,*) 'Invalid grid orientation';
00134   error = -1
00135   return
00136 endif
00137 
00138   ! Bearing
00139 call XF_BEARING_DEFINED(a_Id, bDefined, error)
00140 if (error < 0) then
00141   return
00142 endif
00143 if (bDefined) then
00144   call XF_GET_BEARING(a_Id, dBearing, error)
00145   if (error < 0) then
00146     return
00147   endif
00148   WRITE(a_Outfile,*) 'The grid bearing is ', dBearing
00149 endif
00150 
00151   ! Dip
00152 call XF_DIP_DEFINED(a_Id, bDefined, error)
00153 if (error < 0) then
00154   return
00155 endif
00156 if (bDefined) then
00157   call XF_GET_DIP(a_Id, dDip, error)
00158   if (error < 0) then
00159     return
00160   endif
00161   WRITE(a_Outfile,*) 'The grid Dip is ', dDip
00162 endif
00163 
00164 if (nDims == 3) then
00165   ! Roll
00166   call XF_ROLL_DEFINED(a_Id, bDefined, error)
00167   if (error < 0) then
00168     return
00169   endif
00170   if (bDefined) then
00171     call XF_GET_ROLL(a_Id, dRoll, error)
00172     if (error < 0) then
00173       return
00174     endif
00175     WRITE(a_Outfile,*) 'The grid Roll is ', dRoll
00176   endif
00177 endif
00178 
00179   ! Computational origin
00180 call XF_COMPUTATIONAL_ORIGIN_DEFINED(a_Id, bDefined, error)
00181 if (error < 0) then
00182   return
00183 endif
00184 if (bDefined) then
00185   call XF_GET_COMPUTATIONAL_ORIGIN(a_Id, nCompOrigin, error)
00186   if (error < 0) then
00187     return
00188   endif
00189   WRITE(a_Outfile,*) 'The grid Computational Origin is ', nCompOrigin
00190 else 
00191   WRITE(a_Outfile,*) 'The grid Computational Origin is not defined';
00192 endif
00193 
00194 
00195   ! U Direction
00196 call XF_GET_U_DIRECTION_DEFINED(a_Id, bDefined, error)
00197 if (error < 0) then
00198   return 
00199 endif
00200 if (bDefined) then
00201   call XF_GET_U_DIRECTION(a_Id, nUDir, error)
00202   if (error < 0) then
00203     return
00204   endif
00205     WRITE(a_Outfile,*) 'The grid U Direction is ', nUDir
00206 else 
00207   WRITE(a_Outfile,*) 'The grid U Direction is not defined'
00208 endif
00209 
00210   ! number of cells in each direction
00211 call XF_GET_NUMBER_CELLS_IN_I(a_Id, nCellsI, error)
00212 if (error >= 0) then
00213   call XF_GET_NUMBER_CELLS_IN_J(a_Id, nCellsJ, error)
00214   if ((error >= 0) .AND. (nDims == 3)) then 
00215     call XF_GET_NUMBER_CELLS_IN_K(a_Id, nCellsK, error)
00216   endif
00217 endif
00218 if (error < 0) then
00219   return
00220 endif
00221 WRITE(a_Outfile,*) 'Number of cells in I ', nCellsI
00222 WRITE(a_Outfile,*) 'Number of cells in J ', nCellsJ
00223 if (nDims == 3) then
00224   WRITE(a_Outfile,*) 'Number of cells in K ', nCellsK
00225 endif
00226 
00227   ! Grid coordinates 
00228 if (nGridType == GRID_TYPE_CARTESIAN .OR. &
00229     nGridType == GRID_TYPE_CARTESIAN_EXTRUDED) then
00230   nValsI = nCellsI
00231   nValsJ = nCellsJ
00232   if (nDims == 3) then
00233     nValsK = nCellsK
00234   endif
00235 elseif (nGridType == GRID_TYPE_CURVILINEAR .OR. &
00236         nGridType == GRID_TYPE_CURVILINEAR_EXTRUDED) then
00237   if (nDims == 3) then
00238       ! three dimensions
00239     nValsK = (nCellsI + 1) * (nCellsJ + 1) * (nCellsK + 1)
00240     nValsJ = nValsK
00241     nValsI = nValsJ
00242   else
00243       ! two dimensions
00244     nValsJ = (nCellsI + 1) * (nCellsJ + 1)
00245     nValsI = nValsJ
00246   endif
00247 else
00248   WRITE(*,*) 'Invalid grid type'
00249   error = -1
00250   return
00251 endif
00252 
00253 ALLOCATE(dCoordI(nValsI))
00254 ALLOCATE(dCoordJ(nValsJ))
00255 if (nDims == 3) then
00256   ALLOCATE(dCoordK(nValsK))
00257 endif
00258 
00259 call XF_GET_GRID_COORDS_I(a_Id, nValsI, dCoordI, error)
00260 if (error >= 0) then
00261   call XF_GET_GRID_COORDS_J(a_Id, nValsJ, dCoordJ, error)
00262   if ((error >= 0) .AND. (nDims == 3)) then
00263     call XF_GET_GRID_COORDS_K(a_Id, nValsK, dCoordK, error)
00264   endif
00265 endif
00266 if (error < 0) then
00267   WRITE(*,*) 'Error reading coordinates'
00268   error = -1
00269   return
00270 endif
00271 
00272 WRITE(a_Outfile,*) 'The Coordinates in direction I:'
00273 do i = 1, nValsI 
00274   if (mod(i,5) == 0) then
00275     WRITE(a_Outfile,*) ''
00276   endif
00277   WRITE(a_Outfile,*) dCoordI(i)
00278 enddo
00279 WRITE(a_Outfile,*) ''
00280 
00281 WRITE(a_Outfile,*) 'The Coordinates in direction J:'
00282 do i = 1, nValsJ
00283   if (mod(i,5) == 0) then
00284     WRITE(a_Outfile,*) ''
00285   endif
00286   WRITE(a_Outfile,*) dCoordJ(i)
00287 enddo
00288 WRITE(a_Outfile,*) ''
00289 
00290 if (nDims == 3) then
00291   WRITE(a_Outfile,*) 'The Coordinates in direction K:'
00292   do i = 1, nValsK
00293     if (mod(i,5) == 0) then
00294       WRITE(a_Outfile,*) ''
00295     endif
00296     WRITE(a_Outfile,*) dCoordK(i)
00297   enddo
00298 endif
00299 WRITE(a_Outfile,*) ''
00300 
00301 if (ALLOCATED(dCoordI)) DEALLOCATE(dCoordI)
00302 if (ALLOCATED(dCoordJ)) DEALLOCATE(dCoordJ)
00303 if (ALLOCATED(dCoordK)) DEALLOCATE(dCoordK)
00304 
00305 !  // Extrude data
00306 if (nGridType .EQ. GRID_TYPE_CARTESIAN_EXTRUDED .OR. &
00307     nGridType .EQ. GRID_TYPE_CURVILINEAR_EXTRUDED) then
00308   call XF_GET_EXTRUDE_NUM_LAYERS(a_Id, nLayers, error)
00309   if (error < 0) then
00310     return
00311   endif
00312 
00313   SELECT CASE(nExtrudeType)
00314     case (EXTRUDE_SIGMA)
00315       nExtrudeVals = nLayers
00316     case (EXTRUDE_CURV_AT_CORNERS)
00317       nExtrudeVals = (nCellsI + 1) * (nCellsJ + 1) * nLayers
00318     case (EXTRUDE_CURV_AT_CELLS)
00319       nExtrudeVals = nCellsI * nCellsJ * nLayers
00320   END SELECT
00321 
00322   ALLOCATE(dExtrudeVals(nExtrudeVals))
00323 
00324   call XF_GET_EXTRUDE_VALUES(a_Id, nExtrudeVals, dExtrudeVals, error)
00325   if (error < 0) then
00326     return
00327   endif
00328 
00329   WRITE(*,*) 'The extrude values are:'
00330   do i = 1, nExtrudeVals
00331     if (mod(i,5) == 0) then
00332       WRITE(a_Outfile,*) ''
00333     endif
00334     WRITE(a_Outfile,*) dExtrudeVals(i)
00335   enddo
00336   if (ALLOCATED(dExtrudeVals)) DEALLOCATE(dExtrudeVals)
00337 endif
00338 
00339 return
00340 
00341 END SUBROUTINE TG_READ_GRID
00342 
00343 !****************************
00344 !----------------------------------------------------------------------------
00345 ! FUNCTION   TG_WRITE_TEST_GRID_CART_2D
00346 ! PURPOSE    Write a file that contains data for a 2D Cartesian Grid
00347 ! NOTES      A picture of the grid is in the file (TestGridCart2D.gif)
00348 !            returns TRUE on success and FALSE on failure
00349 !----------------------------------------------------------------------------
00350 SUBROUTINE TG_WRITE_TEST_GRID_CART_2D(Filename, error)
00351 CHARACTER(LEN=*), INTENT(IN) :: Filename
00352 INTEGER, INTENT(OUT) :: error
00353 INTEGER        nDimensions
00354 INTEGER        nCellsI, nCellsJ
00355 INTEGER        nGridType
00356 INTEGER        nCompOrigin, nUDir
00357 REAL(DOUBLE)   dOriginX, dOriginY, dOriginZ
00358 INTEGER        nOrientation
00359 REAL(DOUBLE)   dBearing
00360 REAL(DOUBLE)   PlanesI(5), PlanesJ(5)
00361 INTEGER        i, j, iSpcZone
00362 INTEGER xFileId, xGridId, xCoordId
00363 INTEGER        status
00364 INTEGER        tmpOut1, tmpOut2
00365 
00366   nDimensions = 2
00367   nCellsI = 5
00368   nCellsJ = 5
00369   nGridType = GRID_TYPE_CARTESIAN
00370   nCompOrigin = 4
00371   nUDir = -2
00372   dOriginX = 10.0
00373   dOriginY = 10.0
00374   dOriginZ = 0.0
00375   nOrientation = ORIENTATION_RIGHT_HAND
00376   dBearing = 45.0
00377   xFileId = NONE
00378   xGridId = NONE
00379 
00380     ! Fill in the grid plane data with a constant size of 30
00381   do i = 1, nCellsI
00382     PlanesI(i) = i*30.0
00383   enddo
00384   do j = 1, nCellsJ
00385     PlanesJ(j) = j*30.0
00386   enddo
00387 
00388     ! create the file
00389   call XF_CREATE_FILE(Filename, .TRUE., xFileId, status)
00390   if (status < 0) then
00391     error = -1  
00392     return
00393   endif
00394 
00395     ! create the group to store the grid
00396   call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CART2D_GROUP_NAME, xGridId, status)
00397   if (status < 0) then
00398     call XF_CLOSE_FILE(xFileId, error)
00399     error = -1
00400     return
00401   endif
00402 
00403     ! Write the grid information to the file
00404   call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1)
00405   call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2)
00406 
00407   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00408     call XF_CLOSE_GROUP(xGridId, error)
00409     call XF_CLOSE_FILE(xFileId, error)
00410     error = -1
00411     return
00412   endif
00413 
00414     ! set origin and orientation
00415   call XF_SET_ORIGIN(xGridId, dOriginX, dOriginY, dOriginZ, tmpOut1) 
00416   call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut2)
00417 
00418   if ((tmpOut1 < 0) .OR. (tmpOut2 .LT. 0)) then
00419     call XF_CLOSE_GROUP(xGridId, error)
00420     call XF_CLOSE_FILE(xFileId, error)
00421     error = -1
00422     return
00423   endif
00424 
00425     ! Set bearing
00426   call XF_SET_BEARING(xGridId, dBearing, tmpOut1)
00427   if (tmpOut1 < 0) then
00428     call XF_CLOSE_GROUP(xGridId, error)
00429     call XF_CLOSE_FILE(xFileId, error)
00430     error = -1
00431     return
00432   endif
00433 
00434    ! Set computational origin
00435   call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1)
00436   if (tmpOut1 < 0) then
00437     call XF_CLOSE_GROUP(xGridId, error)
00438     call XF_CLOSE_FILE(xFileId, error)
00439     error = -1
00440     return
00441   endif
00442 
00443     ! Set u direction
00444   call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1)
00445   if (tmpOut1 < 0) then
00446     call XF_CLOSE_GROUP(xGridId, error)
00447     call XF_CLOSE_FILE(xFileId, error)
00448     error = -1
00449     return
00450   endif
00451 
00452     ! Write the grid geometry to the file
00453     ! Set the number of cells in each direction
00454   call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1)
00455   call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2)
00456   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00457     call XF_CLOSE_GROUP(xGridId, error)
00458     call XF_CLOSE_FILE(xFileId, error)
00459     error = -1
00460     return
00461   endif
00462 
00463     ! Set the grid plane locations
00464   call XF_SET_GRID_COORDS_I(xGridId, nCellsI, PlanesI, tmpOut1)
00465   call XF_SET_GRID_COORDS_J(xGridId, nCellsJ, PlanesJ, tmpOut2)  
00466   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00467     call XF_CLOSE_GROUP(xGridId, error)
00468     call XF_CLOSE_FILE(xFileId, error)
00469     error = -1
00470     return
00471   endif
00472 
00473   ! Write Coordinate file - for GridCart2D, we will set the coordinate system
00474   !   to be State Plane NAD27.
00475   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00476   if (status < 0) then
00477     call XF_CLOSE_GROUP(xGridId, error)
00478     call XF_CLOSE_FILE(xFileId, error)
00479   error = status
00480   return
00481   endif
00482 
00483   iSpcZone = 3601  ! Oregon North
00484 
00485   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_STATE_PLANE_NAD27, error)
00486   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
00487 
00488   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00489   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
00490 
00491     ! write additional information
00492   call XF_SET_SPC_ZONE(xCoordId, iSpcZone, error)
00493 
00494   call XF_CLOSE_GROUP(xCoordId, error)
00495   xCoordId = 0
00496 
00497   ! release memory
00498 call XF_CLOSE_GROUP(xGridId, error)
00499 call XF_CLOSE_FILE(xFileId, error)
00500 return
00501 
00502 END SUBROUTINE TG_WRITE_TEST_GRID_CART_2D
00503 
00504 !****************************
00505 !------------------------------------------------------------------------------
00506 ! FUNCTION   tgWriteTestGridCurv2D
00507 ! PURPOSE    Write a file that contains data for a 2D Curvilinear Grid
00508 ! NOTES      A picture of the grid is TestGridCurv2D.gif
00509 !            returns TRUE on success and FALSE on failure
00510 !------------------------------------------------------------------------------
00511 SUBROUTINE TG_WRITE_TEST_GRID_CURV_2D(Filename, Compression, error)
00512 CHARACTER(LEN=*), INTENT(IN) :: Filename
00513 INTEGER, INTENT(IN) :: Compression
00514 INTEGER, INTENT(OUT) :: error
00515 INTEGER        nDimensions
00516 INTEGER        nCompOrigin, nUDir
00517 INTEGER        nCellsI, nCellsJ
00518 INTEGER        nCells
00519 INTEGER        nCorners
00520 INTEGER        nGridType
00521 REAL(DOUBLE)   xVals(16), yVals(16) !There are 16 corners
00522 INTEGER        i
00523 INTEGER xFileId, xGridId, xPropId, xDatasetsId, xScalarId
00524 INTEGER xCoordId
00525 REAL(DOUBLE)   dNullValue(1)
00526 INTEGER        nOrientation
00527 REAL           fDsetCellVals(6) !For cell-centered dataset
00528 REAL           fDsetCornerVals(12) !For corner-centered dataset
00529 REAL(DOUBLE)   tempdouble, dCppLat, dCppLon
00530 INTEGER*1      bDsetCellActive(6)
00531 INTEGER*1      bDsetCornerActive(12)
00532 INTEGER        status
00533 INTEGER        tmpOut1, tmpOut2
00534 
00535   nDimensions = 2
00536   nCompOrigin = 1
00537   nUDir = 1;
00538   nCellsI = 2
00539   nCellsJ = 3
00540   nCells = nCellsI*nCellsJ
00541   nCorners = (nCellsI + 1)*(nCellsJ + 1)
00542   nGridType = GRID_TYPE_CURVILINEAR
00543   xFileId = NONE
00544   xGridId = NONE
00545   xPropId = NONE
00546   xDatasetsId = NONE
00547   xScalarId = NONE
00548   dNullValue(1) = -999.0
00549   nOrientation = ORIENTATION_RIGHT_HAND
00550 
00551     ! There is no cell in the top right corner so we have a NullValue for
00552     ! the top right corner
00553 
00554     ! xValues row by row
00555   xVals(1) = 0.0
00556   xVals(2) = 7.5
00557   xVals(3) = 15.0
00558   xVals(4) = 2.5
00559   xVals(5) = 10.0
00560   xVals(6) = 17.5
00561   xVals(7) = 3.5
00562   xVals(8) = 11.0
00563   xVals(9) = 18.5
00564   xVals(10) = 0.0
00565   xVals(11) = 7.5
00566   xVals(12) = dNullValue(1)
00567 
00568     ! yValues row by row
00569   yVals(1) = 0.0
00570   yVals(2) = 0.0
00571   yVals(3) = 0.0
00572   yVals(4) = 10.0
00573   yVals(5) = 10.0
00574   yVals(6) = 10.0
00575   yVals(7) = 20.0
00576   yVals(8) = 20.0
00577   yVals(9) = 20.0
00578   yVals(10) = 30.0
00579   yVals(11) = 30.0
00580   yVals(12) = dNullValue(1)
00581 
00582     ! cell centered velocity dataset values
00583   fDsetCellVals(1) = 2.1
00584   fDsetCellVals(2) = 2.0
00585   fDsetCellVals(3) = 1.9
00586   fDsetCellVals(4) = 2.3
00587   fDsetCellVals(5) = 2.5
00588   fDsetCellVals(6) = dNullValue(1)
00589 
00590     ! all are active except the last value
00591   do i = 1, nCells
00592     bDsetCellActive(i) = 1
00593   enddo
00594   bDsetCellActive(nCells) = 0
00595 
00596     ! corner centered elevation dataset values
00597   fDsetCornerVals(1) = 1.0
00598   fDsetCornerVals(2) = 0.8 
00599   fDsetCornerVals(3) = 1.2
00600   fDsetCornerVals(4) = 1.4
00601   fDsetCornerVals(5) = 1.8
00602   fDsetCornerVals(6) = 2.2
00603   fDsetCornerVals(7) = 1.8
00604   fDsetCornerVals(8) = 1.4
00605   fDsetCornerVals(9) = 2.0
00606   fDsetCornerVals(10) = 1.0
00607   fDsetCornerVals(11) = 1.8
00608   fDsetCornerVals(12) = 2.2
00609 
00610     ! all are active except the last value
00611   do i = 1, nCorners
00612     bDsetCornerActive(i) = 1
00613   enddo
00614   bDsetCornerActive(nCorners) = 0
00615 
00616     ! create the file
00617   call XF_CREATE_FILE(Filename, .TRUE., xFileId, status)
00618   if (status < 0) then
00619     error = -1
00620     return
00621   endif
00622 
00623     ! create the group to store the grid
00624   call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CURV2D_GROUP_NAME, xGridId, status)
00625   if (status < 0) then
00626     call XF_CLOSE_FILE(xFileId, error)
00627     error = -1
00628     return
00629   endif
00630 
00631     ! Write the grid information to the file
00632   call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1)
00633   call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2)
00634   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00635     call XF_CLOSE_GROUP(xGridId, error)
00636     call XF_CLOSE_FILE(xFileId, error)
00637     error = -1
00638     return
00639   endif
00640 
00641     ! set orientation
00642   call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut1)  
00643   if (tmpOut1 < 0 ) then
00644     call XF_CLOSE_GROUP(xGridId, error)
00645     call XF_CLOSE_FILE(xFileId, error)
00646     error = -1
00647     return
00648   endif
00649 
00650     ! Set computational origin
00651   call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1)  
00652   if (tmpOut1 < 0 ) then
00653     call XF_CLOSE_GROUP(xGridId, error)
00654     call XF_CLOSE_FILE(xFileId, error)
00655     error = -1
00656     return
00657   endif
00658 
00659     ! Set u direction
00660   call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1)  
00661   if (tmpOut1 < 0 ) then
00662     call XF_CLOSE_GROUP(xGridId, error)
00663     call XF_CLOSE_FILE(xFileId, error)
00664     error = -1
00665     return
00666   endif
00667 
00668     ! Write the grid geometry to the file
00669     ! Set the number of cells in each direction
00670   call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1)
00671   call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2)
00672   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00673     call XF_CLOSE_GROUP(xGridId, error)
00674     call XF_CLOSE_FILE(xFileId, error)
00675     error = -1
00676     return
00677   endif
00678     ! Set a NullValue.  This is used to identify locations in the grid that are
00679     ! not being used.  In our case no geometry is defined for the top right
00680     ! corner.
00681   call XF_CREATE_GRID_PROPERTY_GROUP(xGridId, xPropId, tmpOut1)
00682   if (xPropId < 0) then
00683     call XF_CLOSE_GROUP(xGridId, error)
00684     call XF_CLOSE_FILE(xFileId, error)
00685     error = -1
00686     return
00687   endif
00688 
00689   call XF_WRITE_PROPERTY_DOUBLE(xPropId, PROP_NULL_VALUE, 1, dNullValue, NONE, &
00690                                 tmpOut1)  
00691   if (tmpOut1 < 0) then
00692     call XF_CLOSE_GROUP(xPropId, error)
00693     call XF_CLOSE_GROUP(xGridId, error)
00694     call XF_CLOSE_FILE(xFileId, error)
00695     error = -1
00696     return
00697   endif
00698   call XF_CLOSE_GROUP(xPropId, error)
00699 
00700     ! Set the grid plane locations
00701   call XF_SET_GRID_COORDS_I(xGridId, nCorners, xVals, tmpOut1)
00702   call XF_SET_GRID_COORDS_J(xGridId, nCorners, yVals, tmpOut2)
00703   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00704     call XF_CLOSE_GROUP(xGridId, error)
00705     call XF_CLOSE_FILE(xFileId, error)
00706     error = -1
00707     return
00708   endif
00709 
00710     ! Create the datasets group
00711   call XF_CREATE_GENERIC_GROUP(xGridId, 'Datasets', xDatasetsId, tmpOut1)  
00712   if (tmpOut1 < 0) then
00713     call XF_CLOSE_GROUP(xGridId, error)
00714     call XF_CLOSE_FILE(xFileId, error)
00715     error = -1
00716     return
00717   endif
00718 
00719     ! Create the cell-centered dataset
00720   call XF_CREATE_SCALAR_DATASET(xDatasetsId, 'Velocity Mag', 'ft/s', TS_MINUTES, &
00721                                 Compression, xScalarId, tmpOut1)  
00722   if (tmpOut1 < 0) then
00723     call XF_CLOSE_GROUP(xDatasetsId, error)
00724     call XF_CLOSE_GROUP(xGridId, error)
00725     call XF_CLOSE_FILE(xFileId, error)
00726     error = -1
00727     return
00728   endif
00729 
00730     ! specify that the dataset is cell-centered
00731   call XF_SCALAR_DATA_LOCATION(xScalarId, GRID_LOC_CENTER, tmpOut1)
00732   if (tmpOut1 < 0) then
00733     call XF_CLOSE_GROUP(xScalarId, error)
00734     call XF_CLOSE_GROUP(xDatasetsId, error)
00735     call XF_CLOSE_GROUP(xGridId, error)
00736     call XF_CLOSE_FILE(xFileId, error)
00737     error = -1
00738     return
00739   endif
00740 
00741     ! Write the data
00742     ! set a temporary variable to pass into the function
00743   tempdouble = 0.0
00744   call XF_WRITE_SCALAR_TIMESTEP(xScalarId, tempdouble, nCells, fDsetCellVals, tmpOut1)
00745   call XF_WRITE_ACTIVITY_TIMESTEP(xScalarId, nCells, bDsetCellActive, tmpOut2)
00746   if ((tmpOut1 < 0) .OR. (tmpOut1 < 0)) then
00747     call XF_CLOSE_GROUP(xScalarId, error)
00748     call XF_CLOSE_GROUP(xDatasetsId, error)
00749     call XF_CLOSE_GROUP(xGridId, error)
00750     call XF_CLOSE_FILE(xFileId, error)
00751     error = -1
00752     return
00753   endif
00754 
00755     ! close the cell-centered dataset
00756   call XF_CLOSE_GROUP(xScalarId, error)
00757 
00758     ! Create the corner-centered dataset
00759   call XF_CREATE_SCALAR_DATASET(xDatasetsId, 'elevation', 'ft', TS_MINUTES, &
00760                                 Compression, xScalarId, tmpOut1)  
00761   if (tmpOut1 < 0) then
00762     call XF_CLOSE_GROUP(xDatasetsId, error)
00763     call XF_CLOSE_GROUP(xGridId, error)
00764     call XF_CLOSE_FILE(xFileId, error)
00765     error = -1
00766     return
00767   endif
00768 
00769     ! specify that the dataset is corner-centered
00770   call XF_SCALAR_DATA_LOCATION(xScalarId, GRID_LOC_CORNER, tmpOut1)  
00771   if (tmpOut1 < 0) then
00772     call XF_CLOSE_GROUP(xScalarId, error)
00773     call XF_CLOSE_GROUP(xDatasetsId, error)
00774     call XF_CLOSE_GROUP(xGridId, error)
00775     call XF_CLOSE_FILE(xFileId, error)
00776     error = -1
00777     return
00778   endif
00779 
00780     ! Write the data
00781     ! set a temporary variable to pass into the function
00782   tempdouble = 0.0
00783   call XF_WRITE_SCALAR_TIMESTEP(xScalarId, tempdouble, nCorners, fDsetCornerVals, tmpOut1)
00784   call XF_WRITE_ACTIVITY_TIMESTEP(xScalarId, nCorners, bDsetCornerActive, tmpOut2)
00785   if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00786     call XF_CLOSE_GROUP(xScalarId, error)
00787     call XF_CLOSE_GROUP(xDatasetsId, error)
00788     call XF_CLOSE_GROUP(xGridId, error)
00789     call XF_CLOSE_FILE(xFileId, error)
00790     error = -1
00791     return
00792   endif
00793 
00794   ! Write Coordinate file - for GridCurv2D, we will set the coordinate system
00795   !   to be CPP, with CPP Latitude and CPP Longitude settings written 
00796   !   to the file.
00797   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00798   if (status < 0) then
00799     call XF_CLOSE_GROUP(xScalarId, error)
00800     call XF_CLOSE_GROUP(xDatasetsId, error)
00801     call XF_CLOSE_GROUP(xGridId, error)
00802     call XF_CLOSE_FILE(xFileId, error)
00803     error = status
00804     return
00805   endif
00806 
00807   dCppLat = 56.0;  ! Made-up value
00808   dCppLon = 23.0;  ! Made-up value
00809 
00810   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_CPP, error)
00811   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00812 
00813   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00814   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00815 
00816     ! write additional information
00817   call XF_SET_CPP_LAT(xCoordId, dCppLat, error)
00818   call XF_SET_CPP_LON(xCoordId, dCppLon, error)
00819 
00820   call XF_CLOSE_GROUP(xCoordId, error)
00821   xCoordId = 0
00822 
00823   ! release memory
00824 call XF_CLOSE_GROUP(xScalarId, error)
00825 call XF_CLOSE_GROUP(xDatasetsId, error)
00826 call XF_CLOSE_GROUP(xGridId, error)
00827 call XF_CLOSE_FILE(xFileId, error)
00828 return
00829 
00830 END SUBROUTINE TG_WRITE_TEST_GRID_CURV_2D
00831 
00832 !****************************
00833 !------------------------------------------------------------------------------
00834 ! FUNCTION   tgWriteTestGridCart3D
00835 ! PURPOSE    Write a file that contains data for a 2D Cartesian Grid
00836 ! NOTES      A picture of the grid is in the file (TestGridCart2D.gif)
00837 !            returns TRUE on success and FALSE on failure
00838 !------------------------------------------------------------------------------
00839 SUBROUTINE TG_WRITE_TEST_GRID_CART_3D(Filename, Compression, error)
00840 CHARACTER(LEN=*), INTENT(IN) :: Filename
00841 INTEGER, INTENT(IN) :: Compression
00842 INTEGER, INTENT(OUT) :: error
00843 INTEGER        nDimensions
00844 INTEGER        nCompOrigin, nUDir
00845 INTEGER        nCellsI, nCellsJ, nCellsK
00846 INTEGER        nGridType
00847 REAL(DOUBLE)   dOriginX, dOriginY, dOriginZ
00848 INTEGER        nOrientation
00849 REAL(DOUBLE)   dBearing, dDip, dRoll
00850 REAL(DOUBLE)   PlanesI(5), PlanesJ(5), PlanesK(3)
00851 INTEGER        i, j, status, iSpcZone
00852 INTEGER xFileId, xGridId, xPropId, xCoordId
00853 INTEGER        nCells
00854 INTEGER        Active(75)
00855 INTEGER        tmpOut1, tmpOut2, tmpOut3
00856 
00857 nDimensions = 3
00858 nCompOrigin = 8
00859 nUDir = -2
00860 nCellsI = 5
00861 nCellsJ = 5
00862 nCellsK = 3
00863 nGridType = GRID_TYPE_CARTESIAN
00864 dOriginX = 10.0
00865 dOriginY = 10.0
00866 dOriginZ = 0.0
00867 nOrientation = ORIENTATION_RIGHT_HAND
00868 dBearing = 45.0
00869 dDip = 0.0
00870 dRoll = 0.0
00871 xFileId = NONE
00872 xGridId = NONE
00873 xPropId = NONE
00874 nCells = nCellsI * nCellsJ * nCellsK
00875 
00876   ! Fill in the grid plane data with a constant size of 30
00877 do i = 1, nCellsI
00878   PlanesI(i) = i*30.0
00879 enddo
00880 do j = 1, nCellsJ
00881   PlanesJ(j) = j*30.0
00882 enddo
00883 do j = 1,  nCellsK
00884   PlanesK(j) = j*30.0
00885 enddo
00886 
00887   ! fill in the activity array
00888   ! default array to active
00889 do i = 1, nCells
00890   Active(i) = 1
00891 enddo
00892 
00893   ! two cells are inactive (identified by array index)
00894   ! i = 0, j = 0, k = 0  and i = 4, j = 4, k = 0
00895 Active(1) = 0
00896 Active(4*nCellsJ*nCellsK+4*nCellsK+1) = 0
00897 
00898   ! create the file
00899 call XF_CREATE_FILE(Filename, .TRUE., xFileId, tmpOut1)  
00900 if (tmpOut1 < 0) then
00901   error = -1
00902   return
00903 endif
00904 
00905   ! create the group to store the grid
00906 call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CART3D_GROUP_NAME, xGridId, tmpOut1)
00907 if (tmpOut1 < 0) then
00908   call XF_CLOSE_FILE(xFileId, error)
00909   error = -1
00910   return
00911 endif
00912 
00913   ! Write the grid information to the file
00914 call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1)
00915 call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2)
00916 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00917   call XF_CLOSE_GROUP(xGridId, error)
00918   call XF_CLOSE_FILE(xFileId, error)
00919   error = -1
00920   return
00921 endif
00922 
00923   ! set origin and orientation
00924 call XF_SET_ORIGIN(xGridId, dOriginX, dOriginY, dOriginZ, tmpOut1)
00925 call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut2)
00926 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then
00927   call XF_CLOSE_GROUP(xGridId, error)
00928   call XF_CLOSE_FILE(xFileId, error)
00929   error = -1
00930   return
00931 endif
00932  
00933   ! Set bearing, dip and roll
00934 call XF_SET_BEARING(xGridId, dBearing, tmpOut1)
00935 call XF_SET_DIP(xGridId, dDip, tmpOut2)
00936 call XF_SET_ROLL(xGridId, dRoll, tmpOut3)
00937 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then
00938   call XF_CLOSE_GROUP(xGridId, error)
00939   call XF_CLOSE_FILE(xFileId, error)
00940   error = -1
00941   return
00942 endif
00943 
00944  ! Set computational origin
00945 call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1)
00946 if (tmpOut1 < 0) then
00947   call XF_CLOSE_GROUP(xGridId, error)
00948   call XF_CLOSE_FILE(xFileId, error)
00949   error = -1
00950   return
00951 endif
00952 
00953   ! Set u direction
00954 call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1)
00955 if (tmpOut1 < 0) then
00956   call XF_CLOSE_GROUP(xGridId, error)
00957   call XF_CLOSE_FILE(xFileId, error)
00958   error = -1
00959   return
00960 endif
00961 
00962   ! Write the grid geometry to the file
00963   ! Set the number of cells in each direction
00964 call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1)
00965 call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2)
00966 call XF_SET_NUMBER_CELLS_IN_K(xGridId, nCellsK, tmpOut3)  
00967 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then
00968   call XF_CLOSE_GROUP(xGridId, error)
00969   call XF_CLOSE_FILE(xFileId, error)
00970   error = -1
00971   return
00972 endif
00973 
00974   ! Set the grid plane locations
00975 call XF_SET_GRID_COORDS_I(xGridId, nCellsI, PlanesI, tmpOut1)
00976 call XF_SET_GRID_COORDS_J(xGridId, nCellsJ, PlanesJ, tmpOut2)
00977 call XF_SET_GRID_COORDS_K(xGridId, nCellsK, PlanesK, tmpOut3)  
00978 
00979 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then
00980   call XF_CLOSE_GROUP(xGridId, error)
00981   call XF_CLOSE_FILE(xFileId, error)
00982   error = -1
00983   return
00984 endif
00985 
00986   ! Write the activity array
00987 call XF_CREATE_GRID_CELL_PROP_GRP(xGridId, xPropId, tmpOut1)  
00988 if (xPropId < 0) then
00989   call XF_CLOSE_GROUP(xGridId, error)
00990   call XF_CLOSE_FILE(xFileId, error)
00991   error = -1
00992   return
00993 endif
00994 
00995 call XF_WRITE_PROPERTY_INT(xPropId, PROP_ACTIVITY, nCells, Active, &
00996                            Compression, tmpOut1)
00997 
00998 if (tmpOut1 < 0) then
00999   call XF_CLOSE_GROUP(xPropId, error)
01000   call XF_CLOSE_GROUP(xGridId, error)
01001   call XF_CLOSE_FILE(xFileId, error)
01002   error = -1
01003   return
01004 endif
01005   
01006 call XF_CLOSE_GROUP(xPropId, error)
01007 
01008   ! Write Coordinate file - for GridCart3D, we will set the coordinate system
01009   !   to be State Plane NAD27.
01010   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01011   if (status < 0) then
01012     call XF_CLOSE_GROUP(xGridId, error)
01013     call XF_CLOSE_FILE(xFileId, error)
01014     error = status
01015   endif
01016 
01017   iSpcZone = 3601; ! Oregon North
01018 
01019   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_STATE_PLANE_NAD27, error)
01020   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
01021 
01022   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01023   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
01024 
01025     ! write additional information
01026   call XF_SET_SPC_ZONE(xCoordId, iSpcZone, error)
01027 
01028   call XF_CLOSE_GROUP(xCoordId, error)
01029   xCoordId = 0
01030 
01031   ! release memory
01032 call XF_CLOSE_GROUP(xGridId, error)
01033 call XF_CLOSE_FILE(xFileId, error)
01034 return
01035 
01036 END SUBROUTINE TG_WRITE_TEST_GRID_CART_3D
01037 
01038 END MODULE TestGrid
TestGrid.f90 tests grids
00001 MODULE TestMesh
00002 
00003 USE TestDatasets
00004 USE Xmdf
00005 USE ErrorDefinitions
00006 USE XmdfDefs
00007 
00008 CHARACTER(LEN=*), PARAMETER :: MESH_A_GROUP_NAME = 'MeshA Group'
00009 CHARACTER(LEN=*), PARAMETER :: MESH_B_GROUP_NAME = 'MeshB Group'
00010 
00011 
00012 CONTAINS
00013 
00014 !****************************
00015 ! ---------------------------------------------------------------------------
00016 ! FUNCTION  TM_READ_MESH
00017 ! PURPOSE   Read a mesh file and write a text output file
00018 ! NOTES     
00019 ! ---------------------------------------------------------------------------
00020 SUBROUTINE TM_READ_MESH (xGroupId, a_OutFile, error)
00021 INTEGER, INTENT(IN) :: xGroupId
00022 INTEGER, INTENT(IN)        :: a_OutFile
00023 INTEGER, INTENT(OUT)       :: error
00024 INTEGER           nElems, nNodes, nNodesPerElem, nElemType, nNodeId
00025 LOGICAL*2           ElementsOneType
00026 INTEGER           status, i, j
00027 INTEGER           StrType, UIntType, IntType, DblType, FloatType
00028 INTEGER    xPropGroupId
00029 INTEGER, ALLOCATABLE      :: ElemTypes(:), NodesInElem(:)
00030 REAL(DOUBLE), ALLOCATABLE :: XNodeLocs(:), YNodeLocs(:), ZNodeLocs(:)
00031 
00032     ! Get the number of elements, nodes, and Maximum number of nodes per element
00033   call XF_GET_NUMBER_OF_ELEMENTS (xGroupId, nElems, status)
00034   if (status >= 0) then
00035     call XF_GET_NUMBER_OF_NODES (xGroupId, nNodes, status)
00036     if (status >= 0) then
00037       call XF_GET_MAX_NODES_IN_ELEM (xGroupId, nNodesPerElem, status)
00038     endif
00039   endif
00040 
00041   if (status < 0) then
00042     error = -1
00043     return
00044   endif
00045 
00046     ! Do Element information first
00047   WRITE(a_OutFile,*) 'Number of Elements: ', nElems
00048 
00049     ! Element types
00050   call XF_ARE_ALL_ELEMS_SAME_TYPE (xGroupId, ElementsOneType, status)
00051   if (status < 0) then
00052     error = -1
00053     return
00054   endif
00055 
00056   if (ElementsOneType) then
00057     call XF_READ_ELEM_TYPES_SINGLE_VALUE (xGroupId, nElemType, status)
00058     WRITE(a_OutFile,*) 'All elements are type ', nElemType
00059   else
00060     allocate (ElemTypes(nElems))
00061     call XF_READ_ELEM_TYPES (xGroupId, nElems, ElemTypes, status)
00062     if (status < 0) then
00063       error = -1
00064     return
00065     endif
00066     WRITE(a_OutFile,*) 'Element Types:'
00067     do i=1, nElems
00068       WRITE(a_OutFile,*) 'Elem ', i, ', ', 'Type ', ElemTypes(i)
00069     enddo
00070     deallocate (ElemTypes)
00071   endif
00072 
00073     ! Nodes in each element
00074   allocate (NodesInElem(nElems*nNodesPerElem))
00075   call XF_READ_ELEM_NODE_IDS (xGroupId, nElems, nNodesPerElem, NodesInElem, error)
00076   if (error < 0) then
00077     WRITE (*,*) 'Error reading mesh'
00078     return
00079   endif
00080 
00081   do i=1, nElems
00082     WRITE(a_OutFile,*) 'Elem: ', i, ' - '
00083     do j=1, nNodesPerElem
00084       nNodeId = NodesInElem((i-1)*nNodesPerElem + j)
00085     if (nNodeId > 0) then  ! -1 is for unused array locations
00086         WRITE(a_OutFile,*) nNodeId, ' '
00087       endif
00088     enddo
00089     WRITE (a_OutFile,*) ''
00090   enddo
00091 
00092   if (allocated(NodesInElem)) deallocate (NodesInElem)
00093 
00094     ! NodeLocations
00095   allocate (XNodeLocs(nNodes))
00096   allocate (YNodeLocs(nNodes))
00097   allocate (ZNodeLocs(nNodes))
00098 
00099   call XF_READ_X_NODE_LOCATIONS (xGroupId, nNodes, XNodeLocs, status)
00100   if (status >= 0) then
00101     call XF_READ_Y_NODE_LOCATIONS (xGroupId, nNodes, YNodeLocs, status)
00102     if (status >= 0) then
00103       call XF_READ_Z_NODE_LOCATIONS (xGroupId, nNodes, ZNodeLocs, status)
00104     endif
00105   endif
00106 
00107   WRITE(a_OutFile,*) 'Node Locations:'
00108   do i=1, nNodes
00109     WRITE(a_OutFile,*) 'Node: ', i, ' Location: ', XNodeLocs(i), ' ', &
00110                         YNodeLocs(i), ' ', ZNodeLocs(i)
00111   enddo
00112 
00113     deallocate (XNodeLocs)
00114     deallocate (YNodeLocs)
00115     deallocate (ZNodeLocs)
00116 
00117     ! Open Properties Group
00118   call XF_OPEN_GROUP(xGroupId, 'PROPERTIES', xPropGroupId, status)
00119   if (status < 0) then
00120     WRITE(a_OutFile,*) ''
00121     WRITE(a_OutFile,*) 'Properties Group not found'
00122     WRITE(a_OutFile,*) ''
00123     error = -1
00124     return
00125   endif
00126 
00127   call XF_GET_PROPERTY_TYPE(xPropGroupId, 'String', StrType, status)
00128   call XF_GET_PROPERTY_TYPE(xPropGroupId, 'UInt', UIntType, status)
00129   call XF_GET_PROPERTY_TYPE(xPropGroupId, 'Int', IntType, status)
00130   call XF_GET_PROPERTY_TYPE(xPropGroupId, 'Double', DblType, status)
00131   call XF_GET_PROPERTY_TYPE(xPropGroupId, 'Float', FloatType, status)
00132 
00133     ! Property Types:
00134   WRITE(a_OutFile,*) ''
00135   if (StrType == XF_TYPE_STRING) then
00136     WRITE(a_OutFile,*) 'String Property Type Read Correctly'
00137   else
00138     WRITE(a_OutFile,*) 'Error in Getting String Property Type'
00139   endif
00140   if (UIntType == XF_TYPE_UINT) then
00141     WRITE(a_OutFile,*) 'Unsigned Integer Property Type Read Correctly'
00142   else
00143     WRITE(a_OutFile,*) 'Error in Getting Unsigned Integer Property Type'
00144   endif
00145   if (IntType == XF_TYPE_INT) then
00146     WRITE(a_OutFile,*) 'Integer Property Type Read Correctly'
00147   else
00148     WRITE(a_OutFile,*) 'Error in Getting Integer Property Type'
00149   endif
00150   if (DblType == XF_TYPE_DOUBLE) then
00151     WRITE(a_OutFile,*) 'Double Property Type Read Correctly'
00152   else
00153     WRITE(a_OutFile,*) 'Error in Getting Double Property Type'
00154   endif
00155   if (FloatType == XF_TYPE_FLOAT) then
00156     WRITE(a_OutFile,*) 'Float Property Type Read Correctly'
00157   else
00158     WRITE(a_OutFile,*) 'Error in Getting Float Property Type'
00159   endif
00160   WRITE(a_OutFile,*) ''
00161 
00162   error = 0
00163   return
00164 
00165 END SUBROUTINE
00166 
00167 !****************************
00168 !------------------------------------------------------------------------------
00169 ! FUNCTION   TM_WRITE_TEST_MESH_A
00170 ! PURPOSE    Write a file that contains data for an all tri mesh
00171 ! NOTES      A picture of the mesh is in the file (TestMeshA.gif)
00172 !            error equals TRUE on success and FALSE on failure
00173 !------------------------------------------------------------------------------
00174 SUBROUTINE TM_WRITE_TEST_MESH_A (Filename, Compression, error)
00175 CHARACTER(LEN=*), INTENT(IN) :: Filename
00176 INTEGER, INTENT(IN)          :: Compression
00177 INTEGER, INTENT(OUT)         :: error
00178 INTEGER           nElements, nNodes
00179 INTEGER    xFileId, xMeshId, xPropGroupId, xCoordId
00180 REAL(DOUBLE), DIMENSION(5) :: dNodeLocsX
00181 REAL(DOUBLE), DIMENSION(5) :: dNodeLocsY
00182 REAL(DOUBLE), DIMENSION(5) :: dNodeLocsZ
00183 INTEGER, DIMENSION(3,3)    :: iElementNodes
00184 INTEGER           status, ElemType, propint(1), iEllipse
00185 CHARACTER(LEN=BIG_STRING_SIZE)  propstring
00186 INTEGER           propuint(1)
00187 REAL(DOUBLE)      propdouble(1), dMajorR, dMinorR
00188 REAL              propfloat
00189 
00190     ! set Element type to EL_TYPE_TRI_LINEAR
00191   ElemType = EL_TYPE_TRI_LINEAR
00192 
00193   nElements = 3
00194   nNodes = 5
00195   xFileId = NONE
00196   xMeshId = NONE
00197 
00198     ! Setup the arrays for the mesh data
00199     ! nodes
00200   dNodeLocsX(1) = 0.0
00201   dNodeLocsX(2) = 5.0
00202   dNodeLocsX(3) = 0.0
00203   dNodeLocsX(4) = 5.0
00204   dNodeLocsX(5) = 7.5
00205 
00206   dNodeLocsY(1) = 5.0
00207   dNodeLocsY(2) = 5.0
00208   dNodeLocsY(3) = 0.0
00209   dNodeLocsY(4) = 0.0
00210   dNodeLocsY(5) = 2.5
00211 
00212   dNodeLocsZ(1) = 0.0
00213   dNodeLocsZ(2) = 0.0
00214   dNodeLocsZ(3) = 0.0
00215   dNodeLocsZ(4) = 0.0
00216   dNodeLocsZ(5) = 0.0
00217 
00218     ! nodes for each element must be counter-clockwize
00219   iElementNodes(1,1) = 1
00220   iElementNodes(2,1) = 3
00221   iElementNodes(3,1) = 2
00222 
00223   iElementNodes(1,2) = 2
00224   iElementNodes(2,2) = 3
00225   iElementNodes(3,2) = 4
00226 
00227   iElementNodes(1,3) = 5
00228   iElementNodes(2,3) = 2
00229   iElementNodes(3,3) = 4
00230 
00231     ! create the file
00232   call XF_CREATE_FILE (Filename, .TRUE., xFileId, status)
00233   if (status < 0) then
00234       ! close the resources
00235     call XF_CLOSE_FILE (xFileId, error)
00236     error = -1
00237     return
00238   endif
00239 
00240     ! create the group to store the mesh
00241   call XF_CREATE_GROUP_FOR_MESH (xFileId, MESH_A_GROUP_NAME, xMeshId, status)
00242   if (status < 0) then
00243       ! close the resources
00244     call XF_CLOSE_GROUP (xMeshId, error)
00245     call XF_CLOSE_FILE (xFileId, error)
00246     error = -1
00247     return
00248   endif
00249 
00250     ! Element types - all are linear triangles
00251   call XF_SET_ALL_ELEMS_SAME_TYPE (xMeshId, ElemType, status)
00252   if (status < 0) then
00253       ! close the resources
00254     call XF_CLOSE_GROUP (xMeshId, error)
00255     call XF_CLOSE_FILE (xFileId, error)
00256     error = -1
00257     return
00258   endif
00259 
00260     ! node information
00261   call XF_SET_NUMBER_OF_NODES (xMeshId, nNodes, status)
00262   if (status < 0) then
00263       ! close the resources
00264     call XF_CLOSE_GROUP (xMeshId, error)
00265     call XF_CLOSE_FILE (xFileId, error)
00266     error = -1
00267     return
00268   endif
00269 
00270   call XF_WRITE_X_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsX, Compression, status)
00271   if (status < 0) then
00272       ! close the resources
00273     call XF_CLOSE_GROUP (xMeshId, error)
00274     call XF_CLOSE_FILE (xFileId, error)
00275     error = -1
00276     return
00277   endif
00278 
00279   call  XF_WRITE_Y_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsY, status)
00280   if (status < 0) then
00281       ! close the resources
00282     call XF_CLOSE_GROUP (xMeshId, error)
00283     call XF_CLOSE_FILE (xFileId, error)
00284     error = -1
00285     return
00286   endif
00287 
00288   call XF_WRITE_Z_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsZ, status)
00289   if (status < 0) then
00290       ! close the resources
00291     call XF_CLOSE_GROUP (xMeshId, error)
00292     call XF_CLOSE_FILE (xFileId, error)
00293     error = -1
00294     return
00295   endif
00296 
00297     ! element information
00298   call XF_SET_NUMBER_OF_ELEMENTS (xMeshId, nElements, status)
00299   if (status < 0) then
00300       ! close the resources
00301     call XF_CLOSE_GROUP (xMeshId, error)
00302     call XF_CLOSE_FILE (xFileId, error)
00303     error = -1
00304     return
00305   endif
00306  
00307     ! Write the node array ids for the nodes in each element
00308   call XF_WRITE_ELEM_NODE_IDS (xMeshId, nElements, 3, iElementNodes, &
00309                                Compression, status)
00310   if (status < 0) then
00311       ! close the resources
00312     call XF_CLOSE_GROUP (xMeshId, error)
00313     call XF_CLOSE_FILE (xFileId, error)
00314     error = -1
00315     return
00316   endif
00317 
00318     ! Write the Property File
00319   call XF_CREATE_MESH_PROPERTY_GROUP(xMeshId, xPropGroupId, status)
00320   if (status < 0) then
00321     call XF_CLOSE_GROUP(xMeshId, error)
00322     call XF_CLOSE_FILE(xFileId, error)
00323     error = -1
00324     return
00325   endif
00326 
00327   propstring = 'Property String'
00328   propuint = 5
00329   propint = -5
00330   propdouble = 5.6789012345d0
00331   propfloat = 5.6789
00332 
00333   call XF_WRITE_PROPERTY_STRING(xPropGroupId, 'String', propstring, status)
00334   call XF_WRITE_PROPERTY_UINT(xPropGroupId, 'UInt', 1, propuint, NONE, status)
00335   call XF_WRITE_PROPERTY_INT(xPropGroupId, 'Int', 1, propint, NONE, status)
00336   call XF_WRITE_PROPERTY_DOUBLE(xPropGroupId, 'Double', 1, &
00337                                 propdouble, NONE, status)
00338   call XF_WRITE_PROPERTY_FLOAT(xPropGroupId, 'Float', 1, &
00339                                 propfloat, NONE, status)
00340 
00341   ! Write Coordinate file - for MeshA, we will set the coordinate system to be
00342   !   Geogrpahic, with Latitude, Longitude, and user-defined ellipsoid settings
00343   !   written to the file.
00344   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00345   if (status < 0) then
00346     call XF_CLOSE_GROUP (xPropGroupId, error)
00347     call XF_CLOSE_GROUP (xMeshId, error)
00348     call XF_CLOSE_FILE (xFileId, error)
00349     error = status
00350     return
00351   endif
00352 
00353     ! set coordinate values
00354   iEllipse = 32    ! User defined
00355   dMajorR = 45.0   ! Made up
00356   dMinorR = 32.0   ! Made up
00357 
00358   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC, error)
00359   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
00360 
00361   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00362   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_US_FEET, error)
00363 
00364     ! write additional information
00365   call XF_SET_ELLIPSE(xCoordId, iEllipse, error)
00366   call XF_SET_LAT(xCoordId, LATITUDE_NORTH, error)
00367   call XF_SET_LON(xCoordId, LONGITUDE_EAST, error)
00368   call XF_SET_MAJOR_R(xCoordId, dMajorR, error)
00369   call XF_SET_MINOR_R(xCoordId, dMinorR, error)
00370 
00371   call XF_CLOSE_GROUP(xCoordId, error)
00372   xCoordId = 0
00373 
00374     ! close the resources
00375   call XF_CLOSE_GROUP (xPropGroupId, error)
00376   call XF_CLOSE_GROUP (xMeshId, error)
00377   call XF_CLOSE_FILE (xFileId, error)
00378 
00379   return
00380 
00381 END SUBROUTINE
00382 
00383 !****************************
00384 !------------------------------------------------------------------------------
00385 ! FUNCTION   TM_WRITE_TEST_MESH_B
00386 ! PURPOSE    Write a file that contains data for an mixed quad/tri linear mesh
00387 ! NOTES      A picture of the mesh is in the file (TestMeshB.gif)
00388 !            error equals TRUE on success and FALSE on failure
00389 !------------------------------------------------------------------------------
00390 SUBROUTINE TM_WRITE_TEST_MESH_B (Filename, Compression, error)
00391 CHARACTER(LEN=*), INTENT(IN) :: Filename
00392 INTEGER, INTENT(IN)          :: Compression
00393 INTEGER, INTENT(OUT)         :: error
00394 INTEGER           nElements, nNodes, nMaxNodePerElem
00395 INTEGER    xFileId, xMeshId, xPropGroupId, xCoordId
00396 REAL(DOUBLE), DIMENSION(5)   :: dNodeLocsX
00397 REAL(DOUBLE), DIMENSION(5)   :: dNodeLocsY
00398 REAL(DOUBLE), DIMENSION(5)   :: dNodeLocsZ
00399 INTEGER, DIMENSION(4,2)      :: iElementNodes
00400 INTEGER, DIMENSION(2)        :: iElementTypes
00401 INTEGER           status, propint(1), iEllipse
00402 CHARACTER(LEN=BIG_STRING_SIZE)  propstring
00403 INTEGER           propuint(1)
00404 REAL(DOUBLE)      propdouble(1)
00405 REAL              propfloat
00406 
00407   nElements = 2
00408   nNodes = 5
00409   nMaxNodePerElem = 4
00410   xFileId = NONE
00411   xMeshId = NONE
00412 
00413     ! Setup the arrays for the mesh data
00414     ! nodes
00415   dNodeLocsX(1) = 0.0
00416   dNodeLocsX(2) = 5.0
00417   dNodeLocsX(3) = 0.0
00418   dNodeLocsX(4) = 5.0
00419   dNodeLocsX(5) = 7.5
00420 
00421   dNodeLocsY(1) = 5.0
00422   dNodeLocsY(2) = 5.0
00423   dNodeLocsY(3) = 0.0
00424   dNodeLocsY(4) = 0.0
00425   dNodeLocsY(5) = 2.5
00426 
00427   dNodeLocsZ(1) = 0.0
00428   dNodeLocsZ(2) = 0.0
00429   dNodeLocsZ(3) = 0.0
00430   dNodeLocsZ(4) = 0.0
00431   dNodeLocsZ(5) = 0.0
00432   
00433     ! nodes for each element must be counter-clockwize
00434   iElementNodes(1,1) = 1
00435   iElementNodes(2,1) = 3
00436   iElementNodes(3,1) = 4
00437   iElementNodes(4,1) = 2
00438 
00439   iElementNodes(1,2) = 2
00440   iElementNodes(2,2) = 4
00441   iElementNodes(3,2) = 5
00442   iElementNodes(4,2) = NONE;
00443 
00444   iElementTypes(1) = EL_TYPE_QUADRILATERAL_LINEAR;
00445   iElementTypes(2) = EL_TYPE_TRI_LINEAR;
00446 
00447     ! create the file
00448   call XF_CREATE_FILE (Filename, .TRUE., xFileId, status)
00449   if (status < 0) then
00450       ! close the resources
00451     call XF_CLOSE_FILE  (xFileId, error)
00452     error = -1
00453     return
00454   endif
00455 
00456     ! create the group to store the mesh
00457   call XF_CREATE_GROUP_FOR_MESH (xFileId, MESH_B_GROUP_NAME, xMeshId, status)
00458   if (status < 0) then
00459       ! close the resources
00460     call XF_CLOSE_GROUP (xMeshId, error)
00461     call XF_CLOSE_FILE  (xFileId, error)
00462     error = -1
00463     return
00464   endif
00465 
00466     ! node information
00467   call XF_SET_NUMBER_OF_NODES (xMeshId, nNodes, status)
00468   if (status < 0) then
00469       ! close the resources
00470     call XF_CLOSE_GROUP (xMeshId, error)
00471     call XF_CLOSE_FILE  (xFileId, error)
00472     error = -1
00473     return
00474   endif
00475   
00476   call XF_WRITE_X_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsX, &
00477                                   Compression, status)
00478   if (status < 0) then
00479       ! close the resources
00480     call XF_CLOSE_GROUP (xMeshId, error)
00481     call XF_CLOSE_FILE  (xFileId, error)
00482     error = -1
00483     return
00484   endif
00485 
00486   call XF_WRITE_Y_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsY, status)
00487   if (status < 0) then
00488       ! close the resources
00489     call XF_CLOSE_GROUP (xMeshId, error)
00490     call XF_CLOSE_FILE  (xFileId, error)
00491     error = -1
00492     return
00493   endif
00494 
00495   call XF_WRITE_Z_NODE_LOCATIONS (xMeshId, nNodes, dNodeLocsZ, status)
00496   if (status < 0) then
00497       ! close the resources
00498     call XF_CLOSE_GROUP (xMeshId, error)
00499     call XF_CLOSE_FILE  (xFileId, error)
00500     error = -1
00501     return
00502   endif
00503  
00504     ! element information
00505   call XF_SET_NUMBER_OF_ELEMENTS (xMeshId, nElements, status)
00506   if (status < 0) then
00507       ! close the resources
00508     call XF_CLOSE_GROUP (xMeshId, error)
00509     call XF_CLOSE_FILE  (xFileId, error)
00510     error = -1
00511     return
00512   endif
00513 
00514     ! Element types
00515   call XF_WRITE_ELEM_TYPES (xMeshId, nElements, iElementTypes, &
00516                             Compression, status)
00517   if (status < 0) then
00518       ! close the resources
00519     call XF_CLOSE_GROUP (xMeshId, error)
00520     call XF_CLOSE_FILE  (xFileId, error)
00521     error = -1
00522     return
00523   endif
00524  
00525     ! Write the node array ids for the nodes in each element
00526   call XF_WRITE_ELEM_NODE_IDS (xMeshId, nElements, nMaxNodePerElem, &
00527                                iElementNodes, Compression, status)
00528   if (status < 0) then
00529       ! close the resources
00530     call XF_CLOSE_GROUP (xMeshId, error)
00531     call XF_CLOSE_FILE  (xFileId, error)
00532     error = -1
00533     return
00534   endif
00535 
00536     ! Write the Property File
00537   call XF_CREATE_MESH_PROPERTY_GROUP(xMeshId, xPropGroupId, status)
00538   if (status < 0) then
00539     call XF_CLOSE_GROUP(xMeshId, error)
00540     call XF_CLOSE_GROUP(xFileId, error)
00541     error = -1
00542     return
00543   endif
00544 
00545   propstring = 'String Property'
00546   propuint = 2
00547   propint = -2
00548   propdouble = 2.3456789012d0
00549   propfloat = 2.3456
00550 
00551   call XF_WRITE_PROPERTY_STRING(xPropGroupId, 'String', propstring, status)
00552   call XF_WRITE_PROPERTY_UINT(xPropGroupId, 'UInt', 1, propuint, NONE, status)
00553   call XF_WRITE_PROPERTY_INT(xPropGroupId, 'Int', 1, propint, NONE, status)
00554   call XF_WRITE_PROPERTY_DOUBLE(xPropGroupId, 'Double', 1, &
00555                                 propdouble, NONE, status)
00556   call XF_WRITE_PROPERTY_FLOAT(xPropGroupId, 'Float', 1, &
00557                                propfloat, NONE, status)
00558 
00559   ! Write Coordinate file - for MeshB, we will set the coordinate system to be
00560   !   Geogrpahic, with Latitude, Longitude, and standard ellipsoid settings
00561   !   written to the file.
00562   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00563   if (status < 0) then
00564     call XF_CLOSE_GROUP (xPropGroupId, error)
00565     call XF_CLOSE_GROUP (xMeshId, error)
00566     call XF_CLOSE_FILE  (xFileId, error)
00567     error = status
00568     return
00569   endif
00570 
00571     ! set coordinate values
00572   iEllipse = 21   ! International 1924
00573 
00574   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC, error)
00575   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00576 
00577   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_NGVD_88, error)
00578   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00579 
00580     ! write additional information
00581   call XF_SET_ELLIPSE(xCoordId, iEllipse, error)
00582   call XF_SET_LAT(xCoordId, LATITUDE_SOUTH, error)
00583   call XF_SET_LON(xCoordId, LONGITUDE_WEST, error)
00584 
00585   call XF_CLOSE_GROUP(xCoordId, error)
00586   xCoordId = 0
00587 
00588     ! close the resources
00589   call XF_CLOSE_GROUP (xPropGroupId, error)
00590   call XF_CLOSE_GROUP (xMeshId, error)
00591   call XF_CLOSE_FILE  (xFileId, error)
00592 
00593   return
00594 
00595 END SUBROUTINE
00596 
00597 END MODULE TestMesh
TestMesh.f90 tests meshes
00001 MODULE TestTimestep
00002 
00003 USE Xmdf
00004 
00005 CHARACTER(LEN=*), PARAMETER :: DATASETS_LOCATION = 'Datasets'
00006 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_LOCATION = 'Scalars/ScalarA'
00007 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_LOCATION = 'Scalars/ScalarB'
00008 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_LOCATION = 'Vectors/Vector2D_A'
00009 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_LOCATION = 'Vectors/Vector2D_B'
00010 
00011 CONTAINS
00012 
00013 ! --------------------------------------------------------------------------
00014 ! FUNCTION ttiTestNumTimes
00015 ! PURPOSE  Change the NumTimes to truncate timesteps
00016 ! NOTES    
00017 ! --------------------------------------------------------------------------
00018 RECURSIVE SUBROUTINE TTI_Test_Num_Times (a_DatasetId, a_Itimestep, error)
00019 INTEGER, INTENT(IN) :: a_DatasetId
00020 INTEGER, INTENT(IN)        :: a_Itimestep
00021 INTEGER, INTENT(OUT)       :: error
00022 INTEGER                    NumTimes
00023 INTEGER                    Itimestep
00024 
00025 error = 1
00026 
00027 ! Fortran loops are 1 to 3 but C is 0 to 2, etc
00028 Itimestep = a_Itimestep - 1
00029 
00030   ! truncate just written timestep and test error conditions
00031 if (1 == Itimestep .OR. 3 == Itimestep .OR. 5 == Itimestep) then
00032       ! Test setting NumTimes after end of dataset
00033       call XF_SET_DATASET_NUM_TIMES( a_DatasetId, Itimestep + 2, error )
00034       if (error >= 0) then
00035          WRITE(*,*) 'ERROR1: XF_SET_DATASET_NUM_TIMES must return ERROR.'
00036       endif
00037 
00038       if (1 == Itimestep) then
00039          Itimestep = 1;
00040       endif
00041       if (3 == Itimestep) then
00042          Itimestep = 2;
00043       endif
00044       if (5 == Itimestep) then
00045          Itimestep = 3;
00046       endif
00047 
00048       ! Write actual NumTimes
00049       call XF_SET_DATASET_NUM_TIMES( a_DatasetId, Itimestep, error )
00050       if (error < 0) then
00051          WRITE(*,*) 'ERROR2: xfSetDatasetNumTimes must NOT return error.'
00052       endif
00053 
00054       ! Test setting NumTimes after end step.
00055       call XF_SET_DATASET_NUM_TIMES( a_DatasetId, Itimestep + 1, error )
00056       if (error >= 0) then
00057          WRITE(*,*) 'ERROR3: xfSetDatasetNumTimes must return ERROR.'
00058       endif
00059 
00060       ! Test reading NumTimes
00061       call XF_GET_DATASET_NUM_TIMES( a_DatasetId, NumTimes, error )
00062       if (error < 0) then
00063          WRITE(*,*) 'ERROR4: xfSetDatasetNumTimes must NOT return error.'
00064       endif
00065       if (NumTimes .NE. Itimestep) then
00066          WRITE(*,*) 'ERROR5: xfGetDatasetNumTimes must return CORRECT NumTimes.'
00067       endif
00068 endif
00069 
00070 return
00071 
00072 END SUBROUTINE
00073 !ttiTestNumTimes
00074 ! --------------------------------------------------------------------------
00075 ! FUNCTION ttReadDatasets
00076 ! PURPOSE  Read a dataset group from an XMDF file and output information to
00077 !          to a text file
00078 ! NOTES    
00079 ! --------------------------------------------------------------------------
00080 RECURSIVE SUBROUTINE TT_READ_DATASETS (a_xGroupId, a_FileUnit, error)
00081 INTEGER, INTENT(IN) :: a_xGroupId
00082 INTEGER, INTENT(IN)        :: a_FileUnit
00083 INTEGER, INTENT(OUT)       :: error
00084 INTEGER                   nPaths, nMaxPathLength, j
00085 CHARACTER, ALLOCATABLE, DIMENSION(:) :: Paths
00086 CHARACTER(LEN=500)       IndividualPath
00087 INTEGER                   nStatus, i
00088 INTEGER            xScalarId, xVectorId, xMultiId
00089 INTEGER                   nMultiDatasets
00090 
00091 xScalarId = NONE
00092 xVectorId = NONE
00093 
00094 nMultiDatasets = 0
00095 nPaths = 0
00096 nMaxPathLength = 0
00097 
00098   ! Look for scalar datasets
00099 call XF_GET_SCALAR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus)
00100 if (nStatus >= 0 .AND. nPaths > 0) then
00101   allocate(Paths(nPaths*nMaxPathLength))
00102   call XF_GET_SCALAR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, &
00103                                                                          error)
00104 endif
00105 if (nStatus < 0) then
00106   error = -1
00107   return
00108 endif
00109 
00110   ! Output number and paths to scalar datasets
00111 WRITE(a_FileUnit,*) 'Number of Scalars ', nPaths
00112 do i=2, nPaths
00113   IndividualPath = ''
00114   do j=1, nMaxPathLength-1
00115     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00116   enddo
00117   WRITE(a_FileUnit,*) 'Reading scalar: ', IndividualPath(1:nMaxPathLength-1)
00118   call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00119                                                            xScalarId, nStatus)
00120   if (nStatus < 0) then
00121     error = -1
00122   return
00123   endif
00124 
00125   call TTI_READ_SCALAR(xScalarId, a_FileUnit, nStatus)
00126   call XF_CLOSE_GROUP(xScalarId, error)
00127   if (nStatus < 0) then
00128     WRITE(*,*) 'Error reading scalar dataset.'
00129     error = -1
00130   return
00131   endif
00132 enddo
00133 
00134 if (allocated(Paths)) deallocate(Paths)
00135   ! Look for vector datasets
00136 call XF_GET_VECTOR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus)
00137 if (nStatus >= 0 .AND. nPaths > 0) then
00138   allocate(Paths(nPaths*nMaxPathLength))
00139   call XF_GET_VECTOR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, error)
00140 endif
00141 if (nStatus < 0) then
00142   error = -1
00143   return
00144 endif
00145 
00146   ! Output number and paths to scalar datasets
00147 WRITE(a_FileUnit,*) 'Number of Vectors ', nPaths
00148 do i=2, nPaths
00149   do j=1, nMaxPathLength-1
00150     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00151   enddo
00152   WRITE(a_FileUnit,*) 'Reading Vector: ', &
00153                       IndividualPath(1:nMaxPathLength-1)
00154   call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00155                                                           xVectorId, nStatus)
00156   if (nStatus < 0) then
00157     error = -1
00158   return
00159   endif
00160   call TTI_READ_VECTOR(xVectorId, a_FileUnit, nStatus)
00161   call XF_CLOSE_GROUP(xVectorId, error)
00162   if (nStatus < 0) then
00163     WRITE(*,*) 'Error reading vector dataset.'
00164     error = -1
00165   return
00166   endif
00167 enddo
00168 
00169 if (allocated(Paths)) deallocate(Paths)
00170 
00171 ! find multidataset folders
00172 call XF_GET_GRP_PTHS_SZ_MLT_DSETS(a_xGroupId, nMultiDatasets, &
00173                                                       nMaxPathLength, nStatus)
00174 if (nStatus >= 0 .AND. nMultiDatasets > 0) then
00175   allocate(Paths(nMultiDatasets*nMaxPathLength))
00176   call XF_GET_ALL_GRP_PATHS_MLT_DSETS(a_xGroupId, nMultiDatasets, &
00177                                                  nMaxPathLength, Paths, error)
00178   if (nStatus < 0) then
00179     error = -1
00180     return
00181   endif
00182 
00183   ! Output number and paths to multidatasets
00184   WRITE(a_FileUnit,*) 'Number of Multidatasets ', nMultiDatasets
00185   do i=2, nMultiDatasets
00186     IndividualPath = ''
00187     do j=1, nMaxPathLength-1
00188       IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00189     enddo
00190     WRITE(a_FileUnit,*) 'Reading multidataset: ', &
00191                                              IndividualPath(1:nMaxPathLength-1)
00192     call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), &
00193                                                            xMultiId, nStatus)
00194     if (nStatus < 0) then
00195       error = -1
00196     return
00197     endif
00198 
00199     call TT_READ_DATASETS(xMultiId, a_FileUnit, nStatus)
00200     call XF_CLOSE_GROUP(xMultiId, error)
00201     if (nStatus < 0) then
00202       WRITE(*,*) 'Error reading multidatasets.'
00203       error = -1
00204     return
00205     endif
00206   enddo
00207 endif
00208 if (allocated(Paths)) deallocate(Paths)
00209 
00210 error = 1
00211 return
00212 
00213 END SUBROUTINE
00214 !ttReadDatasets
00215 ! --------------------------------------------------------------------------
00216 ! FUNCTION ttReadActivityScalarAIndex
00217 ! PURPOSE  Read all timestep values for a particular index
00218 ! NOTES    
00219 ! --------------------------------------------------------------------------
00220 SUBROUTINE TT_READ_ACTIVITY_SCALAR_A_INDEX(a_Filename, a_Index, error)
00221 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00222 INTEGER, INTENT(IN)   :: a_Index
00223 INTEGER, INTENT(OUT)  :: error
00224 INTEGER                  status
00225 INTEGER           xFileId, xDsetsId, xScalarAId
00226 INTEGER                  nTimesteps, i
00227 INTEGER, ALLOCATABLE  :: bActive(:)
00228 
00229 xFileId = NONE
00230 xDsetsId = NONE
00231 xScalarAId = NONE
00232 
00233   ! open the file
00234 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
00235 if (status < 0) then
00236   error = -1
00237   return
00238 endif
00239 
00240   ! open the dataset group
00241 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00242 if (status >= 0) then
00243   call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status)
00244 endif
00245 if (status < 0) then
00246   error = status
00247   return
00248 endif
00249 
00250   ! Find out the number of timesteps in the file
00251 CALL XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status)
00252 if (status < 0) then
00253   error = status
00254   return
00255 endif
00256 
00257 if (nTimesteps < 1) then
00258   error = -1
00259   return
00260 endif
00261 
00262   ! Read the values for the index
00263 allocate(bActive(nTimesteps))
00264 call XF_READ_ACTIVE_VALS_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, &
00265                                        bActive, status)
00266   ! output the data
00267 WRITE(*,*) ''
00268 WRITE(*,*) 'Reading activity for scalar A slice at index: ', a_Index
00269 do i=1, nTimesteps
00270   WRITE(*,*) bActive(i), ' '
00271 enddo
00272 
00273 deallocate(bActive)
00274 
00275 error = status
00276 return
00277 
00278 END SUBROUTINE
00279 ! ttReadActivityScalarAIndex
00280 
00281 ! --------------------------------------------------------------------------
00282 ! FUNCTION ttReadScalarAIndex
00283 ! PURPOSE  Read all timestep values for a particular index
00284 ! NOTES    
00285 ! --------------------------------------------------------------------------
00286 SUBROUTINE TT_READ_SCALAR_A_INDEX (a_Filename, a_Index, error)
00287 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00288 INTEGER, INTENT(IN)   :: a_Index
00289 INTEGER, INTENT(OUT)  :: error
00290 INTEGER              status
00291 INTEGER       xFileId, xDsetsId, xScalarAId
00292 INTEGER              nTimesteps, i
00293 REAL, ALLOCATABLE :: fValues(:)
00294 
00295 xFileId = NONE
00296 xDsetsId = NONE
00297 xScalarAId = NONE
00298 
00299   ! open the file
00300 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
00301 if (status < 0) then
00302   error = -1
00303   return
00304 endif
00305 
00306   ! open the dataset group
00307 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00308 if (status >= 0) then
00309   call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status)
00310 endif
00311 if (status < 0) then
00312   error = status
00313   return
00314 endif
00315 
00316   ! Find out the number of timesteps in the file
00317 call XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status)
00318 if (status < 0) then
00319   error = status
00320   return
00321 endif
00322 
00323 if (nTimesteps < 1) then
00324   error = -1
00325   return
00326 endif
00327 
00328   ! Read the values for the index
00329 allocate (fValues(nTimesteps))
00330 call XF_READ_SCALAR_VALUES_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, &
00331                                      fValues, status)
00332 
00333   ! output the data
00334 WRITE(*,*) ''
00335 WRITE(*,*) 'Reading scalar A slice at index: ', a_Index
00336 do i=1, nTimesteps
00337   WRITE(*,*) fValues(i), ' '
00338 enddo
00339 
00340 deallocate(fValues)
00341 
00342 error = status
00343 return
00344 
00345 END SUBROUTINE
00346 ! ttReadScalarAtIndex
00347 
00348 ! --------------------------------------------------------------------------
00349 ! FUNCTION ttWriteScalarA
00350 ! PURPOSE  Write scalar Dataset to an HDF5 File
00351 ! NOTES    This tests dynamic data sets, and activity
00352 !          This dataset is dynamic concentrations (mg/L) with output times
00353 !          in minutes.
00354 !          Dataset is for a mesh and so nActive is the number of elements
00355 !          which is not the same as the nValues which would be number of nodes
00356 !          reads/writes a reference time in julian days
00357 ! --------------------------------------------------------------------------
00358 SUBROUTINE TT_WRITE_SCALAR_A (a_Filename, a_Compression, error)
00359   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00360   INTEGER, INTENT(IN)          :: a_Compression
00361   INTEGER, INTENT(OUT)         :: error
00362   INTEGER      xFileId, xDsetsId, xScalarAId, xCoordId
00363   INTEGER      nValues, nTimes, nActive
00364   REAL(DOUBLE) dTime, dJulianReftime
00365   INTEGER      iTimestep, iActive, iHpgnZone
00366   REAL         fValues(10) ! nValues
00367   INTEGER*1    bActivity(10) ! activity
00368   INTEGER      i, status
00369 
00370   ! initialize the data
00371   nValues = 10
00372   nTimes = 3
00373   nActive = 8
00374   dTime = 0.0
00375 
00376   ! 5th item in data set is always inactive, others active
00377   do iActive = 1, nActive
00378     bActivity(iActive) = 1
00379   enddo 
00380   bActivity(6) = 0
00381 
00382 
00383   ! create the file
00384   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00385   if (error .LT. 0) then
00386       ! close the file
00387     call XF_CLOSE_FILE(xFileId, error)
00388     return
00389   endif
00390 
00391   ! create the group where we will put all the datasets 
00392   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00393   if (status < 0) then
00394     call XF_CLOSE_FILE(xFileId, error)
00395     error = -1
00396   return
00397   endif
00398 
00399   ! Create the scalar A dataset group
00400   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', &
00401               TS_HOURS, a_Compression, xScalarAId, status)
00402   if (status .LT. 0) then
00403       ! close the dataset
00404     call XF_CLOSE_GROUP(xScalarAId, error)
00405     call XF_CLOSE_GROUP(xDsetsId, error)
00406     call XF_CLOSE_FILE(xFileId, error)
00407     error = status
00408     return 
00409   endif
00410 
00411   ! Add in a reftime.  This is a julian day for:
00412   ! noon July 1, 2003
00413   dJulianReftime = 2452822.0;
00414   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
00415   if (status < 0) then
00416     call XF_CLOSE_GROUP(xScalarAId, error)
00417     call XF_CLOSE_GROUP(xDsetsId, error)
00418     call XF_CLOSE_FILE(xFileId, error)
00419   endif
00420 
00421   ! Loop through timesteps adding them to the file
00422   do iTimestep = 1, nTimes
00423     ! We will have an 0.5 hour timestep
00424     dTime = iTimestep * 0.5
00425 
00426     fValues(1) = dTime
00427     do i = 2, nValues
00428       fValues(i) = fValues(i-1)*2.5
00429     end do
00430 
00431     ! write the dataset array values
00432     call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, error)
00433     if (error .GE. 0) then
00434       ! write activity array
00435       call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, error)
00436     end if 
00437 
00438     call TTI_Test_Num_Times(xScalarAid, iTimestep, error)
00439   enddo
00440 
00441   ! Write Coordinate file - for ScalarA, we will set the coordinate system
00442   !   to be Geographic HPGN, with HPGN settings written to the file.
00443   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00444   if (status < 0) then
00445     call XF_CLOSE_GROUP(xScalarAId, error)
00446     call XF_CLOSE_GROUP(xDsetsId, error)
00447     call XF_CLOSE_FILE(xFileId, error)
00448     error = -1
00449   return
00450   endif
00451 
00452     ! set HPGN Zone for test
00453   iHpgnZone = 29   ! Utah
00454     ! Write Coordinate Information to file
00455   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
00456   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00457   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00458   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00459 
00460     ! write additional information
00461   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
00462 
00463   call XF_CLOSE_GROUP(xCoordId, error)
00464   xCoordId = 0;
00465 
00466   ! close the dataset
00467   call XF_CLOSE_GROUP(xScalarAId, error)
00468   call XF_CLOSE_GROUP(xDsetsId, error)
00469   call XF_CLOSE_FILE(xFileId, error)
00470 
00471   return
00472 END SUBROUTINE
00473 ! ttWriteScalarA
00474 
00475 ! --------------------------------------------------------------------------
00476 ! FUNCTION TT_WRITE_SCALAR_B
00477 ! PURPOSE  Write scalar Dataset to an HDF5 File
00478 ! NOTES    This tests dynamic data sets, and activity
00479 !          This dataset is dynamic concentrations (mg/L) with output times
00480 !          in minutes.
00481 !          Dataset is for a mesh and so nActive is the number of elements
00482 !          which is not the same as the nValues which would be number of nodes
00483 !          reads/writes a reference time in julian days
00484 ! --------------------------------------------------------------------------
00485 SUBROUTINE TT_WRITE_SCALAR_B (a_Filename, a_Compression, a_Overwrite, error)
00486   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00487   INTEGER, INTENT(IN)          :: a_Compression
00488   LOGICAL, INTENT(IN)          :: a_Overwrite
00489   INTEGER, INTENT(OUT)         :: error
00490   INTEGER      xFileId, xDsetsId, xScalarBId, xCoordId
00491   INTEGER      nValues, nTimes, nActive
00492   REAL(DOUBLE) dTime, dJulianReftime
00493   INTEGER      iTimestep, iActive
00494   REAL         fValues(10) ! nValues
00495   INTEGER*1    bActivity(10) ! activity
00496   INTEGER      i, status
00497 
00498   ! initialize the data
00499   nValues = 10
00500   nTimes = 3
00501   nActive = 8
00502   dTime = 0.0
00503   i = 0
00504 
00505   ! 5th item in data set is always inactive, others active
00506   do iActive = 1, nActive
00507     bActivity(iActive) = 1
00508   enddo 
00509   bActivity(6) = 0
00510 
00511   if (a_Overwrite) then
00512       ! open the already-existing file
00513     call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status)
00514     if (status < 0) then
00515       error = -1
00516       return
00517     endif
00518       ! open the group where we have all the datasets
00519     call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00520     if (status < 0) then
00521       call XF_CLOSE_FILE(xFileId, error)
00522       error = -1
00523       return
00524     endif
00525   else
00526       ! create the file
00527     call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00528     if (error .LT. 0) then
00529         ! close the file
00530       call XF_CLOSE_FILE(xFileId, error)
00531       return
00532     endif
00533 
00534       ! create the group where we will put all the datasets 
00535     call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00536     if (status < 0) then
00537       call XF_CLOSE_FILE(xFileId, error)
00538       error = -1
00539     return
00540     endif
00541   endif
00542 
00543   ! Create/Overwrite the scalar B dataset group
00544   call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_B_LOCATION, 'mg/L', &
00545               TS_HOURS, a_Compression, xScalarBId, status)
00546   if (status < 0) then
00547       ! close the dataset
00548     call XF_CLOSE_GROUP(xScalarBId, error)
00549     call XF_CLOSE_GROUP(xDsetsId, error)
00550     call XF_CLOSE_FILE(xFileId, error)
00551     error = status
00552     return 
00553   endif
00554 
00555   ! Add in a reftime.  This is a julian day for:
00556   ! noon July 1, 2003
00557   dJulianReftime = 2452822.0;
00558   call XF_WRITE_REFTIME(xScalarBId, dJulianReftime, status)
00559   if (status < 0) then
00560     call XF_CLOSE_GROUP(xScalarBId, error)
00561     call XF_CLOSE_GROUP(xDsetsId, error)
00562     call XF_CLOSE_FILE(xFileId, error)
00563   endif
00564 
00565   if (.NOT. a_Overwrite) then
00566       ! Loop through timesteps adding them to the file
00567     do iTimestep = 1, nTimes
00568         ! We will have an 0.5 hour timestep
00569       dTime = iTimestep * 0.5
00570 
00571       fValues(1) = dTime
00572       do i = 2, nValues
00573         fValues(i) = fValues(i-1)*2.5
00574       end do
00575 
00576         ! write the dataset array values
00577       call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error)
00578       if (error .GE. 0) then
00579           ! write activity array
00580         call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error)
00581       end if
00582       if (error < 0) then
00583           call XF_CLOSE_GROUP(xScalarBId, error)
00584           call XF_CLOSE_GROUP(xDsetsId, error)
00585           call XF_CLOSE_FILE(xFileId, error)
00586       endif
00587     enddo
00588   else
00589       ! Loop through timesteps adding them to the file
00590     do iTimestep = 1, nTimes
00591         ! We will have an 1.5 hour timestep
00592       dTime = iTimestep * 1.5
00593 
00594       fValues(1) = dTime
00595       do i = 2, nValues
00596         fValues(i) = fValues(i-1)*1.5
00597       end do
00598 
00599         ! write the dataset array values
00600       call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error)
00601       if (error .GE. 0) then
00602           ! write activity array
00603         call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error)
00604       end if
00605       if (error < 0) then
00606           call XF_CLOSE_GROUP(xScalarBId, error)
00607           call XF_CLOSE_GROUP(xDsetsId, error)
00608           call XF_CLOSE_FILE(xFileId, error)
00609       endif
00610     enddo
00611   endif
00612 
00613   if (.NOT. a_Overwrite) then
00614     ! Write Coordinate file - for ScalarB, we will set the coordinate system
00615     !   to be UTM, with UTM Zone settings written to the file.
00616     call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00617     if (status < 0) then
00618       call XF_CLOSE_GROUP(xScalarBId, error)
00619       call XF_CLOSE_GROUP(xDsetsId, error)
00620       call XF_CLOSE_FILE(xFileId, error)
00621     error = -1
00622     return
00623     endif
00624 
00625      ! Write Coord Info to file
00626     call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
00627     call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00628 
00629     call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00630     call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00631 
00632       ! write additional information - we'll use the max value for this test
00633     call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
00634 
00635     call XF_CLOSE_GROUP(xCoordId, error)
00636     xCoordId = 0
00637   endif
00638 
00639   ! close the dataset
00640   call XF_CLOSE_GROUP(xScalarBId, error)
00641   call XF_CLOSE_GROUP(xDsetsId, error)
00642   call XF_CLOSE_FILE(xFileId, error)
00643 
00644   error = 1
00645   return
00646 END SUBROUTINE
00647 ! ttWriteScalarB
00648 !------------------------------------------------------------------------------
00649 !  FUNCTION TT_WRITE_COORDS_TO_MULTI
00650 !  PURPOSE  Write coordinate system to a multidataset file
00651 !  NOTES
00652 !------------------------------------------------------------------------------
00653 SUBROUTINE TT_WRITE_COORDS_TO_MULTI (a_xFileId, error)
00654 INTEGER, INTENT(IN) :: a_xFileId
00655 INTEGER, INTENT(OUT)       :: error
00656 INTEGER    xCoordId
00657 INTEGER           status
00658 
00659   ! Write Coordinate file - for Multidatasets, we will set the coordinate system
00660   !   to be UTM, with UTM Zone settings written to the file.
00661   call XF_CREATE_COORDINATE_GROUP(a_xFileId, xCoordId, status)
00662   if (status < 0) then
00663     error = status
00664   return
00665   endif
00666 
00667     ! Write Coord Info to file
00668   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
00669   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00670 
00671   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00672   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00673 
00674     ! write additional information - we'll use the max value for this test
00675   call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
00676 
00677   call XF_CLOSE_GROUP(xCoordId, error)
00678   xCoordId = 0
00679 
00680   return
00681 END SUBROUTINE
00682 
00683 ! --------------------------------------------------------------------------
00684 ! FUNCTION ttWriteScalarAToMulti
00685 ! PURPOSE  Write scalar Dataset to an HDF5 File
00686 ! NOTES    This tests dynamic data sets, and activity
00687 !          This dataset is dynamic concentrations (mg/L) with output times
00688 !          in minutes.
00689 !          Dataset is for a mesh and so nActive is the number of elements
00690 !          which is not the same as the nValues which would be number of nodes
00691 !          reads/writes a reference time in julian days
00692 ! --------------------------------------------------------------------------
00693 SUBROUTINE TT_WRITE_SCALAR_A_TO_MULTI (a_GroupID, status)
00694  ! CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00695  ! INTEGER, INTENT(IN)          :: a_Compression
00696  ! INTEGER, INTENT(OUT)         :: error
00697   INTEGER      xFileId, xDsetsId, xScalarAId
00698   INTEGER      a_GroupID
00699   INTEGER      nValues, nTimes, nActive
00700   REAL(DOUBLE) dTime, dJulianReftime
00701   INTEGER      iTimestep, iActive
00702   REAL         fValues(10) ! nValues
00703   INTEGER*1    bActivity(10) ! activity
00704   INTEGER      i, status
00705 
00706   ! initialize the data
00707   nValues = 10
00708   nTimes  = 3
00709   nActive = 8
00710   dTime   = 0.0
00711 
00712   ! 5th item in data set is always inactive, others active
00713   do iActive = 1, nActive
00714     bActivity(iActive) = 1
00715   enddo 
00716   bActivity(6) = 0
00717 
00718   ! Create the scalar A dataset group
00719   call XF_CREATE_SCALAR_DATASET(a_GroupID, SCALAR_A_LOCATION, 'mg/L', &
00720               TS_HOURS, NONE, xScalarAId, status)
00721   if (status .LT. 0) then
00722       ! close the dataset
00723     call XF_CLOSE_GROUP(xScalarAId, status)
00724     call XF_CLOSE_GROUP(xDsetsId, status)
00725     call XF_CLOSE_FILE(xFileId, status)
00726     return 
00727   endif
00728 
00729   ! Add in a reftime.  This is a julian day for:
00730   ! noon July 1, 2003
00731   dJulianReftime = 2452822.0;
00732   call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status)
00733   if (status < 0) then
00734     call XF_CLOSE_GROUP(xScalarAId, status)
00735     call XF_CLOSE_GROUP(xDsetsId, status)
00736     call XF_CLOSE_FILE(xFileId, status)
00737   endif
00738 
00739   ! Loop through timesteps adding them to the file
00740   do iTimestep = 1, nTimes
00741     ! We will have an 0.5 hour timestep
00742     dTime = iTimestep * 0.5
00743 
00744     fValues(1) = dTime
00745     do i = 2, nValues
00746       fValues(i) = fValues(i-1)*2.5
00747     end do
00748 
00749     ! write the dataset array values
00750     call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, status)
00751     if (status .GE. 0) then
00752       ! write activity array
00753       call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, status)
00754     end if 
00755 
00756     call TTI_Test_Num_Times(xScalarAId, iTimestep, status)
00757   enddo
00758 
00759   ! close the dataset
00760   call XF_CLOSE_GROUP(xScalarAId, status)
00761   !call XF_CLOSE_GROUP(a_GroupID, status)
00762   !call XF_CLOSE_FILE(a_FileID, status)
00763 
00764   return
00765 END SUBROUTINE
00766 ! ttWriteScalarAToMulti
00767 ! --------------------------------------------------------------------------
00768 ! FUNCTION ttReadVector2DAIndex
00769 ! PURPOSE  Read all timestep values for a particular index
00770 ! NOTES    
00771 ! --------------------------------------------------------------------------
00772 SUBROUTINE TT_READ_VECTOR2D_A_INDEX (a_Filename, a_Index, error)
00773 CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00774 INTEGER, INTENT(IN)   :: a_Index
00775 INTEGER, INTENT(OUT)  :: error
00776 INTEGER           status
00777 INTEGER    xFileId, xDsetsId, xVector2DA
00778 INTEGER           nTimesteps, i
00779 REAL, ALLOCATABLE     :: fValues(:)
00780 
00781 xFileId = NONE
00782 xDsetsId = NONE
00783 xVector2DA = NONE
00784 
00785   ! open the file
00786 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status)
00787 if (status < 0) then
00788   error = -1
00789   return
00790 endif
00791 
00792   ! open the dataset group
00793 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00794 if (status >= 0) then
00795   call XF_OPEN_GROUP(xDsetsId, VECTOR2D_A_LOCATION, xVector2DA, status)
00796 endif
00797 if (status < 0) then
00798   error = status
00799   return
00800 endif
00801 
00802   ! Find out the number of timesteps in the file
00803 call XF_GET_DATASET_NUM_TIMES(xVector2DA, nTimesteps, status)
00804 if (status < 0) then
00805   error = status
00806   return
00807 endif
00808 
00809 if (nTimesteps < 1) then
00810   error = -1
00811   return
00812 endif
00813 
00814   ! Read the values for the index
00815 allocate(fValues(nTimesteps*2))
00816 call XF_READ_VECTOR_VALUES_AT_INDEX(xVector2DA, a_Index, 1, nTimesteps, 2, &
00817                                      fValues, status)
00818 
00819   ! output the data
00820 WRITE(*,*) ''
00821 WRITE(*,*) 'Reading vector 2D A slice at index: ', a_Index
00822 do i=1, nTimesteps
00823   WRITE(*,*) fValues(i*2-1), ' ', fValues(i*2)
00824 enddo
00825 WRITE(*,*) ''
00826 
00827 deallocate(fValues)
00828 
00829 error = status
00830 return
00831 
00832 END SUBROUTINE
00833 !ttReadVector2DAIndex
00834 
00835 ! --------------------------------------------------------------------------
00836 ! FUNCTION ttWriteVector2D_A
00837 ! PURPOSE  Write scalar Dataset to an HDF5 File
00838 ! NOTES    This tests dynamic data sets, and activity
00839 !          This dataset is dynamic concentrations (mg/L) with output times
00840 !          in minutes.
00841 !          Dataset is for a mesh and so nActive is the number of elements
00842 !          which is not the same as the nValues which would be number of nodes
00843 !          reads/writes a reference time in julian days
00844 ! --------------------------------------------------------------------------
00845 SUBROUTINE TT_WRITE_VECTOR2D_A (a_Filename, a_Compression, error)
00846   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00847   INTEGER, INTENT(IN)          :: a_Compression
00848   INTEGER, INTENT(OUT)         :: error
00849   INTEGER      xFileId, xDsetsId, xVector2D_A, xCoordId
00850   INTEGER      nValues, nTimes, nComponents, nActive
00851   REAL(DOUBLE) dTime
00852   INTEGER      iTimestep, iActive
00853   REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues
00854   INTEGER*1    bActivity(100) ! activity
00855   INTEGER      i, j, status
00856   INTEGER      iHpgnZone
00857 
00858   ! initialize the data
00859   nComponents = 2
00860   nValues = 100
00861   nTimes = 6
00862   nActive = 75
00863   dTime = 0.0
00864 
00865   ! 5th item in data set is always inactive, others active
00866   bActivity(1) = 0
00867   do iActive = 2, nActive
00868     if (mod(iActive-1, 3) == 0) then
00869       bActivity(iActive) = 0
00870     else
00871     bActivity(iActive) = 1
00872   endif
00873   enddo
00874 
00875   ! create the file
00876   call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
00877   if (error .LT. 0) then
00878     ! close the dataset
00879     call XF_CLOSE_FILE(xFileId, error)
00880     return
00881   endif
00882 
00883   ! create the group where we will put all the datasets 
00884   call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
00885   if (status < 0) then
00886     call XF_CLOSE_FILE(xFileId, error)
00887     error = -1
00888   return
00889   endif
00890 
00891   ! Create the vector dataset group
00892   call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_A_LOCATION, 'ft/s', &
00893               TS_SECONDS, a_Compression, xVector2D_A, status)
00894   if (status .LT. 0) then
00895       ! close the dataset
00896     call XF_CLOSE_GROUP(xVector2D_A, error)
00897     call XF_CLOSE_GROUP(xDsetsId, error)
00898     call XF_CLOSE_FILE(xFileId, error)
00899     error = status
00900     return 
00901   endif
00902 
00903   ! Loop through timesteps adding them to the file
00904   do iTimestep = 1, nTimes
00905     ! We will have an 0.5 hour timestep
00906     dTime = iTimestep * 0.5
00907 
00908     do i = 1, nValues
00909       do j = 1, nComponents
00910         fValues(j,i) = ((i-1)*nComponents + j)*dTime
00911       end do
00912     end do
00913 
00914     ! write the dataset array values
00915     call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, &
00916                                   fValues, error)
00917     if (error .GE. 0) then
00918       ! write activity array
00919       call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, error)
00920     end if 
00921 
00922     call TTI_Test_Num_Times(xVector2d_A, iTimestep, error)
00923   enddo
00924 
00925   ! Write Coordinate file - for Vector2D_A, we will set the coordinate system
00926   !   to be Geographic HPGN, with HPGN settings written to the file.
00927   call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
00928   if (status < 0) then
00929     call XF_CLOSE_GROUP(xVector2D_A, error)
00930     call XF_CLOSE_GROUP(xDsetsId, error)
00931     call XF_CLOSE_FILE(xFileId, error)
00932   error = -1
00933   return
00934   endif
00935 
00936     ! set HPGN info for test
00937   iHpgnZone = 29   ! Utah
00938 
00939   call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error)
00940   call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
00941   call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
00942   call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
00943 
00944     ! write additional information
00945   call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error)
00946 
00947   call XF_CLOSE_GROUP(xCoordId, error)
00948   xCoordId = 0
00949 
00950   ! close the dataset
00951   call XF_CLOSE_GROUP(xVector2D_A, error)
00952   call XF_CLOSE_GROUP(xDsetsId, error)
00953   call XF_CLOSE_FILE(xFileId, error)
00954 
00955   return
00956 END SUBROUTINE
00957 ! ttWriteVector2D_A
00958 
00959 ! --------------------------------------------------------------------------
00960 ! FUNCTION TT_WRITE_VECTOR2D_B
00961 ! PURPOSE  Write scalar Dataset to an HDF5 File
00962 ! NOTES    This tests dynamic data sets, and activity
00963 !          This dataset is dynamic concentrations (mg/L) with output times
00964 !          in minutes.
00965 !          Dataset is for a mesh and so nActive is the number of elements
00966 !          which is not the same as the nValues which would be number of nodes
00967 !          reads/writes a reference time in julian days
00968 ! --------------------------------------------------------------------------
00969 SUBROUTINE TT_WRITE_VECTOR2D_B (a_Filename, a_Compression, a_Overwrite, error)
00970   CHARACTER(LEN=*), INTENT(IN) :: a_Filename
00971   INTEGER, INTENT(IN)          :: a_Compression
00972   LOGICAL, INTENT(IN)          :: a_Overwrite
00973   INTEGER, INTENT(OUT)         :: error
00974   INTEGER      xFileId, xDsetsId, xVector2D_B, xCoordId
00975   INTEGER      nValues, nTimes, nComponents, nActive
00976   REAL(DOUBLE) dTime
00977   INTEGER      iTimestep, iActive
00978   REAL, DIMENSION(2, 100) :: fValues
00979   INTEGER*1    bActivity(100)
00980   INTEGER      i, j, status
00981 
00982     ! initialize the data
00983   nComponents = 2
00984   nValues = 100
00985   nTimes = 6
00986   nActive = 75
00987   dTime = 0.0
00988 
00989     ! 5th item in data set is always inactive, others active
00990   bActivity(1) = 0
00991   do iActive = 2, nActive
00992     if (mod(iActive-1, 3) == 0) then
00993       bActivity(iActive) = 0
00994     else
00995       bActivity(iActive) = 1
00996     endif
00997   enddo
00998 
00999   if (a_Overwrite) then
01000       ! open the already-existing file
01001     call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status)
01002     if (status < 0) then
01003       error = -1
01004       return
01005     endif
01006       ! open the group where we have all the datasets
01007     call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01008     if (status < 0) then
01009       call XF_CLOSE_FILE(xFileId, error)
01010       error = -1
01011       return
01012     endif
01013   else
01014       ! create the file
01015     call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error)
01016     if (error .LT. 0) then
01017         ! close the dataset
01018       call XF_CLOSE_FILE(xFileId, error)
01019       return
01020     endif
01021 
01022       ! create the group where we will put all the datasets 
01023     call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status)
01024     if (status < 0) then
01025       call XF_CLOSE_FILE(xFileId, error)
01026       error = -1
01027       return
01028     endif
01029   endif
01030 
01031     ! Create/Overwrite the vector dataset group
01032   call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_B_LOCATION, 'ft/s', &
01033                                 TS_SECONDS, a_Compression, xVector2D_B, status)
01034   if (status .LT. 0) then
01035       ! close the dataset
01036     call XF_CLOSE_GROUP(xVector2D_B, error)
01037     call XF_CLOSE_GROUP(xDsetsId, error)
01038     call XF_CLOSE_FILE(xFileId, error)
01039     error = status
01040     return 
01041   endif
01042 
01043   if (.NOT. a_Overwrite) then
01044       ! Loop through timesteps adding them to the file
01045     do iTimestep = 1, nTimes
01046         ! We will have an 0.5 hour timestep
01047       dTime = iTimestep * 0.5
01048       do i = 1, nValues
01049         do j = 1, nComponents
01050           fValues(j,i) = ((i-1)*nComponents + j)*dTime
01051         end do
01052       end do
01053         ! write the dataset array values
01054       call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, &
01055                                     fValues, error)
01056       if (error .GE. 0) then
01057           ! write activity array
01058         call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error)
01059       end if
01060       if (error < 0) then
01061         call XF_CLOSE_GROUP(xVector2D_B, error)
01062         call XF_CLOSE_GROUP(xDsetsId, error)
01063         call XF_CLOSE_FILE(xFileId, error)
01064       endif
01065     enddo
01066   else
01067       ! Loop through timesteps adding them to the file
01068     do iTimestep = 1, nTimes
01069         ! We will have an 1.5 hour timestep
01070       dTime = iTimestep * 1.5
01071       do i = 1, nValues
01072         do j = 1, nComponents
01073           fValues(j,i) = ((i-1)*nComponents + j)*dTime
01074         end do
01075       end do
01076         ! write the dataset array values
01077       call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, &
01078                                     fValues, error)
01079       if (error .GE. 0) then
01080           ! write activity array
01081         call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error)
01082       end if
01083       if (error < 0) then
01084         call XF_CLOSE_GROUP(xVector2D_B, error)
01085         call XF_CLOSE_GROUP(xDsetsId, error)
01086         call XF_CLOSE_FILE(xFileId, error)
01087       endif
01088     enddo
01089   endif
01090 
01091   if (.NOT. a_Overwrite) then
01092     ! Write Coordinate file - for ScalarB, we will set the coordinate system
01093     !   to be UTM, with UTM Zone settings written to the file.
01094     call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status)
01095     if (status < 0) then
01096       call XF_CLOSE_GROUP(xVector2D_B, error)
01097       call XF_CLOSE_GROUP(xDsetsId, error)
01098       call XF_CLOSE_FILE(xFileId, error)
01099     error = -1
01100     return
01101     endif
01102 
01103       ! write the coordinate data to the file
01104     call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error)
01105     call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error)
01106     call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error)
01107     call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error)
01108 
01109       ! write additional information - we'll use the max UTM zone for the test
01110     call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error)
01111 
01112     call XF_CLOSE_GROUP(xCoordId, error)
01113     xCoordId = 0
01114   endif
01115 
01116   ! close the dataset
01117   call XF_CLOSE_GROUP(xVector2D_B, error)
01118   call XF_CLOSE_GROUP(xDsetsId, error)
01119   call XF_CLOSE_FILE(xFileId, error)
01120 
01121   return
01122 END SUBROUTINE
01123 ! ttWriteVector2D_B
01124 
01125 ! --------------------------------------------------------------------------
01126 ! FUNCTION ttWriteVector2D_AToMulti
01127 ! PURPOSE  Write scalar Dataset to an HDF5 File
01128 ! NOTES    This tests dynamic data sets, and activity
01129 !          This dataset is dynamic concentrations (mg/L) with output times
01130 !          in minutes.
01131 !          Dataset is for a mesh and so nActive is the number of elements
01132 !          which is not the same as the nValues which would be number of nodes
01133 !          reads/writes a reference time in julian days
01134 ! --------------------------------------------------------------------------
01135 SUBROUTINE TT_WRITE_VECTOR2D_A_TO_MULTI (a_FileID, a_GroupID, status)
01136   INTEGER      xVector2D_A
01137   INTEGER      a_FileID, a_GroupID
01138   INTEGER      nValues, nTimes, nComponents, nActive
01139   REAL(DOUBLE) dTime
01140   INTEGER      iTimestep, iActive
01141   REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues
01142   INTEGER*1    bActivity(100) ! activity
01143   INTEGER      i, j, status
01144 
01145   ! initialize the data
01146   nComponents = 2
01147   nValues = 100
01148   nTimes = 6
01149   nActive = 75
01150   dTime = 0.0
01151 
01152   ! 5th item in data set is always inactive, others active
01153   bActivity(1) = 0
01154   do iActive = 2, nActive
01155     if (mod(iActive-1, 3) == 0) then
01156       bActivity(iActive) = 0
01157     else
01158     bActivity(iActive) = 1
01159   endif
01160   enddo
01161 
01162   ! Create the vector dataset group
01163   call XF_CREATE_VECTOR_DATASET(a_GroupID, VECTOR2D_A_LOCATION, 'ft/s', &
01164               TS_SECONDS, NONE, xVector2D_A, status)
01165   if (status .LT. 0) then
01166       ! close the dataset
01167     call XF_CLOSE_GROUP(xVector2D_A, status)
01168     call XF_CLOSE_GROUP(a_GroupID, status)
01169     call XF_CLOSE_FILE(a_FileID, status)
01170     return 
01171   endif
01172 
01173   ! Loop through timesteps adding them to the file
01174   do iTimestep = 1, nTimes
01175     ! We will have an 0.5 hour timestep
01176     dTime = iTimestep * 0.5
01177 
01178     do i = 1, nValues
01179       do j = 1, nComponents
01180         fValues(j,i) = ((i-1)*nComponents + j)*dTime
01181       end do
01182     end do
01183 
01184     ! write the dataset array values
01185     call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, &
01186                                   fValues, status)
01187     if (status .GE. 0) then
01188       ! write activity array
01189       call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, status)
01190     end if 
01191 
01192     call TTI_Test_Num_Times(xVector2D_A, iTimestep, status)
01193   enddo
01194 
01195   ! close the dataset
01196   call XF_CLOSE_GROUP(xVector2D_A, status)
01197   return
01198 END SUBROUTINE
01199 ! ttWriteVector2D_AToMulti
01200 ! --------------------------------------------------------------------------
01201 ! FUNCTION ttiReadScalar
01202 ! PURPOSE  Read a scalar from an XMDF file and output information to
01203 !          to a text file
01204 ! NOTES    
01205 ! --------------------------------------------------------------------------
01206 SUBROUTINE TTI_READ_SCALAR (a_xScalarId, FileUnit, error)
01207   INTEGER, INTENT(IN) ::  a_xScalarId
01208   INTEGER, INTENT(IN) ::         FileUnit
01209   INTEGER, INTENT(OUT) :: error
01210   INTEGER             nTimes, nValues, nActive
01211   LOGICAL*2             bUseReftime
01212   INTEGER             iTime
01213   CHARACTER(LEN=100)   TimeUnits
01214   REAL(DOUBLE), ALLOCATABLE :: Times(:)
01215   REAL, ALLOCATABLE         :: Values(:), Minimums(:), Maximums(:)
01216   INTEGER, ALLOCATABLE      :: Active(:)
01217   REAL(DOUBLE)                 Reftime
01218 nTimes = NONE
01219 nValues = NONE
01220 nActive = None
01221 
01222   ! read the time units
01223   call XF_GET_DATASET_TIME_UNITS(a_xScalarId, TimeUnits, error)
01224   if (error < 0) return
01225 
01226   WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits))
01227 
01228   ! see if we are using a reftime
01229   call XF_USE_REFTIME (a_xScalarId, bUseReftime, error)
01230   if (error < 0) then
01231     return
01232   endif
01233   if (bUseReftime) then
01234     call XF_READ_REFTIME (a_xScalarId, Reftime, error)
01235     if (error < 0) then
01236       return
01237   endif
01238     WRITE(FileUnit,*) 'Reftime: ', Reftime
01239   endif
01240 
01241   ! read in the number of values and number of active values
01242   call XF_GET_DATASET_NUMVALS(a_xScalarId, nValues, error)
01243   if (error .GE. 0) then
01244     call XF_GET_DATASET_NUMACTIVE(a_xScalarId, nActive, error)
01245   endif
01246   if (error .LT. 0) return 
01247 
01248   if (nValues <= 0) then
01249     WRITE(FileUnit, *) 'No data to read in.'
01250     error = -1
01251     return 
01252   endif
01253 
01254   ! read in the number of times
01255   call XF_GET_DATASET_NUM_TIMES(a_xScalarId, nTimes, error)
01256   if (error < 0) then
01257     return 
01258   endif
01259 
01260   ! Read in the individual time values
01261   allocate(Times(nTimes))
01262 
01263   call XF_GET_DATASET_TIMES(a_xScalarId, nTimes, Times, error)
01264   if (error < 0) return 
01265 
01266   ! Read in the minimum and maximum values
01267   allocate(Minimums(nTimes))
01268   allocate(Maximums(nTimes))
01269 
01270   call XF_GET_DATASET_MINS(a_xScalarId, nTimes, Minimums, error)
01271   if (error >= 0) then
01272     call XF_GET_DATASET_MAXS(a_xScalarId, nTimes, Maximums, error)
01273   endif
01274   if (error < 0) then
01275     deallocate(Times)
01276     deallocate(Minimums)
01277     deallocate(Maximums)
01278     return
01279   endif
01280 
01281   allocate(Values(nValues))
01282   if (nActive .GT. 0) then
01283     allocate(Active(nActive))
01284   endif
01285 
01286   WRITE(FileUnit,*) 'Number Timesteps: ', nTimes
01287   WRITE(FileUnit,*) 'Number Values: ', nValues
01288   WRITE(FileUnit,*) 'Number Active: ', nActive
01289   WRITE(FileUnit,*) ''
01290 
01291   ! loop through the timesteps, read the values and active values and write
01292   ! them to the text file
01293   do iTime = 1, nTimes
01294     call XF_READ_SCALAR_VALUES_TIMESTEP(a_xScalarId, iTime, nValues, Values, error)
01295     if (error >= 0 .AND. nActive > 0) then
01296       call XF_READ_ACTIVITY_TIMESTEP(a_xScalarId, iTime, nActive, Active, error)
01297     endif
01298 
01299     ! Write the time, min, max, values and active values to the text output
01300     ! file.
01301     WRITE(FileUnit,*) 'Timestep at  ', Times(iTime)
01302     WRITE(FileUnit,*) 'Min: ', Minimums(iTime)
01303     WRITE(FileUnit,*) 'Max: ', Maximums(iTime)
01304 
01305     WRITE(FileUnit,*) 'Values:'
01306     WRITE(FileUnit,*) Values(1:nValues)
01307     WRITE(FileUnit,*) ''
01308 
01309     WRITE(FileUnit,*) 'Activity:'
01310     WRITE(FileUnit,*) Active(1:nActive)
01311     WRITE(FileUnit,*) ''
01312   end do
01313 
01314   if (allocated(Times)) then
01315     deallocate(Times)
01316   endif
01317   
01318   if (allocated(Minimums)) then
01319     deallocate(Minimums)
01320   endif
01321 
01322   if (allocated(Maximums)) then
01323     deallocate(Maximums)
01324   endif
01325 
01326   if (allocated(Values)) then
01327     deallocate(Values)
01328   endif
01329 
01330   if (allocated(Active)) then
01331     deallocate(Active)
01332   endif
01333 
01334   return
01335 END SUBROUTINE
01336 ! ttiReadScalar
01337 
01338 ! --------------------------------------------------------------------------
01339 ! FUNCTION TTI_READ_VECTOR
01340 ! PURPOSE  Read a vector from an XMDF file and output information to
01341 !          to a text file
01342 ! NOTES    
01343 ! --------------------------------------------------------------------------
01344 SUBROUTINE TTI_READ_VECTOR (a_xVectorId, FileUnit, error)
01345   INTEGER, INTENT(IN) ::  a_xVectorId
01346   INTEGER, INTENT(IN) ::         FileUnit
01347   INTEGER, INTENT(OUT) :: error
01348   INTEGER             nTimes, nValues, nActive, nComponents
01349   INTEGER             iTime, i
01350   LOGICAL*2            bUseReftime
01351   CHARACTER(LEN=100)   TimeUnits
01352   REAL(DOUBLE), ALLOCATABLE :: Times(:)
01353   REAL, ALLOCATABLE, DIMENSION (:, :) :: Values
01354   REAL, ALLOCATABLE         :: Minimums(:), Maximums(:)
01355   INTEGER, ALLOCATABLE      :: Active(:)
01356   REAL(DOUBLE)                 Reftime
01357 
01358 nTimes = NONE
01359 nValues = NONE
01360 nActive = NONE
01361 nComponents = NONE
01362 
01363   ! read the time units
01364   call XF_GET_DATASET_TIME_UNITS(a_xVectorId, TimeUnits, error)
01365   if (error < 0) return
01366 
01367   WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits))
01368 
01369   ! see if we are using a reftime
01370   call XF_USE_REFTIME (a_xVectorId, bUseReftime, error)
01371   if (error < 0) then
01372     return
01373   endif
01374   if (bUseReftime) then
01375     call XF_READ_REFTIME (a_xVectorId, Reftime, error)
01376     if (error < 0) then
01377       return
01378   endif
01379     WRITE(FileUnit,*) 'Reftime: ', Reftime
01380   endif
01381 
01382   ! read in the number of values and number of active values
01383   call XF_GET_DATASET_NUMVALS(a_xVectorId, nValues, error)
01384   if (error .GE. 0) then
01385     call XF_GET_DATASET_NUMCOMPONENTS(a_xVectorId, nComponents, error)
01386     if (error .GE. 0) then
01387       call XF_GET_DATASET_NUMACTIVE(a_xVectorId, nActive, error)
01388     endif
01389   endif
01390   if (error .LT. 0) return 
01391 
01392   if (nValues <= 0) then
01393     WRITE(FileUnit, *) 'No data to read in.'
01394     error = -1
01395     return 
01396   endif
01397 
01398   ! read in the number of times
01399   call XF_GET_DATASET_NUM_TIMES(a_xVectorId, nTimes, error)
01400   if (error < 0) then
01401     return 
01402   endif
01403 
01404   ! Read in the individual time values
01405   allocate(Times(nTimes))
01406 
01407   call XF_GET_DATASET_TIMES(a_xVectorId, nTimes, Times, error)
01408   if (error < 0) return 
01409 
01410   ! Read in the minimum and maximum values
01411   allocate(Minimums(nTimes))
01412   allocate(Maximums(nTimes))
01413 
01414   call XF_GET_DATASET_MINS(a_xVectorId, nTimes, Minimums, error)
01415   if (error >= 0) then
01416     call XF_GET_DATASET_MAXS(a_xVectorId, nTimes, Maximums, error)
01417   endif
01418   if (error < 0) then
01419     deallocate(Times)
01420     deallocate(Minimums)
01421     deallocate(Maximums)
01422     return
01423   endif
01424 
01425   allocate(Values(nComponents, nValues))
01426   if (nActive .GT. 0) then
01427     allocate(Active(nActive))
01428   endif
01429 
01430   WRITE(FileUnit,*) 'Number Timesteps: ', nTimes
01431   WRITE(FileUnit,*) 'Number Values: ', nValues
01432   WRITE(FileUnit,*) 'Number Components: ', nComponents
01433   WRITE(FileUnit,*) 'Number Active: ', nActive
01434 
01435   ! loop through the timesteps, read the values and active values and write
01436   ! them to the text file
01437   do iTime = 1, nTimes
01438     call XF_READ_VECTOR_VALUES_TIMESTEP(a_xVectorId, iTime, nValues, &
01439                                         nComponents, Values, error)
01440     if (error >= 0 .AND. nActive > 0) then
01441       call XF_READ_ACTIVITY_TIMESTEP(a_xVectorId, iTime, nActive, Active, error)
01442     endif
01443 
01444     ! Write the time, min, max, values and active values to the text output
01445     ! file.
01446   WRITE(FileUnit,*) ''
01447     WRITE(FileUnit,*) 'Timestep at  ', Times(iTime)
01448     WRITE(FileUnit,*) 'Min: ', Minimums(iTime)
01449     WRITE(FileUnit,*) 'Max: ', Maximums(iTime)
01450 
01451     WRITE(FileUnit,*) 'Values:'
01452     do i=1, nValues
01453       WRITE(FileUnit,*) Values(1:nComponents,i:i)
01454     enddo
01455     WRITE(FileUnit,*) ''
01456 
01457     WRITE(FileUnit,*) 'Activity:'
01458     WRITE(FileUnit,*) Active(1:nActive)
01459     WRITE(FileUnit,*) ''    
01460   WRITE(FileUnit,*) ''    
01461 
01462   end do
01463 
01464   if (allocated(Times)) then
01465     deallocate(Times)
01466   endif
01467   
01468   if (allocated(Minimums)) then
01469     deallocate(Minimums)
01470   endif
01471 
01472   if (allocated(Maximums)) then
01473     deallocate(Maximums)
01474   endif
01475 
01476   if (allocated(Values)) then
01477     deallocate(Values)
01478   endif
01479 
01480   if (allocated(Active)) then
01481     deallocate(Active)
01482   endif
01483 
01484   return
01485 END SUBROUTINE
01486 ! ttiReadVector
01487 
01488 END MODULE TestTimestep
TestTimestep.f90 tests timesteps

00001 MODULE TestDefs
00002 
00003 INTEGER, PARAMETER :: NUMTIMES1   = 5
00004 INTEGER, PARAMETER :: NUMVALUES1  = 5
00005 INTEGER, PARAMETER :: NUMACTIVE1  = 3
00006 INTEGER, PARAMETER :: NUMTIMESADD = 1
00007 
00008 CHARACTER(LEN=*), PARAMETER :: XMDF_VERSION_OUT_F = 'XMDF_Version_f.txt'
00009 CHARACTER(LEN=*), PARAMETER :: MESH_A_FILE_F = 'mesh_a_file_f.h5'
00010 CHARACTER(LEN=*), PARAMETER :: MESH_B_FILE_F = 'mesh_b_file_f.h5'
00011 CHARACTER(LEN=*), PARAMETER :: MESH_A_OUT_F  = 'mesh_a_file_f.txt'
00012 CHARACTER(LEN=*), PARAMETER :: MESH_B_OUT_F  = 'mesh_b_file_f.txt'
00013 
00014 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_FILE_F = 'grid_cart2d_a_file_f.h5'
00015 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_FILE_F = 'grid_curv2d_a_file_f.h5'
00016 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_FILE_F = 'grid_cart3d_a_file_f.h5'
00017 
00018 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_OUT_F = 'grid_cart2d_a_out_f.txt'
00019 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_OUT_F = 'grid_curv2d_a_out_f.txt'
00020 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_OUT_F = 'grid_cart3d_a_out_f.txt'
00021 
00022 CHARACTER(LEN=*), PARAMETER :: MULTIDATASET_FILE_F = 'MultiDataSet_f.h5'
00023 CHARACTER(LEN=*), PARAMETER :: MULTIDATASET_TEXT_F = 'MultiDataSet_f.txt'
00024 
00025 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_FILE_F   = 'ScalarA_f.h5'
00026 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_TEXT_F   = 'ScalarA_f.txt'
00027 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_PIECES_FILE_F   = 'ScalarA_Pieces_f.h5'
00028 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_EDITED_FILE_F   = 'ScalarA_edited_f.h5'
00029 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_EDITED_TEXT_F   = 'ScalarA_edited_f.txt'
00030 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_PIECES_ALT_FILE_F   = 'ScalarA_Pieces_alt_f.h5'
00031 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_FILE_F   = 'ScalarB_f.h5'
00032 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_TEXT_F   = 'ScalarB_f.txt'
00033 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_FILE_F = 'Vector2D_A_f.h5'
00034 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_TEXT_F = 'Vector2D_A_f.txt'
00035 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_PIECES_FILE_F = 'Vector2D_A_Pieces_f.h5'
00036 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_FILE_F = 'Vector2D_B_f.h5'
00037 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_TEXT_F = 'Vector2D_B_f.txt'
00038 
00039 CHARACTER(LEN=*), PARAMETER :: MESH_A_FILE_C = 'mesh_a_file_c.h5'
00040 CHARACTER(LEN=*), PARAMETER :: MESH_B_FILE_C = 'mesh_b_file_c.h5'
00041 CHARACTER(LEN=*), PARAMETER :: MESH_A_OUT_CF  = 'mesh_a_file_cf.txt'
00042 CHARACTER(LEN=*), PARAMETER :: MESH_B_OUT_CF  = 'mesh_b_file_cf.txt'
00043 
00044 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_FILE_C = 'grid_cart2d_a_file_c.h5'
00045 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_FILE_C = 'grid_curv2d_a_file_c.h5'
00046 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_FILE_C = 'grid_cart3d_a_file_c.h5'
00047 
00048 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_OUT_CF = 'grid_cart2d_a_out_cf.txt'
00049 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_OUT_CF = 'grid_curv2d_a_out_cf.txt'
00050 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_OUT_CF = 'grid_cart3d_a_out_cf.txt'
00051 
00052 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_FILE_C   = 'ScalarA_c.h5'
00053 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_TEXT_CF   = 'ScalarA_cf.txt'
00054 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_FILE_C   = 'ScalarB_c.h5'
00055 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_TEXT_CF   = 'ScalarB_cf.txt'
00056 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_FILE_C = 'Vector2D_A_c.h5'
00057 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_TEXT_CF = 'Vector2D_A_cf.txt'
00058 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_FILE_C = 'Vector2D_B_c.h5'
00059 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_TEXT_CF = 'Vector2D_B_cf.txt'
00060 
00061 CHARACTER(LEN=*), PARAMETER :: CALENDAR_OUT_F = 'Calendar_f.txt'
00062 
00063 CHARACTER(LEN=*), PARAMETER :: GEOMPATH_A_FILE_F = 'Geompath_a_file_f.h5'
00064 CHARACTER(LEN=*), PARAMETER :: GEOMPATH_A_FILE_F_OUT = 'Geompath_a_file_f_out.txt'
00065 
00066 CHARACTER(LEN=*), PARAMETER :: TT_MULTIDATASET_FILE_F = 'TT_MultiDataSet_f.h5'
00067 CHARACTER(LEN=*), PARAMETER :: TT_SCALAR_A_FILE_F   = 'TT_ScalarA_f.h5'
00068 CHARACTER(LEN=*), PARAMETER :: TT_SCALAR_A_TEXT_F   = 'TT_ScalarA_f.txt'
00069 CHARACTER(LEN=*), PARAMETER :: TT_VECTOR2D_A_FILE_F = 'TT_Vector2D_A_f.h5'
00070 
00071   ! Overwrite options in the function xfSetupToWriteDatasets
00072 !INTEGER,PARAMETER :: XF_OVERWRITE_CLEAR_FILE          = 1
00073 !INTEGER,PARAMETER :: XF_OVERWRITE_CLEAR_DATASET_GROUP = 2
00074 !INTEGER,PARAMETER :: XF_OVERWRITE_NONE                = 3
00075 
00076 END MODULE TestDefs
00077 
00078 MODULE TestsModule
00079 
00080 USE XMDF
00081 USE XMDFDEFS
00082 USE TestTimestep
00083 USE TestDatasets
00084 USE TestMesh
00085 USE TestGrid
00086 USE TestDefs
00087 USE TestGeomPaths
00088 
00089 CONTAINS
00090 
00091 !**************************
00092 !-----------------------------------------------------------------------------
00093 ! SUBROUTINE  TXI_TEST_TIMESTEPS
00094 ! PURPOSE     test to see if the code can read timestepfiles 
00095 ! NOTES
00096 !------------------------------------------------------------------------------
00097 SUBROUTINE TXI_TEST_TIMESTEPS(error)
00098 INTEGER, INTENT(OUT) :: error
00099 INTEGER    status, compression
00100 INTEGER  MultiFileId, MultiGroupId
00101 INTEGER         NumOpen
00102 
00103 CHARACTER(LEN=37) SdoGuid
00104 
00105 SdoGuid = '73289C80-6235-4fdc-9649-49E4F5AEB676'
00106 
00107 status = 1
00108 compression = NONE
00109 ! 'Path' should be able to be blank, but now it creates errors if it's blank
00110  call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', &
00111            SdoGuid, XF_OVERWRITE_CLEAR_FILE, MultiFileId, MultiGroupId, error)
00112 
00113   ! Write coordinates to multidatasets
00114 call TT_WRITE_COORDS_TO_MULTI(MultiFileId, error)
00115 
00116   ! Write scalar A and Vector A to multidatasets.
00117 call TT_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error)
00118 
00119 call TT_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error)
00120 
00121 call XF_CLOSE_GROUP(MultiGroupId, status)
00122 call XF_CLOSE_FILE(MultiFileId, status)
00123 
00124 WRITE(*,*) 'Done writing multiple datasets...'
00125 
00126   ! scalar datasets
00127 call TT_WRITE_SCALAR_A(TT_SCALAR_A_FILE_F, compression, status)
00128 if (status < 0) then
00129   error = status
00130   return
00131 endif
00132   
00133 WRITE(*,*) 'Done writing scalar datasets...'
00134 
00135   ! vector datasets
00136 call TT_WRITE_VECTOR2D_A(TT_VECTOR2D_A_FILE_F, compression, status)
00137 if (status < 0) then
00138   WRITE(*,*) 'Error writing dataset vector2D_A.'
00139   error = status
00140   return
00141 endif
00142 
00143 WRITE(*,*) 'Done writing vector datasets...'
00144 
00145 WRITE(*,*) 'Write edited scalar datasets...'
00146 call TD_EDIT_SCALAR_A_VALUES(SCALAR_A_EDITED_FILE_F, compression, status);
00147 if (status < 0) then
00148   error = status
00149   return
00150 endif
00151 
00152 WRITE(*,*) 'Done writing datasets...'
00153 
00154   ! Read the files back in
00155 call TXI_READ_X_FORMAT_FILE(TT_SCALAR_A_FILE_F, SCALAR_A_TEXT_F, status)
00156 if (status < 0) then
00157   WRITE(*,*) 'Error reading SCALAR A File (see TXI_READ_X_FORMAT_FILE)'
00158   error = status
00159   return
00160 endif
00161 
00162 call TXI_READ_X_FORMAT_FILE(SCALAR_A_EDITED_FILE_F, SCALAR_A_EDITED_TEXT_F, status)
00163 if (status < 0) then
00164   WRITE(*,*) 'Error reading SCALAR A Edited File (see TXI_READ_X_FORMAT_FILE)'
00165   error = status
00166   return
00167 endif
00168 
00169 call  TXI_READ_X_FORMAT_FILE(TT_VECTOR2D_A_FILE_F, VECTOR2D_A_TEXT_F, status)
00170 if (status < 0) then
00171   WRITE(*,*) 'Error reading VECTOR A Format File'
00172   error = status
00173   return
00174 endif
00175 
00176 call TXI_READ_X_FORMAT_FILE(TT_MULTIDATASET_FILE_F, MULTIDATASET_TEXT_F, status)
00177 if (status < 0) then
00178   WRITE(*,*) 'Error reading Multidataset File (see TXI_READ_X_FORMAT_FILE)'
00179   error = status
00180   return
00181 endif
00182 
00183 WRITE(*,*) 'Done reading datasets...'
00184 
00185 call XF_GET_NUM_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, NumOpen, error)
00186 
00187 call XFI_CLOSE_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, error)
00188 
00189 call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', &
00190      SdoGuid, XF_OVERWRITE_CLEAR_DATASET_GRP, MultiFileId, MultiGroupId, &
00191                                                                   error)
00192 
00193 call TT_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error)
00194 
00195 call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', &
00196      SdoGuid, XF_OVERWRITE_NONE, MultiFileId, MultiGroupId, error)
00197 
00198 call TT_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error)
00199 
00200   ! Test reading information at index for multiple timesteps
00201 call TT_READ_SCALAR_A_INDEX(TT_SCALAR_A_FILE_F, 4, status)
00202 if (status < 0) then
00203   error = status
00204   return
00205 endif
00206 
00207 WRITE(*,*) 'Done reading scalar data at index.'
00208   
00209 call TT_READ_VECTOR2D_A_INDEX(TT_VECTOR2D_A_FILE_F, 6, status)
00210 if (status < 0) then
00211   error = status
00212   return
00213 endif
00214 
00215 WRITE(*,*) 'Done reading vector data at index.'
00216 
00217 call TT_READ_ACTIVITY_SCALAR_A_INDEX(TT_SCALAR_A_FILE_F, 6, status)
00218 if (status < 0) then
00219   error = status
00220   return
00221 endif
00222 
00223 error = status
00224 return
00225 
00226 END SUBROUTINE
00227 
00228 
00229 !**************************
00230 !-----------------------------------------------------------------------------
00231 ! SUBROUTINE  TXI_TEST_DATASETS
00232 ! PURPOSE     test to see if the code can read datasetfiles 
00233 ! NOTES
00234 !------------------------------------------------------------------------------
00235 SUBROUTINE TXI_TEST_DATASETS(error)
00236 INTEGER, INTENT(OUT) :: error
00237 INTEGER    status, compression
00238 INTEGER  MultiFileId, MultiGroupId
00239 INTEGER         NumOpen
00240 INTEGER, PARAMETER :: nIndices = 3
00241 INTEGER, DIMENSION(nIndices) :: indices
00242 
00243 CHARACTER(LEN=37) SdoGuid
00244 
00245 SdoGuid = '73289C80-6235-4fdc-9649-49E4F5AEB676'
00246 
00247 status = 1
00248 compression = NONE
00249 ! 'Path' should be able to be blank, but now it creates errors if it's blank
00250 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', &
00251            SdoGuid, XF_OVERWRITE_CLEAR_FILE, MultiFileId, MultiGroupId, error)
00252 
00253   ! Write coordinates to multidatasets
00254 call TD_WRITE_COORDS_TO_MULTI(MultiFileId, error)
00255 
00256   ! Write scalar A and Vector A to multidatasets.
00257 call TD_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error)
00258 
00259 call TD_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error)
00260 
00261 call XF_CLOSE_GROUP(MultiGroupId, status)
00262 call XF_CLOSE_FILE(MultiFileId, status)
00263 
00264 WRITE(*,*) 'Done writing multiple datasets...'
00265 
00266   ! scalar datasets
00267 call TD_WRITE_SCALAR_A(SCALAR_A_FILE_F, compression, status)
00268 if (status < 0) then
00269   error = status
00270   return
00271 endif
00272 
00273 call TD_WRITE_SCALAR_A_PIECES(SCALAR_A_PIECES_FILE_F, compression, status)
00274 if (status < 0) then
00275   error = status
00276   return
00277 endif
00278 
00279 call TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX(SCALAR_A_PIECES_ALT_FILE_F, &
00280                                           compression, status)
00281 if (status < 0) then
00282   error = status
00283   return
00284 endif
00285   
00286 WRITE(*,*) 'Done writing scalar datasets...'
00287 
00288   ! vector datasets
00289 call TD_WRITE_VECTOR2D_A(VECTOR2D_A_FILE_F, compression, status)
00290 if (status < 0) then
00291   WRITE(*,*) 'Error writing dataset vector2D_A.'
00292   error = status
00293   return
00294 endif
00295 
00296 call TD_WRITE_VECTOR2D_A_PIECES(VECTOR2D_A_PIECES_FILE_F, compression, status)
00297 if (status < 0) then
00298   WRITE(*,*) 'Error writing dataset vector2D_A.'
00299   error = status
00300   return
00301 endif
00302 
00303 WRITE(*,*) 'Done writing vector datasets...'
00304 
00305 WRITE(*,*) 'Done writing datasets...'
00306 
00307   ! Read the files back in
00308 call TXI_READ_X_FORMAT_FILE(SCALAR_A_FILE_F, SCALAR_A_TEXT_F, status)
00309 if (status < 0) then
00310   WRITE(*,*) 'Error reading SCALAR A File (see TXI_READ_X_FORMAT_FILE)'
00311   error = status
00312   return
00313 endif
00314 
00315 call  TXI_READ_X_FORMAT_FILE(VECTOR2D_A_FILE_F, VECTOR2D_A_TEXT_F, status)
00316 if (status < 0) then
00317   WRITE(*,*) 'Error reading VECTOR A Format File'
00318   error = status
00319   return
00320 endif
00321 
00322 call TXI_READ_X_FORMAT_FILE(MULTIDATASET_FILE_F, MULTIDATASET_TEXT_F, status)
00323 if (status < 0) then
00324   WRITE(*,*) 'Error reading Multidataset File (see TXI_READ_X_FORMAT_FILE)'
00325   error = status
00326   return
00327 endif
00328 
00329 WRITE(*,*) 'Done reading datasets...'
00330 
00331 call XF_GET_NUM_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, NumOpen, error)
00332 
00333 call XFI_CLOSE_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, error)
00334 
00335 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', &
00336      SdoGuid, XF_OVERWRITE_CLEAR_DATASET_GRP, MultiFileId, MultiGroupId, &
00337                                                                   error)
00338 
00339 call TD_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error)
00340 
00341 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', &
00342      SdoGuid, XF_OVERWRITE_NONE, MultiFileId, MultiGroupId, error)
00343 
00344 call TD_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error)
00345 
00346   ! Test reading information at index for multiple timesteps
00347 call TD_READ_SCALAR_A_INDEX(SCALAR_A_FILE_F, 4, status)
00348 if (status < 0) then
00349   error = status
00350   return
00351 endif
00352 
00353 WRITE(*,*) 'Done reading scalar data at index.'
00354   
00355 call TD_READ_VECTOR2D_A_INDEX(VECTOR2D_A_FILE_F, 6, status)
00356 if (status < 0) then
00357   error = status
00358   return
00359 endif
00360 
00361 WRITE(*,*) 'Done reading vector data at index.'
00362 
00363 call TD_READ_ACTIVITY_SCALAR_A_INDEX(SCALAR_A_FILE_F, 6, status)
00364 if (status < 0) then
00365   error = status
00366   return
00367 endif
00368 
00369     ! Test reading information at multiple indices
00370   indices(1) = 2;
00371   indices(2) = 3;
00372   indices(3) = 5;
00373   CALL TD_READ_SCALAR_A_INDICES(SCALAR_A_FILE_F, nIndices, indices, error)
00374 
00375 error = status
00376 return
00377 
00378 END SUBROUTINE
00379 
00380 !------------------------------------------------------------------------------
00381 !  FUNCTION  TXI_TEST_OVERWRITE_DSETS
00382 !  PURPOSE   Check to see if already-written datasets can be overwritten
00383 !  NOTES
00384 !------------------------------------------------------------------------------
00385 SUBROUTINE TXI_TEST_OVERWRITE_DSETS(error)
00386 INTEGER, INTENT(OUT) :: error
00387 INTEGER    status, compression
00388 
00389   status = 1
00390   compression = NONE
00391 
00392     ! scalar datasets
00393   call TD_WRITE_SCALAR_B(SCALAR_B_FILE_F, compression, .FALSE., status)
00394   if (status < 0) then
00395     error = status
00396     return
00397   endif
00398     !overwrite scalar datasets
00399   call TD_WRITE_SCALAR_B(SCALAR_B_FILE_F, compression, .TRUE., status)
00400   if (status < 0) then
00401     error = status
00402     return
00403   endif
00404   
00405     ! vector datasets
00406   call TD_WRITE_VECTOR2D_B(VECTOR2D_B_FILE_F, compression, .FALSE., status)
00407   if (status < 0) then
00408     WRITE(*,*) 'Error writing dataset vector2D_B.'
00409     error = status
00410     return
00411   endif
00412     ! overwrite vector datasets
00413   call TD_WRITE_VECTOR2D_B(VECTOR2D_B_FILE_F, compression, .TRUE., status)
00414   if (status < 0) then
00415     WRITE(*,*) 'Error writing dataset vector2D_B.'
00416     error = status
00417     return
00418   endif
00419 
00420     ! Read the files back in
00421   call TXI_READ_X_FORMAT_FILE(SCALAR_B_FILE_F, SCALAR_B_TEXT_F, status)
00422   if (status < 0) then
00423     WRITE(*,*) 'Error reading SCALAR B File'
00424     error = status
00425     return
00426   endif
00427 
00428   call  TXI_READ_X_FORMAT_FILE(VECTOR2D_B_FILE_F, VECTOR2D_B_TEXT_F, status)
00429   if (status < 0) then
00430     WRITE(*,*) 'Error reading VECTOR B Format File'
00431     error = status
00432     return
00433   endif
00434 
00435   error = status
00436   return
00437 
00438 END SUBROUTINE
00439 
00440 !------------------------------------------------------------------------------
00441 ! FUNCTION TXI_TEST_GRIDS
00442 ! PURPOSE  Test to see if we can read and write grids
00443 ! NOTES
00444 !------------------------------------------------------------------------------
00445 SUBROUTINE TXI_TEST_GRIDS (error)
00446 INTEGER, INTENT(OUT) :: error
00447 INTEGER    compression
00448 
00449 compression = NONE
00450 
00451 WRITE(*,*) ''
00452 WRITE(*,*) ''
00453 WRITE(*,*) 'Writing grid data.'
00454 WRITE(*,*) ''
00455  
00456 call TG_WRITE_TEST_GRID_CART_2D(GRID_CART2D_A_FILE_F, error)
00457 if (error < 0) then
00458   WRITE(*,*) 'Error writing grid Cartesian 2D A'
00459 endif
00460 WRITE(*,*) 'Finished writing grid Cartesian 2D A'
00461 
00462 call TG_WRITE_TEST_GRID_CURV_2D(GRID_CURV2D_A_FILE_F, compression, error)
00463 if (error < 0) then
00464   WRITE(*,*) 'Error writing grid Curvilinear 2D A'
00465 endif
00466 WRITE(*,*) 'Finished writing grid Curvilinear 2D A'
00467 
00468 call TG_WRITE_TEST_GRID_CART_3D(GRID_CART3D_A_FILE_F, compression, error)
00469 if (error < 0) then
00470   WRITE(*,*) 'Error writing grid Cartesian 3D A'
00471 endif
00472 WRITE(*,*) 'Finished writing grid Cartesian 3D A'
00473   ! read the files back in
00474 call TXI_READ_X_FORMAT_FILE(GRID_CART2D_A_FILE_F, GRID_CART2D_A_OUT_F, error)
00475 if (error < 0) then
00476   WRITE(*,*) 'Error reading grid Cartesian 2D A'
00477 endif
00478 WRITE(*,*) 'Finished reading grid Cartesian 2D A'
00479 
00480 call TXI_READ_X_FORMAT_FILE(GRID_CURV2D_A_FILE_F, GRID_CURV2D_A_OUT_F, error)
00481 if (error < 0) then
00482   WRITE(*,*) 'Error reading grid Curvilinear 2D A'
00483 endif
00484 WRITE(*,*) 'Finished reading grid Curvilinear 2D A'
00485 
00486 call TXI_READ_X_FORMAT_FILE(GRID_CART3D_A_FILE_F, GRID_CART3D_A_OUT_F, error)
00487 if (error < 0) then
00488   WRITE(*,*) 'Error reading grid Cartesian 3D A'
00489 endif
00490 WRITE(*,*) 'Finished reading grid Cartesian 3D A'
00491  
00492 END SUBROUTINE
00493 
00494 !**************************
00495 ! ---------------------------------------------------------------------------
00496 ! FUNCTION  TXI_TEST_MESHS
00497 ! PURPOSE   test to see if we can read and write meshes
00498 ! NOTES     
00499 ! ---------------------------------------------------------------------------
00500 SUBROUTINE TXI_TEST_MESHS (error)
00501 INTEGER, INTENT(OUT) :: error
00502 INTEGER    status
00503 INTEGER    compression
00504 
00505 status = 1
00506 compression = NONE
00507 
00508 call TM_WRITE_TEST_MESH_A(MESH_A_FILE_F, compression, status)
00509 if (status < 0) then
00510   WRITE(*,*) 'Error writing TestMeshA'
00511   error = status
00512   return
00513 endif
00514 
00515 call TM_WRITE_TEST_MESH_B(MESH_B_FILE_F, compression, status)
00516 if (status < 0) then
00517   WRITE(*,*) 'Error writing TestMeshB'
00518   error = status
00519   return
00520 endif
00521 
00522 WRITE(*,*) 'Finished writing meshes.'
00523 
00524   ! read the files back in
00525 call TXI_READ_X_FORMAT_FILE(MESH_A_FILE_F, MESH_A_OUT_F, status)
00526 if (status < 0) then
00527   WRITE(*,*) 'Error reading TestMeshA'
00528   error = status
00529   return
00530 endif
00531 
00532   ! read the files back in
00533 call TXI_READ_X_FORMAT_FILE(MESH_B_FILE_F, MESH_B_OUT_F, status)
00534 if (status < 0) then
00535   WRITE(*,*) 'Error reading TestMeshB'
00536   error = status
00537   return
00538 endif
00539 
00540 WRITE(*,*) 'Finished reading meshes.'
00541 
00542 error = status
00543 return
00544 
00545 END SUBROUTINE
00546 
00547 !**************************
00548 
00549 !---------------------------------------------------------------------------
00550 ! FUNCTION  txiTestC
00551 ! PURPOSE   test to see if fortran code can read file written with C.
00552 ! NOTES     
00553 !---------------------------------------------------------------------------
00554 SUBROUTINE TXI_TEST_C (error)
00555 INTEGER, INTENT(OUT) :: error
00556 INTEGER            nStatus
00557 INTEGER     xFileId
00558 
00559 error = 1
00560 
00561   !Check to see if files written with C exist
00562   ! Turn off error handling
00563 !call H5Eset_auto_f(0, error)
00564   ! Try opening a file written with C to see if one exists.
00565 call XF_OPEN_FILE(SCALAR_A_FILE_C, .TRUE., xFileId, nStatus)
00566   ! If the file written with C doesn't exist, return.
00567 if (nStatus < 0) then
00568   call XF_CLOSE_FILE(xFileId, error)
00569     ! Restore previous error handler
00570   !call H5Eset_Auto_f(1, error)
00571   error = -1
00572   return
00573   ! If the file written with C does exist, assume all C files exist.
00574 else
00575   call XF_CLOSE_FILE(xFileId, error)
00576     ! Restore previous error handler
00577   !call H5Eset_Auto_f(1, error)
00578 endif
00579 
00580   ! Read the files back in
00581 call TXI_READ_X_FORMAT_FILE(SCALAR_A_FILE_C, SCALAR_A_TEXT_CF, error)
00582 if (error < 0) then
00583   return
00584 endif
00585 call TXI_READ_X_FORMAT_FILE(SCALAR_B_FILE_C, SCALAR_B_TEXT_CF, error)
00586 if (error < 0) then
00587   return
00588 endif
00589 
00590 call TXI_READ_X_FORMAT_FILE(VECTOR2D_A_FILE_C, VECTOR2D_A_TEXT_CF, error)
00591 if (error < 0) then
00592   return
00593 endif
00594 call TXI_READ_X_FORMAT_FILE(VECTOR2D_B_FILE_C, VECTOR2D_B_TEXT_CF, error)
00595 if (error < 0) then
00596   return
00597 endif
00598   
00599 WRITE(*,*) 'Done reading C datasets...'
00600 
00601 call TXI_READ_X_FORMAT_FILE(GRID_CART2D_A_FILE_C, GRID_CART2D_A_OUT_CF, error)
00602 if (error < 0) then
00603   WRITE(*,*) 'Error reading C grid Cartesian 2D A'
00604 endif
00605 WRITE(*,*) 'Finished reading C grid Cartesian 2D A'
00606 
00607 call TXI_READ_X_FORMAT_FILE(GRID_CURV2D_A_FILE_C, GRID_CURV2D_A_OUT_CF, error)
00608 if (error < 0) then
00609   WRITE(*,*) 'Error reading C grid Curvilinear 2D A'
00610 endif
00611 WRITE(*,*) 'Finished reading C grid Curvilinear 2D A'
00612 
00613 call TXI_READ_X_FORMAT_FILE(GRID_CART3D_A_FILE_C, GRID_CART3D_A_OUT_CF, error)
00614 if (error < 0) then
00615   WRITE(*,*) 'Error reading C grid Cartesian 3D A'
00616 endif
00617 WRITE(*,*) 'Finished reading C grid Cartesian 3D A'
00618 
00619   ! read the files back in
00620 call TXI_READ_X_FORMAT_FILE(MESH_A_FILE_C, MESH_A_OUT_CF, error)
00621 if (error < 0) then
00622   WRITE(*,*) 'Error reading C TestMeshA'
00623   return
00624 endif
00625 
00626   ! read the files back in
00627 call TXI_READ_X_FORMAT_FILE(MESH_B_FILE_C, MESH_B_OUT_CF, error)
00628 if (error < 0) then
00629   WRITE(*,*) 'Error reading C TestMeshB'
00630   return
00631 endif
00632 
00633 WRITE(*,*) 'Finished reading C meshes.'
00634   
00635 return
00636 
00637 END SUBROUTINE
00638 
00639 !**************************
00640 ! --------------------------------------------------------------------------
00641 ! FUNCTION txiReadXFormatFile
00642 ! PURPOSE  Read a file using XMDF and write information about the data
00643 !          contained in the file to a output file
00644 ! --------------------------------------------------------------------------
00645 SUBROUTINE TXI_READ_X_FORMAT_FILE (a_XmdfFile, a_OutFile, error)
00646 CHARACTER(LEN=*), INTENT(IN) :: a_XmdfFile
00647 CHARACTER(LEN=*), INTENT(IN) :: a_OutFile
00648 INTEGER, INTENT(OUT)  :: error
00649 CHARACTER(LEN=BIG_STRING_SIZE) :: IndividualPath
00650 CHARACTER,ALLOCATABLE :: Paths(:)
00651 INTEGER     xFileId, xGroupId
00652 INTEGER            nMeshGroups, nMaxPathLength, nGridGroups
00653 INTEGER            FileUnit, StartLoc, nStatus, i, j
00654 REAL               Version
00655 
00656 xFileId  = NONE
00657 xGroupId = NONE
00658 
00659   ! Open the XMDF file
00660 call XF_OPEN_FILE(a_XmdfFile, .TRUE., xFileId, nStatus)
00661 if (nStatus < 0) then
00662   call XF_CLOSE_FILE(xFileId, error)
00663   error = -1
00664   return
00665 endif
00666 
00667   ! open the status file
00668 FileUnit = 53
00669 OPEN(UNIT=FileUnit, FILE=a_OutFile, STATUS='REPLACE', ACTION='WRITE', &
00670      IOSTAT = error)
00671 if (FileUnit == 0) then
00672   call XF_CLOSE_FILE(xFileId, error)
00673   error = -1
00674   return
00675 endif
00676 
00677 WRITE(FileUnit,*) 'File ', a_XmdfFile, ' opened.'
00678 
00679   ! write the version number to the file
00680 call XF_GET_LIBRARY_VERSION_FILE(xFileId, Version, error)
00681 WRITE(FileUnit,*) 'XMDF Version: ', Version
00682 WRITE(FileUnit,*) ''
00683 
00684   ! Read Coordinate System Informatioin to the .txt file if contained in
00685   ! file, if not skip
00686 call TXI_TEST_COORD_SYSTEM(xFileId, FileUnit, nStatus)
00687 WRITE(FileUnit,*) ''
00688 
00689   ! read all datasets not beneath a mesh, grid, or cross-sections
00690 call TD_READ_DATASETS(xFileId,FileUnit, nStatus)
00691 if (nStatus < 0) then
00692   call XF_CLOSE_FILE(xFileId, error)
00693   error = -1
00694   return
00695 endif
00696 
00697   ! Get the number and paths of datasets in the file.
00698 call XF_GRP_PTHS_SZ_FOR_MESHES(xFileId, nMeshGroups, &
00699                                        nMaxPathLength, error)
00700 if (error >= 0 .AND. nMeshGroups > 0) then
00701   allocate (Paths(nMaxPathLength*nMeshGroups))
00702   call XF_GET_GROUP_PATHS_FOR_MESHES(xFileId, nMeshGroups, nMaxPathLength, &
00703                                      Paths, error)
00704 endif
00705 
00706 if (error < 0) then
00707   call XF_CLOSE_FILE(xFileId, error)
00708   error = -1
00709   return
00710 endif
00711 
00712   ! Report the number and paths to individual meshes in the file.
00713 WRITE(FileUnit,*) 'Number of meshes in file: ', nMeshGroups
00714 WRITE(FileUnit,*) 'Paths:'
00715 do i=1, nMeshGroups
00716   do j=1, nMaxPathLength-1
00717     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00718   enddo
00719   WRITE(FileUnit,*) IndividualPath(1:nMaxPathLength-1)
00720 enddo
00721 
00722 WRITE(FileUnit,*) ''
00723 
00724   ! Open each mesh group
00725 !if (nMeshGroups > 0) allocate(IndividualPath(nMaxPathLength + 1))
00726 
00727 do i=1, nMeshGroups
00728   ! copy the portion of the array where a single path is stored
00729   StartLoc = (i-1)*nMaxPathLength + 1
00730   IndividualPath = ''
00731   do j = 1, nMaxPathLength - 1
00732     IndividualPath(j:j) = Paths(StartLoc+j-1)
00733   enddo
00734      
00735   WRITE(FileUnit,*) 'Reading mesh in group: ', &
00736                      IndividualPath(1:nMaxPathLength-1)
00737   call XF_OPEN_GROUP(xFileId, IndividualPath(1:LEN_TRIM(IndividualPath)), &
00738             xGroupId, nStatus)
00739   if (nStatus >= 0) then
00740     call TM_READ_MESH(xGroupId, FileUnit, nStatus)
00741   endif
00742   if (nStatus < 0) then
00743     WRITE(*,*) 'Error reading mesh..'
00744   endif
00745 enddo
00746 
00747 if (allocated(Paths)) deallocate(Paths)
00748 !if (allocated(IndividualPath)) deallocate(IndividualPath)
00749 
00750   ! Grid stuff
00751 call XF_GRP_PTHS_SZ_FOR_GRIDS(xFileId, nGridGroups, &
00752                                        nMaxPathLength, nStatus)
00753 if (nStatus >= 0 .AND. nGridGroups > 0) then
00754   allocate (Paths(nMaxPathLength*nGridGroups))
00755   call XF_GET_GROUP_PATHS_FOR_GRIDS(xFileId, nGridGroups, &
00756                                     nMaxPathLength, Paths, nStatus)
00757 endif
00758 if (nStatus < 0) then
00759   call XF_CLOSE_FILE(xFileId, error)
00760   error = -1
00761   return
00762 endif
00763 
00764   ! Report the number and paths to individual meshes in the file.
00765 WRITE(FileUnit,*) 'Number of grids in file: ', nGridGroups
00766 WRITE(FileUnit,*) 'Paths:'
00767 do i=1, nGridGroups
00768   do j=1, nMaxPathLength-1
00769     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00770   enddo
00771   WRITE(FileUnit,*) IndividualPath(1:LEN_TRIM(IndividualPath))
00772 enddo
00773 
00774 WRITE(FileUnit,*) ''
00775 
00776 !if (nGridGroups > 0) allocate(IndividualPath(nMaxPathLength + 1))
00777 
00778   ! Open each grid group
00779 do i=1, nGridGroups
00780   do j = 1, nMaxPathLength - 1
00781     IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j)
00782   enddo
00783   WRITE(FileUnit,*) 'Reading grid in group: ', &
00784                      IndividualPath(1:LEN_TRIM(IndividualPath))
00785   call XF_OPEN_GROUP(xFileId, IndividualPath(1:LEN_TRIM(IndividualPath)), &
00786                      xGroupId, nStatus)
00787   if (nStatus >= 0) then
00788     call TG_READ_GRID(xGroupId, FileUnit, nStatus)
00789   endif
00790   if (nStatus < 0) then
00791      WRITE(FileUnit,*) 'Error reading grid..'
00792   endif
00793 enddo
00794 
00795 if (allocated(Paths)) deallocate(Paths)
00796 !if (allocated(IndividualPath)) deallocate(IndividualPath)
00797   
00798   ! TODO do grid, and cross-section stuff.
00799    
00800   ! close the files
00801 call XF_CLOSE_FILE(xFileId, error)
00802 CLOSE(FileUnit)
00803   
00804 return
00805 
00806 END SUBROUTINE
00807 
00808 !-----------------------------------------------------------------------------
00809 ! SUBROUTINE TXI_TestCalendar
00810 ! PURPOSE    Check the Calculations of Julian date from calendar date or  
00811 !            vice-versa.
00812 ! NOTES      era is #defined (use #defines): ERA_IS_BCE (BC), ERA_IS_CE (AD)
00813 !-----------------------------------------------------------------------------
00814 SUBROUTINE TXI_TEST_CALENDAR (error)
00815   INTEGER, INTENT(OUT) :: error
00816   INTEGER  era1, yr1, mo1, day1, hr1, min1, sec1
00817   INTEGER  era2, yr2, mo2, day2, hr2, min2, sec2
00818   INTEGER  era3, yr3, mo3, day3, hr3, min3, sec3, FileUnit
00819   INTEGER  era4, yr4, mo4, day4, hr4, min4, sec4, calendarworks
00820   DOUBLE PRECISION  julian1, julian2, julian3, julian4
00821 
00822   calendarworks = 0
00823   FileUnit = 53
00824   OPEN(UNIT=FileUnit, FILE=CALENDAR_OUT_F, STATUS='REPLACE', ACTION='WRITE', &
00825      IOSTAT = error)
00826 
00827   WRITE(FileUnit,*) 'Calendar conversion:'
00828 
00829   era1 = ERA_IS_BCE
00830   yr1  = 0
00831   mo1  = 0
00832   day1 = 0
00833   hr1  = 0
00834   min1 = 0
00835   sec1 = 0
00836   julian1 = 2655.5
00837   call XF_JULIAN_TO_CALENDAR(era1, yr1, mo1, day1, hr1, min1, sec1, julian1, error)
00838 
00839   era2 = ERA_IS_BCE
00840   yr2  = 4706
00841   mo2  = 4
00842   day2 = 10
00843   hr2  = 0
00844   min2 = 0
00845   sec2 = 0
00846   julian2 = 0.0
00847   call XF_CALENDAR_TO_JULIAN(era2, yr2, mo2, day2, hr2, min2, sec2, julian2, error)
00848 
00849   era3 = ERA_IS_CE
00850   yr3  = 2004
00851   mo3  = 6
00852   day3 = 3
00853   hr3  = 2
00854   min3 = 8
00855   sec3 = 32
00856   julian3 = 0.0
00857   call XF_CALENDAR_TO_JULIAN(era3, yr3, mo3, day3, hr3, min3, sec3, julian3, error)
00858 
00859   era4 = ERA_IS_BCE
00860   yr4  = 0
00861   mo4  = 0
00862   day4 = 0
00863   hr4  = 0
00864   min4 = 0
00865   sec4 = 0
00866   julian4 = 2453159.5892592594_double
00867   call XF_JULIAN_TO_CALENDAR(era4, yr4, mo4, day4, hr4, min4, sec4, julian4, error)
00868 
00869 WRITE(FileUnit,*) ''
00870 WRITE(FileUnit,*) 'Dates #1 & #2  were calculated with the same date:'
00871 WRITE(FileUnit,*) ''
00872 WRITE(FileUnit,*) era1, '/', yr1, '/', mo1, '/', day1
00873 WRITE(FileUnit,*) '', hr1, ':', min1, ':',sec1, '--- julian =',julian1
00874 WRITE(FileUnit,*) ''
00875 WRITE(FileUnit,*) era2, '/', yr2, '/', mo2, '/', day2
00876 WRITE(FileUnit,*) '', hr2, ':', min2, ':',sec2, '--- julian =',julian2
00877 WRITE(FileUnit,*) ''
00878 WRITE(FileUnit,*) 'Dates #3 & #4  were calculated with the same date:'
00879 WRITE(FileUnit,*) ''
00880 WRITE(FileUnit,*) era3, '/', yr3, '/', mo3, '/', day3
00881 WRITE(FileUnit,*) '', hr3, ':', min3, ':',sec3, '--- julian =',julian3
00882 WRITE(FileUnit,*) ''
00883 WRITE(FileUnit,*) era4, '/', yr4, '/', mo4, '/', day4
00884 WRITE(FileUnit,*) '', hr4, ':', min4, ':',sec4, '--- julian =',julian4
00885 
00886   if (era1==era2 .AND. era3==era4) then
00887     if (yr1==yr2 .AND. yr3==yr4) then
00888           if (mo1==mo2 .AND. mo3==mo4) then
00889             if (day1==day2 .AND. day3==day4) then
00890                   if (hr1==hr2 .AND. hr3==hr4) then
00891                     if (min1==min2 .AND. min3==min4) then
00892               if (julian1==julian2 .AND. (julian3-.0000001)<julian4 .AND. (julian3+.0000001)>julian4) then
00893           WRITE(*,*) ''
00894           WRITE(*,*) 'Calendar conversion works correctly.'
00895         calendarworks = 1
00896                       endif
00897             endif
00898           endif
00899         endif
00900       endif
00901     endif
00902   endif
00903   if (calendarworks .NE. 1) then
00904     WRITE(*,*) 'Calendar Stuff DOES NOT Work Correctly'
00905   error = -1
00906   else
00907     error = 1
00908   endif
00909   return
00910 
00911 END SUBROUTINE
00912 !------------------------------------------------------------------------------
00913 ! FUNCTION TXI_TEST_MULTI_DATASETS
00914 ! PURPOSE  To test the newly translated functions
00915 ! NOTES
00916 !------------------------------------------------------------------------------
00917 SUBROUTINE TXI_TEST_MULTI_DATASETS
00918 
00919 !call XF_SETUP_TO_WRITE_DATASETS(a_Filename, a_MultiDatasetsGroupPath, &
00920 !                        a_PathInMultiDatasetsGroup, a_SpatialDataObjectGuid, &
00921  !                       a_OverwriteOptions, a_FileId, a_GroupId, error)
00922 !XF_OPEN_MULTI_DATASETS_GROUP
00923 !XF_DELETE_GROUP
00924 
00925 END SUBROUTINE
00926 
00927 !------------------------------------------------------------------------------
00928 ! SUBROUTINE TXI_WRITE_XMDF_VERSION
00929 ! PURPOSE    Write the XMDF version number to the screen
00930 ! NOTES
00931 !------------------------------------------------------------------------------
00932 SUBROUTINE TXI_TEST_VERSION ()
00933 INTEGER  error
00934 REAL     Version
00935 
00936   WRITE(*,*) ''
00937   call XF_GET_LIBRARY_VERSION(Version, error)
00938   WRITE(*,*) 'The current version of XMDF is: ', Version
00939   WRITE(*,*) ''
00940 
00941   return
00942 
00943 END SUBROUTINE
00944 
00945 !------------------------------------------------------------------------------
00946 ! SUBROUTINE TXI_TEST_COORD_SYSTEM
00947 ! PURPOSE    Reads a file's Coordinate Group and prints coordinate data out
00948 !            to each text file.
00949 ! NOTES
00950 !------------------------------------------------------------------------------
00951 SUBROUTINE TXI_TEST_COORD_SYSTEM (xFileId, a_OutFile, error)
00952 INTEGER, INTENT(IN) :: xFileId
00953 INTEGER, INTENT(IN)        :: a_OutFile
00954 INTEGER, INTENT(OUT)       :: error
00955 INTEGER   iHorizDatum, iHorizUnits, iVertDatum, iVertUnits
00956 INTEGER   iLat, iLon, iUtmZone, iSpcZone, iHpgnArea, iEllipse
00957 INTEGER   bHorizDatum, nStatus
00958 REAL(DOUBLE)        dCppLat, dCppLon, dMajorR, dMinorR
00959 INTEGER      xCoordId
00960 CHARACTER(LEN=BIG_STRING_SIZE)    strHorizUnits, strVertDatum
00961 CHARACTER(LEN=BIG_STRING_SIZE)    strVertUnits
00962 
00963   ! Coordinate stuff
00964   ! Read Coordinate Info
00965     ! Open the Coordinate group
00966   !call H5Eset_auto_f(0, error)
00967   call XF_OPEN_COORDINATE_GROUP(xFileId, xCoordId, nStatus)
00968   if (nStatus < 0) then
00969     WRITE(a_OutFile,*) ''
00970     WRITE(a_OutFile,*) 'Coordinate Group not found'
00971     WRITE(a_OutFile,*) ''
00972     error = nStatus
00973     return
00974   endif
00975   !call H5Eset_auto_f(1, error)
00976 
00977   WRITE(a_OutFile,*) ''
00978   WRITE(a_OutFile,*) 'Coordinate System:'
00979 
00980   call XF_GET_HORIZ_DATUM(xCoordId, iHorizDatum, bHorizDatum)
00981   call XF_GET_HORIZ_UNITS(xCoordId, iHorizUnits, error)
00982   call XF_GET_VERT_DATUM(xCoordId, iVertDatum, error)
00983   call XF_GET_VERT_UNITS(xCoordId, iVertUnits, error)
00984 
00985     ! set horizontal units
00986   if (iHorizUnits == 0) then
00987     strHorizUnits = 'Horizontal units = US Survey Feet (=0)'
00988   else if (iHorizUnits == 1) then
00989     strHorizUnits = 'Horizontal units = International Feet (=1)'
00990   else if (iHorizUnits == 2) then
00991     strHorizUnits = 'Horizontal units = Meters (=2)'
00992   else
00993     strHorizUnits = 'ERROR in reading Horizontal units'
00994   endif
00995 
00996     ! set vertical datum
00997   if (iVertDatum == 0) then
00998     strVertDatum = 'Vertical datum = Local (=0)'
00999   else if (iVertDatum == 1) then
01000     strVertDatum = 'Vertical datum = NGVD 29 (=1)'
01001   else if (iVertDatum == 2) then
01002     strVertDatum = 'Vertical datum = NGVD 88 (=2)'
01003   else
01004     strVertDatum = 'ERROR in reading the Vertical datum'
01005   endif
01006 
01007     ! set vertocal units
01008   if (iVertUnits == 0) then
01009     strVertUnits = 'Vertical units = US Survey Feet (=0)'
01010   else if (iVertUnits == 1) then
01011     strVertUnits = 'Vertical units = International Feet (=1)'
01012   else if (iVertUnits == 2) then
01013     strVertUnits = 'Vertical units = Meters (=2)'
01014   else
01015     strVertUnits = 'ERROR in reading the Vertical units'
01016   endif
01017 
01018   if (bHorizDatum >= 0) then
01019     SELECT CASE (iHorizDatum)
01020       CASE (HORIZ_DATUM_GEOGRAPHIC)
01021         call XF_GET_ELLIPSE(xCoordId, iEllipse, error)
01022         call XF_GET_LAT(xCoordId, iLat, error)
01023         call XF_GET_LON(xCoordId, iLon, error)
01024           ! Write Horizontal and Vertical Info
01025         WRITE(a_OutFile,*) 'Horizontal datum = Geographic'
01026         WRITE(a_OutFile,*) 'Horizontal units = ', strHorizUnits(1:LEN_TRIM(strHorizUnits))
01027         WRITE(a_OutFile,*) 'Vertical datum = ', strVertDatum(1:LEN_TRIM(strVertDatum))
01028         WRITE(a_OutFile,*) 'Vertical units = ', strVertUnits(1:LEN_TRIM(strVertUnits))
01029           ! Write Latitude data
01030         if (iLat == 0) then
01031           WRITE(a_OutFile,*) '  Latitude = North (=0)'
01032         else if (iLat == 1) then
01033           WRITE(a_OutFile,*) '  Latitude = South (=1)'
01034         else
01035           WRITE(a_OutFile,*) '  LATITUDE INFO INCORRECT'
01036         endif
01037           ! Write Longitude data
01038         if (iLon == 0) then
01039           WRITE(a_OutFile,*) '  Longitude = East (=0)'
01040         else if (iLon == 1) then
01041           WRITE(a_OutFile,*) '  Longitude = West (=1)'
01042         else
01043           WRITE(a_OutFile,*) '  LONGITUDE INFO INCORRECT'
01044         endif
01045           ! Ellipse Information
01046           ! User-defined Ellipse (==32)
01047         if (iEllipse == 32) then
01048           WRITE(a_OutFile,*) 'Ellipse = User-defined:'
01049           call XF_GET_MAJOR_R(xCoordId, dMajorR, error)
01050           call XF_GET_MINOR_R(xCoordId, dMinorR, error)
01051           WRITE(a_OutFile,*) '  MajorR = ', dMajorR
01052           WRITE(a_OutFile,*) '  MinorR = ', dMinorR
01053         else
01054           WRITE(a_OutFile,*) 'Ellipse = ', iEllipse
01055         endif
01056         WRITE(a_OutFile,*) ''
01057       CASE (HORIZ_DATUM_UTM)
01058         call XF_GET_UTM_ZONE(xCoordId, iUtmZone, error)
01059           ! output info to text file
01060         if (iHorizDatum == HORIZ_DATUM_UTM) then
01061           WRITE(a_OutFile,*) 'Horizontal datum = UTM'
01062         else if (iHorizDatum == HORIZ_DATUM_UTM_NAD27) then
01063           WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD27 (US)'
01064         else
01065           WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD83 (US)'
01066         endif
01067         WRITE(a_OutFile,*) 'Horizontal units = ', &
01068                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01069         WRITE(a_OutFile,*) 'Vertical datum = ', &
01070                         strVertDatum(1:LEN_TRIM(strVertDatum))
01071         WRITE(a_OutFile,*) 'Vertical units = ', &
01072                         strVertUnits(1:LEN_TRIM(strVertUnits))
01073         WRITE(a_OutFile,*) 'UTM Zone = ', iUtmZone
01074         WRITE(a_OutFile,*) ''
01075 
01076       CASE (HORIZ_DATUM_UTM_NAD27, HORIZ_DATUM_UTM_NAD83)
01077         call XF_GET_UTM_ZONE(xCoordId, iUtmZone, error)
01078           ! output info to text file
01079         if (iHorizDatum == HORIZ_DATUM_UTM) then
01080           WRITE(a_OutFile,*) 'Horizontal datum = UTM'
01081         else if (iHorizDatum == HORIZ_DATUM_UTM_NAD27) then
01082           WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD27 (US)'
01083         else
01084           WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD83 (US)'
01085         endif
01086         WRITE(a_OutFile,*) 'Horizontal units = ', &
01087                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01088         WRITE(a_OutFile,*) 'Vertical datum = ', &
01089                         strVertDatum(1:LEN_TRIM(strVertDatum))
01090         WRITE(a_OutFile,*) 'Vertical units = ', &
01091                         strVertUnits(1:LEN_TRIM(strVertUnits))
01092         WRITE(a_OutFile,*) 'UTM Zone = ', iUtmZone
01093         WRITE(a_OutFile,*) ''
01094       CASE (HORIZ_DATUM_STATE_PLANE_NAD27, HORIZ_DATUM_STATE_PLANE_NAD83)
01095         call XF_GET_SPC_ZONE(xCoordId, iSpcZone, error)
01096           ! output info to text file
01097         if (iHorizDatum == HORIZ_DATUM_STATE_PLANE_NAD27) then
01098           WRITE(a_OutFile,*) 'Horizontal datum = State Plane NAD27 (US)'
01099         else 
01100           WRITE(a_OutFile,*) 'Horizontal datum = State Plane NAD83 (US)'
01101         endif
01102         WRITE(a_OutFile,*) 'Horizontal units = ', &
01103                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01104         WRITE(a_OutFile,*) 'Vertical datum = ', &
01105                         strVertDatum(1:LEN_TRIM(strVertDatum))
01106         WRITE(a_OutFile,*) 'Vertical units = ', &
01107                         strVertUnits(1:LEN_TRIM(strVertUnits))
01108         WRITE(a_OutFile,*) 'SPC Zone = ', iSpcZone
01109         WRITE(a_OutFile,*) ''
01110       CASE (HORIZ_DATUM_UTM_HPGN, HORIZ_DATUM_STATE_PLANE_HPGN, &
01111                                   HORIZ_DATUM_GEOGRAPHIC_HPGN)
01112         call XF_GET_HPGN_AREA(xCoordId, iHpgnArea, error)
01113         if (iHorizDatum == HORIZ_DATUM_UTM_HPGN) then
01114           WRITE(a_OutFile,*) 'Horizontal datum = UTM HPGN (US)'
01115         else if (iHorizDatum == HORIZ_DATUM_STATE_PLANE_HPGN) then
01116           WRITE(a_OutFile,*) 'Horizontal datum = State Plane HPGN (US)'
01117         else
01118           WRITE(a_OutFile,*) 'Horizontal datum = Geographic HPGN (US)'
01119         endif
01120         WRITE(a_OutFile,*) 'Horizontal units = ', &
01121                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01122         WRITE(a_OutFile,*) 'Vertical datum = ', &
01123                         strVertDatum(1:LEN_TRIM(strVertDatum))
01124         WRITE(a_OutFile,*) 'Vertical units = ', &
01125                         strVertUnits(1:LEN_TRIM(strVertUnits))
01126         WRITE(a_OutFile,*) 'HPGN Area = ', iHpgnArea
01127         WRITE(a_OutFile,*) ''
01128       CASE (HORIZ_DATUM_CPP)
01129         call XF_GET_CPP_LAT(xCoordId, dCppLat, error)
01130         call XF_GET_CPP_LON(xCoordId, dCppLon, error)
01131         WRITE(a_OutFile,*) 'Horizontal datum = CPP (Carte Parallelo-Grammatique Projection)'
01132         WRITE(a_OutFile,*) 'Horizontal units = ', &
01133                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01134         WRITE(a_OutFile,*) 'Vertical datum = ', &
01135                         strVertDatum(1:LEN_TRIM(strVertDatum))
01136         WRITE(a_OutFile,*) 'Vertical units = ', &
01137                         strVertUnits(1:LEN_TRIM(strVertUnits))
01138         WRITE(a_OutFile,*) 'CPP Latitude = ', dCppLat
01139         WRITE(a_OutFile,*) 'CPP Longitude = ', dCppLon
01140         WRITE(a_OutFile,*) ''
01141     CASE (HORIZ_DATUM_LOCAL, HORIZ_DATUM_GEOGRAPHIC_NAD27, &
01142           HORIZ_DATUM_GEOGRAPHIC_NAD83)
01143           ! do other systems
01144         if (iHorizDatum == HORIZ_DATUM_LOCAL) then
01145           WRITE(a_OutFile,*) 'Horizontal datum = Local'
01146         else if (iHorizDatum == HORIZ_DATUM_GEOGRAPHIC_NAD27) then
01147           WRITE(a_OutFile,*) 'Horizontal datum = Geographic NAD27 (US)'
01148         else
01149           WRITE(a_OutFile,*) 'Horizontal datum = Geographic NAD83 (US)'
01150     endif
01151         WRITE(a_OutFile,*) 'Horizontal units = ', &
01152                         strHorizUnits(1:LEN_TRIM(strHorizUnits))
01153         WRITE(a_OutFile,*) 'Vertical datum = ', &
01154                         strVertDatum(1:LEN_TRIM(strVertDatum))
01155         WRITE(a_OutFile,*) 'Vertical units = ', &
01156                         strVertUnits(1:LEN_TRIM(strVertUnits))
01157         WRITE(a_OutFile,*) ''
01158       CASE DEFAULT
01159           WRITE(a_OutFile,*) 'ERROR: The coordinate information is not found in the .h5 file'
01160           error = -1
01161       return
01162     END SELECT
01163   else
01164     WRITE(a_OutFile,*) 'Coordinate information in HDF5 file is incomplete.'
01165     WRITE(a_OutFile,*) ''
01166   endif
01167 
01168   call XF_CLOSE_GROUP(xCoordId, error)
01169   xCoordId = 0
01170 
01171   return
01172 
01173 END SUBROUTINE
01174 
01175 SUBROUTINE TXI_TEST_GEOMETRIC_PATHS(error)
01176   INTEGER, INTENT(OUT) :: error
01177   INTEGER                 compression
01178 
01179   compression = -1
01180 
01181     ! test writing a geometric path file */
01182   WRITE(*,*)''
01183   WRITE(*,*)'Writing geometric path data'
01184   WRITE(*,*)''
01185  
01186   call TM_WRITE_TEST_PATHS(GEOMPATH_A_FILE_F, compression, error);
01187   if (error < 0) then
01188     WRITE(*,*) 'Error writing geometric path data A'
01189     return
01190   endif
01191   WRITE(*,*) 'Finished writing geometric path data A'
01192 
01193     ! test reading a geometric path file */
01194   call TM_READ_TEST_PATHS(GEOMPATH_A_FILE_F, GEOMPATH_A_FILE_F_OUT, error)
01195 
01196   return
01197 
01198 END SUBROUTINE TXI_TEST_GEOMETRIC_PATHS
01199 
01200 !****************************
01201 
01202 END MODULE TestsModule
01203 
01204 PROGRAM TESTS
01205 
01206 USE TestDatasets
01207 USE Xmdf
01208 USE TestMesh
01209 USE TestDefs
01210 USE TestsModule
01211 
01212 INTEGER    error
01213 ! Assign pp to force crash on error
01214 
01215 call XF_INITIALIZE(error)
01216 
01217   ! test the dataset routines
01218 call TXI_TEST_TIMESTEPS(error)
01219 if (error < 0) then
01220   WRITE(*,*) 'Error in writing timesteps!'
01221   PAUSE 'Press ENTER to exit...'
01222 endif
01223 
01224   ! test the dataset routines
01225 call TXI_TEST_DATASETS(error)
01226 if (error < 0) then
01227   WRITE(*,*) 'Error in writing datasets!'
01228   PAUSE 'Press ENTER to exit...'
01229 endif
01230 
01231   ! test overwriting datasets
01232 call TXI_TEST_OVERWRITE_DSETS(error)
01233 if (error < 0) then
01234   WRITE(*,*) 'Error in overwriting datasets!'
01235   PAUSE 'Press ENTER to exit...'
01236 else
01237   WRITE(*,*) 'Finished writing datasets...'
01238 endif
01239 
01240   ! test mesh stuff
01241 call TXI_TEST_MESHS(error)
01242 if (error < 0) then
01243   WRITE(*,*) 'Error in TXI_TEST_MESHS!'
01244   PAUSE 'Press ENTER to exit...'
01245 endif
01246 
01247   ! test grid stuff
01248 call TXI_TEST_GRIDS(error)
01249 if (error < 0) then
01250   WRITE(*,*) 'Error in TXI_TEST_GRIDS!'
01251   PAUSE 'Press ENTER to exit...'
01252 endif
01253 
01254   ! test c in fortran
01255 call TXI_TEST_C(error)
01256 ! Ignore error because fortran will be run once again with file there
01257 
01258   ! test calendar stuff
01259 call TXI_TEST_CALENDAR(error)
01260 if (error < 0) then
01261   WRITE(*,*) 'Error in TXI_TEST_CALENDAR!'
01262   PAUSE 'Press ENTER to exit...'
01263 endif
01264 
01265   ! test version
01266 call TXI_TEST_VERSION
01267 
01268    ! test geometric paths
01269 call TXI_TEST_GEOMETRIC_PATHS(error)
01270 if (error < 0) then
01271   WRITE(*,*) 'Error in TXI_TEST_GEOMETRIC_PATHS!'
01272   PAUSE 'Press ENTER to exit...'
01273 endif
01274 
01275 call XF_CLOSE (error)
01276 if (error < 0) then
01277   WRITE(*,*) 'Error in XF_CLOSE!'
01278   PAUSE 'Press ENTER to exit...'
01279 endif
01280 
01281 ! PAUSE 'Press ENTER to exit...'
01282 
01283 END PROGRAM

Generated on Fri Jul 27 11:33:14 2012 for XMDF by  doxygen 1.5.6