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