00001 MODULE TestDatasets 00002 00003 USE Xmdf 00004 00005 CHARACTER(LEN=*), PARAMETER :: DATASETS_LOCATION = 'Datasets' 00006 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_LOCATION = 'Scalars/ScalarA' 00007 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_LOCATION_FULL = 'Datasets/Scalars/ScalarA' 00008 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_LOCATION = 'Scalars/ScalarB' 00009 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_LOCATION = 'Vectors/Vector2D_A' 00010 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_LOCATION = 'Vectors/Vector2D_B' 00011 00012 CONTAINS 00013 ! --------------------------------------------------------------------------- 00014 ! FUNCTION tdEditScalarAValues 00015 ! PURPOSE 00016 ! NOTES 00017 ! --------------------------------------------------------------------------- 00018 SUBROUTINE TD_EDIT_SCALAR_A_VALUES(a_Filename, a_Compression, error) 00019 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00020 INTEGER, INTENT(IN) :: a_Compression 00021 INTEGER, INTENT(OUT) :: error 00022 INTEGER xFileId, xScalarId 00023 INTEGER, PARAMETER :: editNumValues = 3 00024 INTEGER editTimestep 00025 INTEGER, DIMENSION(editNumValues) :: indices 00026 REAL, DIMENSION(editNumValues) :: new_values 00027 00028 CALL TD_WRITE_SCALAR_A(a_Filename, a_Compression, error) 00029 if (error < 0) then 00030 return 00031 endif 00032 00033 ! open the file and edit the values 00034 CALL XF_OPEN_FILE(a_Filename, .FALSE., xFileId, error) 00035 if (error < 0) then 00036 return 00037 endif 00038 00039 CALL XF_OPEN_GROUP(xFileId, SCALAR_A_LOCATION_FULL, xScalarId, error); 00040 if (error < 0) then 00041 CALL XF_CLOSE_FILE(xFileId, error) 00042 return 00043 endif 00044 00045 ! Edit values in timestep 1, make index 1 = 4, index 5 = 40, 00046 ! and index 10 = 400 00047 editTimestep = 1 00048 indices(1) = 1; 00049 indices(2) = 5; 00050 indices(3) = 10; 00051 new_values(1) = 4.0; 00052 new_values(2) = 40.0; 00053 new_values(3) = 400.0; 00054 00055 CALL XF_CHANGE_SCALAR_VALUES_TIMESTEP_FLOAT(xScalarId, editTimestep, editNumValues, & 00056 indices, new_values, error) 00057 if (error < 0) then 00058 CALL XF_CLOSE_GROUP(xScalarId, error) 00059 CALL XF_CLOSE_FILE(xFileId, error) 00060 return 00061 endif 00062 00063 ! RDJ - Technically we shouldn't have to close and reopen a file that we are 00064 ! editing but it seems to fix a crash that the tests are having. 00065 ! CALL XF_CLOSE_GROUP(xScalarId, error) 00066 ! CALL XF_CLOSE_FILE(xFileId, error) 00067 ! ! open the file and edit the values 00068 ! CALL XF_OPEN_FILE(a_Filename, .FALSE., xFileId, error) 00069 ! if (error < 0) then 00070 ! return 00071 ! endif 00072 ! 00073 ! CALL XF_OPEN_GROUP(xFileId, SCALAR_A_LOCATION_FULL, xScalarId, error); 00074 ! if (error < 0) then 00075 ! CALL XF_CLOSE_FILE(xFileId, error) 00076 ! return 00077 ! endif 00078 00079 ! Edit values in timestep 2, make index 2 = 6, index 3 = 60, and 00080 ! index 9 = 600 00081 editTimestep = 2 00082 indices(1) = 2 00083 indices(2) = 3 00084 indices(3) = 9 00085 new_values(1) = -6.0 00086 new_values(2) = 60.0 00087 new_values(3) = 6000.0 00088 00089 CALL XF_CHANGE_SCALAR_VALUES_TIMESTEP_FLOAT(xScalarId, editTimestep, editNumValues, & 00090 indices, new_values, error) 00091 if (error < 0) then 00092 CALL XF_CLOSE_GROUP(xScalarId, error) 00093 CALL XF_CLOSE_FILE(xFileId, error) 00094 return 00095 endif 00096 00097 CALL XF_CLOSE_GROUP(xScalarId, error) 00098 CALL XF_CLOSE_FILE(xFileId, error) 00099 00100 return 00101 END SUBROUTINE 00102 ! tdEditScalarAValues 00103 00104 ! --------------------------------------------------------------------------- 00105 ! FUNCTION tdReadScalarAIndices 00106 ! PURPOSE 00107 ! NOTES 00108 ! --------------------------------------------------------------------------- 00109 SUBROUTINE TD_READ_SCALAR_A_INDICES (a_Filename, a_nIndices, a_indices, error) 00110 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00111 INTEGER, INTENT(IN) :: a_nIndices 00112 INTEGER, DIMENSION(*), INTENT(IN) :: a_indices 00113 INTEGER, INTENT(OUT) :: error 00114 INTEGER xFileId, xDsetsId, xScalarAId 00115 INTEGER nTimesteps 00116 REAL, ALLOCATABLE, DIMENSION(:) :: fValues 00117 INTEGER nValues 00118 INTEGER id, i, j 00119 00120 ! open the file 00121 CALL XF_OPEN_FILE(a_Filename, .TRUE., xFileId, error) 00122 if (error < 0) then 00123 return 00124 endif 00125 00126 ! open the dataset group 00127 CALL XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, error) 00128 if (error >= 0) then 00129 CALL XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, error) 00130 endif 00131 if (error < 0) then 00132 return 00133 endif 00134 00135 ! Find out the number of timesteps in the file 00136 CALL XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, error) 00137 if (error < 0) then 00138 return 00139 endif 00140 if (nTimesteps < 1) then 00141 error = -1 00142 return 00143 endif 00144 00145 ! Read the values for the index 00146 nValues = nTimesteps*a_nIndices 00147 allocate(fValues(nValues)) 00148 CALL XF_READ_SCALAR_VALUES_AT_INDICES_FLOAT(xScalarAId, a_nIndices, a_indices, 1, & 00149 nTimesteps, fValues, error) 00150 if (error < 0) then 00151 return 00152 endif 00153 00154 ! output the data 00155 WRITE(*,*) '' 00156 WRITE(*,*) 'Reading scalar A indices' 00157 id = 1; 00158 do i = 1, nTimesteps 00159 WRITE(*,*) 'Timestep: ', i 00160 do j = 1, a_nIndices 00161 WRITE(*,*) 'index:', a_indices(j), ' value: ', fValues(id) 00162 id = id + 1 00163 enddo 00164 enddo 00165 WRITE(*,*) '' 00166 00167 deallocate(fValues) 00168 00169 return 00170 00171 END SUBROUTINE 00172 ! TD_READ_SCALARA_INDICES 00173 00174 ! -------------------------------------------------------------------------- 00175 ! FUNCTION tdReadDatasets 00176 ! PURPOSE Read a dataset group from an XMDF file and output information to 00177 ! to a text file 00178 ! NOTES 00179 ! -------------------------------------------------------------------------- 00180 RECURSIVE SUBROUTINE TD_READ_DATASETS (a_xGroupId, a_FileUnit, error) 00181 INTEGER, INTENT(IN) :: a_xGroupId 00182 INTEGER, INTENT(IN) :: a_FileUnit 00183 INTEGER, INTENT(OUT) :: error 00184 INTEGER nPaths, nMaxPathLength, j 00185 CHARACTER, ALLOCATABLE, DIMENSION(:) :: Paths 00186 CHARACTER(LEN=500) IndividualPath 00187 INTEGER nStatus, i 00188 INTEGER xScalarId, xVectorId, xMultiId 00189 INTEGER nMultiDatasets 00190 00191 xScalarId = NONE 00192 xVectorId = NONE 00193 00194 nMultiDatasets = 0 00195 nPaths = 0 00196 nMaxPathLength = 0 00197 00198 ! Look for scalar datasets 00199 call XF_GET_SCALAR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus) 00200 if (nStatus >= 0 .AND. nPaths > 0) then 00201 allocate(Paths(nPaths*nMaxPathLength)) 00202 call XF_GET_SCALAR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, & 00203 error) 00204 endif 00205 if (nStatus < 0) then 00206 error = -1 00207 return 00208 endif 00209 00210 ! Output number and paths to scalar datasets 00211 WRITE(a_FileUnit,*) 'Number of Scalars ', nPaths 00212 do i=2, nPaths 00213 IndividualPath = '' 00214 do j=1, nMaxPathLength-1 00215 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00216 enddo 00217 WRITE(a_FileUnit,*) 'Reading scalar: ', IndividualPath(1:nMaxPathLength-1) 00218 call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), & 00219 xScalarId, nStatus) 00220 if (nStatus < 0) then 00221 error = -1 00222 return 00223 endif 00224 00225 call TDI_READ_SCALAR(xScalarId, a_FileUnit, nStatus) 00226 call XF_CLOSE_GROUP(xScalarId, error) 00227 if (nStatus < 0) then 00228 WRITE(*,*) 'Error reading scalar dataset.' 00229 error = -1 00230 return 00231 endif 00232 enddo 00233 00234 if (allocated(Paths)) deallocate(Paths) 00235 ! Look for vector datasets 00236 call XF_GET_VECTOR_DATASETS_INFO(a_xGroupId, nPaths, nMaxPathLength, nStatus) 00237 if (nStatus >= 0 .AND. nPaths > 0) then 00238 allocate(Paths(nPaths*nMaxPathLength)) 00239 call XF_GET_VECTOR_DATASET_PATHS(a_xGroupId, nPaths, nMaxPathLength, Paths, error) 00240 endif 00241 if (nStatus < 0) then 00242 error = -1 00243 return 00244 endif 00245 00246 ! Output number and paths to scalar datasets 00247 WRITE(a_FileUnit,*) 'Number of Vectors ', nPaths 00248 do i=2, nPaths 00249 do j=1, nMaxPathLength-1 00250 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00251 enddo 00252 WRITE(a_FileUnit,*) 'Reading Vector: ', & 00253 IndividualPath(1:nMaxPathLength-1) 00254 call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), & 00255 xVectorId, nStatus) 00256 if (nStatus < 0) then 00257 error = -1 00258 return 00259 endif 00260 call TDI_READ_VECTOR(xVectorId, a_FileUnit, nStatus) 00261 call XF_CLOSE_GROUP(xVectorId, error) 00262 if (nStatus < 0) then 00263 WRITE(*,*) 'Error reading vector dataset.' 00264 error = -1 00265 return 00266 endif 00267 enddo 00268 00269 if (allocated(Paths)) deallocate(Paths) 00270 00271 ! find multidataset folders 00272 call XF_GET_GRP_PTHS_SZ_MLT_DSETS(a_xGroupId, nMultiDatasets, & 00273 nMaxPathLength, nStatus) 00274 if (nStatus >= 0 .AND. nMultiDatasets > 0) then 00275 allocate(Paths(nMultiDatasets*nMaxPathLength)) 00276 call XF_GET_ALL_GRP_PATHS_MLT_DSETS(a_xGroupId, nMultiDatasets, & 00277 nMaxPathLength, Paths, error) 00278 if (nStatus < 0) then 00279 error = -1 00280 return 00281 endif 00282 00283 ! Output number and paths to multidatasets 00284 WRITE(a_FileUnit,*) 'Number of Multidatasets ', nMultiDatasets 00285 do i=2, nMultiDatasets 00286 IndividualPath = '' 00287 do j=1, nMaxPathLength-1 00288 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00289 enddo 00290 WRITE(a_FileUnit,*) 'Reading multidataset: ', & 00291 IndividualPath(1:nMaxPathLength-1) 00292 call XF_OPEN_GROUP(a_xGroupId, IndividualPath(1:nMaxPathLength-1), & 00293 xMultiId, nStatus) 00294 if (nStatus < 0) then 00295 error = -1 00296 return 00297 endif 00298 00299 call TD_READ_DATASETS(xMultiId, a_FileUnit, nStatus) 00300 call XF_CLOSE_GROUP(xMultiId, error) 00301 if (nStatus < 0) then 00302 WRITE(*,*) 'Error reading multidatasets.' 00303 error = -1 00304 return 00305 endif 00306 enddo 00307 endif 00308 if (allocated(Paths)) deallocate(Paths) 00309 00310 error = 1 00311 return 00312 00313 END SUBROUTINE 00314 !tdReadDatasets 00315 ! -------------------------------------------------------------------------- 00316 ! FUNCTION tdReadActivityScalarAIndex 00317 ! PURPOSE Read all timestep values for a particular index 00318 ! NOTES 00319 ! -------------------------------------------------------------------------- 00320 SUBROUTINE TD_READ_ACTIVITY_SCALAR_A_INDEX(a_Filename, a_Index, error) 00321 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00322 INTEGER, INTENT(IN) :: a_Index 00323 INTEGER, INTENT(OUT) :: error 00324 INTEGER status 00325 INTEGER xFileId, xDsetsId, xScalarAId 00326 INTEGER nTimesteps, i 00327 INTEGER, ALLOCATABLE :: bActive(:) 00328 00329 xFileId = NONE 00330 xDsetsId = NONE 00331 xScalarAId = NONE 00332 00333 ! open the file 00334 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status) 00335 if (status < 0) then 00336 error = -1 00337 return 00338 endif 00339 00340 ! open the dataset group 00341 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00342 if (status >= 0) then 00343 call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status) 00344 endif 00345 if (status < 0) then 00346 error = status 00347 return 00348 endif 00349 00350 ! Find out the number of timesteps in the file 00351 CALL XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status) 00352 if (status < 0) then 00353 error = status 00354 return 00355 endif 00356 00357 if (nTimesteps < 1) then 00358 error = -1 00359 return 00360 endif 00361 00362 ! Read the values for the index 00363 allocate(bActive(nTimesteps)) 00364 call XF_READ_ACTIVE_VALS_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, & 00365 bActive, status) 00366 ! output the data 00367 WRITE(*,*) '' 00368 WRITE(*,*) 'Reading activity for scalar A slice at index: ', a_Index 00369 do i=1, nTimesteps 00370 WRITE(*,*) bActive(i), ' ' 00371 enddo 00372 00373 deallocate(bActive) 00374 00375 error = status 00376 return 00377 00378 END SUBROUTINE 00379 ! tdReadActivityScalarAIndex 00380 00381 ! -------------------------------------------------------------------------- 00382 ! FUNCTION tdReadScalarAIndex 00383 ! PURPOSE Read all timestep values for a particular index 00384 ! NOTES 00385 ! -------------------------------------------------------------------------- 00386 SUBROUTINE TD_READ_SCALAR_A_INDEX (a_Filename, a_Index, error) 00387 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00388 INTEGER, INTENT(IN) :: a_Index 00389 INTEGER, INTENT(OUT) :: error 00390 INTEGER status 00391 INTEGER xFileId, xDsetsId, xScalarAId 00392 INTEGER nTimesteps, i 00393 REAL, ALLOCATABLE :: fValues(:) 00394 00395 xFileId = NONE 00396 xDsetsId = NONE 00397 xScalarAId = NONE 00398 00399 ! open the file 00400 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status) 00401 if (status < 0) then 00402 error = -1 00403 return 00404 endif 00405 00406 ! open the dataset group 00407 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00408 if (status >= 0) then 00409 call XF_OPEN_GROUP(xDsetsId, SCALAR_A_LOCATION, xScalarAId, status) 00410 endif 00411 if (status < 0) then 00412 error = status 00413 return 00414 endif 00415 00416 ! Find out the number of timesteps in the file 00417 call XF_GET_DATASET_NUM_TIMES(xScalarAId, nTimesteps, status) 00418 if (status < 0) then 00419 error = status 00420 return 00421 endif 00422 00423 if (nTimesteps < 1) then 00424 error = -1 00425 return 00426 endif 00427 00428 ! Read the values for the index 00429 allocate (fValues(nTimesteps)) 00430 call XF_READ_SCALAR_VALUES_AT_INDEX(xScalarAId, a_Index, 1, nTimesteps, & 00431 fValues, status) 00432 00433 ! output the data 00434 WRITE(*,*) '' 00435 WRITE(*,*) 'Reading scalar A slice at index: ', a_Index 00436 do i=1, nTimesteps 00437 WRITE(*,*) fValues(i), ' ' 00438 enddo 00439 00440 deallocate(fValues) 00441 00442 error = status 00443 return 00444 00445 END SUBROUTINE 00446 ! tdReadScalarAtIndex 00447 00448 ! -------------------------------------------------------------------------- 00449 ! FUNCTION tdWriteScalarA 00450 ! PURPOSE Write scalar Dataset to an HDF5 File 00451 ! NOTES This tests dynamic data sets, and activity 00452 ! This dataset is dynamic concentrations (mg/L) with output times 00453 ! in minutes. 00454 ! Dataset is for a mesh and so nActive is the number of elements 00455 ! which is not the same as the nValues which would be number of nodes 00456 ! reads/writes a reference time in julian days 00457 ! -------------------------------------------------------------------------- 00458 SUBROUTINE TD_WRITE_SCALAR_A (a_Filename, a_Compression, error) 00459 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00460 INTEGER, INTENT(IN) :: a_Compression 00461 INTEGER, INTENT(OUT) :: error 00462 INTEGER xFileId, xDsetsId, xScalarAId, xCoordId 00463 INTEGER nValues, nTimes, nActive 00464 REAL(DOUBLE) dTime, dJulianReftime 00465 INTEGER iTimestep, iActive, iHpgnZone 00466 REAL fValues(10) ! nValues 00467 INTEGER*1 bActivity(10) ! activity 00468 INTEGER i, status 00469 00470 ! initialize the data 00471 nValues = 10 00472 nTimes = 3 00473 nActive = 8 00474 dTime = 0.0 00475 00476 ! 5th item in data set is always inactive, others active 00477 do iActive = 1, nActive 00478 bActivity(iActive) = 1 00479 enddo 00480 bActivity(6) = 0 00481 00482 00483 ! create the file 00484 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 00485 if (error .LT. 0) then 00486 ! close the file 00487 call XF_CLOSE_FILE(xFileId, error) 00488 return 00489 endif 00490 00491 ! create the group where we will put all the datasets 00492 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00493 if (status < 0) then 00494 call XF_CLOSE_FILE(xFileId, error) 00495 error = -1 00496 return 00497 endif 00498 00499 ! Create the scalar A dataset group 00500 call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', & 00501 TS_HOURS, a_Compression, xScalarAId, status) 00502 if (status .LT. 0) then 00503 ! close the dataset 00504 call XF_CLOSE_GROUP(xScalarAId, error) 00505 call XF_CLOSE_GROUP(xDsetsId, error) 00506 call XF_CLOSE_FILE(xFileId, error) 00507 error = status 00508 return 00509 endif 00510 00511 ! Add in a reftime. This is a julian day for: 00512 ! noon July 1, 2003 00513 dJulianReftime = 2452822.0; 00514 call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status) 00515 if (status < 0) then 00516 call XF_CLOSE_GROUP(xScalarAId, error) 00517 call XF_CLOSE_GROUP(xDsetsId, error) 00518 call XF_CLOSE_FILE(xFileId, error) 00519 endif 00520 00521 ! Loop through timesteps adding them to the file 00522 do iTimestep = 1, nTimes 00523 ! We will have an 0.5 hour timestep 00524 dTime = iTimestep * 0.5 00525 00526 fValues(1) = dTime 00527 do i = 2, nValues 00528 fValues(i) = fValues(i-1)*2.5 00529 end do 00530 00531 ! write the dataset array values 00532 call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, error) 00533 if (error .GE. 0) then 00534 ! write activity array 00535 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, error) 00536 end if 00537 enddo 00538 00539 ! Write Coordinate file - for ScalarA, we will set the coordinate system 00540 ! to be Geographic HPGN, with HPGN settings written to the file. 00541 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 00542 if (status < 0) then 00543 call XF_CLOSE_GROUP(xScalarAId, error) 00544 call XF_CLOSE_GROUP(xDsetsId, error) 00545 call XF_CLOSE_FILE(xFileId, error) 00546 error = -1 00547 return 00548 endif 00549 00550 ! set HPGN Zone for test 00551 iHpgnZone = 29 ! Utah 00552 ! Write Coordinate Information to file 00553 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error) 00554 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 00555 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 00556 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 00557 00558 ! write additional information 00559 call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error) 00560 00561 call XF_CLOSE_GROUP(xCoordId, error) 00562 xCoordId = 0; 00563 00564 ! close the dataset 00565 call XF_CLOSE_GROUP(xScalarAId, error) 00566 call XF_CLOSE_GROUP(xDsetsId, error) 00567 call XF_CLOSE_FILE(xFileId, error) 00568 00569 return 00570 END SUBROUTINE 00571 ! tdWriteScalarA 00572 00573 ! -------------------------------------------------------------------------- 00574 ! FUNCTION tdWriteScalarAPIECES 00575 ! PURPOSE Write scalar Dataset to an HDF5 File 00576 ! NOTES This tests dynamic data sets, and activity 00577 ! This dataset is dynamic concentrations (mg/L) with output times 00578 ! in minutes. 00579 ! Dataset is for a mesh and so nActive is the number of elements 00580 ! which is not the same as the nValues which would be number of nodes 00581 ! reads/writes a reference time in julian days 00582 ! -------------------------------------------------------------------------- 00583 SUBROUTINE TD_WRITE_SCALAR_A_PIECES (a_Filename, a_Compression, error) 00584 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00585 INTEGER, INTENT(IN) :: a_Compression 00586 INTEGER, INTENT(OUT) :: error 00587 INTEGER xFileId, xDsetsId, xScalarAId, xCoordId 00588 INTEGER nValues, nTimes, nActive 00589 REAL(DOUBLE) dTime, dJulianReftime 00590 INTEGER iTimestep, iActive, iHpgnZone 00591 REAL fValues(10) ! nValues 00592 INTEGER*1 bActivity(10) ! activity 00593 INTEGER i, status 00594 REAL minvalue, maxvalue 00595 INTEGER timestepId 00596 INTEGER activeTs 00597 00598 ! initialize the data 00599 nValues = 10 00600 nTimes = 3 00601 nActive = 8 00602 dTime = 0.0 00603 00604 ! 5th item in data set is always inactive, others active 00605 do iActive = 1, nActive 00606 bActivity(iActive) = 1 00607 enddo 00608 bActivity(6) = 0 00609 00610 00611 ! create the file 00612 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 00613 if (error .LT. 0) then 00614 ! close the file 00615 call XF_CLOSE_FILE(xFileId, error) 00616 return 00617 endif 00618 00619 ! create the group where we will put all the datasets 00620 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00621 if (status < 0) then 00622 call XF_CLOSE_FILE(xFileId, error) 00623 error = -1 00624 return 00625 endif 00626 00627 ! Create the scalar A dataset group 00628 call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', & 00629 TS_HOURS, a_Compression, xScalarAId, status) 00630 if (status .LT. 0) then 00631 ! close the dataset 00632 call XF_CLOSE_GROUP(xScalarAId, error) 00633 call XF_CLOSE_GROUP(xDsetsId, error) 00634 call XF_CLOSE_FILE(xFileId, error) 00635 error = status 00636 return 00637 endif 00638 00639 ! Add in a reftime. This is a julian day for: 00640 ! noon July 1, 2003 00641 dJulianReftime = 2452822.0; 00642 call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status) 00643 if (status < 0) then 00644 call XF_CLOSE_GROUP(xScalarAId, error) 00645 call XF_CLOSE_GROUP(xDsetsId, error) 00646 call XF_CLOSE_FILE(xFileId, error) 00647 endif 00648 00649 ! Loop through timesteps adding them to the file 00650 do iTimestep = 1, nTimes 00651 ! We will have an 0.5 hour timestep 00652 dTime = iTimestep * 0.5 00653 00654 fValues(1) = dTime 00655 minvalue = fValues(1) 00656 maxvalue = fValues(1) 00657 do i = 2, nValues 00658 fValues(i) = fValues(i-1)*2.5 00659 minvalue = min(minvalue, fValues(i)) 00660 maxvalue = max(maxvalue, fValues(i)) 00661 end do 00662 00663 ! write the dataset array values 00664 call XF_INITIALIZE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, minvalue, & 00665 maxvalue, timestepId, error) 00666 00667 ! write data in pairs 00668 do i = 1, nValues, +2 00669 call XF_WRITE_SCALAR_TIMESTEP_PORTION(xScalarAId, timestepId, 2, i, & 00670 fValues(i), error) 00671 enddo 00672 00673 if (error .GE. 0) then 00674 ! write activity array 00675 call XF_INITIALIZE_ACTIVITY_TIMESTEP(xScalarAId, nActive, activeTs, error) 00676 00677 do i = 1, nActive, +2 00678 call XF_WRITE_ACTIVITY_TIMESTEP_PORTION(xScalarAId, activeTs, 2, & 00679 i, bActivity(i), error) 00680 enddo 00681 00682 end if 00683 enddo 00684 00685 ! Write Coordinate file - for ScalarA, we will set the coordinate system 00686 ! to be Geographic HPGN, with HPGN settings written to the file. 00687 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 00688 if (status < 0) then 00689 call XF_CLOSE_GROUP(xScalarAId, error) 00690 call XF_CLOSE_GROUP(xDsetsId, error) 00691 call XF_CLOSE_FILE(xFileId, error) 00692 error = -1 00693 return 00694 endif 00695 00696 ! set HPGN Zone for test 00697 iHpgnZone = 29 ! Utah 00698 ! Write Coordinate Information to file 00699 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error) 00700 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 00701 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 00702 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 00703 00704 ! write additional information 00705 call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error) 00706 00707 call XF_CLOSE_GROUP(xCoordId, error) 00708 xCoordId = 0; 00709 00710 ! close the dataset 00711 call XF_CLOSE_GROUP(xScalarAId, error) 00712 call XF_CLOSE_GROUP(xDsetsId, error) 00713 call XF_CLOSE_FILE(xFileId, error) 00714 00715 return 00716 END SUBROUTINE 00717 ! tdWriteScalarAPieces 00718 00719 ! -------------------------------------------------------------------------- 00720 ! FUNCTION tdWriteScalarAPIECESAltMinMax 00721 ! PURPOSE Write scalar Dataset to an HDF5 File 00722 ! NOTES This tests dynamic data sets, and activity 00723 ! This dataset is dynamic concentrations (mg/L) with output times 00724 ! in minutes. 00725 ! Dataset is for a mesh and so nActive is the number of elements 00726 ! which is not the same as the nValues which would be number of nodes 00727 ! reads/writes a reference time in julian days 00728 ! -------------------------------------------------------------------------- 00729 SUBROUTINE TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX (a_Filename, a_Compression, error) 00730 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00731 INTEGER, INTENT(IN) :: a_Compression 00732 INTEGER, INTENT(OUT) :: error 00733 INTEGER xFileId, xDsetsId, xScalarAId, xCoordId 00734 INTEGER nValues, nTimes, nActive 00735 REAL(DOUBLE) dTime, dJulianReftime 00736 INTEGER iTimestep, iActive, iHpgnZone 00737 REAL fValues(10) ! nValues 00738 INTEGER*1 bActivity(10) ! activity 00739 INTEGER i, status 00740 REAL minvalue, maxvalue 00741 INTEGER timestepId 00742 INTEGER activeTs 00743 00744 ! initialize the data 00745 nValues = 10 00746 nTimes = 3 00747 nActive = 8 00748 dTime = 0.0 00749 00750 ! 5th item in data set is always inactive, others active 00751 do iActive = 1, nActive 00752 bActivity(iActive) = 1 00753 enddo 00754 bActivity(6) = 0 00755 00756 00757 ! create the file 00758 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 00759 if (error .LT. 0) then 00760 ! close the file 00761 call XF_CLOSE_FILE(xFileId, error) 00762 return 00763 endif 00764 00765 ! create the group where we will put all the datasets 00766 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00767 if (status < 0) then 00768 call XF_CLOSE_FILE(xFileId, error) 00769 error = -1 00770 return 00771 endif 00772 00773 ! Create the scalar A dataset group 00774 call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_A_LOCATION, 'mg/L', & 00775 TS_HOURS, a_Compression, xScalarAId, status) 00776 if (status .LT. 0) then 00777 ! close the dataset 00778 call XF_CLOSE_GROUP(xScalarAId, error) 00779 call XF_CLOSE_GROUP(xDsetsId, error) 00780 call XF_CLOSE_FILE(xFileId, error) 00781 error = status 00782 return 00783 endif 00784 00785 ! Add in a reftime. This is a julian day for: 00786 ! noon July 1, 2003 00787 dJulianReftime = 2452822.0; 00788 call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status) 00789 if (status < 0) then 00790 call XF_CLOSE_GROUP(xScalarAId, error) 00791 call XF_CLOSE_GROUP(xDsetsId, error) 00792 call XF_CLOSE_FILE(xFileId, error) 00793 endif 00794 00795 ! Loop through timesteps adding them to the file 00796 do iTimestep = 1, nTimes 00797 ! We will have an 0.5 hour timestep 00798 dTime = iTimestep * 0.5 00799 00800 fValues(1) = dTime 00801 minvalue = fValues(1) 00802 maxvalue = fValues(1) 00803 do i = 2, nValues 00804 fValues(i) = fValues(i-1)*2.5 00805 minvalue = min(minvalue, fValues(i)) 00806 maxvalue = max(maxvalue, fValues(i)) 00807 end do 00808 00809 ! write the dataset array values 00810 call XF_INITIALIZE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, minvalue, & 00811 maxvalue, timestepId, error) 00812 00813 ! write data in pairs 00814 do i = 1, nValues, +2 00815 call XF_WRITE_SCALAR_TIMESTEP_PORTION(xScalarAId, timestepId, 2, i, & 00816 fValues(i), error) 00817 enddo 00818 00819 minvalue = 0.1111*timestepId 00820 maxvalue = 1111*timestepId 00821 call XF_SET_DATASET_TIMESTEP_MIN_MAX(xScalarAId, timestepId, minvalue, & 00822 maxvalue, error) 00823 00824 if (error .GE. 0) then 00825 ! write activity array 00826 call XF_INITIALIZE_ACTIVITY_TIMESTEP(xScalarAId, nActive, activeTs, error) 00827 00828 do i = 1, nActive, +2 00829 call XF_WRITE_ACTIVITY_TIMESTEP_PORTION(xScalarAId, activeTs, 2, & 00830 i, bActivity(i), error) 00831 enddo 00832 00833 end if 00834 enddo 00835 00836 ! Write Coordinate file - for ScalarA, we will set the coordinate system 00837 ! to be Geographic HPGN, with HPGN settings written to the file. 00838 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 00839 if (status < 0) then 00840 call XF_CLOSE_GROUP(xScalarAId, error) 00841 call XF_CLOSE_GROUP(xDsetsId, error) 00842 call XF_CLOSE_FILE(xFileId, error) 00843 error = -1 00844 return 00845 endif 00846 00847 ! set HPGN Zone for test 00848 iHpgnZone = 29 ! Utah 00849 ! Write Coordinate Information to file 00850 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error) 00851 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 00852 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 00853 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 00854 00855 ! write additional information 00856 call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error) 00857 00858 call XF_CLOSE_GROUP(xCoordId, error) 00859 xCoordId = 0; 00860 00861 ! close the dataset 00862 call XF_CLOSE_GROUP(xScalarAId, error) 00863 call XF_CLOSE_GROUP(xDsetsId, error) 00864 call XF_CLOSE_FILE(xFileId, error) 00865 00866 return 00867 END SUBROUTINE 00868 ! TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX 00869 00870 00871 ! -------------------------------------------------------------------------- 00872 ! FUNCTION TD_WRITE_SCALAR_B 00873 ! PURPOSE Write scalar Dataset to an HDF5 File 00874 ! NOTES This tests dynamic data sets, and activity 00875 ! This dataset is dynamic concentrations (mg/L) with output times 00876 ! in minutes. 00877 ! Dataset is for a mesh and so nActive is the number of elements 00878 ! which is not the same as the nValues which would be number of nodes 00879 ! reads/writes a reference time in julian days 00880 ! -------------------------------------------------------------------------- 00881 SUBROUTINE TD_WRITE_SCALAR_B (a_Filename, a_Compression, a_Overwrite, error) 00882 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 00883 INTEGER, INTENT(IN) :: a_Compression 00884 LOGICAL, INTENT(IN) :: a_Overwrite 00885 INTEGER, INTENT(OUT) :: error 00886 INTEGER xFileId, xDsetsId, xScalarBId, xCoordId 00887 INTEGER nValues, nTimes, nActive 00888 REAL(DOUBLE) dTime, dJulianReftime 00889 INTEGER iTimestep, iActive 00890 REAL fValues(10) ! nValues 00891 INTEGER*1 bActivity(10) ! activity 00892 INTEGER i, status 00893 00894 ! initialize the data 00895 nValues = 10 00896 nTimes = 3 00897 nActive = 8 00898 dTime = 0.0 00899 i = 0 00900 00901 ! 5th item in data set is always inactive, others active 00902 do iActive = 1, nActive 00903 bActivity(iActive) = 1 00904 enddo 00905 bActivity(6) = 0 00906 00907 if (a_Overwrite) then 00908 ! open the already-existing file 00909 call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status) 00910 if (status < 0) then 00911 error = -1 00912 return 00913 endif 00914 ! open the group where we have all the datasets 00915 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00916 if (status < 0) then 00917 call XF_CLOSE_FILE(xFileId, error) 00918 error = -1 00919 return 00920 endif 00921 else 00922 ! create the file 00923 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 00924 if (error .LT. 0) then 00925 ! close the file 00926 call XF_CLOSE_FILE(xFileId, error) 00927 return 00928 endif 00929 00930 ! create the group where we will put all the datasets 00931 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 00932 if (status < 0) then 00933 call XF_CLOSE_FILE(xFileId, error) 00934 error = -1 00935 return 00936 endif 00937 endif 00938 00939 ! Create/Overwrite the scalar B dataset group 00940 call XF_CREATE_SCALAR_DATASET(xDsetsId, SCALAR_B_LOCATION, 'mg/L', & 00941 TS_HOURS, a_Compression, xScalarBId, status) 00942 if (status < 0) then 00943 ! close the dataset 00944 call XF_CLOSE_GROUP(xScalarBId, error) 00945 call XF_CLOSE_GROUP(xDsetsId, error) 00946 call XF_CLOSE_FILE(xFileId, error) 00947 error = status 00948 return 00949 endif 00950 00951 ! Add in a reftime. This is a julian day for: 00952 ! noon July 1, 2003 00953 dJulianReftime = 2452822.0; 00954 call XF_WRITE_REFTIME(xScalarBId, dJulianReftime, status) 00955 if (status < 0) then 00956 call XF_CLOSE_GROUP(xScalarBId, error) 00957 call XF_CLOSE_GROUP(xDsetsId, error) 00958 call XF_CLOSE_FILE(xFileId, error) 00959 endif 00960 00961 if (.NOT. a_Overwrite) then 00962 ! Loop through timesteps adding them to the file 00963 do iTimestep = 1, nTimes 00964 ! We will have an 0.5 hour timestep 00965 dTime = iTimestep * 0.5 00966 00967 fValues(1) = dTime 00968 do i = 2, nValues 00969 fValues(i) = fValues(i-1)*2.5 00970 end do 00971 00972 ! write the dataset array values 00973 call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error) 00974 if (error .GE. 0) then 00975 ! write activity array 00976 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error) 00977 end if 00978 if (error < 0) then 00979 call XF_CLOSE_GROUP(xScalarBId, error) 00980 call XF_CLOSE_GROUP(xDsetsId, error) 00981 call XF_CLOSE_FILE(xFileId, error) 00982 endif 00983 enddo 00984 else 00985 ! Loop through timesteps adding them to the file 00986 do iTimestep = 1, nTimes 00987 ! We will have an 1.5 hour timestep 00988 dTime = iTimestep * 1.5 00989 00990 fValues(1) = dTime 00991 do i = 2, nValues 00992 fValues(i) = fValues(i-1)*1.5 00993 end do 00994 00995 ! write the dataset array values 00996 call XF_WRITE_SCALAR_TIMESTEP(xScalarBId, dTime, nValues, fValues, error) 00997 if (error .GE. 0) then 00998 ! write activity array 00999 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarBId, nActive, bActivity, error) 01000 end if 01001 if (error < 0) then 01002 call XF_CLOSE_GROUP(xScalarBId, error) 01003 call XF_CLOSE_GROUP(xDsetsId, error) 01004 call XF_CLOSE_FILE(xFileId, error) 01005 endif 01006 enddo 01007 endif 01008 01009 if (.NOT. a_Overwrite) then 01010 ! Write Coordinate file - for ScalarB, we will set the coordinate system 01011 ! to be UTM, with UTM Zone settings written to the file. 01012 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 01013 if (status < 0) then 01014 call XF_CLOSE_GROUP(xScalarBId, error) 01015 call XF_CLOSE_GROUP(xDsetsId, error) 01016 call XF_CLOSE_FILE(xFileId, error) 01017 error = -1 01018 return 01019 endif 01020 01021 ! Write Coord Info to file 01022 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error) 01023 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 01024 01025 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01026 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 01027 01028 ! write additional information - we'll use the max value for this test 01029 call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error) 01030 01031 call XF_CLOSE_GROUP(xCoordId, error) 01032 xCoordId = 0 01033 endif 01034 01035 ! close the dataset 01036 call XF_CLOSE_GROUP(xScalarBId, error) 01037 call XF_CLOSE_GROUP(xDsetsId, error) 01038 call XF_CLOSE_FILE(xFileId, error) 01039 01040 error = 1 01041 return 01042 END SUBROUTINE 01043 ! tdWriteScalarB 01044 !------------------------------------------------------------------------------ 01045 ! FUNCTION TD_WRITE_COORDS_TO_MULTI 01046 ! PURPOSE Write coordinate system to a multidataset file 01047 ! NOTES 01048 !------------------------------------------------------------------------------ 01049 SUBROUTINE TD_WRITE_COORDS_TO_MULTI (a_xFileId, error) 01050 INTEGER, INTENT(IN) :: a_xFileId 01051 INTEGER, INTENT(OUT) :: error 01052 INTEGER xCoordId 01053 INTEGER status 01054 01055 ! Write Coordinate file - for Multidatasets, we will set the coordinate system 01056 ! to be UTM, with UTM Zone settings written to the file. 01057 call XF_CREATE_COORDINATE_GROUP(a_xFileId, xCoordId, status) 01058 if (status < 0) then 01059 error = status 01060 return 01061 endif 01062 01063 ! Write Coord Info to file 01064 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error) 01065 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 01066 01067 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01068 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 01069 01070 ! write additional information - we'll use the max value for this test 01071 call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error) 01072 01073 call XF_CLOSE_GROUP(xCoordId, error) 01074 xCoordId = 0 01075 01076 return 01077 END SUBROUTINE 01078 01079 ! -------------------------------------------------------------------------- 01080 ! FUNCTION tdWriteScalarAToMulti 01081 ! PURPOSE Write scalar Dataset to an HDF5 File 01082 ! NOTES This tests dynamic data sets, and activity 01083 ! This dataset is dynamic concentrations (mg/L) with output times 01084 ! in minutes. 01085 ! Dataset is for a mesh and so nActive is the number of elements 01086 ! which is not the same as the nValues which would be number of nodes 01087 ! reads/writes a reference time in julian days 01088 ! -------------------------------------------------------------------------- 01089 SUBROUTINE TD_WRITE_SCALAR_A_TO_MULTI (a_GroupID, status) 01090 ! CHARACTER(LEN=*), INTENT(IN) :: a_Filename 01091 ! INTEGER, INTENT(IN) :: a_Compression 01092 ! INTEGER, INTENT(OUT) :: error 01093 INTEGER xFileId, xDsetsId, xScalarAId 01094 INTEGER a_GroupID 01095 INTEGER nValues, nTimes, nActive 01096 REAL(DOUBLE) dTime, dJulianReftime 01097 INTEGER iTimestep, iActive 01098 REAL fValues(10) ! nValues 01099 INTEGER*1 bActivity(10) ! activity 01100 INTEGER i, status 01101 01102 ! initialize the data 01103 nValues = 10 01104 nTimes = 3 01105 nActive = 8 01106 dTime = 0.0 01107 01108 ! 5th item in data set is always inactive, others active 01109 do iActive = 1, nActive 01110 bActivity(iActive) = 1 01111 enddo 01112 bActivity(6) = 0 01113 01114 ! Create the scalar A dataset group 01115 call XF_CREATE_SCALAR_DATASET(a_GroupID, SCALAR_A_LOCATION, 'mg/L', & 01116 TS_HOURS, NONE, xScalarAId, status) 01117 if (status .LT. 0) then 01118 ! close the dataset 01119 call XF_CLOSE_GROUP(xScalarAId, status) 01120 call XF_CLOSE_GROUP(xDsetsId, status) 01121 call XF_CLOSE_FILE(xFileId, status) 01122 return 01123 endif 01124 01125 ! Add in a reftime. This is a julian day for: 01126 ! noon July 1, 2003 01127 dJulianReftime = 2452822.0; 01128 call XF_WRITE_REFTIME(xScalarAId, dJulianReftime, status) 01129 if (status < 0) then 01130 call XF_CLOSE_GROUP(xScalarAId, status) 01131 call XF_CLOSE_GROUP(xDsetsId, status) 01132 call XF_CLOSE_FILE(xFileId, status) 01133 endif 01134 01135 ! Loop through timesteps adding them to the file 01136 do iTimestep = 1, nTimes 01137 ! We will have an 0.5 hour timestep 01138 dTime = iTimestep * 0.5 01139 01140 fValues(1) = dTime 01141 do i = 2, nValues 01142 fValues(i) = fValues(i-1)*2.5 01143 end do 01144 01145 ! write the dataset array values 01146 call XF_WRITE_SCALAR_TIMESTEP(xScalarAId, dTime, nValues, fValues, status) 01147 if (status .GE. 0) then 01148 ! write activity array 01149 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarAId, nActive, bActivity, status) 01150 end if 01151 enddo 01152 01153 ! close the dataset 01154 call XF_CLOSE_GROUP(xScalarAId, status) 01155 !call XF_CLOSE_GROUP(a_GroupID, status) 01156 !call XF_CLOSE_FILE(a_FileID, status) 01157 01158 return 01159 END SUBROUTINE 01160 ! tdWriteScalarAToMulti 01161 ! -------------------------------------------------------------------------- 01162 ! FUNCTION tdReadVector2DAIndex 01163 ! PURPOSE Read all timestep values for a particular index 01164 ! NOTES 01165 ! -------------------------------------------------------------------------- 01166 SUBROUTINE TD_READ_VECTOR2D_A_INDEX (a_Filename, a_Index, error) 01167 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 01168 INTEGER, INTENT(IN) :: a_Index 01169 INTEGER, INTENT(OUT) :: error 01170 INTEGER status 01171 INTEGER xFileId, xDsetsId, xVector2DA 01172 INTEGER nTimesteps, i 01173 REAL, ALLOCATABLE :: fValues(:) 01174 01175 xFileId = NONE 01176 xDsetsId = NONE 01177 xVector2DA = NONE 01178 01179 ! open the file 01180 call XF_OPEN_FILE(a_Filename, .TRUE., xFileId, status) 01181 if (status < 0) then 01182 error = -1 01183 return 01184 endif 01185 01186 ! open the dataset group 01187 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 01188 if (status >= 0) then 01189 call XF_OPEN_GROUP(xDsetsId, VECTOR2D_A_LOCATION, xVector2DA, status) 01190 endif 01191 if (status < 0) then 01192 error = status 01193 return 01194 endif 01195 01196 ! Find out the number of timesteps in the file 01197 call XF_GET_DATASET_NUM_TIMES(xVector2DA, nTimesteps, status) 01198 if (status < 0) then 01199 error = status 01200 return 01201 endif 01202 01203 if (nTimesteps < 1) then 01204 error = -1 01205 return 01206 endif 01207 01208 ! Read the values for the index 01209 allocate(fValues(nTimesteps*2)) 01210 call XF_READ_VECTOR_VALUES_AT_INDEX(xVector2DA, a_Index, 1, nTimesteps, 2, & 01211 fValues, status) 01212 01213 ! output the data 01214 WRITE(*,*) '' 01215 WRITE(*,*) 'Reading vector 2D A slice at index: ', a_Index 01216 do i=1, nTimesteps 01217 WRITE(*,*) fValues(i*2-1), ' ', fValues(i*2) 01218 enddo 01219 WRITE(*,*) '' 01220 01221 deallocate(fValues) 01222 01223 error = status 01224 return 01225 01226 END SUBROUTINE 01227 !tdReadVector2DAIndex 01228 01229 ! -------------------------------------------------------------------------- 01230 ! FUNCTION tdWriteVector2D_A 01231 ! PURPOSE Write scalar Dataset to an HDF5 File 01232 ! NOTES This tests dynamic data sets, and activity 01233 ! This dataset is dynamic concentrations (mg/L) with output times 01234 ! in minutes. 01235 ! Dataset is for a mesh and so nActive is the number of elements 01236 ! which is not the same as the nValues which would be number of nodes 01237 ! reads/writes a reference time in julian days 01238 ! -------------------------------------------------------------------------- 01239 SUBROUTINE TD_WRITE_VECTOR2D_A (a_Filename, a_Compression, error) 01240 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 01241 INTEGER, INTENT(IN) :: a_Compression 01242 INTEGER, INTENT(OUT) :: error 01243 INTEGER xFileId, xDsetsId, xVector2D_A, xCoordId 01244 INTEGER nValues, nTimes, nComponents, nActive 01245 REAL(DOUBLE) dTime 01246 INTEGER iTimestep, iActive 01247 REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues 01248 INTEGER*1 bActivity(100) ! activity 01249 INTEGER i, j, status 01250 INTEGER iHpgnZone 01251 01252 ! initialize the data 01253 nComponents = 2 01254 nValues = 100 01255 nTimes = 6 01256 nActive = 75 01257 dTime = 0.0 01258 01259 ! 5th item in data set is always inactive, others active 01260 bActivity(1) = 0 01261 do iActive = 2, nActive 01262 if (mod(iActive-1, 3) == 0) then 01263 bActivity(iActive) = 0 01264 else 01265 bActivity(iActive) = 1 01266 endif 01267 enddo 01268 01269 ! create the file 01270 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 01271 if (error .LT. 0) then 01272 ! close the dataset 01273 call XF_CLOSE_FILE(xFileId, error) 01274 return 01275 endif 01276 01277 ! create the group where we will put all the datasets 01278 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 01279 if (status < 0) then 01280 call XF_CLOSE_FILE(xFileId, error) 01281 error = -1 01282 return 01283 endif 01284 01285 ! Create the vector dataset group 01286 call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_A_LOCATION, 'ft/s', & 01287 TS_SECONDS, a_Compression, xVector2D_A, status) 01288 if (status .LT. 0) then 01289 ! close the dataset 01290 call XF_CLOSE_GROUP(xVector2D_A, error) 01291 call XF_CLOSE_GROUP(xDsetsId, error) 01292 call XF_CLOSE_FILE(xFileId, error) 01293 error = status 01294 return 01295 endif 01296 01297 ! Loop through timesteps adding them to the file 01298 do iTimestep = 1, nTimes 01299 ! We will have an 0.5 hour timestep 01300 dTime = iTimestep * 0.5 01301 01302 do i = 1, nValues 01303 do j = 1, nComponents 01304 fValues(j,i) = ((i-1)*nComponents + j)*dTime 01305 end do 01306 end do 01307 01308 ! write the dataset array values 01309 call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, & 01310 fValues, error) 01311 if (error .GE. 0) then 01312 ! write activity array 01313 call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, error) 01314 end if 01315 enddo 01316 01317 ! Write Coordinate file - for Vector2D_A, we will set the coordinate system 01318 ! to be Geographic HPGN, with HPGN settings written to the file. 01319 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 01320 if (status < 0) then 01321 call XF_CLOSE_GROUP(xVector2D_A, error) 01322 call XF_CLOSE_GROUP(xDsetsId, error) 01323 call XF_CLOSE_FILE(xFileId, error) 01324 error = -1 01325 return 01326 endif 01327 01328 ! set HPGN info for test 01329 iHpgnZone = 29 ! Utah 01330 01331 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error) 01332 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 01333 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01334 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 01335 01336 ! write additional information 01337 call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error) 01338 01339 call XF_CLOSE_GROUP(xCoordId, error) 01340 xCoordId = 0 01341 01342 ! close the dataset 01343 call XF_CLOSE_GROUP(xVector2D_A, error) 01344 call XF_CLOSE_GROUP(xDsetsId, error) 01345 call XF_CLOSE_FILE(xFileId, error) 01346 01347 return 01348 END SUBROUTINE 01349 ! tdWriteVector2D_A 01350 01351 ! -------------------------------------------------------------------------- 01352 ! FUNCTION tdWriteVector2D_A_PIECES 01353 ! PURPOSE Write scalar Dataset to an HDF5 File 01354 ! NOTES This tests dynamic data sets, and activity 01355 ! This dataset is dynamic concentrations (mg/L) with output times 01356 ! in minutes. 01357 ! Dataset is for a mesh and so nActive is the number of elements 01358 ! which is not the same as the nValues which would be number of nodes 01359 ! reads/writes a reference time in julian days 01360 ! -------------------------------------------------------------------------- 01361 SUBROUTINE TD_WRITE_VECTOR2D_A_PIECES (a_Filename, a_Compression, error) 01362 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 01363 INTEGER, INTENT(IN) :: a_Compression 01364 INTEGER, INTENT(OUT) :: error 01365 INTEGER xFileId, xDsetsId, xVector2D_A, xCoordId 01366 INTEGER nValues, nTimes, nComponents, nActive 01367 REAL(DOUBLE) dTime 01368 INTEGER iTimestep, iActive 01369 REAL*4, DIMENSION(2, 100) :: fValues ! nComponents, nValues 01370 INTEGER*1 bActivity(100) ! activity 01371 INTEGER i, j, status 01372 INTEGER iHpgnZone 01373 INTEGER nValuesToWrite, nComponentsToWrite, startComponent 01374 REAL*4 minvalue, maxvalue 01375 INTEGER timeId 01376 REAL*8 mag 01377 01378 ! initialize the data 01379 nComponents = 2 01380 nValues = 100 01381 nTimes = 6 01382 nActive = 75 01383 dTime = 0.0 01384 01385 ! 5th item in data set is always inactive, others active 01386 bActivity(1) = 0 01387 do iActive = 2, nActive 01388 if (mod(iActive-1, 3) == 0) then 01389 bActivity(iActive) = 0 01390 else 01391 bActivity(iActive) = 1 01392 endif 01393 enddo 01394 01395 ! create the file 01396 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 01397 if (error .LT. 0) then 01398 ! close the dataset 01399 call XF_CLOSE_FILE(xFileId, error) 01400 return 01401 endif 01402 01403 ! create the group where we will put all the datasets 01404 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 01405 if (status < 0) then 01406 call XF_CLOSE_FILE(xFileId, error) 01407 error = -1 01408 return 01409 endif 01410 01411 ! Create the vector dataset group 01412 call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_A_LOCATION, 'ft/s', & 01413 TS_SECONDS, a_Compression, xVector2D_A, status) 01414 if (status .LT. 0) then 01415 ! close the dataset 01416 call XF_CLOSE_GROUP(xVector2D_A, error) 01417 call XF_CLOSE_GROUP(xDsetsId, error) 01418 call XF_CLOSE_FILE(xFileId, error) 01419 error = status 01420 return 01421 endif 01422 01423 ! Loop through timesteps adding them to the file 01424 do iTimestep = 1, nTimes 01425 ! We will have an 0.5 hour timestep 01426 dTime = iTimestep * 0.5 01427 01428 do i = 1, nValues 01429 do j = 1, nComponents 01430 fValues(j,i) = ((i-1)*nComponents + j)*dTime 01431 end do 01432 end do 01433 01434 minvalue = 99999.0 01435 maxvalue = 0.0 01436 do i = 1, nValues 01437 mag = 0.0 01438 do j = 1, nComponents 01439 mag = mag + fValues(j, i)**2 01440 end do 01441 mag = mag**0.5 01442 01443 minvalue = min(minvalue, mag) 01444 maxvalue = max(maxvalue, mag) 01445 end do 01446 01447 ! write the dataset array values 01448 call XF_INITIALIZE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, & 01449 minvalue, maxvalue, timeId, error) 01450 01451 nValuesToWrite = 2 01452 nComponentsToWrite = 2 01453 startComponent = 1 01454 01455 do i = 1, nValues, +2 01456 call XF_WRITE_VECTOR_TIMESTEP_PORTION(xVector2D_A, timeId, nValuesToWrite, & 01457 nComponentsToWrite, i, startComponent, fValues(1, i), error) 01458 enddo 01459 01460 if (error .GE. 0) then 01461 ! write activity array 01462 call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, error) 01463 end if 01464 enddo 01465 01466 ! Write Coordinate file - for Vector2D_A, we will set the coordinate system 01467 ! to be Geographic HPGN, with HPGN settings written to the file. 01468 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 01469 if (status < 0) then 01470 call XF_CLOSE_GROUP(xVector2D_A, error) 01471 call XF_CLOSE_GROUP(xDsetsId, error) 01472 call XF_CLOSE_FILE(xFileId, error) 01473 error = -1 01474 return 01475 endif 01476 01477 ! set HPGN info for test 01478 iHpgnZone = 29 ! Utah 01479 01480 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_GEOGRAPHIC_HPGN, error) 01481 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 01482 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01483 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 01484 01485 ! write additional information 01486 call XF_SET_HPGN_AREA(xCoordId, iHpgnZone, error) 01487 01488 call XF_CLOSE_GROUP(xCoordId, error) 01489 xCoordId = 0 01490 01491 ! close the dataset 01492 call XF_CLOSE_GROUP(xVector2D_A, error) 01493 call XF_CLOSE_GROUP(xDsetsId, error) 01494 call XF_CLOSE_FILE(xFileId, error) 01495 01496 return 01497 END SUBROUTINE 01498 ! tdWriteVector2D_A_PIECES 01499 01500 ! -------------------------------------------------------------------------- 01501 ! FUNCTION TD_WRITE_VECTOR2D_B 01502 ! PURPOSE Write scalar Dataset to an HDF5 File 01503 ! NOTES This tests dynamic data sets, and activity 01504 ! This dataset is dynamic concentrations (mg/L) with output times 01505 ! in minutes. 01506 ! Dataset is for a mesh and so nActive is the number of elements 01507 ! which is not the same as the nValues which would be number of nodes 01508 ! reads/writes a reference time in julian days 01509 ! -------------------------------------------------------------------------- 01510 SUBROUTINE TD_WRITE_VECTOR2D_B (a_Filename, a_Compression, a_Overwrite, error) 01511 CHARACTER(LEN=*), INTENT(IN) :: a_Filename 01512 INTEGER, INTENT(IN) :: a_Compression 01513 LOGICAL, INTENT(IN) :: a_Overwrite 01514 INTEGER, INTENT(OUT) :: error 01515 INTEGER xFileId, xDsetsId, xVector2D_B, xCoordId 01516 INTEGER nValues, nTimes, nComponents, nActive 01517 REAL(DOUBLE) dTime 01518 INTEGER iTimestep, iActive 01519 REAL, DIMENSION(2, 100) :: fValues 01520 INTEGER*1 bActivity(100) 01521 INTEGER i, j, status 01522 01523 ! initialize the data 01524 nComponents = 2 01525 nValues = 100 01526 nTimes = 6 01527 nActive = 75 01528 dTime = 0.0 01529 01530 ! 5th item in data set is always inactive, others active 01531 bActivity(1) = 0 01532 do iActive = 2, nActive 01533 if (mod(iActive-1, 3) == 0) then 01534 bActivity(iActive) = 0 01535 else 01536 bActivity(iActive) = 1 01537 endif 01538 enddo 01539 01540 if (a_Overwrite) then 01541 ! open the already-existing file 01542 call XF_OPEN_FILE(a_Filename, .FALSE., xFileId, status) 01543 if (status < 0) then 01544 error = -1 01545 return 01546 endif 01547 ! open the group where we have all the datasets 01548 call XF_OPEN_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 01549 if (status < 0) then 01550 call XF_CLOSE_FILE(xFileId, error) 01551 error = -1 01552 return 01553 endif 01554 else 01555 ! create the file 01556 call XF_CREATE_FILE(a_Filename, .TRUE., xFileId, error) 01557 if (error .LT. 0) then 01558 ! close the dataset 01559 call XF_CLOSE_FILE(xFileId, error) 01560 return 01561 endif 01562 01563 ! create the group where we will put all the datasets 01564 call XF_CREATE_GENERIC_GROUP(xFileId, DATASETS_LOCATION, xDsetsId, status) 01565 if (status < 0) then 01566 call XF_CLOSE_FILE(xFileId, error) 01567 error = -1 01568 return 01569 endif 01570 endif 01571 01572 ! Create/Overwrite the vector dataset group 01573 call XF_CREATE_VECTOR_DATASET(xDsetsId, VECTOR2D_B_LOCATION, 'ft/s', & 01574 TS_SECONDS, a_Compression, xVector2D_B, status) 01575 if (status .LT. 0) then 01576 ! close the dataset 01577 call XF_CLOSE_GROUP(xVector2D_B, error) 01578 call XF_CLOSE_GROUP(xDsetsId, error) 01579 call XF_CLOSE_FILE(xFileId, error) 01580 error = status 01581 return 01582 endif 01583 01584 if (.NOT. a_Overwrite) then 01585 ! Loop through timesteps adding them to the file 01586 do iTimestep = 1, nTimes 01587 ! We will have an 0.5 hour timestep 01588 dTime = iTimestep * 0.5 01589 do i = 1, nValues 01590 do j = 1, nComponents 01591 fValues(j,i) = ((i-1)*nComponents + j)*dTime 01592 end do 01593 end do 01594 ! write the dataset array values 01595 call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, & 01596 fValues, error) 01597 if (error .GE. 0) then 01598 ! write activity array 01599 call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error) 01600 end if 01601 if (error < 0) then 01602 call XF_CLOSE_GROUP(xVector2D_B, error) 01603 call XF_CLOSE_GROUP(xDsetsId, error) 01604 call XF_CLOSE_FILE(xFileId, error) 01605 endif 01606 enddo 01607 else 01608 ! Loop through timesteps adding them to the file 01609 do iTimestep = 1, nTimes 01610 ! We will have an 1.5 hour timestep 01611 dTime = iTimestep * 1.5 01612 do i = 1, nValues 01613 do j = 1, nComponents 01614 fValues(j,i) = ((i-1)*nComponents + j)*dTime 01615 end do 01616 end do 01617 ! write the dataset array values 01618 call XF_WRITE_VECTOR_TIMESTEP(xVector2D_B, dTime, nValues, nComponents, & 01619 fValues, error) 01620 if (error .GE. 0) then 01621 ! write activity array 01622 call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_B, nActive, bActivity, error) 01623 end if 01624 if (error < 0) then 01625 call XF_CLOSE_GROUP(xVector2D_B, error) 01626 call XF_CLOSE_GROUP(xDsetsId, error) 01627 call XF_CLOSE_FILE(xFileId, error) 01628 endif 01629 enddo 01630 endif 01631 01632 if (.NOT. a_Overwrite) then 01633 ! Write Coordinate file - for ScalarB, we will set the coordinate system 01634 ! to be UTM, with UTM Zone settings written to the file. 01635 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 01636 if (status < 0) then 01637 call XF_CLOSE_GROUP(xVector2D_B, error) 01638 call XF_CLOSE_GROUP(xDsetsId, error) 01639 call XF_CLOSE_FILE(xFileId, error) 01640 error = -1 01641 return 01642 endif 01643 01644 ! write the coordinate data to the file 01645 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_UTM, error) 01646 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 01647 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01648 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 01649 01650 ! write additional information - we'll use the max UTM zone for the test 01651 call XF_SET_UTM_ZONE(xCoordId, UTM_ZONE_MAX, error) 01652 01653 call XF_CLOSE_GROUP(xCoordId, error) 01654 xCoordId = 0 01655 endif 01656 01657 ! close the dataset 01658 call XF_CLOSE_GROUP(xVector2D_B, error) 01659 call XF_CLOSE_GROUP(xDsetsId, error) 01660 call XF_CLOSE_FILE(xFileId, error) 01661 01662 return 01663 END SUBROUTINE 01664 ! tdWriteVector2D_B 01665 01666 ! -------------------------------------------------------------------------- 01667 ! FUNCTION tdWriteVector2D_AToMulti 01668 ! PURPOSE Write scalar Dataset to an HDF5 File 01669 ! NOTES This tests dynamic data sets, and activity 01670 ! This dataset is dynamic concentrations (mg/L) with output times 01671 ! in minutes. 01672 ! Dataset is for a mesh and so nActive is the number of elements 01673 ! which is not the same as the nValues which would be number of nodes 01674 ! reads/writes a reference time in julian days 01675 ! -------------------------------------------------------------------------- 01676 SUBROUTINE TD_WRITE_VECTOR2D_A_TO_MULTI (a_FileID, a_GroupID, status) 01677 INTEGER xVector2D_A 01678 INTEGER a_FileID, a_GroupID 01679 INTEGER nValues, nTimes, nComponents, nActive 01680 REAL(DOUBLE) dTime 01681 INTEGER iTimestep, iActive 01682 REAL, DIMENSION(2, 100) :: fValues ! nComponents, nValues 01683 INTEGER*1 bActivity(100) ! activity 01684 INTEGER i, j, status 01685 01686 ! initialize the data 01687 nComponents = 2 01688 nValues = 100 01689 nTimes = 6 01690 nActive = 75 01691 dTime = 0.0 01692 01693 ! 5th item in data set is always inactive, others active 01694 bActivity(1) = 0 01695 do iActive = 2, nActive 01696 if (mod(iActive-1, 3) == 0) then 01697 bActivity(iActive) = 0 01698 else 01699 bActivity(iActive) = 1 01700 endif 01701 enddo 01702 01703 ! Create the vector dataset group 01704 call XF_CREATE_VECTOR_DATASET(a_GroupID, VECTOR2D_A_LOCATION, 'ft/s', & 01705 TS_SECONDS, NONE, xVector2D_A, status) 01706 if (status .LT. 0) then 01707 ! close the dataset 01708 call XF_CLOSE_GROUP(xVector2D_A, status) 01709 call XF_CLOSE_GROUP(a_GroupID, status) 01710 call XF_CLOSE_FILE(a_FileID, status) 01711 return 01712 endif 01713 01714 ! Loop through timesteps adding them to the file 01715 do iTimestep = 1, nTimes 01716 ! We will have an 0.5 hour timestep 01717 dTime = iTimestep * 0.5 01718 01719 do i = 1, nValues 01720 do j = 1, nComponents 01721 fValues(j,i) = ((i-1)*nComponents + j)*dTime 01722 end do 01723 end do 01724 01725 ! write the dataset array values 01726 call XF_WRITE_VECTOR_TIMESTEP(xVector2D_A, dTime, nValues, nComponents, & 01727 fValues, status) 01728 if (status .GE. 0) then 01729 ! write activity array 01730 call XF_WRITE_ACTIVITY_TIMESTEP(xVector2D_A, nActive, bActivity, status) 01731 end if 01732 enddo 01733 01734 ! close the dataset 01735 call XF_CLOSE_GROUP(xVector2D_A, status) 01736 return 01737 END SUBROUTINE 01738 ! tdWriteVector2D_AToMulti 01739 ! -------------------------------------------------------------------------- 01740 ! FUNCTION tdiReadScalar 01741 ! PURPOSE Read a scalar from an XMDF file and output information to 01742 ! to a text file 01743 ! NOTES 01744 ! -------------------------------------------------------------------------- 01745 SUBROUTINE TDI_READ_SCALAR (a_xScalarId, FileUnit, error) 01746 INTEGER, INTENT(IN) :: a_xScalarId 01747 INTEGER, INTENT(IN) :: FileUnit 01748 INTEGER, INTENT(OUT) :: error 01749 INTEGER nTimes, nValues, nActive 01750 LOGICAL*2 bUseReftime 01751 INTEGER iTime 01752 CHARACTER(LEN=100) TimeUnits 01753 REAL(DOUBLE), ALLOCATABLE :: Times(:) 01754 REAL, ALLOCATABLE :: Values(:), Minimums(:), Maximums(:) 01755 INTEGER, ALLOCATABLE :: Active(:) 01756 REAL(DOUBLE) Reftime 01757 nTimes = NONE 01758 nValues = NONE 01759 nActive = None 01760 01761 ! read the time units 01762 call XF_GET_DATASET_TIME_UNITS(a_xScalarId, TimeUnits, error) 01763 if (error < 0) return 01764 01765 WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits)) 01766 01767 ! see if we are using a reftime 01768 call XF_USE_REFTIME (a_xScalarId, bUseReftime, error) 01769 if (error < 0) then 01770 return 01771 endif 01772 if (bUseReftime) then 01773 call XF_READ_REFTIME (a_xScalarId, Reftime, error) 01774 if (error < 0) then 01775 return 01776 endif 01777 WRITE(FileUnit,*) 'Reftime: ', Reftime 01778 endif 01779 01780 ! read in the number of values and number of active values 01781 call XF_GET_DATASET_NUMVALS(a_xScalarId, nValues, error) 01782 if (error .GE. 0) then 01783 call XF_GET_DATASET_NUMACTIVE(a_xScalarId, nActive, error) 01784 endif 01785 if (error .LT. 0) return 01786 01787 if (nValues <= 0) then 01788 WRITE(FileUnit, *) 'No data to read in.' 01789 error = -1 01790 return 01791 endif 01792 01793 ! read in the number of times 01794 call XF_GET_DATASET_NUM_TIMES(a_xScalarId, nTimes, error) 01795 if (error < 0) then 01796 return 01797 endif 01798 01799 ! Read in the individual time values 01800 allocate(Times(nTimes)) 01801 01802 call XF_GET_DATASET_TIMES(a_xScalarId, nTimes, Times, error) 01803 if (error < 0) return 01804 01805 ! Read in the minimum and maximum values 01806 allocate(Minimums(nTimes)) 01807 allocate(Maximums(nTimes)) 01808 01809 call XF_GET_DATASET_MINS(a_xScalarId, nTimes, Minimums, error) 01810 if (error >= 0) then 01811 call XF_GET_DATASET_MAXS(a_xScalarId, nTimes, Maximums, error) 01812 endif 01813 if (error < 0) then 01814 deallocate(Times) 01815 deallocate(Minimums) 01816 deallocate(Maximums) 01817 return 01818 endif 01819 01820 allocate(Values(nValues)) 01821 if (nActive .GT. 0) then 01822 allocate(Active(nActive)) 01823 endif 01824 01825 WRITE(FileUnit,*) 'Number Timesteps: ', nTimes 01826 WRITE(FileUnit,*) 'Number Values: ', nValues 01827 WRITE(FileUnit,*) 'Number Active: ', nActive 01828 WRITE(FileUnit,*) '' 01829 01830 ! loop through the timesteps, read the values and active values and write 01831 ! them to the text file 01832 do iTime = 1, nTimes 01833 call XF_READ_SCALAR_VALUES_TIMESTEP(a_xScalarId, iTime, nValues, Values, error) 01834 if (error >= 0 .AND. nActive > 0) then 01835 call XF_READ_ACTIVITY_TIMESTEP(a_xScalarId, iTime, nActive, Active, error) 01836 endif 01837 01838 ! Write the time, min, max, values and active values to the text output 01839 ! file. 01840 WRITE(FileUnit,*) 'Timestep at ', Times(iTime) 01841 WRITE(FileUnit,*) 'Min: ', Minimums(iTime) 01842 WRITE(FileUnit,*) 'Max: ', Maximums(iTime) 01843 01844 WRITE(FileUnit,*) 'Values:' 01845 WRITE(FileUnit,*) Values(1:nValues) 01846 WRITE(FileUnit,*) '' 01847 01848 WRITE(FileUnit,*) 'Activity:' 01849 WRITE(FileUnit,*) Active(1:nActive) 01850 WRITE(FileUnit,*) '' 01851 end do 01852 01853 if (allocated(Times)) then 01854 deallocate(Times) 01855 endif 01856 01857 if (allocated(Minimums)) then 01858 deallocate(Minimums) 01859 endif 01860 01861 if (allocated(Maximums)) then 01862 deallocate(Maximums) 01863 endif 01864 01865 if (allocated(Values)) then 01866 deallocate(Values) 01867 endif 01868 01869 if (allocated(Active)) then 01870 deallocate(Active) 01871 endif 01872 01873 return 01874 END SUBROUTINE 01875 ! tdiReadScalar 01876 01877 ! -------------------------------------------------------------------------- 01878 ! FUNCTION TDI_READ_VECTOR 01879 ! PURPOSE Read a vector from an XMDF file and output information to 01880 ! to a text file 01881 ! NOTES 01882 ! -------------------------------------------------------------------------- 01883 SUBROUTINE TDI_READ_VECTOR (a_xVectorId, FileUnit, error) 01884 INTEGER, INTENT(IN) :: a_xVectorId 01885 INTEGER, INTENT(IN) :: FileUnit 01886 INTEGER, INTENT(OUT) :: error 01887 INTEGER nTimes, nValues, nActive, nComponents 01888 INTEGER iTime, i 01889 LOGICAL*2 bUseReftime 01890 CHARACTER(LEN=100) TimeUnits 01891 REAL(DOUBLE), ALLOCATABLE :: Times(:) 01892 REAL, ALLOCATABLE, DIMENSION (:, :) :: Values 01893 REAL, ALLOCATABLE :: Minimums(:), Maximums(:) 01894 INTEGER, ALLOCATABLE :: Active(:) 01895 REAL(DOUBLE) Reftime 01896 01897 nTimes = NONE 01898 nValues = NONE 01899 nActive = NONE 01900 nComponents = NONE 01901 01902 ! read the time units 01903 call XF_GET_DATASET_TIME_UNITS(a_xVectorId, TimeUnits, error) 01904 if (error < 0) return 01905 01906 WRITE(FileUnit,*) 'Time units: ', TimeUnits(1:LEN_TRIM(TimeUnits)) 01907 01908 ! see if we are using a reftime 01909 call XF_USE_REFTIME (a_xVectorId, bUseReftime, error) 01910 if (error < 0) then 01911 return 01912 endif 01913 if (bUseReftime) then 01914 call XF_READ_REFTIME (a_xVectorId, Reftime, error) 01915 if (error < 0) then 01916 return 01917 endif 01918 WRITE(FileUnit,*) 'Reftime: ', Reftime 01919 endif 01920 01921 ! read in the number of values and number of active values 01922 call XF_GET_DATASET_NUMVALS(a_xVectorId, nValues, error) 01923 if (error .GE. 0) then 01924 call XF_GET_DATASET_NUMCOMPONENTS(a_xVectorId, nComponents, error) 01925 if (error .GE. 0) then 01926 call XF_GET_DATASET_NUMACTIVE(a_xVectorId, nActive, error) 01927 endif 01928 endif 01929 if (error .LT. 0) return 01930 01931 if (nValues <= 0) then 01932 WRITE(FileUnit, *) 'No data to read in.' 01933 error = -1 01934 return 01935 endif 01936 01937 ! read in the number of times 01938 call XF_GET_DATASET_NUM_TIMES(a_xVectorId, nTimes, error) 01939 if (error < 0) then 01940 return 01941 endif 01942 01943 ! Read in the individual time values 01944 allocate(Times(nTimes)) 01945 01946 call XF_GET_DATASET_TIMES(a_xVectorId, nTimes, Times, error) 01947 if (error < 0) return 01948 01949 ! Read in the minimum and maximum values 01950 allocate(Minimums(nTimes)) 01951 allocate(Maximums(nTimes)) 01952 01953 call XF_GET_DATASET_MINS(a_xVectorId, nTimes, Minimums, error) 01954 if (error >= 0) then 01955 call XF_GET_DATASET_MAXS(a_xVectorId, nTimes, Maximums, error) 01956 endif 01957 if (error < 0) then 01958 deallocate(Times) 01959 deallocate(Minimums) 01960 deallocate(Maximums) 01961 return 01962 endif 01963 01964 allocate(Values(nComponents, nValues)) 01965 if (nActive .GT. 0) then 01966 allocate(Active(nActive)) 01967 endif 01968 01969 WRITE(FileUnit,*) 'Number Timesteps: ', nTimes 01970 WRITE(FileUnit,*) 'Number Values: ', nValues 01971 WRITE(FileUnit,*) 'Number Components: ', nComponents 01972 WRITE(FileUnit,*) 'Number Active: ', nActive 01973 01974 ! loop through the timesteps, read the values and active values and write 01975 ! them to the text file 01976 do iTime = 1, nTimes 01977 call XF_READ_VECTOR_VALUES_TIMESTEP(a_xVectorId, iTime, nValues, & 01978 nComponents, Values, error) 01979 if (error >= 0 .AND. nActive > 0) then 01980 call XF_READ_ACTIVITY_TIMESTEP(a_xVectorId, iTime, nActive, Active, error) 01981 endif 01982 01983 ! Write the time, min, max, values and active values to the text output 01984 ! file. 01985 WRITE(FileUnit,*) '' 01986 WRITE(FileUnit,*) 'Timestep at ', Times(iTime) 01987 WRITE(FileUnit,*) 'Min: ', Minimums(iTime) 01988 WRITE(FileUnit,*) 'Max: ', Maximums(iTime) 01989 01990 WRITE(FileUnit,*) 'Values:' 01991 do i=1, nValues 01992 WRITE(FileUnit,*) Values(1:nComponents,i:i) 01993 enddo 01994 WRITE(FileUnit,*) '' 01995 01996 WRITE(FileUnit,*) 'Activity:' 01997 WRITE(FileUnit,*) Active(1:nActive) 01998 WRITE(FileUnit,*) '' 01999 WRITE(FileUnit,*) '' 02000 02001 end do 02002 02003 if (allocated(Times)) then 02004 deallocate(Times) 02005 endif 02006 02007 if (allocated(Minimums)) then 02008 deallocate(Minimums) 02009 endif 02010 02011 if (allocated(Maximums)) then 02012 deallocate(Maximums) 02013 endif 02014 02015 if (allocated(Values)) then 02016 deallocate(Values) 02017 endif 02018 02019 if (allocated(Active)) then 02020 deallocate(Active) 02021 endif 02022 02023 return 02024 END SUBROUTINE 02025 ! tdiReadVector 02026 02027 END MODULE TestDatasets
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 ! // Extrude data 00306 if (nGridType .EQ. GRID_TYPE_CARTESIAN_EXTRUDED .OR. & 00307 nGridType .EQ. GRID_TYPE_CURVILINEAR_EXTRUDED) then 00308 call XF_GET_EXTRUDE_NUM_LAYERS(a_Id, nLayers, error) 00309 if (error < 0) then 00310 return 00311 endif 00312 00313 SELECT CASE(nExtrudeType) 00314 case (EXTRUDE_SIGMA) 00315 nExtrudeVals = nLayers 00316 case (EXTRUDE_CURV_AT_CORNERS) 00317 nExtrudeVals = (nCellsI + 1) * (nCellsJ + 1) * nLayers 00318 case (EXTRUDE_CURV_AT_CELLS) 00319 nExtrudeVals = nCellsI * nCellsJ * nLayers 00320 END SELECT 00321 00322 ALLOCATE(dExtrudeVals(nExtrudeVals)) 00323 00324 call XF_GET_EXTRUDE_VALUES(a_Id, nExtrudeVals, dExtrudeVals, error) 00325 if (error < 0) then 00326 return 00327 endif 00328 00329 WRITE(*,*) 'The extrude values are:' 00330 do i = 1, nExtrudeVals 00331 if (mod(i,5) == 0) then 00332 WRITE(a_Outfile,*) '' 00333 endif 00334 WRITE(a_Outfile,*) dExtrudeVals(i) 00335 enddo 00336 if (ALLOCATED(dExtrudeVals)) DEALLOCATE(dExtrudeVals) 00337 endif 00338 00339 return 00340 00341 END SUBROUTINE TG_READ_GRID 00342 00343 !**************************** 00344 !---------------------------------------------------------------------------- 00345 ! FUNCTION TG_WRITE_TEST_GRID_CART_2D 00346 ! PURPOSE Write a file that contains data for a 2D Cartesian Grid 00347 ! NOTES A picture of the grid is in the file (TestGridCart2D.gif) 00348 ! returns TRUE on success and FALSE on failure 00349 !---------------------------------------------------------------------------- 00350 SUBROUTINE TG_WRITE_TEST_GRID_CART_2D(Filename, error) 00351 CHARACTER(LEN=*), INTENT(IN) :: Filename 00352 INTEGER, INTENT(OUT) :: error 00353 INTEGER nDimensions 00354 INTEGER nCellsI, nCellsJ 00355 INTEGER nGridType 00356 INTEGER nCompOrigin, nUDir 00357 REAL(DOUBLE) dOriginX, dOriginY, dOriginZ 00358 INTEGER nOrientation 00359 REAL(DOUBLE) dBearing 00360 REAL(DOUBLE) PlanesI(5), PlanesJ(5) 00361 INTEGER i, j, iSpcZone 00362 INTEGER xFileId, xGridId, xCoordId 00363 INTEGER status 00364 INTEGER tmpOut1, tmpOut2 00365 00366 nDimensions = 2 00367 nCellsI = 5 00368 nCellsJ = 5 00369 nGridType = GRID_TYPE_CARTESIAN 00370 nCompOrigin = 4 00371 nUDir = -2 00372 dOriginX = 10.0 00373 dOriginY = 10.0 00374 dOriginZ = 0.0 00375 nOrientation = ORIENTATION_RIGHT_HAND 00376 dBearing = 45.0 00377 xFileId = NONE 00378 xGridId = NONE 00379 00380 ! Fill in the grid plane data with a constant size of 30 00381 do i = 1, nCellsI 00382 PlanesI(i) = i*30.0 00383 enddo 00384 do j = 1, nCellsJ 00385 PlanesJ(j) = j*30.0 00386 enddo 00387 00388 ! create the file 00389 call XF_CREATE_FILE(Filename, .TRUE., xFileId, status) 00390 if (status < 0) then 00391 error = -1 00392 return 00393 endif 00394 00395 ! create the group to store the grid 00396 call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CART2D_GROUP_NAME, xGridId, status) 00397 if (status < 0) then 00398 call XF_CLOSE_FILE(xFileId, error) 00399 error = -1 00400 return 00401 endif 00402 00403 ! Write the grid information to the file 00404 call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1) 00405 call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2) 00406 00407 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00408 call XF_CLOSE_GROUP(xGridId, error) 00409 call XF_CLOSE_FILE(xFileId, error) 00410 error = -1 00411 return 00412 endif 00413 00414 ! set origin and orientation 00415 call XF_SET_ORIGIN(xGridId, dOriginX, dOriginY, dOriginZ, tmpOut1) 00416 call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut2) 00417 00418 if ((tmpOut1 < 0) .OR. (tmpOut2 .LT. 0)) then 00419 call XF_CLOSE_GROUP(xGridId, error) 00420 call XF_CLOSE_FILE(xFileId, error) 00421 error = -1 00422 return 00423 endif 00424 00425 ! Set bearing 00426 call XF_SET_BEARING(xGridId, dBearing, tmpOut1) 00427 if (tmpOut1 < 0) then 00428 call XF_CLOSE_GROUP(xGridId, error) 00429 call XF_CLOSE_FILE(xFileId, error) 00430 error = -1 00431 return 00432 endif 00433 00434 ! Set computational origin 00435 call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1) 00436 if (tmpOut1 < 0) then 00437 call XF_CLOSE_GROUP(xGridId, error) 00438 call XF_CLOSE_FILE(xFileId, error) 00439 error = -1 00440 return 00441 endif 00442 00443 ! Set u direction 00444 call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1) 00445 if (tmpOut1 < 0) then 00446 call XF_CLOSE_GROUP(xGridId, error) 00447 call XF_CLOSE_FILE(xFileId, error) 00448 error = -1 00449 return 00450 endif 00451 00452 ! Write the grid geometry to the file 00453 ! Set the number of cells in each direction 00454 call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1) 00455 call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2) 00456 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00457 call XF_CLOSE_GROUP(xGridId, error) 00458 call XF_CLOSE_FILE(xFileId, error) 00459 error = -1 00460 return 00461 endif 00462 00463 ! Set the grid plane locations 00464 call XF_SET_GRID_COORDS_I(xGridId, nCellsI, PlanesI, tmpOut1) 00465 call XF_SET_GRID_COORDS_J(xGridId, nCellsJ, PlanesJ, tmpOut2) 00466 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00467 call XF_CLOSE_GROUP(xGridId, error) 00468 call XF_CLOSE_FILE(xFileId, error) 00469 error = -1 00470 return 00471 endif 00472 00473 ! Write Coordinate file - for GridCart2D, we will set the coordinate system 00474 ! to be State Plane NAD27. 00475 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 00476 if (status < 0) then 00477 call XF_CLOSE_GROUP(xGridId, error) 00478 call XF_CLOSE_FILE(xFileId, error) 00479 error = status 00480 return 00481 endif 00482 00483 iSpcZone = 3601 ! Oregon North 00484 00485 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_STATE_PLANE_NAD27, error) 00486 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_US_FEET, error) 00487 00488 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 00489 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_US_FEET, error) 00490 00491 ! write additional information 00492 call XF_SET_SPC_ZONE(xCoordId, iSpcZone, error) 00493 00494 call XF_CLOSE_GROUP(xCoordId, error) 00495 xCoordId = 0 00496 00497 ! release memory 00498 call XF_CLOSE_GROUP(xGridId, error) 00499 call XF_CLOSE_FILE(xFileId, error) 00500 return 00501 00502 END SUBROUTINE TG_WRITE_TEST_GRID_CART_2D 00503 00504 !**************************** 00505 !------------------------------------------------------------------------------ 00506 ! FUNCTION tgWriteTestGridCurv2D 00507 ! PURPOSE Write a file that contains data for a 2D Curvilinear Grid 00508 ! NOTES A picture of the grid is TestGridCurv2D.gif 00509 ! returns TRUE on success and FALSE on failure 00510 !------------------------------------------------------------------------------ 00511 SUBROUTINE TG_WRITE_TEST_GRID_CURV_2D(Filename, Compression, error) 00512 CHARACTER(LEN=*), INTENT(IN) :: Filename 00513 INTEGER, INTENT(IN) :: Compression 00514 INTEGER, INTENT(OUT) :: error 00515 INTEGER nDimensions 00516 INTEGER nCompOrigin, nUDir 00517 INTEGER nCellsI, nCellsJ 00518 INTEGER nCells 00519 INTEGER nCorners 00520 INTEGER nGridType 00521 REAL(DOUBLE) xVals(16), yVals(16) !There are 16 corners 00522 INTEGER i 00523 INTEGER xFileId, xGridId, xPropId, xDatasetsId, xScalarId 00524 INTEGER xCoordId 00525 REAL(DOUBLE) dNullValue(1) 00526 INTEGER nOrientation 00527 REAL fDsetCellVals(6) !For cell-centered dataset 00528 REAL fDsetCornerVals(12) !For corner-centered dataset 00529 REAL(DOUBLE) tempdouble, dCppLat, dCppLon 00530 INTEGER*1 bDsetCellActive(6) 00531 INTEGER*1 bDsetCornerActive(12) 00532 INTEGER status 00533 INTEGER tmpOut1, tmpOut2 00534 00535 nDimensions = 2 00536 nCompOrigin = 1 00537 nUDir = 1; 00538 nCellsI = 2 00539 nCellsJ = 3 00540 nCells = nCellsI*nCellsJ 00541 nCorners = (nCellsI + 1)*(nCellsJ + 1) 00542 nGridType = GRID_TYPE_CURVILINEAR 00543 xFileId = NONE 00544 xGridId = NONE 00545 xPropId = NONE 00546 xDatasetsId = NONE 00547 xScalarId = NONE 00548 dNullValue(1) = -999.0 00549 nOrientation = ORIENTATION_RIGHT_HAND 00550 00551 ! There is no cell in the top right corner so we have a NullValue for 00552 ! the top right corner 00553 00554 ! xValues row by row 00555 xVals(1) = 0.0 00556 xVals(2) = 7.5 00557 xVals(3) = 15.0 00558 xVals(4) = 2.5 00559 xVals(5) = 10.0 00560 xVals(6) = 17.5 00561 xVals(7) = 3.5 00562 xVals(8) = 11.0 00563 xVals(9) = 18.5 00564 xVals(10) = 0.0 00565 xVals(11) = 7.5 00566 xVals(12) = dNullValue(1) 00567 00568 ! yValues row by row 00569 yVals(1) = 0.0 00570 yVals(2) = 0.0 00571 yVals(3) = 0.0 00572 yVals(4) = 10.0 00573 yVals(5) = 10.0 00574 yVals(6) = 10.0 00575 yVals(7) = 20.0 00576 yVals(8) = 20.0 00577 yVals(9) = 20.0 00578 yVals(10) = 30.0 00579 yVals(11) = 30.0 00580 yVals(12) = dNullValue(1) 00581 00582 ! cell centered velocity dataset values 00583 fDsetCellVals(1) = 2.1 00584 fDsetCellVals(2) = 2.0 00585 fDsetCellVals(3) = 1.9 00586 fDsetCellVals(4) = 2.3 00587 fDsetCellVals(5) = 2.5 00588 fDsetCellVals(6) = dNullValue(1) 00589 00590 ! all are active except the last value 00591 do i = 1, nCells 00592 bDsetCellActive(i) = 1 00593 enddo 00594 bDsetCellActive(nCells) = 0 00595 00596 ! corner centered elevation dataset values 00597 fDsetCornerVals(1) = 1.0 00598 fDsetCornerVals(2) = 0.8 00599 fDsetCornerVals(3) = 1.2 00600 fDsetCornerVals(4) = 1.4 00601 fDsetCornerVals(5) = 1.8 00602 fDsetCornerVals(6) = 2.2 00603 fDsetCornerVals(7) = 1.8 00604 fDsetCornerVals(8) = 1.4 00605 fDsetCornerVals(9) = 2.0 00606 fDsetCornerVals(10) = 1.0 00607 fDsetCornerVals(11) = 1.8 00608 fDsetCornerVals(12) = 2.2 00609 00610 ! all are active except the last value 00611 do i = 1, nCorners 00612 bDsetCornerActive(i) = 1 00613 enddo 00614 bDsetCornerActive(nCorners) = 0 00615 00616 ! create the file 00617 call XF_CREATE_FILE(Filename, .TRUE., xFileId, status) 00618 if (status < 0) then 00619 error = -1 00620 return 00621 endif 00622 00623 ! create the group to store the grid 00624 call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CURV2D_GROUP_NAME, xGridId, status) 00625 if (status < 0) then 00626 call XF_CLOSE_FILE(xFileId, error) 00627 error = -1 00628 return 00629 endif 00630 00631 ! Write the grid information to the file 00632 call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1) 00633 call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2) 00634 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00635 call XF_CLOSE_GROUP(xGridId, error) 00636 call XF_CLOSE_FILE(xFileId, error) 00637 error = -1 00638 return 00639 endif 00640 00641 ! set orientation 00642 call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut1) 00643 if (tmpOut1 < 0 ) then 00644 call XF_CLOSE_GROUP(xGridId, error) 00645 call XF_CLOSE_FILE(xFileId, error) 00646 error = -1 00647 return 00648 endif 00649 00650 ! Set computational origin 00651 call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1) 00652 if (tmpOut1 < 0 ) then 00653 call XF_CLOSE_GROUP(xGridId, error) 00654 call XF_CLOSE_FILE(xFileId, error) 00655 error = -1 00656 return 00657 endif 00658 00659 ! Set u direction 00660 call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1) 00661 if (tmpOut1 < 0 ) then 00662 call XF_CLOSE_GROUP(xGridId, error) 00663 call XF_CLOSE_FILE(xFileId, error) 00664 error = -1 00665 return 00666 endif 00667 00668 ! Write the grid geometry to the file 00669 ! Set the number of cells in each direction 00670 call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1) 00671 call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2) 00672 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00673 call XF_CLOSE_GROUP(xGridId, error) 00674 call XF_CLOSE_FILE(xFileId, error) 00675 error = -1 00676 return 00677 endif 00678 ! Set a NullValue. This is used to identify locations in the grid that are 00679 ! not being used. In our case no geometry is defined for the top right 00680 ! corner. 00681 call XF_CREATE_GRID_PROPERTY_GROUP(xGridId, xPropId, tmpOut1) 00682 if (xPropId < 0) then 00683 call XF_CLOSE_GROUP(xGridId, error) 00684 call XF_CLOSE_FILE(xFileId, error) 00685 error = -1 00686 return 00687 endif 00688 00689 call XF_WRITE_PROPERTY_DOUBLE(xPropId, PROP_NULL_VALUE, 1, dNullValue, NONE, & 00690 tmpOut1) 00691 if (tmpOut1 < 0) then 00692 call XF_CLOSE_GROUP(xPropId, error) 00693 call XF_CLOSE_GROUP(xGridId, error) 00694 call XF_CLOSE_FILE(xFileId, error) 00695 error = -1 00696 return 00697 endif 00698 call XF_CLOSE_GROUP(xPropId, error) 00699 00700 ! Set the grid plane locations 00701 call XF_SET_GRID_COORDS_I(xGridId, nCorners, xVals, tmpOut1) 00702 call XF_SET_GRID_COORDS_J(xGridId, nCorners, yVals, tmpOut2) 00703 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00704 call XF_CLOSE_GROUP(xGridId, error) 00705 call XF_CLOSE_FILE(xFileId, error) 00706 error = -1 00707 return 00708 endif 00709 00710 ! Create the datasets group 00711 call XF_CREATE_GENERIC_GROUP(xGridId, 'Datasets', xDatasetsId, tmpOut1) 00712 if (tmpOut1 < 0) then 00713 call XF_CLOSE_GROUP(xGridId, error) 00714 call XF_CLOSE_FILE(xFileId, error) 00715 error = -1 00716 return 00717 endif 00718 00719 ! Create the cell-centered dataset 00720 call XF_CREATE_SCALAR_DATASET(xDatasetsId, 'Velocity Mag', 'ft/s', TS_MINUTES, & 00721 Compression, xScalarId, tmpOut1) 00722 if (tmpOut1 < 0) then 00723 call XF_CLOSE_GROUP(xDatasetsId, error) 00724 call XF_CLOSE_GROUP(xGridId, error) 00725 call XF_CLOSE_FILE(xFileId, error) 00726 error = -1 00727 return 00728 endif 00729 00730 ! specify that the dataset is cell-centered 00731 call XF_SCALAR_DATA_LOCATION(xScalarId, GRID_LOC_CENTER, tmpOut1) 00732 if (tmpOut1 < 0) then 00733 call XF_CLOSE_GROUP(xScalarId, error) 00734 call XF_CLOSE_GROUP(xDatasetsId, error) 00735 call XF_CLOSE_GROUP(xGridId, error) 00736 call XF_CLOSE_FILE(xFileId, error) 00737 error = -1 00738 return 00739 endif 00740 00741 ! Write the data 00742 ! set a temporary variable to pass into the function 00743 tempdouble = 0.0 00744 call XF_WRITE_SCALAR_TIMESTEP(xScalarId, tempdouble, nCells, fDsetCellVals, tmpOut1) 00745 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarId, nCells, bDsetCellActive, tmpOut2) 00746 if ((tmpOut1 < 0) .OR. (tmpOut1 < 0)) then 00747 call XF_CLOSE_GROUP(xScalarId, error) 00748 call XF_CLOSE_GROUP(xDatasetsId, error) 00749 call XF_CLOSE_GROUP(xGridId, error) 00750 call XF_CLOSE_FILE(xFileId, error) 00751 error = -1 00752 return 00753 endif 00754 00755 ! close the cell-centered dataset 00756 call XF_CLOSE_GROUP(xScalarId, error) 00757 00758 ! Create the corner-centered dataset 00759 call XF_CREATE_SCALAR_DATASET(xDatasetsId, 'elevation', 'ft', TS_MINUTES, & 00760 Compression, xScalarId, tmpOut1) 00761 if (tmpOut1 < 0) then 00762 call XF_CLOSE_GROUP(xDatasetsId, error) 00763 call XF_CLOSE_GROUP(xGridId, error) 00764 call XF_CLOSE_FILE(xFileId, error) 00765 error = -1 00766 return 00767 endif 00768 00769 ! specify that the dataset is corner-centered 00770 call XF_SCALAR_DATA_LOCATION(xScalarId, GRID_LOC_CORNER, tmpOut1) 00771 if (tmpOut1 < 0) then 00772 call XF_CLOSE_GROUP(xScalarId, error) 00773 call XF_CLOSE_GROUP(xDatasetsId, error) 00774 call XF_CLOSE_GROUP(xGridId, error) 00775 call XF_CLOSE_FILE(xFileId, error) 00776 error = -1 00777 return 00778 endif 00779 00780 ! Write the data 00781 ! set a temporary variable to pass into the function 00782 tempdouble = 0.0 00783 call XF_WRITE_SCALAR_TIMESTEP(xScalarId, tempdouble, nCorners, fDsetCornerVals, tmpOut1) 00784 call XF_WRITE_ACTIVITY_TIMESTEP(xScalarId, nCorners, bDsetCornerActive, tmpOut2) 00785 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00786 call XF_CLOSE_GROUP(xScalarId, error) 00787 call XF_CLOSE_GROUP(xDatasetsId, error) 00788 call XF_CLOSE_GROUP(xGridId, error) 00789 call XF_CLOSE_FILE(xFileId, error) 00790 error = -1 00791 return 00792 endif 00793 00794 ! Write Coordinate file - for GridCurv2D, we will set the coordinate system 00795 ! to be CPP, with CPP Latitude and CPP Longitude settings written 00796 ! to the file. 00797 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 00798 if (status < 0) then 00799 call XF_CLOSE_GROUP(xScalarId, error) 00800 call XF_CLOSE_GROUP(xDatasetsId, error) 00801 call XF_CLOSE_GROUP(xGridId, error) 00802 call XF_CLOSE_FILE(xFileId, error) 00803 error = status 00804 return 00805 endif 00806 00807 dCppLat = 56.0; ! Made-up value 00808 dCppLon = 23.0; ! Made-up value 00809 00810 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_CPP, error) 00811 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_METERS, error) 00812 00813 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 00814 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_METERS, error) 00815 00816 ! write additional information 00817 call XF_SET_CPP_LAT(xCoordId, dCppLat, error) 00818 call XF_SET_CPP_LON(xCoordId, dCppLon, error) 00819 00820 call XF_CLOSE_GROUP(xCoordId, error) 00821 xCoordId = 0 00822 00823 ! release memory 00824 call XF_CLOSE_GROUP(xScalarId, error) 00825 call XF_CLOSE_GROUP(xDatasetsId, error) 00826 call XF_CLOSE_GROUP(xGridId, error) 00827 call XF_CLOSE_FILE(xFileId, error) 00828 return 00829 00830 END SUBROUTINE TG_WRITE_TEST_GRID_CURV_2D 00831 00832 !**************************** 00833 !------------------------------------------------------------------------------ 00834 ! FUNCTION tgWriteTestGridCart3D 00835 ! PURPOSE Write a file that contains data for a 2D Cartesian Grid 00836 ! NOTES A picture of the grid is in the file (TestGridCart2D.gif) 00837 ! returns TRUE on success and FALSE on failure 00838 !------------------------------------------------------------------------------ 00839 SUBROUTINE TG_WRITE_TEST_GRID_CART_3D(Filename, Compression, error) 00840 CHARACTER(LEN=*), INTENT(IN) :: Filename 00841 INTEGER, INTENT(IN) :: Compression 00842 INTEGER, INTENT(OUT) :: error 00843 INTEGER nDimensions 00844 INTEGER nCompOrigin, nUDir 00845 INTEGER nCellsI, nCellsJ, nCellsK 00846 INTEGER nGridType 00847 REAL(DOUBLE) dOriginX, dOriginY, dOriginZ 00848 INTEGER nOrientation 00849 REAL(DOUBLE) dBearing, dDip, dRoll 00850 REAL(DOUBLE) PlanesI(5), PlanesJ(5), PlanesK(3) 00851 INTEGER i, j, status, iSpcZone 00852 INTEGER xFileId, xGridId, xPropId, xCoordId 00853 INTEGER nCells 00854 INTEGER Active(75) 00855 INTEGER tmpOut1, tmpOut2, tmpOut3 00856 00857 nDimensions = 3 00858 nCompOrigin = 8 00859 nUDir = -2 00860 nCellsI = 5 00861 nCellsJ = 5 00862 nCellsK = 3 00863 nGridType = GRID_TYPE_CARTESIAN 00864 dOriginX = 10.0 00865 dOriginY = 10.0 00866 dOriginZ = 0.0 00867 nOrientation = ORIENTATION_RIGHT_HAND 00868 dBearing = 45.0 00869 dDip = 0.0 00870 dRoll = 0.0 00871 xFileId = NONE 00872 xGridId = NONE 00873 xPropId = NONE 00874 nCells = nCellsI * nCellsJ * nCellsK 00875 00876 ! Fill in the grid plane data with a constant size of 30 00877 do i = 1, nCellsI 00878 PlanesI(i) = i*30.0 00879 enddo 00880 do j = 1, nCellsJ 00881 PlanesJ(j) = j*30.0 00882 enddo 00883 do j = 1, nCellsK 00884 PlanesK(j) = j*30.0 00885 enddo 00886 00887 ! fill in the activity array 00888 ! default array to active 00889 do i = 1, nCells 00890 Active(i) = 1 00891 enddo 00892 00893 ! two cells are inactive (identified by array index) 00894 ! i = 0, j = 0, k = 0 and i = 4, j = 4, k = 0 00895 Active(1) = 0 00896 Active(4*nCellsJ*nCellsK+4*nCellsK+1) = 0 00897 00898 ! create the file 00899 call XF_CREATE_FILE(Filename, .TRUE., xFileId, tmpOut1) 00900 if (tmpOut1 < 0) then 00901 error = -1 00902 return 00903 endif 00904 00905 ! create the group to store the grid 00906 call XF_CREATE_GROUP_FOR_GRID(xFileId, GRID_CART3D_GROUP_NAME, xGridId, tmpOut1) 00907 if (tmpOut1 < 0) then 00908 call XF_CLOSE_FILE(xFileId, error) 00909 error = -1 00910 return 00911 endif 00912 00913 ! Write the grid information to the file 00914 call XF_SET_GRID_TYPE(xGridId, nGridType, tmpOut1) 00915 call XF_SET_NUMBER_OF_DIMENSIONS(xGridId, nDimensions, tmpOut2) 00916 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00917 call XF_CLOSE_GROUP(xGridId, error) 00918 call XF_CLOSE_FILE(xFileId, error) 00919 error = -1 00920 return 00921 endif 00922 00923 ! set origin and orientation 00924 call XF_SET_ORIGIN(xGridId, dOriginX, dOriginY, dOriginZ, tmpOut1) 00925 call XF_SET_ORIENTATION(xGridId, nOrientation, tmpOut2) 00926 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0)) then 00927 call XF_CLOSE_GROUP(xGridId, error) 00928 call XF_CLOSE_FILE(xFileId, error) 00929 error = -1 00930 return 00931 endif 00932 00933 ! Set bearing, dip and roll 00934 call XF_SET_BEARING(xGridId, dBearing, tmpOut1) 00935 call XF_SET_DIP(xGridId, dDip, tmpOut2) 00936 call XF_SET_ROLL(xGridId, dRoll, tmpOut3) 00937 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then 00938 call XF_CLOSE_GROUP(xGridId, error) 00939 call XF_CLOSE_FILE(xFileId, error) 00940 error = -1 00941 return 00942 endif 00943 00944 ! Set computational origin 00945 call XF_SET_COMPUTATIONAL_ORIGIN(xGridId, nCompOrigin, tmpOut1) 00946 if (tmpOut1 < 0) then 00947 call XF_CLOSE_GROUP(xGridId, error) 00948 call XF_CLOSE_FILE(xFileId, error) 00949 error = -1 00950 return 00951 endif 00952 00953 ! Set u direction 00954 call XF_SET_U_DIRECTION(xGridId, nUDir, tmpOut1) 00955 if (tmpOut1 < 0) then 00956 call XF_CLOSE_GROUP(xGridId, error) 00957 call XF_CLOSE_FILE(xFileId, error) 00958 error = -1 00959 return 00960 endif 00961 00962 ! Write the grid geometry to the file 00963 ! Set the number of cells in each direction 00964 call XF_SET_NUMBER_CELLS_IN_I(xGridId, nCellsI, tmpOut1) 00965 call XF_SET_NUMBER_CELLS_IN_J(xGridId, nCellsJ, tmpOut2) 00966 call XF_SET_NUMBER_CELLS_IN_K(xGridId, nCellsK, tmpOut3) 00967 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then 00968 call XF_CLOSE_GROUP(xGridId, error) 00969 call XF_CLOSE_FILE(xFileId, error) 00970 error = -1 00971 return 00972 endif 00973 00974 ! Set the grid plane locations 00975 call XF_SET_GRID_COORDS_I(xGridId, nCellsI, PlanesI, tmpOut1) 00976 call XF_SET_GRID_COORDS_J(xGridId, nCellsJ, PlanesJ, tmpOut2) 00977 call XF_SET_GRID_COORDS_K(xGridId, nCellsK, PlanesK, tmpOut3) 00978 00979 if ((tmpOut1 < 0) .OR. (tmpOut2 < 0) .OR. (tmpOut3 < 0)) then 00980 call XF_CLOSE_GROUP(xGridId, error) 00981 call XF_CLOSE_FILE(xFileId, error) 00982 error = -1 00983 return 00984 endif 00985 00986 ! Write the activity array 00987 call XF_CREATE_GRID_CELL_PROP_GRP(xGridId, xPropId, tmpOut1) 00988 if (xPropId < 0) then 00989 call XF_CLOSE_GROUP(xGridId, error) 00990 call XF_CLOSE_FILE(xFileId, error) 00991 error = -1 00992 return 00993 endif 00994 00995 call XF_WRITE_PROPERTY_INT(xPropId, PROP_ACTIVITY, nCells, Active, & 00996 Compression, tmpOut1) 00997 00998 if (tmpOut1 < 0) then 00999 call XF_CLOSE_GROUP(xPropId, error) 01000 call XF_CLOSE_GROUP(xGridId, error) 01001 call XF_CLOSE_FILE(xFileId, error) 01002 error = -1 01003 return 01004 endif 01005 01006 call XF_CLOSE_GROUP(xPropId, error) 01007 01008 ! Write Coordinate file - for GridCart3D, we will set the coordinate system 01009 ! to be State Plane NAD27. 01010 call XF_CREATE_COORDINATE_GROUP(xFileId, xCoordId, status) 01011 if (status < 0) then 01012 call XF_CLOSE_GROUP(xGridId, error) 01013 call XF_CLOSE_FILE(xFileId, error) 01014 error = status 01015 endif 01016 01017 iSpcZone = 3601; ! Oregon North 01018 01019 call XF_SET_HORIZ_DATUM(xCoordId, HORIZ_DATUM_STATE_PLANE_NAD27, error) 01020 call XF_SET_HORIZ_UNITS(xCoordId, COORD_UNITS_US_FEET, error) 01021 01022 call XF_SET_VERT_DATUM(xCoordId, VERT_DATUM_LOCAL, error) 01023 call XF_SET_VERT_UNITS(xCoordId, COORD_UNITS_US_FEET, error) 01024 01025 ! write additional information 01026 call XF_SET_SPC_ZONE(xCoordId, iSpcZone, error) 01027 01028 call XF_CLOSE_GROUP(xCoordId, error) 01029 xCoordId = 0 01030 01031 ! release memory 01032 call XF_CLOSE_GROUP(xGridId, error) 01033 call XF_CLOSE_FILE(xFileId, error) 01034 return 01035 01036 END SUBROUTINE TG_WRITE_TEST_GRID_CART_3D 01037 01038 END MODULE TestGrid
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_A_PIECES_FILE_F = 'ScalarA_Pieces_f.h5' 00028 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_EDITED_FILE_F = 'ScalarA_edited_f.h5' 00029 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_EDITED_TEXT_F = 'ScalarA_edited_f.txt' 00030 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_PIECES_ALT_FILE_F = 'ScalarA_Pieces_alt_f.h5' 00031 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_FILE_F = 'ScalarB_f.h5' 00032 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_TEXT_F = 'ScalarB_f.txt' 00033 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_FILE_F = 'Vector2D_A_f.h5' 00034 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_TEXT_F = 'Vector2D_A_f.txt' 00035 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_PIECES_FILE_F = 'Vector2D_A_Pieces_f.h5' 00036 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_FILE_F = 'Vector2D_B_f.h5' 00037 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_TEXT_F = 'Vector2D_B_f.txt' 00038 00039 CHARACTER(LEN=*), PARAMETER :: MESH_A_FILE_C = 'mesh_a_file_c.h5' 00040 CHARACTER(LEN=*), PARAMETER :: MESH_B_FILE_C = 'mesh_b_file_c.h5' 00041 CHARACTER(LEN=*), PARAMETER :: MESH_A_OUT_CF = 'mesh_a_file_cf.txt' 00042 CHARACTER(LEN=*), PARAMETER :: MESH_B_OUT_CF = 'mesh_b_file_cf.txt' 00043 00044 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_FILE_C = 'grid_cart2d_a_file_c.h5' 00045 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_FILE_C = 'grid_curv2d_a_file_c.h5' 00046 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_FILE_C = 'grid_cart3d_a_file_c.h5' 00047 00048 CHARACTER(LEN=*), PARAMETER :: GRID_CART2D_A_OUT_CF = 'grid_cart2d_a_out_cf.txt' 00049 CHARACTER(LEN=*), PARAMETER :: GRID_CURV2D_A_OUT_CF = 'grid_curv2d_a_out_cf.txt' 00050 CHARACTER(LEN=*), PARAMETER :: GRID_CART3D_A_OUT_CF = 'grid_cart3d_a_out_cf.txt' 00051 00052 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_FILE_C = 'ScalarA_c.h5' 00053 CHARACTER(LEN=*), PARAMETER :: SCALAR_A_TEXT_CF = 'ScalarA_cf.txt' 00054 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_FILE_C = 'ScalarB_c.h5' 00055 CHARACTER(LEN=*), PARAMETER :: SCALAR_B_TEXT_CF = 'ScalarB_cf.txt' 00056 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_FILE_C = 'Vector2D_A_c.h5' 00057 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_A_TEXT_CF = 'Vector2D_A_cf.txt' 00058 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_FILE_C = 'Vector2D_B_c.h5' 00059 CHARACTER(LEN=*), PARAMETER :: VECTOR2D_B_TEXT_CF = 'Vector2D_B_cf.txt' 00060 00061 CHARACTER(LEN=*), PARAMETER :: CALENDAR_OUT_F = 'Calendar_f.txt' 00062 00063 CHARACTER(LEN=*), PARAMETER :: GEOMPATH_A_FILE_F = 'Geompath_a_file_f.h5' 00064 CHARACTER(LEN=*), PARAMETER :: GEOMPATH_A_FILE_F_OUT = 'Geompath_a_file_f_out.txt' 00065 00066 CHARACTER(LEN=*), PARAMETER :: TT_MULTIDATASET_FILE_F = 'TT_MultiDataSet_f.h5' 00067 CHARACTER(LEN=*), PARAMETER :: TT_SCALAR_A_FILE_F = 'TT_ScalarA_f.h5' 00068 CHARACTER(LEN=*), PARAMETER :: TT_SCALAR_A_TEXT_F = 'TT_ScalarA_f.txt' 00069 CHARACTER(LEN=*), PARAMETER :: TT_VECTOR2D_A_FILE_F = 'TT_Vector2D_A_f.h5' 00070 00071 ! Overwrite options in the function xfSetupToWriteDatasets 00072 !INTEGER,PARAMETER :: XF_OVERWRITE_CLEAR_FILE = 1 00073 !INTEGER,PARAMETER :: XF_OVERWRITE_CLEAR_DATASET_GROUP = 2 00074 !INTEGER,PARAMETER :: XF_OVERWRITE_NONE = 3 00075 00076 END MODULE TestDefs 00077 00078 MODULE TestsModule 00079 00080 USE XMDF 00081 USE XMDFDEFS 00082 USE TestTimestep 00083 USE TestDatasets 00084 USE TestMesh 00085 USE TestGrid 00086 USE TestDefs 00087 USE TestGeomPaths 00088 00089 CONTAINS 00090 00091 !************************** 00092 !----------------------------------------------------------------------------- 00093 ! SUBROUTINE TXI_TEST_TIMESTEPS 00094 ! PURPOSE test to see if the code can read timestepfiles 00095 ! NOTES 00096 !------------------------------------------------------------------------------ 00097 SUBROUTINE TXI_TEST_TIMESTEPS(error) 00098 INTEGER, INTENT(OUT) :: error 00099 INTEGER status, compression 00100 INTEGER MultiFileId, MultiGroupId 00101 INTEGER NumOpen 00102 00103 CHARACTER(LEN=37) SdoGuid 00104 00105 SdoGuid = '73289C80-6235-4fdc-9649-49E4F5AEB676' 00106 00107 status = 1 00108 compression = NONE 00109 ! 'Path' should be able to be blank, but now it creates errors if it's blank 00110 call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', & 00111 SdoGuid, XF_OVERWRITE_CLEAR_FILE, MultiFileId, MultiGroupId, error) 00112 00113 ! Write coordinates to multidatasets 00114 call TT_WRITE_COORDS_TO_MULTI(MultiFileId, error) 00115 00116 ! Write scalar A and Vector A to multidatasets. 00117 call TT_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error) 00118 00119 call TT_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error) 00120 00121 call XF_CLOSE_GROUP(MultiGroupId, status) 00122 call XF_CLOSE_FILE(MultiFileId, status) 00123 00124 WRITE(*,*) 'Done writing multiple datasets...' 00125 00126 ! scalar datasets 00127 call TT_WRITE_SCALAR_A(TT_SCALAR_A_FILE_F, compression, status) 00128 if (status < 0) then 00129 error = status 00130 return 00131 endif 00132 00133 WRITE(*,*) 'Done writing scalar datasets...' 00134 00135 ! vector datasets 00136 call TT_WRITE_VECTOR2D_A(TT_VECTOR2D_A_FILE_F, compression, status) 00137 if (status < 0) then 00138 WRITE(*,*) 'Error writing dataset vector2D_A.' 00139 error = status 00140 return 00141 endif 00142 00143 WRITE(*,*) 'Done writing vector datasets...' 00144 00145 WRITE(*,*) 'Write edited scalar datasets...' 00146 call TD_EDIT_SCALAR_A_VALUES(SCALAR_A_EDITED_FILE_F, compression, status); 00147 if (status < 0) then 00148 error = status 00149 return 00150 endif 00151 00152 WRITE(*,*) 'Done writing datasets...' 00153 00154 ! Read the files back in 00155 call TXI_READ_X_FORMAT_FILE(TT_SCALAR_A_FILE_F, SCALAR_A_TEXT_F, status) 00156 if (status < 0) then 00157 WRITE(*,*) 'Error reading SCALAR A File (see TXI_READ_X_FORMAT_FILE)' 00158 error = status 00159 return 00160 endif 00161 00162 call TXI_READ_X_FORMAT_FILE(SCALAR_A_EDITED_FILE_F, SCALAR_A_EDITED_TEXT_F, status) 00163 if (status < 0) then 00164 WRITE(*,*) 'Error reading SCALAR A Edited File (see TXI_READ_X_FORMAT_FILE)' 00165 error = status 00166 return 00167 endif 00168 00169 call TXI_READ_X_FORMAT_FILE(TT_VECTOR2D_A_FILE_F, VECTOR2D_A_TEXT_F, status) 00170 if (status < 0) then 00171 WRITE(*,*) 'Error reading VECTOR A Format File' 00172 error = status 00173 return 00174 endif 00175 00176 call TXI_READ_X_FORMAT_FILE(TT_MULTIDATASET_FILE_F, MULTIDATASET_TEXT_F, status) 00177 if (status < 0) then 00178 WRITE(*,*) 'Error reading Multidataset File (see TXI_READ_X_FORMAT_FILE)' 00179 error = status 00180 return 00181 endif 00182 00183 WRITE(*,*) 'Done reading datasets...' 00184 00185 call XF_GET_NUM_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, NumOpen, error) 00186 00187 call XFI_CLOSE_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, error) 00188 00189 call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', & 00190 SdoGuid, XF_OVERWRITE_CLEAR_DATASET_GRP, MultiFileId, MultiGroupId, & 00191 error) 00192 00193 call TT_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error) 00194 00195 call XF_SETUP_TO_WRITE_DATASETS(TT_MULTIDATASET_FILE_F, 'Multidatasets','', & 00196 SdoGuid, XF_OVERWRITE_NONE, MultiFileId, MultiGroupId, error) 00197 00198 call TT_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error) 00199 00200 ! Test reading information at index for multiple timesteps 00201 call TT_READ_SCALAR_A_INDEX(TT_SCALAR_A_FILE_F, 4, status) 00202 if (status < 0) then 00203 error = status 00204 return 00205 endif 00206 00207 WRITE(*,*) 'Done reading scalar data at index.' 00208 00209 call TT_READ_VECTOR2D_A_INDEX(TT_VECTOR2D_A_FILE_F, 6, status) 00210 if (status < 0) then 00211 error = status 00212 return 00213 endif 00214 00215 WRITE(*,*) 'Done reading vector data at index.' 00216 00217 call TT_READ_ACTIVITY_SCALAR_A_INDEX(TT_SCALAR_A_FILE_F, 6, status) 00218 if (status < 0) then 00219 error = status 00220 return 00221 endif 00222 00223 error = status 00224 return 00225 00226 END SUBROUTINE 00227 00228 00229 !************************** 00230 !----------------------------------------------------------------------------- 00231 ! SUBROUTINE TXI_TEST_DATASETS 00232 ! PURPOSE test to see if the code can read datasetfiles 00233 ! NOTES 00234 !------------------------------------------------------------------------------ 00235 SUBROUTINE TXI_TEST_DATASETS(error) 00236 INTEGER, INTENT(OUT) :: error 00237 INTEGER status, compression 00238 INTEGER MultiFileId, MultiGroupId 00239 INTEGER NumOpen 00240 INTEGER, PARAMETER :: nIndices = 3 00241 INTEGER, DIMENSION(nIndices) :: indices 00242 00243 CHARACTER(LEN=37) SdoGuid 00244 00245 SdoGuid = '73289C80-6235-4fdc-9649-49E4F5AEB676' 00246 00247 status = 1 00248 compression = NONE 00249 ! 'Path' should be able to be blank, but now it creates errors if it's blank 00250 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', & 00251 SdoGuid, XF_OVERWRITE_CLEAR_FILE, MultiFileId, MultiGroupId, error) 00252 00253 ! Write coordinates to multidatasets 00254 call TD_WRITE_COORDS_TO_MULTI(MultiFileId, error) 00255 00256 ! Write scalar A and Vector A to multidatasets. 00257 call TD_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error) 00258 00259 call TD_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error) 00260 00261 call XF_CLOSE_GROUP(MultiGroupId, status) 00262 call XF_CLOSE_FILE(MultiFileId, status) 00263 00264 WRITE(*,*) 'Done writing multiple datasets...' 00265 00266 ! scalar datasets 00267 call TD_WRITE_SCALAR_A(SCALAR_A_FILE_F, compression, status) 00268 if (status < 0) then 00269 error = status 00270 return 00271 endif 00272 00273 call TD_WRITE_SCALAR_A_PIECES(SCALAR_A_PIECES_FILE_F, compression, status) 00274 if (status < 0) then 00275 error = status 00276 return 00277 endif 00278 00279 call TD_WRITE_SCALAR_A_PIECES_ALT_MIN_MAX(SCALAR_A_PIECES_ALT_FILE_F, & 00280 compression, status) 00281 if (status < 0) then 00282 error = status 00283 return 00284 endif 00285 00286 WRITE(*,*) 'Done writing scalar datasets...' 00287 00288 ! vector datasets 00289 call TD_WRITE_VECTOR2D_A(VECTOR2D_A_FILE_F, compression, status) 00290 if (status < 0) then 00291 WRITE(*,*) 'Error writing dataset vector2D_A.' 00292 error = status 00293 return 00294 endif 00295 00296 call TD_WRITE_VECTOR2D_A_PIECES(VECTOR2D_A_PIECES_FILE_F, compression, status) 00297 if (status < 0) then 00298 WRITE(*,*) 'Error writing dataset vector2D_A.' 00299 error = status 00300 return 00301 endif 00302 00303 WRITE(*,*) 'Done writing vector datasets...' 00304 00305 WRITE(*,*) 'Done writing datasets...' 00306 00307 ! Read the files back in 00308 call TXI_READ_X_FORMAT_FILE(SCALAR_A_FILE_F, SCALAR_A_TEXT_F, status) 00309 if (status < 0) then 00310 WRITE(*,*) 'Error reading SCALAR A File (see TXI_READ_X_FORMAT_FILE)' 00311 error = status 00312 return 00313 endif 00314 00315 call TXI_READ_X_FORMAT_FILE(VECTOR2D_A_FILE_F, VECTOR2D_A_TEXT_F, status) 00316 if (status < 0) then 00317 WRITE(*,*) 'Error reading VECTOR A Format File' 00318 error = status 00319 return 00320 endif 00321 00322 call TXI_READ_X_FORMAT_FILE(MULTIDATASET_FILE_F, MULTIDATASET_TEXT_F, status) 00323 if (status < 0) then 00324 WRITE(*,*) 'Error reading Multidataset File (see TXI_READ_X_FORMAT_FILE)' 00325 error = status 00326 return 00327 endif 00328 00329 WRITE(*,*) 'Done reading datasets...' 00330 00331 call XF_GET_NUM_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, NumOpen, error) 00332 00333 call XFI_CLOSE_OPEN_IDENTIFIERS(H5F_OBJ_ALL_F, error) 00334 00335 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', & 00336 SdoGuid, XF_OVERWRITE_CLEAR_DATASET_GRP, MultiFileId, MultiGroupId, & 00337 error) 00338 00339 call TD_WRITE_SCALAR_A_TO_MULTI(MultiGroupId, error) 00340 00341 call XF_SETUP_TO_WRITE_DATASETS(MULTIDATASET_FILE_F, 'Multidatasets','', & 00342 SdoGuid, XF_OVERWRITE_NONE, MultiFileId, MultiGroupId, error) 00343 00344 call TD_WRITE_VECTOR2D_A_TO_MULTI(MultiFileId, MultiGroupId, error) 00345 00346 ! Test reading information at index for multiple timesteps 00347 call TD_READ_SCALAR_A_INDEX(SCALAR_A_FILE_F, 4, status) 00348 if (status < 0) then 00349 error = status 00350 return 00351 endif 00352 00353 WRITE(*,*) 'Done reading scalar data at index.' 00354 00355 call TD_READ_VECTOR2D_A_INDEX(VECTOR2D_A_FILE_F, 6, status) 00356 if (status < 0) then 00357 error = status 00358 return 00359 endif 00360 00361 WRITE(*,*) 'Done reading vector data at index.' 00362 00363 call TD_READ_ACTIVITY_SCALAR_A_INDEX(SCALAR_A_FILE_F, 6, status) 00364 if (status < 0) then 00365 error = status 00366 return 00367 endif 00368 00369 ! Test reading information at multiple indices 00370 indices(1) = 2; 00371 indices(2) = 3; 00372 indices(3) = 5; 00373 CALL TD_READ_SCALAR_A_INDICES(SCALAR_A_FILE_F, nIndices, indices, error) 00374 00375 error = status 00376 return 00377 00378 END SUBROUTINE 00379 00380 !------------------------------------------------------------------------------ 00381 ! FUNCTION TXI_TEST_OVERWRITE_DSETS 00382 ! PURPOSE Check to see if already-written datasets can be overwritten 00383 ! NOTES 00384 !------------------------------------------------------------------------------ 00385 SUBROUTINE TXI_TEST_OVERWRITE_DSETS(error) 00386 INTEGER, INTENT(OUT) :: error 00387 INTEGER status, compression 00388 00389 status = 1 00390 compression = NONE 00391 00392 ! scalar datasets 00393 call TD_WRITE_SCALAR_B(SCALAR_B_FILE_F, compression, .FALSE., status) 00394 if (status < 0) then 00395 error = status 00396 return 00397 endif 00398 !overwrite scalar datasets 00399 call TD_WRITE_SCALAR_B(SCALAR_B_FILE_F, compression, .TRUE., status) 00400 if (status < 0) then 00401 error = status 00402 return 00403 endif 00404 00405 ! vector datasets 00406 call TD_WRITE_VECTOR2D_B(VECTOR2D_B_FILE_F, compression, .FALSE., status) 00407 if (status < 0) then 00408 WRITE(*,*) 'Error writing dataset vector2D_B.' 00409 error = status 00410 return 00411 endif 00412 ! overwrite vector datasets 00413 call TD_WRITE_VECTOR2D_B(VECTOR2D_B_FILE_F, compression, .TRUE., status) 00414 if (status < 0) then 00415 WRITE(*,*) 'Error writing dataset vector2D_B.' 00416 error = status 00417 return 00418 endif 00419 00420 ! Read the files back in 00421 call TXI_READ_X_FORMAT_FILE(SCALAR_B_FILE_F, SCALAR_B_TEXT_F, status) 00422 if (status < 0) then 00423 WRITE(*,*) 'Error reading SCALAR B File' 00424 error = status 00425 return 00426 endif 00427 00428 call TXI_READ_X_FORMAT_FILE(VECTOR2D_B_FILE_F, VECTOR2D_B_TEXT_F, status) 00429 if (status < 0) then 00430 WRITE(*,*) 'Error reading VECTOR B Format File' 00431 error = status 00432 return 00433 endif 00434 00435 error = status 00436 return 00437 00438 END SUBROUTINE 00439 00440 !------------------------------------------------------------------------------ 00441 ! FUNCTION TXI_TEST_GRIDS 00442 ! PURPOSE Test to see if we can read and write grids 00443 ! NOTES 00444 !------------------------------------------------------------------------------ 00445 SUBROUTINE TXI_TEST_GRIDS (error) 00446 INTEGER, INTENT(OUT) :: error 00447 INTEGER compression 00448 00449 compression = NONE 00450 00451 WRITE(*,*) '' 00452 WRITE(*,*) '' 00453 WRITE(*,*) 'Writing grid data.' 00454 WRITE(*,*) '' 00455 00456 call TG_WRITE_TEST_GRID_CART_2D(GRID_CART2D_A_FILE_F, error) 00457 if (error < 0) then 00458 WRITE(*,*) 'Error writing grid Cartesian 2D A' 00459 endif 00460 WRITE(*,*) 'Finished writing grid Cartesian 2D A' 00461 00462 call TG_WRITE_TEST_GRID_CURV_2D(GRID_CURV2D_A_FILE_F, compression, error) 00463 if (error < 0) then 00464 WRITE(*,*) 'Error writing grid Curvilinear 2D A' 00465 endif 00466 WRITE(*,*) 'Finished writing grid Curvilinear 2D A' 00467 00468 call TG_WRITE_TEST_GRID_CART_3D(GRID_CART3D_A_FILE_F, compression, error) 00469 if (error < 0) then 00470 WRITE(*,*) 'Error writing grid Cartesian 3D A' 00471 endif 00472 WRITE(*,*) 'Finished writing grid Cartesian 3D A' 00473 ! read the files back in 00474 call TXI_READ_X_FORMAT_FILE(GRID_CART2D_A_FILE_F, GRID_CART2D_A_OUT_F, error) 00475 if (error < 0) then 00476 WRITE(*,*) 'Error reading grid Cartesian 2D A' 00477 endif 00478 WRITE(*,*) 'Finished reading grid Cartesian 2D A' 00479 00480 call TXI_READ_X_FORMAT_FILE(GRID_CURV2D_A_FILE_F, GRID_CURV2D_A_OUT_F, error) 00481 if (error < 0) then 00482 WRITE(*,*) 'Error reading grid Curvilinear 2D A' 00483 endif 00484 WRITE(*,*) 'Finished reading grid Curvilinear 2D A' 00485 00486 call TXI_READ_X_FORMAT_FILE(GRID_CART3D_A_FILE_F, GRID_CART3D_A_OUT_F, error) 00487 if (error < 0) then 00488 WRITE(*,*) 'Error reading grid Cartesian 3D A' 00489 endif 00490 WRITE(*,*) 'Finished reading grid Cartesian 3D A' 00491 00492 END SUBROUTINE 00493 00494 !************************** 00495 ! --------------------------------------------------------------------------- 00496 ! FUNCTION TXI_TEST_MESHS 00497 ! PURPOSE test to see if we can read and write meshes 00498 ! NOTES 00499 ! --------------------------------------------------------------------------- 00500 SUBROUTINE TXI_TEST_MESHS (error) 00501 INTEGER, INTENT(OUT) :: error 00502 INTEGER status 00503 INTEGER compression 00504 00505 status = 1 00506 compression = NONE 00507 00508 call TM_WRITE_TEST_MESH_A(MESH_A_FILE_F, compression, status) 00509 if (status < 0) then 00510 WRITE(*,*) 'Error writing TestMeshA' 00511 error = status 00512 return 00513 endif 00514 00515 call TM_WRITE_TEST_MESH_B(MESH_B_FILE_F, compression, status) 00516 if (status < 0) then 00517 WRITE(*,*) 'Error writing TestMeshB' 00518 error = status 00519 return 00520 endif 00521 00522 WRITE(*,*) 'Finished writing meshes.' 00523 00524 ! read the files back in 00525 call TXI_READ_X_FORMAT_FILE(MESH_A_FILE_F, MESH_A_OUT_F, status) 00526 if (status < 0) then 00527 WRITE(*,*) 'Error reading TestMeshA' 00528 error = status 00529 return 00530 endif 00531 00532 ! read the files back in 00533 call TXI_READ_X_FORMAT_FILE(MESH_B_FILE_F, MESH_B_OUT_F, status) 00534 if (status < 0) then 00535 WRITE(*,*) 'Error reading TestMeshB' 00536 error = status 00537 return 00538 endif 00539 00540 WRITE(*,*) 'Finished reading meshes.' 00541 00542 error = status 00543 return 00544 00545 END SUBROUTINE 00546 00547 !************************** 00548 00549 !--------------------------------------------------------------------------- 00550 ! FUNCTION txiTestC 00551 ! PURPOSE test to see if fortran code can read file written with C. 00552 ! NOTES 00553 !--------------------------------------------------------------------------- 00554 SUBROUTINE TXI_TEST_C (error) 00555 INTEGER, INTENT(OUT) :: error 00556 INTEGER nStatus 00557 INTEGER xFileId 00558 00559 error = 1 00560 00561 !Check to see if files written with C exist 00562 ! Turn off error handling 00563 !call H5Eset_auto_f(0, error) 00564 ! Try opening a file written with C to see if one exists. 00565 call XF_OPEN_FILE(SCALAR_A_FILE_C, .TRUE., xFileId, nStatus) 00566 ! If the file written with C doesn't exist, return. 00567 if (nStatus < 0) then 00568 call XF_CLOSE_FILE(xFileId, error) 00569 ! Restore previous error handler 00570 !call H5Eset_Auto_f(1, error) 00571 error = -1 00572 return 00573 ! If the file written with C does exist, assume all C files exist. 00574 else 00575 call XF_CLOSE_FILE(xFileId, error) 00576 ! Restore previous error handler 00577 !call H5Eset_Auto_f(1, error) 00578 endif 00579 00580 ! Read the files back in 00581 call TXI_READ_X_FORMAT_FILE(SCALAR_A_FILE_C, SCALAR_A_TEXT_CF, error) 00582 if (error < 0) then 00583 return 00584 endif 00585 call TXI_READ_X_FORMAT_FILE(SCALAR_B_FILE_C, SCALAR_B_TEXT_CF, error) 00586 if (error < 0) then 00587 return 00588 endif 00589 00590 call TXI_READ_X_FORMAT_FILE(VECTOR2D_A_FILE_C, VECTOR2D_A_TEXT_CF, error) 00591 if (error < 0) then 00592 return 00593 endif 00594 call TXI_READ_X_FORMAT_FILE(VECTOR2D_B_FILE_C, VECTOR2D_B_TEXT_CF, error) 00595 if (error < 0) then 00596 return 00597 endif 00598 00599 WRITE(*,*) 'Done reading C datasets...' 00600 00601 call TXI_READ_X_FORMAT_FILE(GRID_CART2D_A_FILE_C, GRID_CART2D_A_OUT_CF, error) 00602 if (error < 0) then 00603 WRITE(*,*) 'Error reading C grid Cartesian 2D A' 00604 endif 00605 WRITE(*,*) 'Finished reading C grid Cartesian 2D A' 00606 00607 call TXI_READ_X_FORMAT_FILE(GRID_CURV2D_A_FILE_C, GRID_CURV2D_A_OUT_CF, error) 00608 if (error < 0) then 00609 WRITE(*,*) 'Error reading C grid Curvilinear 2D A' 00610 endif 00611 WRITE(*,*) 'Finished reading C grid Curvilinear 2D A' 00612 00613 call TXI_READ_X_FORMAT_FILE(GRID_CART3D_A_FILE_C, GRID_CART3D_A_OUT_CF, error) 00614 if (error < 0) then 00615 WRITE(*,*) 'Error reading C grid Cartesian 3D A' 00616 endif 00617 WRITE(*,*) 'Finished reading C grid Cartesian 3D A' 00618 00619 ! read the files back in 00620 call TXI_READ_X_FORMAT_FILE(MESH_A_FILE_C, MESH_A_OUT_CF, error) 00621 if (error < 0) then 00622 WRITE(*,*) 'Error reading C TestMeshA' 00623 return 00624 endif 00625 00626 ! read the files back in 00627 call TXI_READ_X_FORMAT_FILE(MESH_B_FILE_C, MESH_B_OUT_CF, error) 00628 if (error < 0) then 00629 WRITE(*,*) 'Error reading C TestMeshB' 00630 return 00631 endif 00632 00633 WRITE(*,*) 'Finished reading C meshes.' 00634 00635 return 00636 00637 END SUBROUTINE 00638 00639 !************************** 00640 ! -------------------------------------------------------------------------- 00641 ! FUNCTION txiReadXFormatFile 00642 ! PURPOSE Read a file using XMDF and write information about the data 00643 ! contained in the file to a output file 00644 ! -------------------------------------------------------------------------- 00645 SUBROUTINE TXI_READ_X_FORMAT_FILE (a_XmdfFile, a_OutFile, error) 00646 CHARACTER(LEN=*), INTENT(IN) :: a_XmdfFile 00647 CHARACTER(LEN=*), INTENT(IN) :: a_OutFile 00648 INTEGER, INTENT(OUT) :: error 00649 CHARACTER(LEN=BIG_STRING_SIZE) :: IndividualPath 00650 CHARACTER,ALLOCATABLE :: Paths(:) 00651 INTEGER xFileId, xGroupId 00652 INTEGER nMeshGroups, nMaxPathLength, nGridGroups 00653 INTEGER FileUnit, StartLoc, nStatus, i, j 00654 REAL Version 00655 00656 xFileId = NONE 00657 xGroupId = NONE 00658 00659 ! Open the XMDF file 00660 call XF_OPEN_FILE(a_XmdfFile, .TRUE., xFileId, nStatus) 00661 if (nStatus < 0) then 00662 call XF_CLOSE_FILE(xFileId, error) 00663 error = -1 00664 return 00665 endif 00666 00667 ! open the status file 00668 FileUnit = 53 00669 OPEN(UNIT=FileUnit, FILE=a_OutFile, STATUS='REPLACE', ACTION='WRITE', & 00670 IOSTAT = error) 00671 if (FileUnit == 0) then 00672 call XF_CLOSE_FILE(xFileId, error) 00673 error = -1 00674 return 00675 endif 00676 00677 WRITE(FileUnit,*) 'File ', a_XmdfFile, ' opened.' 00678 00679 ! write the version number to the file 00680 call XF_GET_LIBRARY_VERSION_FILE(xFileId, Version, error) 00681 WRITE(FileUnit,*) 'XMDF Version: ', Version 00682 WRITE(FileUnit,*) '' 00683 00684 ! Read Coordinate System Informatioin to the .txt file if contained in 00685 ! file, if not skip 00686 call TXI_TEST_COORD_SYSTEM(xFileId, FileUnit, nStatus) 00687 WRITE(FileUnit,*) '' 00688 00689 ! read all datasets not beneath a mesh, grid, or cross-sections 00690 call TD_READ_DATASETS(xFileId,FileUnit, nStatus) 00691 if (nStatus < 0) then 00692 call XF_CLOSE_FILE(xFileId, error) 00693 error = -1 00694 return 00695 endif 00696 00697 ! Get the number and paths of datasets in the file. 00698 call XF_GRP_PTHS_SZ_FOR_MESHES(xFileId, nMeshGroups, & 00699 nMaxPathLength, error) 00700 if (error >= 0 .AND. nMeshGroups > 0) then 00701 allocate (Paths(nMaxPathLength*nMeshGroups)) 00702 call XF_GET_GROUP_PATHS_FOR_MESHES(xFileId, nMeshGroups, nMaxPathLength, & 00703 Paths, error) 00704 endif 00705 00706 if (error < 0) then 00707 call XF_CLOSE_FILE(xFileId, error) 00708 error = -1 00709 return 00710 endif 00711 00712 ! Report the number and paths to individual meshes in the file. 00713 WRITE(FileUnit,*) 'Number of meshes in file: ', nMeshGroups 00714 WRITE(FileUnit,*) 'Paths:' 00715 do i=1, nMeshGroups 00716 do j=1, nMaxPathLength-1 00717 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00718 enddo 00719 WRITE(FileUnit,*) IndividualPath(1:nMaxPathLength-1) 00720 enddo 00721 00722 WRITE(FileUnit,*) '' 00723 00724 ! Open each mesh group 00725 !if (nMeshGroups > 0) allocate(IndividualPath(nMaxPathLength + 1)) 00726 00727 do i=1, nMeshGroups 00728 ! copy the portion of the array where a single path is stored 00729 StartLoc = (i-1)*nMaxPathLength + 1 00730 IndividualPath = '' 00731 do j = 1, nMaxPathLength - 1 00732 IndividualPath(j:j) = Paths(StartLoc+j-1) 00733 enddo 00734 00735 WRITE(FileUnit,*) 'Reading mesh in group: ', & 00736 IndividualPath(1:nMaxPathLength-1) 00737 call XF_OPEN_GROUP(xFileId, IndividualPath(1:LEN_TRIM(IndividualPath)), & 00738 xGroupId, nStatus) 00739 if (nStatus >= 0) then 00740 call TM_READ_MESH(xGroupId, FileUnit, nStatus) 00741 endif 00742 if (nStatus < 0) then 00743 WRITE(*,*) 'Error reading mesh..' 00744 endif 00745 enddo 00746 00747 if (allocated(Paths)) deallocate(Paths) 00748 !if (allocated(IndividualPath)) deallocate(IndividualPath) 00749 00750 ! Grid stuff 00751 call XF_GRP_PTHS_SZ_FOR_GRIDS(xFileId, nGridGroups, & 00752 nMaxPathLength, nStatus) 00753 if (nStatus >= 0 .AND. nGridGroups > 0) then 00754 allocate (Paths(nMaxPathLength*nGridGroups)) 00755 call XF_GET_GROUP_PATHS_FOR_GRIDS(xFileId, nGridGroups, & 00756 nMaxPathLength, Paths, nStatus) 00757 endif 00758 if (nStatus < 0) then 00759 call XF_CLOSE_FILE(xFileId, error) 00760 error = -1 00761 return 00762 endif 00763 00764 ! Report the number and paths to individual meshes in the file. 00765 WRITE(FileUnit,*) 'Number of grids in file: ', nGridGroups 00766 WRITE(FileUnit,*) 'Paths:' 00767 do i=1, nGridGroups 00768 do j=1, nMaxPathLength-1 00769 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00770 enddo 00771 WRITE(FileUnit,*) IndividualPath(1:LEN_TRIM(IndividualPath)) 00772 enddo 00773 00774 WRITE(FileUnit,*) '' 00775 00776 !if (nGridGroups > 0) allocate(IndividualPath(nMaxPathLength + 1)) 00777 00778 ! Open each grid group 00779 do i=1, nGridGroups 00780 do j = 1, nMaxPathLength - 1 00781 IndividualPath(j:j) = Paths((i-1)*nMaxPathLength+j) 00782 enddo 00783 WRITE(FileUnit,*) 'Reading grid in group: ', & 00784 IndividualPath(1:LEN_TRIM(IndividualPath)) 00785 call XF_OPEN_GROUP(xFileId, IndividualPath(1:LEN_TRIM(IndividualPath)), & 00786 xGroupId, nStatus) 00787 if (nStatus >= 0) then 00788 call TG_READ_GRID(xGroupId, FileUnit, nStatus) 00789 endif 00790 if (nStatus < 0) then 00791 WRITE(FileUnit,*) 'Error reading grid..' 00792 endif 00793 enddo 00794 00795 if (allocated(Paths)) deallocate(Paths) 00796 !if (allocated(IndividualPath)) deallocate(IndividualPath) 00797 00798 ! TODO do grid, and cross-section stuff. 00799 00800 ! close the files 00801 call XF_CLOSE_FILE(xFileId, error) 00802 CLOSE(FileUnit) 00803 00804 return 00805 00806 END SUBROUTINE 00807 00808 !----------------------------------------------------------------------------- 00809 ! SUBROUTINE TXI_TestCalendar 00810 ! PURPOSE Check the Calculations of Julian date from calendar date or 00811 ! vice-versa. 00812 ! NOTES era is #defined (use #defines): ERA_IS_BCE (BC), ERA_IS_CE (AD) 00813 !----------------------------------------------------------------------------- 00814 SUBROUTINE TXI_TEST_CALENDAR (error) 00815 INTEGER, INTENT(OUT) :: error 00816 INTEGER era1, yr1, mo1, day1, hr1, min1, sec1 00817 INTEGER era2, yr2, mo2, day2, hr2, min2, sec2 00818 INTEGER era3, yr3, mo3, day3, hr3, min3, sec3, FileUnit 00819 INTEGER era4, yr4, mo4, day4, hr4, min4, sec4, calendarworks 00820 DOUBLE PRECISION julian1, julian2, julian3, julian4 00821 00822 calendarworks = 0 00823 FileUnit = 53 00824 OPEN(UNIT=FileUnit, FILE=CALENDAR_OUT_F, STATUS='REPLACE', ACTION='WRITE', & 00825 IOSTAT = error) 00826 00827 WRITE(FileUnit,*) 'Calendar conversion:' 00828 00829 era1 = ERA_IS_BCE 00830 yr1 = 0 00831 mo1 = 0 00832 day1 = 0 00833 hr1 = 0 00834 min1 = 0 00835 sec1 = 0 00836 julian1 = 2655.5 00837 call XF_JULIAN_TO_CALENDAR(era1, yr1, mo1, day1, hr1, min1, sec1, julian1, error) 00838 00839 era2 = ERA_IS_BCE 00840 yr2 = 4706 00841 mo2 = 4 00842 day2 = 10 00843 hr2 = 0 00844 min2 = 0 00845 sec2 = 0 00846 julian2 = 0.0 00847 call XF_CALENDAR_TO_JULIAN(era2, yr2, mo2, day2, hr2, min2, sec2, julian2, error) 00848 00849 era3 = ERA_IS_CE 00850 yr3 = 2004 00851 mo3 = 6 00852 day3 = 3 00853 hr3 = 2 00854 min3 = 8 00855 sec3 = 32 00856 julian3 = 0.0 00857 call XF_CALENDAR_TO_JULIAN(era3, yr3, mo3, day3, hr3, min3, sec3, julian3, error) 00858 00859 era4 = ERA_IS_BCE 00860 yr4 = 0 00861 mo4 = 0 00862 day4 = 0 00863 hr4 = 0 00864 min4 = 0 00865 sec4 = 0 00866 julian4 = 2453159.5892592594_double 00867 call XF_JULIAN_TO_CALENDAR(era4, yr4, mo4, day4, hr4, min4, sec4, julian4, error) 00868 00869 WRITE(FileUnit,*) '' 00870 WRITE(FileUnit,*) 'Dates #1 & #2 were calculated with the same date:' 00871 WRITE(FileUnit,*) '' 00872 WRITE(FileUnit,*) era1, '/', yr1, '/', mo1, '/', day1 00873 WRITE(FileUnit,*) '', hr1, ':', min1, ':',sec1, '--- julian =',julian1 00874 WRITE(FileUnit,*) '' 00875 WRITE(FileUnit,*) era2, '/', yr2, '/', mo2, '/', day2 00876 WRITE(FileUnit,*) '', hr2, ':', min2, ':',sec2, '--- julian =',julian2 00877 WRITE(FileUnit,*) '' 00878 WRITE(FileUnit,*) 'Dates #3 & #4 were calculated with the same date:' 00879 WRITE(FileUnit,*) '' 00880 WRITE(FileUnit,*) era3, '/', yr3, '/', mo3, '/', day3 00881 WRITE(FileUnit,*) '', hr3, ':', min3, ':',sec3, '--- julian =',julian3 00882 WRITE(FileUnit,*) '' 00883 WRITE(FileUnit,*) era4, '/', yr4, '/', mo4, '/', day4 00884 WRITE(FileUnit,*) '', hr4, ':', min4, ':',sec4, '--- julian =',julian4 00885 00886 if (era1==era2 .AND. era3==era4) then 00887 if (yr1==yr2 .AND. yr3==yr4) then 00888 if (mo1==mo2 .AND. mo3==mo4) then 00889 if (day1==day2 .AND. day3==day4) then 00890 if (hr1==hr2 .AND. hr3==hr4) then 00891 if (min1==min2 .AND. min3==min4) then 00892 if (julian1==julian2 .AND. (julian3-.0000001)<julian4 .AND. (julian3+.0000001)>julian4) then 00893 WRITE(*,*) '' 00894 WRITE(*,*) 'Calendar conversion works correctly.' 00895 calendarworks = 1 00896 endif 00897 endif 00898 endif 00899 endif 00900 endif 00901 endif 00902 endif 00903 if (calendarworks .NE. 1) then 00904 WRITE(*,*) 'Calendar Stuff DOES NOT Work Correctly' 00905 error = -1 00906 else 00907 error = 1 00908 endif 00909 return 00910 00911 END SUBROUTINE 00912 !------------------------------------------------------------------------------ 00913 ! FUNCTION TXI_TEST_MULTI_DATASETS 00914 ! PURPOSE To test the newly translated functions 00915 ! NOTES 00916 !------------------------------------------------------------------------------ 00917 SUBROUTINE TXI_TEST_MULTI_DATASETS 00918 00919 !call XF_SETUP_TO_WRITE_DATASETS(a_Filename, a_MultiDatasetsGroupPath, & 00920 ! a_PathInMultiDatasetsGroup, a_SpatialDataObjectGuid, & 00921 ! a_OverwriteOptions, a_FileId, a_GroupId, error) 00922 !XF_OPEN_MULTI_DATASETS_GROUP 00923 !XF_DELETE_GROUP 00924 00925 END SUBROUTINE 00926 00927 !------------------------------------------------------------------------------ 00928 ! SUBROUTINE TXI_WRITE_XMDF_VERSION 00929 ! PURPOSE Write the XMDF version number to the screen 00930 ! NOTES 00931 !------------------------------------------------------------------------------ 00932 SUBROUTINE TXI_TEST_VERSION () 00933 INTEGER error 00934 REAL Version 00935 00936 WRITE(*,*) '' 00937 call XF_GET_LIBRARY_VERSION(Version, error) 00938 WRITE(*,*) 'The current version of XMDF is: ', Version 00939 WRITE(*,*) '' 00940 00941 return 00942 00943 END SUBROUTINE 00944 00945 !------------------------------------------------------------------------------ 00946 ! SUBROUTINE TXI_TEST_COORD_SYSTEM 00947 ! PURPOSE Reads a file's Coordinate Group and prints coordinate data out 00948 ! to each text file. 00949 ! NOTES 00950 !------------------------------------------------------------------------------ 00951 SUBROUTINE TXI_TEST_COORD_SYSTEM (xFileId, a_OutFile, error) 00952 INTEGER, INTENT(IN) :: xFileId 00953 INTEGER, INTENT(IN) :: a_OutFile 00954 INTEGER, INTENT(OUT) :: error 00955 INTEGER iHorizDatum, iHorizUnits, iVertDatum, iVertUnits 00956 INTEGER iLat, iLon, iUtmZone, iSpcZone, iHpgnArea, iEllipse 00957 INTEGER bHorizDatum, nStatus 00958 REAL(DOUBLE) dCppLat, dCppLon, dMajorR, dMinorR 00959 INTEGER xCoordId 00960 CHARACTER(LEN=BIG_STRING_SIZE) strHorizUnits, strVertDatum 00961 CHARACTER(LEN=BIG_STRING_SIZE) strVertUnits 00962 00963 ! Coordinate stuff 00964 ! Read Coordinate Info 00965 ! Open the Coordinate group 00966 !call H5Eset_auto_f(0, error) 00967 call XF_OPEN_COORDINATE_GROUP(xFileId, xCoordId, nStatus) 00968 if (nStatus < 0) then 00969 WRITE(a_OutFile,*) '' 00970 WRITE(a_OutFile,*) 'Coordinate Group not found' 00971 WRITE(a_OutFile,*) '' 00972 error = nStatus 00973 return 00974 endif 00975 !call H5Eset_auto_f(1, error) 00976 00977 WRITE(a_OutFile,*) '' 00978 WRITE(a_OutFile,*) 'Coordinate System:' 00979 00980 call XF_GET_HORIZ_DATUM(xCoordId, iHorizDatum, bHorizDatum) 00981 call XF_GET_HORIZ_UNITS(xCoordId, iHorizUnits, error) 00982 call XF_GET_VERT_DATUM(xCoordId, iVertDatum, error) 00983 call XF_GET_VERT_UNITS(xCoordId, iVertUnits, error) 00984 00985 ! set horizontal units 00986 if (iHorizUnits == 0) then 00987 strHorizUnits = 'Horizontal units = US Survey Feet (=0)' 00988 else if (iHorizUnits == 1) then 00989 strHorizUnits = 'Horizontal units = International Feet (=1)' 00990 else if (iHorizUnits == 2) then 00991 strHorizUnits = 'Horizontal units = Meters (=2)' 00992 else 00993 strHorizUnits = 'ERROR in reading Horizontal units' 00994 endif 00995 00996 ! set vertical datum 00997 if (iVertDatum == 0) then 00998 strVertDatum = 'Vertical datum = Local (=0)' 00999 else if (iVertDatum == 1) then 01000 strVertDatum = 'Vertical datum = NGVD 29 (=1)' 01001 else if (iVertDatum == 2) then 01002 strVertDatum = 'Vertical datum = NGVD 88 (=2)' 01003 else 01004 strVertDatum = 'ERROR in reading the Vertical datum' 01005 endif 01006 01007 ! set vertocal units 01008 if (iVertUnits == 0) then 01009 strVertUnits = 'Vertical units = US Survey Feet (=0)' 01010 else if (iVertUnits == 1) then 01011 strVertUnits = 'Vertical units = International Feet (=1)' 01012 else if (iVertUnits == 2) then 01013 strVertUnits = 'Vertical units = Meters (=2)' 01014 else 01015 strVertUnits = 'ERROR in reading the Vertical units' 01016 endif 01017 01018 if (bHorizDatum >= 0) then 01019 SELECT CASE (iHorizDatum) 01020 CASE (HORIZ_DATUM_GEOGRAPHIC) 01021 call XF_GET_ELLIPSE(xCoordId, iEllipse, error) 01022 call XF_GET_LAT(xCoordId, iLat, error) 01023 call XF_GET_LON(xCoordId, iLon, error) 01024 ! Write Horizontal and Vertical Info 01025 WRITE(a_OutFile,*) 'Horizontal datum = Geographic' 01026 WRITE(a_OutFile,*) 'Horizontal units = ', strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01027 WRITE(a_OutFile,*) 'Vertical datum = ', strVertDatum(1:LEN_TRIM(strVertDatum)) 01028 WRITE(a_OutFile,*) 'Vertical units = ', strVertUnits(1:LEN_TRIM(strVertUnits)) 01029 ! Write Latitude data 01030 if (iLat == 0) then 01031 WRITE(a_OutFile,*) ' Latitude = North (=0)' 01032 else if (iLat == 1) then 01033 WRITE(a_OutFile,*) ' Latitude = South (=1)' 01034 else 01035 WRITE(a_OutFile,*) ' LATITUDE INFO INCORRECT' 01036 endif 01037 ! Write Longitude data 01038 if (iLon == 0) then 01039 WRITE(a_OutFile,*) ' Longitude = East (=0)' 01040 else if (iLon == 1) then 01041 WRITE(a_OutFile,*) ' Longitude = West (=1)' 01042 else 01043 WRITE(a_OutFile,*) ' LONGITUDE INFO INCORRECT' 01044 endif 01045 ! Ellipse Information 01046 ! User-defined Ellipse (==32) 01047 if (iEllipse == 32) then 01048 WRITE(a_OutFile,*) 'Ellipse = User-defined:' 01049 call XF_GET_MAJOR_R(xCoordId, dMajorR, error) 01050 call XF_GET_MINOR_R(xCoordId, dMinorR, error) 01051 WRITE(a_OutFile,*) ' MajorR = ', dMajorR 01052 WRITE(a_OutFile,*) ' MinorR = ', dMinorR 01053 else 01054 WRITE(a_OutFile,*) 'Ellipse = ', iEllipse 01055 endif 01056 WRITE(a_OutFile,*) '' 01057 CASE (HORIZ_DATUM_UTM) 01058 call XF_GET_UTM_ZONE(xCoordId, iUtmZone, error) 01059 ! output info to text file 01060 if (iHorizDatum == HORIZ_DATUM_UTM) then 01061 WRITE(a_OutFile,*) 'Horizontal datum = UTM' 01062 else if (iHorizDatum == HORIZ_DATUM_UTM_NAD27) then 01063 WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD27 (US)' 01064 else 01065 WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD83 (US)' 01066 endif 01067 WRITE(a_OutFile,*) 'Horizontal units = ', & 01068 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01069 WRITE(a_OutFile,*) 'Vertical datum = ', & 01070 strVertDatum(1:LEN_TRIM(strVertDatum)) 01071 WRITE(a_OutFile,*) 'Vertical units = ', & 01072 strVertUnits(1:LEN_TRIM(strVertUnits)) 01073 WRITE(a_OutFile,*) 'UTM Zone = ', iUtmZone 01074 WRITE(a_OutFile,*) '' 01075 01076 CASE (HORIZ_DATUM_UTM_NAD27, HORIZ_DATUM_UTM_NAD83) 01077 call XF_GET_UTM_ZONE(xCoordId, iUtmZone, error) 01078 ! output info to text file 01079 if (iHorizDatum == HORIZ_DATUM_UTM) then 01080 WRITE(a_OutFile,*) 'Horizontal datum = UTM' 01081 else if (iHorizDatum == HORIZ_DATUM_UTM_NAD27) then 01082 WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD27 (US)' 01083 else 01084 WRITE(a_OutFile,*) 'Horizontal datum = UTM NAD83 (US)' 01085 endif 01086 WRITE(a_OutFile,*) 'Horizontal units = ', & 01087 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01088 WRITE(a_OutFile,*) 'Vertical datum = ', & 01089 strVertDatum(1:LEN_TRIM(strVertDatum)) 01090 WRITE(a_OutFile,*) 'Vertical units = ', & 01091 strVertUnits(1:LEN_TRIM(strVertUnits)) 01092 WRITE(a_OutFile,*) 'UTM Zone = ', iUtmZone 01093 WRITE(a_OutFile,*) '' 01094 CASE (HORIZ_DATUM_STATE_PLANE_NAD27, HORIZ_DATUM_STATE_PLANE_NAD83) 01095 call XF_GET_SPC_ZONE(xCoordId, iSpcZone, error) 01096 ! output info to text file 01097 if (iHorizDatum == HORIZ_DATUM_STATE_PLANE_NAD27) then 01098 WRITE(a_OutFile,*) 'Horizontal datum = State Plane NAD27 (US)' 01099 else 01100 WRITE(a_OutFile,*) 'Horizontal datum = State Plane NAD83 (US)' 01101 endif 01102 WRITE(a_OutFile,*) 'Horizontal units = ', & 01103 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01104 WRITE(a_OutFile,*) 'Vertical datum = ', & 01105 strVertDatum(1:LEN_TRIM(strVertDatum)) 01106 WRITE(a_OutFile,*) 'Vertical units = ', & 01107 strVertUnits(1:LEN_TRIM(strVertUnits)) 01108 WRITE(a_OutFile,*) 'SPC Zone = ', iSpcZone 01109 WRITE(a_OutFile,*) '' 01110 CASE (HORIZ_DATUM_UTM_HPGN, HORIZ_DATUM_STATE_PLANE_HPGN, & 01111 HORIZ_DATUM_GEOGRAPHIC_HPGN) 01112 call XF_GET_HPGN_AREA(xCoordId, iHpgnArea, error) 01113 if (iHorizDatum == HORIZ_DATUM_UTM_HPGN) then 01114 WRITE(a_OutFile,*) 'Horizontal datum = UTM HPGN (US)' 01115 else if (iHorizDatum == HORIZ_DATUM_STATE_PLANE_HPGN) then 01116 WRITE(a_OutFile,*) 'Horizontal datum = State Plane HPGN (US)' 01117 else 01118 WRITE(a_OutFile,*) 'Horizontal datum = Geographic HPGN (US)' 01119 endif 01120 WRITE(a_OutFile,*) 'Horizontal units = ', & 01121 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01122 WRITE(a_OutFile,*) 'Vertical datum = ', & 01123 strVertDatum(1:LEN_TRIM(strVertDatum)) 01124 WRITE(a_OutFile,*) 'Vertical units = ', & 01125 strVertUnits(1:LEN_TRIM(strVertUnits)) 01126 WRITE(a_OutFile,*) 'HPGN Area = ', iHpgnArea 01127 WRITE(a_OutFile,*) '' 01128 CASE (HORIZ_DATUM_CPP) 01129 call XF_GET_CPP_LAT(xCoordId, dCppLat, error) 01130 call XF_GET_CPP_LON(xCoordId, dCppLon, error) 01131 WRITE(a_OutFile,*) 'Horizontal datum = CPP (Carte Parallelo-Grammatique Projection)' 01132 WRITE(a_OutFile,*) 'Horizontal units = ', & 01133 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01134 WRITE(a_OutFile,*) 'Vertical datum = ', & 01135 strVertDatum(1:LEN_TRIM(strVertDatum)) 01136 WRITE(a_OutFile,*) 'Vertical units = ', & 01137 strVertUnits(1:LEN_TRIM(strVertUnits)) 01138 WRITE(a_OutFile,*) 'CPP Latitude = ', dCppLat 01139 WRITE(a_OutFile,*) 'CPP Longitude = ', dCppLon 01140 WRITE(a_OutFile,*) '' 01141 CASE (HORIZ_DATUM_LOCAL, HORIZ_DATUM_GEOGRAPHIC_NAD27, & 01142 HORIZ_DATUM_GEOGRAPHIC_NAD83) 01143 ! do other systems 01144 if (iHorizDatum == HORIZ_DATUM_LOCAL) then 01145 WRITE(a_OutFile,*) 'Horizontal datum = Local' 01146 else if (iHorizDatum == HORIZ_DATUM_GEOGRAPHIC_NAD27) then 01147 WRITE(a_OutFile,*) 'Horizontal datum = Geographic NAD27 (US)' 01148 else 01149 WRITE(a_OutFile,*) 'Horizontal datum = Geographic NAD83 (US)' 01150 endif 01151 WRITE(a_OutFile,*) 'Horizontal units = ', & 01152 strHorizUnits(1:LEN_TRIM(strHorizUnits)) 01153 WRITE(a_OutFile,*) 'Vertical datum = ', & 01154 strVertDatum(1:LEN_TRIM(strVertDatum)) 01155 WRITE(a_OutFile,*) 'Vertical units = ', & 01156 strVertUnits(1:LEN_TRIM(strVertUnits)) 01157 WRITE(a_OutFile,*) '' 01158 CASE DEFAULT 01159 WRITE(a_OutFile,*) 'ERROR: The coordinate information is not found in the .h5 file' 01160 error = -1 01161 return 01162 END SELECT 01163 else 01164 WRITE(a_OutFile,*) 'Coordinate information in HDF5 file is incomplete.' 01165 WRITE(a_OutFile,*) '' 01166 endif 01167 01168 call XF_CLOSE_GROUP(xCoordId, error) 01169 xCoordId = 0 01170 01171 return 01172 01173 END SUBROUTINE 01174 01175 SUBROUTINE TXI_TEST_GEOMETRIC_PATHS(error) 01176 INTEGER, INTENT(OUT) :: error 01177 INTEGER compression 01178 01179 compression = -1 01180 01181 ! test writing a geometric path file */ 01182 WRITE(*,*)'' 01183 WRITE(*,*)'Writing geometric path data' 01184 WRITE(*,*)'' 01185 01186 call TM_WRITE_TEST_PATHS(GEOMPATH_A_FILE_F, compression, error); 01187 if (error < 0) then 01188 WRITE(*,*) 'Error writing geometric path data A' 01189 return 01190 endif 01191 WRITE(*,*) 'Finished writing geometric path data A' 01192 01193 ! test reading a geometric path file */ 01194 call TM_READ_TEST_PATHS(GEOMPATH_A_FILE_F, GEOMPATH_A_FILE_F_OUT, error) 01195 01196 return 01197 01198 END SUBROUTINE TXI_TEST_GEOMETRIC_PATHS 01199 01200 !**************************** 01201 01202 END MODULE TestsModule 01203 01204 PROGRAM TESTS 01205 01206 USE TestDatasets 01207 USE Xmdf 01208 USE TestMesh 01209 USE TestDefs 01210 USE TestsModule 01211 01212 INTEGER error 01213 ! Assign pp to force crash on error 01214 01215 call XF_INITIALIZE(error) 01216 01217 ! test the dataset routines 01218 call TXI_TEST_TIMESTEPS(error) 01219 if (error < 0) then 01220 WRITE(*,*) 'Error in writing timesteps!' 01221 PAUSE 'Press ENTER to exit...' 01222 endif 01223 01224 ! test the dataset routines 01225 call TXI_TEST_DATASETS(error) 01226 if (error < 0) then 01227 WRITE(*,*) 'Error in writing datasets!' 01228 PAUSE 'Press ENTER to exit...' 01229 endif 01230 01231 ! test overwriting datasets 01232 call TXI_TEST_OVERWRITE_DSETS(error) 01233 if (error < 0) then 01234 WRITE(*,*) 'Error in overwriting datasets!' 01235 PAUSE 'Press ENTER to exit...' 01236 else 01237 WRITE(*,*) 'Finished writing datasets...' 01238 endif 01239 01240 ! test mesh stuff 01241 call TXI_TEST_MESHS(error) 01242 if (error < 0) then 01243 WRITE(*,*) 'Error in TXI_TEST_MESHS!' 01244 PAUSE 'Press ENTER to exit...' 01245 endif 01246 01247 ! test grid stuff 01248 call TXI_TEST_GRIDS(error) 01249 if (error < 0) then 01250 WRITE(*,*) 'Error in TXI_TEST_GRIDS!' 01251 PAUSE 'Press ENTER to exit...' 01252 endif 01253 01254 ! test c in fortran 01255 call TXI_TEST_C(error) 01256 ! Ignore error because fortran will be run once again with file there 01257 01258 ! test calendar stuff 01259 call TXI_TEST_CALENDAR(error) 01260 if (error < 0) then 01261 WRITE(*,*) 'Error in TXI_TEST_CALENDAR!' 01262 PAUSE 'Press ENTER to exit...' 01263 endif 01264 01265 ! test version 01266 call TXI_TEST_VERSION 01267 01268 ! test geometric paths 01269 call TXI_TEST_GEOMETRIC_PATHS(error) 01270 if (error < 0) then 01271 WRITE(*,*) 'Error in TXI_TEST_GEOMETRIC_PATHS!' 01272 PAUSE 'Press ENTER to exit...' 01273 endif 01274 01275 call XF_CLOSE (error) 01276 if (error < 0) then 01277 WRITE(*,*) 'Error in XF_CLOSE!' 01278 PAUSE 'Press ENTER to exit...' 01279 endif 01280 01281 ! PAUSE 'Press ENTER to exit...' 01282 01283 END PROGRAM