diff --git a/.github/workflows/ubuntu.yml b/.github/workflows/ubuntu.yml index 8d3b4f30..7aaf8e5a 100644 --- a/.github/workflows/ubuntu.yml +++ b/.github/workflows/ubuntu.yml @@ -29,6 +29,7 @@ jobs: mtln: ["ON", "OFF"] hdf: ["ON"] double-precision: ["OFF"] + new-output-module: ["OFF","ON"] include: # Disable by lack of space on github action @@ -89,13 +90,15 @@ jobs: -DSEMBA_FDTD_ENABLE_MPI=${{matrix.mpi}} \ -DSEMBA_FDTD_ENABLE_HDF=${{matrix.hdf}} \ -DSEMBA_FDTD_ENABLE_MTLN=${{matrix.mtln}} \ - -DSEMBA_FDTD_ENABLE_DOUBLE_PRECISION=${{matrix.double-precision}} + -DSEMBA_FDTD_ENABLE_DOUBLE_PRECISION=${{matrix.double-precision}} \ + -DSEMBA_FDTD_ENABLE_OUTPUT_MODULE=${{matrix.new-output-module}} cmake --build build -j - name: Run unit tests run: build/bin/fdtd_tests - name: Run python tests + if: matrix.new-output-module=='OFF' env: SEMBA_FDTD_ENABLE_MPI: ${{ matrix.mpi }} SEMBA_FDTD_ENABLE_MTLN: ${{ matrix.mtln }} diff --git a/.gitmodules b/.gitmodules index 01ca1a8d..3cff2024 100755 --- a/.gitmodules +++ b/.gitmodules @@ -20,4 +20,4 @@ [submodule "external/googletest"] path = external/googletest - url = https://github.com/OpenSEMBA/googletest.git \ No newline at end of file + url = https://github.com/OpenSEMBA/googletest.git diff --git a/CMakeLists.txt b/CMakeLists.txt index f8622e45..e8e3f039 100755 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -16,7 +16,7 @@ option(SEMBA_FDTD_ENABLE_MPI "Use MPI" OFF) option(SEMBA_FDTD_ENABLE_HDF "Use HDF" ON) option(SEMBA_FDTD_ENABLE_MTLN "Use MTLN" ON) option(SEMBA_FDTD_ENABLE_SMBJSON "Use smbjson" ON) -option(SEMBA_FDTD_ENABLE_DOUBLE_PRECISION "Use double precision (CompileWithReal8)" OFF) +option(SEMBA_FDTD_ENABLE_DOUBLE_PRECISION "Use double precision (CompileWithReal8)" ON) option(SEMBA_FDTD_ENABLE_TEST "Compile tests" ON) @@ -27,12 +27,26 @@ option(SEMBA_FDTD_EXECUTABLE "Compiles executable" ON) option(SEMBA_FDTD_MAIN_LIB "Compiles main library" ON) option(SEMBA_FDTD_COMPONENTS_LIB "Compiles components library" ON) option(SEMBA_FDTD_OUTPUTS_LIB "Compiles outputs library" ON) + +option(SEMBA_FDTD_ENABLE_OUTPUT_MODULE "Use new output module" OFF) + # Compilation defines. if(CMAKE_BUILD_TYPE MATCHES "Release" OR CMAKE_BUILD_TYPE MATCHES "release" ) add_definitions(-DCompileWithRelease) else() add_definitions(-DCompileWithDebug) endif() +if (CMAKE_SYSTEM_NAME STREQUAL "Windows") +add_compile_definitions(__WIN32__) +elseif (CMAKE_SYSTEM_NAME STREQUAL "Darwin") +add_compile_definitions(__APPLE__) +elseif (CMAKE_SYSTEM_NAME STREQUAL "Linux") +add_compile_definitions(__linux__) +endif() + +if(SEMBA_FDTD_ENABLE_OUTPUT_MODULE) + add_definitions(-DCompileWithNewOutputModule) +endif() if(SEMBA_FDTD_ENABLE_SMBJSON) add_definitions(-DCompileWithSMBJSON) endif() @@ -49,6 +63,14 @@ add_definitions( -DCompileWithOpenMP ) +if(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") + add_definitions(-DGNUCompiler) +endif() +if(CMAKE_Fortran_COMPILER_ID MATCHES "IntelLLVM") + add_definitions(-DIFXCompiler) +endif() + + include("${CMAKE_CURRENT_SOURCE_DIR}/set_precompiled_libraries.cmake") if (CMAKE_SYSTEM_NAME MATCHES "Linux") @@ -174,6 +196,22 @@ if (SEMBA_FDTD_ENABLE_MTLN) endif() endif() +add_subdirectory(src_utils) + +if (SEMBA_FDTD_ENABLE_OUTPUT_MODULE) + add_subdirectory(src_output) + set(OUTPUT_LIBRARIES fdtd-output) + target_link_libraries(fdtd-output + semba-components + semba-types + fdtd-utils + ${HDF5_LIBRARIES} ${HDF5_HL_LIBRARIES} + ) + + target_include_directories(fdtd-output PRIVATE ${HDF5_INCLUDE_DIRS}) + set(VTK_API_LIBRARIES vtkAPI) + set(XDMF_API_LIBRARIES xdmfAPI) +endif() add_subdirectory(src_conformal) set(CONFORMAL_LIBRARIES conformal) @@ -182,6 +220,8 @@ if (SEMBA_FDTD_ENABLE_TEST) add_subdirectory(test) endif() + + if(SEMBA_FDTD_COMPONENTS_LIB) add_library(semba-components "src_main_pub/anisotropic.F90" @@ -244,7 +284,11 @@ if(SEMBA_FDTD_MAIN_LIB) "src_main_pub/timestepping.F90" ) target_link_libraries(semba-main - semba-outputs + semba-outputs + fdtd-utils + ${OUTPUT_LIBRARIES} + ${VTK_API_LIBRARIES} + ${XDMF_API_LIBRARIES} ${SMBJSON_LIBRARIES} ${MTLN_LIBRARIES}) endif() diff --git a/CMakePresets.json b/CMakePresets.json index 32ba2f5b..8b0bc189 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -24,6 +24,31 @@ "cacheVariables": { "SEMBA_FDTD_ENABLE_MTLN": "OFF" } + }, + { + "name": "intel-rls", + "generator": "Ninja", + "binaryDir": "build-intel-rls/", + "environment": { + "I_MPI_ROOT": "/opt/intel/oneapi/mpi/latest", + "FC": "mpiifx", + "CC": "mpiicx", + "CXX": "mpiicpx" + }, + "cacheVariables": { + "CMAKE_BUILD_TYPE": "Release", + "SEMBA_FDTD_ENABLE_MPI": "ON", + "SEMBA_FDTD_ENABLE_MTLN": "ON", + "SEMBA_FDTD_ENABLE_DOUBLE_PRECISION": "ON" + } + }, + { + "name": "intel-rls-nomtln", + "inherits": "intel-rls", + "binaryDir": "build-intel-rls-nomtln/", + "cacheVariables": { + "SEMBA_FDTD_ENABLE_MTLN": "OFF" + } } ] } diff --git a/setup_intel_build.sh b/setup_intel_build.sh new file mode 100755 index 00000000..3895230e --- /dev/null +++ b/setup_intel_build.sh @@ -0,0 +1,53 @@ +#!/bin/bash +# ======================================================== +# Script para limpiar CMake y configurar Intel 2025.3 +# ======================================================== + +# -------------------------- +# Configuración del proyecto +# -------------------------- +SRC_DIR="/home/username/elemwave/fdtd" +BUILD_DIR="$SRC_DIR/build-dbg" + +# -------------------------- +# Carga Intel oneAPI 2025.3 +# -------------------------- +echo "Cargando Intel oneAPI 2025.1..." +source /opt/intel/oneapi/setvars.sh intel64 --force --compiler-version=2025.1 + +# -------------------------- +# Definir compiladores Intel +# -------------------------- +export CC=/opt/intel/oneapi/compiler/2025.1/bin/icx +export CXX=/opt/intel/oneapi/compiler/2025.1/bin/icpx +export FC=/opt/intel/oneapi/compiler/2025.1/bin/ifx + +echo "Compiladores configurados:" +echo " CC = $CC" +echo " CXX = $CXX" +echo " FC = $FC" + +# -------------------------- +# Limpiar build anterior +# -------------------------- +if [ -d "$BUILD_DIR" ]; then + echo "Eliminando cache de CMake y archivos previos..." + rm -rf "$BUILD_DIR/CMakeCache.txt" "$BUILD_DIR/CMakeFiles" +else + mkdir -p "$BUILD_DIR" +fi + +# -------------------------- +# Ejecutar CMake con Ninja +# -------------------------- +echo "Ejecutando CMake con Intel..." +cmake -G Ninja \ + -DCMAKE_BUILD_TYPE=Debug \ + -DCMAKE_C_COMPILER=$CC \ + -DCMAKE_CXX_COMPILER=$CXX \ + -DCMAKE_Fortran_COMPILER=$FC \ + -S "$SRC_DIR" \ + -B "$BUILD_DIR" + +echo "¡Configuración completa! Ahora puedes compilar con:" +echo " ninja -C $BUILD_DIR" diff --git a/src_main_pub/fdetypes.F90 b/src_main_pub/fdetypes.F90 index 40fb62b1..06f21682 100755 --- a/src_main_pub/fdetypes.F90 +++ b/src_main_pub/fdetypes.F90 @@ -6,7 +6,6 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module FDETYPES - #ifdef CompileWithOpenMP use omp_lib #endif @@ -186,6 +185,17 @@ module FDETYPES integer (kind=4), parameter :: iBloqueJx=100*iEx,iBloqueJy=100*iEy,iBloqueJz=100*iEz integer (kind=4), parameter :: iBloqueMx=100*iHx,iBloqueMy=100*iHy,iBloqueMz=100*iHz ! + integer (kind=4), parameter :: VOLUMIC_M_MEASURE(3) = [iCur, iMEC, iMHC] !Module + integer (kind=4), parameter :: VOLUMIC_X_MEASURE(3) = [iCurx, iExC, iHxC] + integer (kind=4), parameter :: VOLUMIC_Y_MEASURE(3) = [iCury, iEyC, iHyC] + integer (kind=4), parameter :: VOLUMIC_Z_MEASURE(3) = [iCurz, iEzC, iHzC] + + integer (kind=4), parameter :: MAGNETIC_FIELD_DIRECTION(3) = [iEx, iEy, iEz] + integer (kind=4), parameter :: ELECTRIC_FIELD_DIRECTION(3) = [iHx, iHy, iHz] + integer (kind=4), parameter :: CURRENT_MEASURE(4) = [iCur, iCurx, iCury, iCurz] + integer (kind=4), parameter :: ELECTRIC_FIELD_MEASURE(4) = [iMEC, iExC, iEyC, iEzC] + integer (kind=4), parameter :: MAGNETIC_FIELD_MEASURE(4) = [iMHC, iHxC, iHyC, iHzC] + ! CHARACTER (LEN=*), PARAMETER :: SEPARADOR='______________' integer (kind=4), PARAMETER :: comi=1,fine=2, icoord=1,jcoord=2,kcoord=3 @@ -591,6 +601,7 @@ module FDETYPES type :: MediaData_t + integer(kind=SINGLE) :: Id REAL (KIND=RKIND) :: Priority,Epr,Sigma,Mur,SigmaM logical :: sigmareasignado !solo afecta a un chequeo de errores en lumped 120123 type (exists_t) :: Is @@ -616,15 +627,15 @@ module FDETYPES REAL (KIND=RKIND_tiempo) :: dt character (len=BUFSIZE) :: extraswitches !! - integer (kind=4) :: NumMedia,AllocMed - integer (kind=4) :: IniPMLMedia,EndPMLMedia - integer (kind=4) :: NumPlaneWaves,TimeSteps,InitialTimeStep - integer (kind=4) :: NumNodalSources - integer (kind=4) :: NumberRequest + integer (kind=SINGLE) :: NumMedia,AllocMed + integer (kind=SINGLE) :: IniPMLMedia,EndPMLMedia + integer (kind=SINGLE) :: NumPlaneWaves,TimeSteps,InitialTimeStep + integer (kind=SINGLE) :: NumNodalSources + integer (kind=SINGLE) :: NumberRequest = 0_SINGLE !!! REAL (KIND=RKIND) , pointer, dimension ( : ) :: LineX,LineY,LineZ REAL (KIND=RKIND) , pointer, dimension ( : ) :: DX,DY,DZ - integer (kind=4) :: AllocDxI,AllocDyI,AllocDzI,AllocDxE,AllocDyE,AllocDzE + integer (kind=SINGLE) :: AllocDxI,AllocDyI,AllocDzI,AllocDxE,AllocDyE,AllocDzE type (planeonde_t), pointer, dimension ( : ) :: PlaneWave type (Border_t) :: Border type (PML_t) :: PML @@ -641,6 +652,7 @@ module FDETYPES logical :: thereArePMLMagneticMedia CHARACTER (LEN=BUFSIZE) :: nEntradaRoot type (coorsxyzP) :: Punto + end type type media_matrices_t @@ -868,6 +880,8 @@ logical function direction_eq(a,b) direction_eq = direction_eq .and. (a%orientation == b%orientation) end function + + end module FDETYPES !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src_main_pub/observation.F90 b/src_main_pub/observation.F90 index 27aeee62..9cc5edf9 100755 --- a/src_main_pub/observation.F90 +++ b/src_main_pub/observation.F90 @@ -743,13 +743,15 @@ subroutine InitObservation(sgg, media, tag_numbers, & type(mtln_solver_t), pointer :: mtln_solver integer :: i, j mtln_solver => GetSolverPtr() - do i = 1, ubound(mtln_solver%bundles, 1) - if (ubound(mtln_solver%bundles(i)%probes, 1) /= 0) then - do j = 1, ubound(mtln_solver%bundles(i)%probes, 1) - if (mtln_solver%bundles(i)%probes(j)%in_layer) ThereAreObservation = .true. - end do - end if - end do + if (mtln_solver%number_of_bundles > 0) then + do i = 1, ubound(mtln_solver%bundles, 1) + if (ubound(mtln_solver%bundles(i)%probes, 1) /= 0) then + do j = 1, ubound(mtln_solver%bundles(i)%probes, 1) + if (mtln_solver%bundles(i)%probes(j)%in_layer) ThereAreObservation = .true. + end do + end if + end do + end if end block #endif ! @@ -1796,13 +1798,13 @@ subroutine InitObservation(sgg, media, tag_numbers, & if ((SGG%Observation(ii)%TimeDomain) .and. (sgg%observation(ii)%P(1)%what /= mapvtk)) then ! read (output(ii)%item(i)%unit) ndum - if (output(ii)%item(i)%columnas /= ndum) call stoponerror(layoutnumber, size, 'BUGGYError reading resuming files () ') + if (output(ii)%item(i)%columnas /= ndum) call stoponerror(layoutnumber, size, 'BUGGYError reading resuming files () ') do conta = 1, output(ii)%item(i)%columnas read (output(ii)%item(i)%unit) ndum, ndum, ndum, ndum, ndum end do cutting3: do read (output(ii)%item(i)%unit, end=699) at - if (output(ii)%item(i)%columnas /= 0) read (output(ii)%item(i)%unit, end=699) (rdum, conta=1, output(ii)%item(i)%columnas) + if (output(ii)%item(i)%columnas /= 0) read (output(ii)%item(i)%unit, end=699) (rdum, conta=1, output(ii)%item(i)%columnas) output(ii)%TimesWritten = output(ii)%TimesWritten + 1 if (at > lastexecutedtime) then print '(i4,a,a,2e19.9e3)', quienmpi, 'Cutting 3 ', trim(adjustl(output(ii)%item(i)%path)), at, lastexecutedtime diff --git a/src_main_pub/timestepping.F90 b/src_main_pub/timestepping.F90 index 5a783efe..0d6f7fb5 100755 --- a/src_main_pub/timestepping.F90 +++ b/src_main_pub/timestepping.F90 @@ -15,11 +15,15 @@ !________________________________________________________________________________________ module Solver_mod - + use mod_logUtils use fdetypes use report use PostProcessing use Ilumina +#ifdef CompileWithNewOutputModule + use output + use outputTypes +#endif use Observa use BORDERS_other use Borders_CPML @@ -1505,10 +1509,13 @@ subroutine initializeObservation() call MPI_Barrier(SUBCOMM_MPI,ierr) #endif write(dubuf,*) 'Init Observation...'; call print11(this%control%layoutnumber,dubuf) +#ifdef CompileWithNewOutputModule + call init_outputs(this%sgg, this%media, this%sinPML_fullsize, this%tag_numbers, this%bounds, this%control, this%thereAre%Observation, this%thereAre%wires) +#else call InitObservation (this%sgg,this%media,this%tag_numbers, & this%thereAre%Observation,this%thereAre%wires,this%thereAre%FarFields,this%initialtimestep,this%lastexecutedtime, & this%sinPML_fullsize,this%eps0,this%mu0,this%bounds, this%control) - +#endif l_auxinput=this%thereAre%Observation.or.this%thereAre%FarFields l_auxoutput=l_auxinput @@ -1773,6 +1780,10 @@ subroutine solver_run(this) real(kind=rkind), pointer, dimension (:,:,:) :: Ex, Ey, Ez, Hx, Hy, Hz real(kind=rkind), pointer, dimension (:) :: Idxe, Idye, Idze, Idxh, Idyh, Idzh, dxe, dye, dze, dxh, dyh, dzh +#ifdef CompileWithNewOutputModule + type(fields_reference_t) :: fieldReference +#endif + logical :: call_timing, l_aux, flushFF, somethingdone, newsomethingdone integer :: i real (kind=rkind) :: pscale_alpha @@ -1798,6 +1809,23 @@ subroutine solver_run(this) Idxe => this%Idxe; Idye => this%Idye; Idze => this%Idze; Idxh => this%Idxh; Idyh => this%Idyh; Idzh => this%Idzh; dxe => this%dxe; dye => this%dye; dze => this%dze; dxh => this%dxh; dyh => this%dyh; dzh => this%dzh +#ifdef CompileWithNewOutputModule + fieldReference%E%x => this%Ex + fieldReference%E%y => this%Ey + fieldReference%E%z => this%Ez + + fieldReference%E%deltax => this%dxe + fieldReference%E%deltay => this%dye + fieldReference%E%deltaz => this%dze + + fieldReference%H%x => this%Hx + fieldReference%H%y => this%Hy + fieldReference%H%z => this%Hz + + fieldReference%H%deltax => this%dxh + fieldReference%H%deltay => this%dyh + fieldReference%H%deltaz => this%dzh +#endif ciclo_temporal : DO while (this%n <= this%control%finaltimestep) @@ -1821,48 +1849,13 @@ subroutine solver_run(this) Ex,Ey,Ez,this%everflushed,this%control%nentradaroot,this%control%maxSourceValue,this%control%opcionestotales,this%control%simu_devia,this%control%dontwritevtk,this%control%permitscaling) if (.not.this%parar) then !!! si es por parada se gestiona al final -!!!!! si esta hecho lo flushea todo pero poniendo de acuerdo a todos los mpi - do i=1,this%sgg%NumberRequest - if (this%sgg%Observation(i)%done.and.(.not.this%sgg%Observation(i)%flushed)) then - this%perform%flushXdmf=.true. - this%perform%flushVTK=.true. - endif - end do -#ifdef CompileWithMPI - l_aux=this%perform%flushVTK - call MPI_AllReduce( l_aux, this%perform%flushVTK, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) - ! - l_aux=this%perform%flushXdmf - call MPI_AllReduce( l_aux, this%perform%flushXdmf, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) - ! - l_aux=this%perform%flushDATA - call MPI_AllReduce( l_aux, this%perform%flushDATA, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) - ! - l_aux=this%perform%flushFIELDS - call MPI_AllReduce( l_aux, this%perform%flushFIELDS, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) - ! - l_aux=this%perform%postprocess - call MPI_AllReduce( l_aux, this%perform%postprocess, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) -#endif -!!!!!!!!!!!! - if (this%perform%flushFIELDS) then - write(dubuf,*) SEPARADOR,trim(adjustl(this%control%nentradaroot)),separador - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) 'INIT FLUSHING OF RESTARTING FIELDS n=',this%n - call print11(this%control%layoutnumber,dubuf) - call flush_and_save_resume(this%sgg, this%bounds, this%control%layoutnumber, this%control%size, this%control%nentradaroot, this%control%nresumeable2, this%thereare, this%n,this%eps0,this%mu0, this%everflushed, & - Ex, Ey, Ez, Hx, Hy, Hz,this%control%wiresflavor,this%control%simu_devia,this%control%stochastic) -#ifdef CompileWithMPI - call MPI_Barrier(SUBCOMM_MPI,ierr) -#endif - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) 'DONE FLUSHING OF RESTARTING FIELDS n=',this%n - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) - endif - if (this%perform%isFlush()) then + call request_flush_if_any_observation_is_done() + + if (this%perform%flushFIELDS) then + call performFlushField() + endif + + if (this%perform%isFlush()) then ! flushFF=this%perform%postprocess if (this%thereAre%FarFields.and.flushFF) then @@ -1870,12 +1863,11 @@ subroutine solver_run(this) else write(dubuf,'(a,i9)') ' INIT OBSERVATION DATA FLUSHING n= ',this%n endif - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - !! + call printMessageWithSeparator(this%control%layoutnumber,dubuf) +#ifdef CompileWithNewOutputModule + if (this%thereAre%Observation) call flush_outputs(this%sgg%tiempo, this%n, this%control, fieldReference, this%bounds, flushFF) +#else if (this%thereAre%Observation) call FlushObservationFiles(this%sgg,this%ini_save, this%n,this%control%layoutnumber, this%control%size, dxe, dye, dze, dxh, dyh, dzh,this%bounds,this%control%singlefilewrite,this%control%facesNF2FF,flushFF) - !! #ifdef CompileWithMPI call MPI_Barrier(SUBCOMM_MPI,ierr) #endif @@ -1884,15 +1876,11 @@ subroutine solver_run(this) else write(dubuf,'(a,i9)') ' Done OBSERVATION DATA FLUSHED n= ',this%n endif - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber,dubuf) ! if (this%perform%postprocess) then write(dubuf,'(a,i9)') 'Postprocessing frequency domain probes, if any, at n= ',this%n - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) somethingdone=.false. at=this%n*this%sgg%dt if (this%thereAre%Observation) call PostProcessOnthefly(this%control%layoutnumber,this%control%size,this%sgg,this%control%nentradaroot,at,somethingdone,this%control%niapapostprocess,this%control%forceresampled) @@ -1903,22 +1891,16 @@ subroutine solver_run(this) #endif if (somethingdone) then write(dubuf,*) 'End Postprocessing frequency domain probes.' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) else write(dubuf,*) 'No frequency domain probes snapshots found to be postrocessed' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) endif endif !! if (this%perform%flushvtk) then write(dubuf,'(a,i9)') ' Post-processing .vtk files n= ',this%n - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber,dubuf) somethingdone=.false. if (this%thereAre%Observation) call createvtkOnTheFly(this%control%layoutnumber,this%control%size,this%sgg,this%control%vtkindex,somethingdone,this%control%mpidir,this%media%sggMtag,this%control%dontwritevtk) #ifdef CompileWithMPI @@ -1928,21 +1910,15 @@ subroutine solver_run(this) #endif if (somethingdone) then write(dubuf,*) 'End flushing .vtk snapshots' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) else write(dubuf,*) 'No .vtk snapshots found to be flushed' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) endif endif if (this%perform%flushXdmf) then write(dubuf,'(a,i9)') ' Post-processing .xdmf files n= ',this%n - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber,dubuf) somethingdone=.false. if (this%thereAre%Observation) call createxdmfOnTheFly(this%sgg,this%control%layoutnumber,this%control%size,this%control%vtkindex,this%control%createh5bin,somethingdone,this%control%mpidir) @@ -1955,30 +1931,22 @@ subroutine solver_run(this) #endif if (somethingdone) then write(dubuf,*) 'End flushing .xdmf snapshots' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) else write(dubuf,*) 'No .xdmf snapshots found to be flushed' - call print11(this%control%layoutnumber,dubuf) - write(dubuf,*) SEPARADOR//separador//separador - call print11(this%control%layoutnumber,dubuf) + call printMessageWithEndingSeparator(this%control%layoutnumber,dubuf) endif endif #ifdef CompileWithMPI call MPI_Barrier(SUBCOMM_MPI,ierr) +#endif #endif endif !del if (this%performflushDATA.or.... - ! - - if (this%control%singlefilewrite.and.this%perform%Unpack) call singleUnpack() if ((this%control%singlefilewrite.and.this%perform%Unpack).or.this%perform%isFlush()) then write(dubuf,'(a,i9)') ' Continuing simulation at n= ',this%n - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber,dubuf) endif endif !!!del if (.not.this%parar) @@ -2020,15 +1988,72 @@ subroutine solver_run(this) this%n=this%n+1 !sube de iteracion end do ciclo_temporal ! End of the time-stepping loop + contains + + subroutine request_flush_if_any_observation_is_done() + do i=1,this%sgg%NumberRequest + if (this%sgg%Observation(i)%done.and.(.not.this%sgg%Observation(i)%flushed)) then + this%perform%flushXdmf=.true. + this%perform%flushVTK=.true. + endif + end do +#ifdef CompileWithMPI + call syncroniceFlushFlags(this%perform, ierr) +#endif + end subroutine + +#ifdef CompileWithMPI + subroutine syncroniceFlushFlags(performFlags, integerError) + type(perform_t), intent(inout) :: performFlags + integer, intent(inout) :: integerError + logical :: logicalAux + logicalAux=performFlags%flushVTK + call MPI_AllReduce( logicalAux, performFlags%flushVTK, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, integerError) + logicalAux=performFlags%flushXdmf + call MPI_AllReduce( logicalAux, performFlags%flushXdmf, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, integerError) + logicalAux=performFlags%flushDATA + call MPI_AllReduce( logicalAux, performFlags%flushDATA, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, integerError) + logicalAux=performFlags%flushFIELDS + call MPI_AllReduce( logicalAux, performFlags%flushFIELDS, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, integerError) + logicalAux=performFlags%postprocess + call MPI_AllReduce( logicalAux, performFlags%postprocess, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, integerError) + end subroutine syncroniceFlushFlags +#endif + + subroutine performFlushField() + write(dubuf,*) SEPARADOR,trim(adjustl(this%control%nentradaroot)),SEPARADOR + call printMessage(this%control%layoutnumber,dubuf) + write(dubuf,*) 'INIT FLUSHING OF RESTARTING FIELDS n=',this%n + call printMessage(this%control%layoutnumber,dubuf) + + call flush_and_save_resume(this%sgg, this%bounds, this%control%layoutnumber, this%control%size, this%control%nentradaroot, this%control%nresumeable2, this%thereare, this%n,this%eps0,this%mu0, this%everflushed, & + Ex, Ey, Ez, Hx, Hy, Hz,this%control%wiresflavor,this%control%simu_devia,this%control%stochastic) +#ifdef CompileWithMPI + call MPI_Barrier(SUBCOMM_MPI,ierr) +#endif + write(dubuf,*) 'DONE FLUSHING OF RESTARTING FIELDS n=',this%n + call printMessageWithSeparator(this%control%layoutnumber, dubuf) + + end subroutine performFlushField subroutine updateAndFlush() integer(kind=4) :: mindum IF (this%thereAre%Observation) then +#ifdef CompileWithNewOutputModule + if (this%n /= 0) then + call update_outputs(this%control, this%sgg%tiempo, this%n, fieldReference) + if (this%n>=this%ini_save+BuffObse) then + mindum=min(this%control%finaltimestep,this%ini_save+BuffObse) + call flush_outputs(this%sgg%tiempo, this%n, this%control, fieldReference, this%bounds, .FALSE.) + endif + end if +#else call UpdateObservation(this%sgg,this%media,this%tag_numbers, this%n,this%ini_save, Ex, Ey, Ez, Hx, Hy, Hz, dxe, dye, dze, dxh, dyh, dzh,this%control%wiresflavor,this%sinPML_fullsize,this%control%wirecrank, this%control%noconformalmapvtk,this%bounds) if (this%n>=this%ini_save+BuffObse) then mindum=min(this%control%finaltimestep,this%ini_save+BuffObse) call FlushObservationFiles(this%sgg,this%ini_save,mindum,this%control%layoutnumber,this%control%size, dxe, dye, dze, dxh, dyh, dzh,this%bounds,this%control%singlefilewrite,this%control%facesNF2FF,.FALSE.) !no se flushean los farfields ahora endif +#endif endif end subroutine @@ -2039,10 +2064,9 @@ subroutine singleUnpack() #ifdef CompileWithMPI integer(kind=4) :: ierr #endif - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) write(dubuf,'(a,i9)') ' Unpacking .bin files and prostprocessing them at n= ',this%n - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber, dubuf) + if (this%thereAre%Observation) call unpacksinglefiles(this%sgg,this%control%layoutnumber,this%control%size,this%control%singlefilewrite,this%initialtimestep,this%control%resume) !dump the remaining to disk somethingdone=.false. if (this%control%singlefilewrite.and.this%perform%Unpack) then @@ -2055,9 +2079,7 @@ subroutine singleUnpack() somethingdone=newsomethingdone #endif write(dubuf,'(a,i9)') ' Done Unpacking .bin files and prostprocessing them at n= ',this%n - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) - call print11(this%control%layoutnumber,dubuf) - call print11(this%control%layoutnumber,SEPARADOR//separador//separador) + call printMessageWithSeparator(this%control%layoutnumber, dubuf) end subroutine singleUnpack @@ -2719,12 +2741,35 @@ subroutine solver_end(this) logical :: dummylog, somethingdone, newsomethingdone character(len=bufsize) :: dubuf +#ifdef CompileWithNewOutputModule + type(fields_reference_t) :: fieldReference +#endif + + #ifdef CompileWithMPI integer (kind=4) :: ierr #endif Ex => this%Ex; Ey => this%Ey; Ez => this%Ez; Hx => this%Hx; Hy => this%Hy; Hz => this%Hz; dxe => this%dxe; dye => this%dye; dze => this%dze; dxh => this%dxh; dyh => this%dyh; dzh => this%dzh +#ifdef CompileWithNewOutputModule + fieldReference%E%x => this%Ex + fieldReference%E%y => this%Ey + fieldReference%E%z => this%Ez + + fieldReference%E%deltax => this%dxe + fieldReference%E%deltay => this%dye + fieldReference%E%deltaz => this%dze + + fieldReference%H%x => this%Hx + fieldReference%H%y => this%Hy + fieldReference%H%z => this%Hz + + fieldReference%H%deltax => this%dxh + fieldReference%H%deltay => this%dyh + fieldReference%H%deltaz => this%dzh +#endif + #ifdef CompileWithProfiling call nvtxEndRange #endif @@ -2770,8 +2815,13 @@ subroutine solver_end(this) call print11(this%control%layoutnumber,dubuf) call print11(this%control%layoutnumber,SEPARADOR//separador//separador) if (this%thereAre%Observation) THEN +#ifdef CompileWithNewOutputModule + call flush_outputs(this%sgg%tiempo, this%n, this%control, fieldReference, this%bounds, .TRUE.) + call close_outputs() +#else call FlushObservationFiles(this%sgg,this%ini_save, this%n,this%control%layoutnumber, this%control%size, dxe, dye, dze, dxh, dyh, dzh,this%bounds,this%control%singlefilewrite,this%control%facesNF2FF,.TRUE.) call CloseObservationFiles(this%sgg,this%control%layoutnumber,this%control%size,this%control%singlefilewrite,this%initialtimestep,this%lastexecutedtime,this%control%resume) !dump the remaining to disk +#endif #ifdef CompileWithMTLN call FlushMTLNObservationFiles(this%control%nentradaroot, mtlnProblem = .false.) #endif @@ -2790,6 +2840,9 @@ subroutine solver_end(this) call MPI_Barrier(SUBCOMM_MPI,ierr) #endif +#ifdef CompileWithNewOutputModule +#else + write(dubuf,'(a,i9)') 'INIT FINAL Postprocessing frequency domain probes, if any, at n= ',this%n call print11(this%control%layoutnumber,dubuf) write(dubuf,*) SEPARADOR//separador//separador @@ -2797,6 +2850,7 @@ subroutine solver_end(this) somethingdone=.false. at=this%n*this%sgg%dt if (this%thereAre%Observation) call PostProcess(this%control%layoutnumber,this%control%size,this%sgg,this%control%nentradaroot,at,somethingdone,this%control%niapapostprocess,this%control%forceresampled) +#endif #ifdef CompileWithMPI call MPI_Barrier(SUBCOMM_MPI,ierr) call MPI_AllReduce(somethingdone, newsomethingdone, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) @@ -2822,7 +2876,6 @@ subroutine solver_end(this) somethingdone=.false. if (this%thereAre%Observation) call createvtk(this%control%layoutnumber,this%control%size,this%sgg,this%control%vtkindex,somethingdone,this%control%mpidir,this%media%sggMtag,this%control%dontwritevtk) - #ifdef CompileWithMPI call MPI_Barrier(SUBCOMM_MPI,ierr) call MPI_AllReduce(somethingdone, newsomethingdone, 1_4, MPI_LOGICAL, MPI_LOR, SUBCOMM_MPI, ierr) diff --git a/src_output/CMakeLists.txt b/src_output/CMakeLists.txt new file mode 100644 index 00000000..5b727ea8 --- /dev/null +++ b/src_output/CMakeLists.txt @@ -0,0 +1,28 @@ +add_library(fdtd-output + "output.F90" + "outputTypes.F90" + "domain.F90" + "outputUtils.F90" + "volumicProbeUtils.F90" + "pointProbeOutput.F90" + "wireProbeOutput.F90" + "bulkProbeOutput.F90" + "movieProbeOutput.F90" + "frequencySliceProbeOutput.F90" + "farFieldProbeOutput.F90" + "mapVTKOutput.F90" +) +add_library(vtkAPI + "vtkAPI.F90" +) + +add_library(xdmfAPI + "xdmfAPI.F90" +) + +target_include_directories(xdmfAPI PRIVATE ${HDF5_INCLUDE_DIRS}) + +target_link_libraries(vtkAPI + fdtd-utils +) + diff --git a/src_output/bulkProbeOutput.F90 b/src_output/bulkProbeOutput.F90 new file mode 100644 index 00000000..a468e3ac --- /dev/null +++ b/src_output/bulkProbeOutput.F90 @@ -0,0 +1,183 @@ +module mod_bulkProbeOutput + use FDETYPES + use mod_UTILS + use outputTypes + use mod_outputUtils + implicit none + +contains + + subroutine init_bulk_probe_output(this, lowerBound, upperBound, field, domain, outputTypeExtension, mpidir) + type(bulk_current_probe_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: mpidir, field + character(len=BUFSIZE), intent(in) :: outputTypeExtension + type(domain_t), intent(in) :: domain + + integer(kind=SINGLE) :: i + + this%mainCoords = lowerBound + this%auxCoords = upperBound + this%component = field + + this%domain = domain + this%path = get_output_path() + + call alloc_and_init(this%timeStep, BuffObse, 0.0_RKIND_tiempo) + call alloc_and_init(this%valueForTime, BuffObse, 0.0_RKIND) + call create_data_file(this%filePathTime, this%path, timeExtension, datFileExtension) + + contains + + function get_output_path() result(outputPath) + character(len=BUFSIZE) :: probeBoundsExtension, prefixFieldExtension + character(len=BUFSIZE) :: outputPath + probeBoundsExtension = get_coordinates_extension(this%mainCoords, this%auxCoords, mpidir) + prefixFieldExtension = get_prefix_extension(field, mpidir) + outputPath = & + trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + return + end function get_output_path + + end subroutine init_bulk_probe_output + + subroutine update_bulk_probe_output(this, step, field) + type(bulk_current_probe_output_t), intent(inout) :: this + real(kind=RKIND_tiempo), intent(in) :: step + type(field_data_t), intent(in) :: field + + integer(kind=SINGLE) :: i1_m, i2_m, j1_m, j2_m, k1_m, k2_m + integer(kind=SINGLE) :: i1, i2, j1, j2, k1, k2 + integer(kind=SINGLE) :: iii, jjj, kkk + + real(kind=RKIND), pointer, dimension(:, :, :) :: xF, yF, zF + real(kind=RKIND), pointer, dimension(:) :: dx, dy, dz + + i1_m = this%mainCoords%x + j1_m = this%mainCoords%y + k1_m = this%mainCoords%z + i2_m = this%auxCoords%x + j2_m = this%auxCoords%y + k2_m = this%auxCoords%z + + i1 = i1_m + j1 = j1_m + k1 = k1_m + i2 = i2_m + j2 = j2_m + k2 = k2_m + + xF => field%x + yF => field%y + zF => field%z + dx => field%deltaX + dy => field%deltaY + dz => field%deltaZ + + this%nTime = this%nTime + 1 + this%timeStep(this%nTime) = step + this%valueForTime(this%nTime) = 0.0_RKIND !Clear uninitialized value + selectcase (this%component) + case (iBloqueJx) + do JJJ = j1, j2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (yF(i1_m, JJJ, k1_m - 1) - yF(i1_m, JJJ, k2_m))*dy(JJJ) + end do + do KKK = k1, k2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-zF(i1_m, j1_m - 1, KKK) + zF(i1_m, j2_m, KKK))*dz(KKK) + end do + + case (iBloqueJy) + do KKK = k1, k2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-zF(i2_m, j1_m, KKK) + zF(i1_m - 1, j1_m, KKK))*dz(KKK) + end do + do III = i1, i2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (xF(III, j1_m, k2_m) - xF(III, j1_m, k1_m - 1))*dx(III) + end do + + case (iBloqueJz) + do III = i1, i2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (xF(III, j1_m - 1, k1_m) - xF(III, j2_m, k1_m))*dx(III) + end do + do JJJ = j1, j2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-yF(i1_m - 1, JJJ, k1_m) + yF(i2_m, JJJ, k1_m))*dy(JJJ) + end do + + case (iBloqueMx) + do JJJ = j1, j2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-yF(i1_m, JJJ, k1_m) + yF(i1_m, JJJ, k2_m + 1))*dy(JJJ) + end do + do KKK = k1, k2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (zF(i1_m, j1_m, KKK) - zF(i1_m, j2_m + 1, KKK))*dz(KKK) + end do + + case (iBloqueMy) + do KKK = k1, k2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (zF(i2_m + 1, j1_m, KKK) - zF(i1_m, j1_m, KKK))*dz(KKK) + end do + do III = i1, i2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-xF(III, j1_m, k2_m + 1) + xF(III, j1_m, k1_m))*dx(III) + end do + + case (iBloqueMz) + do III = i1, i2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (-xF(III, j1_m, k1_m) + xF(III, j2_m + 1, k1_m))*dx(III) + end do + do JJJ = j1, j2 + this%valueForTime(this%nTime) = & + this%valueForTime(this%nTime) + & + (yF(i1_m, JJJ, k1_m) - yF(i2_m + 1, JJJ, k1_m))*dy(JJJ) + end do + + end select + + end subroutine update_bulk_probe_output + + subroutine flush_bulk_probe_output(this) + type(bulk_current_probe_output_t), intent(inout) :: this + integer :: i + integer :: unit + if (this%nTime <= 0) then + print *, "No data to write." + return + end if + + open (unit=unit, file=this%filePathTime, status="old", action="write", position="append") + + do i = 1, this%nTime + write (unit, fmt) this%timeStep(i), this%valueForTime(i) + end do + + close (unit) + call clear_time_data() + contains + subroutine clear_time_data() + this%timeStep = 0.0_RKIND_tiempo + this%valueForTime = 0.0_RKIND + + this%nTime = 0 + end subroutine clear_time_data + end subroutine flush_bulk_probe_output + +end module mod_bulkProbeOutput diff --git a/src_output/domain.F90 b/src_output/domain.F90 new file mode 100644 index 00000000..d9799478 --- /dev/null +++ b/src_output/domain.F90 @@ -0,0 +1,67 @@ +module mod_domain + use FDETYPES + use outputTypes + implicit none + + private + public :: domain_t + + interface domain_t + module procedure new_domain_time, new_domain_freq, new_domain_both, null_domain + end interface domain_t + +contains + function new_domain_time(tstart, tstop, tstep) result(new_domain) + real(kind=RKIND_tiempo), intent(in) :: tstart, tstop, tstep + type(domain_t) :: new_domain + + new_domain%tstart = tstart + new_domain%tstop = tstop + new_domain%tstep = tstep + new_domain%domainType = TIME_DOMAIN + end function new_domain_time + + function new_domain_freq(fstart, fstop, fnum, logarithmicSpacing) result(new_domain) + real(kind=RKIND), intent(in) :: fstart, fstop + integer(kind=SINGLE), intent(in) :: fnum + logical, intent(in) :: logarithmicSpacing + type(domain_t) :: new_domain + + new_domain%fstart = fstart + new_domain%fstop = fstop + new_domain%fnum = fnum + new_domain%fstep = (fstop - fstart) / fnum + new_domain%logarithmicSpacing = logarithmicSpacing + + new_domain%domainType = FREQUENCY_DOMAIN + + + end function new_domain_freq + + function new_domain_both(tstart, tstop, tstep, fstart, fstop, fnum, logarithmicSpacing) result(new_domain) + real(kind=RKIND_tiempo), intent(in) :: tstart, tstop, tstep + real(kind=RKIND), intent(in) :: fstart, fstop + integer(kind=SINGLE), intent(in) :: fnum + logical, intent(in) :: logarithmicSpacing + type(domain_t) :: new_domain + + new_domain%tstart = tstart + new_domain%tstop = tstop + new_domain%tstep = tstep + + new_domain%fstart = fstart + new_domain%fstop = fstop + new_domain%fnum = fnum + new_domain%fstep = (fstop - fstart) / fnum + new_domain%logarithmicSpacing = logarithmicSpacing + + new_domain%domainType = BOTH_DOMAIN + + end function new_domain_both + + function null_domain() result(new_domain) + type(domain_t) :: new_domain + new_domain%domainType = UNDEFINED_DOMAIN + end function + +end module mod_domain diff --git a/src_output/farFieldProbeOutput.F90 b/src_output/farFieldProbeOutput.F90 new file mode 100644 index 00000000..15ffc752 --- /dev/null +++ b/src_output/farFieldProbeOutput.F90 @@ -0,0 +1,94 @@ +module mod_farFieldOutput + use outputTypes + use Report + use mod_outputUtils + use farfield_m + implicit none + private + !=========================== + ! Public interface summary + !=========================== + public :: init_farField_probe_output + !public :: create_farField_probe_output + public :: update_farField_probe_output + public :: flush_farField_probe_output + !=========================== +contains + + subroutine init_farField_probe_output(this, sgg, lowerBound, upperBound, field, domain, sphericRange, outputTypeExtension, fileNormalize,control, problemInfo, eps0, mu0) + type(far_field_probe_output_t), intent(out) :: this + type(domain_t), intent(in) :: domain + type(SGGFDTDINFO), intent(in) :: sgg + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: field + type(spheric_domain_t), intent(in) :: sphericRange + type(sim_control_t), intent(in) :: control + character(len=*), intent(in) :: fileNormalize, outputTypeExtension + type(problem_info_t), intent(in) :: problemInfo + real(kind=RKIND), intent(in) :: mu0, eps0 + + if (domain%domainType /= TIME_DOMAIN) call StopOnError(0, 0, "Unexpected domain type for farField probe") + + this%domain = domain + this%sphericRange = sphericRange + this%component = field + this%path = get_output_path() + call InitFarField(sgg, & + problemInfo%geometryToMaterialData%sggMiEx, problemInfo%geometryToMaterialData%sggMiEy, problemInfo%geometryToMaterialData%sggMiEz, & + problemInfo%geometryToMaterialData%sggMiHx, problemInfo%geometryToMaterialData%sggMiHy, problemInfo%geometryToMaterialData%sggMiHz, & + control%layoutnumber, control%size, problemInfo%simulationBounds, control%resume, & + 2025, this%path, & + lowerBound%x, upperBound%x, & + lowerBound%y, upperBound%y, & + lowerBound%z, upperBound%z, & + domain%fstart, domain%fstop, domain%fstep, & + sphericRange%phiStart, sphericRange%phiStop, sphericRange%phiStep, & + sphericRange%thetaStart, sphericRange%thetaStop, sphericRange%thetaStep, & + fileNormalize, problemInfo%problemDimension, & + control%facesNF2FF, control%NF2FFDecim, & +#ifdef CompileWithMPI + 0, 0, & +#endif + eps0, mu0) + + contains + function get_output_path() result(outputPath) + character(len=BUFSIZE) :: probeBoundsExtension, prefixFieldExtension + character(len=BUFSIZE) :: outputPath + probeBoundsExtension = get_coordinates_extension(this%mainCoords, this%auxCoords, control%mpidir) + prefixFieldExtension = get_prefix_extension(field, control%mpidir) + outputPath = & + trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + return + end function get_output_path + + end subroutine init_farField_probe_output + + subroutine update_farField_probe_output(this, ntime, bounds, fieldsReference) + type(far_field_probe_output_t), intent(inout) :: this + type(fields_reference_t), intent(in) :: fieldsReference + integer(kind=SINGLE), intent(in) :: ntime + type(bounds_t), intent(in) :: bounds + call UpdateFarField(ntime, bounds, & + fieldsReference%E%x, fieldsReference%E%y, fieldsReference%E%z, & + fieldsReference%H%x, fieldsReference%H%y, fieldsReference%H%z) + end subroutine update_farField_probe_output + + subroutine flush_farField_probe_output(this, simlulationTimeArray, timeIndex, control, fieldsReference, bounds) + type(far_field_probe_output_t), intent(out) :: this + integer, intent(in) :: timeIndex + real(KIND=RKIND_tiempo), pointer, dimension(:), intent(in) :: simlulationTimeArray + type(sim_control_t), intent(in) :: control + type(fields_reference_t), pointer, intent(in) :: fieldsReference + type(bounds_t), intent(in) :: bounds + + real(kind=RKIND_tiempo) :: flushTime + + flushTime = simlulationTimeArray(timeIndex) + call FlushFarfield(control%layoutnumber, control%size, bounds, & + fieldsReference%E%deltaX, fieldsReference%E%deltaY, fieldsReference%E%deltaZ, & + fieldsReference%H%deltaX, fieldsReference%H%deltaY, fieldsReference%H%deltaZ, & + control%facesNF2FF, flushTime) + end subroutine flush_farfield_probe_output + +end module mod_farFieldOutput diff --git a/src_output/frequencySliceProbeOutput.F90 b/src_output/frequencySliceProbeOutput.F90 new file mode 100644 index 00000000..1cf43bd8 --- /dev/null +++ b/src_output/frequencySliceProbeOutput.F90 @@ -0,0 +1,341 @@ +module mod_frequencySliceProbeOutput + use FDETYPES + use mod_UTILS + use Report + use outputTypes + use mod_outputUtils + use mod_volumicProbeUtils + use mod_directoryUtils + use HDF5 + use mod_xdmfAPI + implicit none + private + + !=========================== + ! Public interface summary + !=========================== + public :: init_frequency_slice_probe_output + public :: update_frequency_slice_probe_output + public :: flush_frequency_slice_probe_output + public :: close_frequency_slice_probe_output + !=========================== + + !=========================== + ! Private interface summary + !=========================== + private :: save_field + private :: save_field_module + private :: save_field_component + private :: save_current + private :: save_current_module + private :: save_current_component + !=========================== + + !=========================== + +contains + + subroutine init_frequency_slice_probe_output(this, lowerBound, upperBound, timeInterval, field, domain, outputTypeExtension, control, problemInfo) + type(frequency_slice_probe_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + real(kind=RKIND_tiempo), intent(in) :: timeInterval + integer(kind=SINGLE), intent(in) :: field + type(domain_t), intent(in) :: domain + character(len=BUFSIZE), intent(in) :: outputTypeExtension + type(sim_control_t), intent(in) :: control + type(problem_info_t), intent(in) :: problemInfo + + integer :: i + integer :: error + character(len=BUFSIZE) :: filename + + this%mainCoords = lowerBound + this%auxCoords = upperBound + this%component = field !This can refer to electric, magnetic or currentDensity + this%domain = domain + this%nFreq = domain%fnum + + call alloc_and_init(this%frequencySlice, this%nFreq, 0.0_RKIND) + do i = 1, this%nFreq + call init_frequency_slice(this%frequencySlice, this%domain) + end do + + call find_and_store_important_coords(this%mainCoords, this%auxCoords, this%component, problemInfo, this%nPoints, this%coords) + + call alloc_and_init(this%xValueForFreq, this%nFreq, this%nPoints, (0.0_CKIND, 0.0_CKIND)) + call alloc_and_init(this%yValueForFreq, this%nFreq, this%nPoints, (0.0_CKIND, 0.0_CKIND)) + call alloc_and_init(this%zValueForFreq, this%nFreq, this%nPoints, (0.0_CKIND, 0.0_CKIND)) + + call alloc_and_init(this%auxExp_E, this%nFreq, (0.0_CKIND, 0.0_CKIND)) + call alloc_and_init(this%auxExp_H, this%nFreq, (0.0_CKIND, 0.0_CKIND)) + + do i = 1, this%nFreq + this%auxExp_E(i) = timeInterval*(1.0E0_RKIND, 0.0E0_RKIND)*Exp(mcpi2*this%frequencySlice(i)) ! the dt should be some kind of average + this%auxExp_H(i) = this%auxExp_E(i)*Exp(mcpi2*this%frequencySlice(i)*timeInterval*0.5_RKIND) + end do + + this%path = get_output_path_freq(this, outputTypeExtension, field, control) + + filename = get_last_component(this%path) + this%filesPath = join_path(this%path, filename) + + call create_folder(this%path, error) + call create_bin_file(this%filesPath, error) + end subroutine init_frequency_slice_probe_output + + subroutine create_bin_file(filePath, error) + character(len=*), intent(in) :: filePath + integer, intent(out) :: error + call create_file_with_path(add_extension(filePath, binaryExtension), error) + end subroutine + + subroutine write_bin_file(this) + ! Check type definition for binary format + type(frequency_slice_probe_output_t), intent(inout) :: this + integer :: i, f, unit + !We rewrite the binary as simulation continues + open (unit=unit, file=add_extension(this%filesPath, binaryExtension), & + status='old', form='unformatted', action='write', access='stream') + do f = 1, this%nFreq + do i = 1, this%nPoints + write(unit) this%frequencySlice(f), this%coords(1,i), this%coords(2,i), this%coords(3,i), this%xValueForFreq(f,i), this%yValueForFreq(f,i), this%xValueForFreq(f,i) + end do + end do + flush (unit) + close (unit) + end subroutine + + subroutine write_to_xdmf_h5(this) + !If we call to this subrutine it will always replace old values + type(frequency_slice_probe_output_t), intent(inout) :: this + + integer(HID_T) :: file_id + integer :: f, error, xdmfunit + real(dp), allocatable, dimension(:, :) :: coordsReal + character(len=256) :: h5_filename, h5_filepath + character(len=256) :: xdmf_filename + character(len=10) :: dimension_string + character(len=10) :: nCoordsString + character(len=14) :: stepName + h5_filepath = add_extension(this%filesPath, ".h5") + h5_filename = get_last_component(h5_filepath) + + call H5open_f(error) + call H5Fopen_f(trim(h5_filepath), H5F_ACC_RDWR_F, file_id, error) + write(dimension_string, '(I0,1X,I0)') this%nPoints, this%nFreq + write(nCoordsString, '(I0, I0)') this%nPoints, 1 + do f = 1, this%nFreq + write(stepName, '((I5.5))') f + call h5_append_rows_to_dataset(file_id, "xVal", reshape(real(abs(this%xValueForFreq(f, :)), dp), [1, this%nPoints])) + call h5_append_rows_to_dataset(file_id, "yVal", reshape(real(abs(this%yValueForFreq(f, :)), dp), [1, this%nPoints])) + call h5_append_rows_to_dataset(file_id, "zVal", reshape(real(abs(this%zValueForFreq(f, :)), dp), [1, this%nPoints])) + end do + call H5Fclose_f(file_id, error) + call H5close_f(error) + end subroutine + + function get_output_path_freq(this, outputTypeExtension, field, control) result(outputPath) + type(frequency_slice_probe_output_t), intent(in) :: this + character(len=*), intent(in) :: outputTypeExtension + integer(kind=SINGLE), intent(in) :: field + type(sim_control_t), intent(in) :: control + character(len=BUFSIZE) :: probeBoundsExtension, prefixFieldExtension + character(len=BUFSIZE) :: outputPath + probeBoundsExtension = get_coordinates_extension(this%mainCoords, this%auxCoords, control%mpidir) + prefixFieldExtension = get_prefix_extension(field, control%mpidir) + outputPath = & + trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + end function get_output_path_freq + + subroutine update_frequency_slice_probe_output(this, step, fieldsReference, control, problemInfo) + type(frequency_slice_probe_output_t), intent(inout) :: this + real(kind=RKIND_tiempo), intent(in) :: step + type(sim_control_t), intent(in) :: control + type(problem_info_t), intent(in) :: problemInfo + type(fields_reference_t), intent(in) :: fieldsReference + + integer(kind=4) :: request + request = this%component + + if (any(VOLUMIC_M_MEASURE == request)) then + select case (request) + case (iCur); call save_current_module(this, fieldsReference, step, problemInfo) + case (iMEC); call save_field_module(this, fieldsReference%E, step, request, problemInfo) + case (iMHC); call save_field_module(this, fieldsReference%H, step, request, problemInfo) + case default; call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + + else if (any(VOLUMIC_X_MEASURE == request)) then + select case (request) + case (iCurX); call save_current_component(this, this%xValueForFreq, fieldsReference, problemInfo, iEx, this%auxExp_E, this%nFreq, step) + case (iExC); call save_field_component(this, this%xValueForFreq, fieldsReference%E%x, step, problemInfo, iEx) + case (iHxC); call save_field_component(this, this%xValueForFreq, fieldsReference%H%x, step, problemInfo, iHx) + case default; call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + + else if (any(VOLUMIC_Y_MEASURE == request)) then + select case (request) + case (iCurY); call save_current_component(this, this%yValueForFreq, fieldsReference, problemInfo, iEy, this%auxExp_E, this%nFreq, step) + case (iEyC); call save_field_component(this, this%yValueForFreq, fieldsReference%E%y, step, problemInfo, iEy) + case (iHyC); call save_field_component(this, this%yValueForFreq, fieldsReference%H%y, step, problemInfo, iHy) + case default; call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + + else if (any(VOLUMIC_Z_MEASURE == request)) then + select case (request) + case (iCurZ); call save_current_component(this, this%zValueForFreq, fieldsReference, problemInfo, iEz, this%auxExp_E, this%nFreq, step) + case (iEzC); call save_field_component(this, this%zValueForFreq, fieldsReference%E%z, step, problemInfo, iEz) + case (iHzC); call save_field_component(this, this%zValueForFreq, fieldsReference%H%z, step, problemInfo, iHz) + case default; call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + end if + end subroutine update_frequency_slice_probe_output + + subroutine save_current_module(this, fieldsReference, step, problemInfo) + type(frequency_slice_probe_output_t), intent(inout) :: this + type(fields_reference_t), intent(in) :: fieldsReference + type(problem_info_t), intent(in) :: problemInfo + real(kind=RKIND_tiempo), intent(in) :: step + + integer :: i, j, k, coordIdx + + coordIdx = 0 + do i = this%mainCoords%x, this%auxCoords%x + do j = this%mainCoords%y, this%auxCoords%y + do k = this%mainCoords%z, this%auxCoords%z + if (isValidPointForCurrent(iCur, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_current(this%xValueForFreq, iEx, coordIdx, i, j, k, fieldsReference, this%auxExp_E, this%nFreq, step) + call save_current(this%yValueForFreq, iEy, coordIdx, i, j, k, fieldsReference, this%auxExp_E, this%nFreq, step) + call save_current(this%zValueForFreq, iEz, coordIdx, i, j, k, fieldsReference, this%auxExp_E, this%nFreq, step) + end if + end do + end do + end do + end subroutine + + subroutine save_current_component(this, currentData, fieldsReference, problemInfo, fieldDir, auxExp, nFreq, step) + type(frequency_slice_probe_output_t), intent(inout) :: this + complex(kind=CKIND), intent(inout) :: currentData(:, :) + type(fields_reference_t), intent(in) :: fieldsReference + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: fieldDir, nFreq + complex(kind=ckind), intent(in), dimension(:) :: auxExp + real(kind=RKIND_tiempo), intent(in) :: step + + integer :: i, j, k, coordIdx + + coordIdx = 0 + do i = this%mainCoords%x, this%auxCoords%x + do j = this%mainCoords%y, this%auxCoords%y + do k = this%mainCoords%z, this%auxCoords%z + if (isValidPointForCurrent(fieldDir, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_current(currentData, fieldDir, coordIdx, i, j, k, fieldsReference, auxExp, nFreq, step) + end if + end do + end do + end do + end subroutine + + subroutine save_current(valorComplex, direction, coordIdx, i, j, k, fieldsReference, auxExponential, nFreq, step) + integer, intent(in) :: direction + complex(kind=CKIND), intent(inout) :: valorComplex(:, :) + complex(kind=CKIND), intent(in) :: auxExponential(:) + integer, intent(in) :: i, j, k, coordIdx, nFreq + type(fields_reference_t), intent(in) :: fieldsReference + real(kind=RKIND_tiempo), intent(in) :: step + + integer :: iter + complex(kind=CKIND) :: z_cplx = (0.0_RKIND, 0.0_RKIND) + real(kind=rkind) :: jdir + + jdir = computej(direction, i, j, k, fieldsReference) + + do iter = 1, nFreq + valorComplex(iter, coordIdx) = valorComplex(iter, coordIdx) + (auxExponential(iter)**step)*jdir + end do + end subroutine + + subroutine save_field_module(this, fieldInfo, simTime, request, problemInfo) + type(frequency_slice_probe_output_t), intent(inout) :: this + type(field_data_t), intent(in) :: fieldInfo + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: request + + complex(kind=CKIND), dimension(this%nFreq) :: auxExponential + integer :: i, j, k, coordIdx + + if (iMHC == request) auxExponential = this%auxExp_H**simTime + if (iMEC == request) auxExponential = this%auxExp_E**simTime + + coordIdx = 0 + do i = this%mainCoords%x, this%auxCoords%x + do j = this%mainCoords%y, this%auxCoords%y + do k = this%mainCoords%z, this%auxCoords%z + if (isValidPointForField(request, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_field(this%xValueForFreq, auxExponential, fieldInfo%x(i, j, k), this%nFreq, coordIdx) + call save_field(this%yValueForFreq, auxExponential, fieldInfo%y(i, j, k), this%nFreq, coordIdx) + call save_field(this%zValueForFreq, auxExponential, fieldInfo%z(i, j, k), this%nFreq, coordIdx) + end if + end do + end do + end do + + end subroutine + + subroutine save_field_component(this, fieldData, fieldComponent, simTime, problemInfo, fieldDir) + type(frequency_slice_probe_output_t), intent(inout) :: this + complex(kind=CKIND), intent(inout) :: fieldData(:, :) + real(kind=RKIND), intent(in) :: fieldComponent(:, :, :) + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: fieldDir + + complex(kind=CKIND), dimension(this%nFreq) :: auxExponential + integer :: i, j, k, coordIdx + + if (any(MAGNETIC_FIELD_DIRECTION == fieldDir)) auxExponential = this%auxExp_H**simTime + if (any(ELECTRIC_FIELD_DIRECTION == fieldDir)) auxExponential = this%auxExp_E**simTime + + coordIdx = 0 + do i = this%mainCoords%x, this%auxCoords%x + do j = this%mainCoords%y, this%auxCoords%y + do k = this%mainCoords%z, this%auxCoords%z + if (isValidPointForField(fieldDir, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_field(fieldData, auxExponential, fieldComponent(i, j, k), this%nFreq, coordIdx) + end if + end do + end do + end do + end subroutine + + subroutine save_field(valorComplex, auxExp, fieldValue, nFreq, coordIdx) + complex(kind=CKIND), intent(inout) :: valorComplex(:, :) + complex(kind=CKIND), intent(in) :: auxExp(:) + real(KIND=RKIND), intent(in) :: fieldValue + integer(KIND=SINGLE), intent(in) :: nFreq, coordIdx + + integer :: freq + + do freq = 1, nFreq + valorComplex = valorComplex(freq, coordIdx) + auxExp(freq)*fieldValue + end do + end subroutine + + subroutine flush_frequency_slice_probe_output(this) + type(frequency_slice_probe_output_t), intent(inout) :: this + call write_bin_file(this) + end subroutine flush_frequency_slice_probe_output + + subroutine close_frequency_slice_probe_output(this) + type(frequency_slice_probe_output_t), intent(inout) :: this + call write_to_xdmf_h5(this) + end subroutine + + + +end module mod_frequencySliceProbeOutput diff --git a/src_output/mapVTKOutput.F90 b/src_output/mapVTKOutput.F90 new file mode 100644 index 00000000..4c3f36f7 --- /dev/null +++ b/src_output/mapVTKOutput.F90 @@ -0,0 +1,344 @@ +module mod_mapVTKOutput + use FDETYPES + use outputTypes + use mod_outputUtils + use mod_directoryUtils + use mod_allocationUtils + use mod_vtkAPI + use mod_volumicProbeUtils + use Report + + implicit none +contains + subroutine init_mapvtk_output(this, lowerBound, upperBound, field, outputTypeExtension, mpidir, problemInfo) + type(mapvtk_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + type(problem_info_t), target ,intent(in) :: problemInfo + integer(kind=SINGLE), intent(in) :: mpidir, field + character(len=BUFSIZE), intent(in) :: outputTypeExtension + + integer(kind=SINGLE) :: i + + this%mainCoords = lowerBound + this%auxCoords = upperBound + this%component = field + + this%path = get_output_path() + call store_relevant_coordinates(this, problemInfo) + + contains + + function get_output_path() result(outputPath) + character(len=BUFSIZE) :: probeBoundsExtension, prefixFieldExtension + character(len=BUFSIZE) :: outputPath + probeBoundsExtension = get_coordinates_extension(this%mainCoords, this%auxCoords, mpidir) + prefixFieldExtension = get_prefix_extension(field, mpidir) + outputPath = & + trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + return + end function + + subroutine store_media_tag() + end subroutine store_media_tag + end subroutine init_mapvtk_output + + subroutine store_relevant_coordinates(this, problemInfo) + type(mapvtk_output_t), intent(inout) :: this + type(problem_info_t), pointer, intent(in) :: problemInfo + + integer :: i, j, k, field, counter + + counter = 0 + do k = this%mainCoords%Z, this%auxCoords%Z + do j = this%mainCoords%Y, this%auxCoords%Y + do i = this%mainCoords%X, this%auxCoords%X + do field = iEx, iEz + if (isEdge(field, i, j, k, problemInfo)) then + counter = counter + 1 + end if + end do + do field = iHx, iHz + if (isWithinBounds(field, i, j, k, problemInfo)) then + if (isMaterialExceptPML(field, i, j, k, problemInfo)) then + counter = counter + 1 + end if + if (problemInfo%materialTag%getFaceTag(field, i, j, k) < 0 & + .and. (btest(iabs(problemInfo%materialTag%getFaceTag(field, i, j, k)), field - 1)) & + .and. (.not. isPML(field, i, j, k, problemInfo))) then + counter = counter + 1 + end if + end if + end do + end do + end do + end do + + this%nPoints = counter + call alloc_and_init(this%coords, 3, this%nPoints, -99) + call alloc_and_init(this%materialTag, this%nPoints, -1) + call alloc_and_init(this%currentType, this%nPoints, -1) + + counter = 0 + do k = this%mainCoords%Z, this%auxCoords%Z + do j = this%mainCoords%Y, this%auxCoords%Y + do i = this%mainCoords%X, this%auxCoords%X + do field = iEx, iEz + if (isEdge(field, i, j, k, problemInfo)) then + counter = counter + 1 + call writeFaceTagInfo(this, counter, i, j, k, field, problemInfo%materialTag%getFaceTag(field, i, j, k)) + end if + end do + do field = iHx, iHz + if (isWithinBounds(field, i, j, k, problemInfo)) then + if (isMaterialExceptPML(field, i, j, k, problemInfo)) then + counter = counter + 1 + call writeFaceTagInfo(this, counter, i, j, k, field, problemInfo%materialTag%getFaceTag(field, i, j, k)) + end if + if (problemInfo%materialTag%getFaceTag(field, i, j, k) < 0 & + .and. (btest(iabs(problemInfo%materialTag%getFaceTag(field, i, j, k)), field - 1)) & + .and. .not. isPML(field, i, j, k, problemInfo)) then + counter = counter + 1 + call writeFaceTagInfo(this, counter, i, j, k, field, problemInfo%materialTag%getFaceTag(field, i, j, k)) + end if + end if + end do + end do + end do + end do + end subroutine store_relevant_coordinates + + logical function isMaterialExceptPML(field, i, j, k, problemInfo) + integer, intent(in) :: field, i, j, k + type(problem_info_t), intent(in):: problemInfo + isMaterialExceptPML = .not. isMediaVacuum(field, i, j, k, problemInfo) + isMaterialExceptPML = isMaterialExceptPML .and. (.not. isPML(field, i, j, k, problemInfo)) + end function isMaterialExceptPML + + subroutine writeFaceTagInfo(this, counter, i, j, k, field, tag) + type(mapvtk_output_t), intent(inout) :: this + integer, intent(in) :: i, j, k, counter, tag, field + this%coords(1, counter) = i + this%coords(2, counter) = j + this%coords(3, counter) = k + this%currentType(counter) = currentType(field) + this%materialTag(counter) = tag + end subroutine + + subroutine create_geometry_simulation_vtu(this, control, realXGrid, realYGrid, realZGrid) + implicit none + + type(mapvtk_output_t), intent(in) :: this + type(sim_control_t), intent(in) :: control + real(KIND=RKIND), pointer, dimension(:), intent(in) :: realXGrid, realYGrid, realZGrid + + !type(vtk_file) :: vtkOutput + type(vtk_unstructured_grid), target :: ugrid + + integer :: ierr, i, npts, unit + real(RKIND), allocatable :: x(:), y(:), z(:), materialTag(:) + character(len=BUFSIZE) :: info_str + character(len=BUFSIZE) :: metadata_filename, vtuPath + + integer, allocatable :: conn(:), offsets(:), types(:) + integer :: numNodes, numEdges, numQuads + real(kind=RKIND), allocatable :: nodes(:, :) + integer(kind=SINGLE), allocatable :: edges(:, :), quads(:, :) + + call create_folder(this%path, ierr) + vtuPath = join_path(this%path, get_last_component(this%path))//vtuFileExtension + + call createUnstructuredDataForVTU(this%nPoints, this%coords, this%currentType, nodes, edges, quads, numNodes, numEdges, numQuads, control%vtkindex, realXGrid, realYGrid, realZGrid) + call ugrid%add_points(real(nodes, 4)) + + allocate (conn(2*numEdges + 4*numQuads)) + conn(1:2*numEdges) = reshape(edges, [2*numEdges]) + conn(2*numEdges + 1:2*numEdges + 4*numQuads) = reshape(quads, [4*numQuads]) + + allocate (offsets(numEdges + numQuads)) + do i = 1, numEdges + numQuads + if (i <= numEdges) then + if (i == 1) then + offsets(i) = 2 + else + offsets(i) = offsets(i - 1) + 2 + end if + else + if (i == 1) then + offsets(i) = 4 + else + offsets(i) = offsets(i - 1) + 4 + end if + end if + end do + + allocate (types(numEdges + numQuads)) + types(1:numEdges) = 3 + types(numEdges + 1:numEdges + numQuads) = 9 + + call ugrid%add_cell_connectivity(conn, offsets, types) + if (size(offsets) /= numQuads) then + print *, "Problema con offsets" + end if + if (size(types) /= numQuads) then + print *, "Problema con types" + end if + if (offsets(numQuads) /= size(conn)) then + print *, "Tenemos un problema con conn y offset" + end if + + call ugrid%write_file(vtuPath) + + !--------------------------------------------- + ! Metadata: write to .txt file + !--------------------------------------------- + info_str = 'PEC=0, already_YEEadvanced_byconformal=5, NOTOUCHNOUSE=6, '// & + 'WIRE=7, WIRE-COLISION=8, COMPO=3, DISPER=1, DIEL=2, SLOT=4, '// & + 'CONF=5/6, OTHER=-1 (ADD +0.5 for borders)' + + metadata_filename = trim(this%path)//'.txt' + open (newunit=unit, file=metadata_filename, status='replace', action='write', iostat=ierr) + if (ierr /= 0) then + print *, 'Error opening metadata file: ', metadata_filename + else + write (unit, '(A)') trim(info_str) + close (unit) + end if + + end subroutine create_geometry_simulation_vtu + + logical function isEdge(campo, iii, jjj, kkk, problemInfo) + integer(4), intent(in) :: campo, iii, jjj, kkk + type(problem_info_t), pointer, intent(in) :: problemInfo + + type(MediaData_t), pointer, dimension(:) :: mData + type(limit_t), pointer, dimension(:) :: problemDimension + + integer(4) :: imed, imed1, imed2, imed3, imed4, contaborde + + mData => problemInfo%materialList + problemDimension => problemInfo%problemDimension + isEdge = .false. + contaborde = 0 + + call get_media_from_coord_and_h_neighbours(campo, iii, jjj, kkk, problemInfo%geometryToMaterialData, imed, imed1, imed2, imed3, imed4) + + if (imed /= 1) then + + if (mData(imed)%is%SGBC) then + + if (mData(imed1)%is%SGBC) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed1)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed1 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed2)%is%SGBC) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed2)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed2 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed3)%is%SGBC) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed3)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed3 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed4)%is%SGBC) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed4)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed4 /= 1) then + contaborde = contaborde + 1 + end if + + elseif (mData(imed)%is%Multiport) then + + if (mData(imed1)%is%Multiport) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed1)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed1 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed2)%is%Multiport) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed2)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed2 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed3)%is%Multiport) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed3)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed3 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed4)%is%Multiport) then + if (trim(adjustl(mData(imed)%Multiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed4)%Multiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed4 /= 1) then + contaborde = contaborde + 1 + end if + + elseif (mData(imed)%is%AnisMultiport) then + + if (mData(imed1)%is%AnisMultiport) then + if (trim(adjustl(mData(imed)%AnisMultiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed1)%AnisMultiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed1 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed2)%is%AnisMultiport) then + if (trim(adjustl(mData(imed)%AnisMultiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed2)%AnisMultiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed2 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed3)%is%AnisMultiport) then + if (trim(adjustl(mData(imed)%AnisMultiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed3)%AnisMultiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed3 /= 1) then + contaborde = contaborde + 1 + end if + + if (mData(imed4)%is%AnisMultiport) then + if (trim(adjustl(mData(imed)%AnisMultiport(1)%MultiportFileZ11)) /= & + trim(adjustl(mData(imed4)%AnisMultiport(1)%MultiportFileZ11))) contaborde = contaborde + 1 + elseif (imed4 /= 1) then + contaborde = contaborde + 1 + end if + + else + if ((imed /= imed1) .and. (imed1 /= 1)) contaborde = contaborde + 1 + if ((imed /= imed2) .and. (imed2 /= 1)) contaborde = contaborde + 1 + if ((imed /= imed3) .and. (imed3 /= 1)) contaborde = contaborde + 1 + if ((imed /= imed4) .and. (imed4 /= 1)) contaborde = contaborde + 1 + end if + + if ((imed1 == 1 .and. imed2 == 1 .and. imed3 == 1 .and. imed4 /= 1) .or. & + (imed2 == 1 .and. imed3 == 1 .and. imed4 == 1 .and. imed1 /= 1) .or. & + (imed3 == 1 .and. imed4 == 1 .and. imed1 == 1 .and. imed2 /= 1) .or. & + (imed4 == 1 .and. imed1 == 1 .and. imed2 == 1 .and. imed3 /= 1) .or. & + (imed1 == 1 .and. imed2 == 1 .and. imed3 == 1 .and. imed4 == 1) .or. & + (contaborde > 0)) isEdge = .true. + + if ((iii > problemDimension(campo)%XE) .or. (jjj > problemDimension(campo)%YE) .or. & + (kkk > problemDimension(campo)%ZE)) isEdge = .false. + + if ((iii < problemDimension(campo)%XI) .or. (jjj < problemDimension(campo)%YI) .or. & + (kkk < problemDimension(campo)%ZI)) isEdge = .false. + + else + isEdge = .false. + end if + + end function + +end module mod_mapVTKOutput + diff --git a/src_output/movieProbeOutput.F90 b/src_output/movieProbeOutput.F90 new file mode 100644 index 00000000..359bc78f --- /dev/null +++ b/src_output/movieProbeOutput.F90 @@ -0,0 +1,479 @@ +module mod_movieProbeOutput + use FDETYPES + USE mod_UTILS + use Report + use outputTypes + use mod_outputUtils + use mod_volumicProbeUtils + use HDF5 + use mod_xdmfAPI + implicit none + private + + !=========================== + ! Public interface + !=========================== + public :: init_movie_probe_output + public :: update_movie_probe_output + public :: flush_movie_probe_output + !=========================== + + !=========================== + ! Private helpers + !=========================== + ! Output & File Management + private :: clear_memory_data + +contains + + !=========================== + ! Public routines + !=========================== + + subroutine init_movie_probe_output(this, lowerBound, upperBound, field, domain, control, problemInfo, outputTypeExtension) + type(movie_probe_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: field + type(domain_t), intent(in) :: domain + type(sim_control_t), intent(in) :: control + type(problem_info_t), intent(in) :: problemInfo + character(len=BUFSIZE), intent(in) :: outputTypeExtension + + integer :: error + character(len=BUFSIZE) :: filename + real(RKIND), pointer :: xsteps(:), ysteps(:), zsteps(:) + + this%mainCoords = lowerBound + this%auxCoords = upperBound + this%component = field + this%domain = domain + + xsteps => problemInfo%xSteps(lowerBound%x:upperBound%x) + ysteps => problemInfo%ySteps(lowerBound%y:upperBound%y) + zsteps => problemInfo%zSteps(lowerBound%z:upperBound%z) + + call find_and_store_important_coords(this%mainCoords, this%auxCoords, this%component, problemInfo, this%nPoints, this%coords) + call alloc_and_init(this%timeStep, BUFSIZE, 0.0_RKIND_tiempo) + + ! Allocate value arrays based on component type + call alloc_and_init(this%xValueForTime, BUFSIZE, this%nPoints, 0.0_RKIND) + call alloc_and_init(this%yValueForTime, BUFSIZE, this%nPoints, 0.0_RKIND) + call alloc_and_init(this%zValueForTime, BUFSIZE, this%nPoints, 0.0_RKIND) + + this%path = get_output_path(this, outputTypeExtension, field, control%mpidir) + filename = get_last_component(this%path) + this%filesPath = join_path(this%path, filename) + + call create_folder(this%path, error) + call create_bin_file(this%filesPath, error) + call create_movie_files(this, error, xsteps, ysteps, zsteps) + if (error/=0) print *, 'error en creacion' + end subroutine init_movie_probe_output + + subroutine create_bin_file(filePath, error) + character(len=*), intent(in) :: filePath + integer, intent(out) :: error + call create_file_with_path(add_extension(filePath, binaryExtension), error) + end subroutine + + subroutine create_movie_files(this, error, xsteps, ysteps, zsteps) + type(movie_probe_output_t), intent(in) :: this + real(RKIND), pointer, intent(in) :: xsteps(:), ysteps(:), zsteps(:) + integer, intent(out) :: error + + real(dp), allocatable, dimension(:, :) :: coordsReal + integer(HID_T) :: file_id + character(len=BUFSIZE) :: h5_filename + character(len=BUFSIZE) :: attributeBaseName + integer(SINGLE), dimension(3) :: topology_size + + h5_filename = add_extension(this%filesPath, ".h5") + topology_size(1) = this%auxCoords%x - this%mainCoords%x + 1 + topology_size(2) = this%auxCoords%y - this%mainCoords%y + 1 + topology_size(3) = this%auxCoords%z - this%mainCoords%z + 1 + + call H5open_f(error) + call create_h5_file(trim(h5_filename), file_id) + + call h5_create_rectilinear_coords_dataset(file_id, real(xsteps,dp), real(ysteps,dp), real(zsteps,dp)) + call h5_create_times_dataset(file_id, BUFSIZE) + call create_h5_data_dataset(file_id, this%component, topology_size) + + call H5Fclose_f(file_id, error) + call H5close_f(error) + end subroutine + + subroutine create_h5_data_dataset(file_id, requestedComponent, topology_size) + integer(HID_T), intent(in) :: file_id + integer(SINGLE), intent(in) :: requestedComponent + integer(SINGLE), dimension(3), intent(in) :: topology_size + + character(len=BUFSIZE) :: attributeBaseName + + select case(requestedComponent) + case(iCur, iCurX, iCurY, iCurZ); attributeBaseName = 'CurrenDensity' + case(iMEC, iExC, iEyC, iEzC); attributeBaseName = 'ElectricField' + case(iMHC, iHxC, iHyC, iHzC); attributeBaseName = 'MagneticField' + end select + + select case(requestedComponent) + case(iCur, iMEC, iMHC) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'X', topology_size, BUFSIZE) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'Y', topology_size, BUFSIZE) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'Z', topology_size, BUFSIZE) + case(iCurX, iEXC, iHXC) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'X', topology_size, BUFSIZE) + case(iCurY, iEyC, iHyC) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'Y', topology_size, BUFSIZE) + case(iCurZ, iEZC, iHzC) + call h5_init_extendable_dataset(file_id, trim(attributeBaseName)//'Z', topology_size, BUFSIZE) + end select + end subroutine + + subroutine update_movie_probe_output(this, step, fieldsReference, control, problemInfo) + type(movie_probe_output_t), intent(inout) :: this + real(kind=RKIND_tiempo), intent(in) :: step + type(fields_reference_t), intent(in) :: fieldsReference + type(sim_control_t), intent(in) :: control + type(problem_info_t), intent(in) :: problemInfo + + integer(kind=4) :: request + request = this%component + this%nTime = this%nTime + 1 + + ! Determine which save routine to call + if (any(VOLUMIC_M_MEASURE == request)) then + select case (request) + case (iCur) + call save_current_module(this, fieldsReference, step, problemInfo) + case (iMEC) + call save_field_module(this, fieldsReference%E, request, step, problemInfo) + case (iMHC) + call save_field_module(this, fieldsReference%H, request, step, problemInfo) + case default + call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + else if (any(VOLUMIC_X_MEASURE == request)) then + select case (request) + case (iCurX) + call save_current_component(this, this%xValueForTime, fieldsReference, step, problemInfo, iEx) + case (iExC) + call save_field_component(this, this%xValueForTime, fieldsReference%E%x, step, problemInfo, iEx) + case (iHxC) + call save_field_component(this, this%xValueForTime, fieldsReference%H%x, step, problemInfo, iHx) + case default + call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + else if (any(VOLUMIC_Y_MEASURE == request)) then + select case (request) + case (iCurY) + call save_current_component(this, this%yValueForTime, fieldsReference, step, problemInfo, iEy) + case (iEyC) + call save_field_component(this, this%yValueForTime, fieldsReference%E%y, step, problemInfo, iEy) + case (iHyC) + call save_field_component(this, this%yValueForTime, fieldsReference%H%y, step, problemInfo, iHy) + case default + call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + else if (any(VOLUMIC_Z_MEASURE == request)) then + select case (request) + case (iCurZ) + call save_current_component(this, this%zValueForTime, fieldsReference, step, problemInfo, iEz) + case (iEzC) + call save_field_component(this, this%zValueForTime, fieldsReference%E%z, step, problemInfo, iEz) + case (iHzC) + call save_field_component(this, this%zValueForTime, fieldsReference%H%z, step, problemInfo, iHz) + case default + call StopOnError(control%layoutnumber, control%size, "Volumic measure not supported") + end select + end if + end subroutine update_movie_probe_output + + subroutine flush_movie_probe_output(this) + type(movie_probe_output_t), intent(inout) :: this + integer :: i + if (this%nTime /= 0) then + call write_bin_file(this) + call write_to_h5_file(this) + call write_to_xdmf_file(this) + end if + call clear_memory_data(this) + end subroutine flush_movie_probe_output + + !=========================== + ! Private routines + !=========================== + + subroutine write_bin_file(this) + ! Check type definition for binary format + type(movie_probe_output_t), intent(inout) :: this + integer :: i, t, unit + + open (unit=unit, file=add_extension(this%filesPath, binaryExtension), & + status='old', form='unformatted', position='append', access='stream') + do t = 1, this%nTime + do i = 1, this%nPoints + write(unit) this%timeStep(t), this%coords(1,i), this%coords(2,i), this%coords(3,i), this%xValueForTime(t,i), this%yValueForTime(t,i), this%zValueForTime(t,i) + end do + end do + flush (unit) + close (unit) + end subroutine + + subroutine write_to_xdmf_file(this) + type(movie_probe_output_t), intent(inout) :: this + + character(len=256) :: xdmf_filename + character(len=256) :: h5_filename + character(len=256) :: attributeBaseName + integer :: xdmfunit, error + integer, dimension(3) :: topologyDimensions + integer, dimension(4) :: h5_dimensions + xdmf_filename = add_extension(this%filesPath, ".xdmf") + h5_filename = add_extension(get_last_component(this%filesPath), ".h5") + + topologyDimensions(1) = this%auxCoords%x - this%mainCoords%x + 1 + topologyDimensions(2) = this%auxCoords%y - this%mainCoords%y + 1 + topologyDimensions(3) = this%auxCoords%z - this%mainCoords%z + 1 + + h5_dimensions(1) = this%nTime + this%nTimesFlushed + h5_dimensions(2) = topologyDimensions(3) + h5_dimensions(3) = topologyDimensions(2) + h5_dimensions(4) = topologyDimensions(1) + + select case(this%component) + case(iCur, iCurX, iCurY, iCurZ); attributeBaseName = 'CurrenDensity' + case(iMEC, iExC, iEyC, iEzC); attributeBaseName = 'ElectricField' + case(iMHC, iHxC, iHyC, iHzC); attributeBaseName = 'MagneticField' + end select + + open(newunit=xdmfunit, file=trim(xdmf_filename), status='replace', position='append', iostat=error) + call xdmf_write_header_file(xdmfunit, 'movieProbe') + + call xdmf_write_topology(xdmfunit, topologyDimensions) + call xdmf_write_geometry(xdmfunit, topologyDimensions, h5_filename) + call xdmf_write_time_array(xdmfunit, this%nTime + this%nTimesFlushed, h5_filename) + + select case(this%component) + case(iCur, iMEC, iMHC) + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'X') + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'Y') + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'Z') + case(iCurX, iEXC, iHXC) + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'X') + case(iCurY, iEyC, iHyC) + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'Y') + case(iCurZ, iEZC, iHzC) + call xdmf_write_scalar_attribute(xdmfunit, h5_dimensions, h5_filename, trim(attributeBaseName)//'Z') + end select + + call xdmf_write_footer_file(xdmfunit) + + close(xdmfunit) + end subroutine + + subroutine write_to_h5_file(this) + type(movie_probe_output_t), intent(inout) :: this + + integer(HID_T) :: file_id + integer :: i, error, probeDimensions(3) + real(dp), allocatable, dimension(:,:,:,:) :: h5Table + character(len=256) :: h5_filename, h5_filepath + character(len=256) :: attributeBaseName + h5_filepath = add_extension(this%filesPath, ".h5") + h5_filename = get_last_component(h5_filepath) + + !Only stores the volume associated to that probe + + probeDimensions(1) = this%auxCoords%x - this%mainCoords%x + 1 + probeDimensions(2) = this%auxCoords%y - this%mainCoords%y + 1 + probeDimensions(3) = this%auxCoords%z - this%mainCoords%z + 1 + + select case(this%component) + case(iCur, iCurX, iCurY, iCurZ); attributeBaseName = 'CurrenDensity' + case(iMEC, iExC, iEyC, iEzC); attributeBaseName = 'ElectricField' + case(iMHC, iHxC, iHyC, iHzC); attributeBaseName = 'MagneticField' + end select + + call H5open_f(error) + call H5Fopen_f(trim(h5_filepath), H5F_ACC_RDWR_F, file_id, error) + + call h5_append_rows_to_dataset(file_id, 'times', this%timeStep(:this%nTime)) + + allocate(h5Table(probeDimensions(1), probeDimensions(2), probeDimensions(3), this%nTime)) !(x,y,z,t) + if (any([iCur, iMEC, iMHC, iCurX, iExC, iHxC]==this%component)) then + h5Table = 0_dp + do i=1, this%nPoints !Readjust idx into hyperslab (x,y,z,t) + h5Table(this%coords(1,i) - this%mainCoords%x + 1, & + this%coords(2,i) - this%mainCoords%y + 1, & + this%coords(3,i) - this%mainCoords%z + 1, & + : ) = this%xValueForTime(:this%nTime, i) + end do + call h5_append_rows_to_dataset(file_id, trim(attributeBaseName)//'X', h5Table) + end if + if (any([iCur, iMEC, iMHC, iCurY, iEyC, iHyC]==this%component)) then + h5Table = 0_dp + do i=1, this%nPoints !Readjust idx into hyperslab (x,y,z,t) + h5Table(this%coords(1,i) - this%mainCoords%x + 1, & + this%coords(2,i) - this%mainCoords%y + 1, & + this%coords(3,i) - this%mainCoords%z + 1, & + : ) = this%yValueForTime(:this%nTime, i) + end do + call h5_append_rows_to_dataset(file_id, trim(attributeBaseName)//'Y', h5Table) + end if + if (any([iCur, iMEC, iMHC, iCurZ, iEzC, iHzC]==this%component)) then + h5Table = 0_dp + do i=1, this%nPoints !Readjust idx into hyperslab (x,y,z,t) + h5Table(this%coords(1,i) - this%mainCoords%x + 1, & + this%coords(2,i) - this%mainCoords%y + 1, & + this%coords(3,i) - this%mainCoords%z + 1, & + : ) = this%zValueForTime(:this%nTime, i) + end do + call h5_append_rows_to_dataset(file_id, trim(attributeBaseName)//'Z', h5Table) + end if + deallocate(h5Table) + + call H5Fclose_f(file_id, error) + call H5close_f(error) + if (error/=0) stop + end subroutine write_to_h5_file + + function get_output_path(this, outputTypeExtension, field, mpidir) result(path) + type(movie_probe_output_t), intent(in) :: this + character(len=*), intent(in) :: outputTypeExtension + integer(kind=SINGLE), intent(in) :: field, mpidir + character(len=BUFSIZE) :: path, probeBoundsExtension, prefixFieldExtension + + probeBoundsExtension = get_coordinates_extension(this%mainCoords, this%auxCoords, mpidir) + prefixFieldExtension = get_prefix_extension(field, mpidir) + path = trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + end function get_output_path + + subroutine save_current_module(this, fieldsReference, simTime, problemInfo) + type(movie_probe_output_t), intent(inout) :: this + type(fields_reference_t), intent(in) :: fieldsReference + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + + integer :: i, j, k, coordIdx + this%timeStep(this%nTime) = simTime + coordIdx = 0 + do k = this%mainCoords%z, this%auxCoords%z + do j = this%mainCoords%y, this%auxCoords%y + do i = this%mainCoords%x, this%auxCoords%x + if (isValidPointForCurrent(iCur, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_current(this%xValueForTime, this%nTime, coordIdx, iEx, i, j, k, fieldsReference) + call save_current(this%yValueForTime, this%nTime, coordIdx, iEy, i, j, k, fieldsReference) + call save_current(this%zValueForTime, this%nTime, coordIdx, iEz, i, j, k, fieldsReference) + end if + end do + end do + end do + end subroutine save_current_module + + subroutine save_current_component(this, currentData, fieldsReference, simTime, problemInfo, fieldDir) + type(movie_probe_output_t), intent(inout) :: this + real(kind=RKIND), intent(inout) :: currentData(:, :) + type(fields_reference_t), intent(in) :: fieldsReference + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: fieldDir + + integer :: i, j, k, coordIdx + this%timeStep(this%nTime) = simTime + coordIdx = 0 + do k = this%mainCoords%z, this%auxCoords%z + do j = this%mainCoords%y, this%auxCoords%y + do i = this%mainCoords%x, this%auxCoords%x + if (isValidPointForCurrent(fieldDir, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_current(currentData, this%nTime, coordIdx, fieldDir, i, j, k, fieldsReference) + end if + end do + end do + end do + end subroutine save_current_component + + subroutine save_current(currentData, timeIdx, coordIdx, field, i, j, k, fieldsReference) + real(kind=RKIND), intent(inout) :: currentData(:, :) + integer(kind=SINGLE), intent(in) :: timeIdx, coordIdx, field, i, j, k + type(fields_reference_t), intent(in) :: fieldsReference + + currentData(timeIdx, coordIdx) = computeJ(field, i, j, k, fieldsReference) + end subroutine save_current + + subroutine save_field_module(this, field, request, simTime, problemInfo) + type(movie_probe_output_t), intent(inout) :: this + type(field_data_t), intent(in) :: field + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: request + + integer :: i, j, k, coordIdx + this%timeStep(this%nTime) = simTime + coordIdx = 0 + do k = this%mainCoords%z, this%auxCoords%z + do j = this%mainCoords%y, this%auxCoords%y + do i = this%mainCoords%x, this%auxCoords%x + if (isValidPointForField(request, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_field(this%xValueForTime, this%nTime, coordIdx, field%x(i, j, k)) + call save_field(this%yValueForTime, this%nTime, coordIdx, field%y(i, j, k)) + call save_field(this%zValueForTime, this%nTime, coordIdx, field%z(i, j, k)) + end if + end do + end do + end do + end subroutine save_field_module + + subroutine save_field_component(this, fieldData, fieldComponent, simTime, problemInfo, fieldDir) + type(movie_probe_output_t), intent(inout) :: this + real(kind=RKIND), intent(inout) :: fieldData(:, :) + real(kind=RKIND), intent(in) :: fieldComponent(:, :, :) + real(kind=RKIND_tiempo), intent(in) :: simTime + type(problem_info_t), intent(in) :: problemInfo + integer, intent(in) :: fieldDir + + integer :: i, j, k, coordIdx + this%timeStep(this%nTime) = simTime + coordIdx = 0 + do k = this%mainCoords%z, this%auxCoords%z + do j = this%mainCoords%y, this%auxCoords%y + do i = this%mainCoords%x, this%auxCoords%x + if (isValidPointForField(fieldDir, i, j, k, problemInfo)) then + coordIdx = coordIdx + 1 + call save_field(fieldData, this%nTime, coordIdx, fieldComponent(i, j, k)) + end if + end do + end do + end do + end subroutine save_field_component + + subroutine save_field(fieldData, timeIdx, coordIdx, fieldValue) + real(kind=RKIND), intent(inout) :: fieldData(:, :) + integer(kind=SINGLE), intent(in) :: timeIdx, coordIdx + real(kind=RKIND), intent(in) :: fieldValue + + fieldData(timeIdx, coordIdx) = fieldValue + end subroutine save_field + + subroutine clear_memory_data(this) + type(movie_probe_output_t), intent(inout) :: this + this%nTimesFlushed = this%nTimesFlushed + this%nTime + this%nTime = 0 + this%timeStep = 0.0_RKIND + if (any(VOLUMIC_M_MEASURE == this%component)) then + this%xValueForTime = 0.0_RKIND + this%yValueForTime = 0.0_RKIND + this%zValueForTime = 0.0_RKIND + else if (any(VOLUMIC_X_MEASURE == this%component)) then + this%xValueForTime = 0.0_RKIND + else if (any(VOLUMIC_Y_MEASURE == this%component)) then + this%yValueForTime = 0.0_RKIND + else if (any(VOLUMIC_Z_MEASURE == this%component)) then + this%zValueForTime = 0.0_RKIND + end if + end subroutine clear_memory_data + +end module mod_movieProbeOutput diff --git a/src_output/output.F90 b/src_output/output.F90 new file mode 100644 index 00000000..8e9a3c44 --- /dev/null +++ b/src_output/output.F90 @@ -0,0 +1,545 @@ +module output + use FDETYPES + use Report + use mod_domain + use mod_outputUtils + use mod_pointProbeOutput + use mod_wireProbeOutput + use mod_bulkProbeOutput + use mod_movieProbeOutput + use mod_frequencySliceProbeOutput + use mod_farFieldOutput + use mtln_solver_mod, only: mtln_solver_t => mtln_t + use Wire_bundles_mtln_mod, only: GetSolverPtr + use mod_mapVTKOutput + + + implicit none + private + + !=========================== + ! Public interface summary + !=========================== + public :: solver_output_t + public :: GetOutputs + public :: init_outputs + public :: update_outputs + public :: flush_outputs + public :: close_outputs + + public :: POINT_PROBE_ID, WIRE_CURRENT_PROBE_ID, WIRE_CHARGE_PROBE_ID, BULK_PROBE_ID, VOLUMIC_CURRENT_PROBE_ID, & + MOVIE_PROBE_ID, FREQUENCY_SLICE_PROBE_ID, FAR_FIELD_PROBE_ID + !=========================== + + !=========================== + ! Private interface summary + !=========================== + private :: get_required_output_count + !=========================== + + integer(kind=SINGLE), parameter :: UNDEFINED_PROBE = -1, & + POINT_PROBE_ID = 0, & + WIRE_CURRENT_PROBE_ID = 1, & + WIRE_CHARGE_PROBE_ID = 2, & + BULK_PROBE_ID = 3, & + VOLUMIC_CURRENT_PROBE_ID = 4, & + MOVIE_PROBE_ID = 5, & + FREQUENCY_SLICE_PROBE_ID = 6, & + FAR_FIELD_PROBE_ID = 7, & + MAPVTK_ID = 8 + + REAL(KIND=RKIND), save :: eps0, mu0 + REAL(KIND=RKIND), pointer, dimension(:), save :: InvEps, InvMu + type(solver_output_t), pointer, dimension(:), save :: outputs + type(problem_info_t), save, target :: problemInfo + + interface init_solver_output + module procedure & + init_point_probe_output, & + init_wire_current_probe_output, & + init_wire_charge_probe_output, & + init_bulk_probe_output, & + init_movie_probe_output, & + init_frequency_slice_probe_output, & + init_farField_probe_output, & + init_mapvtk_output + end interface + + interface update_solver_output + module procedure & + update_point_probe_output, & + update_wire_current_probe_output, & + update_wire_charge_probe_output, & + update_bulk_probe_output, & + update_movie_probe_output, & + update_frequency_slice_probe_output, & + update_farField_probe_output + end interface + + interface flush_solver_output + module procedure & + flush_point_probe_output, & + flush_wire_current_probe_output, & + flush_wire_charge_probe_output, & + flush_bulk_probe_output, & + flush_movie_probe_output, & + flush_frequency_slice_probe_output, & + flush_farField_probe_output + + end interface + + interface close_solver_output + module procedure close_frequency_slice_probe_output + end interface +contains + + function GetOutputs() result(r) + type(solver_output_t), pointer, dimension(:) :: r + r => outputs + return + end function + + function GetProblemInfo() result(r) + type(problem_info_t), pointer :: r + r => problemInfo + return + end function + + subroutine init_outputs(sgg, media, sinpml_fullsize, materialTags, bounds, control, observationsExists, wiresExists) + + type(SGGFDTDINFO), intent(in) :: sgg + type(media_matrices_t), target, intent(in) :: media + type(limit_t), dimension(:), target, intent(in) :: SINPML_fullsize + type(bounds_t),intent(in), target :: bounds + type(taglist_t),intent(in), target :: materialTags + type(sim_control_t), intent(in) :: control + logical, intent(inout) :: wiresExists + logical, intent(out) :: observationsExists + + type(domain_t) :: domain + type(spheric_domain_t) :: sphericRange + type(cell_coordinate_t) :: lowerBound, upperBound + integer(kind=SINGLE) :: i, ii, outputRequestType + integer(kind=SINGLE) :: NODE + integer(kind=SINGLE) :: outputCount + integer(kind=SINGLE) :: requestedOutputs + character(len=BUFSIZE) :: outputTypeExtension + +#ifdef CompileWithMTLN + logical :: thereAreMtlnObservations = .false. +#endif + observationsExists = .false. + requestedOutputs = get_required_output_count(sgg) + + problemInfo%geometryToMaterialData => media + problemInfo%materialList => sgg%Med + problemInfo%simulationBounds => bounds + problemInfo%problemDimension => SINPML_fullsize + problemInfo%materialTag => materialTags + problemInfo%xSteps => sgg%LineX + problemInfo%ySteps => sgg%LineY + problemInfo%zSteps => sgg%LineZ + + outputs => NULL() + allocate (outputs(requestedOutputs)) + + allocate (InvEps(0:sgg%NumMedia - 1), InvMu(0:sgg%NumMedia - 1)) + outputCount = 0 + + InvEps(0:sgg%NumMedia - 1) = 1.0_RKIND/(Eps0*sgg%Med(0:sgg%NumMedia - 1)%Epr) + InvMu(0:sgg%NumMedia - 1) = 1.0_RKIND/(Mu0*sgg%Med(0:sgg%NumMedia - 1)%Mur) + + !do ii = 1, sgg%NumberRequest + !do i = 1, sgg%Observation(ii)%nP + ! call eliminate_unnecesary_observation_points(sgg%Observation(ii)%P(i), output(ii)%item(i), & + ! sgg%Sweep, sgg%SINPMLSweep, sgg%Observation(ii)%P(1)%ZI, sgg%Observation(ii)%P(1)%ZE, control%layoutnumber, control%size) + !end do + !end do + +#ifdef CompileWithMTLN + block + type(mtln_solver_t), pointer :: mtln_solver + integer :: i, j + mtln_solver => GetSolverPtr() + if (mtln_solver%number_of_bundles > 0) then + do i = 1, ubound(mtln_solver%bundles, 1) + if (ubound(mtln_solver%bundles(i)%probes, 1) /= 0) then + do j = 1, ubound(mtln_solver%bundles(i)%probes, 1) + if (mtln_solver%bundles(i)%probes(j)%in_layer) thereAreMtlnObservations = .true. + end do + end if + end do + end if + end block +#endif + + do ii = 1, sgg%NumberRequest + domain = preprocess_domain(sgg%Observation(ii), sgg%tiempo, sgg%dt, control%finaltimestep) + if (domain%domainType == UNDEFINED_DOMAIN) cycle + do i = 1, sgg%Observation(ii)%nP + lowerBound%x = sgg%observation(ii)%P(i)%XI + lowerBound%y = sgg%observation(ii)%P(i)%YI + lowerBound%z = sgg%observation(ii)%P(i)%ZI + + upperBound%x = sgg%observation(ii)%P(i)%XE + upperBound%y = sgg%observation(ii)%P(i)%YE + upperBound%z = sgg%observation(ii)%P(i)%ZE + NODE = sgg%observation(ii)%P(i)%NODE + + outputTypeExtension = trim(adjustl(control%nEntradaRoot))//'_'//trim(adjustl(sgg%observation(ii)%outputrequest)) + + outputRequestType = sgg%observation(ii)%P(i)%what + select case (outputRequestType) + case (mapvtk) + outputCount = outputCount + 1 + outputs(outputCount)%outputID = MAPVTK_ID + + allocate (outputs(outputCount)%mapvtkOutput) + call init_solver_output(outputs(outputCount)%mapvtkOutput, lowerBound, upperBound, outputRequestType, outputTypeExtension, control%mpidir, problemInfo) + call create_geometry_simulation_vtu(outputs(outputCount)%mapvtkOutput, control, sgg%LineX, sgg%LineY, sgg%LineZ) + !! call adjust_computation_range --- Required due to issues in mpi region edges + + case (iEx, iEy, iEz, iHx, iHy, iHz) + outputCount = outputCount + 1 + outputs(outputCount)%outputID = POINT_PROBE_ID + + allocate (outputs(outputCount)%pointProbe) + call init_solver_output(outputs(outputCount)%pointProbe, lowerBound, outputRequestType, domain, outputTypeExtension, control%mpidir, sgg%dt) + case (iJx, iJy, iJz) + if (wiresExists) then + outputCount = outputCount + 1 + outputs(outputCount)%outputID = WIRE_CURRENT_PROBE_ID + + allocate (outputs(outputCount)%wireCurrentProbe) + call init_solver_output(outputs(outputCount)%wireCurrentProbe, lowerBound, NODE, outputRequestType, domain, problemInfo%materialList, outputTypeExtension, control%mpidir, control%wiresflavor) + end if + + case (iQx, iQy, iQz) + outputCount = outputCount + 1 + outputs(outputCount)%outputID = WIRE_CHARGE_PROBE_ID + + allocate (outputs(outputCount)%wireChargeProbe) + call init_solver_output(outputs(outputCount)%wireChargeProbe, lowerBound, NODE, outputRequestType, domain, outputTypeExtension, control%mpidir, control%wiresflavor) + + case (iBloqueJx, iBloqueJy, iBloqueJz, iBloqueMx, iBloqueMy, iBloqueMz) + outputCount = outputCount + 1 + outputs(outputCount)%outputID = BULK_PROBE_ID + + allocate (outputs(outputCount)%bulkCurrentProbe) + call init_solver_output(outputs(outputCount)%bulkCurrentProbe, lowerBound, upperBound, outputRequestType, domain, outputTypeExtension, control%mpidir) + !! call adjust_computation_range --- Required due to issues in mpi region edges + + case (iCur, iMEC, iMHC, iCurX, iCurY, iCurZ, iExC, iEyC, iEzC, iHxC, iHyC, iHzC) + call adjust_bound_range() + + if (domain%domainType == TIME_DOMAIN) then + + outputCount = outputCount + 1 + outputs(outputCount)%outputID = MOVIE_PROBE_ID + allocate (outputs(outputCount)%movieProbe) + call init_solver_output(outputs(outputCount)%movieProbe, lowerBound, upperBound, outputRequestType, domain, control, problemInfo, outputTypeExtension) + else if (domain%domainType == FREQUENCY_DOMAIN) then + + outputCount = outputCount + 1 + outputs(outputCount)%outputID = FREQUENCY_SLICE_PROBE_ID + allocate (outputs(outputCount)%frequencySliceProbe) + call init_solver_output(outputs(outputCount)%frequencySliceProbe, lowerBound, upperBound, sgg%dt, outputRequestType, domain, outputTypeExtension, control, problemInfo) + end if + case (farfield) + sphericRange = preprocess_polar_range(sgg%Observation(ii)) + + outputCount = outputCount + 1 + outputs(outputCount)%outputID = FAR_FIELD_PROBE_ID + allocate (outputs(outputCount)%farFieldOutput) + call init_solver_output(outputs(outputCount)%farFieldOutput, sgg, lowerBound, upperBound, outputRequestType, domain, sphericRange, outputTypeExtension, sgg%Observation(ii)%FileNormalize, control, problemInfo, eps0, mu0) + case default + call stoponerror(0, 0, 'OutputRequestType type not implemented yet on new observations') + end select + end do + end do + if (outputCount /= requestedOutputs) then + call remove_unused_outputs(outputs) + outputCount = size(outputs) + end if + if (outputCount /= 0) observationsExists = .true. +#ifdef CompileWithMTLN + observationsExists = observationsExists .or. thereAreMtlnObservations +#endif + if (observationsExists) call registerOutputFiles(control, outputCount) + return + contains + subroutine adjust_bound_range() + select case (outputRequestType) + case (iExC, iEyC, iHzC, iMhC) + lowerBound%z = max(sgg%Sweep(fieldo(outputRequestType, 'Z'))%ZI, sgg%observation(ii)%P(i)%ZI) + upperBound%z = min(sgg%Sweep(fieldo(outputRequestType, 'Z'))%ZE - 1, sgg%observation(ii)%P(i)%ZE) + case (iEzC, iHxC, iHyC, iMeC) + lowerBound%z = max(sgg%Sweep(fieldo(outputRequestType, 'Z'))%ZI, sgg%observation(ii)%P(i)%ZI) + upperbound%z = min(sgg%Sweep(fieldo(outputRequestType, 'Z'))%ZE, sgg%observation(ii)%P(i)%ZE) + case (iCur, iCurX, iCurY, iCurZ) + lowerBound%z = max(sgg%Sweep(fieldo(outputRequestType, 'X'))%ZI, sgg%observation(ii)%P(i)%ZI) !ojo estaba sweep(iEz) para ser conservador...puede dar problemas!! 03/07/15 + upperbound%z = min(sgg%Sweep(fieldo(outputRequestType, 'X'))%ZE, sgg%observation(ii)%P(i)%ZE) !ojo estaba sweep(iEz) para ser conservador...puede dar problemas!! 03/07/15 + end select + end subroutine + function preprocess_domain(observation, timeArray, simulationTimeStep, finalStepIndex) result(newDomain) + type(Obses_t), intent(in) :: observation + real(kind=RKIND_tiempo), pointer, dimension(:), intent(in) :: timeArray + real(kind=RKIND_tiempo), intent(in) :: simulationTimeStep + integer(kind=4), intent(in) :: finalStepIndex + type(domain_t) :: newDomain + + integer(kind=SINGLE) :: nFreq + + if (observation%TimeDomain) then + newdomain = domain_t(real(observation%InitialTime, kind=RKIND_tiempo), & + real(observation%FinalTime, kind=RKIND_tiempo), & + real(observation%TimeStep, kind=RKIND_tiempo)) + + newdomain%tstep = max(newdomain%tstep, simulationTimeStep) + + if (10.0_RKIND*(newdomain%tstop - newdomain%tstart)/min(simulationTimeStep, newdomain%tstep) >= huge(1_4)) then + newdomain%tstop = newdomain%tstart + min(simulationTimeStep, newdomain%tstep)*huge(1_4)/10.0_RKIND + end if + + if (newDomain%tstart < newDomain%tstep) then + newDomain%tstart = 0.0_RKIND_tiempo + end if + + if (newDomain%tstep > (newdomain%tstop - newdomain%tstart)) then + newDomain%tstop = newDomain%tstart + newDomain%tstep + end if + + elseif (observation%FreqDomain) then + !Just linear progression for now. Need to bring logartihmic info to here + nFreq = int((observation%FinalFreq - observation%InitialFreq)/observation%FreqStep, kind=SINGLE) + 1_SINGLE + newdomain = domain_t(observation%InitialFreq, observation%FinalFreq, nFreq, logarithmicspacing=.false.) + + newDomain%fstep = min(newDomain%fstep, 2.0_RKIND/simulationTimeStep) + if ((newDomain%fstep > newDomain%fstop - newDomain%fstart) .or. (newDomain%fstep == 0)) then + newDomain%fstep = newDomain%fstop - newDomain%fstart + newDomain%fstop = newDomain%fstart + newDomain%fstep + end if + + newDomain%fnum = int((newDomain%fstop - newDomain%fstart)/newDomain%fstep, kind=SINGLE) + + else + newDomain = domain_t() + end if + return + end function preprocess_domain + + function preprocess_polar_range(observation) result(sphericDomain) + type(spheric_domain_t) :: sphericDomain + type(Obses_t), intent(in) :: observation + + sphericDomain%phiStart = observation%phiStart + sphericDomain%phiStop = observation%phiStop + sphericDomain%phiStep = observation%phiStep + sphericDomain%thetaStart = observation%thetaStart + sphericDomain%thetaStop = observation%thetaStop + sphericDomain%thetaStep = observation%thetaStep + end function preprocess_polar_range + + end subroutine init_outputs + + subroutine update_outputs(control, discreteTimeArray, timeIndx, fieldsReference) + integer(kind=SINGLE), intent(in) :: timeIndx + real(kind=RKIND_tiempo), dimension(:), intent(in) :: discreteTimeArray + integer(kind=SINGLE) :: i, id + type(sim_control_t), intent(in) :: control + real(kind=RKIND), pointer, dimension(:, :, :) :: fieldComponent + type(field_data_t) :: fieldReference + type(fields_reference_t), intent(in) :: fieldsReference + real(kind=RKIND_tiempo) :: discreteTime + + discreteTime = discreteTimeArray(timeIndx) + + do i = 1, size(outputs) + select case (outputs(i)%outputID) + case (POINT_PROBE_ID) + fieldComponent => get_field_component(outputs(i)%pointProbe%component, fieldsReference) !Cada componente requiere de valores deiferentes pero estos valores no se como conseguirlos + call update_solver_output(outputs(i)%pointProbe, discreteTime, fieldComponent) + case (WIRE_CURRENT_PROBE_ID) + call update_solver_output(outputs(i)%wireCurrentProbe, discreteTime, control, InvEps, InvMu) + case (WIRE_CHARGE_PROBE_ID) + call update_solver_output(outputs(i)%wireChargeProbe, discreteTime) + case (BULK_PROBE_ID) + fieldReference = get_field_reference(outputs(i)%bulkCurrentProbe%component, fieldsReference) + call update_solver_output(outputs(i)%bulkCurrentProbe, discreteTime, fieldReference) + case (MOVIE_PROBE_ID) + call update_solver_output(outputs(i)%movieProbe, discreteTime, fieldsReference, control, problemInfo) + case (FREQUENCY_SLICE_PROBE_ID) + call update_solver_output(outputs(i)%frequencySliceProbe, discreteTime, fieldsReference, control, problemInfo) + case (FAR_FIELD_PROBE_ID) + call update_solver_output(outputs(i)%farFieldOutput, timeIndx, problemInfo%simulationBounds, fieldsReference) + case(MAPVTK_ID) + case default + call stoponerror(0, 0, 'Output update not implemented') + end select + end do + + end subroutine update_outputs + + subroutine flush_outputs(simulationTimeArray, simulationTimeIndex, control, fields, bounds, farFieldFlushRequested) + implicit none + type(fields_reference_t), target :: fields + type(fields_reference_t), pointer :: fieldsPtr + type(sim_control_t), intent(in) :: control + type(bounds_t), intent(in) :: bounds + logical, intent(in) :: farFieldFlushRequested + real(KIND=RKIND_tiempo), pointer, dimension(:), intent(in) :: simulationTimeArray + integer, intent(in) :: simulationTimeIndex + integer :: outIdx + + fieldsPtr => fields + + do outIdx = 1, size(outputs) + select case (outputs(outIdx)%outputID) + case (POINT_PROBE_ID) + call flush_solver_output(outputs(outIdx)%pointProbe) + case (WIRE_CURRENT_PROBE_ID) + call flush_solver_output(outputs(outIdx)%wireCurrentProbe) + case (WIRE_CHARGE_PROBE_ID) + call flush_solver_output(outputs(outIdx)%wireChargeProbe) + case (BULK_PROBE_ID) + call flush_solver_output(outputs(outIdx)%bulkCurrentProbe) + case (MOVIE_PROBE_ID) + call flush_solver_output(outputs(outIdx)%movieProbe) + case (FREQUENCY_SLICE_PROBE_ID) + call flush_solver_output(outputs(outIdx)%frequencySliceProbe) + case (FAR_FIELD_PROBE_ID) + if (farFieldFlushRequested) call flush_solver_output(outputs(outIdx)%farFieldOutput, simulationTimeArray, simulationTimeIndex, control, fieldsPtr, bounds) + case default + end select + end do + end subroutine flush_outputs + + subroutine remove_unused_outputs(output_list) + implicit none + type(solver_output_t), pointer, intent(inout) :: output_list(:) + + type(solver_output_t), allocatable :: tmp(:) + integer :: i, n, k + + n = count(output_list%outputID /= UNDEFINED_PROBE) + + allocate (tmp(n)) + + ! Copy valid elements + k = 0 + do i = 1, size(output_list) + if (output_list(i)%outputID /= UNDEFINED_PROBE) then + k = k + 1 + tmp(k) = output_list(i) ! deep copy of all allocatable components + end if + end do + + ! Replace the saved pointer target safely + if (associated(output_list)) deallocate (output_list) + allocate (output_list(n)) + output_list = tmp + + end subroutine remove_unused_outputs + + subroutine close_outputs() + integer :: i + do i = 1, size(outputs) + select case (outputs(i)%outputID) + case (POINT_PROBE_ID) + case (WIRE_CURRENT_PROBE_ID) + case (WIRE_CHARGE_PROBE_ID) + case (BULK_PROBE_ID) + case (VOLUMIC_CURRENT_PROBE_ID) + case (MOVIE_PROBE_ID) + case (FREQUENCY_SLICE_PROBE_ID) + call close_solver_output(outputs(i)%frequencySliceProbe) + end select + end do + end subroutine + + subroutine create_pvd(pvdPath) + implicit none + character(len=*), intent(out) :: pvdPath + integer :: ios + integer :: unit + + open (newunit=unit, file=trim(pvdPath), status="replace", action="write", iostat=ios) + if (ios /= 0) stop "Error al crear archivo PVD" + + ! Escribimos encabezados XML + write (unit, *) '' + write (unit, *) '' + write (unit, *) ' ' + close (unit) + end subroutine create_pvd + + subroutine close_pvd(pvdPath) + implicit none + character(len=*), intent(in) :: pvdPath + integer :: unit + integer :: ios + open (newunit=unit, file=trim(pvdPath), status="old", action="write", iostat=ios) + if (ios /= 0) stop "Error al abrir archivo PVD" + write (unit, *) ' ' + write (unit, *) '' + close (unit) + end subroutine close_pvd + + function get_required_output_count(sgg) result(count) + type(SGGFDTDINFO), intent(in) :: sgg + integer(kind=SINGLE) ::i, count + count = 0 + do i = 1, sgg%NumberRequest + count = count + sgg%Observation(i)%nP + end do + return + end function + + subroutine registerOutputFiles(control, outputCount) + type(sim_control_t), intent(in) :: control + integer, intent(in) :: outputCount + + character(LEN=BUFSIZE) :: whoami, whoamishort, outputRequestFile + integer :: iostat, i, unit + + write (whoamishort, '(i5)') control%layoutnumber + 1 + write (whoami, '(a,i5,a,i5,a)') '(', control%layoutnumber + 1, '/', control%size, ') ' + write (outputRequestFile, *) trim(adjustl(control%nEntradaRoot))//'_Outputrequests_'//trim(adjustl(whoamishort))//'.txt' + + call create_file_with_path(outputRequestFile, iostat) + if (iostat /= 0) call StopOnError(control%layoutnumber, control%size, 'Error while creating new outputrequestRegister file...') + + open (newunit=unit, file=trim(adjustl(outputRequestFile)), status='replace', action='write', position='append', iostat=iostat) + do i = 1, outputCount + select case (outputs(i)%outputID) + case (POINT_PROBE_ID) + if (any(outputs(i)%pointProbe%domain%domainType == (/TIME_DOMAIN, BOTH_DOMAIN/))) then + write (unit, *) trim(adjustl(outputs(i)%pointProbe%filePathTime)) + end if + if (any(outputs(i)%pointProbe%domain%domainType == (/FREQUENCY_DOMAIN, BOTH_DOMAIN/))) then + write (unit, *) trim(adjustl(outputs(i)%pointProbe%filePathFreq)) + end if + case (WIRE_CURRENT_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%wireCurrentProbe%filePathTime)) + case (WIRE_CHARGE_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%wireChargeProbe%filePathTime)) + case (BULK_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%bulkCurrentProbe%filePathTime)) + case (MOVIE_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%movieProbe%filePathTime)) + case (FREQUENCY_SLICE_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%frequencySliceProbe%filePathFreq)) + case (FAR_FIELD_PROBE_ID) + write (unit, *) trim(adjustl(outputs(i)%farFieldOutput%filePathFreq)) + case (MAPVTK_ID) + write (unit, *) trim(adjustl(outputs(i)%mapvtkOutput%path)) + case default + call stoponerror(0, 0, 'Output update not implemented') + end select + end do + + write (unit, *) 'END!' + close (unit) + end subroutine + +end module output diff --git a/src_output/outputTypes.F90 b/src_output/outputTypes.F90 new file mode 100644 index 00000000..0a4bd9cf --- /dev/null +++ b/src_output/outputTypes.F90 @@ -0,0 +1,221 @@ +module outputTypes + use FDETYPES + use HollandWires + use wiresHolland_constants +#ifdef CompileWithBerengerWires + use WiresBerenger +#endif +#ifdef CompileWithSlantedWires + use WiresSlanted + use WiresSlanted_Types + use WiresSlanted_Constants +#endif + implicit none + +!===================================================== +! Parameters & constants +!===================================================== + integer, parameter :: UNDEFINED_DOMAIN = -1 + integer, parameter :: TIME_DOMAIN = 0 + integer, parameter :: FREQUENCY_DOMAIN = 1 + integer, parameter :: BOTH_DOMAIN = 2 + + + character(len=4), parameter :: binaryExtension = '.bin' + character(len=4), parameter :: pvdExtension = '.pvd' + character(len=4), parameter :: datFileExtension = '.dat' + character(len=4), parameter :: vtkFileExtension = '.vtk' + character(len=4), parameter :: vtuFileExtension = '.vtu' + character(len=2), parameter :: timeExtension = 'tm' + character(len=2), parameter :: frequencyExtension = 'fq' + character(len=1), parameter :: wordseparation = '_' + +!===================================================== +! Basic helper / geometry types +!===================================================== + type :: cell_coordinate_t + integer(kind=SINGLE) :: x, y, z + end type cell_coordinate_t + + type :: domain_t + real(kind=RKIND_tiempo) :: tstart = 0.0_RKIND_tiempo + real(kind=RKIND_tiempo) :: tstop = 0.0_RKIND_tiempo + real(kind=RKIND_tiempo) :: tstep = 0.0_RKIND_tiempo + real(kind=RKIND) :: fstart = 0.0_RKIND + real(kind=RKIND) :: fstop = 0.0_RKIND + real(kind=RKIND) :: fstep + integer(kind=SINGLE) :: fnum = 0 + integer(kind=SINGLE) :: domainType = UNDEFINED_DOMAIN + logical :: logarithmicSpacing = .false. + end type domain_t + + type :: spheric_domain_t + real(kind=RKIND) :: phiStart = 0.0_RKIND + real(kind=RKIND) :: phiStop = 0.0_RKIND + real(kind=RKIND) :: phiStep = 0.0_RKIND + real(kind=RKIND) :: thetaStart = 0.0_RKIND + real(kind=RKIND) :: thetaStop = 0.0_RKIND + real(kind=RKIND) :: thetastep = 0.0_RKIND + end type spheric_domain_t + +!===================================================== +! Field & current data containers +!===================================================== + type :: field_data_t + real(kind=RKIND), pointer, dimension(:, :, :), contiguous :: x => NULL() + real(kind=RKIND), pointer, dimension(:, :, :), contiguous :: y => NULL() + real(kind=RKIND), pointer, dimension(:, :, :), contiguous :: z => NULL() + real(kind=RKIND), pointer, dimension(:), contiguous :: deltaX => NULL() + real(kind=RKIND), pointer, dimension(:), contiguous :: deltaY => NULL() + real(kind=RKIND), pointer, dimension(:), contiguous :: deltaZ => NULL() + end type field_data_t + + type :: fields_reference_t + type(field_data_t) :: E + type(field_data_t) :: H + end type fields_reference_t + + type :: current_values_t + real(kind=RKIND) :: current = 0.0_RKIND + real(kind=RKIND) :: deltaVoltage = 0.0_RKIND + real(kind=RKIND) :: plusVoltage = 0.0_RKIND + real(kind=RKIND) :: minusVoltage = 0.0_RKIND + real(kind=RKIND) :: voltageDiference = 0.0_RKIND + end type current_values_t + +!===================================================== +! Abstract probe hierarchy +!===================================================== + type :: abstract_probe_t + integer(kind=SINGLE) :: columnas + type(domain_t) :: domain + type(cell_coordinate_t) :: mainCoords + integer(kind=SINGLE) :: component + character(len=BUFSIZE) :: path + end type abstract_probe_t + type, extends(abstract_probe_t) :: abstract_time_probe_t + character(len=BUFSIZE) :: filePathTime + integer(kind=SINGLE) :: nTime = 0_SINGLE + integer(kind=SINGLE) :: nTimesFlushed = 0_SINGLE !times alredy writen in disk + real(kind=RKIND_tiempo), allocatable :: timeStep(:) + end type abstract_time_probe_t + + type, extends(abstract_probe_t) :: abstract_frequency_probe_t + character(len=BUFSIZE) :: filePathFreq + integer(kind=SINGLE) :: nFreq = 0_SINGLE + real(kind=RKIND), allocatable :: frequencySlice(:) + complex(kind=CKIND), allocatable :: auxExp_E(:), auxExp_H(:) + end type abstract_frequency_probe_t + + type, extends(abstract_probe_t) :: abstract_time_frequency_probe_t + character(len=BUFSIZE) :: filePathTime, filePathFreq + integer(kind=SINGLE) :: nTime = 0_SINGLE, nFreq = 0_SINGLE + real(kind=RKIND_tiempo), allocatable :: timeStep(:) + real(kind=RKIND), allocatable :: frequencySlice(:) + complex(kind=CKIND), allocatable :: auxExp_E(:), auxExp_H(:) + end type abstract_time_frequency_probe_t + +!===================================================== +! Concrete probe types +!===================================================== + + type, extends(abstract_probe_t) :: mapvtk_output_t + type(cell_coordinate_t) :: auxCoords + integer(kind=SINGLE), allocatable :: coords(:, :) + integer(kind=SINGLE), allocatable :: currentType(:) + integer(kind=SINGLE), allocatable :: materialTag(:) + integer :: nPoints = -1 + end type mapvtk_output_t + + type, extends(abstract_time_frequency_probe_t) :: point_probe_output_t + real(kind=RKIND), allocatable :: valueForTime(:) + complex(kind=CKIND), allocatable :: valueForFreq(:) + end type point_probe_output_t + + type, extends(abstract_time_probe_t) :: wire_charge_probe_output_t + integer(kind=SINGLE) :: sign = +1 + real(kind=RKIND), allocatable :: chargeValue(:) + type(CurrentSegments), pointer :: segment + end type wire_charge_probe_output_t + + type, extends(abstract_time_probe_t) :: wire_current_probe_output_t + integer(kind=SINGLE) :: sign = +1 + type(current_values_t) :: currentValues(BuffObse) + type(CurrentSegments), pointer :: segment +#ifdef CompileWithBerengerWires + type(TSegment), pointer :: segmentBerenger +#endif +#ifdef CompileWithSlantedWires + class(Segment), pointer :: segmentSlanted +#endif + end type wire_current_probe_output_t + + type, extends(abstract_time_probe_t) :: bulk_current_probe_output_t + !Binary format: timeStamp, Val. Total register size: 16 + type(cell_coordinate_t) :: auxCoords + real(kind=RKIND), allocatable :: valueForTime(:) + end type bulk_current_probe_output_t + + type, extends(abstract_frequency_probe_t) :: far_field_probe_output_t + type(spheric_domain_t) :: sphericRange + type(cell_coordinate_t) :: auxCoords + integer(kind=SINGLE) :: nPoints = -1 + integer(kind=SINGLE), allocatable :: coords(:, :) + complex(kind=CKIND), allocatable :: valueForFreq(:, :) + end type far_field_probe_output_t + + type, extends(abstract_time_probe_t) :: movie_probe_output_t + !Binary format: timeStamp, x, y, z, xVal, yVal, zVal. Total register size: 44 + type(cell_coordinate_t) :: auxCoords + integer(kind=SINGLE) :: nPoints = -1 + integer(kind=SINGLE), allocatable :: coords(:, :) !(3, coordIdx) + real(kind=RKIND), allocatable :: xValueForTime(:, :) !(time, coordIdx) + real(kind=RKIND), allocatable :: yValueForTime(:, :) !(time, coordIdx) + real(kind=RKIND), allocatable :: zValueForTime(:, :) !(time, coordIdx) + character(len=BUFSIZE) :: filesPath + end type movie_probe_output_t + + type, extends(abstract_frequency_probe_t) :: frequency_slice_probe_output_t + !Binary format: frequencySlice, x, y, z, xVal, yVal, zVal. Total register size: 44 + type(cell_coordinate_t) :: auxCoords + integer(kind=SINGLE) :: nPoints = -1 + integer(kind=SINGLE), allocatable :: coords(:, :) !(3, coordIdx) + complex(kind=CKIND), allocatable :: xValueForFreq(:, :) !(time, coordIdx) + complex(kind=CKIND), allocatable :: yValueForFreq(:, :) !(time, coordIdx) + complex(kind=CKIND), allocatable :: zValueForFreq(:, :) !(time, coordIdx) + character(len=BUFSIZE) :: filesPath + end type frequency_slice_probe_output_t + +!===================================================== +! High-level aggregation types +!===================================================== + type :: solver_output_t + integer(kind=SINGLE) :: outputID = -1 + type(point_probe_output_t), allocatable :: pointProbe + type(wire_current_probe_output_t), allocatable :: wireCurrentProbe + type(wire_charge_probe_output_t), allocatable :: wireChargeProbe + type(bulk_current_probe_output_t), allocatable :: bulkCurrentProbe + type(movie_probe_output_t), allocatable :: movieProbe + type(frequency_slice_probe_output_t), allocatable :: frequencySliceProbe + type(far_field_probe_output_t), allocatable :: farFieldOutput + type(mapvtk_output_t), allocatable :: mapvtkOutput +#ifdef CompileWithMPI + integer(kind=4) :: MPISubcomm, MPIRoot, MPIGroupIndex + integer(kind=4) :: ZIorig, ZEorig +#endif + end type solver_output_t + + type :: problem_info_t + type(media_matrices_t), pointer :: geometryToMaterialData + type(limit_t), pointer :: problemDimension(:) + type(bounds_t), pointer :: simulationBounds + type(MediaData_t), pointer :: materialList(:) + type(taglist_t), pointer :: materialTag + real(RKIND), pointer, dimension(:) :: xSteps + real(RKIND), pointer, dimension(:) :: ySteps + real(RKIND), pointer, dimension(:) :: zSteps + end type problem_info_t + +contains + +end module outputTypes diff --git a/src_output/outputUtils.F90 b/src_output/outputUtils.F90 new file mode 100644 index 00000000..562d4609 --- /dev/null +++ b/src_output/outputUtils.F90 @@ -0,0 +1,675 @@ +module mod_outputUtils + use FDETYPES + use outputTypes + use mod_domain + use report + implicit none + integer(kind=SINGLE), parameter :: FILE_UNIT = 400 + + private + + !=========================== + ! Public interface summary + !=========================== + public :: new_cell_coordinate + public :: get_coordinates_extension + public :: get_prefix_extension + public :: get_field_component + public :: get_field_reference + public :: init_frequency_slice + public :: getBlockCurrentDirection + public :: isPEC + public :: isPML + public :: isSplitOrAdvanced + public :: isThinWire + public :: isMediaVacuum + public :: isWithinBounds + public :: isSurface + public :: isFlush + public :: computej + public :: computeJ1 + public :: computeJ2 + public :: fieldo + public :: create_data_file + public :: currentType + public :: get_media_from_coord_and_h_neighbours + !=========================== + + !=========================== + ! Private interface summary + !=========================== + private :: get_rotated_prefix + private :: prefix + private :: get_probe_coords_extension + private :: get_probe_bounds_coords_extension + private :: get_delta + !=========================== + + interface get_coordinates_extension + module procedure get_probe_coords_extension, get_probe_bounds_coords_extension + end interface get_coordinates_extension + +contains + function new_cell_coordinate(x, y, z) result(cell) + integer(kind=SINGLE), intent(in) :: x, y, z + type(cell_coordinate_t) :: cell + + cell%x = x + cell%y = y + cell%z = z + end function new_cell_coordinate + + function getMediaIndex(field, i, j, k, CoordToMaterial) result(res) + integer, intent(in) :: field, i, j, k + type(media_matrices_t), pointer, intent(in) :: CoordToMaterial + + integer :: res + + select case (field) + case (iEx); res = CoordToMaterial%sggMiEx(i, j, k) + case (iEy); res = CoordToMaterial%sggMiEy(i, j, k) + case (iEz); res = CoordToMaterial%sggMiEz(i, j, k) + case (iHx); res = CoordToMaterial%sggMiHx(i, j, k) + case (iHy); res = CoordToMaterial%sggMiHy(i, j, k) + case (iHz); res = CoordToMaterial%sggMiHz(i, j, k) + end select + + end function + + subroutine get_media_from_coord_and_h_neighbours(field, i, j, k, CoordToMaterial, media, firstPositiveMedia, firstNegativeMedia, secondPositiveMedia, secondNegativeMedia) + !Returns field media and Hmedia from borders of i,j,k + type(media_matrices_t), pointer, intent(in) :: CoordToMaterial + integer(4), intent(in) :: field, i, j, k + integer(4), intent(out) :: media, firstPositiveMedia, firstNegativeMedia, secondPositiveMedia, secondNegativeMedia + integer, parameter :: nFields = 3 + + ! Precomputed shifts for first direction + integer, dimension(nFields) :: shift_i = [0, -1, 0] + integer, dimension(nFields) :: shift_j = [0, 0, -1] + integer, dimension(nFields) :: shift_k = [-1, 0, 0] + + ! Precomputed shifts for second direction + integer, dimension(nFields) :: shift_i2 = [0, 0, -1] + integer, dimension(nFields) :: shift_j2 = [-1, 0, 0] + integer, dimension(nFields) :: shift_k2 = [0, -1, 0] + + ! Precomputed neighbor hfield types + integer, dimension(nFields) :: HFieldTable = [iHy, iHz, iHx] ! returns perpendicular field tags from H + + ! Main mediua + media = getMediaIndex(field, i, j, k, CoordToMaterial) + + ! Neighboring media + !First Direction + firstPositiveMedia = getMediaIndex(HFieldTable(field), i, j, k, CoordToMaterial) + firstNegativeMedia = getMediaIndex(HFieldTable(field), i + shift_i(field), j + shift_j(field), k + shift_k(field), CoordToMaterial) + + !Second Direction + secondPositiveMedia = getMediaIndex(HFieldTable(mod(field, nFields) + 1), i, j, k, CoordToMaterial) + secondNegativeMedia = getMediaIndex(HFieldTable(mod(field, nFields) + 1), i + shift_i2(field), j + shift_j2(field), k + shift_k2(field), CoordToMaterial) + end subroutine + + function get_probe_coords_extension(coordinates, mpidir) result(ext) + type(cell_coordinate_t) :: coordinates + integer(kind=SINGLE), intent(in) :: mpidir + character(len=BUFSIZE) :: ext + character(len=BUFSIZE) :: chari, charj, chark + + write (chari, '(i7)') coordinates%x + write (charj, '(i7)') coordinates%y + write (chark, '(i7)') coordinates%z + +#if CompileWithMPI + if (mpidir == 3) then + ext = trim(adjustl(chari))//'_'//trim(adjustl(charj))//'_'//trim(adjustl(chark)) + elseif (mpidir == 2) then + ext = trim(adjustl(charj))//'_'//trim(adjustl(chark))//'_'//trim(adjustl(chari)) + elseif (mpidir == 1) then + ext = trim(adjustl(chark))//'_'//trim(adjustl(chari))//'_'//trim(adjustl(charj)) + else + call stoponerror(0, 0, 'Buggy error in mpidir. ') + end if +#else + ext = trim(adjustl(chari))//'_'//trim(adjustl(charj))//'_'//trim(adjustl(chark)) +#endif + + return + end function get_probe_coords_extension + + function get_probe_bounds_coords_extension(lowerCoordinates, upperCoordinates, mpidir) result(ext) + type(cell_coordinate_t) :: lowerCoordinates, upperCoordinates + integer(kind=SINGLE), intent(in) :: mpidir + character(len=BUFSIZE) :: ext + character(len=BUFSIZE) :: chari, charj, chark, chari2, charj2, chark2 + + write (chari, '(i7)') lowerCoordinates%x + write (charj, '(i7)') lowerCoordinates%y + write (chark, '(i7)') lowerCoordinates%z + + write (chari2, '(i7)') upperCoordinates%x + write (charj2, '(i7)') upperCoordinates%y + write (chark2, '(i7)') upperCoordinates%z + +#if CompileWithMPI + if (mpidir == 3) then + ext = trim(adjustl(chari))//'_'//trim(adjustl(charj))//'_'//trim(adjustl(chark))//'__'// & + trim(adjustl(chari2))//'_'//trim(adjustl(charj2))//'_'//trim(adjustl(chark2)) + elseif (mpidir == 2) then + ext = trim(adjustl(charj))//'_'//trim(adjustl(chark))//'_'//trim(adjustl(chari))//'__'// & + trim(adjustl(charj2))//'_'//trim(adjustl(chark2))//'_'//trim(adjustl(chari2)) + elseif (mpidir == 1) then + ext = trim(adjustl(chark))//'_'//trim(adjustl(chari))//'_'//trim(adjustl(charj))//'__'// & + trim(adjustl(chark2))//'_'//trim(adjustl(chari2))//'_'//trim(adjustl(charj2)) + else + call stoponerror(0, 0, 'Buggy error in mpidir. ') + end if +#else + ext = trim(adjustl(chari))//'_'//trim(adjustl(charj))//'_'//trim(adjustl(chark))//'__'// & + trim(adjustl(chari2))//'_'//trim(adjustl(charj2))//'_'//trim(adjustl(chark2)) +#endif + + return + end function get_probe_bounds_coords_extension + + function get_prefix_extension(field, mpidir) result(prefixExtension) + integer(kind=SINGLE), intent(in) :: field, mpidir + character(len=BUFSIZE) :: prefixExtension + +#if CompileWithMPI + prefixExtension = get_rotated_prefix(field, mpidir) +#else + prefixExtension = prefix(field) +#endif + end function get_prefix_extension + + function get_rotated_prefix(field, mpidir) result(prefixExtension) + integer(kind=SINGLE), intent(in) :: field, mpidir + character(len=BUFSIZE) :: prefixExtension + if (mpidir == 3) then + select case (field) + case (iEx); prefixExtension = prefix(iEx) + case (iEy); prefixExtension = prefix(iEy) + case (iEz); prefixExtension = prefix(iEz) + case (iJx); prefixExtension = prefix(iJx) + case (iJy); prefixExtension = prefix(iJy) + case (iJz); prefixExtension = prefix(iJz) + case (iQx); prefixExtension = prefix(iQx) + case (iQy); prefixExtension = prefix(iQy) + case (iQz); prefixExtension = prefix(iQz) + case (iVx); prefixExtension = prefix(iVx) + case (iVy); prefixExtension = prefix(iVy) + case (iVz); prefixExtension = prefix(iVz) + case (iHx); prefixExtension = prefix(iHx) + case (iHy); prefixExtension = prefix(iHy) + case (iHz); prefixExtension = prefix(iHz) + case (iBloqueJx); prefixExtension = prefix(iBloqueJx) + case (iBloqueJy); prefixExtension = prefix(iBloqueJy) + case (iBloqueJz); prefixExtension = prefix(iBloqueJz) + case (iBloqueMx); prefixExtension = prefix(iBloqueMx) + case (iBloqueMy); prefixExtension = prefix(iBloqueMy) + case (iBloqueMz); prefixExtension = prefix(iBloqueMz) + case default; prefixExtension = prefix(field) + end select + elseif (mpidir == 2) then + select case (field) + case (iEx); prefixExtension = prefix(iEz) + case (iEy); prefixExtension = prefix(iEx) + case (iEz); prefixExtension = prefix(iEy) + case (iJx); prefixExtension = prefix(iJz) + case (iJy); prefixExtension = prefix(iJx) + case (iJz); prefixExtension = prefix(iJy) + case (iQx); prefixExtension = prefix(iQz) + case (iQy); prefixExtension = prefix(iQx) + case (iQz); prefixExtension = prefix(iQy) + case (iVx); prefixExtension = prefix(iVz) + case (iVy); prefixExtension = prefix(iVx) + case (iVz); prefixExtension = prefix(iVy) + case (iHx); prefixExtension = prefix(iHz) + case (iHy); prefixExtension = prefix(iHx) + case (iHz); prefixExtension = prefix(iHy) + case (iBloqueJx); prefixExtension = prefix(iBloqueJz) + case (iBloqueJy); prefixExtension = prefix(iBloqueJx) + case (iBloqueJz); prefixExtension = prefix(iBloqueJy) + case (iBloqueMx); prefixExtension = prefix(iBloqueMz) + case (iBloqueMy); prefixExtension = prefix(iBloqueMx) + case (iBloqueMz); prefixExtension = prefix(iBloqueMy) + case default; prefixExtension = prefix(field) + end select + elseif (mpidir == 1) then + select case (field) + case (iEx); prefixExtension = prefix(iEy) + case (iEy); prefixExtension = prefix(iEz) + case (iEz); prefixExtension = prefix(iEx) + case (iJx); prefixExtension = prefix(iJy) + case (iJy); prefixExtension = prefix(iJz) + case (iJz); prefixExtension = prefix(iJx) + case (iQx); prefixExtension = prefix(iQy) + case (iQy); prefixExtension = prefix(iQz) + case (iQz); prefixExtension = prefix(iQx) + case (iVx); prefixExtension = prefix(iVy) + case (iVy); prefixExtension = prefix(iVz) + case (iVz); prefixExtension = prefix(iVx) + case (iHx); prefixExtension = prefix(iHy) + case (iHy); prefixExtension = prefix(iHz) + case (iHz); prefixExtension = prefix(iHx) + case (iBloqueJx); prefixExtension = prefix(iBloqueJy) + case (iBloqueJy); prefixExtension = prefix(iBloqueJz) + case (iBloqueJz); prefixExtension = prefix(iBloqueJx) + case (iBloqueMx); prefixExtension = prefix(iBloqueMy) + case (iBloqueMy); prefixExtension = prefix(iBloqueMz) + case (iBloqueMz); prefixExtension = prefix(iBloqueMx) + case default; prefixExtension = prefix(field) + end select + else + call stoponerror(0, 0, "Buggy error in mpidir.") + end if + return + end function get_rotated_prefix + + function prefix(campo) result(ext) + integer(kind=SINGLE), intent(in) :: campo + character(len=BUFSIZE) :: ext + + select case (campo) + case (iEx); ext = 'Ex' + case (iEy); ext = 'Ey' + case (iEz); ext = 'Ez' + case (iVx); ext = 'Vx' + case (iVy); ext = 'Vy' + case (iVz); ext = 'Vz' + case (iHx); ext = 'Hx' + case (iHy); ext = 'Hy' + case (iHz); ext = 'Hz' + case (iBloqueJx); ext = 'Jx' + case (iBloqueJy); ext = 'Jy' + case (iBloqueJz); ext = 'Jz' + case (iBloqueMx); ext = 'Mx' + case (iBloqueMy); ext = 'My' + case (iBloqueMz); ext = 'Mz' + case (iJx); ext = 'Wx' + case (iJy); ext = 'Wy' + case (iJz); ext = 'Wz' + case (iQx); ext = 'Qx' + case (iQy); ext = 'Qy' + case (iQz); ext = 'Qz' + case (iExC); ext = 'ExC' + case (iEyC); ext = 'EyC' + case (iEzC); ext = 'EzC' + case (iHxC); ext = 'HxC' + case (iHyC); ext = 'HyC' + case (iHzC); ext = 'HzC' + case (iMEC); ext = 'ME' + case (iMHC); ext = 'MH' + case (iCur); ext = 'BC' + case (mapvtk); ext = 'MAP' + case (iCurX); ext = 'BCX' + case (iCurY); ext = 'BCY' + case (iCurZ); ext = 'BCZ' + case (farfield); ext = 'FF' + case (lineIntegral); ext = 'LI' + end select + return + end function prefix + + function fieldo(field, dir) result(fieldo2) + integer :: fieldo2, field + character(len=1) :: dir + fieldo2 = -1 + select case (field) + case (iEx, iEy, iEz, iHx, iHy, iHz); fieldo2 = field + case (iJx, iVx, iBloqueJx, iExC, iQx); fieldo2 = iEx + case (iJy, iVy, iBloqueJy, iEyC, iQy); fieldo2 = iEy + case (iJz, iVz, iBloqueJz, iEzC, iQz); fieldo2 = iEz + case (iBloqueMx, iHxC); fieldo2 = iHx + case (iBloqueMy, iHyC); fieldo2 = iHy + case (iBloqueMz, iHzC); fieldo2 = iHz + case (iMEC) + select case (dir) + CASE ('X', 'x'); fieldo2 = iEx + CASE ('Y', 'y'); fieldo2 = iEY + CASE ('Z', 'z'); fieldo2 = iEz + END SELECT + case (iMHC) + select case (dir) + CASE ('X', 'x'); fieldo2 = ihx + CASE ('Y', 'y'); fieldo2 = iHY + CASE ('Z', 'z'); fieldo2 = iHz + END SELECT + case (iCur, iCurX, icurY, icurZ, mapvtk) !los pongo en efield para evitar problemas con el MPI + select case (dir) + CASE ('X', 'x'); fieldo2 = iEx + CASE ('Y', 'y'); fieldo2 = iEY + CASE ('Z', 'z'); fieldo2 = iEz + END SELECT + end select + end function + + function get_field_component(fieldId, fieldReference) result(component) + type(fields_reference_t), intent(in) :: fieldReference + integer(kind=SINGLE), intent(in) :: fieldId + real(kind=RKIND), pointer, dimension(:, :, :) :: component + select case (fieldId) + case (iEx); component => fieldReference%E%x + case (iEy); component => fieldReference%E%y + case (iEz); component => fieldReference%E%z + case (iHx); component => fieldReference%H%x + case (iHy); component => fieldReference%H%y + case (iHz); component => fieldReference%H%z + end select + end function + + function get_field_reference(fieldId, fieldReference) result(field) + type(fields_reference_t), intent(in) :: fieldReference + integer(kind=SINGLE), intent(in) :: fieldId + type(field_data_t) :: field + select case (fieldId) + case (iBloqueJx, iBloqueJy, iBloqueJz) + field%x => fieldReference%E%x + field%y => fieldReference%E%y + field%z => fieldReference%E%z + + field%deltaX => fieldReference%E%deltax + field%deltaY => fieldReference%E%deltay + field%deltaZ => fieldReference%E%deltaz + case (iBloqueMx, iBloqueMy, iBloqueMz) + field%x => fieldReference%H%x + field%y => fieldReference%H%y + field%z => fieldReference%H%z + + field%deltaX => fieldReference%H%deltax + field%deltaY => fieldReference%H%deltay + field%deltaZ => fieldReference%H%deltaz + end select + end function get_field_reference + + subroutine init_frequency_slice(frequencySlice, domain) + real(kind=RKIND), dimension(:), intent(out) :: frequencySlice + type(domain_t), intent(in) :: domain + + integer(kind=SINGLE) :: i + + if (domain%logarithmicSpacing) then + do i = 1, domain%fnum + frequencySlice(i) = 10.0_RKIND**(domain%fstart + (i - 1)*domain%fstep) + end do + else + do i = 1, domain%fnum + frequencySlice(i) = domain%fstart + (i - 1)*domain%fstep + end do + end if + end subroutine init_frequency_slice + + integer function getBlockCurrentDirection(field) + integer(kind=4) :: field + select case (field) + case (iHx); getBlockCurrentDirection = iCurX + case (iHy); getBlockCurrentDirection = iCurY + case (iHz); getBlockCurrentDirection = iCurZ + case default; call StopOnError(0, 0, 'field is not H field') + end select + end function + + logical function isThinWire(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + integer(kind=SINGLE) :: mediaIndex + + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + isThinWire = problem%materialList(mediaIndex)%is%ThinWire + end function + + logical function isPEC(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + integer(kind=SINGLE) :: mediaIndex + + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + isPEC = problem%materialList(mediaIndex)%is%PEC + end function + + logical function isPML(field, i, j, k, problem) + integer(kind=4) :: field, i, j, k + integer(kind=SINGLE) :: mediaIndex + type(problem_info_t), intent(in) :: problem + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + isPML = problem%materialList(mediaIndex)%is%PML + end function + + logical function isSurface(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + integer(kind=SINGLE) :: mediaIndex + + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + isSurface = problem%materialList(mediaIndex)%is%Surface + end function + + logical function isWithinBounds(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + isWithinBounds = (i <= problem%problemDimension(field)%XE) .and. & + (j <= problem%problemDimension(field)%YE) .and. & + (k <= problem%problemDimension(field)%ZE) .and. & + (i >= problem%problemDimension(field)%XI) .and. & + (j >= problem%problemDimension(field)%YI) .and. & + (k >= problem%problemDimension(field)%ZI) + end function + + logical function isMediaVacuum(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + integer(kind=INTEGERSIZEOFMEDIAMATRICES) :: mediaIndex + integer(kind=INTEGERSIZEOFMEDIAMATRICES), parameter :: vacuum = 1 + + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + isMediaVacuum = (mediaIndex == vacuum) + end function + + logical function isSplitOrAdvanced(field, i, j, k, problem) + integer(kind=4), intent(in) :: field, i, j, k + type(problem_info_t), intent(in) :: problem + + integer(kind=INTEGERSIZEOFMEDIAMATRICES) :: mediaIndex + mediaIndex = getMediaIndex(field, i, j, k, problem%geometryToMaterialData) + + isSplitOrAdvanced = problem%materialList(mediaIndex)%is%split_and_useless .or. & + problem%materialList(mediaIndex)%is%already_YEEadvanced_byconformal + end function + + function computej(field, i, j, k, fields_reference) result(res) + implicit none + + ! Input Arguments + integer(kind=single), intent(in) :: field, i, j, k + type(fields_reference_t), intent(in) :: fields_reference + + ! Local Variables + integer(kind=single) :: i_shift_a, j_shift_a, k_shift_a ! Shift for Term A (Offset for H/M field) + integer(kind=single) :: i_shift_b, j_shift_b, k_shift_b ! Shift for Term B (Offset for H/M field) + + integer(kind=single) :: curl_component_a ! H/M field component for Term A + integer(kind=single) :: curl_component_b ! H/M field component for Term B + + real(kind=rkind) :: res + + ! ----------------------------------------------------------- + ! 1. Determine Curl Components + ! The MOD 3 operation cyclically maps the E-field to the two required H-field components. + ! ----------------------------------------------------------- + + ! Component A (The 'next' component in the sequence) + curl_component_a = 1 + mod(field + 1, 3) + + ! Component B (The 'current' component in the sequence) + curl_component_b = 1 + mod(field, 3) + + ! ----------------------------------------------------------- + ! 2. Calculate Spatial Shifts (Yee Cell Staggering) + ! We use MERGE to apply the (i-1) shift only in the relevant direction. + ! ----------------------------------------------------------- + + ! Shift for Term A + i_shift_a = i - merge(1, 0, curl_component_a == iex) + j_shift_a = j - merge(1, 0, curl_component_a == iey) + k_shift_a = k - merge(1, 0, curl_component_a == iez) + + ! Shift for Term B + i_shift_b = i - merge(1, 0, curl_component_b == iex) + j_shift_b = j - merge(1, 0, curl_component_b == iey) + k_shift_b = k - merge(1, 0, curl_component_b == iez) + + ! ----------------------------------------------------------- + ! 3. Calculate J (Curl Difference) + ! The H/M fields are accessed using an offset (+3) from the E-field index. + ! ----------------------------------------------------------- + + res = & + ! TERM B: (Positive term in the difference) + (get_delta(curl_component_b, i, j, k, fields_reference)* & + ( get_field(curl_component_b + 3, i, j, k, fields_reference) - get_field(curl_component_b + 3, i_shift_b, j_shift_b, k_shift_b, fields_reference) ) & + ) - & + ! TERM A: (Negative term in the difference) + (get_delta(curl_component_a, i, j, k, fields_reference)* & + ( get_field(curl_component_a + 3, i, j, k, fields_reference) - get_field(curl_component_a + 3, i_shift_a, j_shift_a, k_shift_a, fields_reference) ) & + ) + + end function computej + + function computeJ1(f, i, j, k, fields_reference) result(res) + implicit none + integer(kind=4), intent(in) :: f, i, j, k + type(fields_reference_t), intent(in) :: fields_reference + integer(kind=4) :: c ! Complementary H-field index (Hy/Hz) + real(kind=rkind) :: res + real(kind=rkind) :: curl_h_term_a, curl_h_term_b, field_diff_term + + ! Calculate complementary H-field index (e.g., if f=1 (Ex), c=5 (Hy) and c+1=6 (Hz) or vice versa depending on definitions) + ! For f=1 (Ex), c = mod(1-2, 3)+4 = mod(-1, 3)+4 = 2+4 = 6 (Hz). + + c = mod(f - 2, 3) + 4 ! This typically corresponds to H_z for J_x, or H_x for J_y, etc. + + ! First set of H-field terms + curl_h_term_a = get_delta(c, i, j, k, fields_reference)*get_field(c, i, j, k, fields_reference) + & + get_delta(c, i+u(f,iHy), j+u(f,iHz), k+u(f,iHx), fields_reference) * get_field(c, i+u(f,iHy), j+u(f,iHz), k+u(f,iHx), fields_reference) + + ! Second set of H-field terms + curl_h_term_b = get_delta(c, i, j, k, fields_reference) * get_field(c, i-u(f,iHx), j-u(f,iHy), k-u(f,iHz), fields_reference) + & + get_delta(c, i+u(f,iHy), j+u(f,iHz), k+u(f,iHx), fields_reference) * get_field(c, i-u(f,iHx)+u(f,iHy), j-u(f,iHy)+u(f,iHz), k-u(f,iHz)+u(f,iHx), fields_reference) + + ! E-field term (approximates the change in E-field at the J-node) + field_diff_term = get_delta(f, i, j, k, fields_reference)*( & + get_field(f, i - u(f, iHy), j - u(f, iHz), k - u(f, iHx), fields_reference) - & + get_field(f, i + u(f, iHy), j + u(f, iHz), k + u(f, iHx), fields_reference)) + + ! Final computation: J1 = - ((Curl_H_A) - (Curl_H_B) + (E_diff)) + res = -((curl_h_term_a - curl_h_term_b) + field_diff_term) + + end function computeJ1 + + function computeJ2(f, i, j, k, fields_reference) result(res) + implicit none + integer(kind=4), intent(in) :: f, i, j, k + type(fields_reference_t), intent(in) :: fields_reference + integer(kind=4) :: c ! Complementary H-field index (Hx/Hy/Hz) + real(kind=rkind) :: res + real(kind=rkind) :: curl_h_term_a, curl_h_term_b, field_diff_term + + ! Calculate complementary H-field index (e.g., if f=1 (Ex), c=4 (Hx) or c=5 (Hy)) + ! For f=1 (Ex), c = mod(1-3, 3)+4 = mod(-2, 3)+4 = 1+4 = 5 (Hy). This is the second H-field curl component. + c = mod(f - 3, 3) + 4 + + ! First set of H-field terms + curl_h_term_a = get_delta(c, i, j, k, fields_reference)*get_field(c, i, j, k, fields_reference) + & + get_delta(c, i+u(f,iHz), j+u(f,iHx), k+u(f,iHy), fields_reference) * get_field(c, i+u(f,iHz), j+u(f,iHx), k+u(f,iHy), fields_reference) + + ! Second set of H-field terms + curl_h_term_b = get_delta(c, i, j, k, fields_reference) * get_field(c, i-u(f,iHx), j-u(f,iHy), k-u(f,iHz), fields_reference) + & + get_delta(c, i+u(f,iHz), j+u(f,iHx), k+u(f,iHy), fields_reference) * get_field(c, i-u(f,iHx)+u(f,iHz), j-u(f,iHy)+u(f,iHx), k-u(f,iHz)+u(f,iHy), fields_reference) + + ! E-field term (approximates the change in E-field at the J-node) + field_diff_term = get_delta(f, i, j, k, fields_reference)*( & + get_field(f, i - u(f, iHz), j - u(f, iHx), k - u(f, iHy), fields_reference) - & + get_field(f, i + u(f, iHz), j + u(f, iHx), k + u(f, iHy), fields_reference)) + + ! Final computation: J2 = (Curl_H_A) - (Curl_H_B) + (E_diff) + res = (curl_h_term_a - curl_h_term_b) + field_diff_term + + end function computeJ2 + + integer function u(field1, field2) + integer(kind=4) :: field1, field2 + if (field1 == field2) then + u = 1 + else + u = 0 + end if + end function + + integer function currentType(field) + integer(kind=4) :: field + select case (field) + case (iEx); currentType = iJx + case (iEy); currentType = iJy + case (iEz); currentType = iJz + case (iHx); currentType = iBloqueJx + case (iHy); currentType = iBloqueJy + case (iHz); currentType = iBloqueJz + case default; call StopOnError(0, 0, 'field is not a E or H field') + end select + end function + + function get_field(field, i, j, k, fields_reference) result(res) + implicit none + real(kind=rkind) :: res + integer(kind=4), intent(in) :: field, i, j, k + type(fields_reference_t), intent(in) :: fields_reference + + ! Retrieves the field value based on the field index (1-3 for E, 4-6 for H) + select case (field) + case (iex); res = fields_reference%e%x(i, j, k) + case (iey); res = fields_reference%e%y(i, j, k) + case (iez); res = fields_reference%e%z(i, j, k) + case (ihx); res = fields_reference%h%x(i, j, k) + case (ihy); res = fields_reference%h%y(i, j, k) + case (ihz); res = fields_reference%h%z(i, j, k) + end select + end function get_field + + function get_delta(field, i, j, k, fields_reference) result(res) + implicit none + real(kind=rkind) :: res + integer(kind=4), intent(in) :: field, i, j, k + type(fields_reference_t), intent(in) :: fields_reference + + ! Retrieves the spatial step size (delta) corresponding to the field direction + ! Note: i, j, k are used to select the correct array index if the grid is non-uniform. + select case (field) + case (iex); res = fields_reference%e%deltax(i) + case (iey); res = fields_reference%e%deltay(j) + case (iez); res = fields_reference%e%deltaz(k) + case (ihx); res = fields_reference%h%deltax(i) + case (ihy); res = fields_reference%h%deltay(j) + case (ihz); res = fields_reference%h%deltaz(k) + end select + end function get_delta + + subroutine create_data_file(filePathReference, probePathReference, domainTypeReference, fileExtension) + use mod_directoryUtils + character(len=*), intent(out) :: filePathReference + character(len=*), intent(in) :: probePathReference + character(len=*), intent(in) :: domainTypeReference + character(len=*), intent(in) :: fileExtension + + character(len=1) :: sep = '_' + integer :: err + + filePathReference = trim(probePathReference)//sep//trim(domainTypeReference)//fileExtension + call create_file_with_path(filePathReference, err) + end subroutine + +end module mod_outputUtils diff --git a/src_output/pointProbeOutput.F90 b/src_output/pointProbeOutput.F90 new file mode 100644 index 00000000..f4a29ba6 --- /dev/null +++ b/src_output/pointProbeOutput.F90 @@ -0,0 +1,162 @@ +module mod_pointProbeOutput + use FDETYPES + use mod_UTILS + use outputTypes + use mod_domain + use mod_outputUtils + + implicit none + + private + + public :: init_point_probe_output + public :: update_point_probe_output + public :: flush_point_probe_output + +contains + subroutine init_point_probe_output(this, coordinates, field, domain, outputTypeExtension, mpidir, timeInterval) + type(point_probe_output_t), intent(out) :: this + type(cell_coordinate_t) :: coordinates + integer(kind=SINGLE), intent(in) :: mpidir, field + character(len=*), intent(in) :: outputTypeExtension + type(domain_t), intent(in) :: domain + + real(kind=RKIND_tiempo), intent(in) :: timeInterval + + integer(kind=SINGLE) :: i + + this%mainCoords = coordinates + + this%component = field + + this%domain = domain + this%path = get_output_path() + + if (any(this%domain%domainType == (/TIME_DOMAIN, BOTH_DOMAIN/))) then + call alloc_and_init(this%timeStep, BUFSIZE, 0.0_RKIND_tiempo) + call alloc_and_init(this%valueForTime, BUFSIZE, 0.0_RKIND) + call create_data_file(this%filePathTime, this%path, timeExtension, datFileExtension) + end if + if (any(this%domain%domainType == (/FREQUENCY_DOMAIN, BOTH_DOMAIN/))) then + this%nFreq = this%domain%fnum + allocate (this%frequencySlice(this%domain%fnum)) + call alloc_and_init(this%valueForFreq, this%domain%fnum, (0.0_CKIND, 0.0_CKIND)) + do i = 1, this%nFreq + call init_frequency_slice(this%frequencySlice, this%domain) + end do + this%valueForFreq = (0.0_RKIND, 0.0_RKIND) + + allocate (this%auxExp_E(this%nFreq)) + allocate (this%auxExp_H(this%nFreq)) + do i = 1, this%nFreq + this%auxExp_E(i) = timeInterval*(1.0E0_RKIND, 0.0E0_RKIND)*Exp(mcpi2*this%frequencySlice(i)) !el dt deberia ser algun tipo de promedio + this%auxExp_H(i) = this%auxExp_E(i)*Exp(mcpi2*this%frequencySlice(i)*timeInterval*0.5_RKIND) + end do + call create_data_file(this%filePathFreq, this%path, frequencyExtension, datFileExtension) + end if + + contains + function get_output_path() result(outputPath) + character(len=BUFSIZE) :: probeBoundsExtension, prefixFieldExtension + character(len=BUFSIZE) :: outputPath + probeBoundsExtension = get_coordinates_extension(this%mainCoords, mpidir) + prefixFieldExtension = get_prefix_extension(field, mpidir) + outputPath = & + trim(adjustl(outputTypeExtension))//'_'//trim(adjustl(prefixFieldExtension))//'_'//trim(adjustl(probeBoundsExtension)) + return + end function get_output_path + + end subroutine init_point_probe_output + + subroutine update_point_probe_output(this, step, field) + type(point_probe_output_t), intent(inout) :: this + real(kind=RKIND), pointer, dimension(:, :, :), intent(in) :: field + real(kind=RKIND_tiempo), intent(in) :: step + + integer(kind=SINGLE) :: iter + + if (any(this%domain%domainType == (/TIME_DOMAIN, BOTH_DOMAIN/))) then + this%nTime = this%nTime + 1 + this%timeStep(this%nTime) = step + this%valueForTime(this%nTime) = field(this%mainCoords%x, this%mainCoords%y, this%mainCoords%z) + end if + + if (any(this%domain%domainType == (/FREQUENCY_DOMAIN, BOTH_DOMAIN/))) then + select case(this%component) + case (iEx, iEy, iEz) + do iter = 1, this%nFreq + this%valueForFreq(iter) = & + this%valueForFreq(iter) + field(this%mainCoords%x, this%mainCoords%y, this%mainCoords%z)*(this%auxExp_E(iter)**step) + end do + case (iHx, iHy, iHz) + do iter = 1, this%nFreq + this%valueForFreq(iter) = & + this%valueForFreq(iter) + field(this%mainCoords%x, this%mainCoords%y, this%mainCoords%z)*(this%auxExp_H(iter)**step) + end do + end select + + end if + end subroutine update_point_probe_output + + subroutine flush_point_probe_output(this) + type(point_probe_output_t), intent(inout) :: this + if (any(this%domain%domainType == (/TIME_DOMAIN, BOTH_DOMAIN/))) then + call flush_time_domain(this) + call clear_time_data() + end if + if (any(this%domain%domainType == (/FREQUENCY_DOMAIN, BOTH_DOMAIN/))) then + call flush_frequency_domain(this) + end if + contains + + subroutine flush_time_domain(this) + type(point_probe_output_t), intent(in) :: this + integer :: i + integer :: unit + + if (this%nTime <= 0) then + print *, "No data to write." + return + end if + + open (unit=unit, file=this%filePathTime, status="old", action="write", position="append") + + do i = 1, this%nTime + write (unit, '(F12.6,1X,F12.6)') this%timeStep(i), this%valueForTime(i) + end do + + close (unit) + end subroutine flush_time_domain + + subroutine flush_frequency_domain(this) + type(point_probe_output_t), intent(in) :: this + integer :: i + integer :: unit + + if (.not. allocated(this%frequencySlice) .or. .not. allocated(this%valueForFreq)) then + print *, "Error: arrays not allocated." + return + end if + + if (this%nFreq <= 0) then + print *, "No data to write." + return + end if + open (unit=unit, file=this%filePathFreq, status="replace", action="write") + + do i = 1, this%nFreq + write (unit, '(F12.6,1X,F12.6,1X,F12.6)') this%frequencySlice(i), real(this%valueForFreq(i)), aimag(this%valueForFreq(i)) + end do + + close (unit) + end subroutine flush_frequency_domain + + subroutine clear_time_data() + this%timeStep = 0.0_RKIND_tiempo + this%valueForTime = 0.0_RKIND + + this%nTime = 0 + end subroutine clear_time_data + + end subroutine flush_point_probe_output +end module diff --git a/src_output/volumicProbeUtils.F90 b/src_output/volumicProbeUtils.F90 new file mode 100644 index 00000000..4b251137 --- /dev/null +++ b/src_output/volumicProbeUtils.F90 @@ -0,0 +1,367 @@ +module mod_volumicProbeUtils + use FDETYPES + USE mod_UTILS + use outputTypes + use mod_outputUtils + implicit none + private + + ! Public interface + public :: find_and_store_important_coords + public :: isValidPointForCurrent + public :: isValidPointForField + public :: createUnstructuredDataForVTU + + abstract interface + logical function logical_func(component, i, j, k, problemInfo) + import :: problem_info_t, SINGLE + type(problem_info_t), intent(in) :: problemInfo + integer(kind=SINGLE), intent(in) :: component, i, j, k + end function logical_func + end interface + + interface registerNode + module procedure & + registerNodeByIndex, & + registerNodeByCoordinate + end interface + +contains + + subroutine find_and_store_important_coords(lowerBound, upperBound, component, problemInfo, nPoints, coords) + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: component + type(problem_info_t), intent(in) :: problemInfo + integer(kind=SINGLE), intent(out) :: nPoints + integer(kind=SINGLE), allocatable, intent(inout) :: coords(:, :) + + call count_required_coords(lowerBound, upperBound, component, problemInfo, nPoints) + call alloc_and_init(coords, 3, nPoints, 0_SINGLE) + call store_required_coords(lowerBound, upperBound, component, problemInfo, coords) + end subroutine find_and_store_important_coords + + subroutine count_required_coords(lowerBound, upperBound, requestComponent, problemInfo, count) + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: requestComponent + type(problem_info_t), intent(in) :: problemInfo + integer(kind=SINGLE), intent(out) :: count + + integer :: i, j, k + procedure(logical_func), pointer :: checker => null() + integer :: component + + call get_checker_and_component(requestComponent, checker, component) + + count = 0 + do k = lowerBound%z, upperBound%z + do j = lowerBound%y, upperBound%y + do i = lowerBound%x, upperBound%x + if (checker(component, i, j, k, problemInfo)) count = count + 1 + end do + end do + end do + end subroutine count_required_coords + + subroutine store_required_coords(lowerBound, upperBound, requestComponent, problemInfo, coords) + type(cell_coordinate_t), intent(in) :: lowerBound, upperBound + integer(kind=SINGLE), intent(in) :: requestComponent + type(problem_info_t), intent(in) :: problemInfo + integer(kind=SINGLE), intent(inout) :: coords(:, :) + + integer :: i, j, k, count + procedure(logical_func), pointer :: checker => null() + integer :: component + + call get_checker_and_component(requestComponent, checker, component) + + count = 0 + do k = lowerBound%z, upperBound%z + do j = lowerBound%y, upperBound%y + do i = lowerBound%x, upperBound%x + if (checker(component, i, j, k, problemInfo)) then + count = count + 1 + coords(1, count) = i + coords(2, count) = j + coords(3, count) = k + end if + end do + end do + end do + end subroutine store_required_coords + + subroutine createUnstructuredDataForVTU(counter, coords, currentType, Nodes, Edges, Quads, numNodes, numEdges, numQuads, usevtkindex, realXGrid, realYGrid, realZGrid) + integer, intent(in) :: counter + integer(kind=SINGLE), intent(in) :: coords(:, :), currentType(:) + logical, intent(in) :: usevtkindex + real(KIND=RKIND), pointer, dimension(:), intent(in) :: realXGrid, realYGrid, realZGrid + + integer(kind=4), intent(out):: numNodes, numQuads, numEdges + real(kind=RKIND), allocatable, dimension(:, :), intent(out) :: Nodes + integer(kind=4), allocatable, dimension(:, :), intent(out) :: Edges, Quads + + if (counter == 0) return + + call countElements(counter, currentType, numEdges, numQuads) + + allocate (Edges(2, numEdges)) + allocate (Quads(4, numQuads)) + allocate (Nodes(3, 2*numEdges + 4*numQuads)) + + call registerElements(counter, coords, currentType, Nodes, Edges, Quads, usevtkindex, realXGrid, realYGrid, realZGrid) + return + end subroutine + + subroutine registerNodeByIndex(nodes, nodeIdx, x, y, z) + real(kind=RKIND), dimension(:, :), intent(inout) :: nodes + integer(kind=SINGLE), intent(in) :: nodeIdx, x, y, z + !We need to avoid using idx 0 + nodes(1, nodeIdx + 1) = x*1.0_RKIND + nodes(2, nodeIdx + 1) = y*1.0_RKIND + nodes(3, nodeIdx + 1) = z*1.0_RKIND + end subroutine + + subroutine registerNodeByCoordinate(nodes, nodeIdx, x, y, z) + real(kind=RKIND), dimension(:, :), intent(inout) :: nodes + integer(kind=SINGLE), intent(in) :: nodeIdx + real(kind=RKIND), intent(in) :: x, y, z + !We need to avoid using idx 0 + nodes(1, nodeIdx + 1) = x + nodes(2, nodeIdx + 1) = y + nodes(3, nodeIdx + 1) = z + end subroutine + + subroutine registerEdge(edges, edgeIdx, startNodeIdx, endNodeIdx) + integer(kind=SINGLE), dimension(:, :), intent(inout) :: edges + integer(kind=SINGLE), intent(in) :: edgeIdx, startNodeIdx, endNodeIdx + + edges(1, edgeIdx + 1) = startNodeIdx + edges(2, edgeIdx + 1) = endNodeIdx + end subroutine + + subroutine registerQuad(quads, quadIdx, firstNodeIdx, secondNodeIdx, thirdNodeIdx, fourthNodeIdx) + integer(kind=SINGLE), dimension(:, :), intent(inout) :: quads + integer(kind=SINGLE), intent(in) :: quadIdx, firstNodeIdx, secondNodeIdx, thirdNodeIdx, fourthNodeIdx + + quads(1, quadIdx + 1) = firstNodeIdx + quads(2, quadIdx + 1) = secondNodeIdx + quads(3, quadIdx + 1) = thirdNodeIdx + quads(4, quadIdx + 1) = fourthNodeIdx + end subroutine + + subroutine countElements(counter, currentType, numEdges, numQuads) + integer, intent(in) :: counter + integer(kind=SINGLE), intent(in) :: currentType(:) + integer(kind=4), intent(out) :: numEdges, numQuads + integer :: i + + numEdges = 0 + numQuads = 0 + + do i = 1, counter + if ((currentType(i) == iJx) .or. (currentType(i) == iJy) .or. (currentType(i) == iJz)) numEdges = numEdges + 1 + if ((currentType(i) == iBloqueJx) .or. (currentType(i) == iBloqueJy) .or. (currentType(i) == iBloqueJz)) numQuads = numQuads + 1 + end do + end subroutine + + subroutine registerElements(counter, coords, currentType, Nodes, Edges, Quads, usevtkindex, realXGrid, realYGrid, realZGrid) + integer, intent(in) :: counter + integer(kind=SINGLE), intent(in) :: coords(:, :), currentType(:) + real(kind=RKIND), intent(inout) :: Nodes(:, :) + integer(kind=4), intent(inout) :: Edges(:, :), Quads(:, :) + logical :: usevtkindex + real(KIND=RKIND), pointer, dimension(:), intent(in) :: realXGrid, realYGrid, realZGrid + + integer :: nodeIdx, quadIdx, edgeIdx + integer :: xCoord, yCoord, zCoord + integer :: i + + nodeIdx = -1 + quadIdx = -1 + edgeIdx = -1 + + do i = 1, counter + xCoord = coords(1, i) + yCoord = coords(2, i) + zCoord = coords(3, i) + + select case (currentType(i)) + case (iJx) + nodeIdx = nodeIdx + 2 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 1, xCoord , yCoord, zCoord ) + call registerNode(Nodes, nodeIdx , xCoord + 1, yCoord, zCoord ) + else + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord) , realYGrid(yCoord), realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord + 1), realYGrid(yCoord), realZGrid(zCoord) ) + endif + edgeIdx = edgeIdx + 1 + call registerEdge(Edges, edgeIdx, nodeIdx - 1, nodeIdx) + + case (iJy) + nodeIdx = nodeIdx + 2 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 1, xCoord , yCoord , zCoord ) + call registerNode(Nodes, nodeIdx , xCoord , yCoord + 1, zCoord ) + else + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord) , realYGrid(yCoord) , realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord) , realYGrid(yCoord + 1), realZGrid(zCoord) ) + endif + edgeIdx = edgeIdx + 1 + call registerEdge(Edges, edgeIdx, nodeIdx - 1, nodeIdx) + + case (iJz) + nodeIdx = nodeIdx + 2 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 1, xCoord, yCoord , zCoord ) + call registerNode(Nodes, nodeIdx , xCoord, yCoord , zCoord + 1) + else + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord) , realYGrid(yCoord) , realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord) , realYGrid(yCoord) , realZGrid(zCoord + 1)) + endif + edgeIdx = edgeIdx + 1 + call registerEdge(Edges, edgeIdx, nodeIdx - 1, nodeIdx) + + case (iBloqueJx) + nodeIdx = nodeIdx + 4 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 3, xCoord, yCoord , zCoord ) + call registerNode(Nodes, nodeIdx - 2, xCoord, yCoord + 1, zCoord ) + call registerNode(Nodes, nodeIdx - 1, xCoord, yCoord + 1, zCoord + 1) + call registerNode(Nodes, nodeIdx , xCoord, yCoord , zCoord + 1) + else + call registerNode(Nodes, nodeIdx - 3, realXGrid(xCoord), realYGrid(yCoord) , realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx - 2, realXGrid(xCoord), realYGrid(yCoord + 1), realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord), realYGrid(yCoord + 1), realZGrid(zCoord + 1)) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord), realYGrid(yCoord) , realZGrid(zCoord + 1)) + endif + quadIdx = quadIdx + 1 + call registerQuad(Quads, quadIdx, nodeIdx - 3, nodeIdx - 2, nodeIdx - 1, nodeIdx) + + case (iBloqueJy) + nodeIdx = nodeIdx + 4 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 3, xCoord , yCoord, zCoord ) + call registerNode(Nodes, nodeIdx - 2, xCoord + 1, yCoord, zCoord ) + call registerNode(Nodes, nodeIdx - 1, xCoord + 1, yCoord, zCoord + 1) + call registerNode(Nodes, nodeIdx , xCoord , yCoord, zCoord + 1) + else + call registerNode(Nodes, nodeIdx - 3, realXGrid(xCoord) , realYGrid(yCoord), realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx - 2, realXGrid(xCoord + 1), realYGrid(yCoord), realZGrid(zCoord) ) + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord + 1), realYGrid(yCoord), realZGrid(zCoord + 1)) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord) , realYGrid(yCoord), realZGrid(zCoord + 1)) + endif + quadIdx = quadIdx + 1 + call registerQuad(Quads, quadIdx, nodeIdx - 3, nodeIdx - 2, nodeIdx - 1, nodeIdx) + + case (iBloqueJz) + nodeIdx = nodeIdx + 4 + if (usevtkindex) then + call registerNode(Nodes, nodeIdx - 3, xCoord , yCoord , zCoord) + call registerNode(Nodes, nodeIdx - 2, xCoord + 1, yCoord , zCoord) + call registerNode(Nodes, nodeIdx - 1, xCoord + 1, yCoord + 1, zCoord) + call registerNode(Nodes, nodeIdx , xCoord , yCoord + 1, zCoord) + else + call registerNode(Nodes, nodeIdx - 3, realXGrid(xCoord) , realYGrid(yCoord) , realZGrid(zCoord)) + call registerNode(Nodes, nodeIdx - 2, realXGrid(xCoord + 1), realYGrid(yCoord) , realZGrid(zCoord)) + call registerNode(Nodes, nodeIdx - 1, realXGrid(xCoord + 1), realYGrid(yCoord + 1), realZGrid(zCoord)) + call registerNode(Nodes, nodeIdx , realXGrid(xCoord) , realYGrid(yCoord + 1), realZGrid(zCoord)) + endif + quadIdx = quadIdx + 1 + call registerQuad(Quads, quadIdx, nodeIdx - 3, nodeIdx - 2, nodeIdx - 1, nodeIdx) + end select + end do + end subroutine + + subroutine get_checker_and_component(request, checker, component) + integer(kind=SINGLE), intent(in) :: request + procedure(logical_func), pointer, intent(out) :: checker + integer(kind=SINGLE), intent(out) :: component + + select case (request) + case (iCur); checker => volumicCurrentRequest; component = iCur + case (iMEC); checker => volumicElectricRequest; component = iMEC + case (iMHC); checker => volumicMagneticRequest; component = iMHC + case (iCurx); checker => componentCurrentRequest; component = iEx + case (iExC); checker => componentFieldRequest; component = iEx + case (iHxC); checker => componentFieldRequest; component = iHx + case (iCurY); checker => componentCurrentRequest; component = iEy + case (iEyC); checker => componentFieldRequest; component = iEy + case (iHyC); checker => componentFieldRequest; component = iHy + case (iCurZ); checker => componentCurrentRequest; component = iEz + case (iEzC); checker => componentFieldRequest; component = iEz + case (iHzC); checker => componentFieldRequest; component = iHz + end select + end subroutine get_checker_and_component + + !-------------------------------------------------------------------------- + ! Logic Functions + !-------------------------------------------------------------------------- + + logical function isValidPointForCurrent(request, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: request, i, j, k + type(problem_info_t), intent(in) :: problemInfo + select case (request) + case (iCur) + isValidPointForCurrent = volumicCurrentRequest(request, i, j, k, problemInfo) + case (iEx, iEy, iEz) + isValidPointForCurrent = componentCurrentRequest(request, i, j, k, problemInfo) + case default + isValidPointForCurrent = .false. + end select + end function isValidPointForCurrent + + logical function isValidPointForField(request, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: request, i, j, k + type(problem_info_t), intent(in) :: problemInfo + select case (request) + case (iMEC) + isValidPointForField = volumicElectricRequest(request, i, j, k, problemInfo) + case (iMHC) + isValidPointForField = volumicMagneticRequest(request, i, j, k, problemInfo) + case (iEx, iEy, iEz, iHx, iHy, iHz) + isValidPointForField = componentFieldRequest(request, i, j, k, problemInfo) + case default + isValidPointForField = .false. + end select + end function isValidPointForField + + logical function volumicCurrentRequest(request, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: request, i, j, k + type(problem_info_t), intent(in) :: problemInfo + volumicCurrentRequest = componentCurrentRequest(iEx, i, j, k, problemInfo) .or. & + componentCurrentRequest(iEy, i, j, k, problemInfo) .or. & + componentCurrentRequest(iEz, i, j, k, problemInfo) + end function volumicCurrentRequest + + logical function volumicElectricRequest(request, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: request, i, j, k + type(problem_info_t), intent(in) :: problemInfo + volumicElectricRequest = componentFieldRequest(iEx, i, j, k, problemInfo) .or. & + componentFieldRequest(iEy, i, j, k, problemInfo) .or. & + componentFieldRequest(iEz, i, j, k, problemInfo) + end function volumicElectricRequest + + logical function volumicMagneticRequest(request, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: request, i, j, k + type(problem_info_t), intent(in) :: problemInfo + volumicMagneticRequest = componentFieldRequest(iHx, i, j, k, problemInfo) .or. & + componentFieldRequest(iHy, i, j, k, problemInfo) .or. & + componentFieldRequest(iHz, i, j, k, problemInfo) + end function volumicMagneticRequest + + logical function componentCurrentRequest(fieldDir, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: fieldDir, i, j, k + type(problem_info_t), intent(in) :: problemInfo + componentCurrentRequest = isWithinBounds(fieldDir, i, j, k, problemInfo) + if (componentCurrentRequest) then + componentCurrentRequest = isPEC(fieldDir, i, j, k, problemInfo) .or. isThinWire(fieldDir, i, j, k, problemInfo) + end if + end function componentCurrentRequest + + logical function componentFieldRequest(fieldDir, i, j, k, problemInfo) + integer(kind=SINGLE), intent(in) :: fieldDir, i, j, k + type(problem_info_t), intent(in) :: problemInfo + componentFieldRequest = isWithinBounds(fieldDir, i, j, k, problemInfo) + end function componentFieldRequest + +end module mod_volumicProbeUtils diff --git a/src_output/vtkAPI.F90 b/src_output/vtkAPI.F90 new file mode 100644 index 00000000..8c058280 --- /dev/null +++ b/src_output/vtkAPI.F90 @@ -0,0 +1,356 @@ +module mod_vtkAPI + implicit none + private + public :: vtk_data_array, vtk_grid, vtk_structured_grid, vtk_unstructured_grid + + !========================== + ! Data array type + !========================== + type :: vtk_data_array + character(len=:), allocatable :: name + character(len=:), allocatable :: type + integer :: num_components + real, allocatable :: data(:) + end type vtk_data_array + + !========================== + ! Base abstract class + !========================== + type, abstract :: vtk_grid + real, allocatable :: points(:, :) + type(vtk_data_array), allocatable :: scalars(:) + type(vtk_data_array), allocatable :: vectors(:) + type(vtk_data_array), allocatable :: cell_scalars(:) + type(vtk_data_array), allocatable :: cell_vectors(:) + contains + procedure(add_points_generic), deferred :: add_points + procedure(add_scalar_generic), deferred :: add_scalar + procedure(add_vector_generic), deferred :: add_vector + procedure(add_cell_scalar_generic), deferred :: add_cell_scalar + procedure(add_cell_vector_generic), deferred :: add_cell_vector + procedure(write_file_generic), deferred :: write_file + end type vtk_grid + + !========================== + ! Structured Grid (VTS) + !========================== + type, extends(vtk_grid) :: vtk_structured_grid + integer :: nx = 0, ny = 0, nz = 0 + contains + procedure :: add_points => add_points_structured + procedure :: add_scalar => add_scalar_structured + procedure :: add_vector => add_vector_structured + procedure :: add_cell_scalar => add_cell_scalar_structured + procedure :: add_cell_vector => add_cell_vector_structured + procedure :: write_file => write_vts_file + end type vtk_structured_grid + + !========================== + ! Unstructured Grid (VTU) + !========================== + type, extends(vtk_grid) :: vtk_unstructured_grid + integer :: num_points = 0 + integer :: num_cells = 0 + integer, allocatable :: connectivity(:) + integer, allocatable :: offsets(:) + integer, allocatable :: types(:) + contains + procedure :: add_points => add_points_unstructured + procedure :: add_scalar => add_scalar_unstructured + procedure :: add_vector => add_vector_unstructured + procedure :: add_cell_scalar => add_cell_scalar_unstructured + procedure :: add_cell_vector => add_cell_vector_unstructured + procedure :: add_cell_connectivity + procedure :: write_file => write_vtu_file + end type vtk_unstructured_grid + + !========================== + ! Generic deferred interfaces + !========================== + abstract interface + subroutine add_points_generic(this, pts) + import :: vtk_grid + class(vtk_grid), intent(inout) :: this + real, intent(in) :: pts(:, :) + end subroutine add_points_generic + + subroutine add_scalar_generic(this, name, data) + import :: vtk_grid + class(vtk_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + end subroutine add_scalar_generic + + subroutine add_vector_generic(this, name, data) + import :: vtk_grid + class(vtk_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + end subroutine add_vector_generic + + subroutine add_cell_scalar_generic(this, name, data) + import :: vtk_grid + class(vtk_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + end subroutine add_cell_scalar_generic + + subroutine add_cell_vector_generic(this, name, data) + import :: vtk_grid + class(vtk_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + end subroutine add_cell_vector_generic + + subroutine write_file_generic(this, filename) + import :: vtk_grid + class(vtk_grid), intent(in) :: this + character(len=*), intent(in) :: filename + end subroutine write_file_generic + end interface + +contains + !========================== + !==== Structured Grid Methods ==== + !========================== + + subroutine add_points_structured(this, pts) + class(vtk_structured_grid), intent(inout) :: this + real, intent(in) :: pts(:, :) + integer :: npts + npts = this%nx*this%ny*this%nz + if (size(pts, 1) /= 3) error stop 'add_points_structured: first dim must be 3' + if (size(pts, 2) /= npts) error stop 'add_points_structured: wrong number of points' + if (allocated(this%points)) deallocate (this%points) + allocate (this%points(3, npts)) + this%points = pts + end subroutine add_points_structured + + subroutine add_scalar_structured(this, name, data) + class(vtk_structured_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + call add_array_generic(this%scalars, name, data, 1) + end subroutine add_scalar_structured + + subroutine add_vector_structured(this, name, data) + class(vtk_structured_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + call add_array_generic(this%vectors, name, data, 3) + end subroutine add_vector_structured + + subroutine add_cell_scalar_structured(this, name, data) + class(vtk_structured_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + call add_array_generic(this%cell_scalars, name, data, 1) + end subroutine add_cell_scalar_structured + + subroutine add_cell_vector_structured(this, name, data) + class(vtk_structured_grid), intent(inout) :: this + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + call add_array_generic(this%cell_vectors, name, data, 3) + end subroutine add_cell_vector_structured + + !========================== + ! Write VTS + !========================== + subroutine write_vts_file(this, filename) + class(vtk_structured_grid), intent(in) :: this + character(len=*), intent(in) :: filename + integer :: iunit + open (newunit=iunit, file=filename, status='replace', action='write', form='formatted') + write (iunit, *) '' + write (iunit, *) ' ' + write (iunit, *) ' ' + call write_pointdata(iunit, this%scalars, this%vectors) + call write_celldata(iunit, this%cell_scalars, this%cell_vectors) + call write_points(iunit, this%points) + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, *) '' + close (iunit) + end subroutine write_vts_file + + !========================== + !==== Unstructured Grid Methods ==== + !========================== + subroutine add_points_unstructured(this, pts) + real, intent(in) :: pts(:, :) + class(vtk_unstructured_grid), intent(inout) :: this + if (size(pts, 1) /= 3) error stop 'add_points_unstructured: first dim must be 3' + this%num_points = size(pts, 2) + if (allocated(this%points)) deallocate (this%points) + allocate (this%points(3, this%num_points)) + this%points = pts + end subroutine add_points_unstructured + + subroutine add_scalar_unstructured(this, name, data) + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + class(vtk_unstructured_grid), intent(inout) :: this + call add_array_generic(this%scalars, name, data, 1) + end subroutine add_scalar_unstructured + + subroutine add_vector_unstructured(this, name, data) + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + class(vtk_unstructured_grid), intent(inout) :: this + call add_array_generic(this%vectors, name, data, 3) + end subroutine add_vector_unstructured + + subroutine add_cell_scalar_unstructured(this, name, data) + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + class(vtk_unstructured_grid), intent(inout) :: this + call add_array_generic(this%cell_scalars, name, data, 1) + end subroutine add_cell_scalar_unstructured + + subroutine add_cell_vector_unstructured(this, name, data) + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + class(vtk_unstructured_grid), intent(inout) :: this + call add_array_generic(this%cell_vectors, name, data, 3) + end subroutine add_cell_vector_unstructured + + subroutine add_cell_connectivity(this, conn, offsets, types) + class(vtk_unstructured_grid), intent(inout) :: this + integer, intent(in) :: conn(:), offsets(:), types(:) + this%num_cells = size(offsets) + if (allocated(this%connectivity)) deallocate (this%connectivity) + if (allocated(this%offsets)) deallocate (this%offsets) + if (allocated(this%types)) deallocate (this%types) + allocate (this%connectivity(size(conn))) + allocate (this%offsets(size(offsets))) + allocate (this%types(size(types))) + this%connectivity = conn + this%offsets = offsets + this%types = types + end subroutine add_cell_connectivity + + !========================== + ! Write VTU + !========================== + subroutine write_vtu_file(this, filename) + character(len=*), intent(in) :: filename + class(vtk_unstructured_grid), intent(in) :: this + integer :: iunit + open (newunit=iunit, file=filename, status='replace', action='write', form='formatted') + write (iunit, *) '' + write (iunit, *) ' ' + write (iunit, *) ' ' + call write_pointdata(iunit, this%scalars, this%vectors) + call write_celldata(iunit, this%cell_scalars, this%cell_vectors) + call write_cells(iunit, this%connectivity, this%offsets, this%types) + call write_points(iunit, this%points) + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, *) '' + close (iunit) + end subroutine write_vtu_file + +!========================== +!==== Shared helper routines ==== +!========================== + subroutine add_array_generic(array_list, name, data, ncomp) + type(vtk_data_array), allocatable, intent(inout) :: array_list(:) + character(len=*), intent(in) :: name + real, intent(in) :: data(:) + integer, intent(in) :: ncomp + type(vtk_data_array), allocatable :: tmp(:) + integer :: n + if (.not. allocated(array_list)) then + allocate (array_list(1)) + n = 1 + else + n = size(array_list) + 1 + allocate (tmp(n)) + tmp(1:n - 1) = array_list + call move_alloc(tmp, array_list) + end if + array_list(n)%name = name + array_list(n)%type = 'Float32' + array_list(n)%num_components = ncomp + array_list(n)%data = data + end subroutine add_array_generic + + subroutine write_pointdata(iunit, scalars, vectors) + integer, intent(in) :: iunit + type(vtk_data_array), allocatable, intent(in) :: scalars(:) + type(vtk_data_array), allocatable, intent(in) :: vectors(:) + integer :: i + write (iunit, *) ' ' + if (allocated(scalars)) then + do i = 1, size(scalars) + write (iunit, '(A)') ' ' + write (iunit, '(1000(F12.6,1X))') scalars(i)%data + write (iunit, '(A)') ' ' + end do + end if + if (allocated(vectors)) then + do i = 1, size(vectors) + write (iunit, '(A)') ' ' + write (iunit, '(1000(F12.6,1X))') vectors(i)%data + write (iunit, '(A)') ' ' + end do + end if + write (iunit, *) ' ' + end subroutine write_pointdata + + subroutine write_celldata(iunit, scalars, vectors) + integer, intent(in) :: iunit + type(vtk_data_array), allocatable, intent(in) :: scalars(:) + type(vtk_data_array), allocatable, intent(in) :: vectors(:) + integer :: i + if (.not. allocated(scalars) .and. .not. allocated(vectors)) then + write (iunit, *) ' ' + write (iunit, *) ' ' + return + end if + write (iunit, *) ' ' + if (allocated(scalars)) then + do i = 1, size(scalars) + write (iunit, '(A)') ' ' + write (iunit, '(1000(F12.6,1X))') scalars(i)%data + write (iunit, '(A)') ' ' + end do + end if + if (allocated(vectors)) then + do i = 1, size(vectors) + write (iunit, '(A)') ' ' + write (iunit, '(1000(F12.6,1X))') vectors(i)%data + write (iunit, '(A)') ' ' + end do + end if + write (iunit, *) ' ' + end subroutine write_celldata + + subroutine write_points(iunit, pts) + integer, intent(in) :: iunit + real, intent(in) :: pts(:, :) + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, '(1000(F12.6,1X))') pts + write (iunit, *) ' ' + write (iunit, *) ' ' + end subroutine write_points + + subroutine write_cells(iunit, conn, offsets, types) + integer, intent(in) :: iunit + integer, intent(in) :: conn(:), offsets(:), types(:) + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, '(1000(I8,1X))') conn + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, '(1000(I8,1X))') offsets + write (iunit, *) ' ' + write (iunit, *) ' ' + write (iunit, '(1000(I3,1X))') types + write (iunit, *) ' ' + write (iunit, *) ' ' + end subroutine write_cells + +end module mod_vtkAPI diff --git a/src_output/wireProbeOutput.F90 b/src_output/wireProbeOutput.F90 new file mode 100644 index 00000000..572cc288 --- /dev/null +++ b/src_output/wireProbeOutput.F90 @@ -0,0 +1,459 @@ +module mod_wireProbeOutput + use FDETYPES + USE mod_UTILS + use Report + use outputTypes + use mod_outputUtils + use wiresHolland_constants + use HollandWires + + implicit none + private + + !=========================== + ! Public interface + !=========================== + public :: init_wire_current_probe_output + public :: init_wire_charge_probe_output + public :: update_wire_current_probe_output + public :: update_wire_charge_probe_output + public :: flush_wire_current_probe_output + public :: flush_wire_charge_probe_output + !=========================== + + !=========================== + ! Private interface + !=========================== + private :: find_current_segment + private :: find_charge_segment + private :: build_output_path + private :: probe_bounds_extension + private :: clear_current_time_data + private :: clear_charge_time_data + private :: update_current_holland + +#ifdef CompileWithBerengerWires + private :: update_current_berenger +#endif + +#ifdef CompileWithSlantedWires + private :: update_current_slanted +#endif + !=========================== + + contains + !====================================================================== + ! INITIALIZATION + !====================================================================== + subroutine init_wire_current_probe_output(this, coordinates, node, field, domain, media, & + outputTypeExtension, mpidir, wiresflavor) + type(wire_current_probe_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: coordinates + type(domain_t), intent(in) :: domain + type(MediaData_t), intent(in) :: media(:) + integer(kind=SINGLE), intent(in) :: node, field, mpidir + character(len=*), intent(in) :: outputTypeExtension, wiresflavor + + this%mainCoords = coordinates + this%component = field + this%domain = domain + this%sign = 1 + + call find_current_segment(this, node, field, media, wiresflavor) + this%path = build_output_path(outputTypeExtension, field, node, mpidir, coordinates) + + call alloc_and_init(this%timeStep, BuffObse, 0.0_RKIND_tiempo) + call create_data_file(this%filePathTime, this%path, timeExtension, datFileExtension) + + end subroutine init_wire_current_probe_output + + + subroutine init_wire_charge_probe_output(this, coordinates, node, field, domain, & + outputTypeExtension, mpidir, wiresflavor) + type(wire_charge_probe_output_t), intent(out) :: this + type(cell_coordinate_t), intent(in) :: coordinates + type(domain_t), intent(in) :: domain + integer(kind=SINGLE), intent(in) :: node, field, mpidir + character(len=*), intent(in) :: outputTypeExtension, wiresflavor + + this%mainCoords = coordinates + this%component = field + this%domain = domain + this%sign = 1 + + call find_charge_segment(this, node, field, wiresflavor) + this%path = build_output_path(outputTypeExtension, field, node, mpidir, coordinates) + + call alloc_and_init(this%timeStep, BuffObse, 0.0_RKIND_tiempo) + call alloc_and_init(this%chargeValue, BuffObse, 0.0_RKIND) + call create_data_file(this%filePathTime, this%path, timeExtension, datFileExtension) + + end subroutine init_wire_charge_probe_output + + !====================================================================== + ! UPDATE + !====================================================================== + subroutine update_wire_current_probe_output(this, step, control, InvEps, InvMu) + type(wire_current_probe_output_t), intent(inout) :: this + real(kind=RKIND_tiempo), intent(in) :: step + type(sim_control_t), intent(in) :: control + real(kind=RKIND), intent(in) :: InvEps(:), InvMu(:) + + this%nTime = this%nTime + 1 + this%timeStep(this%nTime) = step + + select case (trim(control%wiresflavor)) + case ('holland','transition') + call update_current_holland(this, control, InvEps, InvMu) +#ifdef CompileWithBerengerWires + case ('berenger') + call update_current_berenger(this, InvEps, InvMu) +#endif +#ifdef CompileWithSlantedWires + case ('slanted','semistructured') + call update_current_slanted(this) +#endif + end select + end subroutine + + + subroutine update_wire_charge_probe_output(this, step) + type(wire_charge_probe_output_t), intent(inout) :: this + real(kind=RKIND_tiempo), intent(in) :: step + + this%nTime = this%nTime + 1 + this%timeStep(this%nTime) = step + this%chargeValue(this%nTime) = this%segment%ChargeMinus%ChargePresent + end subroutine + + !====================================================================== + ! FLUSH + !====================================================================== + subroutine flush_wire_current_probe_output(this) + type(wire_current_probe_output_t), intent(inout) :: this + integer :: i + integer :: unit + + open(unit, file=this%filePathTime, & + status='old', position='append') + + do i = 1, this%nTime + write(unit, fmt) this%timeStep(i), & + this%currentValues(i)%current, & + this%currentValues(i)%deltaVoltage, & + this%currentValues(i)%plusVoltage, & + this%currentValues(i)%minusVoltage, & + this%currentValues(i)%voltageDiference + end do + close(unit) + + call clear_current_time_data(this) + end subroutine + + + subroutine flush_wire_charge_probe_output(this) + type(wire_charge_probe_output_t), intent(inout) :: this + integer :: i + integer :: unit + + open(unit, file=this%filePathTime, & + status='old', position='append') + + do i = 1, this%nTime + write(unit, fmt) this%timeStep(i), this%chargeValue(i) + end do + close(unit) + + call clear_charge_time_data(this) + end subroutine + + subroutine find_current_segment(this, node, field, media, wiresflavor) + type(wire_current_probe_output_t), intent(inout) :: this + type(MediaData_t), intent(in) :: media(:) + integer(kind=SINGLE), intent(in) :: node, field + character(len=*), intent(in) :: wiresflavor + + type(Thinwires_t), pointer :: Hwireslocal + type(CurrentSegments), pointer :: seg +#ifdef CompileWithBerengerWires + type(TWires), pointer :: Hwireslocal_B +#endif +#ifdef CompileWithSlantedWires + type(WiresData), pointer :: Hwireslocal_S +#endif + + integer :: n, iwi, iwj, node2 + logical :: found + character(len=BUFSIZE) :: buff + + found = .false. + this%sign = 1 + + select case (trim(adjustl(wiresflavor))) + case ('holland','transition') + Hwireslocal => GetHwires() + this%segment => Hwireslocal%NullSegment + + do n = 1, Hwireslocal%NumCurrentSegments + seg => Hwireslocal%CurrentSegment(n) + if (seg%origindex == node .and. & + seg%i == iCoord .and. seg%j == jCoord .and. seg%k == kCoord .and. & + seg%tipofield*10 == field) then + found = .true. + this%segment => seg + if (seg%orientadoalreves) this%sign = -1 + exit + end if + end do + +#ifdef CompileWithBerengerWires + case ('berenger') + Hwireslocal_B => GetHwires_Berenger() + do n = 1, Hwireslocal_B%NumSegments + if (Hwireslocal_B%Segments(n)%IndexSegment == node) then + found = .true. + this%segmentBerenger => Hwireslocal_B%Segments(n) + if (Hwireslocal_B%Segments(n)%orientadoalreves) this%sign = -1 + exit + end if + end do +#endif + +#ifdef CompileWithSlantedWires + case ('slanted','semistructured') + Hwireslocal_S => GetHwires_Slanted() + do n = 1, Hwireslocal_S%NumSegments + if (Hwireslocal_S%Segments(n)%ptr%Index == node) then + found = .true. + this%segmentSlanted => Hwireslocal_S%Segments(n)%ptr + exit + end if + end do +#endif + end select + + ! --- multirabo fallback (Holland only) + if (.not. found .and. trim(adjustl(wiresflavor)) /= 'berenger') then + buscarabono: do iwi = 1, Hwireslocal%NumDifferentWires + do iwj = 1, media(Hwireslocal%WireTipoMedio(iwi))%wire(1)%numsegmentos + if (node == media(Hwireslocal%WireTipoMedio(iwi))%wire(1)%segm(iwj)%origindex .and. & + media(Hwireslocal%WireTipoMedio(iwi))%wire(1)%segm(iwj)%multirabo) then + + node2 = media(Hwireslocal%WireTipoMedio(iwi))%wire(1)%segm(iwj)%multiraboDE + do n = 1, Hwireslocal%NumCurrentSegments + seg => Hwireslocal%CurrentSegment(n) + if (seg%origindex == node2) then + found = .true. + this%segment => seg + if (seg%orientadoalreves) this%sign = -1 + exit buscarabono + end if + end do + end if + end do + end do buscarabono + end if + + if (.not. found) then + write(buff,'(a,4i7,a)') 'ERROR: WIRE probe ',node,iCoord,jCoord,kCoord,' DOES NOT EXIST' + call WarnErrReport(buff,.true.) + end if + end subroutine find_current_segment + + subroutine find_charge_segment(this, node, field, wiresflavor) + type(wire_charge_probe_output_t), intent(inout) :: this + integer(kind=SINGLE), intent(in) :: node, field + character(len=*), intent(in) :: wiresflavor + + type(Thinwires_t), pointer :: Hwireslocal + type(CurrentSegments), pointer :: seg + integer :: n + logical :: found + character(len=BUFSIZE) :: buff + + found = .false. + this%sign = 1 + + if (trim(adjustl(wiresflavor)) /= 'holland' .and. & + trim(adjustl(wiresflavor)) /= 'transition') then + call WarnErrReport('Charge probes only supported for holland wires', .true.) + return + end if + + Hwireslocal => GetHwires() + + do n = 1, Hwireslocal%NumCurrentSegments + seg => Hwireslocal%CurrentSegment(n) + if (seg%origindex == node .and. & + seg%i == iCoord .and. seg%j == jCoord .and. seg%k == kCoord .and. & + seg%tipofield*10000 == field) then + found = .true. + this%segment => seg + if (seg%orientadoalreves) this%sign = -1 + exit + end if + end do + + if (.not. found) then + write(buff,'(a,4i7,a)') 'ERROR: CHARGE probe ',node,iCoord,jCoord,kCoord,' DOES NOT EXIST' + call WarnErrReport(buff,.true.) + end if + end subroutine find_charge_segment + + function probe_bounds_extension(mpidir, coords) result(ext) + integer(kind=SINGLE), intent(in) :: mpidir + type(cell_coordinate_t), intent(in) :: coords + character(len=BUFSIZE) :: ext + character(len=BUFSIZE) :: ci, cj, ck + + write(ci,'(i7)') coords%x + write(cj,'(i7)') coords%y + write(ck,'(i7)') coords%z + +#if CompileWithMPI + select case (mpidir) + case (3) + ext = trim(adjustl(ci))//'_'//trim(adjustl(cj))//'_'//trim(adjustl(ck)) + case (2) + ext = trim(adjustl(cj))//'_'//trim(adjustl(ck))//'_'//trim(adjustl(ci)) + case (1) + ext = trim(adjustl(ck))//'_'//trim(adjustl(ci))//'_'//trim(adjustl(cj)) + case default + call stoponerror(0,0,'Buggy error in mpidir.') + end select +#else + ext = trim(adjustl(ci))//'_'//trim(adjustl(cj))//'_'//trim(adjustl(ck)) +#endif + end function probe_bounds_extension + + function build_output_path(outExt, field, node, mpidir, coords) result(path) + character(len=*), intent(in) :: outExt + integer(kind=SINGLE), intent(in) :: field, node, mpidir + type(cell_coordinate_t), intent(in) :: coords + character(len=BUFSIZE) :: path + character(len=BUFSIZE) :: nodeStr, fieldExt, boundsExt + + write(nodeStr,'(i7)') node + fieldExt = get_prefix_extension(field, mpidir) + boundsExt = probe_bounds_extension(mpidir, coords) + + path = trim(outExt)//'_'//trim(fieldExt)//'_'// & + trim(boundsExt)//'_s'//trim(adjustl(nodeStr)) + end function build_output_path + + subroutine clear_current_time_data(this) + type(wire_current_probe_output_t), intent(inout) :: this + + this%timeStep = 0.0_RKIND_tiempo + this%currentValues%current = 0.0_RKIND + this%currentValues%deltaVoltage = 0.0_RKIND + this%currentValues%plusVoltage = 0.0_RKIND + this%currentValues%minusVoltage = 0.0_RKIND + this%currentValues%voltageDiference = 0.0_RKIND + this%nTime = 0 + end subroutine clear_current_time_data + + subroutine clear_charge_time_data(this) + type(wire_charge_probe_output_t), intent(inout) :: this + + this%timeStep = 0.0_RKIND_tiempo + this%chargeValue = 0.0_RKIND + this%nTime = 0 + end subroutine clear_charge_time_data + + subroutine update_current_holland(this, control, InvEps, InvMu) + type(wire_current_probe_output_t), intent(inout) :: this + type(sim_control_t), intent(in) :: control + real(kind=RKIND), intent(in) :: InvEps(:), InvMu(:) + + type(CurrentSegments), pointer :: seg + + seg => this%segment + + this%currentValues(this%nTime)%current = & + this%sign * seg%currentpast + + this%currentValues(this%nTime)%deltaVoltage = & + - seg%Efield_wire2main * seg%delta + + if (control%wirecrank) then + this%currentValues(this%nTime)%plusVoltage = this%sign * & + (seg%ChargePlus%ChargePresent) * seg%Lind * & + (InvMu(seg%indexmed) * InvEps(seg%indexmed)) + + this%currentValues(this%nTime)%minusVoltage = this%sign * & + (seg%ChargeMinus%ChargePresent) * seg%Lind * & + (InvMu(seg%indexmed) * InvEps(seg%indexmed)) + else + this%currentValues(this%nTime)%plusVoltage = this%sign * & + ((seg%ChargePlus%ChargePresent + seg%ChargePlus%ChargePast) / 2.0_RKIND) * & + seg%Lind * (InvMu(seg%indexmed) * InvEps(seg%indexmed)) + + this%currentValues(this%nTime)%minusVoltage = this%sign * & + ((seg%ChargeMinus%ChargePresent + seg%ChargeMinus%ChargePast) / 2.0_RKIND) * & + seg%Lind * (InvMu(seg%indexmed) * InvEps(seg%indexmed)) + end if + + this%currentValues(this%nTime)%voltageDiference = & + this%currentValues(this%nTime)%plusVoltage - & + this%currentValues(this%nTime)%minusVoltage + end subroutine update_current_holland + +#ifdef CompileWithBerengerWires + subroutine update_current_berenger(this, InvEps, InvMu) + type(wire_current_probe_output_t), intent(inout) :: this + real(kind=RKIND), intent(in) :: InvEps(:), InvMu(:) + + type(TSegment), pointer :: seg + + seg => this%segmentBerenger + + this%currentValues(this%nTime)%current = & + this%sign * seg%currentpast + + this%currentValues(this%nTime)%deltaVoltage = & + - seg%field * seg%dl + + this%currentValues(this%nTime)%plusVoltage = this%sign * & + ((seg%ChargePlus + seg%ChargePlusPast) / 2.0_RKIND) * & + seg%L * (InvMu(seg%imed) * InvEps(seg%imed)) + + this%currentValues(this%nTime)%minusVoltage = this%sign * & + ((seg%ChargeMinus + seg%ChargeMinusPast) / 2.0_RKIND) * & + seg%L * (InvMu(seg%imed) * InvEps(seg%imed)) + + this%currentValues(this%nTime)%voltageDiference = & + this%currentValues(this%nTime)%plusVoltage - & + this%currentValues(this%nTime)%minusVoltage + end subroutine update_current_berenger +#endif + +#ifdef CompileWithSlantedWires + subroutine update_current_slanted(this) + type(wire_current_probe_output_t), intent(inout) :: this + + class(Segment), pointer :: seg + + seg => this%segmentSlanted + + this%currentValues(this%nTime)%current = & + seg%Currentpast + + this%currentValues(this%nTime)%deltaVoltage = & + - seg%field * seg%dl + + this%currentValues(this%nTime)%plusVoltage = & + (seg%Voltage(iPlus)%ptr%Voltage + & + seg%Voltage(iPlus)%ptr%VoltagePast) / 2.0_RKIND + + this%currentValues(this%nTime)%minusVoltage = & + (seg%Voltage(iMinus)%ptr%Voltage + & + seg%Voltage(iMinus)%ptr%VoltagePast) / 2.0_RKIND + + this%currentValues(this%nTime)%voltageDiference = & + this%currentValues(this%nTime)%plusVoltage - & + this%currentValues(this%nTime)%minusVoltage + end subroutine update_current_slanted +#endif + +end module mod_wireProbeOutput diff --git a/src_output/xdmfAPI.F90 b/src_output/xdmfAPI.F90 new file mode 100644 index 00000000..1868755c --- /dev/null +++ b/src_output/xdmfAPI.F90 @@ -0,0 +1,561 @@ +module mod_xdmfAPI + use HDF5 + implicit none + + ! HDF5 constants + + integer, parameter :: dp = kind(1.0d0) + + + interface h5_write_dataset + module procedure write_1d_dataset + module procedure write_2d_dataset + module procedure write_3d_dataset + end interface + + interface h5_init_extendable_dataset + module procedure init_extendable_1D_dataset + module procedure init_extendable_2D_dataset + module procedure init_extendable_4D_dataset + end interface + + interface h5_append_rows_to_dataset + module procedure append_rows_to_1d_dataset + module procedure append_rows_to_2d_dataset + module procedure append_rows_to_4d_dataset + end interface + +contains + subroutine xdmf_write_header_file(unit, gridName) + integer, intent(in) :: unit + character (len=*), intent(in) :: gridName + write (unit, '(A)' ) '' + write (unit, '(A)' ) '' + write (unit, '(A)' ) '' + write (unit, '(A,A,A)') '' + end subroutine + + subroutine xdmf_write_footer_file(unit) + integer :: unit + write (unit, '(A)') '' + write (unit, '(A)') '' + write (unit, '(A)') '' + end subroutine + + subroutine xdmf_write_topology(unit, dimensions) + integer, intent(in) :: unit + integer, intent(in), dimension(3) :: dimensions + write (unit, '(A,I0,1X,I0,1X,I0,A)') '' !(z,y,x) + end subroutine + + subroutine xdmf_write_geometry(unit, dimensions, h5_filename) + integer, intent(in) :: unit + integer, intent(in), dimension(3) :: dimensions + character (len=*), intent(in) :: h5_filename + + write(unit, '(A)') '' + ! X coordinates + write(unit, '(A,I0,A)') '' + write(unit, '(A,A)' ) trim(h5_filename),':/coordsX' + write(unit, '(A)' ) '' + ! Y coordinates + write(unit, '(A,I0,A)') '' + write(unit, '(A,A)' ) trim(h5_filename),':/coordsY' + write(unit, '(A)' ) '' + ! Z coordinates + write(unit, '(A,I0,A)') '' + write(unit, '(A,A)' ) trim(h5_filename),':/coordsZ' + write(unit, '(A)' ) '' + ! Close JOIN and Geometry + write(unit, '(A)' ) '' + end subroutine + + subroutine xdmf_write_time_array(unit, nTime, h5_filename) + integer, intent(in) :: unit + integer, intent(in) :: nTime + character (len=*), intent(in) :: h5_filename + write(unit, '(A)' ) '' + end subroutine + + subroutine xdmf_write_scalar_attribute(unit, dimensions, h5_filename, attributeName) + integer, intent(in) :: unit + integer, intent(in), dimension(4) :: dimensions + character (len=*), intent(in) :: h5_filename + character (len=*), intent(in) :: attributeName + + write(unit, '(A,A,A)' ) '' + write(unit, '(A,I0,1X,I0,1X,I0,1X,I0,A)') '' + write(unit, '(A,A,A)' ) trim(h5_filename), ':/' ,trim(attributeName) + write(unit, '(A)' ) '' + write(unit, '(A)' ) '' + end subroutine + + subroutine xdmf_create_grid_step_info(unit, stepName, stepValue, h5_filename, ncoords) + !Requires file already open + !h5_file must contain a coords field + integer, intent(in) :: unit + character(len=*), intent(in) :: stepName + real, intent(in) :: stepValue + character(len=*), intent(in) :: h5_filename + integer, intent(in) :: ncoords + + write (unit, '(A,A,A)' ) '' + write (unit, '(A,G0,A)' ) '' + end subroutine xdmf_close_grid + + subroutine xdmf_write_attribute(unit, attributeName) + integer, intent(in) :: unit + character(len=*), intent(in) :: attributeName + write (unit, '(A,A,A)' ) '' + end subroutine xdmf_write_attribute + + subroutine xdmf_close_attribute(unit) + integer, intent(in) :: unit + write (unit, '(A)' ) '' + end subroutine xdmf_close_attribute + + subroutine xdmf_write_hyperslab_data_item(unit, offset, stride, selection, h5_dimension, h5_file_path, h5_data_path) + integer, intent(in) :: unit, offset(4), stride(4), selection(4), h5_dimension(4) + character(len=*), intent(in) :: h5_file_path, h5_data_path + write (unit, '(A,I0,1X,I0,1X,I0,1X,I0,A)') '' + call xdmf_write_h5_acces_data_item(unit, offset, stride, selection) + call xdmf_write_h5_data_path(unit, h5_dimension, h5_file_path, h5_data_path) + call xdmf_close_data_item(unit) + end subroutine xdmf_write_hyperslab_data_item + + subroutine xdmf_write_h5_acces_data_item(unit, offset, stride, selection) + !Used on cases where we acces parts of an h5 array + integer, intent(in) :: unit, offset(4), stride(4), selection(4) + write (unit, '(A)' ) '' + write (unit, '(I0,1X,I0,1X,I0,1X,I0)') offset(1), offset(2), offset(3), offset(4) + write (unit, '(I0,1X,I0,1X,I0,1X,I0)') stride(1), stride(2), stride(3), stride(4) + write (unit, '(I0,1X,I0,1X,I0,1X,I0)') selection(1), selection(2), selection(3), selection(4) + call xdmf_close_data_item(unit) + end subroutine xdmf_write_h5_acces_data_item + + subroutine xdmf_write_h5_data_path(unit, h5_dimension, h5_file_path, h5_data_path) + integer, intent(in) :: unit, h5_dimension(4) + character(len=*), intent(in) :: h5_file_path, h5_data_path + write (unit, '(A,A,A)') ' 0) then + p = trim(p)//"\" + else + p = trim(p)//"/" + end if +#ifdef GNUCompiler + inquire (file=p, exist=exists) +#else + inquire (directory=p, exist=exists) +#endif + end function folder_exists + + !------------------------------------------------------------ + ! Remove the final extension from a filename + !------------------------------------------------------------ + function remove_extension(filename) result(base) + character(len=*), intent(in) :: filename + character(len=BUFSIZE) :: base + integer :: last_dot, n, i + + base = trim(filename) + n = len_trim(base) + last_dot = 0 + + do i = n, 1, -1 + if (base(i:i) == '.') then + last_dot = i + exit + end if + end do + + if (last_dot > 0) then + base = base(:last_dot-1) + end if + end function remove_extension + + !------------------------------------------------------------ + ! Join two path components into one (simplified) + !------------------------------------------------------------ + function join_path(base, child) result(fullpath) + character(len=*), intent(in) :: base, child + character(len=:), allocatable :: fullpath + character(len=1) :: sep + integer :: n + + + sep = get_path_separator() + + + fullpath = trim(base) + n = len_trim(fullpath) + + + if (n > 0) then + if (fullpath(n:n) /= sep) fullpath = fullpath // sep + end if + + + fullpath = fullpath // trim(child) + end function join_path + + !------------------------------------------------------------ + ! Get the last component of a path (file or folder) + !------------------------------------------------------------ + function get_last_component(path) result(component) + character(len=*), intent(in) :: path + character(len=BUFSIZE) :: component + integer :: last_slash, n + + n = len_trim(path) + component = path(:n) + + if (n > 0) then + if (component(n:n) == get_path_separator()) component = component(:n - 1) + end if + + last_slash = scan(component, get_path_separator(),.TRUE.) + + if (last_slash > 0) then + component = component(last_slash + 1:) + end if + end function get_last_component + + !------------------------------------------------------------ + ! Create a folder (portable) + !------------------------------------------------------------ + subroutine create_folder(path, ios) + character(len=*), intent(in) :: path + integer, intent(out) :: ios + + if (folder_exists(path)) then + ios = 0 + return + end if + +#ifdef __WIN32__ + call execute_command_line("mkdir """//trim(path)//"""", exitstat=ios) +#else + call execute_command_line("mkdir -p "//trim(path), exitstat=ios) +#endif + end subroutine create_folder + + !------------------------------------------------------------ + ! Remove a folder + !------------------------------------------------------------ + subroutine remove_folder(path, ios) + character(len=*), intent(in) :: path + integer, intent(out) :: ios + + if (.not. folder_exists(path)) then + ios = 0 + return + end if + +#ifdef __WIN32__ + call execute_command_line("rmdir /S /Q """//trim(path)//"""", exitstat=ios) +#else + call execute_command_line("rm -rf "//trim(path), exitstat=ios) +#endif + + end subroutine remove_folder + + !------------------------------------------------------------ + ! Check if a file exists + !------------------------------------------------------------ + function file_exists(path) result(exists) + character(len=*), intent(in) :: path + logical :: exists + + inquire (file=trim(path), exist=exists) + end function file_exists + + !------------------------------------------------------------ + ! Delete a file + !------------------------------------------------------------ + subroutine delete_file(path, ios) + character(len=*), intent(in) :: path + integer, intent(out) :: ios + + if (.not. file_exists(path)) then + ios = 0 + return + end if + +#ifdef __WIN32__ + call execute_command_line("del /Q """//trim(path)//"""", exitstat=ios) +#else + call execute_command_line("rm -f "//trim(path), exitstat=ios) +#endif + + end subroutine delete_file + + !------------------------------------------------------------ + ! List files in a folder (simple) + !------------------------------------------------------------ + subroutine list_files(path, files, nfiles, ios) + character(len=*), intent(in) :: path + character(len=BUFSIZE), dimension(:), intent(out) :: files + integer, intent(out) :: nfiles + integer, intent(out) :: ios + + character(len=BUFSIZE) :: cmd + character(len=BUFSIZE) :: line + integer :: i + integer :: unit + + nfiles = 0 + ios = 0 + + if (.not. folder_exists(path)) then + ios = 1 + return + end if + +#ifdef __WIN32__ + cmd = 'dir /B "'//trim(path)//'"' +#else + cmd = 'ls -1 "'//trim(path)//'"' +#endif + + open (newunit=unit, file=cmd, action='read', status='old', iostat=ios) + + if (ios /= 0) return + + do + read (unit, '(A)', iostat=ios) line + if (ios /= 0) exit + i = i + 1 + if (i > size(files)) then + ios = 2 + exit + end if + files(i) = adjustl(trim(line)) + end do + + nfiles = i + close (unit) + + end subroutine list_files + + !------------------------------------------------------------ + ! Create a file, creating its folder if needed + !------------------------------------------------------------ + subroutine create_file_with_path(fullpath, ios) + character(len=*), intent(in) :: fullpath + integer, intent(out) :: ios + integer :: unit + + character(len=BUFSIZE) :: folder + integer :: pos + + ios = 0 + ! Find last slash or backslash + pos = index(fullpath, get_path_separator()) + + if (pos > 0) then + folder = adjustl(fullpath(:pos - 1)) + call create_folder(trim(folder), ios) + if (ios /= 0) return + end if + open (newunit=unit, file=trim(adjustl(fullpath)), status='replace', iostat=ios) + if (ios == 0) close (unit) + + end subroutine create_file_with_path + + function get_path_separator() result(sep) + character(len=1) :: sep + +#ifdef __WIN32__ + sep = '\' +#else + sep = '/' +#endif + + end function get_path_separator + +end module mod_directoryUtils diff --git a/src_utils/logUtils.F90 b/src_utils/logUtils.F90 new file mode 100644 index 00000000..6fb0bbc8 --- /dev/null +++ b/src_utils/logUtils.F90 @@ -0,0 +1,90 @@ +module mod_logUtils + implicit none + +contains + subroutine printMessage(layoutNumber, message) + implicit none + integer, intent(in) :: layoutnumber + character(len=*), intent(in) :: message + logical :: printea + printea = .true. + + ! Print into console + if (printea) then + write (*, '(a)') trim(adjustl(message)) + end if + + ! Print into unitFile 11 + if (layoutnumber == 0) then + write (11, '(a)') trim(adjustl(message)) + end if + end subroutine printMessage + + subroutine printMessageWithSeparator(layoutnumber, message) + implicit none + integer, intent(in) :: layoutnumber + character(len=*), intent(in) :: message + logical :: printea + character(len=50) :: SEPARADOR + SEPARADOR = repeat('_', 50) + printea = .true. + + ! Print into console + if (printea) then + write (*, '(a)') SEPARADOR + write (*, '(a)') trim(adjustl(message)) + write (*, '(a)') SEPARADOR + end if + + ! Print into unitFile 11 + if (layoutnumber == 0) then + write (11, '(a)') SEPARADOR + write (11, '(a)') trim(adjustl(message)) + write (11, '(a)') SEPARADOR + end if + + end subroutine printMessageWithSeparator + + subroutine printMessageWithEndingSeparator(layoutNumber, message) + implicit none + integer, intent(in) :: layoutnumber + character(len=*), intent(in) :: message + logical :: printea + character(len=50) :: SEPARADOR + SEPARADOR = repeat('_', 50) + printea = .true. + + ! Print into console + if (printea) then + write (*, '(a)') SEPARADOR + write (*, '(a)') trim(adjustl(message)) + write (*, '(a)') SEPARADOR + end if + + ! Print into unitFile 11 + if (layoutnumber == 0) then + write (11, '(a)') SEPARADOR + write (11, '(a)') trim(adjustl(message)) + write (11, '(a)') SEPARADOR + end if + end subroutine printMessageWithEndingSeparator + + subroutine printSeparator(layoutnumber) + implicit none + integer, intent(in) :: layoutnumber + logical :: printea + character(len=50) :: SEPARADOR + SEPARADOR = repeat('_', 50) + printea = .true. + + ! Print into console + if (printea) then + write (*, '(a)') SEPARADOR + end if + + ! Print into unitFile 11 + if (layoutnumber == 0) then + write (11, '(a)') SEPARADOR + end if + end subroutine printSeparator +end module mod_logUtils diff --git a/src_utils/utils.F90 b/src_utils/utils.F90 new file mode 100644 index 00000000..da6a7b7d --- /dev/null +++ b/src_utils/utils.F90 @@ -0,0 +1,9 @@ +module mod_UTILS + use mod_allocationUtils + use mod_valueReplacer + use mod_directoryUtils + implicit none + +contains + +end module mod_UTILS \ No newline at end of file diff --git a/src_utils/valueReplacer.F90 b/src_utils/valueReplacer.F90 new file mode 100644 index 00000000..8c3df663 --- /dev/null +++ b/src_utils/valueReplacer.F90 @@ -0,0 +1,130 @@ +module mod_valueReplacer + use FDETYPES, only: RKIND, CKIND, SINGLE, RKIND_tiempo + implicit none + private + + public :: replace_value + + interface replace_value + ! Scalars + module procedure replace_scalar_int + module procedure replace_scalar_real + module procedure replace_scalar_complex + + ! 1D arrays + module procedure replace_1d_int + module procedure replace_1d_real + module procedure replace_1d_complex + + ! 2D arrays + module procedure replace_2d_int + module procedure replace_2d_real + module procedure replace_2d_complex + + ! 3D arrays + module procedure replace_3d_int + module procedure replace_3d_real + module procedure replace_3d_complex + end interface + +contains + !===================== + ! Scalar replacements + !===================== + subroutine replace_scalar_int(x, val) + integer(SINGLE), intent(inout) :: x + integer(SINGLE), intent(in) :: val + x = val + end subroutine + + subroutine replace_scalar_real(x, val) + real(RKIND), intent(inout) :: x + real(RKIND), intent(in) :: val + x = val + end subroutine + + subroutine replace_scalar_real_t(x, val) + real(RKIND_tiempo), intent(inout) :: x + real(RKIND_tiempo), intent(in) :: val + x = val + end subroutine + + subroutine replace_scalar_complex(x, val) + complex(CKIND), intent(inout) :: x + complex(CKIND), intent(in) :: val + x = val + end subroutine + + !===================== + ! 1D array replacements + !===================== + subroutine replace_1d_int(x, idx1, val) + integer(SINGLE), intent(inout) :: x(:) + integer(SINGLE), intent(in) :: idx1 + integer(SINGLE), intent(in) :: val + x(idx1) = val + end subroutine + + subroutine replace_1d_real(x, idx1, val) + real(RKIND), intent(inout) :: x(:) + integer(SINGLE), intent(in) :: idx1 + real(RKIND), intent(in) :: val + x(idx1) = val + end subroutine + + subroutine replace_1d_complex(x, idx1, val) + complex(CKIND), intent(inout) :: x(:) + integer(SINGLE), intent(in) :: idx1 + complex(CKIND), intent(in) :: val + x(idx1) = val + end subroutine + + !===================== + ! 2D array replacements + !===================== + subroutine replace_2d_int(x, idx1, idx2, val) + integer(SINGLE), intent(inout) :: x(:,:) + integer(SINGLE), intent(in) :: idx1, idx2 + integer(SINGLE), intent(in) :: val + x(idx1, idx2) = val + end subroutine + + subroutine replace_2d_real(x, idx1, idx2, val) + real(RKIND), intent(inout) :: x(:,:) + integer(SINGLE), intent(in) :: idx1, idx2 + real(RKIND), intent(in) :: val + x(idx1, idx2) = val + end subroutine + + subroutine replace_2d_complex(x, idx1, idx2, val) + complex(CKIND), intent(inout) :: x(:,:) + integer(SINGLE), intent(in) :: idx1, idx2 + complex(CKIND), intent(in) :: val + x(idx1, idx2) = val + end subroutine + + !===================== + ! 3D array replacements + !===================== + subroutine replace_3d_int(x, idx1, idx2, idx3, val) + integer(SINGLE), intent(inout) :: x(:,:,:) + integer(SINGLE), intent(in) :: idx1, idx2, idx3 + integer(SINGLE), intent(in) :: val + x(idx1, idx2, idx3) = val + end subroutine + + subroutine replace_3d_real(x, idx1, idx2, idx3, val) + real(RKIND), intent(inout) :: x(:,:,:) + integer(SINGLE), intent(in) :: idx1, idx2, idx3 + real(RKIND), intent(in) :: val + x(idx1, idx2, idx3) = val + end subroutine + + subroutine replace_3d_complex(x, idx1, idx2, idx3, val) + complex(CKIND), intent(inout) :: x(:,:,:) + integer(SINGLE), intent(in) :: idx1, idx2, idx3 + complex(CKIND), intent(in) :: val + x(idx1, idx2, idx3) = val + end subroutine + +end module mod_valueReplacer diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 5b2b68c4..7ebebbf8 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -21,11 +21,17 @@ if (SEMBA_FDTD_ENABLE_SMBJSON) set(SMBJSON_TESTS_LIBRARY smbjson_tests) add_subdirectory(rotate) set(ROTATE_TESTS_LIBRARY rotate_tests) - add_subdirectory(vtk) - set(VTK_TESTS_LIBRARY vtk_tests) + + if (SEMBA_FDTD_ENABLE_OUTPUT_MODULE) + add_subdirectory(output) + set(OUPUT_TESTS_LIBRARY output_tests) + set(VTK_API_TESTS_LIBRARY vtkAPI_tests) + set(XDMF_API_TESTS_LIBRARY xdmfAPI_tests) + endif() + if (NOT SEMBA_FDTD_ENABLE_MPI) - add_subdirectory(observation) - set(OBSERVATION_TESTS_LIBRARY observation_tests) + #add_subdirectory(observation) + #set(OBSERVATION_TESTS_LIBRARY observation_tests) endif() endif() @@ -44,6 +50,9 @@ target_link_libraries(fdtd_tests ${HDF_TESTS_LIBRARY} ${VTK_TESTS_LIBRARY} ${SYSTEM_TESTS_LIBRARY} + ${VTK_API_TESTS_LIBRARY} + ${XDMF_API_TESTS_LIBRARY} + ${OUPUT_TESTS_LIBRARY} ${OBSERVATION_TESTS_LIBRARY} GTest::gtest_main ) \ No newline at end of file diff --git a/test/fdtd_tests.cpp b/test/fdtd_tests.cpp index 08f95a01..3545667c 100644 --- a/test/fdtd_tests.cpp +++ b/test/fdtd_tests.cpp @@ -7,7 +7,9 @@ #ifdef CompileWithSMBJSON #include "smbjson/smbjson_tests.h" #include "rotate/rotate_tests.h" - #include "vtk/vtk_tests.h" + #include "output/output_tests.h" + #include "output/vtkAPI_tests.h" + #include "output/xdmfAPI_tests.h" #endif #ifndef CompileWithMPI #include "observation/observation_tests.h" diff --git a/test/observation/CMakeLists.txt b/test/observation/CMakeLists.txt index 9f54a0d8..6f157373 100644 --- a/test/observation/CMakeLists.txt +++ b/test/observation/CMakeLists.txt @@ -1,22 +1,22 @@ message(STATUS "Creating build system for test/observation") -add_library( - observation_test_fortran - "observation_testingTools.F90" - "test_observation.F90" - "test_preprocess.F90" - "test_observation_init.F90" - "test_observation_update.F90" -) - -target_link_libraries(observation_test_fortran - semba-outputs - test_utils_fortran -) - -add_library(observation_tests "observation_tests.cpp") - -target_link_libraries(observation_tests - observation_test_fortran - GTest::gtest -) \ No newline at end of file +#add_library( +# observation_test_fortran +# "observation_testingTools.F90" +# "test_observation.F90" +# "test_preprocess.F90" +# "test_observation_init.F90" +# "test_observation_update.F90" +#) +# +#target_link_libraries(observation_test_fortran +# semba-outputs +# test_utils_fortran +#) +# +#add_library(observation_tests "observation_tests.cpp") +# +#target_link_libraries(observation_tests +# observation_test_fortran +# GTest::gtest +#) \ No newline at end of file diff --git a/test/observation/observation_testingTools.F90 b/test/observation/observation_testingTools.F90 index 5b672a4a..920c7a28 100644 --- a/test/observation/observation_testingTools.F90 +++ b/test/observation/observation_testingTools.F90 @@ -129,23 +129,6 @@ logical function approx_equal(a, b, tol) result(equal) equal = abs(a - b) <= tol end function approx_equal - function create_time_array(array_size, interval) result(arr) - integer, intent(in) :: array_size - integer(kind=4) :: i - real(kind=RKIND_tiempo) :: interval - - real(kind=RKIND_tiempo), pointer, dimension(:) :: arr - allocate (arr(array_size)) - - DO i = 1, array_size - arr(i) = (i - 1)*interval - END DO - end function create_time_array - - function create_limit_type() result(r) - type(limit_t) :: r - end function - function create_xyz_limit_array(XI,YI,ZI,XE,YE,ZE) result(arr) type(XYZlimit_t), dimension(1:6) :: arr integer (kind=4), intent(in) :: XI,YI,ZI,XE,YE,ZE @@ -160,60 +143,6 @@ function create_xyz_limit_array(XI,YI,ZI,XE,YE,ZE) result(arr) end do end function create_xyz_limit_array - - function create_facesNF2FF(tr, fr, iz, de, ab, ar) result(faces) - type(nf2ff_t) :: faces - logical :: tr, fr, iz, de, ab, ar - - faces%tr = tr - faces%fr = fr - faces%iz = iz - faces%de = de - faces%ab = ab - faces%ar = ar - end function create_facesNF2FF - - function create_control_flags(layoutnumber, size, mpidir, finaltimestep, & - nEntradaRoot, wiresflavor, & - resume, saveall, NF2FFDecim, simu_devia, singlefilewrite, & - facesNF2FF) result(control) - type(sim_control_t) :: control - integer(kind=4), intent(in) :: layoutnumber, size, mpidir, finaltimestep - character(len=*), intent(in) :: nEntradaRoot, wiresflavor - logical, intent(in) :: resume, saveall, NF2FFDecim, simu_devia, singlefilewrite - type(nf2ff_t), intent(in) :: facesNF2FF - - control%layoutnumber = layoutnumber - control%size = size - control%mpidir = mpidir - control%finaltimestep = finaltimestep - control%nEntradaRoot = nEntradaRoot - control%wiresflavor = wiresflavor - control%resume = resume - control%saveall = saveall - control%NF2FFDecim = NF2FFDecim - control%simu_devia = simu_devia - control%singlefilewrite = singlefilewrite - control%facesNF2FF = facesNF2FF - - end function create_control_flags - - function create_base_sgg() result(sgg) - type(SGGFDTDINFO) :: sgg - - sgg%NumMedia = 3 - allocate(sgg%Med(0:sgg%NumMedia)) - sgg%Med = create_basic_media() - sgg%NumberRequest = 1 - sgg%dt = 0.1_RKIND_tiempo - sgg%tiempo => create_time_array(100, sgg%dt) - sgg%Sweep = create_xyz_limit_array(0,0,0,6,6,6) - sgg%SINPMLSweep = create_xyz_limit_array(1,1,1,5,5,5) - sgg%NumPlaneWaves = 1 - sgg%alloc = create_xyz_limit_array(0,0,0,6,6,6) - - end function create_base_sgg - function create_basic_media () result(media) type(MediaData_t) :: media end function create_basic_media diff --git a/test/observation/observation_tests.h b/test/observation/observation_tests.h index c3a1ebb3..09ec239e 100644 --- a/test/observation/observation_tests.h +++ b/test/observation/observation_tests.h @@ -1,36 +1,37 @@ #include - -extern "C" int test_allocate_serialize_for_time_domain(); -extern "C" int test_allocate_serialize_for_frequency_domain(); -extern "C" int test_allocate_current(); - -extern "C" int test_initial_time_less_than_timestep(); -extern "C" int test_timestep_greater_and_mapvtk(); -extern "C" int test_timestep_greater_not_mapvtk(); -extern "C" int test_freqstep_zero_or_large(); -extern "C" int test_volumic_false_true_and_saveall(); -extern "C" int test_saveall_branch(); -extern "C" int test_final_less_than_initial(); -extern "C" int test_huge_cap(); - -extern "C" int test_init_time_movie_observation(); - -extern "C" int test_update_time_movie_observation(); - -TEST(observation, test_allocate_time ) {EXPECT_EQ(0, test_allocate_serialize_for_time_domain()); } -TEST(observation, test_allocate_frequency ) {EXPECT_EQ(0, test_allocate_serialize_for_frequency_domain()); } -TEST(observation, test_allocate_serialize_current) {EXPECT_EQ(0, test_allocate_current()); } - -TEST(observation, test_preproces_initial_time_less_than_timestep) {EXPECT_EQ(0, test_initial_time_less_than_timestep()); } -TEST(observation, test_preproces_timestep_greater_and_mapvtk ) {EXPECT_EQ(0, test_timestep_greater_and_mapvtk()); } -TEST(observation, test_preproces_timestep_greater_not_mapvtk ) {EXPECT_EQ(0, test_timestep_greater_not_mapvtk()); } -TEST(observation, test_preproces_freqstep_zero_or_large ) {EXPECT_EQ(0, test_freqstep_zero_or_large()); } -TEST(observation, test_preproces_volumic_false_true_and_saveall ) {EXPECT_EQ(0, test_volumic_false_true_and_saveall()); } -TEST(observation, test_preproces_saveall_branch ) {EXPECT_EQ(0, test_saveall_branch()); } -TEST(observation, test_preproces_final_less_than_initial ) {EXPECT_EQ(0, test_final_less_than_initial()); } -TEST(observation, test_preproces_huge_cap ) {EXPECT_EQ(0, test_huge_cap()); } - -TEST(observation, test_init_movie_observation ) {EXPECT_EQ(0, test_init_time_movie_observation()); } - -TEST(observation, test_update_movie_observation ) {EXPECT_EQ(0, test_update_time_movie_observation()); } - +// +//extern "C" int test_allocate_serialize_for_time_domain(); +//extern "C" int test_allocate_serialize_for_frequency_domain(); +//extern "C" int test_allocate_current(); +// +//extern "C" int test_initial_time_less_than_timestep(); +//extern "C" int test_timestep_greater_and_mapvtk(); +//extern "C" int test_timestep_greater_not_mapvtk(); +//extern "C" int test_freqstep_zero_or_large(); +//extern "C" int test_volumic_false_true_and_saveall(); +//extern "C" int test_saveall_branch(); +//extern "C" int test_final_less_than_initial(); +//extern "C" int test_huge_cap(); +// +//extern "C" int test_init_time_movie_observation(); +// +//extern "C" int test_update_time_movie_observation(); +// +//TEST(observation, test_allocate_time ) {EXPECT_EQ(0, test_allocate_serialize_for_time_domain()); } +//TEST(observation, test_allocate_frequency ) {EXPECT_EQ(0, test_allocate_serialize_for_frequency_domain()); } +//TEST(observation, test_allocate_serialize_current) {EXPECT_EQ(0, test_allocate_current()); } +// +//TEST(observation, test_preproces_initial_time_less_than_timestep) {EXPECT_EQ(0, test_initial_time_less_than_timestep()); } +//TEST(observation, test_preproces_timestep_greater_and_mapvtk ) {EXPECT_EQ(0, test_timestep_greater_and_mapvtk()); } +//TEST(observation, test_preproces_timestep_greater_not_mapvtk ) {EXPECT_EQ(0, test_timestep_greater_not_mapvtk()); } +//TEST(observation, test_preproces_freqstep_zero_or_large ) {EXPECT_EQ(0, test_freqstep_zero_or_large()); } +//TEST(observation, test_preproces_volumic_false_true_and_saveall ) {EXPECT_EQ(0, test_volumic_false_true_and_saveall()); } +//TEST(observation, test_preproces_saveall_branch ) {EXPECT_EQ(0, test_saveall_branch()); } +//TEST(observation, test_preproces_final_less_than_initial ) {EXPECT_EQ(0, test_final_less_than_initial()); } +//TEST(observation, test_preproces_huge_cap ) {EXPECT_EQ(0, test_huge_cap()); } +// +//TEST(observation, test_init_movie_observation ) {EXPECT_EQ(0, test_init_time_movie_observation()); } +// +//TEST(observation, test_update_movie_observation ) {EXPECT_EQ(0, test_update_time_movie_observation()); } +// +// \ No newline at end of file diff --git a/test/observation/test_observation_init.F90 b/test/observation/test_observation_init.F90 index 5d0db0cf..10f31636 100644 --- a/test/observation/test_observation_init.F90 +++ b/test/observation/test_observation_init.F90 @@ -19,7 +19,7 @@ integer function test_init_time_movie_observation() bind(C) result(err) type(output_t), pointer, dimension(:) :: output - sgg = create_base_sgg() + sgg = create_base_sgg(dt=0.1_RKIND_tiempo, time_steps=100) call set_sgg_data(sgg) media = create_media(sgg%Alloc) @@ -35,9 +35,7 @@ integer function test_init_time_movie_observation() bind(C) result(err) SINPML_fullsize = create_limit_t(0,4,0,4,0,4,3,3,3) facesNF2FF = create_facesNF2FF(.false., .false., .false., .false., .false., .false.) - control = create_control_flags(0, 0, 3, 10, "entryRoot", "wireflavour",& - .false., .false., .false., .false., .false.,& - facesNF2FF) + control = create_control_flags(nEntradaRoot="entryRoot", wiresflavor="wiresflavour",facesNF2FF=facesNF2FF) call InitObservation(sgg, media, tag_numbers, & ThereAreObservation, ThereAreWires, ThereAreFarFields,& @@ -74,7 +72,6 @@ integer function test_init_time_movie_observation() bind(C) result(err) err = err + 1 end if - !Extra func contains subroutine set_sgg_data(baseSGG) type(SGGFDTDINFO), intent(inout) :: baseSGG diff --git a/test/observation/test_observation_update.F90 b/test/observation/test_observation_update.F90 index 28aacbf4..fc443f4b 100644 --- a/test/observation/test_observation_update.F90 +++ b/test/observation/test_observation_update.F90 @@ -3,6 +3,7 @@ integer function test_update_time_movie_observation() bind(C) result(err) use FDETYPES_TOOLS use Observa use observation_testingTools + use mod_sggMethods type(SGGFDTDINFO) :: sgg type(media_matrices_t) :: media @@ -21,10 +22,10 @@ integer function test_update_time_movie_observation() bind(C) result(err) type(output_t), pointer, dimension(:) :: output - sgg = create_base_sgg() + call sgg_init(sgg) call set_sgg_data(sgg) - media = create_media(sgg%Alloc) + media = create_geometry_media_from_sggAlloc(sgg%Alloc) tag_numbers = create_tag_list(sgg%Alloc) ThereAreObservation = .false. @@ -37,9 +38,7 @@ integer function test_update_time_movie_observation() bind(C) result(err) SINPML_fullsize = create_limit_t(0,4,0,4,0,4,3,3,3) facesNF2FF = create_facesNF2FF(.false., .false., .false., .false., .false., .false.) - control = create_control_flags(0, 0, 3, 10, "entryRoot", "wireflavour",& - .false., .false., .false., .false., .false.,& - facesNF2FF) + control = create_control_flags(nEntradaRoot="entryRoot", wiresflavor="wireflavour", facesNF2FF=facesNF2FF) call InitObservation(sgg, media, tag_numbers, & ThereAreObservation, ThereAreWires, ThereAreFarFields,& diff --git a/test/observation/test_preprocess.F90 b/test/observation/test_preprocess.F90 index 79467ddb..db4c33cc 100644 --- a/test/observation/test_preprocess.F90 +++ b/test/observation/test_preprocess.F90 @@ -2,6 +2,7 @@ integer function test_initial_time_less_than_timestep() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -24,7 +25,7 @@ integer function test_initial_time_less_than_timestep() bind(C) result(err) finalTimeIndex = 20 dt = 0.1 - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) saveall = .true. @@ -42,6 +43,7 @@ integer function test_timestep_greater_and_mapvtk() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -67,7 +69,7 @@ integer function test_timestep_greater_and_mapvtk() bind(C) result(err) finalTimeIndex = 90 dt = 0.1 - tiempo => create_time_array(100, dt) +call init_time_array(tiempo, 100, dt) saveall = .false. @@ -87,6 +89,7 @@ integer function test_timestep_greater_not_mapvtk() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -128,6 +131,7 @@ integer function test_freqstep_zero_or_large() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -138,7 +142,7 @@ integer function test_freqstep_zero_or_large() bind(C) result(err) finalTimeIndex = 90 dt = 0.1_RKIND_tiempo - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) saveall = .false. ! Case A: FreqStep = 0 -> should be set to FinalFreq-InitialFreq @@ -179,6 +183,7 @@ integer function test_volumic_false_true_and_saveall() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -190,7 +195,7 @@ integer function test_volumic_false_true_and_saveall() bind(C) result(err) finalTimeIndex = 90 dt = 0.1_RKIND - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) saveall = .false. ! Case Volumic = .false. and global saveall = .false. @@ -230,6 +235,7 @@ integer function test_saveall_branch() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -240,7 +246,7 @@ integer function test_saveall_branch() bind(C) result(err) finalTimeIndex = 90 dt = 0.1_RKIND - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) saveall = .false. obs%Volumic = .false. @@ -268,6 +274,7 @@ integer function test_final_less_than_initial() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -278,7 +285,7 @@ integer function test_final_less_than_initial() bind(C) result(err) finalTimeIndex = 90 dt = 0.1_RKIND_tiempo - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) saveall = .false. obs%Volumic = .false. @@ -304,6 +311,7 @@ integer function test_huge_cap() bind(C) result(err) use observation_testingTools use FDETYPES use OBSERVA + use FDETYPES_TOOLS type(Obses_t) :: obs type(output_t) :: out @@ -315,7 +323,7 @@ integer function test_huge_cap() bind(C) result(err) finalTimeIndex = 90 dt = 0.1_RKIND - tiempo => create_time_array(100, dt) + call init_time_array(tiempo, 100, dt) huge4 = huge(1.0_4) saveall = .false. diff --git a/test/output/CMakeLists.txt b/test/output/CMakeLists.txt new file mode 100644 index 00000000..9d27ef09 --- /dev/null +++ b/test/output/CMakeLists.txt @@ -0,0 +1,52 @@ +message(STATUS "Creating build system for test/output") + +add_library( + output_test_fortran + "test_output.F90" + "test_output_utils.F90" + "test_volumic_utils.F90" +) + +add_library(vtkAPI_test_fortran + "test_vtkAPI.F90" +) + +add_library(xdmfAPI_test_fortran + "test_xdmfAPI.F90" +) + +add_library(output_tests "output_tests.cpp") +add_library(vtkAPI_tests "vtkAPI_tests.cpp") +add_library(xdmfAPI_tests "xdmfAPI_tests.cpp") + +target_link_libraries(output_test_fortran + semba-outputs + fdtd-output + test_utils_fortran +) +target_link_libraries(output_tests + output_test_fortran + GTest::gtest +) +target_link_libraries(vtkAPI_test_fortran + vtkAPI + test_utils_fortran +) +target_link_libraries(vtkAPI_tests + vtkAPI_test_fortran + GTest::gtest +) + +target_link_libraries(xdmfAPI_test_fortran + xdmfAPI + test_utils_fortran + ${HDF5_LIBRARIES} ${HDF5_HL_LIBRARIES} +) + +target_link_libraries(xdmfAPI_tests + xdmfAPI_test_fortran + GTest::gtest +) + +target_include_directories(xdmfAPI_test_fortran PRIVATE ${HDF5_INCLUDE_DIRS}) + diff --git a/test/output/output_tests.cpp b/test/output/output_tests.cpp new file mode 100644 index 00000000..0dcc8252 --- /dev/null +++ b/test/output/output_tests.cpp @@ -0,0 +1 @@ +#include "output_tests.h" \ No newline at end of file diff --git a/test/output/output_tests.h b/test/output/output_tests.h new file mode 100644 index 00000000..8fa915cf --- /dev/null +++ b/test/output/output_tests.h @@ -0,0 +1,38 @@ +#ifdef CompileWithNewOutputModule + +#include + +extern "C" int test_init_point_probe(); +extern "C" int test_update_point_probe(); +extern "C" int test_flush_point_probe(); +extern "C" int test_multiple_flush_point_probe(); +extern "C" int test_init_movie_probe(); +extern "C" int test_update_movie_probe(); +extern "C" int test_flush_movie_probe(); +extern "C" int test_init_frequency_slice_probe(); +extern "C" int test_update_frequency_slice_probe(); +extern "C" int test_flush_frequency_slice_probe(); + +extern "C" int test_count_required_coords(); +extern "C" int test_store_required_coords(); +extern "C" int test_is_valid_point_current(); +extern "C" int test_is_valid_point_field(); + + +TEST(output, test_initialize_point_probe) {EXPECT_EQ(0, test_init_point_probe()); } +TEST(output, test_update_point_probe_info) {EXPECT_EQ(0, test_update_point_probe()); } +TEST(output, test_flush_point_probe_info) {EXPECT_EQ(0, test_flush_point_probe()); } +TEST(output, test_flush_multiple_point_probe_info) {EXPECT_EQ(0, test_multiple_flush_point_probe()); } +TEST(output, test_init_movie_probe_for_pec_surface) {EXPECT_EQ(0, test_init_movie_probe()); } +TEST(output, test_update_movie_probe_for_pec_surface) {EXPECT_EQ(0, test_update_movie_probe()); } +TEST(output, test_flush_movie_probe_data) {EXPECT_EQ(0, test_flush_movie_probe()); } +TEST(output, test_init_frequency_slice) {EXPECT_EQ(0, test_init_frequency_slice_probe()); } +TEST(output, test_update_frequency_slice) {EXPECT_EQ(0, test_update_frequency_slice_probe()); } +TEST(output, test_flush_frequency_slice) {EXPECT_EQ(0, test_flush_frequency_slice_probe()); } + +TEST(output, test_volumic_utils_count) { EXPECT_EQ(0, test_count_required_coords()); } +TEST(output, test_volumic_utils_store) { EXPECT_EQ(0, test_store_required_coords()); } +TEST(output, test_volumic_utils_valid_current) { EXPECT_EQ(0, test_is_valid_point_current()); } +TEST(output, test_volumic_utils_valid_field) { EXPECT_EQ(0, test_is_valid_point_field()); } + +#endif \ No newline at end of file diff --git a/test/output/test_output.F90 b/test/output/test_output.F90 new file mode 100644 index 00000000..597459f6 --- /dev/null +++ b/test/output/test_output.F90 @@ -0,0 +1,1230 @@ +integer function test_init_point_probe() bind(c) result(err) +! This test initializes a single point probe at coordinates (4,4,4). +! It verifies that the probe is correctly registered in the simulation outputs, +! that the output ID matches POINT_PROBE_ID, and that the output paths for +! both the probe and its time data file are correctly set and exist. + use FDETYPES + use FDETYPES_TOOLS + use output + use outputTypes + use mod_testOutputUtils + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + ! Parameters + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=18), parameter :: test_name = 'initPointProbeTest' + + ! Local variables + character(len=1) :: sep + character(len=BUFSIZE) :: nEntrada + character(len=BUFSIZE) :: expectedProbePath + character(len=BUFSIZE) :: expectedDataPath + + type(SGGFDTDINFO) :: sgg + type(sim_control_t) :: control + type(bounds_t) :: bounds + type(media_matrices_t) :: media + type(limit_t), allocatable :: sinpml(:) + type(Obses_t) :: probe + type(solver_output_t), pointer :: outputs(:) + type(MediaData_t), allocatable, target :: materials(:) + type(MediaData_t), pointer :: materialsPtr(:) + type(taglist_t) :: tagNumbers + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nSteps = 100_SINGLE + + logical :: outputRequested + logical :: hasWires = .false. + integer(kind=SINGLE) :: test_err = 0 + integer :: ios + + ! Setup + sep = get_path_separator() + nEntrada = test_folder//sep//test_name + + call sgg_init(sgg) + call init_time_array(timeArray, nSteps, dt) + call sgg_set_tiempo(sgg, timeArray) + call sgg_set_dt(sgg, dt) + + call init_simulation_material_list(materials) + materialsPtr => materials + call sgg_set_Med(sgg, materialsPtr) + + probe = create_point_probe_observation(4, 4, 4) + call sgg_add_observation(sgg, probe) + + control = create_control_flags(mpidir=3, nEntradaRoot=trim(nEntrada), wiresflavor='holland') + + ! Action + call init_outputs(sgg, media, sinpml, tagNumbers, bounds, control, outputRequested, hasWires) + outputs => GetOutputs() + + ! Assertions + test_err = test_err + assert_true(outputRequested, 'Valid probes not found') + test_err = test_err + assert_integer_equal(outputs(1)%outputID, POINT_PROBE_ID, 'Unexpected probe id') + + expectedProbePath = trim(nEntrada)//wordSeparation//'pointProbe_Ex_4_4_4' + expectedDataPath = trim(expectedProbePath)//wordSeparation//timeExtension//datFileExtension + + test_err = test_err + assert_string_equal(outputs(1)%pointProbe%path, expectedProbePath, 'Unexpected path') + test_err = test_err + assert_string_equal(outputs(1)%pointProbe%filePathTime, expectedDataPath, 'Unexpected path') + test_err = test_err + assert_true(file_exists(expectedDataPath), 'Time data file do not exist') + + ! Cleanup + call remove_folder(test_folder, ios) + deallocate (sgg%Observation, outputs) + + err = test_err +end function + +integer function test_update_point_probe() bind(c) result(err) +! This test updates the values recorded by a single point probe at (4,4,4) +! over two timesteps. It verifies that the probe correctly stores the time +! steps and associated field values, ensuring proper temporal tracking of +! measured quantities. + use FDETYPES + use FDETYPES_TOOLS + use output + use outputTypes + use mod_testOutputUtils + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + ! Parameters + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=20), parameter :: test_name = 'updatePointProbeTest' + + ! Local variables + character(len=1) :: sep + character(len=BUFSIZE) :: nEntrada + + type(SGGFDTDINFO) :: sgg + type(sim_control_t) :: control + type(bounds_t) :: bounds + type(media_matrices_t) :: media + type(limit_t), allocatable :: sinpml(:) + type(Obses_t) :: probe + type(solver_output_t), pointer :: outputs(:) + type(MediaData_t), allocatable, target :: materials(:) + type(MediaData_t), pointer :: materialsPtr(:) + type(taglist_t) :: tagNumbers + + type(dummyFields_t), target :: dummyFields + type(fields_reference_t) :: fields + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nSteps = 100_SINGLE + + logical :: outputRequested + logical :: hasWires = .false. + integer(kind=SINGLE) :: test_err = 0 + integer :: ios + + ! Setup + sep = get_path_separator() + nEntrada = test_folder//sep//test_name + + call sgg_init(sgg) + call init_time_array(timeArray, nSteps, dt) + call sgg_set_tiempo(sgg, timeArray) + call sgg_set_dt(sgg, dt) + + probe = create_point_probe_observation(4, 4, 4) + call sgg_add_observation(sgg, probe) + + call init_simulation_material_list(materials) + materialsPtr => materials + call sgg_set_Med(sgg, materialsPtr) + + control = create_control_flags(mpidir=3, nEntradaRoot=nEntrada, wiresflavor='holland') + call init_outputs(sgg, media, sinpml, tagNumbers, bounds, control, outputRequested, hasWires) + + call create_dummy_fields(dummyFields, 1, 10, 0.01_RKIND) + + fields%E%x => dummyFields%Ex + fields%E%y => dummyFields%Ey + fields%E%z => dummyFields%Ez + fields%E%deltax => dummyFields%dxe + fields%E%deltaY => dummyFields%dye + fields%E%deltaZ => dummyFields%dze + + fields%H%x => dummyFields%Hx + fields%H%y => dummyFields%Hy + fields%H%z => dummyFields%Hz + fields%H%deltax => dummyFields%dxh + fields%H%deltaY => dummyFields%dyh + fields%H%deltaZ => dummyFields%dzh + + ! Action + dummyFields%Ex(4, 4, 4) = 5.0_RKIND + call update_outputs(control, sgg%tiempo, 1_SINGLE, fields) + outputs => GetOutputs() + + ! Assertions + test_err = test_err + assert_real_equal(outputs(1)%pointProbe%timeStep(1), 0.0_RKIND_tiempo, 1e-5_RKIND_tiempo, 'Unexpected timestep 1') + test_err = test_err + assert_real_equal(outputs(1)%pointProbe%valueForTime(1), 5.0_RKIND, 1e-5_RKIND, 'Unexpected field 1') + + dummyFields%Ex(4, 4, 4) = -4.0_RKIND + call update_outputs(control, sgg%tiempo, 2_SINGLE, fields) + + test_err = test_err + assert_real_equal(outputs(1)%pointProbe%timeStep(2), 0.1_RKIND_tiempo, 1e-5_RKIND_tiempo, 'Unexpected timestep 2') + test_err = test_err + assert_real_equal(outputs(1)%pointProbe%valueForTime(2), -4.0_RKIND, 1e-5_RKIND, 'Unexpected field 2') + + !Cleanup + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_flush_point_probe() bind(c) result(err) +! This test validates the flush operation for a point probe. It ensures +! that time and frequency data are properly written to files, and that +! internal arrays are cleared/reset after flushing, preserving data integrity. + use output + use outputTypes + use mod_pointProbeOutput + use mod_domain + use mod_testOutputUtils + use mod_assertionTools + use mod_directoryUtils + implicit none + + ! Parameters + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=19), parameter :: test_name = 'flushPointProbeTest' + + ! Local variables + character(len=1) :: sep + character(len=BUFSIZE) :: nEntrada + + type(point_probe_output_t) :: probe + type(domain_t) :: domain + type(cell_coordinate_t) :: coordinates + + integer :: n, i + integer :: test_err = 0 + integer :: ios + + ! Setup + sep = get_path_separator() + nEntrada = test_folder//sep//test_name + + domain = domain_t( & + 0.0_RKIND_tiempo, 10.0_RKIND_tiempo, 0.1_RKIND_tiempo, & + 10.0_RKIND, 100.0_RKIND, 10, .false.) + + coordinates%x = 2 + coordinates%y = 2 + coordinates%z = 2 + + call init_point_probe_output(probe, coordinates, iEx, domain, nEntrada, 3, 0.1_RKIND_tiempo) + + ! Action + n = 10 + do i = 1, n + probe%timeStep(i) = real(i) + probe%valueForTime(i) = 10.0*i + probe%frequencySlice(i) = 0.1*i + probe%valueForFreq(i) = 0.2*i + end do + + probe%nTime = n + probe%nFreq = n + + call flush_point_probe_output(probe) + + ! Assertions + test_err = test_err + assert_written_output_file(probe%filePathTime) + test_err = test_err + assert_written_output_file(probe%filePathFreq) + + test_err = test_err + assert_integer_equal(probe%nTime, 0, 'ERROR: clear_time_data did not reset serializedTimeSize!') + + if (.not. all(probe%timeStep == 0.0) .or. .not. all(probe%valueForTime == 0.0)) then + print *, 'ERROR: time arrays not cleared!' + test_err = test_err + 1 + end if + + if (probe%nFreq == 0) then + print *, 'ERROR: Destroyed frequency reference!' + test_err = test_err + 1 + end if + + !Cleanup + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_multiple_flush_point_probe() bind(c) result(err) +! This test verifies that multiple consecutive flushes of a point probe +! correctly append or overwrite data files without losing previous data. +! It ensures consistency of both time and frequency outputs across multiple flushes. + use output + use outputTypes + use mod_pointProbeOutput + use mod_domain + use mod_testOutputUtils + use mod_assertionTools + use mod_directoryUtils + implicit none + + ! Parameters + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=27), parameter :: test_name = 'flushMultiplePointProbeTest' + + ! Local variables + character(len=1) :: sep + character(len=BUFSIZE) :: nEntrada + + type(point_probe_output_t) :: probe + type(domain_t) :: domain + type(cell_coordinate_t) :: coordinates + + real(kind=RKIND), allocatable :: expectedTime(:, :) + real(kind=RKIND), allocatable :: expectedFreq(:, :) + + integer :: n, i, unit + integer :: test_err = 0 + integer :: ios + + ! Setup + sep = get_path_separator() + nEntrada = test_folder//sep//test_name + + domain = domain_t( & + 0.0_RKIND_tiempo, 10.0_RKIND_tiempo, 0.1_RKIND_tiempo, & + 10.0_RKIND, 100.0_RKIND, 10, .false.) + + coordinates%x = 2 + coordinates%y = 2 + coordinates%z = 2 + + call init_point_probe_output(probe, coordinates, iEx, domain, nEntrada, 3, 0.1_RKIND_tiempo) + + n = 10 + allocate (expectedTime(2*n, 2)) + allocate (expectedFreq(n, 2)) + + ! Action - first flush + do i = 1, n + probe%timeStep(i) = real(i) + probe%valueForTime(i) = 10.0*i + probe%frequencySlice(i) = 0.1*i + probe%valueForFreq(i) = 0.2*i + + expectedTime(i, 1) = real(i) + expectedTime(i, 2) = 10.0*i + + expectedFreq(i, 1) = 0.1*i + expectedFreq(i, 2) = 0.2*i + end do + + probe%nTime = n + probe%nFreq = n + call flush_point_probe_output(probe) + + ! Action - second flush + do i = 1, n + probe%timeStep(i) = real(i + 10) + probe%valueForTime(i) = 10.0*(i + 10) + probe%valueForFreq(i) = -0.5*i + + expectedTime(i + n, 1) = real(i + 10) + expectedTime(i + n, 2) = 10.0*(i + 10) + + expectedFreq(i, 1) = 0.1*i + expectedFreq(i, 2) = -0.5*i + end do + + probe%nTime = n + call flush_point_probe_output(probe) + + ! Assertions + open (unit=unit, file=probe%filePathTime, status='old', action='read') + test_err = test_err + assert_file_content(unit, expectedTime, 2*n, 2, 1e-06_RKIND) + close (unit) + + open (unit=unit, file=probe%filePathFreq, status='old', action='read') + test_err = test_err + assert_file_content(unit, expectedFreq, n, 2, 1e-06_RKIND) + close (unit) + + !Cleanup + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_init_movie_probe() bind(c) result(err) +! This test initializes a movie probe over a 3D region from (2,2,2) to (5,5,5). +! It checks that the probe is correctly allocated, that the number of measurement +! points and buffer sizes are correct, and that the output folder and PVD file +! for the movie are properly created. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(taglist_t) :: tagNumbers + + type(limit_t) :: sinpml(6) + + type(Obses_t) :: movieObservable + type(cell_coordinate_t) :: lowerBoundMovieProbe + type(cell_coordinate_t) :: upperBoundMovieProbe + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: mpidir = 3 + logical :: ThereAreWires = .false. + logical :: outputRequested + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=9), parameter :: test_name = 'initMovie' + + character(len=BUFSIZE) :: nEntrada + character(len=1) :: sep + character(len=BUFSIZE) :: expectedProbePath + character(len=BUFSIZE) :: expectedPDVPath + character(len=BUFSIZE) :: pdvFileName + integer :: ios + + sep = get_path_separator() + nEntrada = test_folder//sep//test_name + + err = 1 + + lowerBoundMovieProbe = cell_coordinate_t(2, 2, 2) + upperBoundMovieProbe = cell_coordinate_t(5, 5, 5) + + call sgg_init(dummysgg) + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + movieObservable = create_movie_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, movieObservable) + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + + expectedNumMeasurments = 4_SINGLE + mediaPtr => media + + do iter = 1, 6 + sinpml(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + + outputs => GetOutputs() + + test_err = test_err + assert_integer_equal(outputs(1)%outputID, MOVIE_PROBE_ID, 'Unexpected probe id') + test_err = test_err + assert_integer_equal(outputs(1)%movieProbe%nPoints, expectedNumMeasurments, 'Unexpected number of measurements') + test_err = test_err + assert_integer_equal(size(outputs(1)%movieProbe%xValueForTime), expectedNumMeasurments*BuffObse, 'Unexpected allocation size') + test_err = test_err + assert_integer_equal(size(outputs(1)%movieProbe%timeStep), BuffObse, 'Unexpected timestep buffer size') + + expectedProbePath = trim(nEntrada)//wordSeparation//'movieProbe_BC_2_2_2__5_5_5' + pdvFileName = trim(get_last_component(expectedProbePath))//pvdExtension + expectedPDVPath = join_path(expectedProbePath, pdvFileName) + + test_err = test_err + assert_string_equal(outputs(1)%movieProbe%path, expectedProbePath, 'Unexpected path') + test_err = test_err + assert_true(folder_exists(expectedProbePath), 'Movie folder do not exist') + test_err = test_err + assert_true(file_exists(expectedPDVPath), 'PDV file for movie do not exist') + + !Cleanup + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_update_movie_probe() bind(c) result(err) +! This test updates a movie probe with field values at a single timestep. +! It verifies that the probe correctly stores the measured values in the x, y, +! and z components for all points, and that the timestep buffer is properly populated. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(limit_t), target :: sinpml_fullsize(6) + type(limit_t), pointer :: sinpml_fullsizePtr(:) + + type(taglist_t) :: tagNumbers + + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + + type(Obses_t) :: movieObservable + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + + type(dummyFields_t), target :: dummyFields + type(fields_reference_t) :: fields + + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: mpidir = 3 + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + logical :: ThereAreWires = .false. + logical :: outputRequested + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=11), parameter :: test_name = 'updateMovie' + + character(len=BUFSIZE) :: nEntrada + integer :: ios + + nEntrada = join_path(test_folder, test_name) + + err = 1 + + call sgg_init(dummysgg) + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + movieObservable = create_movie_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, movieObservable) + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + + expectedNumMeasurments = 4_SINGLE + mediaPtr => media + + do iter = 1, 6 + sinpml_fullsize(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + sinpml_fullsizePtr => sinpml_fullsize + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml_fullsize, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + + outputs => GetOutputs() + + call create_dummy_fields(dummyFields, 1, 5, 0.1_RKIND) + + fields%E%x => dummyFields%Ex + fields%E%y => dummyFields%Ey + fields%E%z => dummyFields%Ez + fields%E%deltax => dummyFields%dxe + fields%E%deltaY => dummyFields%dye + fields%E%deltaZ => dummyFields%dze + fields%H%x => dummyFields%Hx + fields%H%y => dummyFields%Hy + fields%H%z => dummyFields%Hz + fields%H%deltax => dummyFields%dxh + fields%H%deltaY => dummyFields%dyh + fields%H%deltaZ => dummyFields%dzh + + dummyFields%Hx(3, 3, 3) = 2.0_RKIND + dummyFields%Hy(3, 3, 3) = 5.0_RKIND + dummyFields%Hz(3, 3, 3) = 4.0_RKIND + + call update_outputs(dummyControl, dummysgg%tiempo, 1_SINGLE, fields) + + test_err = test_err + assert_real_equal(outputs(1)%movieProbe%yValueForTime(1, 1), & + 0.2_RKIND, 1e-5_RKIND, 'Value error') + + test_err = test_err + assert_real_equal(outputs(1)%movieProbe%yValueForTime(1, 2), & + 0.0_RKIND, 1e-5_RKIND, 'Value error') + + test_err = test_err + assert_real_equal(outputs(1)%movieProbe%yValueForTime(1, 3), & + 0.2_RKIND, 1e-5_RKIND, 'Value error') + + test_err = test_err + assert_real_equal(outputs(1)%movieProbe%yValueForTime(1, 4), & + 0.0_RKIND, 1e-5_RKIND, 'Value error') + + test_err = test_err + assert_integer_equal( & + size(outputs(1)%movieProbe%timeStep), BuffObse, 'Unexpected timestep buffer size') + + !Cleanup + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_flush_movie_probe() bind(c) result(err) +! This test validates flushing movie probes to disk. It ensures that +! VTU files for each timestep and the PVD file are created, confirming that +! the temporal sequence of the movie probe is correctly serialized and saved. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(limit_t), target :: sinpml_fullsize(6) + type(limit_t), pointer :: sinpml_fullsizePtr(:) + + type(taglist_t) :: tagNumbers + + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + + type(Obses_t) :: movieCurrentObservable + type(Obses_t) :: movieElectricXObservable + type(Obses_t) :: movieMagneticYObservable + type(fields_reference_t) :: fields + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: mpidir = 3 + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + logical :: ThereAreWires = .false. + logical :: outputRequested + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=10), parameter :: test_name = 'flushMovie' + + character(len=BUFSIZE) :: nEntrada + character(len=BUFSIZE) :: expectedPath + integer :: outputIdx + integer :: ios + + nEntrada = join_path(test_folder, test_name) + + err = 1 + + call sgg_init(dummysgg) + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + movieCurrentObservable = create_movie_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, movieCurrentObservable) + + movieElectricXObservable = create_movie_observation(2, 2, 2, 5, 5, 5, iExC) + call sgg_add_observation(dummysgg, movieElectricXObservable) + + movieMagneticYObservable = create_movie_observation(2, 2, 2, 5, 5, 5, iHyC) + call sgg_add_observation(dummysgg, movieMagneticYObservable) + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + + call assing_material_id_to_media_matrix_coordinate(media, iEx, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iHy, 3, 3, 3, simulationMaterials(0)%Id) + + call assing_material_id_to_media_matrix_coordinate(media, iEx, 3, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iHy, 3, 4, 3, simulationMaterials(0)%Id) + + call assing_material_id_to_media_matrix_coordinate(media, iEx, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iHy, 4, 4, 3, simulationMaterials(0)%Id) + + call assing_material_id_to_media_matrix_coordinate(media, iEx, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iHy, 4, 3, 3, simulationMaterials(0)%Id) + + expectedNumMeasurments = 4_SINGLE + mediaPtr => media + + do iter = 1, 6 + sinpml_fullsize(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + sinpml_fullsizePtr => sinpml_fullsize + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml_fullsize, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + + outputs => GetOutputs() + + !--- Dummy first update --- + !movieCurrentObservable + outputs(1)%movieProbe%nTime = 1 + outputs(1)%movieProbe%timeStep(1) = 0.5_RKIND_tiempo + outputs(1)%movieProbe%xValueForTime(1, :) = [0.1_RKIND, 0.2_RKIND, 0.3_RKIND, 0.4_RKIND] + outputs(1)%movieProbe%yValueForTime(1, :) = [0.3_RKIND, 0.4_RKIND, 0.5_RKIND, 0.6_RKIND] + outputs(1)%movieProbe%zValueForTime(1, :) = [0.7_RKIND, 0.8_RKIND, 0.9_RKIND, 1.0_RKIND] + + !movieElectricXObservable + outputs(2)%movieProbe%nTime = 1 + outputs(2)%movieProbe%timeStep(1) = 0.5_RKIND_tiempo + outputs(2)%movieProbe%xValueForTime(1, :) = [0.1_RKIND, 0.2_RKIND, 0.3_RKIND, 0.4_RKIND] + + !movieMagneticYObservable + outputs(3)%movieProbe%nTime = 1 + outputs(3)%movieProbe%timeStep(1) = 0.5_RKIND_tiempo + outputs(3)%movieProbe%yValueForTime(1, :) = [0.1_RKIND, 0.2_RKIND, 0.3_RKIND, 0.4_RKIND] + + !--- Dummy second update --- + !movieCurrentObservable + outputs(1)%movieProbe%nTime = 2 + outputs(1)%movieProbe%timeStep(2) = 0.75_RKIND_tiempo + outputs(1)%movieProbe%xValueForTime(2, :) = [1.1_RKIND, 1.2_RKIND, 1.3_RKIND, 1.4_RKIND] + outputs(1)%movieProbe%yValueForTime(2, :) = [1.3_RKIND, 1.4_RKIND, 1.5_RKIND, 1.6_RKIND] + outputs(1)%movieProbe%zValueForTime(2, :) = [1.7_RKIND, 1.8_RKIND, 1.9_RKIND, 2.0_RKIND] + + !movieElectricXObservable + outputs(2)%movieProbe%nTime = 2 + outputs(2)%movieProbe%timeStep(2) = 0.75_RKIND_tiempo + outputs(2)%movieProbe%xValueForTime(2, :) = [1.1_RKIND, 1.2_RKIND, 1.3_RKIND, 1.4_RKIND] + + !movieMagneticYObservable + outputs(3)%movieProbe%nTime = 2 + outputs(3)%movieProbe%timeStep(2) = 0.75_RKIND_tiempo + outputs(3)%movieProbe%yValueForTime(2, :) = [1.1_RKIND, 1.2_RKIND, 1.3_RKIND, 1.4_RKIND] + + call flush_outputs(dummysgg%tiempo, 1_SINGLE, dummyControl, fields, dummyBound, .false.) + + call close_outputs() + + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_init_frequency_slice_probe() bind(c) result(err) +! This test initializes a frequency slice probe over a 3D region (2,2,2) to (5,5,5). +! It verifies that the probe is correctly set up, that the expected number of measurement +! points and frequencies are allocated, and that the output folder and PVD file exist. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(taglist_t) :: tagNumbers + + type(limit_t), target :: sinpml_fullsize(6) + type(limit_t), pointer :: sinpml_fullsizePtr(:) + + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + + type(Obses_t) :: frequencySliceObservation + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: expectedTotalFrequnecies + integer(kind=SINGLE) :: mpidir = 3 + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + logical :: ThereAreWires = .false. + logical :: outputRequested + + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=13), parameter :: test_name = 'initFrequency' + + character(len=BUFSIZE) :: nEntrada + character(len=BUFSIZE) :: expectedPDVPath + character(len=BUFSIZE) :: expectedProbePath + character(len=BUFSIZE) :: pdvFileName + integer :: ios + + nEntrada = join_path(test_folder, test_name) + err = 1 + + call sgg_init(dummysgg) + + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + frequencySliceObservation = create_frequency_slice_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, frequencySliceObservation) + + expectedTotalFrequnecies = 6_SINGLE + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + + expectedNumMeasurments = 4_SINGLE + mediaPtr => media + + do iter = 1, 6 + sinpml_fullsize(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + sinpml_fullsizePtr => sinpml_fullsize + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml_fullsize, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + + outputs => GetOutputs() + + test_err = test_err + assert_integer_equal(outputs(1)%outputID, FREQUENCY_SLICE_PROBE_ID, 'Unexpected probe id') + + test_err = test_err + assert_integer_equal(outputs(1)%frequencySliceProbe%nFreq, 6, 'Unexpected number of frequencies') + + test_err = test_err + assert_integer_equal(outputs(1)%frequencySliceProbe%nPoints, expectedNumMeasurments, 'Unexpected number of measurements') + + test_err = test_err + assert_integer_equal( & + size(outputs(1)%frequencySliceProbe%xValueForFreq), & + expectedNumMeasurments*expectedTotalFrequnecies, 'Unexpected allocation size') + + test_err = test_err + assert_integer_equal( & + size(outputs(1)%frequencySliceProbe%frequencySlice), & + expectedTotalFrequnecies, 'Unexpected frequency count') + + expectedProbePath = trim(nEntrada)//wordSeparation//'frequencySliceProbe_BC_2_2_2__5_5_5' + pdvFileName = trim(get_last_component(expectedProbePath))//pvdExtension + expectedPDVPath = join_path(expectedProbePath, pdvFileName) + + test_err = test_err + assert_string_equal(outputs(1)%frequencySliceProbe%path, expectedProbePath, 'Unexpected path') + test_err = test_err + assert_string_equal(outputs(1)%frequencySliceProbe%pvdPath, expectedPDVPath, 'Unexpected pdv path') + test_err = test_err + assert_true(folder_exists(expectedProbePath), 'Frequency Slice folder do not exist') + test_err = test_err + assert_true(file_exists(expectedPDVPath), 'PDV file for Frequency Slice do not exist') + + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_update_frequency_slice_probe() bind(c) result(err) +! This test updates a frequency slice probe with field gradients. +! It checks that no current is detected along the X-axis for H-field gradients +! and verifies the correct relation between Y and Z values (Y = -Z), ensuring +! correct handling of field distributions across the frequency slice. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(limit_t), target :: sinpml_fullsize(6) + type(limit_t), pointer :: sinpml_fullsizePtr(:) + + type(taglist_t) :: tagNumbers + + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + + type(Obses_t) :: frequencySliceObservation + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + + type(dummyFields_t), target :: dummyFields + type(fields_reference_t) :: fields + + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: expectedNumberFrequencies + integer(kind=SINGLE) :: mpidir = 3 + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + logical :: ThereAreWires = .false. + logical :: outputRequested + + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=13), parameter :: test_name = 'initFrequency' + + character(len=BUFSIZE) :: nEntrada + integer :: ios + + nEntrada = join_path(test_folder, test_name) + + err = 1 + + call sgg_init(dummysgg) + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + frequencySliceObservation = create_frequency_slice_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, frequencySliceObservation) + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + expectedNumberFrequencies = 6_SINGLE + expectedNumMeasurments = 4_SINGLE + mediaPtr => media + + do iter = 1, 6 + sinpml_fullsize(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + sinpml_fullsizePtr => sinpml_fullsize + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml_fullsize, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + + outputs => GetOutputs() + + call create_dummy_fields(dummyFields, 1, 5, 0.1_RKIND) + + fields%E%x => dummyFields%Ex + fields%E%y => dummyFields%Ey + fields%E%z => dummyFields%Ez + fields%E%deltax => dummyFields%dxe + fields%E%deltaY => dummyFields%dye + fields%E%deltaZ => dummyFields%dze + fields%H%x => dummyFields%Hx + fields%H%y => dummyFields%Hy + fields%H%z => dummyFields%Hz + fields%H%deltax => dummyFields%dxh + fields%H%deltaY => dummyFields%dyh + fields%H%deltaZ => dummyFields%dzh + + call fillGradient(dummyFields, 1, 0.0_RKIND, 10.0_RKIND) + + call update_outputs(dummyControl, dummysgg%tiempo, 2_SINGLE, fields) + + test_err = test_err + assert_integer_equal(outputs(1)%outputID, & + FREQUENCY_SLICE_PROBE_ID, 'Unexpected probe id') + + test_err = test_err + assert_integer_equal(outputs(1)%frequencySliceProbe%nPoints, & + expectedNumMeasurments, 'Unexpected number of measurements') + + test_err = test_err + assert_integer_equal( & + size(outputs(1)%frequencySliceProbe%frequencySlice), & + expectedNumberFrequencies, 'Unexpected allocation size') + + !This test generates X Gradient for H. It is expected to detect none Current accros X axis and Opposite values for Y and Z + + test_err = test_err + assert_array_value(outputs(1)%frequencySliceProbe%xValueForFreq, (0.0_CKIND , 0.0_CKIND), errormessage='Detected Current on X Axis for Hx gradient') + test_err = test_err + assert_arrays_equal(outputs(1)%frequencySliceProbe%yValueForFreq, & + -1.0_RKIND*outputs(1)%frequencySliceProbe%zValueForFreq, errormessage='Unequal values for Y and -Z') + + + call remove_folder(test_folder, ios) + + err = test_err +end function + +integer function test_flush_frequency_slice_probe() bind(c) result(err) +! This test validates flushing a frequency slice probe to disk. +! It ensures that all data corresponding to measured points and frequencies +! are correctly written to output files and that the PVD file for visualization +! is properly created. + use output + use outputTypes + use mod_testOutputUtils + use FDETYPES_TOOLS + use mod_sggMethods + use mod_assertionTools + use mod_directoryUtils + implicit none + + type(SGGFDTDINFO) :: dummysgg + type(sim_control_t) :: dummyControl + type(bounds_t) :: dummyBound + type(solver_output_t), pointer :: outputs(:) + + type(media_matrices_t), target :: media + type(media_matrices_t), pointer :: mediaPtr + + type(MediaData_t), allocatable, target :: simulationMaterials(:) + type(MediaData_t), pointer :: simulationMaterialsPtr(:) + + type(limit_t), target :: sinpml_fullsize(6) + type(limit_t), pointer :: sinpml_fullsizePtr(:) + + type(taglist_t) :: tagNumbers + + type(XYZlimit_t) :: dummySweep(6) + type(XYZlimit_t) :: dummySinpmlSweep(6) + type(XYZlimit_t) :: allocationRange(6) + + type(Obses_t) :: frequencySliceCurrentObservable + type(Obses_t) :: frequencySliceElectricXObservable + type(Obses_t) :: frequencySliceMagneticHObservable + type(fields_reference_t) :: fields + type(dummyFields_t), target :: dummyFields + + real(kind=RKIND_tiempo), pointer :: timeArray(:) + real(kind=RKIND_tiempo) :: dt = 0.1_RKIND_tiempo + integer(kind=SINGLE) :: nTimeSteps = 100_SINGLE + integer(kind=SINGLE) :: expectedNumMeasurments + integer(kind=SINGLE) :: expectedNumFrequencies + integer(kind=SINGLE) :: mpidir = 3 + integer(kind=SINGLE) :: iter + integer(kind=SINGLE) :: test_err = 0 + logical :: ThereAreWires = .false. + logical :: outputRequested + character(len=BUFSIZE) :: test_folder_path = 'tmp_cases/' + character(len=BUFSIZE) :: expectedPath + character(len=3) :: freqIdName + + + character(len=14), parameter :: test_folder = 'testing_folder' + character(len=13), parameter :: test_name = 'initFrequency' + + character(len=BUFSIZE) :: nEntrada + integer :: ios + integer :: freq + + nEntrada = join_path(test_folder, test_name) + + err = 1 + + !--- Setup SGG --- + call sgg_init(dummysgg) + call init_time_array(timeArray, nTimeSteps, dt) + call sgg_set_tiempo(dummysgg, timeArray) + call sgg_set_dt(dummysgg, dt) + + call init_simulation_material_list(simulationMaterials) + simulationMaterialsPtr => simulationMaterials + call sgg_set_NumMedia(dummysgg, size(simulationMaterials)) + call sgg_set_Med(dummysgg, simulationMaterialsPtr) + + dummySweep = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Sweep(dummysgg, dummySweep) + dummySinpmlSweep = create_xyz_limit_array(1, 1, 1, 5, 5, 5) + call sgg_set_SINPMLSweep(dummysgg, dummySinpmlSweep) + call sgg_set_NumPlaneWaves(dummysgg, 1) + allocationRange = create_xyz_limit_array(0, 0, 0, 6, 6, 6) + call sgg_set_Alloc(dummysgg, allocationRange) + + frequencySliceCurrentObservable = create_frequency_slice_observation(2, 2, 2, 5, 5, 5, iCur) + call sgg_add_observation(dummysgg, frequencySliceCurrentObservable) + + frequencySliceElectricXObservable = create_frequency_slice_observation(2, 2, 2, 5, 5, 5, iExC) + call sgg_add_observation(dummysgg, frequencySliceElectricXObservable) + + frequencySliceMagneticHObservable = create_frequency_slice_observation(2, 2, 2, 5, 5, 5, iHyC) + call sgg_add_observation(dummysgg, frequencySliceMagneticHObservable) + + call create_geometry_media(media, 0, 8, 0, 8, 0, 8) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 3, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 4, 4, 3, simulationMaterials(0)%Id) + call assing_material_id_to_media_matrix_coordinate(media, iEy, 3, 4, 3, simulationMaterials(0)%Id) + + expectedNumFrequencies = 6_SINGLE + expectedNumMeasurments = 4_SINGLE + + mediaPtr => media + + do iter = 1, 6 + sinpml_fullsize(iter) = create_limit_t(0, 8, 0, 8, 0, 8, 10, 10, 10) + end do + sinpml_fullsizePtr => sinpml_fullsize + + dummyControl = create_control_flags(nEntradaRoot=nEntrada, mpidir=mpidir) + + call init_outputs(dummysgg, media, sinpml_fullsize, tagNumbers, dummyBound, dummyControl, & + outputRequested, ThereAreWires) + outputs => GetOutputs() + + !--- Dummy update --- + frequencySliceObservable + do freq = 1, expectedNumFrequencies + outputs(1)%frequencySliceProbe%xvalueForFreq(freq, :) = [(0.1_RKIND, 0.1_RKIND), (0.2_RKIND, 0.2_RKIND), (0.3_RKIND, 0.3_RKIND), (0.4_RKIND, 0.4_RKIND)] + outputs(1)%frequencySliceProbe%yvalueForFreq(freq, :) = [(0.5_RKIND, 0.5_RKIND), (0.6_RKIND, 0.6_RKIND), (0.7_RKIND, 0.7_RKIND), (0.8_RKIND, 0.8_RKIND)] + outputs(1)%frequencySliceProbe%zvalueForFreq(freq, :) = [(0.9_RKIND, 0.9_RKIND), (1.0_RKIND, 1.0_RKIND), (1.1_RKIND, 1.1_RKIND), (1.2_RKIND, 1.2_RKIND)] + end do + frequencySliceXObservable + do freq = 1, expectedNumFrequencies + outputs(2)%frequencySliceProbe%xvalueForFreq(freq, :) = [(0.1_RKIND, 0.1_RKIND), (0.2_RKIND, 0.2_RKIND), (0.3_RKIND, 0.3_RKIND), (0.4_RKIND, 0.4_RKIND)] + end do + frequencySliceYObservable + do freq = 1, expectedNumFrequencies + outputs(3)%frequencySliceProbe%yvalueForFreq(freq, :) = [(0.1_RKIND, 0.1_RKIND), (0.2_RKIND, 0.2_RKIND), (0.3_RKIND, 0.3_RKIND), (0.4_RKIND, 0.4_RKIND)] + end do + + call flush_outputs(dummysgg%tiempo, 1_SINGLE, dummyControl, fields, dummyBound, .false.) + + !--- Assert file existance + do iter = 1, expectedNumFrequencies + write (freqIdName, '(i3)') iter + expectedPath = add_extension(remove_extension(outputs(1)%frequencySliceProbe%pvdPath),'_fq'//'000'//trim(adjustl(freqIdName))//'.vtu') + test_err = test_err + assert_true(file_exists(expectedPath), 'Primera iteracion no encontrada') + end do + + call close_outputs() + + expectedPath = trim(adjustl(outputs(1)%frequencySliceProbe%pvdPath)) + test_err = test_err + assert_true(file_exists(expectedPath), 'PVD file not found') + + call remove_folder(test_folder, ios) + + err = test_err +end function diff --git a/test/output/test_output_utils.F90 b/test/output/test_output_utils.F90 new file mode 100644 index 00000000..75a9d238 --- /dev/null +++ b/test/output/test_output_utils.F90 @@ -0,0 +1,236 @@ +module mod_testOutputUtils + use FDETYPES + use FDETYPES_TOOLS + use outputTypes + implicit none + private + + !=========================== + ! Public interface summary + !=========================== + public :: dummyFields_t + public :: create_point_probe_observation + public :: create_volumic_probe_observation + public :: create_movie_observation + public :: create_frequency_slice_observation + public :: create_dummy_fields + public :: fillGradient + public :: setup_dummy_problem_info + public :: clean_dummy_problem_info + !=========================== + + ! Storage for dummy targets + type(media_matrices_t), target :: dummyGeometry + type(limit_t), allocatable, target :: dummyProblemDim(:) + type(MediaData_t), allocatable, target :: dummyMaterialList(:) + type(bounds_t), target :: dummyBounds + + !=========================== + ! Private interface summary + !=========================== + + !=========================== + + type :: dummyFields_t + real(kind=RKIND), allocatable, dimension(:, :, :) :: Ex, Ey, Ez, Hx, Hy, Hz + real(kind=RKIND), allocatable, dimension(:) :: dxe, dye, dze, dxh, dyh, dzh + contains + procedure, public :: createDummyFields => create_dummy_fields + end type dummyFields_t +contains + function create_point_probe_observation(x, y, z) result(obs) + integer, intent(in) :: x, y, z + type(Obses_t) :: obs + + type(observable_t), dimension(:), allocatable :: P + type(observation_domain_t) :: domain + + allocate (P(1)) + P(1) = create_observable(x, y, z, x, y, z, iEx) + call initialize_observation_time_domain(domain, 0.0_RKIND, 10.0_RKIND, 0.1_RKIND) + + call set_observation(obs, P, 'pointProbe', domain, 'DummyFileNormalize') + end function + + function create_bulk_probe_observation(xi, yi, zi) result(obs) + integer, intent(in) :: xi, yi, zi + type(Obses_t) :: obs + + type(observable_t), dimension(:), allocatable :: P + type(observation_domain_t) :: domain + + allocate (P(1)) + P(1) = create_observable(xi, yi, zi, xi+1, yi+1, zi+1, iCurX) + + call initialize_observation_time_domain(domain, 0.0_RKIND, 10.0_RKIND, 0.1_RKIND) + call initialize_observation_frequency_domain(domain, 0.0_RKIND, 1000.0_RKIND, 50.0_RKIND) + + call set_observation(obs, P, 'bulkProbe', domain, 'DummyFileNormalize') + end function create_bulk_probe_observation + + function create_volumic_probe_observation(xi, yi, zi, xe, ye, ze) result(obs) + integer, intent(in) :: xi, yi, zi, xe, ye, ze + type(Obses_t) :: obs + + type(observable_t), dimension(:), allocatable :: P + type(observation_domain_t) :: domain + + allocate (P(1)) + P(1) = create_observable(xi, yi, zi, xe, ye, ze, iCurX) + + call initialize_observation_time_domain(domain, 0.0_RKIND, 10.0_RKIND, 0.1_RKIND) + call initialize_observation_frequency_domain(domain, 0.0_RKIND, 1000.0_RKIND, 50.0_RKIND) + + call set_observation(obs, P, 'volumicProbe', domain, 'DummyFileNormalize') + end function create_volumic_probe_observation + + function create_movie_observation(xi, yi, zi, xe, ye, ze, request) result(observation) + integer, intent(in) :: xi, yi, zi, xe, ye, ze, request + type(Obses_t) :: observation + + type(observable_t), dimension(:), allocatable :: P + type(observation_domain_t) :: domain + + allocate (P(1)) + P(1) = create_observable(xi, yi, zi, xe, ye, ze, request) + call initialize_observation_time_domain(domain, 0.0_RKIND, 10.0_RKIND, 0.1_RKIND) + + call set_observation(observation, P, 'movieProbe', domain, 'DummyFileNormalize') + end function create_movie_observation + + function create_frequency_slice_observation(xi, yi, zi, xe, ye, ze, request) result(observation) + integer, intent(in) :: xi, yi, zi, xe, ye, ze, request + type(Obses_t) :: observation + + type(observable_t), dimension(:), allocatable :: P + type(observation_domain_t) :: domain + + allocate (P(1)) + P(1) = create_observable(xi, yi, zi, xe, ye, ze, request) + call initialize_observation_frequency_domain(domain, 0.0_RKIND, 100.0_RKIND, 20.0_RKIND) + + call set_observation(observation, P, 'frequencySliceProbe', domain, 'DummyFileNormalize') + end function create_frequency_slice_observation + + subroutine create_dummy_fields(this, lower, upper, delta) + class(dummyFields_t), intent(inout) :: this + integer, intent(in) :: lower, upper + real(kind=rkind), intent(in) :: delta + allocate ( & + this%Ex(lower:upper, lower:upper, lower:upper), & + this%Ey(lower:upper, lower:upper, lower:upper), & + this%Ez(lower:upper, lower:upper, lower:upper), & + this%Hx(lower:upper, lower:upper, lower:upper), & + this%Hy(lower:upper, lower:upper, lower:upper), & + this%Hz(lower:upper, lower:upper, lower:upper) & + ) + + this%Ex = 0.0_RKIND + this%Ey = 0.0_RKIND + this%Ez = 0.0_RKIND + this%Hx = 0.0_RKIND + this%Hy = 0.0_RKIND + this%Hz = 0.0_RKIND + + allocate ( & + this%dxh(lower:upper), & + this%dyh(lower:upper), & + this%dzh(lower:upper), & + this%dxe(lower:upper), & + this%dye(lower:upper), & + this%dze(lower:upper) & + ) + this%dxh = delta + this%dyh = delta + this%dzh = delta + this%dxe = delta + this%dye = delta + this%dze = delta + end subroutine create_dummy_fields + + subroutine fillGradient(dummyFields, direction, minVal, maxVal) + !-------------------------------------------- + ! Fills dummyFields%Hx, Hy, Hz with a linear gradient + ! along the specified direction (1=x, 2=y, 3=z) + !-------------------------------------------- + implicit none + type(dummyFields_t), intent(inout) :: dummyFields + integer, intent(in) :: direction ! 1=x, 2=y, 3=z + real(RKIND), intent(in) :: minVal, maxVal + + integer :: i, j, k + integer :: nx, ny, nz + real(RKIND) :: factor + + ! Get array sizes + nx = size(dummyFields%Hx, 1) + ny = size(dummyFields%Hx, 2) + nz = size(dummyFields%Hx, 3) + + select case (direction) + case (1) ! x-direction + do i = 1, nx + factor = real(i - 1, RKIND)/real(nx - 1, RKIND) + dummyFields%Hx(i, :, :) = minVal + factor*(maxVal - minVal) + dummyFields%Hy(i, :, :) = minVal + factor*(maxVal - minVal) + dummyFields%Hz(i, :, :) = minVal + factor*(maxVal - minVal) + end do + case (2) ! y-direction + do j = 1, ny + factor = real(j - 1, RKIND)/real(ny - 1, RKIND) + dummyFields%Hx(:, j, :) = minVal + factor*(maxVal - minVal) + dummyFields%Hy(:, j, :) = minVal + factor*(maxVal - minVal) + dummyFields%Hz(:, j, :) = minVal + factor*(maxVal - minVal) + end do + case (3) ! z-direction + do k = 1, nz + factor = real(k - 1, RKIND)/real(nz - 1, RKIND) + dummyFields%Hx(:, :, k) = minVal + factor*(maxVal - minVal) + dummyFields%Hy(:, :, k) = minVal + factor*(maxVal - minVal) + dummyFields%Hz(:, :, k) = minVal + factor*(maxVal - minVal) + end do + case default + print *, "Error: direction must be 1, 2, or 3." + end select + + end subroutine fillGradient + + !-------------------------------------------------------------------------------- + ! Setup/Teardown + !-------------------------------------------------------------------------------- + subroutine setup_dummy_problem_info(problemInfo) + type(problem_info_t), intent(out) :: problemInfo + + integer :: i + + ! Create a 11x11x11 grid (0..10) + if (allocated(dummyProblemDim)) deallocate(dummyProblemDim) + allocate(dummyProblemDim(6)) + do i = 1,6 + dummyProblemDim(i) = create_limit_t(0, 10, 0, 10, 0, 10, 1, 1, 1) + end do + problemInfo%problemDimension => dummyProblemDim + + call create_geometry_media(dummyGeometry, 0, 10, 0, 10, 0, 10) + problemInfo%geometryToMaterialData => dummyGeometry + + call init_simulation_material_list(dummyMaterialList) + problemInfo%materialList => dummyMaterialList + + problemInfo%simulationBounds => dummyBounds + + end subroutine setup_dummy_problem_info + + subroutine clean_dummy_problem_info(problemInfo) + type(problem_info_t), intent(inout) :: problemInfo + + if (allocated(dummyProblemDim)) deallocate(dummyProblemDim) + if (allocated(dummyMaterialList)) deallocate(dummyMaterialList) + + nullify(problemInfo%problemDimension) + nullify(problemInfo%geometryToMaterialData) + nullify(problemInfo%materialList) + nullify(problemInfo%simulationBounds) + end subroutine clean_dummy_problem_info + +end module mod_testOutputUtils diff --git a/test/output/test_volumic_utils.F90 b/test/output/test_volumic_utils.F90 new file mode 100644 index 00000000..97962edc --- /dev/null +++ b/test/output/test_volumic_utils.F90 @@ -0,0 +1,138 @@ +!-------------------------------------------------------------------------------- +! Test: count_required_coords +!-------------------------------------------------------------------------------- +integer function test_count_required_coords() bind(c) result(err) + use FDETYPES + use outputTypes + use mod_volumicProbeUtils + use mod_assertionTools + use mod_testOutputUtils + implicit none + + type(cell_coordinate_t) :: lowerBound, upperBound + type(problem_info_t) :: problemInfo + integer(kind=SINGLE) :: count + integer :: test_err = 0 + integer, allocatable :: dummy_coords(:,:) + + ! Setup test case: 3x3x3 domain (1..3) + lowerBound = cell_coordinate_t(1, 1, 1) + upperBound = cell_coordinate_t(3, 3, 3) + + call setup_dummy_problem_info(problemInfo) + + ! Test Case 1: Field Request (iExC) + call find_and_store_important_coords(lowerBound, upperBound, iExC, problemInfo, count, dummy_coords) + + ! Expected: 3*3*3 = 27 points + test_err = test_err + assert_integer_equal(count, 27_SINGLE, "Failed count for iExC") + + if (allocated(dummy_coords)) deallocate(dummy_coords) + call clean_dummy_problem_info(problemInfo) + err = test_err +end function test_count_required_coords + +!-------------------------------------------------------------------------------- +! Test: store_required_coords +!-------------------------------------------------------------------------------- +integer function test_store_required_coords() bind(c) result(err) + use FDETYPES + use outputTypes + use mod_outputUtils + use mod_volumicProbeUtils + use mod_assertionTools + use mod_testOutputUtils + implicit none + + type(cell_coordinate_t) :: lowerBound, upperBound + type(problem_info_t) :: problemInfo + integer(kind=SINGLE) :: nPoints + integer(kind=SINGLE), allocatable :: stored_coords(:,:) + integer :: test_err = 0 + + lowerBound = new_cell_coordinate(1, 1, 1) + upperBound = new_cell_coordinate(2, 2, 2) + call setup_dummy_problem_info(problemInfo) + + call find_and_store_important_coords(lowerBound, upperBound, iHyC, problemInfo, nPoints, stored_coords) + + test_err = test_err + assert_integer_equal(nPoints, 8_SINGLE, "Failed nPoints for iHyC") + + if (allocated(stored_coords)) then + test_err = test_err + assert_integer_equal(int(size(stored_coords, 2), SINGLE), 8_SINGLE, "Allocated coords size error") + ! Verify first coord is (1,1,1) + test_err = test_err + assert_integer_equal(stored_coords(1,1), 1_SINGLE, "First x coord mismatch") + test_err = test_err + assert_integer_equal(stored_coords(2,1), 1_SINGLE, "First y coord mismatch") + test_err = test_err + assert_integer_equal(stored_coords(3,1), 1_SINGLE, "First z coord mismatch") + deallocate(stored_coords) + else + print *, "Coords not allocated." + test_err = test_err + 1 + end if + + call clean_dummy_problem_info(problemInfo) + err = test_err +end function test_store_required_coords + +!-------------------------------------------------------------------------------- +! Test: isValidPointForCurrent +!-------------------------------------------------------------------------------- +integer function test_is_valid_point_current() bind(c) result(err) + use FDETYPES + use outputTypes + use mod_volumicProbeUtils + use mod_testOutputUtils + implicit none + + type(problem_info_t) :: problemInfo + integer :: test_err = 0 + logical :: valid + + call setup_dummy_problem_info(problemInfo) + + ! By default, our dummy setup has NO PEC and NO Wires. + ! So isValidPointForCurrent should be FALSE (as it requires PEC or Wire) + valid = isValidPointForCurrent(iCur, 1, 1, 1, problemInfo) + + if (valid) then + print *, "Expected False for empty space current probe (no PEC/Wire)" + test_err = test_err + 1 + end if + + call clean_dummy_problem_info(problemInfo) + err = test_err +end function test_is_valid_point_current + +!-------------------------------------------------------------------------------- +! Test: isValidPointForField +!-------------------------------------------------------------------------------- +integer function test_is_valid_point_field() bind(c) result(err) + use FDETYPES + use outputTypes + use mod_volumicProbeUtils + use mod_testOutputUtils + implicit none + + type(problem_info_t) :: problemInfo + integer :: test_err = 0 + logical :: valid + + call setup_dummy_problem_info(problemInfo) + + ! Point inside boundary + valid = isValidPointForField(iEx, 5, 5, 5, problemInfo) + if (.not. valid) then + print *, "Expected True for field probe in bounds" + test_err = test_err + 1 + end if + + ! Point outside boundary (-1) + valid = isValidPointForField(iEx, -1, 5, 5, problemInfo) + if (valid) then + print *, "Expected False for field probe out of bounds" + test_err = test_err + 1 + end if + + call clean_dummy_problem_info(problemInfo) + err = test_err +end function test_is_valid_point_field diff --git a/test/output/test_vtkAPI.F90 b/test/output/test_vtkAPI.F90 new file mode 100644 index 00000000..ca9e831d --- /dev/null +++ b/test/output/test_vtkAPI.F90 @@ -0,0 +1,396 @@ +!============================== +! mod_vtkAPI extended testsuite (class-based) +!============================== + +!============================== +! Test 1: Structured grid basic allocation +!============================== +integer function test_vtkAPI_points_allocation() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: points(:, :) + integer :: nx, ny, nz + + error_cnt = 0 + nx = 2; ny = 2; nz = 2 + grid%nx = nx; grid%ny = ny; grid%nz = nz + grid_base => grid + + allocate(points(3, nx*ny*nz)) + points = 0.0 + call grid_base%add_points(points) + + if (.not. allocated(grid%points)) error_cnt = error_cnt + 1 + if (size(grid%points,1) /= 3) error_cnt = error_cnt + 1 + if (size(grid%points,2) /= nx*ny*nz) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 2: Point scalar assignment +!============================== +integer function test_vtkAPI_point_scalar() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: scalars(:) + integer :: nx=2, ny=2, nz=2, i + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + allocate(scalars(nx*ny*nz)) + do i=1,nx*ny*nz + scalars(i) = real(i) + end do + call grid_base%add_scalar('Density', scalars) + + if (.not. allocated(grid%scalars)) error_cnt = error_cnt + 1 + if (grid%scalars(1)%data(1) /= 1.0) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 3: Point vector assignment +!============================== +integer function test_vtkAPI_point_vector() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: vec(:) + integer :: nx=2, ny=2, nz=2, i + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + allocate(vec(3*nx*ny*nz)) + do i=1,nx*ny*nz + vec(3*i-2) = real(i) + vec(3*i-1) = real(i*10) + vec(3*i) = real(i*100) + end do + call grid_base%add_vector('Momentum', vec) + + if (.not. allocated(grid%vectors)) error_cnt = error_cnt + 1 + if (grid%vectors(1)%data(2) /= 10.0) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 4: Cell scalar assignment +!============================== +integer function test_vtkAPI_cell_scalar() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: cell_data(:) + integer :: nx=2, ny=2, nz=2, n + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + allocate(cell_data((nx-1)*(ny-1)*(nz-1))) + do n=1,(nx-1)*(ny-1)*(nz-1) + cell_data(n) = real(n) + end do + call grid_base%add_cell_scalar('Pressure', cell_data) + + if (.not. allocated(grid%cell_scalars)) error_cnt = error_cnt + 1 + if (grid%cell_scalars(1)%data(1) /= 1.0) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 5: Cell vector assignment +!============================== +integer function test_vtkAPI_cell_vector() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: vec(:) + integer :: nx=2, ny=2, nz=2, n + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + allocate(vec(3*(nx-1)*(ny-1)*(nz-1))) + do n=1,(nx-1)*(ny-1)*(nz-1) + vec(3*n-2) = real(n) + vec(3*n-1) = real(n*10) + vec(3*n) = real(n*100) + end do + call grid_base%add_cell_vector('Flux', vec) + + if (.not. allocated(grid%cell_vectors)) error_cnt = error_cnt + 1 + if (grid%cell_vectors(1)%data(3) /= 100.0) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 6: VTS file creation +!============================== +integer function test_vtkAPI_vts_file_creation() bind(C) result(error_cnt) + use mod_vtkAPI + use mod_directoryUtils + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: points(:, :), scalars(:) + integer :: nx=2, ny=2, nz=2 + integer :: ierr + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + allocate(points(3, nx*ny*nz)); points = 0.0 + call grid_base%add_points(points) + + allocate(scalars(nx*ny*nz)); scalars = 1.0 + call grid_base%add_scalar('Density', scalars) + + file = join_path(folder, 'test.vts') + call create_folder(folder, ierr) + call grid_base%write_file(file) + + open(unit=10, file=file, status='old', action='read', iostat=ierr) + if (ierr /= 0) then + error_cnt = error_cnt + 1 + else + close(10) + end if + call remove_folder(folder, ierr) +end function + +!============================== +! Test 7: VTU file creation with cells and point data +!============================== +integer function test_vtkAPI_vtu_file_creation() bind(C) result(error_cnt) + use mod_vtkAPI + use mod_directoryUtils + implicit none + type(vtk_unstructured_grid), target :: ugrid + class(vtk_grid), pointer :: grid_base + real, allocatable :: points(:, :), scalars(:) + integer, allocatable :: conn(:), offsets(:), types(:) + integer :: ierr + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + + error_cnt = 0 + grid_base => ugrid + + ! Points + ugrid%num_points = 4 + allocate(points(3,4)) + points(:,1)=(/0.0,0.0,0.0/) + points(:,2)=(/1.0,0.0,0.0/) + points(:,3)=(/0.0,1.0,0.0/) + points(:,4)=(/0.0,0.0,1.0/) + call grid_base%add_points(points) + + ! Cells + allocate(conn(4)); conn = (/0,1,2,3/) + allocate(offsets(1)); offsets = (/4/) + allocate(types(1)); types = (/10/) + call ugrid%add_cell_connectivity(conn, offsets, types) + + ! Scalars + allocate(scalars(4)); scalars = (/1.0,2.0,3.0,4.0/) + call grid_base%add_scalar('Velocity', scalars) + + file = join_path(folder, 'test.vtu') + call create_folder(folder, ierr) + call grid_base%write_file(file) + + open(unit=10, file=file, status='old', action='read', iostat=ierr) + if (ierr /= 0) then + error_cnt = error_cnt + 1 + else + close(10) + end if + call remove_folder(folder, ierr) +end function + +!============================== +! Test 8: VTU file with cell data +!============================== +integer function test_vtkAPI_vtu_cell_data() bind(C) result(error_cnt) + use mod_vtkAPI + implicit none + type(vtk_unstructured_grid), target :: ugrid + class(vtk_grid), pointer :: grid_base + real, allocatable :: cell_scalars(:), cell_vectors(:) + integer, allocatable :: conn(:), offsets(:), types(:) + + error_cnt = 0 + grid_base => ugrid + + ! Cells + ugrid%num_cells = 1 + allocate(conn(4)); conn = (/0,1,2,3/) + allocate(offsets(1)); offsets = (/4/) + allocate(types(1)); types = (/10/) + call ugrid%add_cell_connectivity(conn, offsets, types) + + ! Cell scalar + allocate(cell_scalars(1)); cell_scalars(1) = 5.0 + call grid_base%add_cell_scalar('Pressure', cell_scalars) + if (ugrid%cell_scalars(1)%data(1) /= 5.0) error_cnt = error_cnt + 1 + + ! Cell vector + allocate(cell_vectors(3*1)); cell_vectors = (/1.0,2.0,3.0/) + call grid_base%add_cell_vector('Flux', cell_vectors) + if (ugrid%cell_vectors(1)%data(3) /= 3.0) error_cnt = error_cnt + 1 +end function + +!============================== +! Test 9: Verificación de VTS contenido +!============================== +integer function test_vtkAPI_vts_content() bind(C) result(error_cnt) + use mod_vtkAPI + use mod_directoryUtils + implicit none + type(vtk_structured_grid), target :: grid + class(vtk_grid), pointer :: grid_base + real, allocatable :: points(:, :), scalars(:), vectors(:) + integer :: nx=2, ny=2, nz=2 + integer :: ierr, i + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + character(len=256) :: line + logical :: found_scalar, found_vector + + error_cnt = 0 + grid%nx=nx; grid%ny=ny; grid%nz=nz + grid_base => grid + + ! Points + allocate(points(3, nx*ny*nz)); points=0.0 + call grid_base%add_points(points) + + ! Scalar + allocate(scalars(nx*ny*nz)) + do i=1,nx*ny*nz + scalars(i) = real(i) + end do + call grid_base%add_scalar('Density', scalars) + + ! Vector + allocate(vectors(3*nx*ny*nz)) + do i=1,nx*ny*nz + vectors(3*i-2) = real(i) + vectors(3*i-1) = real(i*10) + vectors(3*i) = real(i*100) + end do + call grid_base%add_vector('Momentum', vectors) + + ! Create VTS file + file = join_path(folder,'test_content.vts') + call create_folder(folder,ierr) + call grid_base%write_file(file) + + ! Read file and verify PointData + found_scalar = .false.; found_vector = .false. + open(unit=10, file=file, status='old', action='read', iostat=ierr) + if (ierr /= 0) then + error_cnt = error_cnt + 1 + return + end if + + do + read(10,'(A)', iostat=ierr) line + if (ierr /= 0) exit + if (index(line,'Scalars="Density"') /= 0) found_scalar = .true. + if (index(line,'Vectors="Momentum"') /= 0) found_vector = .true. + if (found_scalar .and. found_vector) exit + end do + close(10) + + if (.not. found_scalar) error_cnt = error_cnt + 1 + if (.not. found_vector) error_cnt = error_cnt + 1 + + call remove_folder(folder, ierr) +end function + +!============================== +! Test 10: Verificación de VTU contenido +!============================== +integer function test_vtkAPI_vtu_content() bind(C) result(error_cnt) + use mod_vtkAPI + use mod_directoryUtils + implicit none + type(vtk_unstructured_grid), target :: ugrid + class(vtk_grid), pointer :: grid_base + real, allocatable :: points(:, :), scalars(:), cell_scalars(:) + integer, allocatable :: conn(:), offsets(:), types(:) + integer :: ierr + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + character(len=256) :: line + logical :: found_point_scalar, found_cell_scalar, found_cells, found_points + + error_cnt = 0 + grid_base => ugrid + + ! Points + ugrid%num_points = 4 + allocate(points(3,4)) + points(:,1)=(/0.0,0.0,0.0/); points(:,2)=(/1.0,0.0,0.0/) + points(:,3)=(/0.0,1.0,0.0/); points(:,4)=(/0.0,0.0,1.0/) + call grid_base%add_points(points) + + ! Cells + ugrid%num_cells = 1 + allocate(conn(4)); conn=(/0,1,2,3/) + allocate(offsets(1)); offsets=(/4/) + allocate(types(1)); types=(/10/) + call ugrid%add_cell_connectivity(conn, offsets, types) + + ! Point scalarll + allocate(scalars(4)); scalars=(/1.0,2.0,3.0,4.0/) + call grid_base%add_scalar('Velocity', scalars) + + ! Cell scalar + allocate(cell_scalars(1)); cell_scalars=(/5.0/) + call grid_base%add_cell_scalar('Pressure', cell_scalars) + + ! Create VTU file + file = join_path(folder,'test_content.vtu') + call create_folder(folder,ierr) + call grid_base%write_file(file) + + ! Read file + found_point_scalar = .false.; found_cell_scalar = .false. + found_cells = .false.; found_points = .false. + open(unit=10, file=file, status='old', action='read', iostat=ierr) + if (ierr /= 0) then + error_cnt = error_cnt + 1 + return + end if + + do + read(10,'(A)', iostat=ierr) line + if (ierr /= 0) exit + if (index(line,'PointData') /= 0) found_point_scalar = .true. + if (index(line,'CellData') /= 0) found_cell_scalar = .true. + if (index(line,'') /= 0) found_cells = .true. + if (index(line,'') /= 0) found_points = .true. + if (found_point_scalar .and. found_cell_scalar .and. found_cells .and. found_points) exit + end do + close(10) + + if (.not. found_point_scalar) error_cnt = error_cnt + 1 + if (.not. found_cell_scalar) error_cnt = error_cnt + 1 + if (.not. found_cells) error_cnt = error_cnt + 1 + if (.not. found_points) error_cnt = error_cnt + 1 + + call remove_folder(folder, ierr) +end function \ No newline at end of file diff --git a/test/output/test_xdmfAPI.F90 b/test/output/test_xdmfAPI.F90 new file mode 100644 index 00000000..507b18a9 --- /dev/null +++ b/test/output/test_xdmfAPI.F90 @@ -0,0 +1,289 @@ +integer function test_create_h5_file() bind(c) result(err) + + use HDF5 + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + integer(HID_T) :: file_id + integer :: error + logical :: exists + integer :: test_err = 0 + + call create_folder(folder, error) + file = join_path(folder, "test_api.h5") + + call H5open_f(error) + + call create_h5_file(trim(adjustl(file)), file_id) + + test_err = test_err + assert_true(file_id > 0, "create_h5_file returned invalid id") + + call H5Fclose_f(file_id, error) + + inquire(file=trim(adjustl(file)), exist=exists) + test_err = test_err + assert_true(exists, "HDF5 file was not created") + + call H5close_f(error) + + err = test_err + call remove_folder(folder, error) +end function + +integer function test_write_1d_dataset() bind(c) result(err) + + use HDF5 + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + integer(HID_T) :: file_id + real(8), allocatable :: data(:) + integer :: error + integer :: test_err = 0 + integer :: n, i + + call create_folder(folder, error) + file = join_path(folder, "test_api.h5") + + call H5open_f(error) + + n = 10 + allocate(data(n)) + data = [(real(i,8), i=1,n)] + + call create_h5_file(trim(adjustl(file)), file_id) + + call write_dataset(file_id, "/data1d", data) + + test_err = test_err + assert_integer_equal(size(data), 10, "1D dataset size mismatch") + + call H5Fclose_f(file_id, error) + + deallocate(data) + + call H5close_f(error) + + err = test_err + call remove_folder(folder, error) +end function + +integer function test_write_2d_dataset() bind(c) result(err) + + use HDF5 + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + integer(HID_T) :: file_id + real(8), allocatable :: data(:,:) + integer :: error + integer :: test_err = 0 + + call create_folder(folder, error) + file = join_path(folder, "test_api.h5") + + call H5open_f(error) + + allocate(data(4,5)) + data = 1.0d0 + + call create_h5_file(trim(adjustl(file)), file_id) + + call write_dataset(file_id, "/data2d", data) + + test_err = test_err + assert_integer_equal(size(data,1),4,"2D dim1 mismatch") + test_err = test_err + assert_integer_equal(size(data,2),5,"2D dim2 mismatch") + + call H5Fclose_f(file_id, error) + + deallocate(data) + + call H5close_f(error) + + err = test_err + call remove_folder(folder, error) +end function + +integer function test_write_3d_dataset() bind(c) result(err) + + use HDF5 + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + integer(HID_T) :: file_id + real(8), allocatable :: data(:,:,:) + integer :: error + integer :: test_err = 0 + + call create_folder(folder, error) + file = join_path(folder, "test_api.h5") + + call H5open_f(error) + + allocate(data(3,3,3)) + data = 2.0d0 + + call create_h5_file(trim(adjustl(file)), file_id) + + call write_dataset(file_id, "/data3d", data) + + test_err = test_err + assert_integer_equal(size(data,1),3,"3D dim1 mismatch") + test_err = test_err + assert_integer_equal(size(data,2),3,"3D dim2 mismatch") + test_err = test_err + assert_integer_equal(size(data,3),3,"3D dim3 mismatch") + + call H5Fclose_f(file_id, error) + + deallocate(data) + + call H5close_f(error) + + err = test_err + + call remove_folder(folder, error) +end function + +integer function test_xdmf_file_creation() bind(c) result(err) + + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=14), parameter :: folder='testing_folder' + character(len=1024) :: file + integer :: test_err = 0 + integer :: error, unit + logical :: exists + integer :: dims(3) + + call create_folder(folder, error) + file = join_path(folder, "test_api.xdmf") + + dims = [4,4,4] + + + open(newunit=unit, file=trim(file), position='append') + call xdmf_write_header_file(unit, 'movieProbe') + + call xdmf_create_grid_step_info(unit,"step0",0.0,"data.h5",dims(1)*dims(2)*dims(3)) + + call xdmf_write_attribute(unit,"Efield") + + call xdmf_write_h5_data_item(unit,"data.h5","/Efield","4 4 4") + + call xdmf_close_data_item(unit) + call xdmf_close_attribute(unit) + call xdmf_close_grid(unit) + + call xdmf_write_footer_file(unit) + close(unit) + + + inquire(file=trim(file), exist=exists) + + test_err = test_err + assert_true(exists, "XDMF file not created") + + err = test_err + call remove_folder(folder, error) + +end function + +integer function test_xdmf_file_with_h5data() bind(c) result(err) + use HDF5 + use mod_xdmfAPI + use mod_assertionTools + use mod_directoryUtils + implicit none + + character(len=20), parameter :: folder = "testing_folder" + character(len=1024) :: xdmf_file, h5_file + integer :: test_err = 0 + integer :: error, t, unit + logical :: exists + integer :: dims(3) + integer(HID_T) :: file_id + real(dp), allocatable :: Efield(:,:), coords(:,:) + real(dp) :: time + character(len=20) :: ts + integer :: i,j, npoints + + call create_folder(folder, error) + + xdmf_file = join_path(folder, "test_api.xdmf") + h5_file = join_path(folder, "data.h5") + + call H5open_f(error) + + ! Create HDF5 file + call create_h5_file(trim(h5_file), file_id) + + dims = [3,3,1] ! 2D grid stored as 3D with depth 1 + npoints = dims(1)*dims(2) + + ! Allocate and write coords data: shape (npoints,3) + allocate(coords(npoints,3)) + do j = 1, dims(2) + do i = 1, dims(1) + coords((j-1)*dims(1)+i,1) = real(i-1, dp) ! X + coords((j-1)*dims(1)+i,2) = real(j-1, dp) ! Y + coords((j-1)*dims(1)+i,3) = 0.0_dp ! Z + end do + end do + call write_dataset(file_id,"coords",coords) + deallocate(coords) + + ! Create XDMF file + open(newunit=unit,file=trim(xdmf_file),position='append') + call xdmf_write_header_file(unit) + + do t = 1, 5 + time = real(t-1,dp)*0.1_dp + + allocate(Efield(dims(1),dims(2))) + do j=1,dims(2) + do i=1,dims(1) + Efield(i,j) = i + j + t - 1 + end do + end do + + write(ts,'("Efield_",I0)') t + + ! Write timestep data + call write_dataset(file_id,trim(ts),Efield) + + ! XDMF grid + call xdmf_create_grid_step_info(unit,trim(ts),real(time),trim(h5_file),npoints) + call xdmf_write_attribute(unit,"Efield") + call xdmf_write_h5_data_item(unit,trim(h5_file),"/"//trim(ts),"3 3 1") + call xdmf_close_data_item(unit) + call xdmf_close_attribute(unit) + call xdmf_close_grid(unit) + + deallocate(Efield) + end do + call xdmf_write_footer_file(unit) + close(unit) + call H5Fclose_f(file_id,error) + + inquire(file=trim(xdmf_file),exist=exists) + test_err = test_err + assert_true(exists,"XDMF file not created") + + call remove_folder(folder,error) + call H5close_f(error) + + err = test_err +end function \ No newline at end of file diff --git a/test/output/vtkAPI_tests.cpp b/test/output/vtkAPI_tests.cpp new file mode 100644 index 00000000..01684e2b --- /dev/null +++ b/test/output/vtkAPI_tests.cpp @@ -0,0 +1 @@ +#include "vtkAPI_tests.h" \ No newline at end of file diff --git a/test/output/vtkAPI_tests.h b/test/output/vtkAPI_tests.h new file mode 100644 index 00000000..814c0944 --- /dev/null +++ b/test/output/vtkAPI_tests.h @@ -0,0 +1,27 @@ +#ifdef CompileWithNewOutputModule +#include + +extern "C" int test_vtkapi_points_allocation(); +extern "C" int test_vtkapi_point_scalar(); +extern "C" int test_vtkapi_point_vector(); +extern "C" int test_vtkapi_cell_scalar(); +extern "C" int test_vtkapi_cell_vector(); +extern "C" int test_vtkapi_vts_file_creation(); +extern "C" int test_vtkapi_vtu_file_creation(); +extern "C" int test_vtkapi_vtu_cell_data(); +extern "C" int test_vtkapi_vts_content(); +extern "C" int test_vtkapi_vtu_content(); + +TEST(vtkapi, test_points_allocation) {EXPECT_EQ(0, test_vtkapi_points_allocation());} +TEST(vtkapi, test_point_scalar) {EXPECT_EQ(0, test_vtkapi_point_scalar());} +TEST(vtkapi, test_point_vector) {EXPECT_EQ(0, test_vtkapi_point_vector());} +TEST(vtkapi, test_cell_scalar) {EXPECT_EQ(0, test_vtkapi_cell_scalar());} +TEST(vtkapi, test_cell_vector) {EXPECT_EQ(0, test_vtkapi_cell_vector());} +TEST(vtkapi, test_vts_file_creation) {EXPECT_EQ(0, test_vtkapi_vts_file_creation());} +TEST(vtkapi, test_vtu_file_creation) {EXPECT_EQ(0, test_vtkapi_vtu_file_creation());} +TEST(vtkapi, test_vtu_cell_data) {EXPECT_EQ(0, test_vtkapi_vtu_cell_data());} +TEST(vtkapi, test_vts_content) {EXPECT_EQ(0, test_vtkapi_vts_content());} +TEST(vtkapi, test_vtu_content) {EXPECT_EQ(0, test_vtkapi_vtu_content());} + + +#endif diff --git a/test/output/xdmfAPI_tests.cpp b/test/output/xdmfAPI_tests.cpp new file mode 100644 index 00000000..e0167c57 --- /dev/null +++ b/test/output/xdmfAPI_tests.cpp @@ -0,0 +1 @@ +#include "xdmfAPI_tests.h" \ No newline at end of file diff --git a/test/output/xdmfAPI_tests.h b/test/output/xdmfAPI_tests.h new file mode 100644 index 00000000..6747793f --- /dev/null +++ b/test/output/xdmfAPI_tests.h @@ -0,0 +1,18 @@ +#ifdef CompileWithNewOutputModule +#include + +extern "C" int test_create_h5_file(); +extern "C" int test_write_1d_dataset(); +extern "C" int test_write_2d_dataset(); +extern "C" int test_write_3d_dataset(); +extern "C" int test_xdmf_file_creation(); +extern "C" int test_xdmf_file_with_h5data(); + +TEST(xdmfapi, test_create_h5) { EXPECT_EQ(0, test_create_h5_file()); } +TEST(xdmfapi, test_write_1d) { EXPECT_EQ(0, test_write_1d_dataset()); } +TEST(xdmfapi, test_write_2d) { EXPECT_EQ(0, test_write_2d_dataset()); } +TEST(xdmfapi, test_write_3d) { EXPECT_EQ(0, test_write_3d_dataset()); } +TEST(xdmfapi, test_xdmf_file) { EXPECT_EQ(0, test_xdmf_file_creation()); } +TEST(xdmfapi, test_xdmf_file_with_h5) { EXPECT_EQ(0, test_xdmf_file_with_h5data()); } + +#endif \ No newline at end of file diff --git a/test/pyWrapper/test_script.py b/test/pyWrapper/test_script.py new file mode 100644 index 00000000..e016c369 --- /dev/null +++ b/test/pyWrapper/test_script.py @@ -0,0 +1,142 @@ +from utils import * +from typing import Dict +import os +from sys import platform +from scipy import signal +import sys +from io import StringIO +import time +import matplotlib.pyplot as plt +import numpy as np + +LOG_FILE = os.path.join(os.path.dirname(__file__), 'test_log.txt') + +def printList(listObject: list, listName: str): + print(f'List from {listName}') + for element in listObject: + print(str(element)) + print(f'End of list {listName}') + +def read_xy_file(file_path): + """ + Reads a file with two columns (x and y) and returns as numpy arrays. + Skips the first row assuming it's a header. + """ + data = np.loadtxt(file_path, delimiter=None, skiprows=1) + if data.shape[1] != 2: + raise ValueError(f"File {file_path} does not have two columns after skipping header.") + x, y = data[:, 0], data[:, 1] + return x, y + +def plot_comparison(rls_folder, dbg_folder, output_folder): + """ + Plot comparison between files in Release and Debug folders. + Matches files by name. + """ + rls_files = sorted(os.listdir(rls_folder)) + dbg_files = sorted(os.listdir(dbg_folder)) + skip_labels = ["Outputrequests", "Warnings", "Energy", "Report", "json", "paraviewfilters", ".exc"] + for rls_file, dbg_file in zip(rls_files, dbg_files): + if rls_file != dbg_file: + print(f"Warning: file names do not match: {rls_file} vs {dbg_file}") + continue + + if any(label in rls_file for label in skip_labels): + print(f"Warning: file name to be skipped detected: {rls_file}") + continue + if any(label in dbg_file for label in skip_labels): + print(f"Warning: file name to be skipped detected: {dbg_file}") + continue + rls_path = os.path.join(rls_folder, rls_file) + dbg_path = os.path.join(dbg_folder, dbg_file) + + x_rls, y_rls = read_xy_file(rls_path) + x_dbg, y_dbg = read_xy_file(dbg_path) + + plt.figure(figsize=(8, 5)) + plt.plot(x_rls, y_rls, label='Release', linestyle='-', color='blue', alpha=0.7) + plt.plot(x_dbg, y_dbg, label='Debug', linestyle='--', color='red', alpha=0.7) + plt.title(f"Comparison: {rls_file}") + plt.xlabel('X') + plt.ylabel('Y') + plt.legend() + plt.grid(True) + plt.tight_layout() + + # Save plot + os.makedirs(output_folder, exist_ok=True) + plt.savefig(os.path.join(output_folder, f"{rls_file}_comparison.png")) + plt.close() + +def test_compareOutput(): + # Carpeta raíz para la prueba + base_test_folder = os.path.join(os.path.dirname(__file__), 'test') + rlsFolder = os.path.join(base_test_folder, 'rls') + dbgFolder = os.path.join(base_test_folder, 'dbg') + + # Crear carpetas si no existen + os.makedirs(rlsFolder, exist_ok=True) + os.makedirs(dbgFolder, exist_ok=True) + + # Archive old log if it exists + if os.path.exists(LOG_FILE): + old_log = os.path.join(os.path.dirname(LOG_FILE), 'test_log.old.txt') + import shutil + shutil.copy(LOG_FILE, old_log) + print(f"Archived previous log to {old_log}") + + # Delete current log + if os.path.exists(LOG_FILE): + os.remove(LOG_FILE) + + # Redirect stdout to both console and log + class Tee: + def __init__(self, *files): + self.files = files + def write(self, obj): + for f in self.files: + f.write(obj) + f.flush() + def flush(self): + for f in self.files: + f.flush() + + with open(LOG_FILE, 'w') as log: + sys.stdout = Tee(sys.stdout, log) + + fn = CASES_FOLDER + 'dielectric/dielectricTransmission.fdtd.json' + + # Release version + solverrls = FDTD( + input_filename=fn, + path_to_exe=DEBUG_SEMBA_EXE, + run_in_folder=rlsFolder + ) + startTime = time.time() + solverrls.run() + endTime = time.time() + print(f'Release version time spent {endTime-startTime}') + + # Debug version + solverdbg = FDTD( + input_filename=fn, + path_to_exe=SEMBA_EXE, + run_in_folder=dbgFolder + ) + startTime = time.time() + solverdbg.run() + endTime = time.time() + print(f'Debug version time spent {endTime-startTime}') + + rlsFiles = os.listdir(rlsFolder) + printList(rlsFiles, 'Release') + dbgFiles = os.listdir(dbgFolder) + printList(dbgFiles, 'Debug') + assert len(rlsFiles) == len(dbgFiles), 'Missing files' + + # Plot comparison + plot_output_folder = os.path.join(base_test_folder, 'plots') + plot_comparison(rlsFolder, dbgFolder, plot_output_folder) + print(f"Plots saved in: {plot_output_folder}") + + sys.stdout = sys.__stdout__ # Restore stdout diff --git a/test/pyWrapper/utils.py b/test/pyWrapper/utils.py index 7f1d1857..02d34a8c 100644 --- a/test/pyWrapper/utils.py +++ b/test/pyWrapper/utils.py @@ -35,6 +35,8 @@ # Use of absolute path to avoid conflicts when changing directory. if platform == "linux": SEMBA_EXE = os.path.join(os.getcwd(), 'build', 'bin', 'semba-fdtd') + RELEASE_SEMBA_EXE = os.path.join(os.getcwd(), 'build-rls', 'bin', 'semba-fdtd') + DEBUG_SEMBA_EXE = os.path.join(os.getcwd(), 'build-dbg', 'bin', 'semba-fdtd') elif platform == "win32": SEMBA_EXE = os.path.join(os.getcwd(), 'build', 'bin', 'semba-fdtd.exe') diff --git a/test/utils/CMakeLists.txt b/test/utils/CMakeLists.txt index ad087a19..96e569ad 100644 --- a/test/utils/CMakeLists.txt +++ b/test/utils/CMakeLists.txt @@ -3,8 +3,12 @@ message(STATUS "Creating build system for test/observation") add_library( test_utils_fortran "fdetypes_tools.F90" + "assertion_tools.F90" + "array_assertion_tools.F90" + "sgg_setters.F90" ) target_link_libraries(test_utils_fortran semba-types + fdtd-utils ) diff --git a/test/utils/array_assertion_tools.F90 b/test/utils/array_assertion_tools.F90 new file mode 100644 index 00000000..59092d04 --- /dev/null +++ b/test/utils/array_assertion_tools.F90 @@ -0,0 +1,337 @@ +module mod_arrayAssertionTools + use FDETYPES + implicit none + real(RKIND), parameter :: tol = 1.0e-12_RKIND + private + !----------------------------- + ! Public assertion procedures + !----------------------------- + public :: assert_arrays_equal + public :: assert_array_value + + !--------------------------------------- + ! GENERIC INTERFACES + !--------------------------------------- + interface assert_arrays_equal + module procedure & + assert_arrays_equal_int1, assert_arrays_equal_int2, assert_arrays_equal_int3, & + assert_arrays_equal_real1, assert_arrays_equal_real2, assert_arrays_equal_real3, & + assert_arrays_equal_complex1, assert_arrays_equal_complex2, assert_arrays_equal_complex3 + end interface + + interface assert_array_value + module procedure & + assert_array_value_int1, assert_array_value_int2, assert_array_value_int3, & + assert_array_value_real1, assert_array_value_real2, assert_array_value_real3, & + assert_array_value_complex1, assert_array_value_complex2, assert_array_value_complex3 + end interface + +contains + + !--------------------------------------- + ! 1D Integer arrays + !--------------------------------------- + integer function assert_arrays_equal_int1(A, B, errorMessage) + integer, intent(in) :: A(:), B(:) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_int1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(A == B)) then + assert_arrays_equal_int1 = 0 + else + assert_arrays_equal_int1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_int1(A, val, errorMessage) + integer, intent(in) :: A(:) + integer, intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(A == val)) then + assert_array_value_int1 = 0 + else + assert_array_value_int1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! 2D Integer arrays + !--------------------------------------- + integer function assert_arrays_equal_int2(A, B, errorMessage) + integer, intent(in) :: A(:, :), B(:, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_int2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(A == B)) then + assert_arrays_equal_int2 = 0 + else + assert_arrays_equal_int2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_int2(A, val, errorMessage) + integer, intent(in) :: A(:, :) + integer, intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(A == val)) then + assert_array_value_int2 = 0 + else + assert_array_value_int2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! 3D Integer arrays + !--------------------------------------- + integer function assert_arrays_equal_int3(A, B, errorMessage) + integer, intent(in) :: A(:, :, :), B(:, :, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_int3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(A == B)) then + assert_arrays_equal_int3 = 0 + else + assert_arrays_equal_int3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_int3(A, val, errorMessage) + integer, intent(in) :: A(:, :, :) + integer, intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(A == val)) then + assert_array_value_int3 = 0 + else + assert_array_value_int3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! REAL arrays (1D, 2D, 3D) + !--------------------------------------- + integer function assert_arrays_equal_real1(A, B, errorMessage) + real(RKIND), intent(in) :: A(:), B(:) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_real1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_real1 = 0 + else + assert_arrays_equal_real1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_real1(A, val, errorMessage) + real(RKIND), intent(in) :: A(:) + real(RKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_real1 = 0 + else + assert_array_value_real1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! REAL 2D + !--------------------------------------- + integer function assert_arrays_equal_real2(A, B, errorMessage) + real(RKIND), intent(in) :: A(:, :), B(:, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_real2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_real2 = 0 + else + assert_arrays_equal_real2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_real2(A, val, errorMessage) + real(RKIND), intent(in) :: A(:, :) + real(RKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_real2 = 0 + else + assert_array_value_real2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! REAL 3D + !--------------------------------------- + integer function assert_arrays_equal_real3(A, B, errorMessage) + real(RKIND), intent(in) :: A(:, :, :), B(:, :, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_real3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_real3 = 0 + else + assert_arrays_equal_real3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_real3(A, val, errorMessage) + real(RKIND), intent(in) :: A(:, :, :) + real(RKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_real3 = 0 + else + assert_array_value_real3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! COMPLEX 1D arrays + !--------------------------------------- + integer function assert_arrays_equal_complex1(A, B, errorMessage) + complex(CKIND), intent(in) :: A(:), B(:) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_complex1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_complex1 = 0 + else + assert_arrays_equal_complex1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_complex1(A, val, errorMessage) + complex(CKIND), intent(in) :: A(:) + complex(CKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_complex1 = 0 + else + assert_array_value_complex1 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + +!--------------------------------------- +! COMPLEX 2D arrays +!--------------------------------------- + integer function assert_arrays_equal_complex2(A, B, errorMessage) + complex(CKIND), intent(in) :: A(:, :), B(:, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_complex2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_complex2 = 0 + else + assert_arrays_equal_complex2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_complex2(A, val, errorMessage) + complex(CKIND), intent(in) :: A(:, :) + complex(CKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_complex2 = 0 + else + assert_array_value_complex2 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + +!--------------------------------------- +! COMPLEX 3D arrays +!--------------------------------------- + integer function assert_arrays_equal_complex3(A, B, errorMessage) + complex(CKIND), intent(in) :: A(:, :, :), B(:, :, :) + character(*), intent(in), optional :: errorMessage + + if (any(shape(A) /= shape(B))) then + assert_arrays_equal_complex3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + return + end if + + if (all(abs(A - B) < tol)) then + assert_arrays_equal_complex3 = 0 + else + assert_arrays_equal_complex3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + integer function assert_array_value_complex3(A, val, errorMessage) + complex(CKIND), intent(in) :: A(:, :, :) + complex(CKIND), intent(in) :: val + character(*), intent(in), optional :: errorMessage + + if (all(abs(A - val) < tol)) then + assert_array_value_complex3 = 0 + else + assert_array_value_complex3 = 1 + if (present(errorMessage)) print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + +end module mod_arrayAssertionTools diff --git a/test/utils/assertion_tools.F90 b/test/utils/assertion_tools.F90 new file mode 100644 index 00000000..4a6051e4 --- /dev/null +++ b/test/utils/assertion_tools.F90 @@ -0,0 +1,195 @@ +module mod_assertionTools + use FDETYPES + use mod_arrayAssertionTools + use iso_fortran_env, only: real32, real64 + implicit none + + private :: assert_real_equal_impl + private :: assert_real_RKIND_equal_impl +#ifndef CompileWithReal8 + private :: assert_real_time_equal_impl +#endif + ! Generic interface for real assertions + interface assert_real_equal + module procedure assert_real_equal_impl + module procedure assert_real_RKIND_equal_impl +#ifndef CompileWithReal8 + module procedure assert_real_time_equal_impl +#endif + end interface + +contains + + !--------------------------------------- + ! Logical assertion + !--------------------------------------- + function assert_true(boolean, errorMessage) result(err) + logical, intent(in) :: boolean + character(*), intent(in) :: errorMessage + integer :: err + if (boolean) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED: ', trim(errorMessage) + end if + end function + + !--------------------------------------- + ! Integer equality + !--------------------------------------- + function assert_integer_equal(val, expected, errorMessage) result(err) + integer, intent(in) :: val, expected + character(*), intent(in) :: errorMessage + integer :: err + if (val == expected) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED: ', trim(errorMessage) + print *, " Value: ", val, ". Expected: ", expected + end if + end function + + !--------------------------------------- + ! Real equality implementations + !--------------------------------------- + function assert_real_equal_impl(val, expected, tolerance, errorMessage) result(err) + real(real32), intent(in) :: val, expected, tolerance + character(*), intent(in) :: errorMessage + integer :: err + if (abs(val - expected) <= tolerance) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED (real32): ', trim(errorMessage) + print *, ' Value: ', val, '. Expected: ', expected, '. Tolerance: ', tolerance + end if + end function + + function assert_real_RKIND_equal_impl(val, expected, tolerance, errorMessage) result(err) + real(RKIND), intent(in) :: val, expected, tolerance + character(*), intent(in) :: errorMessage + integer :: err + if (abs(val - expected) <= tolerance) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED (RKIND): ', trim(errorMessage) + print *, ' Value: ', val, '. Expected: ', expected, '. Tolerance: ', tolerance + end if + end function + + function assert_real_time_equal_impl(val, expected, tolerance, errorMessage) result(err) + real(kind=RKIND_tiempo), intent(in) :: val, expected, tolerance + character(*), intent(in) :: errorMessage + integer :: err + if (abs(val - expected) <= tolerance) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED (time): ', trim(errorMessage) + print *, ' Value: ', val, '. Expected: ', expected, '. Tolerance: ', tolerance + end if + end function + + !--------------------------------------- + ! Complex equality + !--------------------------------------- + function assert_complex_equal(val, expected, tolerance, errorMessage) result(err) + complex(kind=CKIND), intent(in) :: val, expected + real(kind=RKIND), intent(in) :: tolerance + character(len=*), intent(in) :: errorMessage + integer :: err + if (abs(val - expected) <= tolerance) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED: ', trim(errorMessage) + print *, ' Value: ', val + print *, ' Expected: ', expected + print *, ' Delta: ', abs(val - expected) + print *, ' Tolerance:', tolerance + end if + end function + + !--------------------------------------- + ! String equality + !--------------------------------------- + function assert_string_equal(val, expected, errorMessage) result(err) + character(*), intent(in) :: val, expected + character(*), intent(in) :: errorMessage + integer :: err + if (trim(val) == trim(expected)) then + err = 0 + else + err = 1 + print *, 'ASSERTION FAILED: ', trim(errorMessage) + print *, ' Value: "', trim(val), '". Expected: "', trim(expected), '"' + end if + end function + + !--------------------------------------- + ! Check if file was written + !--------------------------------------- + integer function assert_written_output_file(filename) result(code) + character(len=*), intent(in) :: filename + logical :: ex + integer :: filesize + code = 0 + inquire (file=filename, exist=ex, size=filesize) + if (.not. ex) then + print *, "ERROR: Output file not created:", trim(filename) + code = 1 + else if (filesize <= 0) then + print *, "ERROR: Output file is empty:", trim(filename) + code = 2 + end if + end function + + !--------------------------------------- + ! Check file content + !--------------------------------------- + integer function assert_file_content(unit, expectedValues, nRows, nCols, tolerance, headers) result(flag) + integer(kind=SINGLE), intent(in) :: unit + real(kind=RKIND), intent(in) :: expectedValues(:, :) + integer(kind=SINGLE), intent(in) :: nRows, nCols + real(kind=RKIND), intent(in) :: tolerance + character(len=*), intent(in), optional :: headers(:) + integer(kind=SINGLE) :: i, j, ios + real(kind=RKIND), dimension(nCols) :: val + character(len=BUFSIZE) :: line + flag = 0 + + if (present(headers)) then + read (unit, '(F12.6,1X,F12.6)', iostat=ios) line + if (ios /= 0) return + end if + + do i = 1, nRows + read (unit, *, iostat=ios) val + if (ios /= 0) then + flag = flag + 1 + return + end if + do j = 1, nCols + if (abs(val(j) - expectedValues(i, j)) > tolerance) then + flag = flag + 1 + end if + end do + end do + end function + + !--------------------------------------- + ! Check file exists + !--------------------------------------- + integer function assert_file_exists(fileName) result(err) + character(len=*), intent(in) :: filename + integer :: unit, ios + err = 0 + open (newunit=unit, file=filename, status='old', iostat=ios) + close (unit) + if (ios /= 0) err = 1 + end function + +end module mod_assertionTools diff --git a/test/utils/fdetypes_tools.F90 b/test/utils/fdetypes_tools.F90 index 01ea7fc9..916f33bf 100644 --- a/test/utils/fdetypes_tools.F90 +++ b/test/utils/fdetypes_tools.F90 @@ -1,63 +1,808 @@ module FDETYPES_TOOLS - use FDETYPES - contains - function create_limit_t(XI,XE,YI,YE,ZI,ZE,NX,NY,NZ) result(r) - type(limit_t) :: r - integer (kind=4), intent(in) :: XI,XE,YI,YE,ZI,ZE,NX,NY,NZ - r%XI = XI - r%XE = XE - r%YI = YI - r%YE = YE - r%ZI = ZI - r%ZE = ZE - r%NX = NX - r%NY = NY - r%NZ = NZ - end function create_limit_t - function create_tag_list(sggAlloc) result(r) - type(XYZlimit_t), dimension(6), intent(in) :: sggAlloc - type(taglist_t) :: r - - - allocate (r%edge%x(sggAlloc(iEx)%XI:sggAlloc(iEx)%XE, sggAlloc(iEx)%YI:sggAlloc(iEx)%YE, sggAlloc(iEx)%ZI:sggAlloc(iEx)%ZE)) - allocate (r%edge%y(sggAlloc(iEy)%XI:sggAlloc(iEy)%XE, sggAlloc(iEy)%YI:sggAlloc(iEy)%YE, sggAlloc(iEy)%ZI:sggAlloc(iEy)%ZE)) - allocate (r%edge%z(sggAlloc(iEz)%XI:sggAlloc(iEz)%XE, sggAlloc(iEz)%YI:sggAlloc(iEz)%YE, sggAlloc(iEz)%ZI:sggAlloc(iEz)%ZE)) - allocate (r%face%x(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHx)%YI:sggAlloc(iHx)%YE, sggAlloc(iHx)%ZI:sggAlloc(iHx)%ZE)) - allocate (r%face%y(sggAlloc(iHy)%XI:sggAlloc(iHy)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHy)%ZI:sggAlloc(iHy)%ZE)) - allocate (r%face%z(sggAlloc(iHz)%XI:sggAlloc(iHz)%XE, sggAlloc(iHz)%YI:sggAlloc(iHz)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) - - - r%edge%x(:,:,:) = 0 - r%edge%y(:,:,:) = 0 - r%edge%z(:,:,:) = 0 - r%face%x(:,:,:) = 0 - r%face%y(:,:,:) = 0 - r%face%z(:,:,:) = 0 - end function create_tag_list - - function create_media(sggAlloc) result(r) - type(XYZlimit_t), dimension(6), intent(in) :: sggAlloc - type(media_matrices_t) :: r - - allocate (r%sggMtag(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) - allocate (r%sggMiNo(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) - - allocate (r%sggMiEx(sggAlloc(iEx)%XI:sggAlloc(iEx)%XE, sggAlloc(iEx)%YI:sggAlloc(iEx)%YE, sggAlloc(iEx)%ZI:sggAlloc(iEx)%ZE)) - allocate (r%sggMiEy(sggAlloc(iEy)%XI:sggAlloc(iEy)%XE, sggAlloc(iEy)%YI:sggAlloc(iEy)%YE, sggAlloc(iEy)%ZI:sggAlloc(iEy)%ZE)) - allocate (r%sggMiEz(sggAlloc(iEz)%XI:sggAlloc(iEz)%XE, sggAlloc(iEz)%YI:sggAlloc(iEz)%YE, sggAlloc(iEz)%ZI:sggAlloc(iEz)%ZE)) - - allocate (r%sggMiHx(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHx)%YI:sggAlloc(iHx)%YE, sggAlloc(iHx)%ZI:sggAlloc(iHx)%ZE)) - allocate (r%sggMiHy(sggAlloc(iHy)%XI:sggAlloc(iHy)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHy)%ZI:sggAlloc(iHy)%ZE)) - allocate (r%sggMiHz(sggAlloc(iHz)%XI:sggAlloc(iHz)%XE, sggAlloc(iHz)%YI:sggAlloc(iHz)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) - - r%sggMtag (:, :, :) = 0 - r%sggMiNo (:, :, :) = 1 - r%sggMiEx (:, :, :) = 1 - r%sggMiEy (:, :, :) = 1 - r%sggMiEz (:, :, :) = 1 - r%sggMiHx (:, :, :) = 1 - r%sggMiHy (:, :, :) = 1 - r%sggMiHz (:, :, :) = 1 - end function create_media - -end module FDETYPES_TOOLS \ No newline at end of file + use FDETYPES + use mod_UTILS + use NFDETypes + implicit none + private + + !=========================== + ! Public interface summary + !=========================== + public :: observation_domain_t + public :: initialize_observation_domain_logical_flags + public :: initialize_observation_time_domain + public :: initialize_observation_frequency_domain + public :: initialize_observation_phi_domain + public :: initialize_observation_theta_domain + public :: create_observable + public :: set_observation + public :: init_time_array + public :: create_limit_t + public :: create_xyzlimit_t + public :: create_xyz_limit_array + public :: create_tag_list + public :: create_geometry_media + public :: create_geometry_media_from_sggAlloc + public :: create_thinWire_simulation_material + public :: init_simulation_material_list + public :: create_facesNF2FF + public :: create_control_flags + public :: add_simulation_material + public :: assing_material_id_to_media_matrix_coordinate + !=========================== + + !=========================== + ! Private interface summary + !=========================== + + !=========================== + + real(kind=rkind) :: UTILEPS0 = 8.8541878176203898505365630317107502606083701665994498081024171524053950954599821142852891607182008932e-12 + real(kind=rkind) :: UTILMU0 = 1.2566370614359172953850573533118011536788677597500423283899778369231265625144835994512139301368468271e-6 + type :: observation_domain_t + real(kind=RKIND) :: InitialTime = 0.0_RKIND + real(kind=RKIND) :: FinalTime = 0.0_RKIND + real(kind=RKIND) :: TimeStep = 0.0_RKIND + + real(kind=RKIND) :: InitialFreq = 0.0_RKIND + real(kind=RKIND) :: FinalFreq = 0.0_RKIND + real(kind=RKIND) :: FreqStep = 0.0_RKIND + + real(kind=RKIND) :: thetaStart = 0.0_RKIND + real(kind=RKIND) :: thetaStop = 0.0_RKIND + real(kind=RKIND) :: thetaStep = 0.0_RKIND + + real(kind=RKIND) :: phiStart = 0.0_RKIND + real(kind=RKIND) :: phiStop = 0.0_RKIND + real(kind=RKIND) :: phiStep = 0.0_RKIND + + logical :: FreqDomain = .FALSE. + logical :: TimeDomain = .FALSE. + logical :: Saveall = .FALSE. + logical :: TransFer = .FALSE. + logical :: Volumic = .FALSE. + end type observation_domain_t + +contains + + function create_xyzlimit_t(XI, XE, YI, YE, ZI, ZE) result(r) + type(limit_t) :: r + integer(kind=4), intent(in) :: XI, XE, YI, YE, ZI, ZE + r%XI = XI + r%XE = XE + r%YI = YI + r%YE = YE + r%ZI = ZI + r%ZE = ZE + end function create_xyzlimit_t + + function create_limit_t(XI, XE, YI, YE, ZI, ZE, NX, NY, NZ) result(r) + type(limit_t) :: r + integer(kind=4), intent(in) :: XI, XE, YI, YE, ZI, ZE, NX, NY, NZ + r%XI = XI + r%XE = XE + r%YI = YI + r%YE = YE + r%ZI = ZI + r%ZE = ZE + r%NX = NX + r%NY = NY + r%NZ = NZ + end function create_limit_t + + function create_tag_list(sggAlloc) result(r) + type(XYZlimit_t), dimension(6), intent(in) :: sggAlloc + type(taglist_t) :: r + + allocate (r%edge%x(sggAlloc(iEx)%XI:sggAlloc(iEx)%XE, sggAlloc(iEx)%YI:sggAlloc(iEx)%YE, sggAlloc(iEx)%ZI:sggAlloc(iEx)%ZE)) + allocate (r%edge%y(sggAlloc(iEy)%XI:sggAlloc(iEy)%XE, sggAlloc(iEy)%YI:sggAlloc(iEy)%YE, sggAlloc(iEy)%ZI:sggAlloc(iEy)%ZE)) + allocate (r%edge%z(sggAlloc(iEz)%XI:sggAlloc(iEz)%XE, sggAlloc(iEz)%YI:sggAlloc(iEz)%YE, sggAlloc(iEz)%ZI:sggAlloc(iEz)%ZE)) + allocate (r%face%x(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHx)%YI:sggAlloc(iHx)%YE, sggAlloc(iHx)%ZI:sggAlloc(iHx)%ZE)) + allocate (r%face%y(sggAlloc(iHy)%XI:sggAlloc(iHy)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHy)%ZI:sggAlloc(iHy)%ZE)) + allocate (r%face%z(sggAlloc(iHz)%XI:sggAlloc(iHz)%XE, sggAlloc(iHz)%YI:sggAlloc(iHz)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) + + r%edge%x(:, :, :) = 0 + r%edge%y(:, :, :) = 0 + r%edge%z(:, :, :) = 0 + r%face%x(:, :, :) = 0 + r%face%y(:, :, :) = 0 + r%face%z(:, :, :) = 0 + end function create_tag_list + + subroutine create_geometry_media(res, xi, xe, yi, ye, zi, ze) + integer(kind=SINGLE), intent(in) :: xi, xe, yi, ye, zi, ze + type(media_matrices_t), intent(inout) :: res + + ! Allocate each array with its own kind + call alloc_and_init(res%sggMtag, xi, xe, yi, ye, zi, ze, 1_IKINDMTAG) + call alloc_and_init(res%sggMiNo, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiEx, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiEy, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiEz, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiHx, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiHy, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + call alloc_and_init(res%sggMiHz, xi, xe, yi, ye, zi, ze, 1_INTEGERSIZEOFMEDIAMATRICES) + end subroutine create_geometry_media + + function create_geometry_media_from_sggAlloc(sggAlloc) result(r) + type(XYZlimit_t), dimension(6), intent(in) :: sggAlloc + type(media_matrices_t) :: r + + allocate (r%sggMtag(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) + allocate (r%sggMiNo(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) + + allocate (r%sggMiEx(sggAlloc(iEx)%XI:sggAlloc(iEx)%XE, sggAlloc(iEx)%YI:sggAlloc(iEx)%YE, sggAlloc(iEx)%ZI:sggAlloc(iEx)%ZE)) + allocate (r%sggMiEy(sggAlloc(iEy)%XI:sggAlloc(iEy)%XE, sggAlloc(iEy)%YI:sggAlloc(iEy)%YE, sggAlloc(iEy)%ZI:sggAlloc(iEy)%ZE)) + allocate (r%sggMiEz(sggAlloc(iEz)%XI:sggAlloc(iEz)%XE, sggAlloc(iEz)%YI:sggAlloc(iEz)%YE, sggAlloc(iEz)%ZI:sggAlloc(iEz)%ZE)) + + allocate (r%sggMiHx(sggAlloc(iHx)%XI:sggAlloc(iHx)%XE, sggAlloc(iHx)%YI:sggAlloc(iHx)%YE, sggAlloc(iHx)%ZI:sggAlloc(iHx)%ZE)) + allocate (r%sggMiHy(sggAlloc(iHy)%XI:sggAlloc(iHy)%XE, sggAlloc(iHy)%YI:sggAlloc(iHy)%YE, sggAlloc(iHy)%ZI:sggAlloc(iHy)%ZE)) + allocate (r%sggMiHz(sggAlloc(iHz)%XI:sggAlloc(iHz)%XE, sggAlloc(iHz)%YI:sggAlloc(iHz)%YE, sggAlloc(iHz)%ZI:sggAlloc(iHz)%ZE)) + + r%sggMtag(:, :, :) = 1 + r%sggMiNo(:, :, :) = 1 + r%sggMiEx(:, :, :) = 1 + r%sggMiEy(:, :, :) = 1 + r%sggMiEz(:, :, :) = 1 + r%sggMiHx(:, :, :) = 1 + r%sggMiHy(:, :, :) = 1 + r%sggMiHz(:, :, :) = 1 + end function create_geometry_media_from_sggAlloc + + function create_control_flags(layoutnumber, size, mpidir, finaltimestep, & + nEntradaRoot, wiresflavor, wirecrank, & + resume, saveall, NF2FFDecim, simu_devia, singlefilewrite, & + facesNF2FF) result(control) + + type(sim_control_t) :: control + + integer(kind=SINGLE), intent(in), optional :: layoutnumber, size, mpidir, finaltimestep + character(len=*), intent(in), optional :: nEntradaRoot, wiresflavor + logical, intent(in), optional :: wirecrank, resume, saveall, NF2FFDecim, simu_devia, singlefilewrite + type(nf2ff_t), intent(in), optional :: facesNF2FF + + ! 1. Set explicit defaults for all components + control%layoutnumber = 0 + control%size = 0 + control%mpidir = 3 + control%finaltimestep = 0 + control%nEntradaRoot = "" + control%wiresflavor = "" + control%wirecrank = .false. + control%resume = .false. + control%saveall = .false. + control%NF2FFDecim = .false. + control%simu_devia = .false. + control%singlefilewrite = .false. + ! Note: control%facesNF2FF retains its default initialized state + + ! 2. Overwrite defaults only if the optional argument is present + if (present(layoutnumber)) control%layoutnumber = layoutnumber + if (present(size)) control%size = size + if (present(mpidir)) control%mpidir = mpidir + if (present(finaltimestep)) control%finaltimestep = finaltimestep + if (present(nEntradaRoot)) control%nEntradaRoot = nEntradaRoot + if (present(wiresflavor)) control%wiresflavor = wiresflavor + if (present(wirecrank)) control%wirecrank = wirecrank + if (present(resume)) control%resume = resume + if (present(saveall)) control%saveall = saveall + if (present(NF2FFDecim)) control%NF2FFDecim = NF2FFDecim + if (present(simu_devia)) control%simu_devia = simu_devia + if (present(singlefilewrite)) control%singlefilewrite = singlefilewrite + if (present(facesNF2FF)) control%facesNF2FF = facesNF2FF + + end function create_control_flags + + subroutine init_simulation_material_list(simulationMaterials) + implicit none + type(MediaData_t), dimension(:), allocatable, intent(out) :: simulationMaterials + if (allocated(simulationMaterials)) deallocate (simulationMaterials) + allocate (simulationMaterials(0:2)) + simulationMaterials(0) = create_pec_simulation_material() + simulationMaterials(1) = get_default_mediadata() + simulationMaterials(2) = create_pmc_simulation_material() + + end subroutine init_simulation_material_list + + subroutine init_time_array(arr, array_size, interval) + integer, intent(in), optional :: array_size + real(kind=RKIND_tiempo), intent(in), optional :: interval + integer(kind=4) :: i + integer :: size_val + real(kind=RKIND_tiempo) :: interval_val + real(kind=RKIND_tiempo), pointer, dimension(:), intent(out) :: arr + + size_val = merge(array_size, 100, present(array_size)) + interval_val = merge(interval, 1.0_RKIND_tiempo, present(interval)) + + allocate (arr(size_val)) + + DO i = 1, size_val + arr(i) = (i - 1)*interval_val + END DO + end subroutine init_time_array + + function create_xyz_limit_array(XI, YI, ZI, XE, YE, ZE) result(arr) + type(XYZlimit_t), dimension(1:6) :: arr + integer(kind=4), intent(in), optional :: XI, YI, ZI, XE, YE, ZE + integer :: i + integer(kind=4) :: xi_val, yi_val, zi_val, xe_val, ye_val, ze_val + + ! Use merge for compact handling of optional inputs with defaults + xi_val = merge(XI, 0, present(XI)) + yi_val = merge(YI, 0, present(YI)) + zi_val = merge(ZI, 0, present(ZI)) + xe_val = merge(XE, 6, present(XE)) + ye_val = merge(YE, 6, present(YE)) + ze_val = merge(ZE, 6, present(ZE)) + + do i = 1, 6 + arr(i)%XI = xi_val + arr(i)%XE = xe_val + arr(i)%YI = yi_val + arr(i)%YE = ye_val + arr(i)%ZI = zi_val + arr(i)%ZE = ze_val + end do + end function create_xyz_limit_array + + function create_facesNF2FF(tr, fr, iz, de, ab, ar) result(faces) + type(nf2ff_t) :: faces + logical, intent(in), optional :: tr, fr, iz, de, ab, ar + + faces%tr = .false. + faces%fr = .false. + faces%iz = .false. + faces%de = .false. + faces%ab = .false. + faces%ar = .false. + + if (present(tr)) faces%tr = tr + if (present(fr)) faces%fr = fr + if (present(iz)) faces%iz = iz + if (present(de)) faces%de = de + if (present(ab)) faces%ab = ab + if (present(ar)) faces%ar = ar + end function create_facesNF2FF + + function define_point_observation() result(obs) + type(Obses_t) :: obs + + obs%nP = 1 + allocate (obs%P(obs%nP)) + obs%P(1) = create_observable(1_SINGLE, 1_SINGLE, 1_SINGLE, 1_SINGLE, 1_SINGLE, 1_SINGLE, iEx) + + obs%InitialTime = 0.0_RKIND_tiempo + obs%FinalTime = 1.0_RKIND_tiempo + obs%TimeStep = 0.1_RKIND_tiempo + + obs%InitialFreq = 0.0_RKIND + obs%FinalFreq = 0.0_RKIND + obs%FreqStep = 0.0_RKIND + + obs%outputrequest = 'pointProbe' + + obs%FreqDomain = .false. + obs%TimeDomain = .true. + obs%Saveall = .false. + obs%TransFer = .false. + obs%Volumic = .false. + obs%Done = .false. + obs%Begun = .false. + obs%Flushed = .false. + + end function define_point_observation + + function define_wire_current_observation() result(obs) + type(Obses_t) :: obs + + obs%nP = 1 + allocate (obs%P(obs%nP)) + obs%P(1) = create_observable(3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, iJx) + + obs%InitialTime = 0.0_RKIND_tiempo + obs%FinalTime = 1.0_RKIND_tiempo + obs%TimeStep = 0.1_RKIND_tiempo + + obs%InitialFreq = 0.0_RKIND + obs%FinalFreq = 0.0_RKIND + obs%FreqStep = 0.0_RKIND + + obs%outputrequest = 'pointProbe' + + obs%FreqDomain = .false. + obs%TimeDomain = .true. + obs%Saveall = .false. + obs%TransFer = .false. + obs%Volumic = .false. + obs%Done = .false. + obs%Begun = .false. + obs%Flushed = .false. + end function define_wire_current_observation + + function define_wire_charge_observation() result(obs) + type(Obses_t) :: obs + + obs%nP = 1 + allocate (obs%P(obs%nP)) + obs%P(1) = create_observable(3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, 3_SINGLE, iQx) + + obs%InitialTime = 0.0_RKIND_tiempo + obs%FinalTime = 1.0_RKIND_tiempo + obs%TimeStep = 0.1_RKIND_tiempo + + obs%InitialFreq = 0.0_RKIND + obs%FinalFreq = 0.0_RKIND + obs%FreqStep = 0.0_RKIND + + obs%outputrequest = 'pointProbe' + + obs%FreqDomain = .false. + obs%TimeDomain = .true. + obs%Saveall = .false. + obs%TransFer = .false. + obs%Volumic = .false. + obs%Done = .false. + obs%Begun = .false. + obs%Flushed = .false. + end function define_wire_charge_observation + + function create_observable(XI, YI, ZI, XE, YE, ZE, what, line_in) result(observable) + type(observable_t) :: observable + integer(kind=4), intent(in) :: XI, YI, ZI, XE, YE, ZE, what + type(direction_t), dimension(:), optional, intent(in) :: line_in + + integer(kind=SINGLE) :: line_size + + observable%XI = XI + observable%YI = YI + observable%ZI = ZI + + observable%XE = XE + observable%YE = YE + observable%ZE = ZE + + observable%Xtrancos = 1 + observable%Ytrancos = 1 + observable%Ztrancos = 1 + + observable%What = what + + if (present(line_in)) then + line_size = size(line_in) + + if (line_size > 0) then + allocate (observable%line(1:line_size)) + + observable%line = line_in + else + + end if + end if + end function create_observable + + subroutine add_simulation_material(simulationMaterials, newSimulationMaterial) + type(MediaData_t), dimension(:), intent(inout), allocatable :: simulationMaterials + type(MediaData_t), intent(in) :: newSimulationMaterial + + type(MediaData_t), dimension(:), target, allocatable :: tempSimulationMaterials + integer(kind=SINGLE) :: oldSize, istat + oldSize = size(simulationMaterials) + allocate (tempSimulationMaterials(0:oldSize), stat=istat) + if (istat /= 0) then + stop "Allocation failed for temporary media array." + end if + + if (oldSize > 0) then + tempSimulationMaterials(0:oldSize - 1) = simulationMaterials + deallocate (simulationMaterials) + end if + tempSimulationMaterials(oldSize) = newSimulationMaterial + + simulationMaterials = tempSimulationMaterials + end subroutine add_simulation_material + + subroutine add_media_data_to_sgg(sgg, mediaData) + implicit none + + type(SGGFDTDINFO), intent(inout) :: sgg + type(MediaData_t), intent(in) :: mediaData + + type(MediaData_t), dimension(:), target, allocatable :: temp_Med + integer :: new_size, istat + + new_size = sgg%NumMedia + 1 + + allocate (temp_Med(new_size), stat=istat) + if (istat /= 0) then + stop "Allocation failed for temporary media array." + end if + + if (sgg%NumMedia > 0) then + temp_Med(1:sgg%NumMedia) = sgg%Med + + deallocate (sgg%Med) + end if + + temp_Med(new_size) = mediaData + + sgg%Med => temp_Med + + sgg%NumMedia = new_size + + end subroutine add_media_data_to_sgg + + subroutine assing_material_id_to_media_matrix_coordinate(media, fieldComponent, i, j, k, materialId) + type(media_matrices_t), intent(inout) :: media + integer(kind=SINGLE), intent(in) :: fieldComponent, i, j, k, materialId + selectcase (fieldComponent) + case (iEx); media%sggMiEx(i, j, k) = materialId + case (iEy); media%sggMiEy(i, j, k) = materialId + case (iEz); media%sggMiEz(i, j, k) = materialId + case (iHx); media%sggMiHx(i, j, k) = materialId + case (iHy); media%sggMiHy(i, j, k) = materialId + case (iHz); media%sggMiHz(i, j, k) = materialId + end select + + end subroutine assing_material_id_to_media_matrix_coordinate + + function get_default_mediadata() result(res) + implicit none + + type(MediaData_t) :: res + !Vacuum id + res%Id = 0 + + ! Reals + res%Priority = 10 + res%Epr = 1.0_RKIND + res%Sigma = 0.0_RKIND + res%Mur = 1.0_RKIND + res%SigmaM = 0.0_RKIND + + ! Logical + res%sigmareasignado = .false. + + ! exists_t logicals + res%Is%PML = .false. + res%Is%PEC = .false. + res%Is%PMC = .false. + res%Is%ThinWire = .false. + res%Is%SlantedWire = .false. + res%Is%EDispersive = .false. + res%Is%MDispersive = .false. + res%Is%EDispersiveAnis = .false. + res%Is%MDispersiveAnis = .false. + res%Is%ThinSlot = .false. + res%Is%PMLbody = .false. + res%Is%SGBC = .false. + res%Is%SGBCDispersive = .false. + res%Is%Lumped = .false. + res%Is%Lossy = .false. + res%Is%AnisMultiport = .false. + res%Is%Multiport = .false. + res%Is%MultiportPadding = .false. + res%Is%Dielectric = .false. + res%Is%Anisotropic = .false. + res%Is%Volume = .false. + res%Is%Line = .false. + res%Is%Surface = .false. + res%Is%Needed = .true. + res%Is%Interfase = .false. + res%Is%already_YEEadvanced_byconformal = .false. + res%Is%split_and_useless = .false. + + ! Pointers: They are automatically unassociated (nullified) + ! when a function returns a type with pointer components, + ! unless explicitly associated before return. + ! For safety, we can explicitly nullify them, although Fortran often handles this. + nullify (res%Wire) + nullify (res%SlantedWire) + nullify (res%PMLbody) + nullify (res%Multiport) + nullify (res%AnisMultiport) + nullify (res%EDispersive) + nullify (res%MDispersive) + nullify (res%Anisotropic) + nullify (res%Lumped) + + end function get_default_mediadata + + function create_pec_simulation_material() result(res) + implicit none + + type(MediaData_t) :: res + type(Material) :: mat + + mat = create_pec_material() + res = get_default_mediadata() + res%Id = mat%id + res%Is%PEC = .TRUE. + + res%Priority = 150 + res%Epr = mat%eps/UTILEPS0 + res%Sigma = mat%sigma + res%Mur = mat%mu/UTILMU0 + res%SigmaM = mat%sigmam + + end function create_pec_simulation_material + + function create_pmc_simulation_material() result(res) + implicit none + + type(MediaData_t) :: res + type(Material) :: mat + + mat = create_pmc_material() + res = get_default_mediadata() + + res%Id = mat%id + res%Is%PMC = .TRUE. + + res%Priority = 160 + res%Epr = mat%eps/UTILEPS0 + res%Sigma = mat%sigma + res%Mur = mat%mu/UTILMU0 + res%SigmaM = mat%sigmam + + end function create_pmc_simulation_material + + function create_thinWire_simulation_material(materialId) result(res) + implicit none + integer(kind=SINGLE) :: materialId + + type(MediaData_t) :: res + type(Material) :: mat + + type(Wires_t), target, dimension(1) :: wire + + res = get_default_mediadata() + res%Id = materialId + res%Is%ThinWire = .TRUE. + + allocate (res%Wire(1)) + wire(1) = get_default_wire() + res%wire => wire + + res%Priority = 15 + + end function create_thinWire_simulation_material + + function create_empty_material() result(mat) + implicit none + type(Material) :: mat + end function create_empty_material + + function create_material(eps_in, mu_in, sigma_in, sigmam_in, id_in) result(mat) + implicit none + real(kind=RK), intent(in) :: eps_in, mu_in, sigma_in, sigmam_in + integer(kind=4), intent(in) :: id_in + type(Material) :: mat + + mat%eps = eps_in + mat%mu = mu_in + mat%sigma = sigma_in + mat%sigmam = sigmam_in + mat%id = id_in + end function create_material + + function create_vacuum_material() result(mat) + type(Material) :: mat + mat = create_material(EPSILON_VACUUM, MU_VACUUM, 0.0_RKIND, 0.0_RKIND, 1) + end function create_vacuum_material + + function create_pec_material() result(mat) + type(Material) :: mat + mat = create_material(EPSILON_VACUUM, MU_VACUUM, SIGMA_PEC, 0.0_RKIND, 0) + end function create_pec_material + + function create_pmc_material() result(mat) + type(Material) :: mat + mat = create_material(EPSILON_VACUUM, MU_VACUUM, 0.0_RKIND, SIGMA_PMC, 2) + end function create_pmc_material + + function create_empty_materials() result(mats) + implicit none + type(Materials) :: mats + end function create_empty_materials + + subroutine add_material_to_materials(mats_collection, new_mat) + implicit none + type(Materials), intent(inout) :: mats_collection + type(Material), intent(in) :: new_mat + + type(Material), dimension(:), target, allocatable :: temp_Mats + integer :: old_size, new_size + + old_size = mats_collection%n_Mats + new_size = old_size + 1 + + allocate (temp_Mats(new_size)) + + if (old_size > 0) then + temp_Mats(1:old_size) = mats_collection%Mats + + deallocate (mats_collection%Mats) + end if + + temp_Mats(new_size) = new_mat + + mats_collection%Mats => temp_Mats + + mats_collection%n_Mats = new_size + mats_collection%n_Mats_max = new_size + + end subroutine add_material_to_materials + + function get_default_wire() result(wire) + implicit none + type(Wires_t) :: wire + + wire%Radius = 0.0_RKIND_wires + wire%R = 0.0_RKIND_wires + wire%L = 0.0_RKIND_wires + wire%C = 0.0_RKIND_wires + wire%P_R = 0.0_RKIND_wires + wire%P_L = 0.0_RKIND_wires + wire%P_C = 0.0_RKIND_wires + wire%Radius_devia = 0.0_RKIND_wires + wire%R_devia = 0.0_RKIND_wires + wire%L_devia = 0.0_RKIND_wires + wire%C_devia = 0.0_RKIND_wires + + wire%numsegmentos = 0 + wire%NUMVOLTAGESOURCES = 0 + wire%NUMCURRENTSOURCES = 0 + + nullify (wire%segm) + nullify (wire%Vsource) + nullify (wire%Isource) + + wire%VsourceExists = .false. + wire%IsourceExists = .false. + wire%HasParallel_LeftEnd = .false. + wire%HasParallel_RightEnd = .false. + wire%HasSeries_LeftEnd = .false. + wire%HasSeries_RightEnd = .false. + wire%HasAbsorbing_LeftEnd = .false. + wire%HasAbsorbing_RightEnd = .false. + + wire%Parallel_R_RightEnd = 0.0_RKIND_wires + wire%Parallel_R_LeftEnd = 0.0_RKIND_wires + wire%Series_R_RightEnd = 0.0_RKIND_wires + wire%Series_R_LeftEnd = 0.0_RKIND_wires + wire%Parallel_L_RightEnd = 0.0_RKIND_wires + wire%Parallel_L_LeftEnd = 0.0_RKIND_wires + wire%Series_L_RightEnd = 0.0_RKIND_wires + wire%Series_L_LeftEnd = 0.0_RKIND_wires + wire%Parallel_C_RightEnd = 0.0_RKIND_wires + wire%Parallel_C_LeftEnd = 0.0_RKIND_wires + wire%Series_C_RightEnd = 2.0e7_RKIND ! Valor por defecto de corto + wire%Series_C_LeftEnd = 2.0e7_RKIND ! Valor por defecto de corto + + wire%Parallel_R_RightEnd_devia = 0.0_RKIND_wires + wire%Parallel_R_LeftEnd_devia = 0.0_RKIND_wires + wire%Series_R_RightEnd_devia = 0.0_RKIND_wires + wire%Series_R_LeftEnd_devia = 0.0_RKIND_wires + wire%Parallel_L_RightEnd_devia = 0.0_RKIND_wires + wire%Parallel_L_LeftEnd_devia = 0.0_RKIND_wires + wire%Series_L_RightEnd_devia = 0.0_RKIND_wires + wire%Series_L_LeftEnd_devia = 0.0_RKIND_wires + wire%Parallel_C_RightEnd_devia = 0.0_RKIND_wires + wire%Parallel_C_LeftEnd_devia = 0.0_RKIND_wires + wire%Series_C_RightEnd_devia = 0.0_RKIND_wires + wire%Series_C_LeftEnd_devia = 0.0_RKIND_wires + + wire%LeftEnd = 0 + wire%RightEnd = 0 + end function get_default_wire + + subroutine set_observation(obs, P_in, outputrequest_in, domain_params, FileNormalize_in) + implicit none + + type(observable_t), dimension(:), intent(in) :: P_in + character(LEN=*), intent(in) :: outputrequest_in, FileNormalize_in + type(observation_domain_t), intent(in) :: domain_params + + type(Obses_t), intent(out) :: obs + integer(kind=4) :: n_count + + n_count = size(P_in) + obs%nP = n_count + + allocate (obs%P(1:n_count)) + + obs%P(1:n_count) = P_in(1:n_count) + + obs%outputrequest = outputrequest_in + obs%FileNormalize = FileNormalize_in + + obs%InitialTime = domain_params%InitialTime + obs%FinalTime = domain_params%FinalTime + obs%TimeStep = domain_params%TimeStep + + obs%InitialFreq = domain_params%InitialFreq + obs%FinalFreq = domain_params%FinalFreq + obs%FreqStep = domain_params%FreqStep + + obs%thetaStart = domain_params%thetaStart + obs%thetaStop = domain_params%thetaStop + obs%thetaStep = domain_params%thetaStep + + obs%phiStart = domain_params%phiStart + obs%phiStop = domain_params%phiStop + obs%phiStep = domain_params%phiStep + + obs%FreqDomain = domain_params%FreqDomain + obs%TimeDomain = domain_params%TimeDomain + obs%Saveall = domain_params%Saveall + obs%TransFer = domain_params%TransFer + obs%Volumic = domain_params%Volumic + + end subroutine set_observation + + subroutine initialize_observation_time_domain(domain, InitialTime, FinalTime, TimeStep) + implicit none + + type(observation_domain_t), intent(inout) :: domain + real(kind=RKIND), intent(in) :: InitialTime, FinalTime, TimeStep + + domain%InitialTime = InitialTime + domain%FinalTime = FinalTime + domain%TimeStep = TimeStep + + domain%TimeDomain = .true. + + end subroutine initialize_observation_time_domain + + subroutine initialize_observation_frequency_domain(domain, InitialFreq, FinalFreq, FreqStep) + implicit none + + type(observation_domain_t), intent(inout) :: domain + real(kind=RKIND), intent(in) :: InitialFreq, FinalFreq, FreqStep + + domain%InitialFreq = InitialFreq + domain%FinalFreq = FinalFreq + domain%FreqStep = FreqStep + + domain%FreqDomain = .true. + + end subroutine initialize_observation_frequency_domain + + subroutine initialize_observation_theta_domain(domain, thetaStart, thetaStop, thetaStep) + implicit none + + type(observation_domain_t), intent(inout) :: domain + real(kind=RKIND), intent(in) :: thetaStart, thetaStop, thetaStep + + domain%thetaStart = thetaStart + domain%thetaStop = thetaStop + domain%thetaStep = thetaStep + + end subroutine initialize_observation_theta_domain + + subroutine initialize_observation_phi_domain(domain, phiStart, phiStop, phiStep) + implicit none + + type(observation_domain_t), intent(inout) :: domain + real(kind=RKIND), intent(in) :: phiStart, phiStop, phiStep + + domain%phiStart = phiStart + domain%phiStop = phiStop + domain%phiStep = phiStep + + end subroutine initialize_observation_phi_domain + + subroutine initialize_observation_domain_logical_flags(domain, Saveall_flag, TransFer_flag, Volumic_flag) + implicit none + + type(observation_domain_t), intent(inout) :: domain + logical, intent(in) :: Saveall_flag, TransFer_flag, Volumic_flag + + domain%Saveall = Saveall_flag + domain%TransFer = TransFer_flag + domain%Volumic = Volumic_flag + + end subroutine initialize_observation_domain_logical_flags + +end module FDETYPES_TOOLS diff --git a/test/utils/sgg_setters.F90 b/test/utils/sgg_setters.F90 new file mode 100644 index 00000000..8e424884 --- /dev/null +++ b/test/utils/sgg_setters.F90 @@ -0,0 +1,416 @@ +module mod_sggMethods + use FDETYPES + implicit none + private + + + public :: sgg_init + + public :: sgg_set_tiempo + public :: sgg_set_dt + public :: sgg_set_extraswitches + + public :: sgg_set_NumMedia + public :: sgg_set_AllocMed + public :: sgg_set_IniPMLMedia + public :: sgg_set_EndPMLMedia + + public :: sgg_set_NumPlaneWaves + public :: sgg_set_TimeSteps + public :: sgg_set_InitialTimeStep + + public :: sgg_set_NumNodalSources + public :: sgg_set_NumberRequest + + public :: sgg_set_LineX + public :: sgg_set_LineY + public :: sgg_set_LineZ + public :: sgg_set_DX + public :: sgg_set_DY + public :: sgg_set_DZ + + public :: sgg_set_AllocDxI + public :: sgg_set_AllocDyI + public :: sgg_set_AllocDzI + public :: sgg_set_AllocDxE + public :: sgg_set_AllocDyE + public :: sgg_set_AllocDzE + + public :: sgg_set_PlaneWave + public :: sgg_set_Border + public :: sgg_set_PML + public :: sgg_set_Eshared + public :: sgg_set_Hshared + + public :: sgg_set_Alloc + public :: sgg_set_Sweep + public :: sgg_set_SINPMLSweep + + public :: sgg_set_Med + public :: sgg_set_NodalSource + public :: sgg_set_Observation + + public :: sgg_set_thereAreMagneticMedia + public :: sgg_set_thereArePMLMagneticMedia + + public :: sgg_set_nEntradaRoot + public :: sgg_set_Punto + + public :: sgg_add_observation +contains + subroutine sgg_init(obj, & + tiempo, dt, extraswitches, & + NumMedia, AllocMed, & + IniPMLMedia, EndPMLMedia, & + NumPlaneWaves, TimeSteps, InitialTimeStep, & + NumNodalSources, NumberRequest, & + thereAreMagneticMedia, thereArePMLMagneticMedia, & + nEntradaRoot) + + implicit none + + type(SGGFDTDINFO), intent(inout) :: obj + + ! ===== Optional arguments ===== + real(kind=RKIND_tiempo), pointer, optional :: tiempo(:) + real(kind=RKIND_tiempo), optional :: dt + character(len=*), optional :: extraswitches + + integer(kind=SINGLE), optional :: NumMedia, AllocMed + integer(kind=SINGLE), optional :: IniPMLMedia, EndPMLMedia + integer(kind=SINGLE), optional :: NumPlaneWaves, TimeSteps, InitialTimeStep + integer(kind=SINGLE), optional :: NumNodalSources, NumberRequest + + logical, optional :: thereAreMagneticMedia + logical, optional :: thereArePMLMagneticMedia + + character(len=*), optional :: nEntradaRoot + + ! ===== Defaults ===== + + nullify (obj%tiempo) + obj%dt = 0.0_RKIND_tiempo + obj%extraswitches = "" + + obj%NumMedia = 0_SINGLE + obj%AllocMed = 0_SINGLE + obj%IniPMLMedia = 0_SINGLE + obj%EndPMLMedia = 0_SINGLE + obj%NumPlaneWaves = 0_SINGLE + obj%TimeSteps = 0_SINGLE + obj%InitialTimeStep = 0_SINGLE + obj%NumNodalSources = 0_SINGLE + obj%NumberRequest = 0_SINGLE + + nullify (obj%LineX, obj%LineY, obj%LineZ) + nullify (obj%DX, obj%DY, obj%DZ) + + obj%AllocDxI = 0_SINGLE + obj%AllocDyI = 0_SINGLE + obj%AllocDzI = 0_SINGLE + obj%AllocDxE = 0_SINGLE + obj%AllocDyE = 0_SINGLE + obj%AllocDzE = 0_SINGLE + + nullify (obj%PlaneWave) + nullify (obj%Med) + nullify (obj%NodalSource) + nullify (obj%Observation) + + obj%thereAreMagneticMedia = .false. + obj%thereArePMLMagneticMedia = .false. + + obj%nEntradaRoot = "" + + ! NOTE: + ! Derived-type components (Border, PML, Shared_t, XYZlimit_t, Punto) + ! are automatically default-initialized if they define their own defaults. + + ! ===== Overrides from arguments ===== + + if (present(tiempo)) obj%tiempo => tiempo + if (present(dt)) obj%dt = dt + if (present(extraswitches)) obj%extraswitches = extraswitches + + if (present(NumMedia)) obj%NumMedia = NumMedia + if (present(AllocMed)) obj%AllocMed = AllocMed + if (present(IniPMLMedia)) obj%IniPMLMedia = IniPMLMedia + if (present(EndPMLMedia)) obj%EndPMLMedia = EndPMLMedia + if (present(NumPlaneWaves)) obj%NumPlaneWaves = NumPlaneWaves + if (present(TimeSteps)) obj%TimeSteps = TimeSteps + if (present(InitialTimeStep)) obj%InitialTimeStep = InitialTimeStep + if (present(NumNodalSources)) obj%NumNodalSources = NumNodalSources + if (present(NumberRequest)) obj%NumberRequest = NumberRequest + + if (present(thereAreMagneticMedia)) & + obj%thereAreMagneticMedia = thereAreMagneticMedia + + if (present(thereArePMLMagneticMedia)) & + obj%thereArePMLMagneticMedia = thereArePMLMagneticMedia + + if (present(nEntradaRoot)) obj%nEntradaRoot = nEntradaRoot + + end subroutine sgg_init + + subroutine sgg_set_tiempo(sgg, tiempo) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND_tiempo), pointer :: tiempo(:) + sgg%tiempo => tiempo + end subroutine + + subroutine sgg_set_dt(sgg, dt) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND_tiempo), intent(in) :: dt + sgg%dt = dt + end subroutine + + subroutine sgg_set_extraswitches(sgg, extraswitches) + type(SGGFDTDINFO), intent(inout) :: sgg + character(len=*), intent(in) :: extraswitches + sgg%extraswitches = extraswitches + end subroutine + + subroutine sgg_set_NumMedia(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%NumMedia = newValue + end subroutine + + subroutine sgg_set_AllocMed(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocMed = newValue + end subroutine + + subroutine sgg_set_IniPMLMedia(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%IniPMLMedia = newValue + end subroutine + + subroutine sgg_set_EndPMLMedia(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%EndPMLMedia = newValue + end subroutine + + subroutine sgg_set_NumPlaneWaves(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%NumPlaneWaves = newValue + end subroutine + + subroutine sgg_set_TimeSteps(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%TimeSteps = newValue + end subroutine + + subroutine sgg_set_InitialTimeStep(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%InitialTimeStep = newValue + end subroutine + + subroutine sgg_set_NumNodalSources(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%NumNodalSources = newValue + end subroutine + + subroutine sgg_set_NumberRequest(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%NumberRequest = newValue + end subroutine + + subroutine sgg_set_LineX(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%LineX => newValue + end subroutine + + subroutine sgg_set_LineY(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%LineY => newValue + end subroutine + + subroutine sgg_set_LineZ(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%LineZ => newValue + end subroutine + + subroutine sgg_set_DX(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%DX => newValue + end subroutine + + subroutine sgg_set_DY(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%DY => newValue + end subroutine + + subroutine sgg_set_DZ(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + real(kind=RKIND), pointer :: newValue(:) + sgg%DZ => newValue + end subroutine + + subroutine sgg_set_AllocDxI(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDxI = newValue + end subroutine + + subroutine sgg_set_AllocDyI(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDyI = newValue + end subroutine + + subroutine sgg_set_AllocDzI(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDzI = newValue + end subroutine + + subroutine sgg_set_AllocDxE(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDxE = newValue + end subroutine + + subroutine sgg_set_AllocDyE(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDyE = newValue + end subroutine + + subroutine sgg_set_AllocDzE(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + integer(kind=SINGLE), intent(in) :: newValue + sgg%AllocDzE = newValue + end subroutine + + subroutine sgg_set_PlaneWave(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(planeonde_t), pointer :: newValue(:) + sgg%PlaneWave => newValue + end subroutine + + subroutine sgg_set_Med(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(MediaData_t), pointer :: newValue(:) + sgg%Med => newValue + end subroutine + + subroutine sgg_set_NodalSource(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(NodalSource_t), pointer :: newValue(:) + sgg%NodalSource => newValue + end subroutine + + subroutine sgg_set_Observation(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(obses_t), pointer :: newValue(:) + sgg%Observation => newValue + end subroutine + + subroutine sgg_set_Border(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(Border_t), intent(in) :: newValue + sgg%Border = newValue + end subroutine + + subroutine sgg_set_PML(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(PML_t), intent(in) :: newValue + sgg%PML = newValue + end subroutine + + subroutine sgg_set_Eshared(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(Shared_t), intent(in) :: newValue + sgg%Eshared = newValue + end subroutine + + subroutine sgg_set_Hshared(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(Shared_t), intent(in) :: newValue + sgg%Hshared = newValue + end subroutine + + subroutine sgg_set_Alloc(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(XYZlimit_t), intent(in) :: newValue(1:6) + sgg%Alloc = newValue + end subroutine + + subroutine sgg_set_Sweep(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(XYZlimit_t), intent(in) :: newValue(1:6) + sgg%Sweep = newValue + end subroutine + + subroutine sgg_set_SINPMLSweep(sgg, newValue) + type(SGGFDTDINFO), intent(inout) :: sgg + type(XYZlimit_t), intent(in) :: newValue(1:6) + sgg%SINPMLSweep = newValue + end subroutine + + subroutine sgg_set_thereAreMagneticMedia(sgg, value) + type(SGGFDTDINFO), intent(inout) :: sgg + logical, intent(in) :: value + sgg%thereAreMagneticMedia = value + end subroutine + + subroutine sgg_set_thereArePMLMagneticMedia(sgg, value) + type(SGGFDTDINFO), intent(inout) :: sgg + logical, intent(in) :: value + sgg%thereArePMLMagneticMedia = value + end subroutine + + subroutine sgg_set_nEntradaRoot(sgg, value) + type(SGGFDTDINFO), intent(inout) :: sgg + character(len=*), intent(in) :: value + sgg%nEntradaRoot = value + end subroutine + + subroutine sgg_set_Punto(sgg, value) + type(SGGFDTDINFO), intent(inout) :: sgg + type(coorsxyzP), intent(in) :: value + sgg%Punto = value + end subroutine + + subroutine sgg_add_observation(sgg, new_observation) + implicit none + + type(SGGFDTDINFO), intent(inout) :: sgg + type(Obses_t), intent(in), target :: new_observation + + type(Obses_t), dimension(:), pointer :: temp_obs + integer :: old_size, new_size + + old_size = sgg%NumberRequest + new_size = old_size + 1 + + allocate (temp_obs(1:new_size)) + + if (old_size > 0) then + temp_obs(1:old_size) = sgg%Observation(1:old_size) + deallocate (sgg%Observation) + end if + + temp_obs(new_size) = new_observation + + sgg%Observation => temp_obs + + sgg%NumberRequest = new_size + + end subroutine sgg_add_observation + +end module mod_sggMethods diff --git a/test/vtk/CMakeLists.txt b/test/vtk/CMakeLists.txt deleted file mode 100644 index 0d96a902..00000000 --- a/test/vtk/CMakeLists.txt +++ /dev/null @@ -1,18 +0,0 @@ -message(STATUS "Creating build system for test/vtk") - -add_library( - vtk_test_fortran - "test_vtk.F90" - -) - -target_link_libraries(vtk_test_fortran - semba-outputs -) - -add_library(vtk_tests "vtk_tests.cpp") - -target_link_libraries(vtk_tests - vtk_test_fortran - GTest::gtest -) \ No newline at end of file diff --git a/test/vtk/test_vtk.F90 b/test/vtk/test_vtk.F90 deleted file mode 100644 index 8821caf3..00000000 --- a/test/vtk/test_vtk.F90 +++ /dev/null @@ -1,8 +0,0 @@ -module test_vtk_m - use VTK - implicit none - contains - integer function test_init_vtk() bind(C) result(err) - err = 0 - end function test_init_vtk -end module \ No newline at end of file diff --git a/test/vtk/vtk_tests.cpp b/test/vtk/vtk_tests.cpp deleted file mode 100644 index 4f145344..00000000 --- a/test/vtk/vtk_tests.cpp +++ /dev/null @@ -1 +0,0 @@ -#include "vtk_tests.h" \ No newline at end of file diff --git a/test/vtk/vtk_tests.h b/test/vtk/vtk_tests.h deleted file mode 100644 index 77e9dc92..00000000 --- a/test/vtk/vtk_tests.h +++ /dev/null @@ -1,7 +0,0 @@ -#include - -//extern "C" int test_init_vtk(); - -//TEST(vtk, test_initialize_vtk) { EXPECT_EQ(0, test_init_vtk()); } - - diff --git a/testData/input_examples/probes/movie_and_frequency_slices.fdtd.json b/testData/input_examples/probes/movie_and_frequency_slices.fdtd.json new file mode 100644 index 00000000..a6686d01 --- /dev/null +++ b/testData/input_examples/probes/movie_and_frequency_slices.fdtd.json @@ -0,0 +1,197 @@ +{ + "_format": "FDTD Input file", + "general": { + "timeStep": 3.0813e-12, + "numberOfSteps": 1298 + }, + "boundary": { + "all": { + "type": "mur" + } + }, + "mesh": { + "grid": { + "numberOfCells": [ + 30, + 30, + 30 + ], + "steps": { + "x": [ + 0.002 + ], + "y": [ + 0.002 + ], + "z": [ + 0.002 + ] + } + }, + "coordinates": [ + { + "id": 1, + "relativePosition": [ + 0.0, + 10.0, + 10.0 + ] + }, + { + "id": 2, + "relativePosition": [ + 10.0, + 10.0, + 10.0 + ] + }, + { + "id": 3, + "relativePosition": [ + 10.0, + 0.0, + 10.0 + ] + } + ], + "elements": [ + { + "id": 1, + "type": "cell", + "intervals": [ + [ + [ + 0.0, + 20.0, + 20.0 + ], + [ + 20.0, + 20.0, + 20.0 + ] + ], + [ + [ + 20.0, + 20.0, + 20.0 + ], + [ + 20.0, + 20.0, + 10.0 + ] + ], + [ + [ + 20.0, + 20.0, + 10.0 + ], + [ + 20.0, + 0.0, + 10.0 + ] + ] + ] + }, + { + "id": 2, + "type": "cell", + "intervals": [ + [ + [ + 15, + 15, + 15 + ], + [ + 25, + 25, + 25 + ] + ] + ] + } + ] + }, + "materials": [], + "materialAssociations": [], + "sources": [ + { + "name": "nodalSource", + "type": "nodalSource", + "magnitudeFile": "predefinedExcitation.1.exc", + "elementIds": [ + 1 + ] + } + ], + "probes": [ + { + "name": "electric_field_movie_x", + "type": "movie", + "field": "electric", + "component": "x", + "elementIds": [2] + }, + { + "name": "magnetic_field_movie_y", + "type": "movie", + "field": "magnetic", + "component": "y", + "elementIds": [2] + }, + { + "name": "current_density_movie_z", + "type": "movie", + "field": "currentDensity", + "component": "z", + "elementIds": [2] + }, + { + "name": "electric_field_frequency_slice_x", + "type": "movie", + "field": "electric", + "component": "x", + "elementIds": [2], + "domain": { + "type": "frequency", + "initialFrequency": 1e6, + "finalFrequency": 1e9, + "numberOfFrequencies": 30, + "frequencySpacing": "logarithmic" + } + }, + { + "name": "magnetic_field_frequency_slice_y", + "type": "movie", + "field": "magnetic", + "component": "y", + "elementIds": [2], + "domain": { + "type": "frequency", + "initialFrequency": 1e6, + "finalFrequency": 1e9, + "numberOfFrequencies": 30, + "frequencySpacing": "logarithmic" + } + }, + { + "name": "current_density_frequency_slice_z", + "type": "movie", + "field": "currentDensity", + "component": "z", + "elementIds": [2], + "domain": { + "type": "frequency", + "initialFrequency": 1e6, + "finalFrequency": 1e9, + "numberOfFrequencies": 30, + "frequencySpacing": "logarithmic" + } + } + ] +} \ No newline at end of file diff --git a/testData/input_examples/probes/time_movie_over_cube.fdtd.json b/testData/input_examples/probes/time_movie_over_cube.fdtd.json index 663f1512..771039e4 100644 --- a/testData/input_examples/probes/time_movie_over_cube.fdtd.json +++ b/testData/input_examples/probes/time_movie_over_cube.fdtd.json @@ -48,7 +48,7 @@ ] ] ] - }, + } ] }, "materials": [