diff --git a/prj/Makefile b/prj/Makefile index 676baef..771ddc0 100644 --- a/prj/Makefile +++ b/prj/Makefile @@ -6,7 +6,7 @@ #Portabilityn #ifdef ComSpec ifeq ($(OS), Windows_NT) - #Windows + # Windows INFO = Compiling for Windows 64bit RM = if exist FILE del /F /Q FILE MV = if exist FILE move FILE DESTINATION @@ -18,12 +18,12 @@ ifeq ($(OS), Windows_NT) PATHSEP2 = \\ LDFLAGS = -shared-libgcc else - #Unix + # Unix RM = rm -f FILE MV = mv FILE DESTINATION || true RP_EXE = eddypro_rp FCC_EXE = eddypro_fcc - FC = gfortran + FC = gfortran MAKE_DIR = @mkdir -p DIR PATHSEP2 = / platform=$(shell uname) @@ -34,7 +34,7 @@ else OS_DIR = mac INFO = Compiling for Mac OS endif - LDLAGS = -shared-libgcc + LDFLAGS = -shared-libgcc endif PATHSEP=$(strip $(PATHSEP2)) @@ -42,7 +42,8 @@ PATHSEP=$(strip $(PATHSEP2)) #Dirs as seen by Make ##RP RP_SRC_DIR_f90d1 = ../src/src_rp/ -RP_SRC_DIR_Fd2 = ../src/src_rp/fft4/ +# RP_SRC_DIR_Fd2 = ../src/src_rp/fft4/ +RP_SRC_DIR_f90d3 = ../src/src_rp/fftpack/src/ ##FCC FCC_SRC_DIR_f90d1 = ../src/src_fcc/ ##Common @@ -53,7 +54,8 @@ EXE_DIR = ../bin/$(OS_DIR)/ #Dirs as seen by OS ##RP OS_RP_SRC_DIR_f90d1 = ..$(PATHSEP)src$(PATHSEP)src_rp$(PATHSEP) -OS_RP_SRC_DIR_Fd2 = ..$(PATHSEP)src$(PATHSEP)src_rp$(PATHSEP)fft4$(PATHSEP) +# OS_RP_SRC_DIR_Fd2 = ..$(PATHSEP)src$(PATHSEP)src_rp$(PATHSEP)fft4$(PATHSEP) +OS_RP_SRC_DIR_f90d3 = ..$(PATHSEP)src$(PATHSEP)src_rp$(PATHSEP)fftpack$(PATHSEP)src$(PATHSEP) ##FCC OS_FCC_SRC_DIR_f90d1 = ..$(PATHSEP)src$(PATHSEP)src_fcc$(PATHSEP) ##Common @@ -64,7 +66,8 @@ OS_EXE_DIR = ..$(PATHSEP)bin$(PATHSEP)$(OS_DIR)$(PATHSEP) #List of source file basenames (.f90, .F) ##RP RP_SRCS_f90d1 = $(notdir $(wildcard $(RP_SRC_DIR_f90d1)*.f90)) -RP_SRCS_Fd2 = $(notdir $(wildcard $(RP_SRC_DIR_Fd2)*.F)) +# RP_SRCS_Fd2 = $(notdir $(wildcard $(RP_SRC_DIR_Fd2)*.F)) +RP_SRCS_f90d3 = $(notdir $(wildcard $(RP_SRC_DIR_f90d3)*.f90)) ##FCC FCC_SRCS_f90d1 = $(notdir $(wildcard $(FCC_SRC_DIR_f90d1)*.f90)) ##Common @@ -73,7 +76,8 @@ COMMON_SRCS_f90d1 = $(notdir $(wildcard $(COMMON_SRC_DIR_f90d1)*.f90)) #List of object file basenames (.o) ##RP RP_OBJS_f90d1=$(patsubst %.f90, %.o, $(RP_SRCS_f90d1)) -RP_OBJS_Fd2=$(patsubst %.F, %.o, $(RP_SRCS_Fd2)) +# RP_OBJS_Fd2=$(patsubst %.F, %.o, $(RP_SRCS_Fd2)) +RP_OBJS_f90d3=$(patsubst %.f90, %.o, $(RP_SRCS_f90d3)) ##FCC FCC_OBJS_f90d1=$(patsubst %.f90, %.o, $(FCC_SRCS_f90d1)) ##Common @@ -83,8 +87,10 @@ COMMON_OBJS_f90d1=$(patsubst %.f90, %.o, $(COMMON_SRCS_f90d1)) #CFLAGS = -g -fcheck=all -Wall -pedantic -fall-intrinsics -fbounds-check -Wextra -Wcharacter-truncation -Wunderflow -Wno-compare-reals -std=f2003 -O3 -I $(OBJS_DIR) CFLAGS = -Wall -pedantic -fall-intrinsics -fbounds-check -Wextra -Wcharacter-truncation -Wunderflow -Wno-compare-reals -std=f2008 -O3 -I $(OBJS_DIR) -VPATH = $(RP_SRC_DIR_f90d1):$(RP_SRC_DIR_Fd2):$(FCC_SRC_DIR_f90d1):$(COMMON_SRC_DIR_f90d1):$(OBJS_DIR) -RP_OBJS = $(addprefix $(OBJS_DIR), $(RP_OBJS_f90d1) $(RP_OBJS_Fd2)$(COMMON_OBJS_f90d1)) +# VPATH = $(RP_SRC_DIR_f90d1):$(RP_SRC_DIR_Fd2):$(RP_SRC_DIR_f90d3):$(FCC_SRC_DIR_f90d1):$(COMMON_SRC_DIR_f90d1):$(OBJS_DIR) +# RP_OBJS = $(addprefix $(OBJS_DIR), $(RP_OBJS_f90d1) $(RP_OBJS_Fd2) $(RP_OBJS_f90d3) $(COMMON_OBJS_f90d1)) +VPATH = $(RP_SRC_DIR_f90d1):$(RP_SRC_DIR_f90d3):$(FCC_SRC_DIR_f90d1):$(COMMON_SRC_DIR_f90d1):$(OBJS_DIR) +RP_OBJS = $(addprefix $(OBJS_DIR), $(RP_OBJS_f90d1) $(RP_OBJS_f90d3) $(COMMON_OBJS_f90d1)) FCC_OBJS = $(addprefix $(OBJS_DIR), $(FCC_OBJS_f90d1) $(COMMON_OBJS_f90d1)) $(info $(INFO)) @@ -92,15 +98,17 @@ $(info $(INFO)) #Targets all : rp fcc -rp : $(RP_OBJS_f90d1) $(RP_OBJS_Fd2) $(COMMON_OBJS_f90d1) +rp : $(RP_OBJS_f90d1) $(RP_OBJS_f90d3) $(COMMON_OBJS_f90d1) @$(subst DIR,$(OS_EXE_DIR),$(MAKE_DIR)) $(FC) $(LDFLAGS) -o $(EXE_DIR)$(RP_EXE) $(RP_OBJS) @$(subst DESTINATION, $(OS_OBJS_DIR), $(subst FILE, *.mod, $(MV))) + @$(subst DESTINATION, $(OS_OBJS_DIR), $(subst FILE, *.smod, $(MV))) fcc : $(FCC_OBJS_f90d1) $(COMMON_OBJS_f90d1) @$(subst DIR,$(OS_EXE_DIR),$(MAKE_DIR)) $(FC) $(LDFLAGS) -o $(EXE_DIR)$(FCC_EXE) $(FCC_OBJS) @$(subst DESTINATION, $(OS_OBJS_DIR), $(subst FILE, *.mod, $(MV))) + @$(subst DESTINATION, $(OS_OBJS_DIR), $(subst FILE, *.smod, $(MV))) #Compilation ##RP @@ -110,6 +118,9 @@ $(RP_OBJS_f90d1): $(RP_OBJS_Fd2): @$(subst DIR,$(OS_OBJS_DIR),$(MAKE_DIR)) $(FC) -c $(RP_SRC_DIR_Fd2)$(@:.o=.F) -o $(OBJS_DIR)$@ +$(RP_OBJS_f90d3): + @$(subst DIR,$(OS_OBJS_DIR),$(MAKE_DIR)) + $(FC) $(CFLAGS) -c $(RP_SRC_DIR_f90d3)$(@:.o=.f90) -o $(OBJS_DIR)$@ ##FCC $(FCC_OBJS_f90d1): @$(subst DIR,$(OS_OBJS_DIR),$(MAKE_DIR)) @@ -171,7 +182,8 @@ interpret_diagnostics.o: \ m_rp_global_var.o kid.o: \ kid.f90 \ - m_rp_global_var.o + m_rp_global_var.o \ + timelag_handle.o fisher.o: \ fisher.f90 \ m_rp_global_var.o @@ -181,9 +193,16 @@ parse_ini_file.o: \ basic_stats.o: \ basic_stats.f90 \ m_common_global_var.o +mo_fftmax.o: \ + mo_fftmax.f90 \ + m_numeric_kinds.o \ + fftpack.o timelag_handle.o: \ timelag_handle.f90 \ - m_rp_global_var.o + m_numeric_kinds.o \ + m_typedef.o \ + m_rp_global_var.o \ + mo_fftmax.o count_records_and_values.o: \ count_records_and_values.f90 \ m_common_global_var.o @@ -264,7 +283,8 @@ wind_direction.o: \ m_common_global_var.o read_ini_rp.o: \ read_ini_rp.f90 \ - m_rp_global_var.o + m_rp_global_var.o \ + exception_handler.o bpcf_li7550_analog_filters.o: \ bpcf_li7550_analog_filters.f90 \ m_common_global_var.o @@ -476,7 +496,8 @@ timestamp.o: \ m_numeric_kinds.o fourier_transform.o: \ fourier_transform.f90 \ - m_rp_global_var.o + m_rp_global_var.o \ + fftpack.o optimize_timelags.o: \ optimize_timelags.f90 \ m_rp_global_var.o @@ -559,7 +580,8 @@ replace_gap_with_linear_interpolation.o: \ m_common_global_var.o eddypro-rp_main.o: \ eddypro-rp_main.f90 \ - m_rp_global_var.o + m_rp_global_var.o \ + timelag_handle.o import_current_period.o: \ import_current_period.f90 \ m_rp_global_var.o @@ -841,3 +863,64 @@ write_out_full_fcc.o: \ write_out_metadata_fcc.o: \ write_out_metadata_fcc.f90 \ m_fx_global_var_mod.o + +# fftpack +fftpack.o: fftpack.f90 rk.o +fftpack_fft.o: fftpack_fft.f90 fftpack.o rk.o +fftpack_ifft.o: fftpack_ifft.f90 fftpack.o rk.o +fftpack_rfft.o: fftpack_rfft.f90 fftpack.o rk.o +fftpack_irfft.o: fftpack_irfft.f90 fftpack.o rk.o +fftpack_qct.o: fftpack_qct.f90 fftpack.o rk.o +fftpack_iqct.o: fftpack_iqct.f90 fftpack.o rk.o +fftpack_dct.o: fftpack_dct.f90 fftpack.o rk.o +fftpack_fftshift.o: fftpack_fftshift.f90 fftpack.o rk.o +fftpack_ifftshift.o: fftpack_ifftshift.f90 fftpack.o rk.o +zfftb.o: zfftb.f90 rk.o +cfftb1.o: cfftb1.f90 rk.o +zfftf.o: zfftf.f90 rk.o +cfftf1.o: cfftf1.f90 rk.o +zffti.o: zffti.f90 rk.o +cffti1.o: cffti1.f90 rk.o +dcosqb.o: dcosqb.f90 rk.o +cosqb1.o: cosqb1.f90 rk.o +dcosqf.o: dcosqf.f90 rk.o +cosqf1.o: cosqf1.f90 rk.o +dcosqi.o: dcosqi.f90 rk.o +dcost.o: dcost.f90 rk.o +dcosti.o: dcosti.f90 rk.o +ezfft1.o: ezfft1.f90 rk.o +dzfftb.o: dzfftb.f90 rk.o +dzfftf.o: dzfftf.f90 rk.o +dzffti.o: dzffti.f90 rk.o +passb.o: passb.f90 rk.o +passb2.o: passb2.f90 rk.o +passb3.o: passb3.f90 rk.o +passb4.o: passb4.f90 rk.o +passb5.o: passb5.f90 rk.o +passf.o: passf.f90 rk.o +passf2.o: passf2.f90 rk.o +passf3.o: passf3.f90 rk.o +passf4.o: passf4.f90 rk.o +passf5.o: passf5.f90 rk.o +radb2.o: radb2.f90 rk.o +radb3.o: radb3.f90 rk.o +radb4.o: radb4.f90 rk.o +radb5.o: radb5.f90 rk.o +radbg.o: radbg.f90 rk.o +radf2.o: radf2.f90 rk.o +radf3.o: radf3.f90 rk.o +radf4.o: radf4.f90 rk.o +radf5.o: radf5.f90 rk.o +radfg.o: radfg.f90 rk.o +dfftb.o: dfftb.f90 rk.o +rfftb1.o: rfftb1.f90 rk.o +dfftf.o: dfftf.f90 rk.o +rfftf1.o: rfftf1.f90 rk.o +dffti.o: dffti.f90 rk.o +rffti1.o: rffti1.f90 rk.o +dsinqb.o: dsinqb.f90 rk.o +dsinqf.o: dsinqf.f90 rk.o +dsinqi.o: dsinqi.f90 rk.o +dsint.o: dsint.f90 rk.o +sint1.o: sint1.f90 rk.o +dsinti.o: dsinti.f90 rk.o diff --git a/src/src_common/configure_for_embedded.f90 b/src/src_common/configure_for_embedded.f90 index ad31619..127ee4f 100644 --- a/src/src_common/configure_for_embedded.f90 +++ b/src/src_common/configure_for_embedded.f90 @@ -75,9 +75,9 @@ subroutine ConfigureForEmbedded() end if !> Retrieve time-lag optimization file name if needed - if (index(Meth%tlag, 'tlag_opt') /= 0) then + if ((index(Meth%tlag, 'tlag_opt') /= 0) .or. (index(Meth%tlag, 'maxfft') /= 0)) then - !> Retrieve planar fit file name from /ini folder + !> Retrieve timelag file name from /ini folder comm = 'find "' // trim(homedir) // 'ini' // slash & // '" -iname *_timelag_opt_*'// ' > ' // '"' & // trim(adjustl(TmpDir)) // 'to_flist.tmp" ' & diff --git a/src/src_common/dir_sub.f90 b/src/src_common/dir_sub.f90 index 7873f7e..ae1e909 100644 --- a/src/src_common/dir_sub.f90 +++ b/src/src_common/dir_sub.f90 @@ -61,7 +61,7 @@ integer function CreateDir(directory) !> create dir and if one already exists, skip obvious system message !> redirecting through windows NUL (equivalent to linux /dev/null) - comm = 'mkdir ' // directory(1: len_trim(directory)) // comm_err_redirect + comm = trim(comm_mkdir) // ' ' // directory(1: len_trim(directory)) // comm_err_redirect CreateDir = system(comm) end function CreateDir diff --git a/src/src_common/exception_handler.f90 b/src/src_common/exception_handler.f90 index 00961c8..d6dd6c0 100644 --- a/src/src_common/exception_handler.f90 +++ b/src/src_common/exception_handler.f90 @@ -359,5 +359,10 @@ subroutine ExceptionHandler(error_code) write(*,*) ' Warning(95)> The selected "w-boost" correction is not applicable' write(*,*) ' Warning(95)> to data collected with selected sonic anemometer.' write(*,*) ' Warning(95)> Continuing without applying "w-boost" correction.' + case(96) + write(*,*) ' Fatal error(96)> You can only choose one of to_mode=2 and pf_mode=2' + write(*,*) ' Fatal error(96)> for only performing timelag optimization or' + write(*,*) ' Fatal error(96)> planar fit calculation.' + stop 1 end select end subroutine ExceptionHandler diff --git a/src/src_common/import_native_data.f90 b/src/src_common/import_native_data.f90 index 0d02de0..a55d4b6 100644 --- a/src/src_common/import_native_data.f90 +++ b/src/src_common/import_native_data.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -56,7 +56,8 @@ subroutine ImportNativeData(Filepath, FirstRecord, LastRecord, LocCol, & integer :: i integer :: io_status integer :: read_status - integer(kind = 1) :: rec_len + !MC integer(kind = 1) :: rec_len + integer(i1) :: rec_len character(ShortInstringLen) :: dataline @@ -66,6 +67,9 @@ subroutine ImportNativeData(Filepath, FirstRecord, LastRecord, LocCol, & case ('eddymeas_bin') !> Open raw file in binary mode + !MC record length should be ncol*2 bytes, + ! which should be the same as 8 + (NumCol - 4) * 2 + ! because NumCol is ncol without the 4 anemometer variables open(unat, file = trim(adjustl(Filepath)), status = 'old', & iostat = io_status, access='direct', form = 'unformatted', & recl = 8 + (NumCol - 4) * 2) @@ -211,7 +215,8 @@ subroutine ReadNativeFile(Filepath, FirstRecord, LastRecord, rec_len, & integer, intent(in) :: FirstRecord integer, intent(in) :: LastRecord integer, intent(in) :: nrow, ncol - integer(kind = 1), intent(in) :: rec_len + !MC integer(kind = 1), intent(in) :: rec_len + integer(i1), intent(in) :: rec_len character(*), intent(in) :: Filepath type(ColType), intent(inout) :: LocCol(MaxNumCol) integer, intent(out) :: N diff --git a/src/src_common/import_slt_eddysoft.f90 b/src/src_common/import_slt_eddysoft.f90 index 58776c2..8880670 100644 --- a/src/src_common/import_slt_eddysoft.f90 +++ b/src/src_common/import_slt_eddysoft.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -58,13 +58,14 @@ subroutine ImportSLTEddySoft(FirstRecord, LastRecord, LocCol, fRaw, nrow, ncol, integer :: j integer :: jj integer :: NumAnalog - integer(kind = 1) :: loc_header(8 + (NumCol - 4) * 2) - integer(kind = 2) :: IntRec(NumCol) + !MC integer(kind = 1) :: loc_header(8 + (NumCol - 4) * 2) + !MC integer(kind = 2) :: IntRec(NumCol) + integer(i1) :: loc_header(8 + (NumCol - 4) * 2) + integer(i2) :: IntRec(NumCol) real(kind = sgl) :: TmpfRaw(nrow, NumCol) type(ColType) :: TmpCol(MaxNumCol) logical :: high_res(6) = .false. - FileEndReached = .false. !> Initializations @@ -78,7 +79,8 @@ subroutine ImportSLTEddySoft(FirstRecord, LastRecord, LocCol, fRaw, nrow, ncol, end if do j = 1, NumAnalog - if (loc_header(7 + 2 * j) == 0_1 .or. loc_header(7 + 2 * j) / 2_1 * 2_1 == loc_header(7 + 2 * j)) then + !MC if (loc_header(7 + 2 * j) == 0_1 .or. loc_header(7 + 2 * j) / 2_1 * 2_1 == loc_header(7 + 2 * j)) then + if (loc_header(7 + 2 * j) == 0_i1 .or. loc_header(7 + 2 * j) / 2_i1 * 2_i1 == loc_header(7 + 2 * j)) then !> if mask byte is even, low resolution is used high_res(j) = .false. else @@ -91,7 +93,7 @@ subroutine ImportSLTEddySoft(FirstRecord, LastRecord, LocCol, fRaw, nrow, ncol, i = 0 N = 0 fRaw = error - IntRec = nint(error) + IntRec = nint(error, i2) record_loop: do i = i + 1 read(unat, rec = i + 1, iostat = io_status) (IntRec(j), j = 1, ncol) @@ -124,7 +126,7 @@ subroutine ImportSLTEddySoft(FirstRecord, LastRecord, LocCol, fRaw, nrow, ncol, TmpCol = NullCol jj = 0 do j = 1, NumCol - if (LocCol(j)%var /= 'ignore' .and. LocCol(j)%var /= 'not_numeric') then + if (trim(LocCol(j)%var) /= 'ignore' .and. trim(LocCol(j)%var) /= 'not_numeric') then jj = jj + 1 TmpCol(jj) = LocCol(j) fRaw(1:N, jj) = TmpfRaw(1:N, j) diff --git a/src/src_common/init_env.f90 b/src/src_common/init_env.f90 index ef7f6cd..4225566 100644 --- a/src/src_common/init_env.f90 +++ b/src/src_common/init_env.f90 @@ -52,6 +52,9 @@ subroutine InitEnv() character(PathLen) :: projPath character(256) :: arg character(32) :: tmpDirPadding + real :: realrand + character(5) :: strrand + character(PathLen) :: tempdir character(3), parameter :: OS_default = 'win' integer, external :: CreateDir @@ -70,6 +73,7 @@ subroutine InitEnv() homedir = '' EddyProProj%run_env = '' EddyProProj%caller = '' + tempdir = '' projPath = '' i = 1 arg_loop: do @@ -77,10 +81,10 @@ subroutine InitEnv() call get_command_argument(i, value=switch, status=io_status) if (io_status > 0 .or. len_trim(switch) == 0) exit arg_loop i = i + 1 - call get_command_argument(i, value=arg, status=io_status) - i = i + 1 if (switch(1:1) == '-') then + call get_command_argument(i, value=arg, status=io_status) + i = i + 1 select case(trim(adjustl(switch))) !> Switch for "system", the host operating system @@ -107,6 +111,12 @@ subroutine InitEnv() EddyProProj%caller = trim(arg) if (EddyProProj%caller(1:1) == '-') EddyProProj%caller = '' + !> Switch for "temporary directory", the temporary working directory + case('-t', '--tmpdir') + if (io_status > 0 .or. len_trim(switch) == 0) exit arg_loop + tempdir = trim(arg) + if (tempdir(1:1) == '-') tempdir = '' + !> Software version case('-v', '--version') call InformOfSoftwareVersion(sw_ver, build_date) @@ -121,6 +131,7 @@ subroutine InitEnv() end if end do arg_loop + !> Set OS-dependent parameters if (len_trim(OS) == 0) OS = OS_default call SetOSEnvironment() @@ -129,6 +140,11 @@ subroutine InitEnv() if (len_trim(homedir) == 0) homedir = '..' if (len_trim(EddyProProj%run_env) == 0) EddyProProj%run_env = 'desktop' if (len_trim(EddyProProj%caller) == 0) EddyProProj%caller = 'console' + if (len_trim(tempdir) == 0) then + tempdir = homedir + if (EddyProProj%run_env == 'desktop') & + tempdir = trim(tempdir) // slash // 'tmp' // slash + endif !> Define default unit number (udf), run specific call hms_current_hms(aux, aux, aux, udf) @@ -145,11 +161,13 @@ subroutine InitEnv() end if !> Define TmpDir differently if it's in desktop or embedded mode + call random_number(realrand) + write(strrand, '(i0.5)') int(realrand*10000) if (EddyProProj%run_env == 'desktop') then - TmpDir = trim(homedir) // 'tmp' // slash // 'tmp' & - // trim(adjustl(tmpDirPadding)) // slash + TmpDir = trim(tempdir) // 'tmp' // trim(adjustl(tmpDirPadding)) & + // '_' // strrand // slash else - TmpDir = trim(homedir) // 'tmp' // slash + TmpDir = trim(tempdir) // 'tmp' // '_' // strrand // slash end if !> Create TmpDir in case it doesn't exist (for use from command line) @@ -178,7 +196,7 @@ subroutine InformOfSoftwareVersion(sw_ver, build_date) write (*, '(a)') ' ' // trim(adjustl(app)) // ', version ' // trim(adjustl(sw_ver)) // & - &', build ' // trim(adjustl(build_date)) // '.' + ', build ' // trim(adjustl(build_date)) // '.' stop end subroutine InformOfSoftwareVersion @@ -212,7 +230,7 @@ subroutine CommandLineHelp(sw_ver, build_date) write(*, '(a)') ' Help for ' // trim(adjustl(app)) write(*, '(a)') ' --------------------' write (*, '(a)') ' ' // trim(adjustl(app)) // ', version ' // trim(adjustl(sw_ver)) // & - &', build ' // trim(adjustl(build_date)) // '.' + ', build ' // trim(adjustl(build_date)) // '.' write(*,*) write(*, '(a)') ' USAGE: ' // trim(prog) // ' [OPTION [ARG]] [PROJ_FILE]' write(*,*) @@ -220,12 +238,14 @@ subroutine CommandLineHelp(sw_ver, build_date) write(*, '(a)') ' [-s | --system [win | linux | mac]] Operating system; if not provided assumes "win"' write(*, '(a)') ' [-m | --mode [embedded | desktop]] Running mode; if not provided assumes "desktop"' write(*, '(a)') ' [-c | --caller [gui | console]] Caller; if not provided assumes "console"' - write(*, '(a)') ' [-e | --environment [DIRECTORY]] Working directory, to be provided in embedded mode;& - & if not provided assumes \.' + write(*, '(a)') ' [-e | --environment [DIRECTORY]] Working directory, to be provided in embedded mode;' & + // ' if not provided assumes \.' + write(*, '(a)') ' [-t | --tmpdir [DIRECTORY]] Directory for temporary files and directories;' & + // ' if not provided assumes \..' write(*, '(a)') ' [-h | --help] Display this help and exit' write(*, '(a)') ' [-v | --version] Output version information and exit' write(*, '(a)') - write(*, '(a)') ' PROJ_FILE Path of project (*.eddypro) file;& - & if not provided, assumes ..\ini\processing.eddypro' + write(*, '(a)') ' PROJ_FILE Path of project (*.eddypro) file;' & + // ' if not provided, assumes ..\ini\processing.eddypro' stop end subroutine CommandLineHelp diff --git a/src/src_common/m_common_global_var.f90 b/src/src_common/m_common_global_var.f90 index f699d0b..5697343 100644 --- a/src/src_common/m_common_global_var.f90 +++ b/src/src_common/m_common_global_var.f90 @@ -86,10 +86,12 @@ module m_common_global_var character(16) :: comm_out_redirect character(16) :: comm_7zip character(16) :: comm_7zip_x_opt + character(16) :: comm_7zip_out character(16) :: comm_copy character(16) :: comm_move character(16) :: comm_force_opt character(15) :: comm_dir + character(15) :: comm_mkdir character(PathLen) :: homedir character(PathLen) :: IniDir character(PathLen) :: TmpDir diff --git a/src/src_common/m_numeric_kinds.f90 b/src/src_common/m_numeric_kinds.f90 index 7553bbc..743e9d8 100644 --- a/src/src_common/m_numeric_kinds.f90 +++ b/src/src_common/m_numeric_kinds.f90 @@ -39,9 +39,8 @@ ! \todo !*************************************************************************** module m_numeric_kinds - implicit none - save + implicit none !> Declare parameters integer, parameter :: short = kind(2) @@ -50,4 +49,12 @@ module m_numeric_kinds integer, parameter :: sgl = kind(0.0) integer, parameter :: dbl = kind(0.0d0) integer, parameter :: utf8 = selected_char_kind('ISO_10646') + + integer, parameter :: i1 = selected_int_kind(2) + integer, parameter :: i2 = selected_int_kind(4) + integer, parameter :: i4 = selected_int_kind(9) + integer, parameter :: i8 = selected_int_kind(18) + integer, parameter :: sp = selected_real_kind(6,37) + integer, parameter :: dp = selected_real_kind(15,307) + end module m_numeric_kinds diff --git a/src/src_common/m_typedef.f90 b/src/src_common/m_typedef.f90 index 665047d..4d3c566 100644 --- a/src/src_common/m_typedef.f90 +++ b/src/src_common/m_typedef.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -903,6 +903,8 @@ module m_typedef logical :: despike logical :: pf_onthefly logical :: to_onthefly + logical :: pf_only + logical :: to_only logical :: pf_subtract_b0 logical :: recurse logical :: despike_vickers97 @@ -914,7 +916,7 @@ module m_typedef logical :: out_full_cosp(GHGNumVar) logical :: out_raw_var(E2NumVar) logical :: out_st(7) - logical :: out_raw(7) + logical :: out_raw(8) end type RPsetupType type :: PrType diff --git a/src/src_common/parse_ini_file.f90 b/src/src_common/parse_ini_file.f90 index d86de61..db488eb 100644 --- a/src/src_common/parse_ini_file.f90 +++ b/src/src_common/parse_ini_file.f90 @@ -178,7 +178,7 @@ end subroutine StoreIniTags ! \test ! \todo !*************************************************************************** -subroutine SearchLocalTags(Tags, nlines, NumTags, CharTags, nnum, nchar,& +subroutine SearchLocalTags(Tags, nlines, NumTags, CharTags, nnum, nchar, & NumTagFound, CharTagFound) use m_common_global_var implicit none diff --git a/src/src_common/read_metadata_file.f90 b/src/src_common/read_metadata_file.f90 index 466cd58..3797401 100644 --- a/src/src_common/read_metadata_file.f90 +++ b/src/src_common/read_metadata_file.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, diff --git a/src/src_common/set_os_environment.f90 b/src/src_common/set_os_environment.f90 index 18472e1..c20c308 100644 --- a/src/src_common/set_os_environment.f90 +++ b/src/src_common/set_os_environment.f90 @@ -53,10 +53,12 @@ subroutine SetOSEnvironment() comm_rmdir = 'rmdir /s /q' comm_7zip = '7z.exe ' comm_7zip_x_opt = 'x -y ' + comm_7zip_out = '-o' comm_copy = 'copy ' comm_move = 'move ' comm_force_opt = '/Y ' comm_dir = 'dir /O:D /B ' + comm_mkdir = 'mkdir' case('linux') slash = '/' escape = '\' @@ -66,11 +68,13 @@ subroutine SetOSEnvironment() comm_rmdir = 'rm -r -f' comm_7zip = '7za ' comm_7zip_x_opt = 'x -y ' + comm_7zip_out = '-o' comm_copy = 'cp ' comm_move = 'mv ' comm_force_opt = '-y ' comm_dir = 'ls ' ! comm_dir = 'find -iname ' + comm_mkdir = 'mkdir -p' case('mac') slash = '/' escape = '\' @@ -78,12 +82,17 @@ subroutine SetOSEnvironment() comm_out_redirect = ' > /dev/null' comm_del = 'rm ' comm_rmdir = 'rm -r -f' - comm_7zip = './7za ' - comm_7zip_x_opt = 'x -y ' + ! comm_7zip = './7za ' + ! comm_7zip_x_opt = 'x -y ' + ! comm_7zip_out = '-o ' + comm_7zip = 'unzip ' + comm_7zip_x_opt = '-o ' + comm_7zip_out = '-d ' comm_copy = 'cp ' comm_move = 'mv ' comm_force_opt = '-y ' comm_dir = 'ls ' ! comm_dir = 'find -iname ' + comm_mkdir = 'mkdir -p' end select end subroutine SetOSEnvironment diff --git a/src/src_common/unzip_archive.f90 b/src/src_common/unzip_archive.f90 index 3a5fd2b..5085925 100644 --- a/src/src_common/unzip_archive.f90 +++ b/src/src_common/unzip_archive.f90 @@ -78,8 +78,8 @@ subroutine UnZipArchive(ZipFile, MetaExt, DataExt, MetaFile, DataFile, & !> Extract files from archive comm = trim(comm_7zip) // ' ' // trim(comm_7zip_x_opt) & - // ' "' // ZipFile(1:len_trim(ZipFile)) // '" -o"' & - // trim(adjustl(TmpDir)) // '"' & + // ' "' // trim(ZipFile(1:len_trim(ZipFile))) // '" ' & + // trim(comm_7zip_out) // '"' // trim(adjustl(TmpDir)) // '" ' & // comm_out_redirect // comm_err_redirect unzip_status = system(comm) diff --git a/src/src_fcc/output_spectral_assessment_results.f90 b/src/src_fcc/output_spectral_assessment_results.f90 index e7afcf7..c4a871c 100644 --- a/src/src_fcc/output_spectral_assessment_results.f90 +++ b/src/src_fcc/output_spectral_assessment_results.f90 @@ -645,7 +645,7 @@ subroutine OutputSpectralAssessmentResults(nbins) MassPar(gas, unstable)%mu)), datum, EddyProProj%err_label) call AddDatum(dataline, datum, separator) !> Ideal cospectrum - call WriteDatumFloat(kaimal(MeanStabilityCosp(i, unstable)%fn(gas), 1, 'unstable'), & + call WriteDatumFloat(kaimal(MeanStabilityCosp(i, unstable)%fn(gas), 1d0, 'unstable'), & datum, EddyProProj%err_label) call AddDatum(dataline, datum, separator) call AddDatum(dataline, '', separator) diff --git a/src/src_rp/eddypro-rp_main.f90 b/src/src_rp/eddypro-rp_main.f90 index f607320..28964a7 100644 --- a/src/src_rp/eddypro-rp_main.f90 +++ b/src/src_rp/eddypro-rp_main.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -39,10 +39,13 @@ ! \todo !*************************************************************************** program EddyproRP + use m_rp_global_var + use mo_timelag_handle, only: TimeLagHandle !use netcdf !use iso_c_binding !use iso_fortran_env + implicit none !> Local variables @@ -103,12 +106,13 @@ program EddyproRP real(kind = dbl) :: Mat2d(2, 2) real(kind = dbl) :: pfVec(3) real(kind = dbl) :: pfVec2d(2) - real(kind = dbl) :: PFb2d(2, MaxNumWSect) = 0.d0 + real(kind = dbl) :: PFb2d(2, MaxNumWSect) = 0.0_dbl real(kind = dbl), allocatable :: bf(:) real(kind = sgl), allocatable :: Raw(:, :) real(kind = dbl), allocatable :: E2Set(:, :) real(kind = dbl), allocatable :: E2Primes(:, :) + real(kind = dbl), allocatable :: CorrSet(:, :) real(kind = dbl), allocatable :: UserSet(:, :) real(kind = dbl), allocatable :: UserPrimes(:, :) real(kind = dbl), allocatable :: DiagSet(:, :) @@ -175,6 +179,7 @@ program EddyproRP integer, external :: CreateDir include '../src_common/interfaces.inc' + logical :: FakeGoPlanarFit(1) !*************************************************************************** !*************************************************************************** @@ -223,9 +228,9 @@ program EddyproRP !> spectral correction method if (EddyProProj%out_avrg_cosp & .or. EddyProProj%out_avrg_spec & - .or. (EddyProProj%hf_meth /= 'none' & - .and. EddyProProj%hf_meth /= 'moncrieff_97' & - .and. EddyProProj%hf_meth /= 'massman_00')) then + .or. (trim(EddyProProj%hf_meth) /= 'none' & + .and. trim(EddyProProj%hf_meth) /= 'moncrieff_97' & + .and. trim(EddyProProj%hf_meth) /= 'massman_00')) then !> in this cases, passage is needed to FCC, so: !> don't output files, don't create dataset !> don't output metadata @@ -296,7 +301,7 @@ program EddyproRP !> GHG files. allocate(Raw(1, 1)) BypassCol = NullCol - if (EddyProProj%ftype == 'licor_ghg') then + if (trim(EddyProProj%ftype) == 'licor_ghg') then i = 1 do while (i <= NumRawFiles) call ReadLicorGhgArchive(RawFileList(i)%path, -1, -1, Col, & @@ -325,7 +330,7 @@ program EddyproRP RPsetup%avrg_len = nint(Metadata%file_length) !> Adjust time constant for planar fit if needed - if (Meth%det == 'ld') then + if (trim(Meth%det) == 'ld') then !> If time constant is larger than flux averaging interval, !> limit time constant to flux averaging interval and notify if (RPsetup%Tconst > RPsetup%avrg_len) then @@ -339,8 +344,8 @@ program EddyproRP !> Some convenient variables DatafileDateStep = DateType(0, 0, 0, 0, nint(Metadata%file_length)) DateStep = DateType(0, 0, 0, 0, RPsetup%avrg_len) - MaxNumFileRecords = nint(Metadata%file_length * 60d0 * Metadata%ac_freq) - MaxPeriodNumRecords = nint(RPsetup%avrg_len * 60d0 * Metadata%ac_freq) + MaxNumFileRecords = nint(Metadata%file_length * 60.0_dbl * Metadata%ac_freq) + MaxPeriodNumRecords = nint(RPsetup%avrg_len * 60.0_dbl * Metadata%ac_freq) !> Remember bypass columns (or columns detected !> from reading a sample GHG file) @@ -359,7 +364,7 @@ program EddyproRP else NumBiometFiles = NumFileNoRecurse end if - write(*, '(a)') ' Done.' + write(*, '(a)') ' Done.' else NumBiometFiles = 1 end if @@ -370,7 +375,8 @@ program EddyproRP end if !> Open biomet output file - if (index(EddyProProj%biomet_data, 'ext_') /= 0 .and. nbVars > 0) & + if ((index(EddyProProj%biomet_data, 'ext_') /= 0) .and. (nbVars > 0) & + .and. (.not. RPsetup%to_only) .and. (.not. RPsetup%pf_only)) & call InitBiometOut() !> Initialize dynamic metadata by reading the file @@ -409,7 +415,7 @@ program EddyproRP !> Check the dynamic metadata file for calibration data. !> If found, builds up time series of absorptance drifts - if (DriftCorr%method /= 'none') then + if (trim(DriftCorr%method) /= 'none') then allocate(tsDrifts(NumberOfPeriods + 1)) allocate(Calib(0:NumDynRecords)) !< elem. 0 is to alloc. start of period allocate(tmpCalib(0:NumDynRecords)) @@ -437,11 +443,11 @@ program EddyproRP !*************************************************************************** !*************************************************************************** - if (trim(adjustl(Meth%tlag)) == 'tlag_opt') then + if ((trim(Meth%tlag) == 'tlag_opt') .or. (trim(Meth%tlag) == 'maxfft')) then if (.not. RPsetup%to_onthefly) then call ReadTimelagOptFile(TOSetup%h2o_nclass) if (TOSetup%h2o_nclass > 1) & - TOSetup%h2o_class_size = floor(100d0 / TOSetup%h2o_nclass) + TOSetup%h2o_class_size = floor(100.0_dbl / TOSetup%h2o_nclass) else write(*,'(a)') ' Performing time-lag optimization:' @@ -467,8 +473,8 @@ program EddyproRP !> Count maximum number of periods for timelag optimization write(TmpString1, '(i7)') toEndTimestampIndx - toStartTimestampIndx - write(*, '(a)') ' Maximum number of flux averaging periods & - &available for time-lag optimization: ' & + write(*, '(a)') ' Maximum number of flux averaging periods ' & + // 'available for time-lag optimization: ' & // trim(adjustl(TmpString1)) !> Allocate variables that depend upon maximum number of periods @@ -513,10 +519,8 @@ program EddyproRP NumRawFiles, LatestRawFileIndx, NextRawFileIndx, skip_period) !> Averaging period advancement - if (day /= 0) then - if (EddyProProj%caller == 'console') then - write(*, '(a)', advance = 'no') '#' - else + if (day /= 0) then + if (trim(EddyProProj%caller) /= 'console') then call DisplayProgress('avrg_interval', & ' another small step to the time-lag: ', & tsStart, 'yes') @@ -528,14 +532,11 @@ program EddyproRP .or. month /= tsStart%month) then month = tsStart%month day = tsStart%day - if (EddyProProj%caller == 'console') then - write(*, '(a)') - call DisplayProgress('daily',' Importing data for ', & - tsStart, 'no') - else - call DisplayProgress('daily',' Importing data for ', & - tsStart, 'yes') - end if + ! if (trim(EddyProProj%caller) == 'console') then + ! write(*, '(a)') + ! endif + call DisplayProgress('daily',' Importing data for ', & + tsStart, 'yes') end if if (skip_period) cycle to_periods_loop @@ -555,8 +556,8 @@ program EddyproRP if (skip_period) cycle to_periods_loop !> Period skip control with message - MissingRecords = dfloat(MaxPeriodNumRecords - PeriodRecords) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - PeriodRecords, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (PeriodRecords > 0 .and. MissingRecords > RPsetup%max_lack) & cycle to_periods_loop @@ -575,6 +576,8 @@ program EddyproRP allocate(E2Set(PeriodRecords, E2NumVar)) if (.not. allocated(E2Primes)) & allocate(E2Primes(PeriodRecords, E2NumVar)) + if (.not. allocated(CorrSet)) & + allocate(CorrSet(PeriodRecords, E2NumVar)) if (.not. allocated(DiagSet)) & allocate(DiagSet(PeriodRecords, MaxNumDiag)) @@ -602,6 +605,7 @@ program EddyproRP if (skip_period) then if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) if(allocated(DiagSet)) deallocate(DiagSet) cycle to_periods_loop end if @@ -609,6 +613,7 @@ program EddyproRP if (.not. any(E2Col(co2:gas4)%present)) then if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) if(allocated(DiagSet)) deallocate(DiagSet) cycle to_periods_loop end if @@ -675,6 +680,7 @@ program EddyproRP if (skip_period) then if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) cycle to_periods_loop end if @@ -707,7 +713,8 @@ program EddyproRP Stats4 = Stats !> Apply rotations for tilt correction, if requested - call TiltCorrection('double_rotation', .false., E2Set, & + FakeGoPlanarFit = .false. + call TiltCorrection('double_rotation', FakeGoPlanarFit, E2Set, & size(E2Set, 1), size(E2Set, 2), 1, Essentials%yaw, & Essentials%pitch, Essentials%roll, .false.) @@ -730,9 +737,25 @@ program EddyproRP call AdjustTimelagOptSettings() !> Calculate and compensate time-lags - call TimeLagHandle('maxcov', E2Set, & - size(E2Set, 1), size(E2Set, 2), Essentials%actual_timelag, & - Essentials%used_timelag, Essentials%def_tlag, .true.) + !MC should this be done with E2Primes? + if (trim(Meth%tlag) == 'tlag_opt') then + call TimeLagHandle('maxcov', E2Set, & + Essentials%actual_timelag, Essentials%used_timelag, & + Essentials%def_tlag, .true.) + elseif (trim(Meth%tlag) == 'maxfft') then + if (RPsetup%out_raw(8)) then + call TimeLagHandle('maxfft', E2Set, & + Essentials%actual_timelag, Essentials%used_timelag, & + Essentials%def_tlag, .true., CorrSet) + !> Output raw dataset eighth level = cross correlations + call OutRawData(Stats%date, Stats%time, CorrSet, & + size(CorrSet, 1), size(CorrSet, 2), 8) + else + call TimeLagHandle('maxfft', E2Set, & + Essentials%actual_timelag, Essentials%used_timelag, & + Essentials%def_tlag, .true.) + endif + endif !> Calculate basic stats call BasicStats(E2Set, & @@ -758,6 +781,7 @@ program EddyproRP if (skip_period) then if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) cycle to_periods_loop end if @@ -769,6 +793,7 @@ program EddyproRP call BasicStats(E2Primes, & size(E2Primes, 1), size(E2Primes, 2), 7, .false.) if (allocated(E2Primes)) deallocate(E2Primes) + if (allocated(CorrSet)) deallocate(CorrSet) Stats7 = Stats !*************************************************************** @@ -787,11 +812,11 @@ program EddyproRP !> Store values if all conditions are met ton = ton + 1 - call AddToTimelagOptDataset(TimelagOpt, size(TimelagOpt),ton) + call AddToTimelagOptDataset(TimelagOpt, size(TimelagOpt), ton) end do to_periods_loop - write(*, '(a)') - write(*, '(a)') ' Done.' + ! write(*, '(a)') + write(*, '(a)') ' Done.' !******************************************************************* !**** RAW DATA REDUCTION FINISHES HERE. ************************* @@ -808,17 +833,27 @@ program EddyproRP allocate(toH2On(TOSetup%h2o_nclass)) !> Optimize time-lags ******* Improve readability of this subroutine interface - call OptimizeTimelags(toSet, size(toSet), tlagn, E2NumVar, toH2On, & + call OptimizeTimelags(toSet, size(toSet), tlagn, E2NumVar, toH2On, & TOSetup%h2o_nclass, TOSetup%h2o_class_size) !> Write time-lag optimization results on output file - if (.not. (Meth%tlag == 'maxcov')) & + if (.not. (trim(Meth%tlag) == 'maxcov')) & call WriteOutTimelagOptimization(tlagn, E2NumVar, & toH2On, TOSetup%h2o_nclass, TOSetup%h2o_class_size) if (allocated(toH2On)) deallocate(toH2On) write(*,'(a)') ' Time-lag optimization session terminated.' write(*,'(a)') + + if (RPsetup%to_only) then + if (EddyProProj%run_env == 'desktop') & + del_status = system(trim(comm_rmdir) // ' "' & + // trim(adjustl(TmpDir)) // '"') + + write(*,'(a)') '' + write(*,'(a)') ' Finish after time-lag optimization.' + stop + endif end if end if @@ -855,7 +890,7 @@ program EddyproRP end if !> Allocate variables depending upon number of sectors - if (.not. allocated(pfNumElem)) & + if (.not. allocated(pfNumElem)) & allocate(pfNumElem(PFSetup%num_sec)) if (PFSetup%subperiod) then @@ -883,8 +918,8 @@ program EddyproRP !> Count maximum number of periods for planar fit write(TmpString1, '(i7)') & pfEndTimestampIndx - pfStartTimestampIndx - write(*, '(a)') ' Maximum number of & - &flux averaging periods available for planar-fit: ' & + write(*, '(a)') ' Maximum number of ' & + // 'flux averaging periods available for planar-fit: ' & // trim(adjustl(TmpString1)) !> Allocate variables that depend upon maximum number of @@ -908,7 +943,6 @@ program EddyproRP Col = BypassCol else Col = NullCol - end if !> Normal exit instruction: either the last period @@ -930,9 +964,7 @@ program EddyproRP !> Averaging period advancement if (day /= 0) then - if (EddyProProj%caller == 'console') then - write(*, '(a)', advance = 'no') '#' - else + if (trim(EddyProProj%caller) /= 'console') then call DisplayProgress('avrg_interval', & ' another small step to the planar-fit: ', & tsStart, 'yes') @@ -944,14 +976,11 @@ program EddyproRP .or. month /= tsStart%month) then month = tsStart%month day = tsStart%day - if (EddyProProj%caller == 'console') then - write(*, '(a)') - call DisplayProgress('daily', & - ' Importing wind data for ', tsStart, 'no') - else - call DisplayProgress('daily', & - ' Importing wind data for ', tsStart, 'yes') - end if + ! if (trim(EddyProProj%caller) == 'console') then + ! write(*, '(a)') + ! endif + call DisplayProgress('daily', & + ' Importing wind data for ', tsStart, 'yes') end if if (skip_period) cycle pf_periods_loop @@ -963,7 +992,7 @@ program EddyproRP !> On exit, LatestRawFileIndx contains the index of !> the latest file used call ImportCurrentPeriod(tsStart, tsEnd, & - RawFileList, NumRawFiles, NextRawFileIndx, BypassCol, & + RawFileList, NumRawFiles, NextRawFileIndx, BypassCol, & MaxNumFileRecords, MetaIsNeeded, & .false., .false., & Raw, size(Raw, 1), size(Raw, 2), PeriodRecords, & @@ -972,8 +1001,8 @@ program EddyproRP if (skip_period) cycle pf_periods_loop !> Period skip control with message - MissingRecords = dfloat(MaxPeriodNumRecords - PeriodRecords) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - PeriodRecords, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (PeriodRecords > 0 .and. MissingRecords > RPsetup%max_lack) & cycle pf_periods_loop @@ -1109,7 +1138,7 @@ program EddyproRP !> Check if wind components are within specified limits where (dsqrt(pfWind(1:pfn, u)**2 + pfWind(1:pfn, v)**2) < PFSetup%u_min & - .or. dsqrt(pfWind(1:pfn, u)**2 + pfWind(1:pfn, v)**2) > 20d0 & + .or. dsqrt(pfWind(1:pfn, u)**2 + pfWind(1:pfn, v)**2) > 20.0_dbl & .or. pfWind(1:pfn, w) > PFSetup%w_max) pfWind(1:pfn, u) = error pfWind(1:pfn, v) = error @@ -1136,7 +1165,7 @@ program EddyproRP !> Some logging write(LogInteger, '(i6)') PFSetup%num_sec write(*, '(a)') ' Calculating planar fit rotation matrices for ' & - // trim(adjustl(LogInteger)) // ' sector(s).' + // trim(adjustl(LogInteger)) // ' sector(s).' !> Loop over wind sectors GoPlanarFit = .true. @@ -1166,7 +1195,7 @@ program EddyproRP call PlanarFitAuxParams(pfWind, pfNumElem(sec), Mat, pfVec) deallocate(pfWind) - if (Meth%rot(1:len_trim(Meth%rot)) == 'planar_fit') then + if (trim(Meth%rot) == 'planar_fit') then !> Invert matrix --> Mat^(-1) call MatrixInversion(Mat, 3, SingMat) @@ -1180,12 +1209,11 @@ program EddyproRP end if !> Calculate plane coefficients: PFb = Mat^(-1) * pfVec - PFb(:, sec) = 0d0 + PFb(:, sec) = 0.0_dbl do i = u, w - PFb(:, sec) = PFb(:, sec) + dble(Mat(:, i)) * pfVec(i) + PFb(:, sec) = PFb(:, sec) + real(Mat(:, i), dbl) * pfVec(i) end do - elseif (Meth%rot(1:len_trim(Meth%rot)) & - == 'planar_fit_no_bias') then + elseif (trim(Meth%rot) == 'planar_fit_no_bias') then !> Define tensors of 2 elements (out of the 3-elements ones) Mat2d(1,1:2) = Mat(2, 2:3) Mat2d(2,1:2) = Mat(3, 2:3) @@ -1204,12 +1232,12 @@ program EddyproRP end if !> Calculate plane coefficients: PFb = Mat^(-1) * pfVec - PFb2d(:, sec) = 0d0 + PFb2d(:, sec) = 0.0_dbl do i = 1, 2 PFb2d(:, sec) = PFb2d(:, sec) & - + dble(Mat2d(:, i)) * pfVec2d(i) + + real(Mat2d(:, i), dbl) * pfVec2d(i) end do - PFb(1, sec) = 0d0 + PFb(1, sec) = 0.0_dbl PFb(2:3, sec) = PFb2d(1:2, sec) end if @@ -1236,6 +1264,16 @@ program EddyproRP if (allocated (pfNumElem)) deallocate(pfNumElem) write(*,'(a)') ' Planar Fit session terminated.' write(*,'(a)') + + if (RPsetup%pf_only) then + if (EddyProProj%run_env == 'desktop') & + del_status = system(trim(comm_rmdir) // ' "' & + // trim(adjustl(TmpDir)) // '"') + + write(*,'(a)') + write(*,'(a)') ' Finish after planar fit.' + stop + endif end if else if (.not. allocated(GoPlanarFit)) allocate(GoPlanarFit(PFSetup%num_sec)) @@ -1281,7 +1319,7 @@ program EddyproRP !******************** DEFINITION OF CALIBRATION EVENTS ********************* !*************************************************************************** !*************************************************************************** - if (DriftCorr%method /= 'none' .and. nCalibEvents > 0) then + if (trim(DriftCorr%method) /= 'none' .and. nCalibEvents > 0) then write(*,'(a)') ' Elaborating IRGA calibration-check history..' !> Loop on periods to be processed @@ -1370,13 +1408,13 @@ program EddyproRP if (skip_period) cycle drift_loop !> Period skip control with message - MissingRecords = dfloat(MaxPeriodNumRecords - PeriodRecords) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - PeriodRecords, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (PeriodRecords > 0 & .and. MissingRecords > RPsetup%max_lack) cycle drift_loop !> Calculate reference counts - call ReferenceCounts(dble(Raw), size(Raw, 1), size(Raw, 2)) + call ReferenceCounts(real(Raw, dbl), size(Raw, 1), size(Raw, 2)) !> Special case of first file in the dataset: used to initialize !> drift history assuming cleaned instrument at the beginning @@ -1413,7 +1451,7 @@ program EddyproRP Calib(i+1)%rf = tmpCalib(i)%rf end do !> For Calib(0) (beginning of dataset), set at clean instrument - Calib(0)%offset = 0d0 + Calib(0)%offset = 0.0_dbl Calib(0)%ri = error Calib(0)%rf = error @@ -1422,7 +1460,7 @@ program EddyproRP !> Artificially set initial ri to the mean value at July 23, !> when H2O signal was actually "clean", i.e. gives !> same concentration of LI-7000. -!Calib(1)%ri(h2o) = 34703.78d0 +!Calib(1)%ri(h2o) = 34703.78_dbl end if @@ -1502,8 +1540,8 @@ program EddyproRP !> Some logging if (EddyProProj%run_mode /= 'md_retrieval') then write(*, '(a)') - call hms_current_print(' ',': processing new & - &flux averaging period', .true.) + call hms_current_print(' ',': processing new ' & + // 'flux averaging period', .true.) write(*, '(a)') ' From: ' & // trim(date) // ' ' // trim(time) write(*, '(a)') ' To: ' & @@ -1554,7 +1592,7 @@ program EddyproRP if (skip_period) then if (EddyProProj%run_mode /= 'md_retrieval') then call ExceptionHandler(53) - if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() end if call hms_delta_print(PeriodSkipMessage,'') cycle periods_loop @@ -1573,8 +1611,8 @@ program EddyproRP !> If it's running in metadata retriever mode, !> create a dummy dataset 1 minute long if (EddyProProj%run_mode == 'md_retrieval') then - PeriodRecords = nint(Metadata%ac_freq * Metadata%file_length * 60d0) - Raw = 1d0 + PeriodRecords = nint(Metadata%ac_freq * Metadata%file_length * 60.0_dbl) + Raw = 1.0_dbl NumUserVar = 0 else !> Retrieve biomet data for current period @@ -1586,7 +1624,7 @@ program EddyproRP call BiometRetrieveEmbeddedData(EmbBiometDataExist, .true.) !> Open biomet output file in case of embedded biomet files - if(initializeBiometOut .and. nbVars > 0) then + if (initializeBiometOut .and. nbVars > 0) then call InitBiometOut() initializeBiometOut = .false. end if @@ -1605,23 +1643,23 @@ program EddyproRP !> Period skip control if (skip_period) then - if (EddyProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddyProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() call hms_delta_print(PeriodSkipMessage,'') cycle periods_loop end if !> Number of valid records imported from raw files Essentials%n_in = & - CountRecordsAndValues(dble(Raw), size(Raw, 1), size(Raw, 2)) + CountRecordsAndValues(real(Raw, dbl), size(Raw, 1), size(Raw, 2)) !> Some logging write(*, '(a, i6)') ' Number of valid records available for this period: ', Essentials%n_in !> Period skip control - MissingRecords = dfloat(MaxPeriodNumRecords - Essentials%n_in) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - Essentials%n_in, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (Essentials%n_in > 0 .and. MissingRecords > RPsetup%max_lack) then - if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() call ExceptionHandler(58) call hms_delta_print(PeriodSkipMessage,'') cycle periods_loop @@ -1631,13 +1669,13 @@ program EddyproRP if (RPsetup%filter_by_raw_flags) & call FilterDatasetForFlags(Col, Raw, size(Raw, 1), size(Raw, 2)) Essentials%n_after_custom_flags = & - CountRecordsAndValues(dble(Raw), size(Raw, 1), size(Raw, 2)) + CountRecordsAndValues(real(Raw, dbl), size(Raw, 1), size(Raw, 2)) !> Period skip control - MissingRecords = dfloat(MaxPeriodNumRecords - Essentials%n_after_custom_flags) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - Essentials%n_after_custom_flags, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (MissingRecords > RPsetup%max_lack) then - if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() call ExceptionHandler(58) call hms_delta_print(PeriodSkipMessage,'') cycle periods_loop @@ -1645,8 +1683,8 @@ program EddyproRP !> If drift correction is to be performed with signal strength !> proxy, calculate mean refCounts for current period - if (DriftCorr%method == 'signal_strength') & - call ReferenceCounts(dble(Raw), size(Raw, 1), size(Raw, 2)) + if (trim(DriftCorr%method) == 'signal_strength') & + call ReferenceCounts(real(Raw, dbl), size(Raw, 1), size(Raw, 2)) end if !*********************************************************************** @@ -1654,11 +1692,13 @@ program EddyproRP !*********************************************************************** !> Allocate arrays for actual data processing - if (.not. allocated(E2Set)) & + if (.not. allocated(E2Set)) & allocate(E2Set(PeriodRecords, E2NumVar)) if (.not. allocated(E2Primes)) & allocate(E2Primes(PeriodRecords, E2NumVar)) - if (.not. allocated(DiagSet)) & + if (.not. allocated(CorrSet)) & + allocate(CorrSet(PeriodRecords, E2NumVar)) + if (.not. allocated(DiagSet)) & allocate(DiagSet(PeriodRecords, MaxNumDiag)) !> Define EddyPro set of variables for the following processing @@ -1725,14 +1765,15 @@ program EddyproRP Essentials%n_after_wdf = & CountRecordsAndValues(E2Set, size(E2Set, 1), size(E2Set, 2)) PeriodActualRecords = Essentials%n_after_wdf - + !> Period skip control - MissingRecords = dfloat(MaxPeriodNumRecords - Essentials%n_after_wdf) & - / dfloat(MaxPeriodNumRecords) * 100d0 + MissingRecords = real(MaxPeriodNumRecords - Essentials%n_after_wdf, dbl) & + / real(MaxPeriodNumRecords, dbl) * 100.0_dbl if (MissingRecords > RPsetup%max_lack) then - if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) if(allocated(UserSet)) deallocate(UserSet) if(allocated(UserPrimes)) deallocate(UserPrimes) call ExceptionHandler(58) @@ -1756,7 +1797,7 @@ program EddyproRP !> Now that variables have been properly assigned, can initialize !> main output files. This is done also if run is in !> metadata retriever mode - if(initialize) then + if (initialize) then call InitOutFiles_rp() initialize = .false. end if @@ -1784,7 +1825,7 @@ program EddyproRP !> Based on mean value, if sonic (or fast) temperature !> is out-ranged, search alternative one. - if (Stats1%Mean(ts) < 220d0 .or. Stats1%Mean(ts) > 340d0) & + if (Stats1%Mean(ts) < 220.0_dbl .or. Stats1%Mean(ts) > 340.0_dbl) & call ReplaceSonicTemperature(E2Set, size(E2Set, 1), & size(E2Set, 2), UserSet, size(UserSet, 1), size(UserSet, 2)) @@ -1803,9 +1844,10 @@ program EddyproRP !> If either u, v or w have been eliminated, !> stops processing this period if (skip_period) then - if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet(suffixOutString) + if (EddYProProj%out_fluxnet) call WriteOutFluxnetOnlyBiomet() if(allocated(E2Set)) deallocate(E2Set) if(allocated(E2Primes)) deallocate(E2Primes) + if(allocated(CorrSet)) deallocate(CorrSet) if(allocated(UserSet)) deallocate(UserSet) if(allocated(UserPrimes)) deallocate(UserPrimes) call ExceptionHandler(59) @@ -1816,10 +1858,10 @@ program EddyproRP !> If got until here, incrase number of ok periods NumberOfOkPeriods = NumberOfOkPeriods + 1 - - !> Count values available for each variable and value pairs + + !> Count values available for each variable and value pairs !> available for each main w-covariance - !>> + !>> Essentials%n = ierror Essentials%n_wcov = ierror !> Wind data @@ -1867,8 +1909,8 @@ program EddyproRP call CrossWindCorr(E2Col(u), E2Set, & size(E2Set, 1), size(E2Set, 2), .true.) else - write(*,'(a)') ' Cross-wind correction not requested & - &or not applicable' + write(*,'(a)') ' Cross-wind correction not requested ' & + // 'or not applicable' end if !> Output raw dataset third level @@ -1914,7 +1956,7 @@ program EddyproRP end if !> ===== 4.1 CORRECTION OF CALIBRATION DRIFTS ====================== - if (DriftCorr%method /= 'none' .and. nCalibEvents /= 0) & + if (trim(DriftCorr%method) /= 'none' .and. nCalibEvents /= 0) & call DriftCorrection(E2Set, size(E2Set, 1), size(E2Set, 2), & E2Col, size(E2Col), nCalibEvents, tsStart) @@ -1925,7 +1967,7 @@ program EddyproRP !> ===== 5. TILT CORRECTION ======================================== !> Apply rotations for tilt correction, if requested - call TiltCorrection(Meth%rot, GoPlanarFit, E2Set, & + call TiltCorrection(trim(Meth%rot), GoPlanarFit, E2Set, & size(E2Set, 1), size(E2Set, 2), PFSetup%num_sec, & Essentials%yaw, Essentials%pitch, Essentials%roll, .true.) @@ -1952,14 +1994,14 @@ program EddyproRP !> ===== 6. TIMELAG COMPENSATION ================================== !> If available, for files others than GHG, replace flow rate !> of LI-7200 provided by user with mean value from raw files - if (EddyProProj%ftype /= 'licor_ghg' & + if (trim(EddyProProj%ftype) /= 'licor_ghg' & .or. EddyProProj%use_extmd_file) then do i = 1, E2NumVar if (NumUserVar > 0) then do j = 1, NumUserVar - if (UserCol(j)%var == 'flowrate' & + if (trim(UserCol(j)%var) == 'flowrate' & .and. UserCol(j)%instr%model == E2Col(i)%instr%model & - .and. UserStats%Mean(j) /= 0d0 & + .and. UserStats%Mean(j) /= 0.0_dbl & .and. UserStats%Mean(j) /= error) then E2Col(i)%instr%tube_f = UserStats%Mean(j) exit @@ -1976,11 +2018,20 @@ program EddyproRP call SetTimelags() !> Calculate and compensate time-lags - if (TimeLagOptSelected) Meth%tlag = 'maxcov&default' - call TimeLagHandle(Meth%tlag(1:len_trim(Meth%tlag)), E2Set, & - size(E2Set, 1), size(E2Set, 2), Essentials%actual_timelag, & - Essentials%used_timelag, Essentials%def_tlag, .false.) - if (TimeLagOptSelected) Meth%tlag = 'tlag_opt' + ! if (TimeLagOptSelected) Meth%tlag = 'maxcov&default' + !MC should this be done with E2Primes? + if ((trim(Meth%tlag) == 'maxfft') .and. RPsetup%out_raw(8)) then + call TimeLagHandle(trim(Meth%tlag), E2Set, & + Essentials%actual_timelag, Essentials%used_timelag, & + Essentials%def_tlag, .false., CorrSet) + !> Output raw dataset eighth level = cross correlations + call OutRawData(Stats%date, Stats%time, CorrSet, & + size(CorrSet, 1), size(CorrSet, 2), 8) + else + call TimeLagHandle(trim(Meth%tlag), E2Set, & + Essentials%actual_timelag, Essentials%used_timelag, & + Essentials%def_tlag, .false.) + endif !> ===== 6.1 FILTERING MOLAR DENSITY DATA FOR ABSOLUTE LIMITS TEST ==================== if (EddyProProj%run_mode /= 'md_retrieval') then @@ -2115,6 +2166,7 @@ program EddyproRP SpecSet(:, u:gas4), size(SpecSet, 1), gas4) if (allocated(SpecSet)) deallocate(SpecSet) if (allocated(E2Primes)) deallocate(E2Primes) + if (allocated(CorrSet)) deallocate(CorrSet) !> Reset stats to Stats7, after the parenthesis !> of spectral analysis @@ -2124,6 +2176,7 @@ program EddyproRP end if end if if (allocated(E2Primes)) deallocate(E2Primes) + if (allocated(CorrSet)) deallocate(CorrSet) if (allocated(UserPrimes)) deallocate(UserPrimes) if (allocated(UserSet)) deallocate(UserSet) @@ -2172,7 +2225,7 @@ program EddyproRP call BandPassSpectralCorrections(E2Col(u)%Instr%height, & Metadata%d, E2Col(u:gas4)%present, Ambient%WS, Ambient%Ta, & Ambient%zL, Metadata%ac_freq, RPsetup%avrg_len, & - Metadata%logger_swver, Meth%det, & + Metadata%logger_swver, trim(Meth%det), & RPsetup%Tconst, .true., E2Col(u:GHGNumVar)%instr, 1) !> Calculate fluxes at Level 1 @@ -2182,7 +2235,7 @@ program EddyproRP call Fluxes23_rp() !> Footprint estimation - foot_model_used = Meth%foot(1:len_trim(Meth%foot)) + foot_model_used = trim(Meth%foot) call FootprintHandle(Stats%Cov(w, w), Ambient%us, & Ambient%zL, Ambient%WS, Ambient%L, & E2Col(u)%Instr%height, Metadata%d, Metadata%z0) @@ -2216,7 +2269,7 @@ program EddyproRP call QualityFlags(Flux2, StDiff, DtDiff, STFlg, DTFlg, QCFlag, .true.) !> Write details on output files if requested - if(RPsetup%out_qc_details .and. Meth%qcflag /= 'none') & + if(RPsetup%out_qc_details .and. trim(Meth%qcflag) /= 'none') & call WriteOutQCDetails(suffixOutString, StDiff, DtDiff, STFlg, DTFlg) !> Update values of AGC and RSSI as available @@ -2243,6 +2296,7 @@ program EddyproRP if (allocated(UserCol)) deallocate(UserCol) if (allocated(E2Set)) deallocate(E2Set) if (allocated(E2Primes)) deallocate(E2Primes) + if (allocated(CorrSet)) deallocate(CorrSet) if (allocated(DiagSet)) deallocate(DiagSet) if (allocated(UserSet)) deallocate(UserSet) end do periods_loop @@ -2289,8 +2343,8 @@ program EddyproRP !> Creating datasets from output files write(*, '(a)') - write(*, '(a)') ' Raw data processing terminated. & - &Creating continuous datasets if necessary..' + write(*, '(a)') ' Raw data processing terminated. ' & + // 'Creating continuous datasets if necessary..' if (make_dataset_common) then call CreateDatasetsCommon(MasterTimeSeries, size(MasterTimeSeries), & @@ -2323,7 +2377,7 @@ program EddyproRP end if !> Delete tmp folder if running in embedded mode - if(EddyProProj%run_env == 'desktop') & + if (EddyProProj%run_env == 'desktop') & del_status = system(trim(comm_rmdir) // ' "' & // trim(adjustl(TmpDir)) // '"') diff --git a/src/src_rp/fft4/rfftb.F b/src/src_rp/fft4/rfftb.F deleted file mode 100644 index c8b6ef3..0000000 --- a/src/src_rp/fft4/rfftb.F +++ /dev/null @@ -1,454 +0,0 @@ -!*************************************************************************** -! rfttb.F -! ------- -! \brief inverse real FTT (Fourier synthesis) -! \author Paul B. Swarztrauber -! \note This routine is part of FFTPACK, which is part of SLATEC -! SLATEC is Public Domain Software, see for example: -! https://gams.nist.gov/cgi-bin/serve.cgi/Package/SLATEC/ -! and -! https://en.wikipedia.org/wiki/SLATEC#Project_history_and_current_status -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** - - SUBROUTINE RFFTB (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RFFTB1 (N,C,CH,WA,WIFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,WIFAC(2) - NF = WIFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = WIFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2 (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA SQRT2 /1.414213562373095/ - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! diff --git a/src/src_rp/fft4/rfftf.F b/src/src_rp/fft4/rfftf.F deleted file mode 100644 index 47ed1d5..0000000 --- a/src/src_rp/fft4/rfftf.F +++ /dev/null @@ -1,445 +0,0 @@ -!*************************************************************************** -! rfttf.F -! ------- -! \brief direct real FTT (Fourier decomposition) -! \author Paul B. Swarztrauber -! \note This routine is part of FFTPACK, which is part of SLATEC -! SLATEC is Public Domain Software, see for example: -! https://gams.nist.gov/cgi-bin/serve.cgi/Package/SLATEC/ -! and -! https://en.wikipedia.org/wiki/SLATEC#Project_history_and_current_status -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** - SUBROUTINE RFFTF (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RFFTF1 (N,C,CH,WA,WIFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,WIFAC(2) - NF = WIFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = WIFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , - 1 WA1(1) ,WA2(1) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA HSQT2 /.7071067811865475/ - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - END -! -!---------------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------------- -! - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END diff --git a/src/src_rp/fft4/rffti.F b/src/src_rp/fft4/rffti.F deleted file mode 100644 index e3e2b4a..0000000 --- a/src/src_rp/fft4/rffti.F +++ /dev/null @@ -1,84 +0,0 @@ -!*************************************************************************** -! rfttb.F -! ------- -! \brief initialze a work array for RFFTF and RFFTB -! \author Paul B. Swarztrauber -! \note This routine is part of FFTPACK, which is part of SLATEC -! SLATEC is Public Domain Software, see for example: -! https://gams.nist.gov/cgi-bin/serve.cgi/Package/SLATEC/ -! and -! https://en.wikipedia.org/wiki/SLATEC#Project_history_and_current_status -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** - SUBROUTINE RFFTI (N,WSAVE) - DIMENSION WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END -! -!----------------------------------------------------------------------------------------- -!----------------------------------------------------------------------------------------- -! - - SUBROUTINE RFFTI1 (N,WA,WIFAC) - DIMENSION WA(1),WIFAC(3),NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - WIFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - WIFAC(IB+2) = WIFAC(IB+1) - 106 CONTINUE - WIFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - WIFAC(1) = N - WIFAC(2) = NF - TPI = 6.28318530717959 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 110 K1=1,NFM1 - IP = WIFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0. - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1. - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END diff --git a/src/src_rp/fftpack/API-doc-FORD-file.md b/src/src_rp/fftpack/API-doc-FORD-file.md new file mode 100644 index 0000000..03e8cb7 --- /dev/null +++ b/src/src_rp/fftpack/API-doc-FORD-file.md @@ -0,0 +1,77 @@ +--- +project: fftpack +summary: A opensource package fftpack v4.0.0 for (modern) Fortran +src_dir: src/ +output_dir: API-doc +page_dir: doc/ +media_dir: doc/media +display: public + protected +source: true +proc_internals: true +md_extensions: markdown.extensions.toc +graph: true +graph_maxnodes: 250 +graph_maxdepth: 5 +coloured_edges: true +sort: permission-alpha +extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html + iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING +print_creation_date: true +creation_date: %Y-%m-%d %H:%M %z +project_github: https://github.com/fortran-lang/fftpack +license: by-sa +author: Paul N. Swarztrauber & fftpack contributors +github: https://github.com/fortran-lang/fftpack +dbg: true +parallel: 4 +--- + +[TOC] + +@warning This API documentation for the fortran-lang/fftpack v4.0.0 is a work in progress. + +Fortran FFTPACK API Documentation +================================= + +This is the main API documentation landing page generated by [FORD]. +The documentation for comment markup in source code, running [FORD] and the [FORD project file] are all maintained on the [FORD wiki]. + +[FORD]: https://github.com/Fortran-FOSS-Programmers/ford#readme +[FORD wiki]: https://github.com/Fortran-FOSS-Programmers/ford/wiki +[FORD project file]: https://github.com/fortran-lang/fftpack/blob/HEAD/API-doc-FORD-file.md + +A package of fortran subprograms for the fast fourier transform of periodic and other symmetric sequences. + +## Getting started +### Get the code +```bash +git clone https://github.com/fortran-lang/fftpack.git +cd fftpack +``` + +### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) +Fortran Package Manager (fpm) is a great package manager and build system for Fortran. +You can build using provided `fpm.toml`: +```bash +fpm build --flag "-O2" +fpm test --flag "-O2" --list +fpm test --flag "-O2" +``` +To use `fftpack` within your `fpm` project, add the following to your `fpm.toml` file: +```toml +[dependencies] +fftpack = { git="https://github.com/fortran-lang/fftpack.git" } +``` + +## Build with Make +Alternatively, you can build using provided `Makefile`: +```bash +make +``` + +## Links +[netlib/dfftpack1.0(fftpack4.0)](http://www.netlib.org/fftpack/) +[Documents of fft routines in GNU/gsl based on `netlib/fftpack`](https://www.gnu.org/software/gsl/doc/html/fft.html#) +[Documents of scipy.fftpack](https://docs.scipy.org/doc/scipy/reference/fftpack.html) +[NACR/FFTPACK 5.1](https://www2.cisl.ucar.edu/resources/legacy/fft5) diff --git a/src/src_rp/fftpack/Makefile b/src/src_rp/fftpack/Makefile new file mode 100644 index 0000000..bf5cf1b --- /dev/null +++ b/src/src_rp/fftpack/Makefile @@ -0,0 +1,23 @@ +# Fortran fftpack Makefile + +LIB = dfftpack + +FC = gfortran +FFLAGS = -O2 + +export LIB +export FC +export FFLAGS + +.PHONY: all clean test + +all: + $(MAKE) -f Makefile --directory=src + $(MAKE) -f Makefile --directory=test + +test: + $(MAKE) -f Makefile --directory=test + +clean: + $(MAKE) -f Makefile clean --directory=src + $(MAKE) -f Makefile clean --directory=test \ No newline at end of file diff --git a/src/src_rp/fftpack/README.md b/src/src_rp/fftpack/README.md new file mode 100644 index 0000000..91845e2 --- /dev/null +++ b/src/src_rp/fftpack/README.md @@ -0,0 +1,38 @@ +# FFTPACK + +[![Actions Status](https://github.com/fortran-lang/fftpack/workflows/fpm/badge.svg)](https://github.com/fortran-lang/fftpack/actions) + +A package of fortran subprograms for the fast fourier transform of periodic and other symmetric sequences. + +## Getting started +### Get the code +```bash +git clone https://github.com/fortran-lang/fftpack.git +cd fftpack +``` + +### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) +Fortran Package Manager (fpm) is a package manager and build system for Fortran. +You can build using provided `fpm.toml`: +```bash +fpm build +fpm test --list +fpm test +``` +To use `fftpack` within your `fpm` project, add the following to your `fpm.toml` file: +```toml +[dependencies] +fftpack = { git="https://github.com/fortran-lang/fftpack.git" } +``` + +## Build with Make +Alternatively, you can build using provided `Makefile`: +```bash +make +``` + +## Links +[netlib/dfftpack1.0(fftpack4.0)](http://www.netlib.org/fftpack/) +[Documents of fft routines in GNU/gsl based on `netlib/fftpack`](https://www.gnu.org/software/gsl/doc/html/fft.html#) +[Documents of scipy.fftpack](https://docs.scipy.org/doc/scipy/reference/fftpack.html) +[NACR/FFTPACK 5.1](https://www2.cisl.ucar.edu/resources/legacy/fft5) diff --git a/src/src_rp/fftpack/doc/Makefile b/src/src_rp/fftpack/doc/Makefile new file mode 100644 index 0000000..952e704 --- /dev/null +++ b/src/src_rp/fftpack/doc/Makefile @@ -0,0 +1,96 @@ +# Several changes made by HCP so this would build without trouble +# on a Linux/g77 system. +# (1) changed step to build library to use ar instead of update +# (update must mean something different on someone elses Unix.) +# (2) Added make clean step +# (3) In test step, changed a.out to ./a.out for cautious folk who don't +# have "." in their PATH. +# (4) Change FFLAGS from -O to -O2 -funroll-loops +# (5) Specify FC=gcc in case /usr/bin/f77 is not a link to g77 +# (as it won't be if you have f77reorder installed) +# (6) Added targets shared and installshared to make and install a shared +# version of the library. You need /usr/local/lib in /etc/ld.so.conf +# for this to work +# (7) Modified names for dble prec version +LIB=dfftpack + +# Use these lines for Linux/g77 +FC=g77 +FFLAGS=-O2 -funroll-loops -fexpensive-optimizations + +# Use these lines for Solaris +#FC=f77 +#FFLAGS=-fast -O5 + +OBJ=\ +zfftb.o\ +cfftb1.o\ +zfftf.o\ +cfftf1.o\ +zffti.o\ +cffti1.o\ +dcosqb.o\ +cosqb1.o\ +dcosqf.o\ +cosqf1.o\ +dcosqi.o\ +dcost.o\ +dcosti.o\ +ezfft1.o\ +dzfftb.o\ +dzfftf.o\ +dzffti.o\ +passb.o\ +passb2.o\ +passb3.o\ +passb4.o\ +passb5.o\ +passf.o\ +passf2.o\ +passf3.o\ +passf4.o\ +passf5.o\ +radb2.o\ +radb3.o\ +radb4.o\ +radb5.o\ +radbg.o\ +radf2.o\ +radf3.o\ +radf4.o\ +radf5.o\ +radfg.o\ +dfftb.o\ +rfftb1.o\ +dfftf.o\ +rfftf1.o\ +dffti.o\ +rffti1.o\ +dsinqb.o\ +dsinqf.o\ +dsinqi.o\ +dsint.o\ +sint1.o\ +dsinti.o + +lib$(LIB).a: $(OBJ) + ar -rcs lib$(LIB).a $(OBJ) + +shared:$(OBJ) + $(FC) -shared -o lib$(LIB).so $(OBJ) + +install: lib$(LIB).a + mv lib$(LIB).a /usr/local/lib + rm *.o + +installshared:lib$(LIB).so + mv lib$(LIB).so /usr/local/lib + rm *.o + ldconfig + +test: test.o + $(FC) test.o -L./ -l$(LIB) + time ./a.out + +clean: + rm -f -r *.o *.a *.so diff --git a/src/src_rp/fftpack/doc/README b/src/src_rp/fftpack/doc/README new file mode 100644 index 0000000..4780f1a --- /dev/null +++ b/src/src_rp/fftpack/doc/README @@ -0,0 +1,31 @@ + DFFTPACK V1.0 +***************************************************************** + A Double precision clone by Hugh C. Pumphrey of: + FFTPACK + version 4 april 1985 + +The gzipped tar file dp.tgz contains a complete copy of the FORTRAN +sources of fftpack, with everything converted to double precision. If +you do + +gunzip dp.tgz +tar xvf dfftpack.tar + +You will get a directory called dfftpack with all the source code in +it. There is also: + +(*) a Makefile which I have tweaked to work on modern Linux and Solaris +systems. The comments in this file document the changes made. + +(*) a file doc which was supplied with fftpack and which has been +altered to reflect the changes made in the change to double precision. + +(*) A file doc.double which details the changes I made to the source code + +Please send any comments or bug reports to hcp@met.ed.ac.uk . Please +also report if you get dfftpack to build successfully on any system +other than Linux or Solaris. + +The original FFTPACK was public domain, so dfftpack is public domain +too. It is released in the hope it will be useful to someone. There is +no warranty of any sort covering this software. diff --git a/src/src_rp/fftpack/doc/doc b/src/src_rp/fftpack/doc/doc new file mode 100644 index 0000000..9457147 --- /dev/null +++ b/src/src_rp/fftpack/doc/doc @@ -0,0 +1,868 @@ + DFFTPACK V1.0 +***************************************************************** + + A Double precision clone by Hugh C. Pumphrey of: + + FFTPACK + version 4 april 1985 + + a package of fortran subprograms for the fast fourier + transform of periodic and other symmetric sequences + + by + + paul n swarztrauber + + national center for atmospheric research boulder,colorado 80307 + + which is sponsored by the national science foundation + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + + +this package consists of programs which perform fast fourier +transforms for both double complex and (double precision) real +periodic sequences and certain other symmetric sequences that are +listed below. + +1. dffti initialize dfftf and dfftb +2. dfftf forward transform of a real periodic sequence +3. dfftb backward transform of a real coefficient array + +4. dzffti initialize dzfftf and dzfftb +5. dzfftf a simplified real periodic forward transform +6. dzfftb a simplified real periodic backward transform + +7. dsinti initialize dsint +8. dsint sine transform of a real odd sequence + +9. dcosti initialize dcost +10. dcost cosine transform of a real even sequence + +11. dsinqi initialize dsinqf and dsinqb +12. dsinqf forward sine transform with odd wave numbers +13. dsinqb unnormalized inverse of dsinqf + +14. dcosqi initialize dcosqf and dcosqb +15. dcosqf forward cosine transform with odd wave numbers +16. dcosqb unnormalized inverse of dcosqf + +17. zffti initialize zfftf and zfftb +18. zfftf forward transform of a double complex periodic sequence +19. zfftb unnormalized inverse of zfftf + + +****************************************************************** + +subroutine dffti(n,wsave) + + **************************************************************** + +subroutine dffti initializes the array wsave which is used in +both dfftf and dfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. + +output parameter + +wsave a work array which must be dimensioned at least 2*n+15. + the same work array can be used for both dfftf and dfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of dfftf or dfftb. + +****************************************************************** + +subroutine dfftf(n,r,wsave) + +****************************************************************** + +subroutine dfftf computes the fourier coefficients of a real +perodic sequence (fourier analysis). the transform is defined +below at output parameter r. + +input parameters + +n the length of the array r to be transformed. the method + is most efficient when n is a product of small primes. + n may change so long as different work arrays are provided + +r a real array of length n which contains the sequence + to be transformed + +wsave a work array which must be dimensioned at least 2*n+15. + in the program that calls dfftf. the wsave array must be + initialized by calling subroutine dffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by dfftf and dfftb. + + +output parameters + +r r(1) = the sum from i=1 to i=n of r(i) + + if n is even set l =n/2 , if n is odd set l = (n+1)/2 + + then for k = 2,...,l + + r(2*k-2) = the sum from i = 1 to i = n of + + r(i)*cos((k-1)*(i-1)*2*pi/n) + + r(2*k-1) = the sum from i = 1 to i = n of + + -r(i)*sin((k-1)*(i-1)*2*pi/n) + + if n is even + + r(n) = the sum from i = 1 to i = n of + + (-1)**(i-1)*r(i) + + ***** note + this transform is unnormalized since a call of dfftf + followed by a call of dfftb will multiply the input + sequence by n. + +wsave contains results which must not be destroyed between + calls of dfftf or dfftb. + + +****************************************************************** + +subroutine dfftb(n,r,wsave) + +****************************************************************** + +subroutine dfftb computes the real perodic sequence from its +fourier coefficients (fourier synthesis). the transform is defined +below at output parameter r. + +input parameters + +n the length of the array r to be transformed. the method + is most efficient when n is a product of small primes. + n may change so long as different work arrays are provided + +r a real array of length n which contains the sequence + to be transformed + +wsave a work array which must be dimensioned at least 2*n+15. + in the program that calls dfftb. the wsave array must be + initialized by calling subroutine dffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by dfftf and dfftb. + + +output parameters + +r for n even and for i = 1,...,n + + r(i) = r(1)+(-1)**(i-1)*r(n) + + plus the sum from k=2 to k=n/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) + + for n odd and for i = 1,...,n + + r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) + + ***** note + this transform is unnormalized since a call of dfftf + followed by a call of dfftb will multiply the input + sequence by n. + +wsave contains results which must not be destroyed between + calls of dfftb or dfftf. + + +****************************************************************** + +subroutine dzffti(n,wsave) + +****************************************************************** + +subroutine dzffti initializes the array wsave which is used in +both dzfftf and dzfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both dzfftf and dzfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. + + +****************************************************************** + +subroutine dzfftf(n,r,azero,a,b,wsave) + +****************************************************************** + +subroutine dzfftf computes the fourier coefficients of a real +perodic sequence (fourier analysis). the transform is defined +below at output parameters azero,a and b. dzfftf is a simplified +but slower version of dfftf. + +input parameters + +n the length of the array r to be transformed. the method + is most efficient when n is the product of small primes. + +r a real array of length n which contains the sequence + to be transformed. r is not destroyed. + + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls dzfftf. the wsave array must be + initialized by calling subroutine dzffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by dzfftf and dzfftb. + +output parameters + +azero the sum from i=1 to i=n of r(i)/n + +a,b for n even b(n/2)=0. and a(n/2) is the sum from i=1 to + i=n of (-1)**(i-1)*r(i)/n + + for n even define kmax=n/2-1 + for n odd define kmax=(n-1)/2 + + then for k=1,...,kmax + + a(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*cos(k*(i-1)*2*pi/n) + + b(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*sin(k*(i-1)*2*pi/n) + + +****************************************************************** + +subroutine dzfftb(n,r,azero,a,b,wsave) + +****************************************************************** + +subroutine dzfftb computes a real perodic sequence from its +fourier coefficients (fourier synthesis). the transform is +defined below at output parameter r. dzfftb is a simplified +but slower version of dfftb. + +input parameters + +n the length of the output array r. the method is most + efficient when n is the product of small primes. + +azero the constant fourier coefficient + +a,b arrays which contain the remaining fourier coefficients + these arrays are not destroyed. + + the length of these arrays depends on whether n is even or + odd. + + if n is even n/2 locations are required + if n is odd (n-1)/2 locations are required + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls dzfftb. the wsave array must be + initialized by calling subroutine dzffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by dzfftf and dzfftb. + + +output parameters + +r if n is even define kmax=n/2 + if n is odd define kmax=(n-1)/2 + + then for i=1,...,n + + r(i)=azero plus the sum from k=1 to k=kmax of + + a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n) + +********************* complex notation ************************** + + for j=1,...,n + + r(j) equals the sum from k=-kmax to k=kmax of + + c(k)*exp(i*k*(j-1)*2*pi/n) + + where + + c(k) = .5*cmplx(a(k),-b(k)) for k=1,...,kmax + + c(-k) = conjg(c(k)) + + c(0) = azero + + and i=sqrt(-1) + +*************** amplitude - phase notation *********************** + + for i=1,...,n + + r(i) equals azero plus the sum from k=1 to k=kmax of + + alpha(k)*cos(k*(i-1)*2*pi/n+beta(k)) + + where + + alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k)) + + cos(beta(k))=a(k)/alpha(k) + + sin(beta(k))=-b(k)/alpha(k) + +****************************************************************** + +subroutine dsinti(n,wsave) + +****************************************************************** + +subroutine dsinti initializes the array wsave which is used in +subroutine dsint. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n+1 is a product of small primes. + +output parameter + +wsave a work array with at least int(2.5*n+15) locations. + different wsave arrays are required for different values + of n. the contents of wsave must not be changed between + calls of dsint. + +****************************************************************** + +subroutine dsint(n,x,wsave) + +****************************************************************** + +subroutine dsint computes the discrete fourier sine transform +of an odd sequence x(i). the transform is defined below at +output parameter x. + +dsint is the unnormalized inverse of itself since a call of dsint +followed by another call of dsint will multiply the input sequence +x by 2*(n+1). + +the array wsave which is used by subroutine dsint must be +initialized by calling subroutine dsinti(n,wsave). + +input parameters + +n the length of the sequence to be transformed. the method + is most efficient when n+1 is the product of small primes. + +x an array which contains the sequence to be transformed + + +wsave a work array with dimension at least int(2.5*n+15) + in the program that calls dsint. the wsave array must be + initialized by calling subroutine dsinti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n + + 2*x(k)*sin(k*i*pi/(n+1)) + + a call of dsint followed by another call of + dsint will multiply the sequence x by 2*(n+1). + hence dsint is the unnormalized inverse + of itself. + +wsave contains initialization calculations which must not be + destroyed between calls of dsint. + +****************************************************************** + +subroutine dcosti(n,wsave) + +****************************************************************** + +subroutine dcosti initializes the array wsave which is used in +subroutine dcost. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n-1 is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + different wsave arrays are required for different values + of n. the contents of wsave must not be changed between + calls of dcost. + +****************************************************************** + +subroutine dcost(n,x,wsave) + +****************************************************************** + +subroutine dcost computes the discrete fourier cosine transform +of an even sequence x(i). the transform is defined below at output +parameter x. + +dcost is the unnormalized inverse of itself since a call of dcost +followed by another call of dcost will multiply the input sequence +x by 2*(n-1). the transform is defined below at output parameter x + +the array wsave which is used by subroutine dcost must be +initialized by calling subroutine dcosti(n,wsave). + +input parameters + +n the length of the sequence x. n must be greater than 1. + the method is most efficient when n-1 is a product of + small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15 + in the program that calls dcost. the wsave array must be + initialized by calling subroutine dcosti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = x(1)+(-1)**(i-1)*x(n) + + + the sum from k=2 to k=n-1 + + 2*x(k)*cos((k-1)*(i-1)*pi/(n-1)) + + a call of dcost followed by another call of + dcost will multiply the sequence x by 2*(n-1) + hence dcost is the unnormalized inverse + of itself. + +wsave contains initialization calculations which must not be + destroyed between calls of dcost. + +****************************************************************** + +subroutine dsinqi(n,wsave) + +****************************************************************** + +subroutine dsinqi initializes the array wsave which is used in +both dsinqf and dsinqb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed. the method + is most efficient when n is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both dsinqf and dsinqb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of dsinqf or dsinqb. + +****************************************************************** + +subroutine dsinqf(n,x,wsave) + +****************************************************************** + +subroutine dsinqf computes the fast fourier transform of quarter +wave data. that is , dsinqf computes the coefficients in a sine +series representation with only odd wave numbers. the transform +is defined below at output parameter x. + +dsinqb is the unnormalized inverse of dsinqf since a call of dsinqf +followed by a call of dsinqb will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine dsinqf must be +initialized by calling subroutine dsinqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls dsinqf. the wsave array must be + initialized by calling subroutine dsinqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = (-1)**(i-1)*x(n) + + + the sum from k=1 to k=n-1 of + + 2*x(k)*sin((2*i-1)*k*pi/(2*n)) + + a call of dsinqf followed by a call of + dsinqb will multiply the sequence x by 4*n. + therefore dsinqb is the unnormalized inverse + of dsinqf. + +wsave contains initialization calculations which must not + be destroyed between calls of dsinqf or dsinqb. + +****************************************************************** + +subroutine dsinqb(n,x,wsave) + +****************************************************************** + +subroutine dsinqb computes the fast fourier transform of quarter +wave data. that is , dsinqb computes a sequence from its +representation in terms of a sine series with odd wave numbers. +the transform is defined below at output parameter x. + +dsinqf is the unnormalized inverse of dsinqb since a call of dsinqb +followed by a call of dsinqf will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine dsinqb must be +initialized by calling subroutine dsinqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15. + in the program that calls dsinqb. the wsave array must be + initialized by calling subroutine dsinqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n of + + 4*x(k)*sin((2k-1)*i*pi/(2*n)) + + a call of dsinqb followed by a call of + dsinqf will multiply the sequence x by 4*n. + therefore dsinqf is the unnormalized inverse + of dsinqb. + +wsave contains initialization calculations which must not + be destroyed between calls of dsinqb or dsinqf. + +****************************************************************** + +subroutine dcosqi(n,wsave) + +****************************************************************** + +subroutine dcosqi initializes the array wsave which is used in +both dcosqf and dcosqb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the array to be transformed. the method + is most efficient when n is a product of small primes. + +output parameter + +wsave a work array which must be dimensioned at least 3*n+15. + the same work array can be used for both dcosqf and dcosqb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of dcosqf or dcosqb. + +****************************************************************** + +subroutine dcosqf(n,x,wsave) + +****************************************************************** + +subroutine dcosqf computes the fast fourier transform of quarter +wave data. that is , dcosqf computes the coefficients in a cosine +series representation with only odd wave numbers. the transform +is defined below at output parameter x + +dcosqf is the unnormalized inverse of dcosqb since a call of dcosqf +followed by a call of dcosqb will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine dcosqf must be +initialized by calling subroutine dcosqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array which must be dimensioned at least 3*n+15 + in the program that calls dcosqf. the wsave array must be + initialized by calling subroutine dcosqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i) = x(1) plus the sum from k=2 to k=n of + + 2*x(k)*cos((2*i-1)*(k-1)*pi/(2*n)) + + a call of dcosqf followed by a call of + cosqb will multiply the sequence x by 4*n. + therefore dcosqb is the unnormalized inverse + of dcosqf. + +wsave contains initialization calculations which must not + be destroyed between calls of dcosqf or dcosqb. + +****************************************************************** + +subroutine dcosqb(n,x,wsave) + +****************************************************************** + +subroutine dcosqb computes the fast fourier transform of quarter +wave data. that is , dcosqb computes a sequence from its +representation in terms of a cosine series with odd wave numbers. +the transform is defined below at output parameter x. + +dcosqb is the unnormalized inverse of dcosqf since a call of dcosqb +followed by a call of dcosqf will multiply the input sequence x +by 4*n. + +the array wsave which is used by subroutine dcosqb must be +initialized by calling subroutine dcosqi(n,wsave). + + +input parameters + +n the length of the array x to be transformed. the method + is most efficient when n is a product of small primes. + +x an array which contains the sequence to be transformed + +wsave a work array that must be dimensioned at least 3*n+15 + in the program that calls dcosqb. the wsave array must be + initialized by calling subroutine dcosqi(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + +output parameters + +x for i=1,...,n + + x(i)= the sum from k=1 to k=n of + + 4*x(k)*cos((2*k-1)*(i-1)*pi/(2*n)) + + a call of dcosqb followed by a call of + dcosqf will multiply the sequence x by 4*n. + therefore dcosqf is the unnormalized inverse + of dcosqb. + +wsave contains initialization calculations which must not + be destroyed between calls of dcosqb or dcosqf. + +****************************************************************** + +subroutine zffti(n,wsave) + +****************************************************************** + +subroutine zffti initializes the array wsave which is used in +both zfftf and zfftb. the prime factorization of n together with +a tabulation of the trigonometric functions are computed and +stored in wsave. + +input parameter + +n the length of the sequence to be transformed + +output parameter + +wsave a work array which must be dimensioned at least 4*n+15 + the same work array can be used for both zfftf and zfftb + as long as n remains unchanged. different wsave arrays + are required for different values of n. the contents of + wsave must not be changed between calls of zfftf or zfftb. + +****************************************************************** + +subroutine zfftf(n,c,wsave) + +****************************************************************** + +subroutine zfftf computes the forward complex discrete fourier +transform (the fourier analysis). equivalently , zfftf computes +the fourier coefficients of a complex periodic sequence. +the transform is defined below at output parameter c. + +the transform is not normalized. to obtain a normalized transform +the output must be divided by n. otherwise a call of zfftf +followed by a call of zfftb will multiply the sequence by n. + +the array wsave which is used by subroutine zfftf must be +initialized by calling subroutine zffti(n,wsave). + +input parameters + + +n the length of the complex sequence c. the method is + more efficient when n is the product of small primes. n + +c a complex array of length n which contains the sequence + +wsave a real work array which must be dimensioned at least 4n+15 + in the program that calls zfftf. the wsave array must be + initialized by calling subroutine zffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by zfftf and zfftb. + +output parameters + +c for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(-i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) + +wsave contains initialization calculations which must not be + destroyed between calls of subroutine zfftf or zfftb + +****************************************************************** + +subroutine zfftb(n,c,wsave) + +****************************************************************** + +subroutine zfftb computes the backward complex discrete fourier +transform (the fourier synthesis). equivalently , zfftb computes +a complex periodic sequence from its fourier coefficients. +the transform is defined below at output parameter c. + +a call of zfftf followed by a call of zfftb will multiply the +sequence by n. + +the array wsave which is used by subroutine zfftb must be +initialized by calling subroutine zffti(n,wsave). + +input parameters + + +n the length of the complex sequence c. the method is + more efficient when n is the product of small primes. + +c a complex array of length n which contains the sequence + +wsave a real work array which must be dimensioned at least 4n+15 + in the program that calls zfftb. the wsave array must be + initialized by calling subroutine zffti(n,wsave) and a + different wsave array must be used for each different + value of n. this initialization does not have to be + repeated so long as n remains unchanged thus subsequent + transforms can be obtained faster than the first. + the same wsave array can be used by zfftf and zfftb. + +output parameters + +c for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) + +wsave contains initialization calculations which must not be + destroyed between calls of subroutine zfftf or zfftb + + + +["send index for vfftpk" describes a vectorized version of fftpack] + diff --git a/src/src_rp/fftpack/doc/doc.double b/src/src_rp/fftpack/doc/doc.double new file mode 100644 index 0000000..e93e722 --- /dev/null +++ b/src/src_rp/fftpack/doc/doc.double @@ -0,0 +1,25 @@ +This documents the changes done by HCP to make fftpack into dfftpack + +(1) Renamed all files corresponding to subroutines in the API + i.e. ones documented as callable by the luser. Names chosen to match + the ones in libsunperf. + +(2) Inserted IMPLICIT DOUBLE PRECISION (A-H,O-Z) after every + subroutine statement. This makes everything that used to be a real + into a double. + +(3) Replaced floating constants with Double Prec. constants. All + 0. become 0.D0 etc and PI, SQRT(2) etc. expanded to dble prec. + +(4) Replaced DIMENSION FOO(1) with DIMENSION FOO(*) where foo + is an array argument of a subroutine. I only did this in the places + where g77 notices it, so the compile looks cleaner. + +(5) Replaced COMPLEX with DOUBLE COMPLEX. Now, this is not standard + fortran 77, so the whole thing may fall apart if you have a VERY + vanilla Fortran 77 compiler. On the other hand, the only place a + complex is _declared_ as such is in the test program. If you don't have + DOUBLE COMPLEX my guess is that the library will work, except for + the routines ZFFTI, ZFFTB and ZFFTF. + +(6) Updated the file doc \ No newline at end of file diff --git a/src/src_rp/fftpack/doc/index.md b/src/src_rp/fftpack/doc/index.md new file mode 100644 index 0000000..073fab1 --- /dev/null +++ b/src/src_rp/fftpack/doc/index.md @@ -0,0 +1,6 @@ +--- +title: Contributing and specs +--- + +@warning +This page is currently under construction! diff --git a/src/src_rp/fftpack/doc/origMakefile b/src/src_rp/fftpack/doc/origMakefile new file mode 100644 index 0000000..f155b5a --- /dev/null +++ b/src/src_rp/fftpack/doc/origMakefile @@ -0,0 +1,63 @@ +LIB=fftpack +FFLAGS=-O +OBJ=\ +cfftb.o\ +cfftb1.o\ +cfftf.o\ +cfftf1.o\ +cffti.o\ +cffti1.o\ +cosqb.o\ +cosqb1.o\ +cosqf.o\ +cosqf1.o\ +cosqi.o\ +cost.o\ +costi.o\ +ezfft1.o\ +ezfftb.o\ +ezfftf.o\ +ezffti.o\ +passb.o\ +passb2.o\ +passb3.o\ +passb4.o\ +passb5.o\ +passf.o\ +passf2.o\ +passf3.o\ +passf4.o\ +passf5.o\ +radb2.o\ +radb3.o\ +radb4.o\ +radb5.o\ +radbg.o\ +radf2.o\ +radf3.o\ +radf4.o\ +radf5.o\ +radfg.o\ +rfftb.o\ +rfftb1.o\ +rfftf.o\ +rfftf1.o\ +rffti.o\ +rffti1.o\ +sinqb.o\ +sinqf.o\ +sinqi.o\ +sint.o\ +sint1.o\ +sinti.o + +lib$(LIB).a: $(OBJ) + update lib$(LIB).a $? + +install: lib$(LIB).a + mv lib$(LIB).a /usr/local/lib + rm *.o + +test: test.o + f77 test.o -l$(LIB) + time a.out diff --git a/src/src_rp/fftpack/doc/specs/fftpack.md b/src/src_rp/fftpack/doc/specs/fftpack.md new file mode 100644 index 0000000..b55891b --- /dev/null +++ b/src/src_rp/fftpack/doc/specs/fftpack.md @@ -0,0 +1,1382 @@ +--- +title: FFTPACK +--- + +# The `fftpack` module + +[TOC] + +## Fourier transform of double complex periodic sequences +### `zffti` + +#### Description + +Initializes the array `wsave` which is used in both `zfftf` and `zfftb`. +The prime factorization of `n` together with a tabulation of the trigonometric functions are computed and +stored in `wsave`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):zffti(interface)]](n, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the sequence to be transformed. + +`wsave`: Shall be a `real` array. +This argument is `intent(out)`. +A work array which must be dimensioned at least `4*n+15`. +The same work array can be used for both `zfftf` and `zfftb` +as long as `n` remains unchanged. Different `wsave` arrays +are required for different values of `n`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `zfftf` or `zfftb`. + +#### Example + +```fortran +program demo_zffti + use fftpack, only: zffti + complex(kind=8) :: x(4) = [1.0, 2.0, 3.0, 4.0] + real(kind=8) :: w(31) + call zffti(4,w) +end program demo_zffti +``` + +### `zfftf` + +#### Description + +Computes the forward complex discrete fourier transform (the fourier analysis). +Equivalently, `zfftf` computes the fourier coefficients of a complex periodic sequence. +The transform is defined below at output parameter `c`. + +The transform is not normalized. To obtain a normalized transform the output must be divided by `n`. Otherwise a call of `zfftf` followed by a call of `zfftb` will multiply the sequence by `n`. + +The array `wsave` which is used by subroutine `zfftf` must be initialized by calling subroutine `zffti(n,wsave)`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):zfftf(interface)]](n, c, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the `complex` sequence `c`. The method is more efficient when `n` is the product of small primes. + +`c`: Shall be a `complex` and rank-1 array. +This argument is `intent(inout)`. +A `complex` array of length `n` which contains the sequence. +``` +for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(-i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) +``` + +`wsave`: Shall be a `real` array. +This argument is `intent(in)`. +A `real` work array which must be dimensioned at least `4n+15` in the program that calls `zfftf`. +The wsave array must be initialized by calling subroutine `zffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. +The same `wsave` array can be used by `zfftf` and `zfftb`. +Contains initialization calculations which must not be destroyed between calls of subroutine `zfftf` or `zfftb`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `zfftf` or `zfftb`. + +#### Example + +```fortran +program demo_zfftf + use fftpack, only: zffti, zfftf + complex(kind=8) :: x(4) + real(kind=8) :: w(31) + x = [real(kind=8) :: 1.0, 2.0, 3.0, 4.0] + call zffti(4,w) + call zfftf(4,x,w) !! `x` returns [(10.0,0.0), (-2.0,2.0), (-2.0,0.0), (-2.0,-2.0)]. +end program demo_zfftf +``` + +### `zfftb` + +#### Description + +Unnormalized inverse of `zfftf`. + +Computes the backward `complex` discrete fourier transform (the fourier synthesis). +Equivalently, `zfftb` computes a `complex` periodic sequence from its fourier coefficients. +The transform is defined below at output parameter `c`. + +The transform is not normalized. to obtain a normalized transform the output must be divided by `n`. Otherwise a call of `zfftf` followed by a call of `zfftb` will multiply the sequence by `n`. + +The array `wsave` which is used by subroutine `zfftf` must be initialized by calling subroutine `zffti(n,wsave)`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):zfftb(interface)]](n, c, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the `complex` sequence `c`. The method is more efficient when `n` is the product of small primes. + +`c`: Shall be a `complex` array. +This argument is `intent(inout)`. +A `complex` array of length `n` which contains the sequence. +``` +for j=1,...,n + + c(j)=the sum from k=1,...,n of + + c(k)*exp(-i*(j-1)*(k-1)*2*pi/n) + + where i=sqrt(-1) +``` + +`wsave`: Shall be a `real` array. +This argument is `intent(in)`. +A `real` work array which must be dimensioned at least `4n+15` in the program that calls `zfftf`. The `wsave` array must be initialized by calling subroutine `zffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. The same `wsave` array can be used by `zfftf` and `zfftb`. +Contains initialization calculations which must not be destroyed between calls of subroutine `zfftf` or `zfftb`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `zfftf` or `zfftb`. + +#### Example + +```fortran +program demo_zfftb + use fftpack, only: zffti, zfftf, zfftb + complex(kind=8) :: x(4) + real(kind=8) :: w(31) + x = [real(kind=8) :: 1.0, 2.0, 3.0, 4.0] + call zffti(4,w) + call zfftf(4,x,w) !! `x` returns [(10.0,0.0), (-2.0,2.0), (-2.0,0.0), (-2.0,-2.0)]. + call zfftb(4,x,w) !! `x` returns [(4.0,0.0), (8.0,0.0), (12.0,0.0), (16.0,0.0)]. +end program demo_zfftb +``` + +### `fft` + +#### Description + +Computes the forward complex discrete fourier transform (the fourier analysis). + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):fft(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `complex` and rank-1 array. +This argument is `intent(in)`. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `complex` and rank-1 array, the Discrete Fourier Transform (DFT) of `x`. + +#### Notes + +Within numerical accuracy, `x == ifft(fft(x))/size(x)`. + +#### Example + +```fortran +program demo_fft + use fftpack, only: fft + complex(kind=8) :: x(4) + x = [real(kind=8) :: 1.0, 2.0, 3.0, 4.0] + print *, fft(x) !! [(10.0,0.0), (-2.0,2.0), (-2.0,0.0), (-2.0,-2.0)]. + print *, fft(x,3) !! [(6.0,0.0), (-1.5,0.86), (-1.5,0.86)]. + print *, fft(x,5) !! [(10.0,0.0), (-4.0,1.3), (1.5,-2.1), (1.5,2.1), (-4.0,1.3)]. +end program demo_fft +``` + +### `ifft` + +#### Description + +Unnormalized inverse of `fft`. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):ifft(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `complex` and rank-1 array. +This argument is `intent(in)`. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `complex` and rank-1 array, the unnormalized inverse Discrete Fourier Transform (DFT) of `x`. + +#### Example + +```fortran +program demo_ifft + use fftpack, only: fft, ifft + complex(kind=8) :: x(4) = [1.0, 2.0, 3.0, 4.0] + print *, ifft(fft(x))/4.0 !! [(1.0,0.0), (2.0,0.0), (3.0,0.0), (4.0,0.0)] + print *, ifft(fft(x), 3) !! [(6.0,2.0), (10.3,-1.0), (13.73,-1.0)] +end program demo_ifft +``` + +## Fourier transform of double real periodic sequences +### `dffti` + +#### Description + +Initializes the array `wsave` which is used in both `dfftf` and `dfftb`. +The prime factorization of `n` together with a tabulation of the trigonometric functions are computed and +stored in `wsave`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dffti(interface)]](n, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the sequence to be transformed. + +`wsave`: Shall be a `real` array. +This argument is `intent(out)`. +A work array which must be dimensioned at least `2*n+15`. +The same work array can be used for both `dfftf` and `dfftb` as long as `n` remains unchanged. +Different `wsave` arrays are required for different values of `n`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `dfftf` or `dfftb`. + +#### Example + +```fortran +program demo_dffti + use fftpack, only: dffti + real(kind=8) :: x(4) = [1.0, 2.0, 3.0, 4.0] + real(kind=8) :: w(23) + call dffti(4,w) +end program demo_dffti +``` + +### `dfftf` + +#### Description + +Computes the fourier coefficients of a real perodic sequence (fourier analysis). +The transform is defined below at output parameter `r`. + +The transform is not normalized. To obtain a normalized transform the output must be divided by `n`. Otherwise a call of `dfftf` followed by a call of `dfftb` will multiply the sequence by `n`. + +The array `wsave` which is used by subroutine `dfftf` must be initialized by calling subroutine `dffti(n,wsave)`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dfftf(interface)]](n, r, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the `real` sequence `r`. The method is more efficient when `n` is the product of small primes. +`n` may change so long as different work arrays are provided. + +`r`: Shall be a `real` array. +This argument is `intent(inout)`. +A `real` array of length `n` which contains the sequence. +``` +r(1) = the sum from i=1 to i=n of r(i) + +if n is even set l =n/2 , if n is odd set l = (n+1)/2 + + then for k = 2,...,l + + r(2*k-2) = the sum from i = 1 to i = n of + + r(i)*cos((k-1)*(i-1)*2*pi/n) + + r(2*k-1) = the sum from i = 1 to i = n of + + -r(i)*sin((k-1)*(i-1)*2*pi/n) + +if n is even + + r(n) = the sum from i = 1 to i = n of + + (-1)**(i-1)*r(i) +``` + +`wsave`: Shall be a `real` array. +This argument is `intent(in)`. +A `real` work array which must be dimensioned at least `4n+15` in the program that calls `dfftf`. +The wsave array must be initialized by calling subroutine `dffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. +The same `wsave` array can be used by `dfftf` and `dfftb`. +Contains initialization calculations which must not be destroyed between calls of subroutine `dfftf` or `dfftb`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `dfftf` or `dfftb`. + +#### Example + +```fortran +program demo_dfftf + use fftpack, only: dffti, dfftf + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(23) + call dffti(4,w) + call dfftf(4,x,w) !! `x` returns [10.0, -2.0, 2.0, -2.0]. +end program demo_dfftf +``` + +### `dfftb` + +#### Description + +Unnormalized inverse of `dfftf`. + +Computes the backward `real` discrete fourier transform (the fourier synthesis). +Equivalently, `dfftb` computes a `real` periodic sequence from its fourier coefficients. +The transform is defined below at output parameter `c`. + +The transform is not normalized. To obtain a normalized transform the output must be divided by `n`. Otherwise a call of `dfftf` followed by a call of `dfftb` will multiply the sequence by `n`. + +The array `wsave` which is used by subroutine `dfftf` must be initialized by calling subroutine `dffti(n,wsave)`. + +#### Status + +Experimental. + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dfftb(interface)]](n, r, wsave)` + +#### Argument + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the `real` sequence `r`. The method is more efficient when `n` is the product of small primes. + +`r`: Shall be a `real` array. +This argument is `intent(inout)`. +A `real` array of length `n` which contains the sequence. +``` +for n even and for i = 1,...,n + + r(i) = r(1)+(-1)**(i-1)*r(n) + + plus the sum from k=2 to k=n/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) + +for n odd and for i = 1,...,n + + r(i) = r(1) plus the sum from k=2 to k=(n+1)/2 of + + 2.*r(2*k-2)*cos((k-1)*(i-1)*2*pi/n) + + -2.*r(2*k-1)*sin((k-1)*(i-1)*2*pi/n) +``` + +`wsave`: Shall be a `real` array. +This argument is `intent(in)`. +A `real` work array which must be dimensioned at least `2n+15` in the program that calls `dfftf`. The `wsave` array must be initialized by calling subroutine `dffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. The same `wsave` array can be used by `dfftf` and `dfftb`. +Contains initialization calculations which must not be destroyed between calls of subroutine `dfftf` or `dfftb`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `dfftf` or `dfftb`. + +#### Example + +```fortran +program demo_dfftb + use fftpack, only: dffti, dfftf, dfftb + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(31) + call dffti(4,w) + call dfftf(4,x,w) !! `x` returns [10.0, -2.0, 2.0, -2.0]. + call dfftb(4,x,w) !! `x` returns [4.0, 8.0, 12.0, 16.0], which is not normalized. +end program demo_dfftb +``` + +### `rfft` + +#### Description + +Discrete Fourier transform of a real sequence. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):rfft(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +The data to transform. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the Discrete Fourier Transform (DFT) of `x`. + +#### Notes + +Within numerical accuracy, `y == rfft(irfft(y))/size(y)`. + +#### Example + +```fortran +program demo_rfft + use fftpack, only: rfft + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, rfft(x,3) !! [6.0, -1.5, 0.87]. + print *, rfft(x) !! [10.0, -2.0, 2.0, -2.0]. + print *, rfft(x,5) !! [10.0, -4.0, -1.3, 1.5, -2.1]. +end program demo_rfft +``` + +### `irfft` + +#### Description + +Unnormalized inverse of `rfft`. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):irfft(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` array. +This argument is `intent(in)`. +Transformed data to invert. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the unnormalized inverse discrete Fourier transform. + +#### Example + +```fortran +program demo_irfft + use fftpack, only: rfft, irfft + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, irfft(rfft(x))/4.0 !! [1.0, 2.0, 3.0, 4.0] + print *, irfft(rfft(x), 3) !! [6.0, 8.53, 15.46] +end program demo_irfft +``` + +## Simplified fourier transform of double real periodic sequences + +### `dzffti` + +#### Description + +Initializes the array `wsave` which is used in both `dzfftf` and `dzfftb`. +The prime factorization of `n` together with a tabulation of the trigonometric functions are computed and stored in `wsave`. + +#### Status + +Experimental + +#### Class + +Prue function. + +#### Syntax + +`call [[fftpack(module):dzffti(interface)]](n, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the sequence to be transformed. + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(out)`. +A work array which must be dimensioned at least `3*n+15`. +The same work array can be used for both `dzfftf` and `dzfftb` as long as n remains unchanged. +Different `wsave` arrays are required for different values of `n`. + +##### Warning + +The contents of `wsave` must not be changed between calls of `dzfftf` or `dzfftb`. + +#### Example + +```fortran +program demo_dzffti + use fftpack, only: dzffti + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(3*4 + 15) + call dzffti(4, w) !! Initializes the array `w` which is used in both `dzfftf` and `dzfftb`. +end program demo_dzffti +``` + +### `dzfftf` + +#### Description + +Computes the fourier coefficients of a `real` perodic sequence (fourier analysis). +The transform is defined below at output parameters `azero`, `a` and `b`. +`dzfftf` is a simplified but **slower version** of `dfftf`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dzfftf(interface)]](n, r, azero, a, b, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the array `r` to be transformed. +The method is most efficient when `n` is the product of small primes. + +`r`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A `real` array of length `n` which contains the sequence to be transformed. `r` is not destroyed. + +`azero`: Shall be a `real` scalar. +This argument is `intent(out)`. +The sum from `i=1` to `i=n` of `r(i)/n`. + +`a`, `b`: Shall be a `real` and rank-1 array. +This argument is `intent(out)`. +``` +for n even b(n/2)=0. and a(n/2) is the sum from i=1 to i=n of (-1)**(i-1)*r(i)/n + +for n even define kmax=n/2-1 +for n odd define kmax=(n-1)/2 + +then for k=1,...,kmax + + a(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*cos(k*(i-1)*2*pi/n) + + b(k) equals the sum from i=1 to i=n of + + 2./n*r(i)*sin(k*(i-1)*2*pi/n) +``` + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A work array which must be dimensioned at least `3*n+15`. +In the program that calls `dzfftf`. The `wsave` array must be initialized by calling subroutine `dzffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. +The same `wsave` array can be used by `dzfftf` and `dzfftb`. + +#### Example + +```fortran +program demo_dzfftf + use fftpack, only: dzffti, dzfftf + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(3*4 + 15) + real(kind=8) :: azero, a(4/2), b(4/2) + call dzffti(4, w) + call dzfftf(4, x, azero, a, b, w) !! `azero`: 2.5; `a`: [-1.0, -0.5]; `b`: [-1.0, -0.0] +end program demo_dzfftf +``` + +### `dzfftb` + +#### Description + +Computes a `real` perodic sequence from its fourier coefficients (fourier synthesis). +The transform is defined below at output parameter `r`. +`dzfftb` is a simplified but **slower version** of `dfftb`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dzfftb(interface)]](n, r, azero, a, b, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the output array `r`. +The method is most efficient when `n` is the product of small primes. + +`r`: Shall be a `real` and rank-1 array. +This argument is `intent(out)`. +``` +if n is even define kmax=n/2 +if n is odd define kmax=(n-1)/2 + +then for i=1,...,n + + r(i)=azero plus the sum from k=1 to k=kmax of + + a(k)*cos(k*(i-1)*2*pi/n)+b(k)*sin(k*(i-1)*2*pi/n) +``` +Complex notation: +``` +for j=1,...,n + +r(j) equals the sum from k=-kmax to k=kmax of + + c(k)*exp(i*k*(j-1)*2*pi/n) + +where + + c(k) = .5*cmplx(a(k),-b(k)) for k=1,...,kmax + + c(-k) = conjg(c(k)) + + c(0) = azero + + and i=sqrt(-1) +``` +Amplitude - phase notation: +``` +for i=1,...,n + +r(i) equals azero plus the sum from k=1 to k=kmax of + + alpha(k)*cos(k*(i-1)*2*pi/n+beta(k)) + +where + + alpha(k) = sqrt(a(k)*a(k)+b(k)*b(k)) + + cos(beta(k))=a(k)/alpha(k) + + sin(beta(k))=-b(k)/alpha(k) +``` + +`azero`: Shall be a `real` scalar. +This argument is `intent(in)`. +The constant fourier coefficient. + +`a`, `b`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +Arrays which contain the remaining fourier coefficients these arrays are not destroyed. +The length of these arrays depends on whether `n` is even or odd. +``` +if n is even n/2 locations are required +if n is odd (n-1)/2 locations are required +``` + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A work array which must be dimensioned at least `3*n+15`. +In the program that calls `dzfftf`. The `wsave` array must be initialized by calling subroutine `dzffti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. +The same `wsave` array can be used by `dzfftf` and `dzfftb`. + +#### Example + +```fortran +program demo_dzfftb + use fftpack, only: dzffti, dzfftf, dzfftb + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(3*4 + 15) + real(kind=8) :: azero, a(4/2), b(4/2) + call dzffti(4, w) + call dzfftf(4, x, azero, a, b, w) !! `azero`: 2.5; `a`: [-1.0, -0.5]; `b`: [-1.0, -0.0] + x = 0.0 + call dzfftb(4, x, azero, a, b, w) !! `x`: [1.0, 2.0, 3.0, 4.0] +end program demo_dzfftb +``` + +## Cosine transform with odd wave numbers + +### `dcosqi` + +#### Description + +Initializes the array `wsave` which is used in both `dcosqf` and `dcosqb`. +The prime factorization of `n` together with +a tabulation of the trigonometric functions are computed and +stored in `wsave`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dcosqi(interface)]](n, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the array to be transformed. +The method is most efficient when `n` is a product of small primes. + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(out)`. +A work array which must be dimensioned at least `3*n+15`. +The same work array can be used for both `dcosqf` and `dcosqb` +as long as `n` remains unchanged. +Different `wsave` arrays are required for different values of `n`. +The contents of `wsave` must not be changed between calls of `dcosqf` or `dcosqb`. + +#### Example + +```fortran +program demo_dcosqi + use fftpack, only: dcosqi + real(kind=8) :: w(3*4 + 15) + call dcosqi(4, w) !! Initializes the array `w` which is used in both `dcosqf` and `dcosqb`. +end program demo_dcosqi +``` + +### `dcosqf` + +#### Decsription + +Computes the fast fourier transform of quarter wave data. +That is, `dcosqf` computes the coefficients in a cosine series representation with only odd wave numbers. +The transform is defined below at output parameter `x`. + +`dcosqf` is the unnormalized inverse of `dcosqb` since a call of `dcosqf` followed by a call of `dcosqb` will multiply the input sequence `x` by `4*n`. + +The array `wsave` which is used by subroutine `dcosqf` must be initialized by calling subroutine `dcosqi(n,wsave)`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dcosqf(interface)]](n, x, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the array `x` to be transformed. +The method is most efficient when `n` is a product of small primes. + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(inout)`. +An array which contains the sequence to be transformed. +``` +for i=1,...,n + + x(i) = x(1) plus the sum from k=2 to k=n of + + 2*x(k)*cos((2*i-1)*(k-1)*pi/(2*n)) + + a call of dcosqf followed by a call of + cosqb will multiply the sequence x by 4*n. + therefore dcosqb is the unnormalized inverse + of dcosqf. +``` + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A work array which must be dimensioned at least `3*n+15` +in the program that calls `dcosqf`. +The `wsave` array must be initialized by calling subroutine `dcosqi(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. + +##### Warning + +`wsave` contains initialization calculations which must not be destroyed between calls of `dcosqf` or `dcosqb`. + +#### Example + +```fortran +program demo_dcosqf + use fftpack, only: dcosqi, dcosqf + real(kind=8) :: w(3*4 + 15) + real(kind=8) :: x(4) = [1, 2, 3, 4] + call dcosqi(4, w) + call dcosqf(4, x, w) !! `x`: [12.0, -9.10, 2.62, -1.51] +end program demo_dcosqf +``` + +### `dcosqb` + +#### Decsription + +Computes the fast fourier transform of quarter wave data. +That is, `dcosqb` computes a sequence from its representation in terms of a cosine series with odd wave numbers. +The transform is defined below at output parameter `x`. + +`dcosqb` is the unnormalized inverse of `dcosqf` since a call of `dcosqb` followed by a call of `dcosqf` will multiply the input sequence `x` by `4*n`. + +The array `wsave` which is used by subroutine `dcosqb` must be initialized by calling subroutine `dcosqi(n,wsave)`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dcosqf(interface)]](n, x, wsave)` + +#### Arguments + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)`. +The length of the array `x` to be transformed. +The method is most efficient when `n` is a product of small primes. + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(inout)`. +An array which contains the sequence to be transformed. +``` +for i=1,...,n + + x(i)= the sum from k=1 to k=n of + + 4*x(k)*cos((2*k-1)*(i-1)*pi/(2*n)) + + a call of dcosqb followed by a call of + dcosqf will multiply the sequence x by 4*n. + therefore dcosqf is the unnormalized inverse + of dcosqb. +``` + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A work array which must be dimensioned at least `3*n+15` +in the program that calls `dcosqb`. +The `wsave` array must be initialized by calling subroutine `dcosqi(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent transforms can be obtained faster than the first. + +##### Warning + +`wsave` contains initialization calculations which must not be destroyed between calls of `dcosqf` or `dcosqb`. + +#### Example + +```fortran +program demo_dcosqb + use fftpack, only: dcosqi, dcosqf, dcosqb + real(kind=8) :: w(3*4 + 15) + real(kind=8) :: x(4) = [4, 3, 5, 10] + call dcosqi(4, w) + call dcosqf(4, x, w) + call dcosqb(4, x, w) !! `x`: [1.0, 2.0, 3.0, 4.0] * 4 * n, n = 4, which is unnormalized. +end program demo_dcosqb +``` + +### `qct` + +#### Description + +Forward transform of quarter wave data. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):qct(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +The data to transform. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the Quarter-Cosine Transform (QCT) of `x`. + +#### Notes + +Within numerical accuracy, `x == iqct(qct(x))/(4*size(x))`. + +#### Example + +```fortran +program demo_qct + use fftpack, only: qct + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, qct(x,3) !! [7.4, -5.0, 0.53]. + print *, qct(x) !! [12.0, -9.10, 2.62, -1.51]. + print *, qct(x,5) !! [14.4, -6.11, -5.0, 4.4, -2.65]. +end program demo_qct +``` + +### `iqct` + +#### Description + +Unnormalized inverse of `qct`. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):iqct(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` array. +This argument is `intent(in)`. +Transformed data to invert. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the unnormalized inverse Quarter-Cosine Transform. + +#### Example + +```fortran +program demo_iqct + use fftpack, only: qct, iqct + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, iqct(qct(x))/(4.0*4.0) !! [1.0, 2.0, 3.0, 4.0] + print *, iqct(qct(x), 3)/(4.0*3.0) !! [1.84, 2.71, 5.47] +end program demo_iqct +``` + +## Cosine transform of a real even sequence + +### `dcosti` + +#### Description + +Initializes the array `wsave` which is used in subroutine `dcost`. +The prime factorization of `n` together with a tabulation of the trigonometric functions are computed and stored in `wsave`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dcosti(interface)]](n , wsave)` + +#### Arguments + +`n`: Shall be a `integer` scalar. +This argument is `intent(in)`. +The length of the sequence to be transformed. +The method is most efficient when n-1 is a product of small primes. + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(out)`. +A work array which must be dimensioned at least `3*n+15`. +Different `wsave` arrays are required for different values of `n`. +The contents of `wsave` must not be changed between calls of `dcost`. + +#### Example + +```fortran +program demo_dcosti + use fftpack, only: dcosti + real(kind=8) :: w(3*4 + 15) + call dcosti(4, w) !! Initializes the array `w` which is used in subroutine `dcost`. +end program demo_dcosti +``` + +### `dcost` + +#### Description + +Computes the discrete fourier cosine transform of an even sequence `x(i)`. +The transform is defined below at output parameter `x`. + +`dcost` is the unnormalized inverse of itself since a call of `dcost` followed by another call of `dcost` will multiply the input sequence `x` by `2*(n-1)`. +The transform is defined below at output parameter `x`. + +The array `wsave` which is used by subroutine `dcost` must be initialized by calling subroutine `dcosti(n,wsave)`. + +#### Status + +Experimental + +#### Class + +Pure subroutine. + +#### Syntax + +`call [[fftpack(module):dcost(interface)]](n, x, wsave)` + +#### Arguments + +`n`: Shall be a `integer` scalar. +This argument is `intent(in)`. +The length of the sequence `x`. +`n` must be greater than `1`. +The method is most efficient when `n-1` is a product of small primes. + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(inout)`. +An array which contains the sequence to be transformed. +``` +for i=1,...,n + + x(i) = x(1)+(-1)**(i-1)*x(n) + + + the sum from k=2 to k=n-1 + + 2*x(k)*cos((k-1)*(i-1)*pi/(n-1)) + + a call of dcost followed by another call of + dcost will multiply the sequence x by 2*(n-1) + hence dcost is the unnormalized inverse + of itself. +``` + +`wsave`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +A work array which must be dimensioned at least `3*n+15` in the program that calls `dcost`. +The `wsave` array must be initialized by calling subroutine `dcosti(n,wsave)` and a different `wsave` array must be used for each different value of `n`. +This initialization does not have to be repeated so long as `n` remains unchanged thus subsequent +transforms can be obtained faster than the first. +Contains initialization calculations which must not be destroyed between calls of `dcost`. + +#### Example + +```fortran +program demo_dcost + use fftpack, only: dcosti, dcost + real(kind=8) :: x(4) = [1, 2, 3, 4] + real(kind=8) :: w(3*4 + 15) + call dcosti(4, w) + call dcost(4, x, w) !! Computes the discrete fourier cosine (forward) transform of an even sequence, `x`(unnormalized): [15.0, -4.0, 0.0, -1.0] + call dcost(4, x, w) !! Computes the discrete fourier cosine (backward) transform of an even sequence, `x`(unnormalized): [6.0, 12.0, 18.0, 24.0] +end program demo_dcost +``` + +### `dct` + +#### Description + +Discrete fourier cosine (forward) transform of an even sequence. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):dct(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` and rank-1 array. +This argument is `intent(in)`. +The data to transform. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the Discrete-Cosine Transform (DCT) of `x`. + +#### Notes + +Within numerical accuracy, `y == dct(idct(y))/2*(size(y) - 1)`. + +#### Example + +```fortran +program demo_dct + use fftpack, only: dct + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, dct(x,3) !! [8.0, -2.0, 0.0]. + print *, dct(x) !! [15.0, -4.0, 0.0, -1.0]. + print *, dct(x,5) !! [19.0, -1.8, -5.0, 3.8, -5.0]. + print *, dct(dct(x))/(2*(4 - 1)) !! (normalized): [1.0, 2.0, 3.0, 4.0] +end program demo_dct +``` + +### `idct` + +#### Description + +Unnormalized inverse of `dct`. +In fact, `idct` and `dct` have the same effect, `idct` = `dct`. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):idct(interface)]](x [, n])` + +#### Argument + +`x`: Shall be a `real` array. +This argument is `intent(in)`. +Transformed data to invert. + +`n`: Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`. +Defines the length of the Fourier transform. If `n` is not specified (the default) then `n = size(x)`. If `n <= size(x)`, `x` is truncated, if `n > size(x)`, `x` is zero-padded. + +#### Return value + +Returns a `real` and rank-1 array, the inverse Discrete-Cosine Transform (iDCT) of `x`. + +#### Example + +```fortran +program demo_idct + use fftpack, only: dct, idct + real(kind=8) :: x(4) = [1, 2, 3, 4] + print *, idct(dct(x))/(2*(4-1)) !! (normalized): [1.0, 2.0, 3.0, 4.0] + print *, idct(idct(x))/(2*(4-1)) !! (normalized): [1.0, 2.0, 3.0, 4.0] + print *, idct(dct(x), 3) !! (unnormalized): [7.0, 15.0, 23.0] +end program demo_idct +``` + + +## Utility functions + +### `fftshift` + +#### Description + +Rearranges the Fourier transform by moving the zero-frequency component to the center of the array. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):fftshift(interface)]](x)` + +#### Argument + +`x`: Shall be a `complex/real` and rank-1 array. +This argument is `intent(in)`. + +#### Return value + +Returns the `complex/real` and rank-1 Fourier transform by moving the zero-frequency component to the center of the array. + +#### Example + +```fortran +program demo_fftshift + use fftpack, only: fftshift + complex(kind=8) :: c(5) = [1, 2, 3, 4, 5] + real(kind=8) :: x(5) = [1, 2, 3, 4, 5] + print *, fftshift(c(1:4)) !! [(3.0,0.0), (4.0,0.0), (1.0,0.0), (2.0,0.0)] + print *, fftshift(c) !! [(4.0,0.0), (5.0,0.0), (1.0,0.0), (2.0,0.0), (3.0,0.0)] + print *, fftshift(x(1:4)) !! [3.0, 4.0, 1.0, 2.0] + print *, fftshift(x) !! [4.0, 5.0, 1.0, 2.0, 3.0] +end program demo_fftshift +``` + +### `ifftshift` + +#### Description + +Rearranges the Fourier transform with zero frequency shifting back to the original transform output. In other words, `ifftshift` is the result of undoing `fftshift`. + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Syntax + +`result = [[fftpack(module):ifftshift(interface)]](x)` + +#### Argument + +`x`: Shall be a `complex/real` and rank-1 array. +This argument is `intent(in)`. + +#### Return value + +Returns the `complex/real` and rank-1 Fourier transform with zero frequency shifting back to the original transform output. + +#### Example + +```fortran +program demo_ifftshift + use fftpack, only: fftshift, ifftshift + complex(kind=8) :: c(5) = [1, 2, 3, 4, 5] + real(kind=8) :: x(5) = [1, 2, 3, 4, 5] + print *, ifftshift(fftshift(c(1:4))) !! [(1.0,0.0), (2.0,0.0), (3.0,0.0), (4.0,0.0)] + print *, ifftshift(fftshift(c) ) !! [(1.0,0.0), (2.0,0.0), (3.0,0.0), (4.0,0.0), (5.0,0.0)] + print *, ifftshift(fftshift(x(1:4))) !! [1.0, 2.0, 3.0, 4.0] + print *, ifftshift(fftshift(x)) !! [1.0, 2.0, 3.0, 4.0, 5.0] +end program demo_ifftshift +``` diff --git a/src/src_rp/fftpack/doc/specs/index.md b/src/src_rp/fftpack/doc/specs/index.md new file mode 100644 index 0000000..083e2cc --- /dev/null +++ b/src/src_rp/fftpack/doc/specs/index.md @@ -0,0 +1,15 @@ +--- +title: Specifications (specs) +--- + +# Fortran fftpack Specifications (specs) + +[TOC] + +## Experimental Features & Modules + + - [fftpack](./fftpack.html) - fftpack module. + +## Released/Stable Features & Modules + + - (None yet) \ No newline at end of file diff --git a/src/src_rp/fftpack/example/bench1.f90 b/src/src_rp/fftpack/example/bench1.f90 new file mode 100644 index 0000000..c46496d --- /dev/null +++ b/src/src_rp/fftpack/example/bench1.f90 @@ -0,0 +1,41 @@ +program bench1 +use fftpack, only: zffti, zfftf, zfftb +use fftpack_kind, only: rk +implicit none +complex(rk), allocatable :: z(:) +real(rk), allocatable :: w(:), x(:) +real(rk) :: err, time_init, time_forward, time_backward, t1, t2 +integer :: N + +N = 1024*1014*16 + +allocate(x(N), z(N), w(4*N+15)) +call random_number(x) +z = x + +print *, "Initializing" +call cpu_time(t1) +call zffti(N, w) +call cpu_time(t2) +time_init = t2-t1 + +print *, "Forward" +call cpu_time(t1) +call zfftf(N, z, w) +call cpu_time(t2) +time_forward = t2-t1 + +print *, "Backward" +call cpu_time(t1) +call zfftb(N, z, w) +call cpu_time(t2) +time_backward = t2-t1 +print *, "Done" + +err = maxval(abs(x-real(z/N,rk))) +print * +print *, "Error: ", err +print *, "Init time: ", time_init +print *, "Forward time: ", time_forward +print *, "Backward time: ", time_backward +end program diff --git a/src/src_rp/fftpack/fpm.toml b/src/src_rp/fftpack/fpm.toml new file mode 100644 index 0000000..1ecbc3f --- /dev/null +++ b/src/src_rp/fftpack/fpm.toml @@ -0,0 +1,94 @@ + +name = "fftpack" +description = "A package of fortran subprograms for the fast fourier transform of periodic and other symmetric sequences" +homepage = "http://www.netlib.org/fftpack/" +version = "4.0.0" +license = "Public Domain" +author = "Paul N. Swarztrauber" +maintainer = "@fortran-lang" +copyright = "Copyright 1985 National Center for Atmospheric Research, Boulder, CO" +categories = ["Fast Fourier Transform"] +keywords = ["netlib", "fftpack", "fft"] + +[build] +auto-executables = false +auto-tests = false +auto-examples = true + +# Original test +[[test]] +name = "tstfft" +source-dir = "test" +main = "tstfft.f" + +# `fftpack` fft routines +[[test]] +name = "fftpack_zfft" +source-dir = "test" +main = "test_fftpack_zfft.f90" + +[[test]] +name = "fftpack_fft" +source-dir = "test" +main = "test_fftpack_fft.f90" + +[[test]] +name = "fftpack_ifft" +source-dir = "test" +main = "test_fftpack_ifft.f90" + +[[test]] +name = "fftpack_dfft" +source-dir = "test" +main = "test_fftpack_dfft.f90" + +[[test]] +name = "fftpack_rfft" +source-dir = "test" +main = "test_fftpack_rfft.f90" + +[[test]] +name = "fftpack_irfft" +source-dir = "test" +main = "test_fftpack_irfft.f90" + +[[test]] +name = "fftpack_dzfft" +source-dir = "test" +main = "test_fftpack_dzfft.f90" + +[[test]] +name = "fftpack_dcosq" +source-dir = "test" +main = "test_fftpack_dcosq.f90" + +[[test]] +name = "fftpack_qct" +source-dir = "test" +main = "test_fftpack_qct.f90" + +[[test]] +name = "fftpack_iqct" +source-dir = "test" +main = "test_fftpack_iqct.f90" + +[[test]] +name = "fftpack_dcost" +source-dir = "test" +main = "test_fftpack_dcost.f90" + +[[test]] +name = "fftpack_dct" +source-dir = "test" +main = "test_fftpack_dct.f90" + +# `fftpack` utility routines +[[test]] +name = "fftpack_fftshift" +source-dir = "test" +main = "test_fftpack_fftshift.f90" + +[[test]] +name = "fftpack_ifftshift" +source-dir = "test" +main = "test_fftpack_ifftshift.f90" diff --git a/src/src_rp/fftpack/src/Makefile b/src/src_rp/fftpack/src/Makefile new file mode 100644 index 0000000..0e97485 --- /dev/null +++ b/src/src_rp/fftpack/src/Makefile @@ -0,0 +1,140 @@ +SRCF = \ + zfftb.f90\ + cfftb1.f90\ + zfftf.f90\ + cfftf1.f90\ + zffti.f90\ + cffti1.f90\ + dcosqb.f90\ + cosqb1.f90\ + dcosqf.f90\ + cosqf1.f90\ + dcosqi.f90\ + dcost.f90\ + dcosti.f90\ + ezfft1.f90\ + dzfftb.f90\ + dzfftf.f90\ + dzffti.f90\ + passb.f90\ + passb2.f90\ + passb3.f90\ + passb4.f90\ + passb5.f90\ + passf.f90\ + passf2.f90\ + passf3.f90\ + passf4.f90\ + passf5.f90\ + radb2.f90\ + radb3.f90\ + radb4.f90\ + radb5.f90\ + radbg.f90\ + radf2.f90\ + radf3.f90\ + radf4.f90\ + radf5.f90\ + radfg.f90\ + dfftb.f90\ + rfftb1.f90\ + dfftf.f90\ + rfftf1.f90\ + dffti.f90\ + rffti1.f90\ + dsinqb.f90\ + dsinqf.f90\ + dsinqi.f90\ + dsint.f90\ + sint1.f90\ + dsinti.f90 + +SRCF90 = \ + fftpack.f90\ + fftpack_fft.f90\ + fftpack_ifft.f90\ + fftpack_rfft.f90\ + fftpack_irfft.f90\ + fftpack_fftshift.f90\ + fftpack_ifftshift.f90\ + fftpack_qct.f90\ + fftpack_iqct.f90\ + fftpack_dct.f90\ + rk.f90 + +OBJF := $(SRCF:.f90=.o) +OBJF90 := $(SRCF90:.f90=.o) + +lib$(LIB).a: $(OBJF) $(OBJF90) + ar -rcs lib$(LIB).a $(OBJF) $(OBJF90) + +shared: $(OBJ) + $(FC) -shared -o lib$(LIB).so $(OBJ) + +clean: + rm -f -r *.o *.a *.so *.mod *.smod + +%.o: %.f90 + $(FC) $(FFLAGS) -c $< + +compile: $(OBJF) $(OBJF90) + +fftpack_fft.o: fftpack.o rk.o +fftpack_ifft.o: fftpack.o rk.o +fftpack_rfft.o: fftpack.o rk.o +fftpack_irfft.o: fftpack.o rk.o +fftpack_qct.o: fftpack.o rk.o +fftpack_iqct.o: fftpack.o rk.o +fftpack_dct.o: fftpack.o rk.o +fftpack_fftshift.o: fftpack.o rk.o +fftpack_ifftshift.o: fftpack.o rk.o + +zfftb.f90: rk.o +cfftb1.f90: rk.o +zfftf.f90: rk.o +cfftf1.f90: rk.o +zffti.f90: rk.o +cffti1.f90: rk.o +dcosqb.f90: rk.o +cosqb1.f90: rk.o +dcosqf.f90: rk.o +cosqf1.f90: rk.o +dcosqi.f90: rk.o +dcost.f90: rk.o +dcosti.f90: rk.o +ezfft1.f90: rk.o +dzfftb.f90: rk.o +dzfftf.f90: rk.o +dzffti.f90: rk.o +passb.f90: rk.o +passb2.f90: rk.o +passb3.f90: rk.o +passb4.f90: rk.o +passb5.f90: rk.o +passf.f90: rk.o +passf2.f90: rk.o +passf3.f90: rk.o +passf4.f90: rk.o +passf5.f90: rk.o +radb2.f90: rk.o +radb3.f90: rk.o +radb4.f90: rk.o +radb5.f90: rk.o +radbg.f90: rk.o +radf2.f90: rk.o +radf3.f90: rk.o +radf4.f90: rk.o +radf5.f90: rk.o +radfg.f90: rk.o +dfftb.f90: rk.o +rfftb1.f90: rk.o +dfftf.f90: rk.o +rfftf1.f90: rk.o +dffti.f90: rk.o +rffti1.f90: rk.o +dsinqb.f90: rk.o +dsinqf.f90: rk.o +dsinqi.f90: rk.o +dsint.f90: rk.o +sint1.f90: rk.o +dsinti.f90: rk.o diff --git a/src/src_rp/fftpack/src/cfftb1.f90 b/src/src_rp/fftpack/src/cfftb1.f90 new file mode 100644 index 0000000..43f5b54 --- /dev/null +++ b/src/src_rp/fftpack/src/cfftb1.f90 @@ -0,0 +1,68 @@ + subroutine cfftb1(n,c,Ch,Wa,Ifac) + use fftpack_kind + implicit none + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4, & + k1 , l1 , l2 , n , n2 , na , nac , nf + dimension Ch(*) , c(*) , Wa(*) , Ifac(*) + nf = Ifac(2) + na = 0 + l1 = 1 + iw = 1 + do k1 = 1 , nf + ip = Ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido + ido + idl1 = idot*l1 + if ( ip==4 ) then + ix2 = iw + idot + ix3 = ix2 + idot + if ( na/=0 ) then + call passb4(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3)) + else + call passb4(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + endif + na = 1 - na + elseif ( ip==2 ) then + if ( na/=0 ) then + call passb2(idot,l1,Ch,c,Wa(iw)) + else + call passb2(idot,l1,c,Ch,Wa(iw)) + endif + na = 1 - na + elseif ( ip==3 ) then + ix2 = iw + idot + if ( na/=0 ) then + call passb3(idot,l1,Ch,c,Wa(iw),Wa(ix2)) + else + call passb3(idot,l1,c,Ch,Wa(iw),Wa(ix2)) + endif + na = 1 - na + elseif ( ip/=5 ) then + if ( na/=0 ) then + call passb(nac,idot,ip,l1,idl1,Ch,Ch,Ch,c,c,Wa(iw)) + else + call passb(nac,idot,ip,l1,idl1,c,c,c,Ch,Ch,Wa(iw)) + endif + if ( nac/=0 ) na = 1 - na + else + ix2 = iw + idot + ix3 = ix2 + idot + ix4 = ix3 + idot + if ( na/=0 ) then + call passb5(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + else + call passb5(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + endif + na = 1 - na + endif + l1 = l2 + iw = iw + (ip-1)*idot + enddo + if ( na==0 ) return + n2 = n + n + do i = 1 , n2 + c(i) = Ch(i) + enddo + end subroutine cfftb1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/cfftf1.f90 b/src/src_rp/fftpack/src/cfftf1.f90 new file mode 100644 index 0000000..0139f39 --- /dev/null +++ b/src/src_rp/fftpack/src/cfftf1.f90 @@ -0,0 +1,68 @@ + subroutine cfftf1(n,c,Ch,Wa,Ifac) + use fftpack_kind + implicit none + real(rk) :: c , Ch , Wa + integer :: i , idl1 , ido , idot , Ifac , ip , iw , ix2 , ix3 , ix4, & + k1 , l1 , l2 , n , n2 , na , nac , nf + dimension Ch(*) , c(*) , Wa(*) , Ifac(*) + nf = Ifac(2) + na = 0 + l1 = 1 + iw = 1 + do k1 = 1 , nf + ip = Ifac(k1+2) + l2 = ip*l1 + ido = n/l2 + idot = ido + ido + idl1 = idot*l1 + if ( ip==4 ) then + ix2 = iw + idot + ix3 = ix2 + idot + if ( na/=0 ) then + call passf4(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3)) + else + call passf4(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3)) + endif + na = 1 - na + elseif ( ip==2 ) then + if ( na/=0 ) then + call passf2(idot,l1,Ch,c,Wa(iw)) + else + call passf2(idot,l1,c,Ch,Wa(iw)) + endif + na = 1 - na + elseif ( ip==3 ) then + ix2 = iw + idot + if ( na/=0 ) then + call passf3(idot,l1,Ch,c,Wa(iw),Wa(ix2)) + else + call passf3(idot,l1,c,Ch,Wa(iw),Wa(ix2)) + endif + na = 1 - na + elseif ( ip/=5 ) then + if ( na/=0 ) then + call passf(nac,idot,ip,l1,idl1,Ch,Ch,Ch,c,c,Wa(iw)) + else + call passf(nac,idot,ip,l1,idl1,c,c,c,Ch,Ch,Wa(iw)) + endif + if ( nac/=0 ) na = 1 - na + else + ix2 = iw + idot + ix3 = ix2 + idot + ix4 = ix3 + idot + if ( na/=0 ) then + call passf5(idot,l1,Ch,c,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + else + call passf5(idot,l1,c,Ch,Wa(iw),Wa(ix2),Wa(ix3),Wa(ix4)) + endif + na = 1 - na + endif + l1 = l2 + iw = iw + (ip-1)*idot + enddo + if ( na==0 ) return + n2 = n + n + do i = 1 , n2 + c(i) = Ch(i) + enddo + end subroutine cfftf1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/cffti1.f90 b/src/src_rp/fftpack/src/cffti1.f90 new file mode 100644 index 0000000..1335697 --- /dev/null +++ b/src/src_rp/fftpack/src/cffti1.f90 @@ -0,0 +1,68 @@ + subroutine cffti1(n,Wa,Ifac) + use fftpack_kind + implicit none + real(rk) :: arg , argh , argld , fi , Wa + integer :: i , i1 , ib , ido , idot , Ifac , ii , ip , ipm , j , k1, & + l1 , l2 , ld , n , nf , nl , nq , nr , ntry + dimension Wa(*) , Ifac(*) + integer,dimension(4),parameter :: ntryh = [3 , 4 , 2 , 5] + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi + nl = n + nf = 0 + j = 0 + 100 j = j + 1 + if ( j<=4 ) then + ntry = ntryh(j) + else + ntry = ntry + 2 + endif + 200 nq = nl/ntry + nr = nl - ntry*nq + if ( nr/=0 ) goto 100 + nf = nf + 1 + Ifac(nf+2) = ntry + nl = nq + if ( ntry==2 ) then + if ( nf/=1 ) then + do i = 2 , nf + ib = nf - i + 2 + Ifac(ib+2) = Ifac(ib+1) + enddo + Ifac(3) = 2 + endif + endif + if ( nl/=1 ) goto 200 + Ifac(1) = n + Ifac(2) = nf + argh = tpi/real(n, rk) + i = 2 + l1 = 1 + do k1 = 1 , nf + ip = Ifac(k1+2) + ld = 0 + l2 = l1*ip + ido = n/l2 + idot = ido + ido + 2 + ipm = ip - 1 + do j = 1 , ipm + i1 = i + Wa(i-1) = 1.0_rk + Wa(i) = 0.0_rk + ld = ld + l1 + fi = 0.0_rk + argld = real(ld, rk)*argh + do ii = 4 , idot , 2 + i = i + 2 + fi = fi + 1.0_rk + arg = fi*argld + Wa(i-1) = cos(arg) + Wa(i) = sin(arg) + enddo + if ( ip>5 ) then + Wa(i1-1) = Wa(i-1) + Wa(i1) = Wa(i) + endif + enddo + l1 = l2 + enddo + end subroutine cffti1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/cosqb1.f90 b/src/src_rp/fftpack/src/cosqb1.f90 new file mode 100644 index 0000000..11d7f4a --- /dev/null +++ b/src/src_rp/fftpack/src/cosqb1.f90 @@ -0,0 +1,30 @@ + subroutine cosqb1(n,x,w,Xh) + use fftpack_kind + implicit none + integer :: i , k , kc , modn , n , np2 , ns2 + real(rk) :: w , x , Xh , xim1 + dimension x(*) , w(*) , Xh(*) + ns2 = (n+1)/2 + np2 = n + 2 + do i = 3 , n , 2 + xim1 = x(i-1) + x(i) + x(i) = x(i) - x(i-1) + x(i-1) = xim1 + enddo + x(1) = x(1) + x(1) + modn = mod(n,2) + if ( modn==0 ) x(n) = x(n) + x(n) + call dfftb(n,x,Xh) + do k = 2 , ns2 + kc = np2 - k + Xh(k) = w(k-1)*x(kc) + w(kc-1)*x(k) + Xh(kc) = w(k-1)*x(k) - w(kc-1)*x(kc) + enddo + if ( modn==0 ) x(ns2+1) = w(ns2)*(x(ns2+1)+x(ns2+1)) + do k = 2 , ns2 + kc = np2 - k + x(k) = Xh(k) + Xh(kc) + x(kc) = Xh(k) - Xh(kc) + enddo + x(1) = x(1) + x(1) + end subroutine cosqb1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/cosqf1.f90 b/src/src_rp/fftpack/src/cosqf1.f90 new file mode 100644 index 0000000..8ef39f4 --- /dev/null +++ b/src/src_rp/fftpack/src/cosqf1.f90 @@ -0,0 +1,28 @@ + subroutine cosqf1(n,x,w,Xh) + use fftpack_kind + implicit none + integer :: i , k , kc , modn , n , np2 , ns2 + real(rk) :: w , x , Xh , xim1 + dimension x(*) , w(*) , Xh(*) + ns2 = (n+1)/2 + np2 = n + 2 + do k = 2 , ns2 + kc = np2 - k + Xh(k) = x(k) + x(kc) + Xh(kc) = x(k) - x(kc) + enddo + modn = mod(n,2) + if ( modn==0 ) Xh(ns2+1) = x(ns2+1) + x(ns2+1) + do k = 2 , ns2 + kc = np2 - k + x(k) = w(k-1)*Xh(kc) + w(kc-1)*Xh(k) + x(kc) = w(k-1)*Xh(k) - w(kc-1)*Xh(kc) + enddo + if ( modn==0 ) x(ns2+1) = w(ns2)*Xh(ns2+1) + call dfftf(n,x,Xh) + do i = 3 , n , 2 + xim1 = x(i-1) - x(i) + x(i) = x(i-1) + x(i) + x(i-1) = xim1 + enddo + end subroutine cosqf1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dcosqb.f90 b/src/src_rp/fftpack/src/dcosqb.f90 new file mode 100644 index 0000000..1ab8de7 --- /dev/null +++ b/src/src_rp/fftpack/src/dcosqb.f90 @@ -0,0 +1,19 @@ + subroutine dcosqb(n,x,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: Wsave , x , x1 + dimension x(*) , Wsave(*) + real(rk),parameter :: tsqrt2 = 2.0_rk * sqrt(2.0_rk) + if ( n<2 ) then + x(1) = 4.0_rk*x(1) + return + elseif ( n==2 ) then + x1 = 4.0_rk*(x(1)+x(2)) + x(2) = tsqrt2*(x(1)-x(2)) + x(1) = x1 + return + else + call cosqb1(n,x,Wsave,Wsave(n+1)) + endif + end subroutine dcosqb \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dcosqf.f90 b/src/src_rp/fftpack/src/dcosqf.f90 new file mode 100644 index 0000000..27f4ceb --- /dev/null +++ b/src/src_rp/fftpack/src/dcosqf.f90 @@ -0,0 +1,17 @@ + subroutine dcosqf(n,x,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: tsqx , Wsave , x + dimension x(*) , Wsave(*) + real(rk),parameter :: sqrt2 = sqrt(2.0_rk) + if ( n<2 ) then + return + elseif ( n==2 ) then + tsqx = sqrt2*x(2) + x(2) = x(1) - tsqx + x(1) = x(1) + tsqx + else + call cosqf1(n,x,Wsave,Wsave(n+1)) + endif + end subroutine dcosqf \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dcosqi.f90 b/src/src_rp/fftpack/src/dcosqi.f90 new file mode 100644 index 0000000..1faf8d0 --- /dev/null +++ b/src/src_rp/fftpack/src/dcosqi.f90 @@ -0,0 +1,15 @@ + subroutine dcosqi(n,Wsave) + use fftpack_kind + implicit none + real(rk) :: dt , fk , Wsave + integer :: k , n + dimension Wsave(*) + real(rk),parameter :: pih = acos(-1.0_rk) / 2.0_rk ! pi / 2 + dt = pih/real(n, rk) + fk = 0.0_rk + do k = 1 , n + fk = fk + 1.0_rk + Wsave(k) = cos(fk*dt) + enddo + call dffti(n,Wsave(n+1)) + end subroutine dcosqi \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dcost.f90 b/src/src_rp/fftpack/src/dcost.f90 new file mode 100644 index 0000000..fdc431d --- /dev/null +++ b/src/src_rp/fftpack/src/dcost.f90 @@ -0,0 +1,48 @@ + subroutine dcost(n,x,Wsave) + use fftpack_kind + implicit none + real(rk) :: c1 , t1 , t2 , tx2 , Wsave , x , x1h , x1p3 , & + xi , xim2 + integer :: i , k , kc , modn , n , nm1 , np1 , ns2 + dimension x(*) , Wsave(*) + nm1 = n - 1 + np1 = n + 1 + ns2 = n/2 + if ( n<2 ) return + if ( n==2 ) then + x1h = x(1) + x(2) + x(2) = x(1) - x(2) + x(1) = x1h + return + elseif ( n>3 ) then + c1 = x(1) - x(n) + x(1) = x(1) + x(n) + do k = 2 , ns2 + kc = np1 - k + t1 = x(k) + x(kc) + t2 = x(k) - x(kc) + c1 = c1 + Wsave(kc)*t2 + t2 = Wsave(k)*t2 + x(k) = t1 - t2 + x(kc) = t1 + t2 + enddo + modn = mod(n,2) + if ( modn/=0 ) x(ns2+1) = x(ns2+1) + x(ns2+1) + call dfftf(nm1,x,Wsave(n+1)) + xim2 = x(2) + x(2) = c1 + do i = 4 , n , 2 + xi = x(i) + x(i) = x(i-2) - x(i-1) + x(i-1) = xim2 + xim2 = xi + enddo + if ( modn/=0 ) x(n) = xim2 + return + endif + x1p3 = x(1) + x(3) + tx2 = x(2) + x(2) + x(2) = x(1) - x(3) + x(1) = x1p3 + tx2 + x(3) = x1p3 - tx2 + end subroutine dcost \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dcosti.f90 b/src/src_rp/fftpack/src/dcosti.f90 new file mode 100644 index 0000000..ed4fc1d --- /dev/null +++ b/src/src_rp/fftpack/src/dcosti.f90 @@ -0,0 +1,21 @@ + subroutine dcosti(n,Wsave) + use fftpack_kind + implicit none + real(rk) :: dt , fk , Wsave + integer :: k , kc , n , nm1 , np1 , ns2 + dimension Wsave(*) + real(rk),parameter :: pi = acos(-1.0_rk) + if ( n<=3 ) return + nm1 = n - 1 + np1 = n + 1 + ns2 = n/2 + dt = pi/real(nm1, rk) + fk = 0.0_rk + do k = 2 , ns2 + kc = np1 - k + fk = fk + 1.0_rk + Wsave(k) = 2.0_rk*sin(fk*dt) + Wsave(kc) = 2.0_rk*cos(fk*dt) + enddo + call dffti(nm1,Wsave(n+1)) + end subroutine dcosti \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dfftb.f90 b/src/src_rp/fftpack/src/dfftb.f90 new file mode 100644 index 0000000..045edc1 --- /dev/null +++ b/src/src_rp/fftpack/src/dfftb.f90 @@ -0,0 +1,9 @@ + subroutine dfftb(n,r,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: r , Wsave + dimension r(*) , Wsave(*) + if ( n==1 ) return + call rfftb1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) + end subroutine dfftb \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dfftf.f90 b/src/src_rp/fftpack/src/dfftf.f90 new file mode 100644 index 0000000..d23437e --- /dev/null +++ b/src/src_rp/fftpack/src/dfftf.f90 @@ -0,0 +1,9 @@ + subroutine dfftf(n,r,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: r , Wsave + dimension r(*) , Wsave(*) + if ( n==1 ) return + call rfftf1(n,r,Wsave,Wsave(n+1),Wsave(2*n+1)) + end subroutine dfftf \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dffti.f90 b/src/src_rp/fftpack/src/dffti.f90 new file mode 100644 index 0000000..d9f07db --- /dev/null +++ b/src/src_rp/fftpack/src/dffti.f90 @@ -0,0 +1,9 @@ + subroutine dffti(n,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: Wsave + dimension Wsave(*) + if ( n==1 ) return + call rffti1(n,Wsave(n+1),Wsave(2*n+1)) + end subroutine dffti \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dsinqb.f90 b/src/src_rp/fftpack/src/dsinqb.f90 new file mode 100644 index 0000000..1832e6b --- /dev/null +++ b/src/src_rp/fftpack/src/dsinqb.f90 @@ -0,0 +1,23 @@ + subroutine dsinqb(n,x,Wsave) + use fftpack_kind + implicit none + integer :: k , kc , n , ns2 + real(rk) :: Wsave , x , xhold + dimension x(*) , Wsave(*) + if ( n>1 ) then + ns2 = n/2 + do k = 2 , n , 2 + x(k) = -x(k) + enddo + call dcosqb(n,x,Wsave) + do k = 1 , ns2 + kc = n - k + xhold = x(k) + x(k) = x(kc+1) + x(kc+1) = xhold + enddo + return + endif + x(1) = 4.0_rk*x(1) + return + end subroutine dsinqb \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dsinqf.f90 b/src/src_rp/fftpack/src/dsinqf.f90 new file mode 100644 index 0000000..66e7312 --- /dev/null +++ b/src/src_rp/fftpack/src/dsinqf.f90 @@ -0,0 +1,19 @@ + subroutine dsinqf(n,x,Wsave) + use fftpack_kind + implicit none + integer :: k , kc , n , ns2 + real(rk) :: Wsave , x , xhold + dimension x(*) , Wsave(*) + if ( n==1 ) return + ns2 = n/2 + do k = 1 , ns2 + kc = n - k + xhold = x(k) + x(k) = x(kc+1) + x(kc+1) = xhold + enddo + call dcosqf(n,x,Wsave) + do k = 2 , n , 2 + x(k) = -x(k) + enddo + end subroutine dsinqf \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dsinqi.f90 b/src/src_rp/fftpack/src/dsinqi.f90 new file mode 100644 index 0000000..d95e2db --- /dev/null +++ b/src/src_rp/fftpack/src/dsinqi.f90 @@ -0,0 +1,8 @@ + subroutine dsinqi(n,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: Wsave + dimension Wsave(*) + call dcosqi(n,Wsave) + end subroutine dsinqi \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dsint.f90 b/src/src_rp/fftpack/src/dsint.f90 new file mode 100644 index 0000000..8c97f2f --- /dev/null +++ b/src/src_rp/fftpack/src/dsint.f90 @@ -0,0 +1,12 @@ + subroutine dsint(n,x,Wsave) + use fftpack_kind + implicit none + integer :: iw1 , iw2 , iw3 , n , np1 + real(rk) :: Wsave , x + dimension x(*) , Wsave(*) + np1 = n + 1 + iw1 = n/2 + 1 + iw2 = iw1 + np1 + iw3 = iw2 + np1 + call sint1(n,x,Wsave,Wsave(iw1),Wsave(iw2),Wsave(iw3)) + end subroutine dsint \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dsinti.f90 b/src/src_rp/fftpack/src/dsinti.f90 new file mode 100644 index 0000000..2069076 --- /dev/null +++ b/src/src_rp/fftpack/src/dsinti.f90 @@ -0,0 +1,16 @@ + subroutine dsinti(n,Wsave) + use fftpack_kind + implicit none + real(rk) :: dt , Wsave + integer :: k , n , np1 , ns2 + dimension Wsave(*) + real(rk),parameter :: pi = acos(-1.0_rk) + if ( n<=1 ) return + ns2 = n/2 + np1 = n + 1 + dt = pi/real(np1, rk) + do k = 1 , ns2 + Wsave(k) = 2.0_rk*sin(k*dt) + enddo + call dffti(np1,Wsave(ns2+1)) + end subroutine dsinti \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dzfftb.f90 b/src/src_rp/fftpack/src/dzfftb.f90 new file mode 100644 index 0000000..e02dcc1 --- /dev/null +++ b/src/src_rp/fftpack/src/dzfftb.f90 @@ -0,0 +1,24 @@ + subroutine dzfftb(n,r,Azero,a,b,Wsave) + use fftpack_kind + implicit none + real(rk) :: a , Azero , b , r , Wsave + integer :: i , n , ns2 + dimension r(*) , a(*) , b(*) , Wsave(*) + if ( n<2 ) then + r(1) = Azero + return + elseif ( n==2 ) then + r(1) = Azero + a(1) + r(2) = Azero - a(1) + return + else + ns2 = (n-1)/2 + do i = 1 , ns2 + r(2*i) = 0.5_rk*a(i) + r(2*i+1) = -0.5_rk*b(i) + enddo + r(1) = Azero + if ( mod(n,2)==0 ) r(n) = a(ns2+1) + call dfftb(n,r,Wsave(n+1)) + endif + end subroutine dzfftb \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dzfftf.f90 b/src/src_rp/fftpack/src/dzfftf.f90 new file mode 100644 index 0000000..d122b9b --- /dev/null +++ b/src/src_rp/fftpack/src/dzfftf.f90 @@ -0,0 +1,35 @@ + subroutine dzfftf(n,r,Azero,a,b,Wsave) +! +! VERSION 3 JUNE 1979 +! + use fftpack_kind + implicit none + real(rk) :: a , Azero , b , cf , cfm , r , Wsave + integer :: i , n , ns2 , ns2m + dimension r(*) , a(*) , b(*) , Wsave(*) + if ( n<2 ) then + Azero = r(1) + return + elseif ( n==2 ) then + Azero = 0.5_rk*(r(1)+r(2)) + a(1) = 0.5_rk*(r(1)-r(2)) + return + else + do i = 1 , n + Wsave(i) = r(i) + enddo + call dfftf(n,Wsave,Wsave(n+1)) + cf = 2.0_rk/real(n, rk) + cfm = -cf + Azero = 0.5_rk*cf*Wsave(1) + ns2 = (n+1)/2 + ns2m = ns2 - 1 + do i = 1 , ns2m + a(i) = cf*Wsave(2*i) + b(i) = cfm*Wsave(2*i+1) + enddo + if ( mod(n,2)==1 ) return + a(ns2) = 0.5_rk*cf*Wsave(n) + b(ns2) = 0.0_rk + endif + end subroutine dzfftf \ No newline at end of file diff --git a/src/src_rp/fftpack/src/dzffti.f90 b/src/src_rp/fftpack/src/dzffti.f90 new file mode 100644 index 0000000..8b51821 --- /dev/null +++ b/src/src_rp/fftpack/src/dzffti.f90 @@ -0,0 +1,9 @@ + subroutine dzffti(n,Wsave) + use fftpack_kind + implicit none + integer :: n + real(rk) :: Wsave + dimension Wsave(*) + if ( n==1 ) return + call ezfft1(n,Wsave(2*n+1),Wsave(3*n+1)) + end subroutine dzffti \ No newline at end of file diff --git a/src/src_rp/fftpack/src/ezfft1.f90 b/src/src_rp/fftpack/src/ezfft1.f90 new file mode 100644 index 0000000..45e1c7d --- /dev/null +++ b/src/src_rp/fftpack/src/ezfft1.f90 @@ -0,0 +1,71 @@ + subroutine ezfft1(n,Wa,Ifac) + use fftpack_kind + implicit none + real(rk) :: arg1 , argh , ch1 , ch1h , dch1 , dsh1 , sh1 , & + Wa + integer :: i , ib , ido , Ifac , ii , ip , ipm , is , j , k1 , l1 , & + l2 , n , nf , nfm1 , nl , nq , nr , ntry + dimension Wa(*) , Ifac(*) + integer,dimension(4),parameter :: ntryh = [4 , 2 , 3 , 5] + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi + nl = n + nf = 0 + j = 0 + 100 j = j + 1 + if ( j<=4 ) then + ntry = ntryh(j) + else + ntry = ntry + 2 + endif + 200 nq = nl/ntry + nr = nl - ntry*nq + if ( nr/=0 ) goto 100 + nf = nf + 1 + Ifac(nf+2) = ntry + nl = nq + if ( ntry==2 ) then + if ( nf/=1 ) then + do i = 2 , nf + ib = nf - i + 2 + Ifac(ib+2) = Ifac(ib+1) + enddo + Ifac(3) = 2 + endif + endif + if ( nl/=1 ) goto 200 + Ifac(1) = n + Ifac(2) = nf + argh = tpi/real(n, rk) + is = 0 + nfm1 = nf - 1 + l1 = 1 + if ( nfm1==0 ) return + do k1 = 1 , nfm1 + ip = Ifac(k1+2) + l2 = l1*ip + ido = n/l2 + ipm = ip - 1 + arg1 = real(l1, rk)*argh + ch1 = 1.0_rk + sh1 = 0.0_rk + dch1 = cos(arg1) + dsh1 = sin(arg1) + do j = 1 , ipm + ch1h = dch1*ch1 - dsh1*sh1 + sh1 = dch1*sh1 + dsh1*ch1 + ch1 = ch1h + i = is + 2 + Wa(i-1) = ch1 + Wa(i) = sh1 + if ( ido>=5 ) then + do ii = 5 , ido , 2 + i = i + 2 + Wa(i-1) = ch1*Wa(i-3) - sh1*Wa(i-2) + Wa(i) = ch1*Wa(i-2) + sh1*Wa(i-3) + enddo + endif + is = is + ido + enddo + l1 = l2 + enddo + end subroutine ezfft1 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/fftpack.f90 b/src/src_rp/fftpack/src/fftpack.f90 new file mode 100644 index 0000000..8acfce4 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack.f90 @@ -0,0 +1,302 @@ +module fftpack + use fftpack_kind + + implicit none + private + + public :: zffti, zfftf, zfftb + public :: fft, ifft + public :: fftshift, ifftshift + + public :: dffti, dfftf, dfftb + public :: rfft, irfft + + public :: dzffti, dzfftf, dzfftb + + public :: dcosqi, dcosqf, dcosqb + public :: qct, iqct + + public :: dcosti, dcost + public :: dct, idct + + public :: rk + + interface + + !> Version: experimental + !> + !> Initialize `zfftf` and `zfftb`. + !> ([Specification](../page/specs/fftpack.html#zffti)) + pure subroutine zffti(n, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: wsave(*) + end subroutine zffti + + !> Version: experimental + !> + !> Forward transform of a complex periodic sequence. + !> ([Specification](../page/specs/fftpack.html#zfftf)) + pure subroutine zfftf(n, c, wsave) + import rk + integer, intent(in) :: n + complex(kind=rk), intent(inout) :: c(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine zfftf + + !> Version: experimental + !> + !> Unnormalized inverse of `zfftf`. + !> ([Specification](../page/specs/fftpack.html#zfftb)) + pure subroutine zfftb(n, c, wsave) + import rk + integer, intent(in) :: n + complex(kind=rk), intent(inout) :: c(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine zfftb + + !> Version: experimental + !> + !> Initialize `dfftf` and `dfftb`. + !> ([Specification](../page/specs/fftpack.html#dffti)) + pure subroutine dffti(n, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: wsave(*) + end subroutine dffti + + !> Version: experimental + !> + !> Forward transform of a real periodic sequence. + !> ([Specification](../page/specs/fftpack.html#dfftf)) + pure subroutine dfftf(n, r, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(inout) :: r(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dfftf + + !> Version: experimental + !> + !> Unnormalized inverse of `dfftf`. + !> ([Specification](../page/specs/fftpack.html#dfftb)) + pure subroutine dfftb(n, r, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(inout) :: r(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dfftb + + !> Version: experimental + !> + !> Initialize `dzfftf` and `dzfftb`. + !> ([Specification](../page/specs/fftpack.html#dzffti)) + pure subroutine dzffti(n, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: wsave(*) + end subroutine dzffti + + !> Version: experimental + !> + !> Simplified forward transform of a real periodic sequence. + !> ([Specification](../page/specs/fftpack.html#dzfftf)) + pure subroutine dzfftf(n, r, azero, a, b, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(in) :: r(*) + real(kind=rk), intent(out) :: azero + real(kind=rk), intent(out) :: a(*), b(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dzfftf + + !> Version: experimental + !> + !> Unnormalized inverse of `dzfftf`. + !> ([Specification](../page/specs/fftpack.html#dzfftb)) + pure subroutine dzfftb(n, r, azero, a, b, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: r(*) + real(kind=rk), intent(in) :: azero + real(kind=rk), intent(in) :: a(*), b(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dzfftb + + !> Version: experimental + !> + !> Initialize `dcosqf` and `dcosqb`. + !> ([Specification](../page/specs/fftpack.html#dcosqi)) + pure subroutine dcosqi(n, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: wsave(*) + end subroutine dcosqi + + !> Version: experimental + !> + !> Forward transform of quarter wave data. + !> ([Specification](../page/specs/fftpack.html#dcosqf)) + pure subroutine dcosqf(n, x, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dcosqf + + !> Version: experimental + !> + !> Unnormalized inverse of `dcosqf`. + !> ([Specification](../page/specs/fftpack.html#dcosqb)) + pure subroutine dcosqb(n, x, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dcosqb + + !> Version: experimental + !> + !> Initialize `dcost`. ([Specification](../page/specs/fftpack.html#dcosti)) + pure subroutine dcosti(n, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(out) :: wsave(*) + end subroutine dcosti + + !> Version: experimental + !> + !> Discrete fourier cosine transform of an even sequence. + !> ([Specification](../page/specs/fftpack.html#dcost)) + pure subroutine dcost(n, x, wsave) + import rk + integer, intent(in) :: n + real(kind=rk), intent(inout) :: x(*) + real(kind=rk), intent(in) :: wsave(*) + end subroutine dcost + + end interface + + !> Version: experimental + !> + !> Forward transform of a complex periodic sequence. + !> ([Specifiction](../page/specs/fftpack.html#fft)) + interface fft + pure module function fft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + complex(kind=rk), allocatable :: result(:) + end function fft_rk + end interface fft + + !> Version: experimental + !> + !> Backward transform of a complex periodic sequence. + !> ([Specifiction](../page/specs/fftpack.html#ifft)) + interface ifft + pure module function ifft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + complex(kind=rk), allocatable :: result(:) + end function ifft_rk + end interface ifft + + !> Version: experimental + !> + !> Forward transform of a real periodic sequence. + !> ([Specifiction](../page/specs/fftpack.html#rfft)) + interface rfft + pure module function rfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + end function rfft_rk + end interface rfft + + !> Version: experimental + !> + !> Backward transform of a real periodic sequence. + !> ([Specifiction](../page/specs/fftpack.html#irfft)) + interface irfft + pure module function irfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + end function irfft_rk + end interface irfft + + !> Version: experimental + !> + !> Forward transform of quarter wave data. + !> ([Specifiction](../page/specs/fftpack.html#qct)) + interface qct + pure module function qct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + end function qct_rk + end interface qct + + !> Version: experimental + !> + !> Backward transform of quarter wave data. + !> ([Specifiction](../page/specs/fftpack.html#iqct)) + interface iqct + pure module function iqct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + end function iqct_rk + end interface iqct + + !> Version: experimental + !> + !> Discrete fourier cosine (forward) transform of an even sequence. + !> ([Specification](../page/specs/fftpack.html#dct)) + interface dct + pure module function dct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + end function dct_rk + end interface dct + + !> Version: experimental + !> + !> Discrete fourier cosine (backward) transform of an even sequence. + !> ([Specification](../page/specs/fftpack.html#idct)) + interface idct + module procedure :: dct_rk + end interface idct + + !> Version: experimental + !> + !> Shifts zero-frequency component to center of spectrum. + !> ([Specifiction](../page/specs/fftpack.html#fftshift)) + interface fftshift + pure module function fftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + end function fftshift_crk + pure module function fftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + end function fftshift_rrk + end interface fftshift + + !> Version: experimental + !> + !> Shifts zero-frequency component to beginning of spectrum. + !> ([Specifiction](../page/specs/fftpack.html#ifftshift)) + interface ifftshift + pure module function ifftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + end function ifftshift_crk + pure module function ifftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + end function ifftshift_rrk + end interface ifftshift + +end module fftpack diff --git a/src/src_rp/fftpack/src/fftpack_dct.f90 b/src/src_rp/fftpack/src/fftpack_dct.f90 new file mode 100644 index 0000000..88a46d9 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_dct.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_dct + +contains + + !> Discrete fourier cosine transform of an even sequence. + pure module function dct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, (0.0_rk, i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 3*lenseq + 15 + allocate (wsave(lensav)) + call dcosti(lenseq, wsave) + + !> Discrete fourier cosine transformation + call dcost(lenseq, result, wsave) + + end function dct_rk + +end submodule fftpack_dct diff --git a/src/src_rp/fftpack/src/fftpack_fft.f90 b/src/src_rp/fftpack/src/fftpack_fft.f90 new file mode 100644 index 0000000..8f02ee0 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_fft.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_fft + +contains + + !> Forward transform of a complex periodic sequence. + pure module function fft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + complex(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, ((0.0_rk, 0.0_rk), i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 4*lenseq + 15 + allocate (wsave(lensav)) + call zffti(lenseq, wsave) + + !> Forward transformation + call zfftf(lenseq, result, wsave) + + end function fft_rk + +end submodule fftpack_fft diff --git a/src/src_rp/fftpack/src/fftpack_fftshift.f90 b/src/src_rp/fftpack/src/fftpack_fftshift.f90 new file mode 100644 index 0000000..a22dfc6 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_fftshift.f90 @@ -0,0 +1,23 @@ +submodule(fftpack) fftpack_fftshift + +contains + + !> Shifts zero-frequency component to center of spectrum for `complex` type. + pure module function fftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + + result = cshift(x, shift=-floor(0.5_rk*size(x))) + + end function fftshift_crk + + !> Shifts zero-frequency component to center of spectrum for `real` type. + pure module function fftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + + result = cshift(x, shift=-floor(0.5_rk*size(x))) + + end function fftshift_rrk + +end submodule fftpack_fftshift diff --git a/src/src_rp/fftpack/src/fftpack_ifft.f90 b/src/src_rp/fftpack/src/fftpack_ifft.f90 new file mode 100644 index 0000000..680e64b --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_ifft.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_ifft + +contains + + !> Backward transform of a complex periodic sequence. + pure module function ifft_rk(x, n) result(result) + complex(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + complex(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, ((0.0_rk, 0.0_rk), i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 4*lenseq + 15 + allocate (wsave(lensav)) + call zffti(lenseq, wsave) + + !> Backward transformation + call zfftb(lenseq, result, wsave) + + end function ifft_rk + +end submodule fftpack_ifft diff --git a/src/src_rp/fftpack/src/fftpack_ifftshift.f90 b/src/src_rp/fftpack/src/fftpack_ifftshift.f90 new file mode 100644 index 0000000..49830a7 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_ifftshift.f90 @@ -0,0 +1,23 @@ +submodule(fftpack) fftpack_ifftshift + +contains + + !> Shifts zero-frequency component to beginning of spectrum for `complex` type. + pure module function ifftshift_crk(x) result(result) + complex(kind=rk), intent(in) :: x(:) + complex(kind=rk), allocatable :: result(:) + + result = cshift(x, shift=-ceiling(0.5_rk*size(x))) + + end function ifftshift_crk + + !> Shifts zero-frequency component to beginning of spectrum for `real` type. + pure module function ifftshift_rrk(x) result(result) + real(kind=rk), intent(in) :: x(:) + real(kind=rk), allocatable :: result(:) + + result = cshift(x, shift=-ceiling(0.5_rk*size(x))) + + end function ifftshift_rrk + +end submodule fftpack_ifftshift diff --git a/src/src_rp/fftpack/src/fftpack_iqct.f90 b/src/src_rp/fftpack/src/fftpack_iqct.f90 new file mode 100644 index 0000000..1ae2a20 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_iqct.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_iqct + +contains + + !> Backward transform of quarter wave data. + pure module function iqct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, (0.0_rk, i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 3*lenseq + 15 + allocate (wsave(lensav)) + call dcosqi(lenseq, wsave) + + !> Backward transformation + call dcosqb(lenseq, result, wsave) + + end function iqct_rk + +end submodule fftpack_iqct diff --git a/src/src_rp/fftpack/src/fftpack_irfft.f90 b/src/src_rp/fftpack/src/fftpack_irfft.f90 new file mode 100644 index 0000000..13cdb05 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_irfft.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_irfft + +contains + + !> Backward transform of a real periodic sequence. + pure module function irfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, (0.0_rk, i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 2*lenseq + 15 + allocate (wsave(lensav)) + call dffti(lenseq, wsave) + + !> Backward transformation + call dfftb(lenseq, result, wsave) + + end function irfft_rk + +end submodule fftpack_irfft diff --git a/src/src_rp/fftpack/src/fftpack_qct.f90 b/src/src_rp/fftpack/src/fftpack_qct.f90 new file mode 100644 index 0000000..ceb2f6b --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_qct.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_qct + +contains + + !> Forward transform of quarter wave data. + pure module function qct_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, (0.0_rk, i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 3*lenseq + 15 + allocate (wsave(lensav)) + call dcosqi(lenseq, wsave) + + !> Forward transformation + call dcosqf(lenseq, result, wsave) + + end function qct_rk + +end submodule fftpack_qct diff --git a/src/src_rp/fftpack/src/fftpack_rfft.f90 b/src/src_rp/fftpack/src/fftpack_rfft.f90 new file mode 100644 index 0000000..2d10767 --- /dev/null +++ b/src/src_rp/fftpack/src/fftpack_rfft.f90 @@ -0,0 +1,36 @@ +submodule(fftpack) fftpack_rfft + +contains + + !> Forward transform of a real periodic sequence. + pure module function rfft_rk(x, n) result(result) + real(kind=rk), intent(in) :: x(:) + integer, intent(in), optional :: n + real(kind=rk), allocatable :: result(:) + + integer :: lenseq, lensav, i + real(kind=rk), allocatable :: wsave(:) + + if (present(n)) then + lenseq = n + if (lenseq <= size(x)) then + result = x(:lenseq) + else if (lenseq > size(x)) then + result = [x, (0.0_rk, i=1, lenseq - size(x))] + end if + else + lenseq = size(x) + result = x + end if + + !> Initialize FFT + lensav = 2*lenseq + 15 + allocate (wsave(lensav)) + call dffti(lenseq, wsave) + + !> Forward transformation + call dfftf(lenseq, result, wsave) + + end function rfft_rk + +end submodule fftpack_rfft diff --git a/src/src_rp/fftpack/src/passb.f90 b/src/src_rp/fftpack/src/passb.f90 new file mode 100644 index 0000000..12c3928 --- /dev/null +++ b/src/src_rp/fftpack/src/passb.f90 @@ -0,0 +1,125 @@ + subroutine passb(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none + real(rk) :: c1 , c2 , Cc , Ch , Ch2 , Wa , wai , war + integer :: i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer :: Nac , nt + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(*) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) + idot = Ido/2 + nt = Ip*Idl1 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + idp = Ip*Ido +! + if ( Idoidp ) idlj = idlj - idp + war = Wa(idlj-1) + wai = Wa(idlj) + do ik = 1 , Idl1 + c2(ik,l) = c2(ik,l) + war*Ch2(ik,j) + c2(ik,lc) = c2(ik,lc) + wai*Ch2(ik,jc) + enddo + enddo + enddo + do j = 2 , ipph + do ik = 1 , Idl1 + Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) + enddo + enddo + do j = 2 , ipph + jc = ipp2 - j + do ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) + Ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) + Ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) + Ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) + enddo + enddo + Nac = 1 + if ( Ido==2 ) return + Nac = 0 + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + c1(1,k,j) = Ch(1,k,j) + c1(2,k,j) = Ch(2,k,j) + enddo + enddo + if ( idot>l1 ) then + idj = 2 - Ido + do j = 2 , Ip + idj = idj + Ido + do k = 1 , l1 + idij = idj + do i = 4 , Ido , 2 + idij = idij + 2 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + *Ch(i-1,k,j) + enddo + enddo + enddo + return + endif + idij = 0 + do j = 2 , Ip + idij = idij + 2 + do i = 4 , Ido , 2 + idij = idij + 2 + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij)*Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij)*Ch(i-1,k,j) + enddo + enddo + enddo + return + end subroutine passb \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passb2.f90 b/src/src_rp/fftpack/src/passb2.f90 new file mode 100644 index 0000000..f75bf41 --- /dev/null +++ b/src/src_rp/fftpack/src/passb2.f90 @@ -0,0 +1,26 @@ + subroutine passb2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , Ido , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) + if ( Ido>2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) + Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) + ti2 = Cc(i,1,k) - Cc(i,2,k) + Ch(i,k,2) = Wa1(i-1)*ti2 + Wa1(i)*tr2 + Ch(i-1,k,2) = Wa1(i-1)*tr2 - Wa1(i)*ti2 + enddo + enddo + else + do k = 1 , l1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + enddo + end if + end subroutine passb2 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passb3.f90 b/src/src_rp/fftpack/src/passb3.f90 new file mode 100644 index 0000000..0161f73 --- /dev/null +++ b/src/src_rp/fftpack/src/passb3.f90 @@ -0,0 +1,47 @@ + subroutine passb3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , Ido , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,2,k) + Cc(i,3,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,2,k)-Cc(i-1,3,k)) + ci3 = taui*(Cc(i,2,k)-Cc(i,3,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i,k,2) = Wa1(i-1)*di2 + Wa1(i)*dr2 + Ch(i-1,k,2) = Wa1(i-1)*dr2 - Wa1(i)*di2 + Ch(i,k,3) = Wa2(i-1)*di3 + Wa2(i)*dr3 + Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 + enddo + enddo + else + do k = 1 , l1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + enddo + end if + end subroutine passb3 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passb4.f90 b/src/src_rp/fftpack/src/passb4.f90 new file mode 100644 index 0000000..0c78a1d --- /dev/null +++ b/src/src_rp/fftpack/src/passb4.f90 @@ -0,0 +1,56 @@ + subroutine passb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + & ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 , Wa2 , Wa3 + integer :: i , Ido , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + ti1 = Cc(i,1,k) - Cc(i,3,k) + ti2 = Cc(i,1,k) + Cc(i,3,k) + ti3 = Cc(i,2,k) + Cc(i,4,k) + tr4 = Cc(i,4,k) - Cc(i,2,k) + tr1 = Cc(i-1,1,k) - Cc(i-1,3,k) + tr2 = Cc(i-1,1,k) + Cc(i-1,3,k) + ti4 = Cc(i-1,2,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,2,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 + tr4 + cr4 = tr1 - tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-1)*cr2 - Wa1(i)*ci2 + Ch(i,k,2) = Wa1(i-1)*ci2 + Wa1(i)*cr2 + Ch(i-1,k,3) = Wa2(i-1)*cr3 - Wa2(i)*ci3 + Ch(i,k,3) = Wa2(i-1)*ci3 + Wa2(i)*cr3 + Ch(i-1,k,4) = Wa3(i-1)*cr4 - Wa3(i)*ci4 + Ch(i,k,4) = Wa3(i-1)*ci4 + Wa3(i)*cr4 + enddo + enddo + else + do k = 1 , l1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,4,k) - Cc(2,2,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,2,k) - Cc(1,4,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + enddo + end if + end subroutine passb4 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passb5.f90 b/src/src_rp/fftpack/src/passb5.f90 new file mode 100644 index 0000000..acdfbfe --- /dev/null +++ b/src/src_rp/fftpack/src/passb5.f90 @@ -0,0 +1,86 @@ + subroutine passb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , Ido , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(*) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + ti5 = Cc(i,2,k) - Cc(i,5,k) + ti2 = Cc(i,2,k) + Cc(i,5,k) + ti4 = Cc(i,3,k) - Cc(i,4,k) + ti3 = Cc(i,3,k) + Cc(i,4,k) + tr5 = Cc(i-1,2,k) - Cc(i-1,5,k) + tr2 = Cc(i-1,2,k) + Cc(i-1,5,k) + tr4 = Cc(i-1,3,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,3,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-1)*dr2 - Wa1(i)*di2 + Ch(i,k,2) = Wa1(i-1)*di2 + Wa1(i)*dr2 + Ch(i-1,k,3) = Wa2(i-1)*dr3 - Wa2(i)*di3 + Ch(i,k,3) = Wa2(i-1)*di3 + Wa2(i)*dr3 + Ch(i-1,k,4) = Wa3(i-1)*dr4 - Wa3(i)*di4 + Ch(i,k,4) = Wa3(i-1)*di4 + Wa3(i)*dr4 + Ch(i-1,k,5) = Wa4(i-1)*dr5 - Wa4(i)*di5 + Ch(i,k,5) = Wa4(i-1)*di5 + Wa4(i)*dr5 + enddo + enddo + else + do k = 1 , l1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + enddo + end if + end subroutine passb5 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passf.f90 b/src/src_rp/fftpack/src/passf.f90 new file mode 100644 index 0000000..ebf9278 --- /dev/null +++ b/src/src_rp/fftpack/src/passf.f90 @@ -0,0 +1,124 @@ + subroutine passf(Nac,Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none + real(rk) :: c1 , c2 , Cc , Ch , Ch2 , Wa , wai , war + integer :: i , idij , idj , idl , Idl1 , idlj , Ido , idot , idp , & + ik , inc , Ip , ipp2 , ipph , j , jc , k , l , l1 , lc + integer :: Nac , nt + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , Wa(*) , & + & c2(Idl1,Ip) , Ch2(Idl1,Ip) + idot = Ido/2 + nt = Ip*Idl1 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + idp = Ip*Ido +! + if ( Idoidp ) idlj = idlj - idp + war = Wa(idlj-1) + wai = Wa(idlj) + do ik = 1 , Idl1 + c2(ik,l) = c2(ik,l) + war*Ch2(ik,j) + c2(ik,lc) = c2(ik,lc) - wai*Ch2(ik,jc) + enddo + enddo + enddo + do j = 2 , ipph + do ik = 1 , Idl1 + Ch2(ik,1) = Ch2(ik,1) + Ch2(ik,j) + enddo + enddo + do j = 2 , ipph + jc = ipp2 - j + do ik = 2 , Idl1 , 2 + Ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) + Ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) + Ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) + Ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) + enddo + enddo + Nac = 1 + if ( Ido==2 ) return + Nac = 0 + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + c1(1,k,j) = Ch(1,k,j) + c1(2,k,j) = Ch(2,k,j) + enddo + enddo + if ( idot>l1 ) then + idj = 2 - Ido + do j = 2 , Ip + idj = idj + Ido + do k = 1 , l1 + idij = idj + do i = 4 , Ido , 2 + idij = idij + 2 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij) & + *Ch(i-1,k,j) + enddo + enddo + enddo + else + idij = 0 + do j = 2 , Ip + idij = idij + 2 + do i = 4 , Ido , 2 + idij = idij + 2 + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) + Wa(idij)*Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) - Wa(idij)*Ch(i-1,k,j) + enddo + enddo + enddo + end if + end subroutine passf \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passf2.f90 b/src/src_rp/fftpack/src/passf2.f90 new file mode 100644 index 0000000..4c9f17c --- /dev/null +++ b/src/src_rp/fftpack/src/passf2.f90 @@ -0,0 +1,26 @@ + subroutine passf2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , Ido , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) + if ( Ido>2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(i-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(i-1,2,k) + Ch(i,k,1) = Cc(i,1,k) + Cc(i,2,k) + ti2 = Cc(i,1,k) - Cc(i,2,k) + Ch(i,k,2) = Wa1(i-1)*ti2 - Wa1(i)*tr2 + Ch(i-1,k,2) = Wa1(i-1)*tr2 + Wa1(i)*ti2 + enddo + enddo + else + do k = 1 , l1 + Ch(1,k,1) = Cc(1,1,k) + Cc(1,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(1,2,k) + Ch(2,k,1) = Cc(2,1,k) + Cc(2,2,k) + Ch(2,k,2) = Cc(2,1,k) - Cc(2,2,k) + enddo + end if + end subroutine passf2 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passf3.f90 b/src/src_rp/fftpack/src/passf3.f90 new file mode 100644 index 0000000..165b286 --- /dev/null +++ b/src/src_rp/fftpack/src/passf3.f90 @@ -0,0 +1,47 @@ + subroutine passf3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + & dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , Ido , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + real(rk),parameter :: taui = -sqrt(3.0_rk) / 2.0_rk + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + tr2 = Cc(i-1,2,k) + Cc(i-1,3,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,2,k) + Cc(i,3,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,2,k)-Cc(i-1,3,k)) + ci3 = taui*(Cc(i,2,k)-Cc(i,3,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i,k,2) = Wa1(i-1)*di2 - Wa1(i)*dr2 + Ch(i-1,k,2) = Wa1(i-1)*dr2 + Wa1(i)*di2 + Ch(i,k,3) = Wa2(i-1)*di3 - Wa2(i)*dr3 + Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 + enddo + enddo + else + do k = 1 , l1 + tr2 = Cc(1,2,k) + Cc(1,3,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ti2 = Cc(2,2,k) + Cc(2,3,k) + ci2 = Cc(2,1,k) + taur*ti2 + Ch(2,k,1) = Cc(2,1,k) + ti2 + cr3 = taui*(Cc(1,2,k)-Cc(1,3,k)) + ci3 = taui*(Cc(2,2,k)-Cc(2,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + Ch(2,k,2) = ci2 + cr3 + Ch(2,k,3) = ci2 - cr3 + enddo + end if + end subroutine passf3 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passf4.f90 b/src/src_rp/fftpack/src/passf4.f90 new file mode 100644 index 0000000..110dea8 --- /dev/null +++ b/src/src_rp/fftpack/src/passf4.f90 @@ -0,0 +1,56 @@ + subroutine passf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + & ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3 , tr4 , & + & Wa1 , Wa2 , Wa3 + integer :: i , Ido , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + ti1 = Cc(i,1,k) - Cc(i,3,k) + ti2 = Cc(i,1,k) + Cc(i,3,k) + ti3 = Cc(i,2,k) + Cc(i,4,k) + tr4 = Cc(i,2,k) - Cc(i,4,k) + tr1 = Cc(i-1,1,k) - Cc(i-1,3,k) + tr2 = Cc(i-1,1,k) + Cc(i-1,3,k) + ti4 = Cc(i-1,4,k) - Cc(i-1,2,k) + tr3 = Cc(i-1,2,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 + tr4 + cr4 = tr1 - tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-1)*cr2 + Wa1(i)*ci2 + Ch(i,k,2) = Wa1(i-1)*ci2 - Wa1(i)*cr2 + Ch(i-1,k,3) = Wa2(i-1)*cr3 + Wa2(i)*ci3 + Ch(i,k,3) = Wa2(i-1)*ci3 - Wa2(i)*cr3 + Ch(i-1,k,4) = Wa3(i-1)*cr4 + Wa3(i)*ci4 + Ch(i,k,4) = Wa3(i-1)*ci4 - Wa3(i)*cr4 + enddo + enddo + else + do k = 1 , l1 + ti1 = Cc(2,1,k) - Cc(2,3,k) + ti2 = Cc(2,1,k) + Cc(2,3,k) + tr4 = Cc(2,2,k) - Cc(2,4,k) + ti3 = Cc(2,2,k) + Cc(2,4,k) + tr1 = Cc(1,1,k) - Cc(1,3,k) + tr2 = Cc(1,1,k) + Cc(1,3,k) + ti4 = Cc(1,4,k) - Cc(1,2,k) + tr3 = Cc(1,2,k) + Cc(1,4,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,3) = tr2 - tr3 + Ch(2,k,1) = ti2 + ti3 + Ch(2,k,3) = ti2 - ti3 + Ch(1,k,2) = tr1 + tr4 + Ch(1,k,4) = tr1 - tr4 + Ch(2,k,2) = ti1 + ti4 + Ch(2,k,4) = ti1 - ti4 + enddo + end if + end subroutine passf4 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/passf5.f90 b/src/src_rp/fftpack/src/passf5.f90 new file mode 100644 index 0000000..6c29b44 --- /dev/null +++ b/src/src_rp/fftpack/src/passf5.f90 @@ -0,0 +1,86 @@ + subroutine passf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , Ido , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(*) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = -sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = -sin(4.0_rk * pi / 5.0_rk) + if ( Ido/=2 ) then + do k = 1 , l1 + do i = 2 , Ido , 2 + ti5 = Cc(i,2,k) - Cc(i,5,k) + ti2 = Cc(i,2,k) + Cc(i,5,k) + ti4 = Cc(i,3,k) - Cc(i,4,k) + ti3 = Cc(i,3,k) + Cc(i,4,k) + tr5 = Cc(i-1,2,k) - Cc(i-1,5,k) + tr2 = Cc(i-1,2,k) + Cc(i-1,5,k) + tr4 = Cc(i-1,3,k) - Cc(i-1,4,k) + tr3 = Cc(i-1,3,k) + Cc(i-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-1)*dr2 + Wa1(i)*di2 + Ch(i,k,2) = Wa1(i-1)*di2 - Wa1(i)*dr2 + Ch(i-1,k,3) = Wa2(i-1)*dr3 + Wa2(i)*di3 + Ch(i,k,3) = Wa2(i-1)*di3 - Wa2(i)*dr3 + Ch(i-1,k,4) = Wa3(i-1)*dr4 + Wa3(i)*di4 + Ch(i,k,4) = Wa3(i-1)*di4 - Wa3(i)*dr4 + Ch(i-1,k,5) = Wa4(i-1)*dr5 + Wa4(i)*di5 + Ch(i,k,5) = Wa4(i-1)*di5 - Wa4(i)*dr5 + enddo + enddo + else + do k = 1 , l1 + ti5 = Cc(2,2,k) - Cc(2,5,k) + ti2 = Cc(2,2,k) + Cc(2,5,k) + ti4 = Cc(2,3,k) - Cc(2,4,k) + ti3 = Cc(2,3,k) + Cc(2,4,k) + tr5 = Cc(1,2,k) - Cc(1,5,k) + tr2 = Cc(1,2,k) + Cc(1,5,k) + tr4 = Cc(1,3,k) - Cc(1,4,k) + tr3 = Cc(1,3,k) + Cc(1,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + Ch(2,k,1) = Cc(2,1,k) + ti2 + ti3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(2,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(2,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,5) = cr2 + ci5 + Ch(2,k,2) = ci2 + cr5 + Ch(2,k,3) = ci3 + cr4 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(2,k,4) = ci3 - cr4 + Ch(2,k,5) = ci2 - cr5 + enddo + end if + end subroutine passf5 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radb2.f90 b/src/src_rp/fftpack/src/radb2.f90 new file mode 100644 index 0000000..b37708a --- /dev/null +++ b/src/src_rp/fftpack/src/radb2.f90 @@ -0,0 +1,31 @@ + subroutine radb2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,2,l1) , Ch(Ido,l1,2) , Wa1(*) + do k = 1 , l1 + Ch(1,k,1) = Cc(1,1,k) + Cc(Ido,2,k) + Ch(1,k,2) = Cc(1,1,k) - Cc(Ido,2,k) + enddo + if ( Ido<2 ) return + if ( Ido/=2 ) then + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + Ch(i-1,k,1) = Cc(i-1,1,k) + Cc(ic-1,2,k) + tr2 = Cc(i-1,1,k) - Cc(ic-1,2,k) + Ch(i,k,1) = Cc(i,1,k) - Cc(ic,2,k) + ti2 = Cc(i,1,k) + Cc(ic,2,k) + Ch(i-1,k,2) = Wa1(i-2)*tr2 - Wa1(i-1)*ti2 + Ch(i,k,2) = Wa1(i-2)*ti2 + Wa1(i-1)*tr2 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 + Ch(Ido,k,1) = Cc(Ido,1,k) + Cc(Ido,1,k) + Ch(Ido,k,2) = -(Cc(1,2,k)+Cc(1,2,k)) + enddo + end subroutine radb2 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radb3.f90 b/src/src_rp/fftpack/src/radb3.f90 new file mode 100644 index 0000000..f2c3e23 --- /dev/null +++ b/src/src_rp/fftpack/src/radb3.f90 @@ -0,0 +1,41 @@ + subroutine radb3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , cr2 , cr3 , di2 , di3 , & + dr2 , dr3 , ti2 , tr2 , Wa1 , Wa2 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,3,l1) , Ch(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = - 0.5_rk + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk + do k = 1 , l1 + tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) + cr2 = Cc(1,1,k) + taur*tr2 + Ch(1,k,1) = Cc(1,1,k) + tr2 + ci3 = taui*(Cc(1,3,k)+Cc(1,3,k)) + Ch(1,k,2) = cr2 - ci3 + Ch(1,k,3) = cr2 + ci3 + enddo + if ( Ido==1 ) return + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + tr2 = Cc(i-1,3,k) + Cc(ic-1,2,k) + cr2 = Cc(i-1,1,k) + taur*tr2 + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + ti2 = Cc(i,3,k) - Cc(ic,2,k) + ci2 = Cc(i,1,k) + taur*ti2 + Ch(i,k,1) = Cc(i,1,k) + ti2 + cr3 = taui*(Cc(i-1,3,k)-Cc(ic-1,2,k)) + ci3 = taui*(Cc(i,3,k)+Cc(ic,2,k)) + dr2 = cr2 - ci3 + dr3 = cr2 + ci3 + di2 = ci2 + cr3 + di3 = ci2 - cr3 + Ch(i-1,k,2) = Wa1(i-2)*dr2 - Wa1(i-1)*di2 + Ch(i,k,2) = Wa1(i-2)*di2 + Wa1(i-1)*dr2 + Ch(i-1,k,3) = Wa2(i-2)*dr3 - Wa2(i-1)*di3 + Ch(i,k,3) = Wa2(i-2)*di3 + Wa2(i-1)*dr3 + enddo + enddo + end subroutine radb3 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radb4.f90 b/src/src_rp/fftpack/src/radb4.f90 new file mode 100644 index 0000000..e6fadf5 --- /dev/null +++ b/src/src_rp/fftpack/src/radb4.f90 @@ -0,0 +1,62 @@ + subroutine radb4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3, & + tr4 , Wa1 , Wa2 , Wa3 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,4,l1) , Ch(Ido,l1,4) , Wa1(*) , Wa2(*) , Wa3(*) + real(rk),parameter :: sqrt2 = sqrt(2.0_rk) + do k = 1 , l1 + tr1 = Cc(1,1,k) - Cc(Ido,4,k) + tr2 = Cc(1,1,k) + Cc(Ido,4,k) + tr3 = Cc(Ido,2,k) + Cc(Ido,2,k) + tr4 = Cc(1,3,k) + Cc(1,3,k) + Ch(1,k,1) = tr2 + tr3 + Ch(1,k,2) = tr1 - tr4 + Ch(1,k,3) = tr2 - tr3 + Ch(1,k,4) = tr1 + tr4 + enddo + if ( Ido<2 ) return + if ( Ido/=2 ) then + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + ti1 = Cc(i,1,k) + Cc(ic,4,k) + ti2 = Cc(i,1,k) - Cc(ic,4,k) + ti3 = Cc(i,3,k) - Cc(ic,2,k) + tr4 = Cc(i,3,k) + Cc(ic,2,k) + tr1 = Cc(i-1,1,k) - Cc(ic-1,4,k) + tr2 = Cc(i-1,1,k) + Cc(ic-1,4,k) + ti4 = Cc(i-1,3,k) - Cc(ic-1,2,k) + tr3 = Cc(i-1,3,k) + Cc(ic-1,2,k) + Ch(i-1,k,1) = tr2 + tr3 + cr3 = tr2 - tr3 + Ch(i,k,1) = ti2 + ti3 + ci3 = ti2 - ti3 + cr2 = tr1 - tr4 + cr4 = tr1 + tr4 + ci2 = ti1 + ti4 + ci4 = ti1 - ti4 + Ch(i-1,k,2) = Wa1(i-2)*cr2 - Wa1(i-1)*ci2 + Ch(i,k,2) = Wa1(i-2)*ci2 + Wa1(i-1)*cr2 + Ch(i-1,k,3) = Wa2(i-2)*cr3 - Wa2(i-1)*ci3 + Ch(i,k,3) = Wa2(i-2)*ci3 + Wa2(i-1)*cr3 + Ch(i-1,k,4) = Wa3(i-2)*cr4 - Wa3(i-1)*ci4 + Ch(i,k,4) = Wa3(i-2)*ci4 + Wa3(i-1)*cr4 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 + ti1 = Cc(1,2,k) + Cc(1,4,k) + ti2 = Cc(1,4,k) - Cc(1,2,k) + tr1 = Cc(Ido,1,k) - Cc(Ido,3,k) + tr2 = Cc(Ido,1,k) + Cc(Ido,3,k) + Ch(Ido,k,1) = tr2 + tr2 + Ch(Ido,k,2) = sqrt2*(tr1-ti1) + Ch(Ido,k,3) = ti2 + ti2 + Ch(Ido,k,4) = -sqrt2*(tr1+ti1) + enddo + end subroutine radb4 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radb5.f90 b/src/src_rp/fftpack/src/radb5.f90 new file mode 100644 index 0000000..e90a4d8 --- /dev/null +++ b/src/src_rp/fftpack/src/radb5.f90 @@ -0,0 +1,73 @@ + subroutine radb5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,5,l1) , Ch(Ido,l1,5) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(*) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) + do k = 1 , l1 + ti5 = Cc(1,3,k) + Cc(1,3,k) + ti4 = Cc(1,5,k) + Cc(1,5,k) + tr2 = Cc(Ido,2,k) + Cc(Ido,2,k) + tr3 = Cc(Ido,4,k) + Cc(Ido,4,k) + Ch(1,k,1) = Cc(1,1,k) + tr2 + tr3 + cr2 = Cc(1,1,k) + tr11*tr2 + tr12*tr3 + cr3 = Cc(1,1,k) + tr12*tr2 + tr11*tr3 + ci5 = ti11*ti5 + ti12*ti4 + ci4 = ti12*ti5 - ti11*ti4 + Ch(1,k,2) = cr2 - ci5 + Ch(1,k,3) = cr3 - ci4 + Ch(1,k,4) = cr3 + ci4 + Ch(1,k,5) = cr2 + ci5 + enddo + if ( Ido==1 ) return + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + ti5 = Cc(i,3,k) + Cc(ic,2,k) + ti2 = Cc(i,3,k) - Cc(ic,2,k) + ti4 = Cc(i,5,k) + Cc(ic,4,k) + ti3 = Cc(i,5,k) - Cc(ic,4,k) + tr5 = Cc(i-1,3,k) - Cc(ic-1,2,k) + tr2 = Cc(i-1,3,k) + Cc(ic-1,2,k) + tr4 = Cc(i-1,5,k) - Cc(ic-1,4,k) + tr3 = Cc(i-1,5,k) + Cc(ic-1,4,k) + Ch(i-1,k,1) = Cc(i-1,1,k) + tr2 + tr3 + Ch(i,k,1) = Cc(i,1,k) + ti2 + ti3 + cr2 = Cc(i-1,1,k) + tr11*tr2 + tr12*tr3 + ci2 = Cc(i,1,k) + tr11*ti2 + tr12*ti3 + cr3 = Cc(i-1,1,k) + tr12*tr2 + tr11*tr3 + ci3 = Cc(i,1,k) + tr12*ti2 + tr11*ti3 + cr5 = ti11*tr5 + ti12*tr4 + ci5 = ti11*ti5 + ti12*ti4 + cr4 = ti12*tr5 - ti11*tr4 + ci4 = ti12*ti5 - ti11*ti4 + dr3 = cr3 - ci4 + dr4 = cr3 + ci4 + di3 = ci3 + cr4 + di4 = ci3 - cr4 + dr5 = cr2 + ci5 + dr2 = cr2 - ci5 + di5 = ci2 - cr5 + di2 = ci2 + cr5 + Ch(i-1,k,2) = Wa1(i-2)*dr2 - Wa1(i-1)*di2 + Ch(i,k,2) = Wa1(i-2)*di2 + Wa1(i-1)*dr2 + Ch(i-1,k,3) = Wa2(i-2)*dr3 - Wa2(i-1)*di3 + Ch(i,k,3) = Wa2(i-2)*di3 + Wa2(i-1)*dr3 + Ch(i-1,k,4) = Wa3(i-2)*dr4 - Wa3(i-1)*di4 + Ch(i,k,4) = Wa3(i-2)*di4 + Wa3(i-1)*dr4 + Ch(i-1,k,5) = Wa4(i-2)*dr5 - Wa4(i-1)*di5 + Ch(i,k,5) = Wa4(i-2)*di5 + Wa4(i-1)*dr5 + enddo + enddo + end subroutine radb5 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radbg.f90 b/src/src_rp/fftpack/src/radbg.f90 new file mode 100644 index 0000000..55a6af4 --- /dev/null +++ b/src/src_rp/fftpack/src/radbg.f90 @@ -0,0 +1,174 @@ + subroutine radbg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none + real(rk) :: ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , & + c2 , Cc , Ch , Ch2 , dc2 , dcp , ds2 , dsp , & + Wa + integer :: i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + ipph , is , j , j2 , jc , k , l , l1 , lc , nbd + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(*) + real(rk),parameter :: tpi = 2*acos(-1.0_rk) ! 2 * pi + arg = tpi/real(Ip, rk) + dcp = cos(arg) + dsp = sin(arg) + idp2 = Ido + 2 + nbd = (Ido-1)/2 + ipp2 = Ip + 2 + ipph = (Ip+1)/2 + if ( Idol1 ) then + is = -Ido + do j = 2 , Ip + is = is + Ido + do k = 1 , l1 + idij = is + do i = 3 , Ido , 2 + idij = idij + 2 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + *Ch(i-1,k,j) + enddo + enddo + enddo + else + is = -Ido + do j = 2 , Ip + is = is + Ido + idij = is + do i = 3 , Ido , 2 + idij = idij + 2 + do k = 1 , l1 + c1(i-1,k,j) = Wa(idij-1)*Ch(i-1,k,j) - Wa(idij) & + *Ch(i,k,j) + c1(i,k,j) = Wa(idij-1)*Ch(i,k,j) + Wa(idij) & + *Ch(i-1,k,j) + enddo + enddo + enddo + endif + end subroutine radbg \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radf2.f90 b/src/src_rp/fftpack/src/radf2.f90 new file mode 100644 index 0000000..51a6fc4 --- /dev/null +++ b/src/src_rp/fftpack/src/radf2.f90 @@ -0,0 +1,31 @@ + subroutine radf2(Ido,l1,Cc,Ch,Wa1) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ti2 , tr2 , Wa1 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Ch(Ido,2,l1) , Cc(Ido,l1,2) , Wa1(*) + do k = 1 , l1 + Ch(1,1,k) = Cc(1,k,1) + Cc(1,k,2) + Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,2) + enddo + if ( Ido<2 ) return + if ( Ido/=2 ) then + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + tr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + ti2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + Ch(i,1,k) = Cc(i,k,1) + ti2 + Ch(ic,2,k) = ti2 - Cc(i,k,1) + Ch(i-1,1,k) = Cc(i-1,k,1) + tr2 + Ch(ic-1,2,k) = Cc(i-1,k,1) - tr2 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 + Ch(1,2,k) = -Cc(Ido,k,2) + Ch(Ido,1,k) = Cc(Ido,k,1) + enddo + end subroutine radf2 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radf3.f90 b/src/src_rp/fftpack/src/radf3.f90 new file mode 100644 index 0000000..472489a --- /dev/null +++ b/src/src_rp/fftpack/src/radf3.f90 @@ -0,0 +1,40 @@ + subroutine radf3(Ido,l1,Cc,Ch,Wa1,Wa2) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , cr2 , di2 , di3 , dr2 , dr3 , & + ti2 , ti3 , tr2 , tr3 , Wa1 , Wa2 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Ch(Ido,3,l1) , Cc(Ido,l1,3) , Wa1(*) , Wa2(*) + real(rk),parameter :: taur = -0.5_rk + ! note: original comment said this was -SQRT(3)/2 but value was 0.86602540378443864676d0 + real(rk),parameter :: taui = sqrt(3.0_rk) / 2.0_rk + do k = 1 , l1 + cr2 = Cc(1,k,2) + Cc(1,k,3) + Ch(1,1,k) = Cc(1,k,1) + cr2 + Ch(1,3,k) = taui*(Cc(1,k,3)-Cc(1,k,2)) + Ch(Ido,2,k) = Cc(1,k,1) + taur*cr2 + enddo + if ( Ido==1 ) return + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + dr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + di3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + cr2 = dr2 + dr3 + ci2 = di2 + di3 + Ch(i-1,1,k) = Cc(i-1,k,1) + cr2 + Ch(i,1,k) = Cc(i,k,1) + ci2 + tr2 = Cc(i-1,k,1) + taur*cr2 + ti2 = Cc(i,k,1) + taur*ci2 + tr3 = taui*(di2-di3) + ti3 = taui*(dr3-dr2) + Ch(i-1,3,k) = tr2 + tr3 + Ch(ic-1,2,k) = tr2 - tr3 + Ch(i,3,k) = ti2 + ti3 + Ch(ic,2,k) = ti3 - ti2 + enddo + enddo + end subroutine radf3 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radf4.f90 b/src/src_rp/fftpack/src/radf4.f90 new file mode 100644 index 0000000..c0b62bb --- /dev/null +++ b/src/src_rp/fftpack/src/radf4.f90 @@ -0,0 +1,58 @@ + subroutine radf4(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , cr2 , cr3 , cr4 , & + ti1 , ti2 , ti3 , ti4 , tr1 , tr2 , tr3, & + tr4 , Wa1 , Wa2 , Wa3 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,l1,4) , Ch(Ido,4,l1) , Wa1(*) , Wa2(*) , Wa3(*) + real(rk),parameter :: hsqt2 = sqrt(2.0_rk) / 2.0_rk + do k = 1 , l1 + tr1 = Cc(1,k,2) + Cc(1,k,4) + tr2 = Cc(1,k,1) + Cc(1,k,3) + Ch(1,1,k) = tr1 + tr2 + Ch(Ido,4,k) = tr2 - tr1 + Ch(Ido,2,k) = Cc(1,k,1) - Cc(1,k,3) + Ch(1,3,k) = Cc(1,k,4) - Cc(1,k,2) + enddo + if ( Ido<2 ) return + if ( Ido/=2 ) then + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + cr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + ci2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + cr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + ci3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + cr4 = Wa3(i-2)*Cc(i-1,k,4) + Wa3(i-1)*Cc(i,k,4) + ci4 = Wa3(i-2)*Cc(i,k,4) - Wa3(i-1)*Cc(i-1,k,4) + tr1 = cr2 + cr4 + tr4 = cr4 - cr2 + ti1 = ci2 + ci4 + ti4 = ci2 - ci4 + ti2 = Cc(i,k,1) + ci3 + ti3 = Cc(i,k,1) - ci3 + tr2 = Cc(i-1,k,1) + cr3 + tr3 = Cc(i-1,k,1) - cr3 + Ch(i-1,1,k) = tr1 + tr2 + Ch(ic-1,4,k) = tr2 - tr1 + Ch(i,1,k) = ti1 + ti2 + Ch(ic,4,k) = ti1 - ti2 + Ch(i-1,3,k) = ti4 + tr3 + Ch(ic-1,2,k) = tr3 - ti4 + Ch(i,3,k) = tr4 + ti3 + Ch(ic,2,k) = tr4 - ti3 + enddo + enddo + if ( mod(Ido,2)==1 ) return + endif + do k = 1 , l1 + ti1 = -hsqt2*(Cc(Ido,k,2)+Cc(Ido,k,4)) + tr1 = hsqt2*(Cc(Ido,k,2)-Cc(Ido,k,4)) + Ch(Ido,1,k) = tr1 + Cc(Ido,k,1) + Ch(Ido,3,k) = Cc(Ido,k,1) - tr1 + Ch(1,2,k) = ti1 - Cc(Ido,k,3) + Ch(1,4,k) = ti1 + Cc(Ido,k,3) + enddo + end subroutine radf4 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radf5.f90 b/src/src_rp/fftpack/src/radf5.f90 new file mode 100644 index 0000000..5fbcb11 --- /dev/null +++ b/src/src_rp/fftpack/src/radf5.f90 @@ -0,0 +1,69 @@ + subroutine radf5(Ido,l1,Cc,Ch,Wa1,Wa2,Wa3,Wa4) + use fftpack_kind + implicit none + real(rk) :: Cc , Ch , ci2 , ci3 , ci4 , ci5 , cr2 , cr3 , & + cr4 , cr5 , di2 , di3 , di4 , di5 , dr2 , dr3 , & + dr4 , dr5 + real(rk) :: ti2 , ti3 , ti4 , ti5 , tr2 , tr3, & + tr4 , tr5 , Wa1 , Wa2 , Wa3 , Wa4 + integer :: i , ic , Ido , idp2 , k , l1 + dimension Cc(Ido,l1,5) , Ch(Ido,5,l1) , Wa1(*) , Wa2(*) , Wa3(*), & + Wa4(*) + real(rk),parameter :: pi = acos(-1.0_rk) + real(rk),parameter :: tr11 = cos(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti11 = sin(2.0_rk * pi / 5.0_rk) + real(rk),parameter :: tr12 = cos(4.0_rk * pi / 5.0_rk) + real(rk),parameter :: ti12 = sin(4.0_rk * pi / 5.0_rk) + do k = 1 , l1 + cr2 = Cc(1,k,5) + Cc(1,k,2) + ci5 = Cc(1,k,5) - Cc(1,k,2) + cr3 = Cc(1,k,4) + Cc(1,k,3) + ci4 = Cc(1,k,4) - Cc(1,k,3) + Ch(1,1,k) = Cc(1,k,1) + cr2 + cr3 + Ch(Ido,2,k) = Cc(1,k,1) + tr11*cr2 + tr12*cr3 + Ch(1,3,k) = ti11*ci5 + ti12*ci4 + Ch(Ido,4,k) = Cc(1,k,1) + tr12*cr2 + tr11*cr3 + Ch(1,5,k) = ti12*ci5 - ti11*ci4 + enddo + if ( Ido==1 ) return + idp2 = Ido + 2 + do k = 1 , l1 + do i = 3 , Ido , 2 + ic = idp2 - i + dr2 = Wa1(i-2)*Cc(i-1,k,2) + Wa1(i-1)*Cc(i,k,2) + di2 = Wa1(i-2)*Cc(i,k,2) - Wa1(i-1)*Cc(i-1,k,2) + dr3 = Wa2(i-2)*Cc(i-1,k,3) + Wa2(i-1)*Cc(i,k,3) + di3 = Wa2(i-2)*Cc(i,k,3) - Wa2(i-1)*Cc(i-1,k,3) + dr4 = Wa3(i-2)*Cc(i-1,k,4) + Wa3(i-1)*Cc(i,k,4) + di4 = Wa3(i-2)*Cc(i,k,4) - Wa3(i-1)*Cc(i-1,k,4) + dr5 = Wa4(i-2)*Cc(i-1,k,5) + Wa4(i-1)*Cc(i,k,5) + di5 = Wa4(i-2)*Cc(i,k,5) - Wa4(i-1)*Cc(i-1,k,5) + cr2 = dr2 + dr5 + ci5 = dr5 - dr2 + cr5 = di2 - di5 + ci2 = di2 + di5 + cr3 = dr3 + dr4 + ci4 = dr4 - dr3 + cr4 = di3 - di4 + ci3 = di3 + di4 + Ch(i-1,1,k) = Cc(i-1,k,1) + cr2 + cr3 + Ch(i,1,k) = Cc(i,k,1) + ci2 + ci3 + tr2 = Cc(i-1,k,1) + tr11*cr2 + tr12*cr3 + ti2 = Cc(i,k,1) + tr11*ci2 + tr12*ci3 + tr3 = Cc(i-1,k,1) + tr12*cr2 + tr11*cr3 + ti3 = Cc(i,k,1) + tr12*ci2 + tr11*ci3 + tr5 = ti11*cr5 + ti12*cr4 + ti5 = ti11*ci5 + ti12*ci4 + tr4 = ti12*cr5 - ti11*cr4 + ti4 = ti12*ci5 - ti11*ci4 + Ch(i-1,3,k) = tr2 + tr5 + Ch(ic-1,2,k) = tr2 - tr5 + Ch(i,3,k) = ti2 + ti5 + Ch(ic,2,k) = ti5 - ti2 + Ch(i-1,5,k) = tr3 + tr4 + Ch(ic-1,4,k) = tr3 - tr4 + Ch(i,5,k) = ti3 + ti4 + Ch(ic,4,k) = ti4 - ti3 + enddo + enddo + end subroutine radf5 \ No newline at end of file diff --git a/src/src_rp/fftpack/src/radfg.f90 b/src/src_rp/fftpack/src/radfg.f90 new file mode 100644 index 0000000..589a466 --- /dev/null +++ b/src/src_rp/fftpack/src/radfg.f90 @@ -0,0 +1,180 @@ + subroutine radfg(Ido,Ip,l1,Idl1,Cc,c1,c2,Ch,Ch2,Wa) + use fftpack_kind + implicit none + real(rk) :: ai1 , ai2 , ar1 , ar1h , ar2 , ar2h , arg , c1 , & + c2 , Cc , Ch , Ch2 , dc2 , dcp , ds2 , dsp , & + Wa + integer :: i , ic , idij , Idl1 , Ido , idp2 , ik , Ip , ipp2 , & + ipph , is , j , j2 , jc , k , l , l1 , lc , nbd + dimension Ch(Ido,l1,Ip) , Cc(Ido,Ip,l1) , c1(Ido,l1,Ip) , & + c2(Idl1,Ip) , Ch2(Idl1,Ip) , Wa(*) + real(rk),parameter :: tpi = 2.0_rk * acos(-1.0_rk) ! 2 * pi + arg = tpi/real(Ip, rk) + dcp = cos(arg) + dsp = sin(arg) + ipph = (Ip+1)/2 + ipp2 = Ip + 2 + idp2 = Ido + 2 + nbd = (Ido-1)/2 + if ( Ido==1 ) then + do ik = 1 , Idl1 + c2(ik,1) = Ch2(ik,1) + enddo + else + do ik = 1 , Idl1 + Ch2(ik,1) = c2(ik,1) + enddo + do j = 2 , Ip + do k = 1 , l1 + Ch(1,k,j) = c1(1,k,j) + enddo + enddo + if ( nbd>l1 ) then + is = -Ido + do j = 2 , Ip + is = is + Ido + do k = 1 , l1 + idij = is + do i = 3 , Ido , 2 + idij = idij + 2 + Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & + *c1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & + *c1(i-1,k,j) + enddo + enddo + enddo + else + is = -Ido + do j = 2 , Ip + is = is + Ido + idij = is + do i = 3 , Ido , 2 + idij = idij + 2 + do k = 1 , l1 + Ch(i-1,k,j) = Wa(idij-1)*c1(i-1,k,j) + Wa(idij) & + *c1(i,k,j) + Ch(i,k,j) = Wa(idij-1)*c1(i,k,j) - Wa(idij) & + *c1(i-1,k,j) + enddo + enddo + enddo + endif + if ( nbd real64 + real(kind=rk) :: eps = 1.0e-10_rk + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(all(idct(dct(x))/(2.0_rk*(4.0_rk - 1.0_rk)) == [real(kind=rk) :: 1, 2, 3, 4]), & + msg="`idct(dct(x))/(2.0_rk*(4.0_rk-1.0_rk))` failed.") + call check(all(idct(dct(x), 2)/(2.0_rk*(2.0_rk - 1.0_rk)) == [real(kind=rk) :: 5.5, 9.5]), & + msg="`idct(dct(x), 2)/(2.0_rk*(2.0_rk-1.0_rk))` failed.") + call check(all(idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk - 1.0_rk)) == & + [0.16666666666666666_rk, 0.33333333333333331_rk, 0.66666666666666663_rk, 0.83333333333333315_rk]), & + msg="`idct(dct(x, 2), 4)/(2.0_rk*(4.0_rk-1.0_rk))` failed.") + + end subroutine test_fftpack_idct + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_dfft.f90 b/src/src_rp/fftpack/test/test_fftpack_dfft.f90 new file mode 100644 index 0000000..bbad26a --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_dfft.f90 @@ -0,0 +1,34 @@ +program tester + + call test_fftpack_dfft() + print *, "All tests in `test_fftpack_dfft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_dfft() + use fftpack, only: dffti, dfftf, dfftb + use fftpack_kind + + real(kind=rk) :: x(4) + real(kind=rk) :: w(31) + + x = [1, 2, 3, 4] + + call dffti(4, w) + call dfftf(4, x, w) + call check(all(x == [real(kind=rk) :: 10, -2, 2, -2]), & + msg="`dfftf` failed.") + + call dfftb(4, x, w) + call check(all(x/4.0_rk == [real(kind=rk) :: 1, 2, 3, 4]), & + msg="`dfftb` failed.") + + end subroutine test_fftpack_dfft + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_dzfft.f90 b/src/src_rp/fftpack/test/test_fftpack_dzfft.f90 new file mode 100644 index 0000000..31f3ebc --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_dzfft.f90 @@ -0,0 +1,35 @@ +program tester + + call test_fftpack_dzfft + print *, "All tests in `test_fftpack_dzfft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_dzfft + use fftpack, only: dzffti, dzfftf, dzfftb + use fftpack_kind + + real(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: w(3*4 + 15) + real(kind=rk) :: azero, a(4/2), b(4/2) + + call dzffti(4, w) + call dzfftf(4, x, azero, a, b, w) + call check(azero == 2.5_rk, msg="azero == 2.5_rk failed.") + call check(all(a == [-1.0_rk, -0.5_rk]), msg="all(a == [-1.0, -0.5]) failed.") + call check(all(b == [-1.0_rk, 0.0_rk]), msg="all(b == [-1.0, 0.0]) failed.") + + x = 0 + call dzfftb(4, x, azero, a, b, w) + call check(all(x == [real(kind=rk) :: 1, 2, 3, 4]), msg="all(x = [real(kind=rk) :: 1, 2, 3, 4]) failed.") + + end subroutine test_fftpack_dzfft + +end program tester + diff --git a/src/src_rp/fftpack/test/test_fftpack_fft.f90 b/src/src_rp/fftpack/test/test_fftpack_fft.f90 new file mode 100644 index 0000000..1770065 --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_fft.f90 @@ -0,0 +1,30 @@ +program tester + + call test_fftpack_fft() + print *, "All tests in `test_fftpack_fft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_fft + use fftpack, only: fft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + complex(kind=rk) :: x(3) = [1.0_rk, 2.0_rk, 3.0_rk] + + call check(sum(abs(fft(x, 2) - [(3.0_rk, 0.0_rk), (-1.0_rk, 0.0_rk)])) < eps, & + msg="`fft(x, 2)` failed.") + call check(sum(abs(fft(x, 3) - fft(x))) < eps, & + msg="`fft(x, 3)` failed.") + call check(sum(abs(fft(x, 4) - [(6.0_rk, 0.0_rk), (-2.0_rk, -2.0_rk), (2.0_rk, 0.0_rk), (-2.0_rk, 2.0_rk)])) < eps, & + msg="`fft(x, 4)` failed.") + + end subroutine test_fftpack_fft + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_fftshift.f90 b/src/src_rp/fftpack/test/test_fftpack_fftshift.f90 new file mode 100644 index 0000000..2b90b3c --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_fftshift.f90 @@ -0,0 +1,43 @@ +program tester + + call test_fftpack_fftshift_complex + call test_fftpack_fftshift_real + print *, "All tests in `test_fftpack_fftshift` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_fftshift_complex + use fftpack, only: fftshift + use fftpack_kind + + complex(kind=rk) :: xeven(4) = [1, 2, 3, 4] + complex(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] + + call check(all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]), & + msg="all(fftshift(xeven) == [complex(kind=rk) :: 3, 4, 1, 2]) failed.") + call check(all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]), & + msg="all(fftshift(xodd) == [complex(kind=rk) :: 4, 5, 1, 2, 3]) failed.") + + end subroutine test_fftpack_fftshift_complex + + subroutine test_fftpack_fftshift_real + use fftpack, only: fftshift + use fftpack_kind + + real(kind=rk) :: xeven(4) = [1, 2, 3, 4] + real(kind=rk) :: xodd(5) = [1, 2, 3, 4, 5] + + call check(all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]), & + msg="all(fftshift(xeven) == [real(kind=rk) :: 3, 4, 1, 2]) failed.") + call check(all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]), & + msg="all(fftshift(xodd) == [real(kind=rk) :: 4, 5, 1, 2, 3]) failed.") + + end subroutine test_fftpack_fftshift_real + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_ifft.f90 b/src/src_rp/fftpack/test/test_fftpack_ifft.f90 new file mode 100644 index 0000000..d7c7f73 --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_ifft.f90 @@ -0,0 +1,30 @@ +program tester + + call test_fftpack_ifft() + print *, "All tests in `test_fftpack_ifft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_ifft + use fftpack, only: fft, ifft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + complex(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(sum(abs(ifft(fft(x))/4.0_rk - [complex(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`ifft(fft(x))/4.0_rk` failed.") + call check(sum(abs(ifft(fft(x), 2) - [complex(kind=rk) ::(8, 2), (12, -2)])) < eps, & + msg="`ifft(fft(x), 2)` failed.") + call check(sum(abs(ifft(fft(x, 2), 4) - [complex(kind=rk) ::(2, 0), (3, -1), (4, 0), (3, 1)])) < eps, & + msg="`ifft(fft(x, 2), 4)` failed.") + + end subroutine test_fftpack_ifft + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_ifftshift.f90 b/src/src_rp/fftpack/test/test_fftpack_ifftshift.f90 new file mode 100644 index 0000000..88f56ed --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_ifftshift.f90 @@ -0,0 +1,45 @@ +program tester + + call test_fftpack_ifftshift_complex + call test_fftpack_ifftshift_real + print *, "All tests in `test_fftpack_ifftshift` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_ifftshift_complex + use fftpack, only: ifftshift + use fftpack_kind + integer :: i + + complex(kind=rk) :: xeven(4) = [3, 4, 1, 2] + complex(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] + + call check(all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]), & + msg="all(ifftshift(xeven) == [complex(kind=rk) ::(i, i=1, 4)]) failed.") + call check(all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]), & + msg="all(ifftshift(xodd) == [complex(kind=rk) ::(i, i=1, 5)]) failed.") + + end subroutine test_fftpack_ifftshift_complex + + subroutine test_fftpack_ifftshift_real + use fftpack, only: ifftshift + use fftpack_kind + integer :: i + + real(kind=rk) :: xeven(4) = [3, 4, 1, 2] + real(kind=rk) :: xodd(5) = [4, 5, 1, 2, 3] + + call check(all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]), & + msg="all(ifftshift(xeven) == [real(kind=rk) ::(i, i=1, 4)]) failed.") + call check(all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]), & + msg="all(ifftshift(xodd) == [real(kind=rk) ::(i, i=1, 5)]) failed.") + + end subroutine test_fftpack_ifftshift_real + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_iqct.f90 b/src/src_rp/fftpack/test/test_fftpack_iqct.f90 new file mode 100644 index 0000000..62f535b --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_iqct.f90 @@ -0,0 +1,31 @@ +program tester + + call test_fftpack_iqct() + print *, "All tests in `test_fftpack_iqct` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_iqct + use fftpack, only: qct, iqct + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(sum(abs(iqct(qct(x))/(4.0_rk*4.0_rk) - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`iqct(qct(x)/(4.0_rk*4.0_rk)` failed.") + call check(sum(abs(iqct(qct(x), 2)/(4.0_rk*2.0_rk) - [1.4483415291679655_rk, 7.4608849947753271_rk])) < eps, & + msg="`iqct(qct(x), 2)/(4.0_rk*2.0_rk)` failed.") + call check(sum(abs(iqct(qct(x, 2), 4)/(4.0_rk*4.0_rk) - [0.5_rk, 0.70932417358418376_rk, 1.0_rk, & + 0.78858050747473762_rk])) < eps, & + msg="`iqct(qct(x, 2), 4)/(4.0_rk*4.0_rk)` failed.") + + end subroutine test_fftpack_iqct + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_irfft.f90 b/src/src_rp/fftpack/test/test_fftpack_irfft.f90 new file mode 100644 index 0000000..0c7e970 --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_irfft.f90 @@ -0,0 +1,30 @@ +program tester + + call test_fftpack_irfft() + print *, "All tests in `test_fftpack_irfft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_irfft + use fftpack, only: rfft, irfft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + real(kind=rk) :: x(4) = [1, 2, 3, 4] + + call check(sum(abs(irfft(rfft(x))/4.0_rk - [real(kind=rk) :: 1, 2, 3, 4])) < eps, & + msg="`irfft(rfft(x))/4.0_rk` failed.") + call check(sum(abs(irfft(rfft(x), 2) - [real(kind=rk) :: 8, 12])) < eps, & + msg="`irfft(rfft(x), 2)` failed.") + call check(sum(abs(irfft(rfft(x, 2), 4) - [real(kind=rk) :: 1, 3, 5, 3])) < eps, & + msg="`irfft(rfft(x, 2), 4)` failed.") + + end subroutine test_fftpack_irfft + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_qct.f90 b/src/src_rp/fftpack/test/test_fftpack_qct.f90 new file mode 100644 index 0000000..850d989 --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_qct.f90 @@ -0,0 +1,31 @@ +program tester + + call test_fftpack_qct() + print *, "All tests in `test_fftpack_qct` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_qct + use fftpack, only: qct + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + real(kind=rk) :: x(3) = [9, -9, 3] + + call check(sum(abs(qct(x, 2) - [-3.7279220613578570_rk, 21.727922061357859_rk])) < eps, & + msg="`qct(x, 2)` failed.") + call check(sum(abs(qct(x, 3) - qct(x))) < eps, & + msg="`qct(x,3)` failed.") + call check(sum(abs(qct(x, 4) - [-3.3871908980838743_rk, -2.1309424696909023_rk, & + 11.645661095452331_rk, 29.872472272322447_rk])) < eps, & + msg="`qct(x, 4)` failed.") + + end subroutine test_fftpack_qct + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_rfft.f90 b/src/src_rp/fftpack/test/test_fftpack_rfft.f90 new file mode 100644 index 0000000..cf37192 --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_rfft.f90 @@ -0,0 +1,30 @@ +program tester + + call test_fftpack_rfft() + print *, "All tests in `test_fftpack_rfft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_rfft + use fftpack, only: rfft + use fftpack_kind + real(kind=rk) :: eps = 1.0e-10_rk + + real(kind=rk) :: x(3) = [9, -9, 3] + + call check(sum(abs(rfft(x, 2) - [real(kind=rk) :: 0, 18])) < eps, & + msg="`rfft(x, 2)` failed.") + call check(sum(abs(rfft(x, 3) - rfft(x))) < eps, & + msg="`rfft(x, 3)` failed.") + call check(sum(abs(rfft(x, 4) - [real(kind=rk) :: 3, 6, 9, 21])) < eps, & + msg="`rfft(x, 4)` failed.") + + end subroutine test_fftpack_rfft + +end program tester diff --git a/src/src_rp/fftpack/test/test_fftpack_zfft.f90 b/src/src_rp/fftpack/test/test_fftpack_zfft.f90 new file mode 100644 index 0000000..b45ab3b --- /dev/null +++ b/src/src_rp/fftpack/test/test_fftpack_zfft.f90 @@ -0,0 +1,35 @@ +program tester + + call test_fftpack_zfft() + print *, "All tests in `test_fftpack_zfft` passed." + +contains + + subroutine check(condition, msg) + logical, intent(in) :: condition + character(*), intent(in) :: msg + if (.not. condition) error stop msg + end subroutine check + + subroutine test_fftpack_zfft() + use fftpack_kind + + use fftpack_kind + use fftpack, only: zffti, zfftf, zfftb + use fftpack_kind + + complex(kind=rk) :: x(4) = [1, 2, 3, 4] + real(kind=rk) :: w(31) + + call zffti(4, w) + call zfftf(4, x, w) + call check(all(x == [complex(kind=rk) ::(10, 0), (-2, 2), (-2, 0), (-2, -2)]), & + msg="`zfftf` failed.") + + call zfftb(4, x, w) + call check(all(x/4.0_rk == [complex(kind=rk) ::(1, 0), (2, 0), (3, 0), (4, 0)]), & + msg="`zfftb` failed.") + + end subroutine test_fftpack_zfft + +end program tester diff --git a/src/src_rp/fftpack/test/tstfft.f b/src/src_rp/fftpack/test/tstfft.f new file mode 100644 index 0000000..36a9a3f --- /dev/null +++ b/src/src_rp/fftpack/test/tstfft.f @@ -0,0 +1,411 @@ + PROGRAM TSTFFT +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C VERSION 4 APRIL 1985 +C +C A TEST DRIVER FOR +C A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER +C TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES +C +C BY +C +C PAUL N SWARZTRAUBER +C +C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER,COLORADO 80307 +C +C WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C +C THIS PROGRAM TESTS THE PACKAGE OF FAST FOURIER +C TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND +C CERTIAN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW. +C +C 1. RFFTI INITIALIZE RFFTF AND RFFTB +C 2. RFFTF FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE +C 3. RFFTB BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY +C +C 4. EZFFTI INITIALIZE EZFFTF AND EZFFTB +C 5. EZFFTF A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM +C 6. EZFFTB A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM +C +C 7. SINTI INITIALIZE SINT +C 8. SINT SINE TRANSFORM OF A REAL ODD SEQUENCE +C +C 9. COSTI INITIALIZE COST +C 10. COST COSINE TRANSFORM OF A REAL EVEN SEQUENCE +C +C 11. SINQI INITIALIZE SINQF AND SINQB +C 12. SINQF FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS +C 13. SINQB UNNORMALIZED INVERSE OF SINQF +C +C 14. COSQI INITIALIZE COSQF AND COSQB +C 15. COSQF FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS +C 16. COSQB UNNORMALIZED INVERSE OF COSQF +C +C 17. CFFTI INITIALIZE CFFTF AND CFFTB +C 18. CFFTF FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE +C 19. CFFTB UNNORMALIZED INVERSE OF CFFTF + +C *** HACKED BY HCP FOR THE DOUBLE PREC. VERSION NOVEMEMBER 1999 + + +C + USE fftpack_kind + IMPLICIT REAL(RK) (A-H,O-Z) + DIMENSION ND(10) ,X(200) ,Y(200) ,W(2000) , + 1 A(100) ,B(100) ,AH(100) ,BH(100) , + 2 XH(200) ,CX(200) ,CY(200) + COMPLEX(RK) CX ,CY + DATA ND(1),ND(2),ND(3),ND(4),ND(5),ND(6),ND(7)/120,54,49,32,4,3,2/ + SQRT2 = SQRT(2.0D0) + NNS = 7 + DO 157 NZ=1,NNS + N = ND(NZ) + MODN = MOD(N,2) + FN = REAL(N,RK) + TFN = FN+FN + NP1 = N+1 + NM1 = N-1 + DO 101 J=1,NP1 + X(J) = SIN(REAL(J,RK)*SQRT2) + Y(J) = X(J) + XH(J) = X(J) + 101 CONTINUE +C +C TEST SUBROUTINES RFFTI,RFFTF AND RFFTB +C + CALL DFFTI (N,W) + PI = 3.14159265358979323846D0 + DT = (PI+PI)/FN + NS2 = (N+1)/2 + IF (NS2 .LT. 2) GO TO 104 + DO 103 K=2,NS2 + SUM1 = 0.0D0 + SUM2 = 0.0D0 + ARG = REAL(K-1,RK)*DT + DO 102 I=1,N + ARG1 = REAL(I-1,RK)*ARG + SUM1 = SUM1+X(I)*COS(ARG1) + SUM2 = SUM2+X(I)*SIN(ARG1) + 102 CONTINUE + Y(2*K-2) = SUM1 + Y(2*K-1) = -SUM2 + 103 CONTINUE + 104 SUM1 = 0.0D0 + SUM2 = 0.0D0 + DO 105 I=1,NM1,2 + SUM1 = SUM1+X(I) + SUM2 = SUM2+X(I+1) + 105 CONTINUE + IF (MODN .EQ. 1) SUM1 = SUM1+X(N) + Y(1) = SUM1+SUM2 + IF (MODN .EQ. 0) Y(N) = SUM1-SUM2 + CALL DFFTF (N,X,W) + RFTF = 0.0D0 + DO 106 I=1,N + RFTF = DMAX1(RFTF,ABS(X(I)-Y(I))) + X(I) = XH(I) + 106 CONTINUE + RFTF = RFTF/FN + DO 109 I=1,N + SUM = 0.5D0*X(1) + ARG = REAL(I-1,RK)*DT + IF (NS2 .LT. 2) GO TO 108 + DO 107 K=2,NS2 + ARG1 = REAL(K-1,RK)*ARG + SUM = SUM+X(2*K-2)*COS(ARG1)-X(2*K-1)*SIN(ARG1) + 107 CONTINUE + 108 IF (MODN .EQ. 0) SUM = SUM+.5*REAL((-1)**(I-1),RK)*X(N) + Y(I) = SUM+SUM + 109 CONTINUE + CALL DFFTB (N,X,W) + RFTB = 0.0D0 + DO 110 I=1,N + RFTB = DMAX1(RFTB,ABS(X(I)-Y(I))) + X(I) = XH(I) + Y(I) = XH(I) + 110 CONTINUE + CALL DFFTB (N,Y,W) + CALL DFFTF (N,Y,W) + CF = 1.0D0/FN + RFTFB = 0. + DO 111 I=1,N + RFTFB = DMAX1(RFTFB,ABS(CF*Y(I)-X(I))) + 111 CONTINUE +C +C TEST SUBROUTINES DSINTI AND DSINT +C + DT = PI/FN + DO 112 I=1,NM1 + X(I) = XH(I) + 112 CONTINUE + DO 114 I=1,NM1 + Y(I) = 0.0D0 + ARG1 = REAL(I,RK)*DT + DO 113 K=1,NM1 + Y(I) = Y(I)+X(K)*SIN(REAL(K,RK)*ARG1) + 113 CONTINUE + Y(I) = Y(I)+Y(I) + 114 CONTINUE + CALL DSINTI (NM1,W) + CALL DSINT (NM1,X,W) + CF = 0.5D0/FN + SINTT = 0.0D0 + DO 115 I=1,NM1 + SINTT = DMAX1(SINTT,ABS(X(I)-Y(I))) + X(I) = XH(I) + Y(I) = X(I) + 115 CONTINUE + SINTT = CF*SINTT + CALL DSINT (NM1,X,W) + CALL DSINT (NM1,X,W) + SINTFB = 0.0D0 + DO 116 I=1,NM1 + SINTFB = DMAX1(SINTFB,ABS(CF*X(I)-Y(I))) + 116 CONTINUE +C +C TEST SUBROUTINES COSTI AND COST +C + DO 117 I=1,NP1 + X(I) = XH(I) + 117 CONTINUE + DO 119 I=1,NP1 + Y(I) = 0.5D0*(X(1)+REAL((-1)**(I+1),RK)*X(N+1)) + ARG = REAL(I-1,RK)*DT + DO 118 K=2,N + Y(I) = Y(I)+X(K)*COS(REAL(K-1,RK)*ARG) + 118 CONTINUE + Y(I) = Y(I)+Y(I) + 119 CONTINUE + CALL DCOSTI (NP1,W) + CALL DCOST (NP1,X,W) + COSTT = 0.0D0 + DO 120 I=1,NP1 + COSTT = DMAX1(COSTT,ABS(X(I)-Y(I))) + X(I) = XH(I) + Y(I) = XH(I) + 120 CONTINUE + COSTT = CF*COSTT + CALL DCOST (NP1,X,W) + CALL DCOST (NP1,X,W) + COSTFB = 0.0D0 + DO 121 I=1,NP1 + COSTFB = DMAX1(COSTFB,ABS(CF*X(I)-Y(I))) + 121 CONTINUE +C +C TEST SUBROUTINES SINQI,SINQF AND SINQB +C + CF = 0.25D0/FN + DO 122 I=1,N + Y(I) = XH(I) + 122 CONTINUE + DT = PI/(FN+FN) + DO 124 I=1,N + X(I) = 0.0D0 + ARG = DT*REAL(I,RK) + DO 123 K=1,N + X(I) = X(I)+Y(K)*SIN(REAL(K+K-1,RK)*ARG) + 123 CONTINUE + X(I) = 4.0D0*X(I) + 124 CONTINUE + CALL DSINQI (N,W) + CALL DSINQB (N,Y,W) + SINQBT = 0.0D0 + DO 125 I=1,N + SINQBT = DMAX1(SINQBT,ABS(Y(I)-X(I))) + X(I) = XH(I) + 125 CONTINUE + SINQBT = CF*SINQBT + DO 127 I=1,N + ARG = REAL(I+I-1,RK)*DT + Y(I) = 0.5D0*REAL((-1)**(I+1),RK)*X(N) + DO 126 K=1,NM1 + Y(I) = Y(I)+X(K)*SIN(REAL(K,RK)*ARG) + 126 CONTINUE + Y(I) = Y(I)+Y(I) + 127 CONTINUE + CALL DSINQF (N,X,W) + SINQFT = 0.0D0 + DO 128 I=1,N + SINQFT = DMAX1(SINQFT,ABS(X(I)-Y(I))) + Y(I) = XH(I) + X(I) = XH(I) + 128 CONTINUE + CALL DSINQF (N,Y,W) + CALL DSINQB (N,Y,W) + SINQFB = 0.0D0 + DO 129 I=1,N + SINQFB = DMAX1(SINQFB,ABS(CF*Y(I)-X(I))) + 129 CONTINUE +C +C TEST SUBROUTINES COSQI,COSQF AND COSQB +C + DO 130 I=1,N + Y(I) = XH(I) + 130 CONTINUE + DO 132 I=1,N + X(I) = 0.0D0 + ARG = REAL(I-1,RK)*DT + DO 131 K=1,N + X(I) = X(I)+Y(K)*COS(REAL(K+K-1,RK)*ARG) + 131 CONTINUE + X(I) = 4.0D0*X(I) + 132 CONTINUE + CALL DCOSQI (N,W) + CALL DCOSQB (N,Y,W) + COSQBT = 0.0D0 + DO 133 I=1,N + COSQBT = DMAX1(COSQBT,ABS(X(I)-Y(I))) + X(I) = XH(I) + 133 CONTINUE + COSQBT = CF*COSQBT + DO 135 I=1,N + Y(I) = 0.5D0*X(1) + ARG = REAL(I+I-1,RK)*DT + DO 134 K=2,N + Y(I) = Y(I)+X(K)*COS(REAL(K-1,RK)*ARG) + 134 CONTINUE + Y(I) = Y(I)+Y(I) + 135 CONTINUE + CALL DCOSQF (N,X,W) + COSQFT = 0.0D0 + DO 136 I=1,N + COSQFT = DMAX1(COSQFT,ABS(Y(I)-X(I))) + X(I) = XH(I) + Y(I) = XH(I) + 136 CONTINUE + COSQFT = CF*COSQFT + CALL DCOSQB (N,X,W) + CALL DCOSQF (N,X,W) + COSQFB = 0.0D0 + DO 137 I=1,N + COSQFB = DMAX1(COSQFB,ABS(CF*X(I)-Y(I))) + 137 CONTINUE +C +C TEST PROGRAMS EZFFTI,EZFFTF,EZFFTB +C + CALL DZFFTI(N,W) + DO 138 I=1,N + X(I) = XH(I) + 138 CONTINUE + TPI = 8.0D0*ATAN(1.0D0) + DT = TPI/REAL(N,RK) + NS2 = (N+1)/2 + CF = 2.0D0/REAL(N,RK) + NS2M = NS2-1 + IF (NS2M .LE. 0) GO TO 141 + DO 140 K=1,NS2M + SUM1 = 0.0D0 + SUM2 = 0.0D0 + ARG = REAL(K,RK)*DT + DO 139 I=1,N + ARG1 = REAL(I-1,RK)*ARG + SUM1 = SUM1+X(I)*COS(ARG1) + SUM2 = SUM2+X(I)*SIN(ARG1) + 139 CONTINUE + A(K) = CF*SUM1 + B(K) = CF*SUM2 + 140 CONTINUE + 141 NM1 = N-1 + SUM1 = 0.0D0 + SUM2 = 0.0D0 + DO 142 I=1,NM1,2 + SUM1 = SUM1+X(I) + SUM2 = SUM2+X(I+1) + 142 CONTINUE + IF (MODN .EQ. 1) SUM1 = SUM1+X(N) + AZERO = 0.5D0*CF*(SUM1+SUM2) + IF (MODN .EQ. 0) A(NS2) = 0.5D0*CF*(SUM1-SUM2) + CALL DZFFTF (N,X,AZEROH,AH,BH,W) + DEZF1 = ABS(AZEROH-AZERO) + IF (MODN .EQ. 0) DEZF1 = DMAX1(DEZF1,ABS(A(NS2)-AH(NS2))) + IF (NS2M .LE. 0) GO TO 144 + DO 143 I=1,NS2M + DEZF1 = DMAX1(DEZF1,ABS(AH(I)-A(I)),ABS(BH(I)-B(I))) + 143 CONTINUE + 144 NS2 = N/2 + IF (MODN .EQ. 0) B(NS2) = 0.0D0 + DO 146 I=1,N + SUM = AZERO + ARG1 = REAL(I-1,RK)*DT + DO 145 K=1,NS2 + ARG2 = REAL(K,RK)*ARG1 + SUM = SUM+A(K)*COS(ARG2)+B(K)*SIN(ARG2) + 145 CONTINUE + X(I) = SUM + 146 CONTINUE + CALL DZFFTB (N,Y,AZERO,A,B,W) + DEZB1 = 0.0D0 + DO 147 I=1,N + DEZB1 = DMAX1(DEZB1,ABS(X(I)-Y(I))) + X(I) = XH(I) + 147 CONTINUE + CALL DZFFTF (N,X,AZERO,A,B,W) + CALL DZFFTB (N,Y,AZERO,A,B,W) + DEZFB = 0.0D0 + DO 148 I=1,N + DEZFB = DMAX1(DEZFB,ABS(X(I)-Y(I))) + 148 CONTINUE +C +C TEST CFFTI,CFFTF,CFFTB +C + DO 149 I=1,N + CX(I) =DCMPLX(COS(SQRT2*REAL(I,RK)),SIN(SQRT2*REAL(I*I,RK))) + 149 CONTINUE + DT = (PI+PI)/FN + DO 151 I=1,N + ARG1 = -REAL(I-1,RK)*DT + CY(I) = (0.0D0,0.0D0) + DO 150 K=1,N + ARG2 = REAL(K-1,RK)*ARG1 + CY(I) = CY(I)+DCMPLX(COS(ARG2),SIN(ARG2))*CX(K) + 150 CONTINUE + 151 CONTINUE + CALL ZFFTI (N,W) + CALL ZFFTF (N,CX,W) + DCFFTF = 0.0D0 + DO 152 I=1,N + DCFFTF = DMAX1(DCFFTF,ABS(CX(I)-CY(I))) + CX(I) = CX(I)/FN + 152 CONTINUE + DCFFTF = DCFFTF/FN + DO 154 I=1,N + ARG1 = REAL(I-1,RK)*DT + CY(I) = (0.0D0,0.0D0) + DO 153 K=1,N + ARG2 = REAL(K-1,RK)*ARG1 + CY(I) = CY(I)+DCMPLX(COS(ARG2),SIN(ARG2))*CX(K) + 153 CONTINUE + 154 CONTINUE + CALL ZFFTB (N,CX,W) + DCFFTB = 0.0D0 + DO 155 I=1,N + DCFFTB = DMAX1(DCFFTB,ABS(CX(I)-CY(I))) + CX(I) = CY(I) + 155 CONTINUE + CF = 1.0D0/FN + CALL ZFFTF (N,CX,W) + CALL ZFFTB (N,CX,W) + DCFB = 0.0D0 + DO 156 I=1,N + DCFB = DMAX1(DCFB,ABS(CF*CX(I)-CY(I))) + 156 CONTINUE + WRITE (6,1001) N,RFTF,RFTB,RFTFB,SINTT,SINTFB,COSTT,COSTFB, + 1 SINQFT,SINQBT,SINQFB,COSQFT,COSQBT,COSQFB,DEZF1, + 2 DEZB1,DEZFB,DCFFTF,DCFFTB,DCFB + 157 CONTINUE +C +C +C + 1001 FORMAT (2H0N,I5,8H RFFTF ,E10.3,8H RFFTB ,E10.3,8H RFFTFB , + 1 E10.3,8H SINT ,E10.3,8H SINTFB ,E10.3,8H COST ,E10.3/ + 2 7X,8H COSTFB ,E10.3,8H SINQF ,E10.3,8H SINQB ,E10.3, + 3 8H SINQFB ,E10.3,8H COSQF ,E10.3,8H COSQB ,E10.3/7X, + 4 8H COSQFB ,E10.3,8H DEZF ,E10.3,8H DEZB ,E10.3, + 5 8H DEZFB ,E10.3,8H CFFTF ,E10.3,8H CFFTB ,E10.3/ + 6 7X,8H CFFTFB ,E10.3) +C + END diff --git a/src/src_rp/filter_dataset_for_flags.f90 b/src/src_rp/filter_dataset_for_flags.f90 index 3254434..1a45bb4 100644 --- a/src/src_rp/filter_dataset_for_flags.f90 +++ b/src/src_rp/filter_dataset_for_flags.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -52,7 +52,7 @@ subroutine FilterDatasetForFlags(LocCol, Raw, nrow, ncol) logical :: filtered(nrow) - write(*, '(a)', advance='no') ' Filtering raw data for custom flags..' + ! write(*, '(a)', advance='no') ' Filtering raw data for custom flags..' filtered = .false. !> External cycle on all columns do j = 1, ncol @@ -77,7 +77,13 @@ subroutine FilterDatasetForFlags(LocCol, Raw, nrow, ncol) end if end do Essentials%m_custom_flags = count(filtered) - write(*, '(a)') ' Done.' - write(*, '(a, i6)') ' Number of records eliminated for custom flags: ', Essentials%m_custom_flags + ! write(*, '(a)') ' Done.' + if (trim(EddyProProj%ftype) == 'licor_ghg') then + ! Native formats read quickly so progress report after + ! one day is fine. ghg files read very slow so that + ! a sign of life after each file is useful + write(*, '(a, i6)') ' Number of records eliminated for custom flags: ', & + Essentials%m_custom_flags + end if end subroutine FilterDatasetForFlags diff --git a/src/src_rp/fourier_transform.f90 b/src/src_rp/fourier_transform.f90 index 077abe6..1d30dec 100644 --- a/src/src_rp/fourier_transform.f90 +++ b/src/src_rp/fourier_transform.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -39,26 +39,36 @@ ! \todo !*************************************************************************** subroutine FourierTransform(xx, N, M) + use m_rp_global_var + use fftpack, only: dffti, dfftf + implicit none + !> in/out variables integer, intent(in) :: N integer, intent(in) :: M real(kind = dbl), intent(inout) :: xx(N, M) + !> local variables integer :: i - real :: xxx(N) - real :: wsave(N*2 + 15) + real(dbl) :: xxx(N) + real(dbl) :: wsave(N*2 + 15) write(*, '(a)', advance = 'no') ' FFT-ing..' - call rffti(N, wsave) + ! call rffti(N, wsave) + call dffti(N, wsave) do i = 1, M !> data in 1D vector - xxx(:) = sngl(xx(:, i)) + ! xxx(:) = sngl(xx(:, i)) + xxx(:) = xx(:, i) !> fast fourier transform - call rfftf(N, xxx, wsave) + ! call rfftf(N, xxx, wsave) + call dfftf(N, xxx, wsave) !> replace time data with spectral data - xx(:, i) = dble(xxx(:)) + ! xx(:, i) = dble(xxx(:)) + xx(:, i) = xxx(:) end do write(*,'(a)') ' Done.' + end subroutine FourierTransform diff --git a/src/src_rp/import_current_period.f90 b/src/src_rp/import_current_period.f90 index d67d17d..81c5ca6 100644 --- a/src/src_rp/import_current_period.f90 +++ b/src/src_rp/import_current_period.f90 @@ -6,20 +6,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -72,8 +72,8 @@ subroutine ImportCurrentPeriod(InitialTimestamp, FinalTimestamp, FileList, & integer :: FirstRecord integer :: LastRecord real(kind = sgl), allocatable :: fRaw(:, :) - real(kind = sgl) :: zero = 0. - real(kind = dbl) :: dzero = 0d0 + real(kind = sgl) :: zero = 0.0 + real(kind = dbl) :: dzero = 0.0_dbl logical :: InitialMetaIsNeeded logical :: skip_file logical :: passed(32) @@ -97,7 +97,7 @@ subroutine ImportCurrentPeriod(InitialTimestamp, FinalTimestamp, FileList, & InitialMetaIsNeeded = MetaIsNeeded pN = 0 if (EddyProProj%biomet_data == 'embedded') nbRecs = 0 - Raw = 0.d0 + Raw = 0.0_dbl CurrentFile = FirstFile rawfile_loop: do FileEndReached = .false. @@ -224,8 +224,8 @@ subroutine ImportCurrentPeriod(InitialTimestamp, FinalTimestamp, FileList, & !> substitute NaN and Inf with error code where (IsNaN(fbSet(:, :)) .or. & - fbSet(:, :) == 1d0 / dzero .or. & - fbSet(:, :) == -1d0 / dzero) & + fbSet(:, :) == 1.0_dbl / dzero .or. & + fbSet(:, :) == -1.0_dbl / dzero) & fbSet(:, :) = error !> Extend size of bSet to accommodate new data diff --git a/src/src_rp/init_outfiles_rp.f90 b/src/src_rp/init_outfiles_rp.f90 index 8836f85..21e80d2 100644 --- a/src/src_rp/init_outfiles_rp.f90 +++ b/src/src_rp/init_outfiles_rp.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -83,7 +83,7 @@ subroutine InitOutFiles_rp() e2sg(pe) = 'air_p_' call lowercase(e2sg(gas4)) - + do j = 1, NumUserVar usg(j) = UserCol(j)%label(1:len_trim(UserCol(j)%label)) // '_' call lowercase(usg(j)) @@ -104,7 +104,7 @@ subroutine InitOutFiles_rp() end if !> Raw dataset dir proceed = .false. - do i = 1, 7 + do i = 1, 8 if (RPsetup%out_raw(i)) then proceed = .true. exit @@ -142,6 +142,10 @@ subroutine InitOutFiles_rp() RawSubDir(7) = RawDir(1:len_trim(RawDir)) // 'level_7' // slash mkdir_status = CreateDir('"' // RawSubDir(7)(1:len_trim(RawSubDir(7))) // '"') end if + if (RPsetup%out_raw(8)) then + RawSubDir(8) = RawDir(1:len_trim(RawDir)) // 'crosscorr' // slash + mkdir_status = CreateDir('"' // RawSubDir(8)(1:len_trim(RawSubDir(8))) // '"') + end if end if !> Binned cospectral dir diff --git a/src/src_rp/kid.f90 b/src/src_rp/kid.f90 index 4ccfebd..4d5ac45 100644 --- a/src/src_rp/kid.f90 +++ b/src/src_rp/kid.f90 @@ -6,20 +6,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -38,8 +38,12 @@ ! \todo !*************************************************************************** subroutine KID(Set, nrow, ncol) + use m_rp_global_var + use mo_timelag_handle, only: VariableStochasticDetrending + implicit none + !> in/out variables integer, intent(in) :: nrow, ncol real(kind = dbl), intent(in) :: Set(nrow, ncol) @@ -62,4 +66,5 @@ subroutine KID(Set, nrow, ncol) Essentials%ZCD(var) = ierror end if end do -end subroutine KID \ No newline at end of file + +end subroutine KID diff --git a/src/src_rp/m_rp_global_var.f90 b/src/src_rp/m_rp_global_var.f90 index b7e198f..c2aa608 100644 --- a/src/src_rp/m_rp_global_var.f90 +++ b/src/src_rp/m_rp_global_var.f90 @@ -64,7 +64,7 @@ module m_rp_global_var character(PathLen) :: StatsDir character(PathLen) :: UserStatsDir character(PathLen) :: RawDir - character(PathLen) :: RawSubDir(7) + character(PathLen) :: RawSubDir(8) character(PathLen) :: BinCospectraDir character(PathLen) :: BinOgivesDir character(PathLen) :: CospectraDir @@ -87,7 +87,7 @@ module m_rp_global_var character(PathLen) :: TimelagOpt_Path character(PathLen) :: QCdetails_Path logical :: OutVarPresent(E2NumVar) - logical :: TimeLagOptSelected + ! logical :: TimeLagOptSelected logical :: SonicDataHasWBug !> global variables @@ -639,5 +639,7 @@ module m_rp_global_var SCTags(96)%Label / 'pf_subtract_b0' / & SCTags(97)%Label / 'pf_subset' / & SCTags(98)%Label / 'to_subset' / & - SCTags(99)%Label / 'wdf_apply' / + SCTags(99)%Label / 'wdf_apply' / & + SCTags(100)%Label / 'out_crosscorr' / + end module m_rp_global_var diff --git a/src/src_rp/mo_fftmax.f90 b/src/src_rp/mo_fftmax.f90 new file mode 100644 index 0000000..caa5442 --- /dev/null +++ b/src/src_rp/mo_fftmax.f90 @@ -0,0 +1,232 @@ +module mo_fftmax + + ! Written Feb 2022, Matthias Cuntz + + use m_numeric_kinds, only: i4, sp => sgl, dp => dbl + + implicit none + + private + + public :: correl ! correlation function between two vectors + public :: fftmax ! index of maximum correlation and actual time lag in s + public :: mean ! 1st moment of an array + + integer, parameter :: spc = sp + integer, parameter :: dpc = dp + + ! ------------------------------------------------------------------ + +contains + + ! ------------------------------------------------------------------ + + ! Fast Fourier Transform of complex numbers + function zfft(x) + + use fftpack, only: zffti, zfftf + + complex(dpc), dimension(:), intent(in) :: x + complex(dpc), dimension(size(x, 1)) :: zfft + + integer :: n + real(dpc), dimension(:), allocatable :: wsave + + n = size(x) + zfft = x + + ! initialise + allocate(wsave(4*n+15)) + call zffti(n, wsave) + + ! FFT + call zfftf(n, zfft, wsave) + + deallocate(wsave) + + return + + end function zfft + + ! Inverse Fast Fourier Transform of complex numbers + function izfft(x) + + use fftpack, only: zffti, zfftb + + complex(dpc), dimension(:), intent(in) :: x + complex(dpc), dimension(size(x, 1)) :: izfft + + integer(i4) :: n + real(dpc), dimension(:), allocatable :: wsave + + n = size(x) + izfft = x + + ! initialise + allocate(wsave(4*n+15)) + call zffti(n, wsave) + + ! inverse FFT + call zfftb(n, izfft, wsave) + izfft = izfft / real(n, dp) + + deallocate(wsave) + + return + + end function izfft + + ! ------------------------------------------------------------------ + + ! correlation function between two vectors + function correl(x, y, nadjust) + + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(:), intent(in) :: y + integer(i4), intent(out), optional :: nadjust + real(dp), dimension(size(x, 1)) :: correl + + integer(i4) :: n, nf + + n = size(x) + nf = 2**floor(log(real(n, dp))/log(2.0_dp)) + correl(1:nf) = real(izfft(zfft(cmplx(x(1:nf), kind=dpc)) & + * conjg(zfft(cmplx(y(1:nf), kind=dpc)))), dp) + + if (present(nadjust)) nadjust = nf + + return + + end function correl + + ! ------------------------------------------------------------------ + + subroutine fftmax(col1, col2, error, & + minlag, maxlag, ac_freq, & + tlag, rlag, & + ncorr, crosscorr) + + implicit none + + !> in/out variables + real(dp), dimension(:), intent(in) :: col1 ! data + real(dp), dimension(:), intent(in) :: col2 + real(dp), intent(in) :: error ! error label of data + integer, intent(in) :: minlag ! minimum possible time lag + integer, intent(in) :: maxlag ! maximum possible time lag + real(dp), intent(in) :: ac_freq ! acquisition frequency + real(dp), intent(out) :: tlag ! time lag [s] + integer, intent(out) :: rlag ! time lag index + integer, intent(out), optional :: ncorr ! length of 2**n + real(dp), dimension(size(col1, 1)), intent(out), optional :: crosscorr ! cross-covariance series + + !> local variables + integer(i4) :: i30 + real(dp) :: r1corr ! 1/icorr + integer :: icorr ! adjusted time series to length of 2**n + integer :: imax ! index of maximum covariance + real(dp), dimension(size(col1, 1)) :: acol1 ! anomalies + real(dp), dimension(size(col2, 1)) :: acol2 + real(dp), dimension(size(col1, 1)) :: cov12 ! cross-covariance series + real(dp), dimension(size(col1, 1)) :: corr12 ! cross-correlation series + logical, dimension(size(col1, 1)) :: mask1 ! data /= error + logical, dimension(size(col2, 1)) :: mask2 ! + real(dp), dimension(:), allocatable :: corr30 ! correlation series minlag to maxlag + logical :: dominmax + + dominmax = .true. + if ((minlag == 0) .and. (maxlag == 0)) then + ! nothing to do if .not. present(crosscorr) + dominmax = .false. + if (.not. present(crosscorr)) then + rlag = 0 + tlag = 0.0_dp + return + endif + endif + + ! correlation is done with anomalies + mask1 = col1 /= error + mask2 = col2 /= error + acol1 = merge(col1 - mean(col1, mask1), 0.0_dp, mask1) + acol2 = merge(col2 - mean(col2, mask2), 0.0_dp, mask2) + + ! cross-correlation time series + cov12 = correl(acol1, acol2, nadjust=icorr) + + ! cross-correlation time series: cov/n + r1corr = 1.0_dp / real(icorr, dp) + corr12(1:icorr) = cov12(1:icorr) * r1corr + + ! Sometimes corr is shifted on y-axis. I do not know why. + ! It could be numeric because of the large amount of data. + ! Workaround: shift corr around 0 in the tails of the time series, + ! which are in the middle of corr. + if (.not. ( (minval(corr12(1:icorr)) < 0.0_dp) .and. & + (maxval(corr12(1:icorr)) > 0.0_dp)) ) & + corr12(1:icorr) = corr12(1:icorr) - mean(corr12(icorr/3:2*icorr/3)) + + ! Get maximum + imax = maxloc(abs(corr12(1:icorr)), 1) - 1 + if (imax > icorr/2) imax = imax - icorr + + ! if time lag out of range + if ((imax < minlag) .or. (imax > maxlag)) then + if (dominmax) then + i30 = maxlag + abs(minlag) + 1 ! minlag < 0 possible + allocate(corr30(i30)) + corr30(1:maxlag+1) = corr12(1:maxlag+1) + corr30(maxlag+2:i30) = corr12(icorr-abs(minlag)+1:icorr) + ! maximum + imax = maxloc(abs(corr30), 1) - 1 + if (imax > (maxlag+1)) imax = imax - i30 + ! for better plotting, uncomment next two lines + icorr = i30 + corr12(1:icorr) = corr30(1:i30) + deallocate(corr30) + else + imax = 0 + endif + endif + + ! time lag index and actual time lag in s + rlag = imax + tlag = real(imax, kind=dp) / ac_freq + + if (present(ncorr)) ncorr = icorr + + if (present(crosscorr)) then + crosscorr(1:icorr) = corr12(1:icorr) + crosscorr(icorr+1:) = 0.0_dp + endif + + end subroutine fftmax + + ! ------------------------------------------------------------------ + + function mean(dat, mask) + ! sum(x)/n + implicit none + + real(dp), dimension(:), intent(IN) :: dat + logical, dimension(:), optional, intent(IN) :: mask + real(dp) :: mean + + real(dp) :: n + + logical, dimension(size(dat)) :: maske + + maske(:) = .true. + if (present(mask)) then + if (size(mask) /= size(dat)) stop 'Error mean: size(mask) /= size(dat)' + maske = mask + endif + n = real(count(maske),dp) + if (n <= (1.0_dp+tiny(1.0_dp))) stop 'mean: n must be at least 2' + + ! Mean + mean = sum(dat(:), mask=maske)/n + + end function mean + +end module mo_fftmax diff --git a/src/src_rp/optimize_timelags.f90 b/src/src_rp/optimize_timelags.f90 index 647e52f..9f9f951 100644 --- a/src/src_rp/optimize_timelags.f90 +++ b/src/src_rp/optimize_timelags.f90 @@ -207,6 +207,6 @@ subroutine OptimizeTimelags(toSet, nrow, actn, M, h2o_n, MM, cls_size) if (toH2O(1)%def == error .and. toH2O(MM)%def == error) then call ExceptionHandler(43) Meth%tlag = 'maxcov' - TimeLagOptSelected = .false. + ! TimeLagOptSelected = .false. end if end subroutine OptimizeTimelags diff --git a/src/src_rp/out_raw_data.f90 b/src/src_rp/out_raw_data.f90 index d2e9098..0f49019 100644 --- a/src/src_rp/out_raw_data.f90 +++ b/src/src_rp/out_raw_data.f90 @@ -57,6 +57,8 @@ subroutine OutRawData(date, time, Set, nrow, ncol, level) character(256) :: string character(256) :: string_utf8 real(kind = dbl) :: OutSet(nrow, ncol) + integer :: hlen + character(512) :: raw_out_corr !> If binned (co)spectra or at least one full (co)spectrum are requested, !> perform all related calculations @@ -86,21 +88,44 @@ subroutine OutRawData(date, time, Set, nrow, ncol, level) & mole fraction [mmol/mol] or mixing ratio [mmol/mol]& &, depending on raw data' write(udf, '(a)') - write(udf, '(a)') raw_out_header(1:len_trim(raw_out_header)) + if (level == 8) then + raw_out_corr = ' ' + hlen = 3 + do j=5, ncol + if (E2Col(j)%present) then + raw_out_corr = raw_out_corr(1:hlen) // E2Col(j)%var + hlen = hlen + 25 + end if + end do + write(udf, '(a)') raw_out_corr(1:hlen) + else + write(udf, '(a)') raw_out_header(1:len_trim(raw_out_header)) + end if !> Define output dataset num_var = 0 - do j = 1, ncol - if (RPsetup%out_raw_var(j)) then - num_var = num_var + 1 - OutSet(:, num_var) = Set(:, j) - end if - end do + if (level == 8) then + do j = 5, ncol + if (E2Col(j)%present) then + num_var = num_var + 1 + OutSet(:, num_var) = Set(:, j) + end if + end do + else + do j = 1, ncol + if (RPsetup%out_raw_var(j)) then + num_var = num_var + 1 + OutSet(:, num_var) = Set(:, j) + end if + end do + end if !> write output dataset do i = 1, nrow - write(udf,*) OutSet(i, 1: num_var) + write(udf,*) OutSet(i, 1:num_var) end do + close(udf) write(*, '(a)') ' Done.' + end subroutine OutRawData diff --git a/src/src_rp/read_ini_rp.f90 b/src/src_rp/read_ini_rp.f90 index f63fdd1..5915d56 100644 --- a/src/src_rp/read_ini_rp.f90 +++ b/src/src_rp/read_ini_rp.f90 @@ -7,20 +7,20 @@ ! ! This file is part of EddyPro®. ! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. +! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for +! non-commercial academic and government research purposes only, +! as provided in the EDDYPRO® End User License Agreement. ! EDDYPRO® may only be used as provided in the End User License Agreement ! and may not be used or accessed for any commercial purposes. ! You may view a copy of the End User License Agreement in the file ! EULA_NON_COMMERCIAL.rtf. ! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial +! Commercial companies that are LI-COR flux system customers +! are encouraged to contact LI-COR directly for our commercial ! EDDYPRO® End User License Agreement. ! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the +! EDDYPRO® contains Open Source Components (as defined in the +! End User License Agreement). The licenses and/or notices for the ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. ! ! EddyPro® is distributed in the hope that it will be useful, @@ -53,7 +53,7 @@ subroutine ReadIniRP(key) !> parse processing.eddypro file and store [Project] variables, !> common to all programs - call ParseIniFile(PrjPath, 'Project', EPPrjNTags, EPPrjCTags,& + call ParseIniFile(PrjPath, 'Project', EPPrjNTags, EPPrjCTags, & size(EPPrjNTags), size(EPPrjCTags), SNTagFound, SCTagFound, & IniFileNotFound) @@ -61,7 +61,7 @@ subroutine ReadIniRP(key) call WriteProcessingProjectVariables() !> parse processing.eddypro file and store all numeric and character tags - call ParseIniFile(PrjPath, key, SNTags, SCTags, size(SNTags), size(SCTags),& + call ParseIniFile(PrjPath, key, SNTags, SCTags, size(SNTags), size(SCTags), & SNTagFound, SCTagFound, IniFileNotFound) if (IniFileNotFound) call ExceptionHandler(21) @@ -297,6 +297,7 @@ subroutine WriteVariablesRP() RPsetup%out_raw(5) = SCTags(72)%value(1:1) == '1' RPsetup%out_raw(6) = SCTags(73)%value(1:1) == '1' RPsetup%out_raw(7) = SCTags(74)%value(1:1) == '1' + RPsetup%out_raw(8) = SCTags(100)%value(1:1) == '1' RPsetup%out_raw_var(u) = SCTags(75)%value(1:1) == '1' RPsetup%out_raw_var(v) = SCTags(76)%value(1:1) == '1' @@ -318,13 +319,13 @@ subroutine WriteVariablesRP() .or. any(RPsetup%out_full_cosp(w_ts:w_gas4))) & RPsetup%do_spectral_analysis = .true. - !> If no variable was selected for output, force out_raw to false + !> If no variable was selected for output, force out_raw(1:7) to false !> regardless of user setting - if (.not. any(RPsetup%out_raw_var(u:pe))) RPsetup%out_raw = .false. + if (.not. any(RPsetup%out_raw_var(u:pe))) RPsetup%out_raw(1:7) = .false. !> Raw dataset dir proceed = .false. - do i = 1, 7 + do i = 1, 8 if (RPsetup%out_raw(i)) then proceed = .true. exit @@ -415,10 +416,14 @@ subroutine WriteVariablesRP() !> Planar fit extra settings RPsetup%pf_onthefly = .false. + RPsetup%pf_only = .false. if (index(Meth%rot, 'planar_fit') /= 0) then !> Whether to perfom planar fit on the fly or use previous results file if (SCTags(56)%value(1:1) == '1') then RPsetup%pf_onthefly = .true. + elseif (SCTags(56)%value(1:1) == '2') then + RPsetup%pf_onthefly = .true. + RPsetup%pf_only = .true. else AuxFile%pf = SCTags(57)%value(1:len_trim(SCTags(57)%value)) end if @@ -429,31 +434,42 @@ subroutine WriteVariablesRP() !> select time lag handling method select case (SCTags(16)%value(1:1)) case ('0') - Meth%tlag = 'none' + Meth%tlag = 'none' case ('1') - Meth%tlag = 'constant' + Meth%tlag = 'constant' case ('2') - Meth%tlag = 'maxcov&default' + Meth%tlag = 'maxcov&default' case ('3') - Meth%tlag = 'maxcov' + Meth%tlag = 'maxcov' case ('4') - Meth%tlag = 'tlag_opt' + Meth%tlag = 'tlag_opt' + case ('5') + Meth%tlag = 'maxfft' case default - Meth%tlag = 'none' + Meth%tlag = 'none' end select !> Time lag optimizer extra settings RPsetup%to_onthefly = .false. - TimeLagOptSelected = .false. - if (Meth%tlag == 'tlag_opt') then - TimeLagOptSelected = .true. + RPsetup%to_only = .false. + ! TimeLagOptSelected = .false. + if ((trim(Meth%tlag) == 'tlag_opt') .or. (trim(Meth%tlag) == 'maxfft')) then + ! TimeLagOptSelected = .true. if (SCTags(91)%value(1:1) == '1') then RPsetup%to_onthefly = .true. + elseif (SCTags(91)%value(1:1) == '2') then + RPsetup%to_onthefly = .true. + RPsetup%to_only = .true. else AuxFile%to = SCTags(92)%value(1:len_trim(SCTags(92)%value)) end if end if + ! Only one of the two possible at once + if (RPsetup%pf_only .and. RPsetup%to_only) then + call ExceptionHandler(96) + endif + !> tapering window select case (SCTags(17)%value(1:1)) case ('0') @@ -703,4 +719,5 @@ subroutine WriteVariablesRP() call AdjDir(Dir%main_in, slash) call AdjFilePath(AuxFile%pf, slash) call AdjFilePath(AuxFile%to, slash) + end subroutine WriteVariablesRP diff --git a/src/src_rp/read_timelag_opt_file.f90 b/src/src_rp/read_timelag_opt_file.f90 index bff53e6..1dc6f0b 100644 --- a/src/src_rp/read_timelag_opt_file.f90 +++ b/src/src_rp/read_timelag_opt_file.f90 @@ -54,7 +54,7 @@ subroutine ReadTimelagOptFile(ncls) open(udf, file = AuxFile%to, status = 'old', iostat = open_status) if (open_status == 0) then - write(*, '(a)') ' Time lag optimization file found, retrieving content..' + write(*, '(a)') ' Time lag optimization file found, retrieving content..' do !> co2 read(udf, '(a)', iostat = read_status) strg @@ -134,5 +134,5 @@ subroutine ReadTimelagOptFile(ncls) Meth%tlag = 'maxcov' call ExceptionHandler(39) end if - write(*,'(a)') ' Done.' + write(*,'(a)') ' Done.' end subroutine ReadTimelagOptFile diff --git a/src/src_rp/set_timelags.f90 b/src/src_rp/set_timelags.f90 index b30ecf0..6638312 100644 --- a/src/src_rp/set_timelags.f90 +++ b/src/src_rp/set_timelags.f90 @@ -59,7 +59,7 @@ subroutine SetTimelags() safety = 0.3d0 !< Safety margin for min/max setting, should nominal tlag be very close to zero !> set time-lags to optimized values if selected so by user - if (meth%tlag == 'tlag_opt') then + if ((trim(Meth%tlag) == 'tlag_opt') .or. (trim(Meth%tlag) == 'maxfft')) then do gas = co2, gas4 if (E2Col(gas)%present) then if (gas /= h2o) then @@ -91,7 +91,7 @@ subroutine SetTimelags() end do else do gas = co2, gas4 - if (E2Col(gas)%instr%path_type == 'closed') then + if (trim(E2Col(gas)%instr%path_type) == 'closed') then if (E2Col(gas)%def_tl == 0d0) then tube_volume(gas) = (p * (E2Col(gas)%instr%tube_d / 2d0)**2 * E2Col(gas)%instr%tube_l) tube_time(gas) = tube_volume(gas) / E2Col(gas)%instr%tube_f @@ -104,7 +104,7 @@ subroutine SetTimelags() if (E2Col(gas)%max_tl == 0d0) E2Col(gas)%max_tl = & E2Col(gas)%def_tl + mult(gas) * E2Col(gas)%def_tl + safety - elseif (E2Col(gas)%instr%path_type == 'open') then + elseif (trim(E2Col(gas)%instr%path_type) == 'open') then if (E2Col(gas)%min_tl == 0d0) & E2Col(gas)%min_tl = - dsqrt(E2Col(gas)%instr%hsep**2 + E2Col(gas)%instr%vsep**2) * 2d0 - safety if (E2Col(gas)%max_tl == 0d0) & diff --git a/src/src_rp/timelag_handle.f90 b/src/src_rp/timelag_handle.f90 index 649bbac..fa29bd9 100644 --- a/src/src_rp/timelag_handle.f90 +++ b/src/src_rp/timelag_handle.f90 @@ -1,96 +1,130 @@ -!*************************************************************************** -! timelag_handle.f90 -! ------------------ -! Copyright (C) 2007-2011, Eco2s team, Gerardo Fratini -! Copyright (C) 2011-2019, LI-COR Biosciences, Inc. All Rights Reserved. -! Author: Gerardo Fratini -! -! This file is part of EddyPro®. -! -! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for -! non-commercial academic and government research purposes only, -! as provided in the EDDYPRO® End User License Agreement. -! EDDYPRO® may only be used as provided in the End User License Agreement -! and may not be used or accessed for any commercial purposes. -! You may view a copy of the End User License Agreement in the file -! EULA_NON_COMMERCIAL.rtf. -! -! Commercial companies that are LI-COR flux system customers -! are encouraged to contact LI-COR directly for our commercial -! EDDYPRO® End User License Agreement. -! -! EDDYPRO® contains Open Source Components (as defined in the -! End User License Agreement). The licenses and/or notices for the -! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. -! -! EddyPro® is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -! -!*************************************************************************** -! -! \brief Calculates time lags (in terms of data rows) for all scalars \n -! not measured by the anemometer. Also calculates covariances \n -! of H2O and Cell T with time-lags of other scalars (from the \n -! same instrument) for proper WPL of closed path systems. -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine TimeLagHandle(TlagMeth, Set, nrow, ncol, ActTLag, TLag, & - DefTlagUsed, InTimelagOpt) - use m_rp_global_var +module mo_timelag_handle + implicit none - !> in/out variables - integer, intent(in) :: nrow, ncol - character(*), intent(in) :: TlagMeth - logical, intent(in) :: InTimelagOpt - logical, intent(out) :: DefTlagUsed(ncol) - real(kind = dbl), intent(out) :: ActTLag(ncol) - real(kind = dbl), intent(out) :: TLag(ncol) - real(kind = dbl), intent(inout) :: Set(nrow, ncol) - !> local variables - integer :: i = 0 - integer :: j = 0 - integer :: def_rl(ncol) - integer :: min_rl(ncol) - integer :: max_rl(ncol) - real(kind = dbl) :: ColW(nrow) - real(kind = dbl) :: ColH2O(nrow) - real(kind = dbl) :: ColTC(nrow) - real(kind = dbl) :: FirstCol(nrow) - real(kind = dbl) :: SecondCol(nrow) - real(kind = dbl) :: TmpSet(nrow, ncol) - - if (.not. InTimelagOpt) write(*, '(a)', advance = 'no') & - ' Compensating time-lags..' - - !> for E2Set scalars, initialise auxiliary vars to zero - def_rl(:) = 0 - min_rl(:) = 0 - min_rl(:) = 0 - !> Define "row-lags" for scalars, using time-lags - !> retrieved from metadata file - where (E2Col(ts:pe)%present) - def_rl(ts:pe) = nint(E2Col(ts:pe)%def_tl * Metadata%ac_freq) - min_rl(ts:pe) = nint(E2Col(ts:pe)%min_tl * Metadata%ac_freq) - max_rl(ts:pe) = nint(E2Col(ts:pe)%max_tl * Metadata%ac_freq) - end where - - DefTlagUsed = .false. - !> calculate actual time-lags according to the chosen method - select case(TlagMeth) + + private + + public :: CalculateTrend ! linear trend of time series + public :: CovarianceW ! covariance of specific timelag + public :: CovMax ! time lag by maximum covariance within min/max + public :: Detrend ! detrend variable given trend from CalculateTrend + public :: TimeLagHandle ! calculate time lags + public :: VariableLinearDetrending ! detrend using CalculateTrend and Detrend + public :: VariableStochasticDetrending ! stochastic detrending + +contains + + !*************************************************************************** + ! timelag_handle.f90 + ! ------------------ + ! Copyright (C) 2007-2011, Eco2s team, Gerardo Fratini + ! Copyright (C) 2011-2019, LI-COR Biosciences, Inc. All Rights Reserved. + ! Author: Gerardo Fratini + ! + ! This file is part of EddyPro®. + ! + ! NON-COMMERCIAL RESEARCH PURPOSES ONLY - EDDYPRO® is licensed for + ! non-commercial academic and government research purposes only, + ! as provided in the EDDYPRO® End User License Agreement. + ! EDDYPRO® may only be used as provided in the End User License Agreement + ! and may not be used or accessed for any commercial purposes. + ! You may view a copy of the End User License Agreement in the file + ! EULA_NON_COMMERCIAL.rtf. + ! + ! Commercial companies that are LI-COR flux system customers + ! are encouraged to contact LI-COR directly for our commercial + ! EDDYPRO® End User License Agreement. + ! + ! EDDYPRO® contains Open Source Components (as defined in the + ! End User License Agreement). The licenses and/or notices for the + ! Open Source Components can be found in the file LIBRARIES-ENGINE.txt. + ! + ! EddyPro® is distributed in the hope that it will be useful, + ! but WITHOUT ANY WARRANTY; without even the implied warranty of + ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + ! + + !*************************************************************************** + ! + ! \brief Calculates time lags (in terms of data rows) for all scalars \n + ! not measured by the anemometer. Also calculates covariances \n + ! of H2O and Cell T with time-lags of other scalars (from the \n + ! same instrument) for proper WPL of closed path systems. + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine TimeLagHandle(TlagMeth, Set, ActTLag, TLag, & + DefTlagUsed, InTimelagOpt, CorrSet) + + use m_numeric_kinds, only: dbl + use m_typedef, only: ts, pe + use m_rp_global_var + use mo_fftmax, only: fftmax + + implicit none + + !> in/out variables + character(len=*), intent(in) :: TlagMeth + real(dbl), dimension(:, :), intent(inout) :: Set + real(dbl), dimension(:), intent(out) :: ActTLag + real(dbl), dimension(:), intent(out) :: TLag + logical, dimension(:), intent(out) :: DefTlagUsed + logical, intent(in) :: InTimelagOpt + real(dbl), dimension(:, :), intent(out), optional :: CorrSet + + !> local variables + integer :: i + integer :: j + integer, dimension(size(Set, 2)) :: def_rl + integer, dimension(size(Set, 2)) :: min_rl + integer, dimension(size(Set, 2)) :: max_rl + real(dbl), dimension(size(Set, 1)) :: ColW + real(dbl), dimension(size(Set, 1)) :: ColH2O + real(dbl), dimension(size(Set, 1)) :: ColTC + real(dbl), dimension(size(Set, 1)) :: FirstCol + real(dbl), dimension(size(Set, 1)) :: SecondCol + real(dbl), dimension(size(Set, 1), size(Set, 2)) :: TmpSet + real(dbl), dimension(size(Set, 1)) :: CrossCorr ! cross-correlations + integer :: RowLagMaxCov ! RowLag of MaxCov if maxfft + real(dbl) :: TlagMaxCov ! TLag of MaxCov if maxfft + integer :: ncorr ! length 2**n of cross-correlation + integer :: nrow + integer :: ncol + + nrow = size(Set, 1) + ncol = size(Set, 2) + + if (.not. InTimelagOpt) write(*, '(a)', advance = 'no') & + ' Compensating time-lags..' + + !> for E2Set scalars, initialise auxiliary vars to zero + def_rl(:) = 0 + min_rl(:) = 0 + min_rl(:) = 0 + !> Define "row-lags" for scalars, using time-lags + !> retrieved from metadata file + where (E2Col(ts:pe)%present) + def_rl(ts:pe) = nint(E2Col(ts:pe)%def_tl * Metadata%ac_freq) + min_rl(ts:pe) = nint(E2Col(ts:pe)%min_tl * Metadata%ac_freq) + max_rl(ts:pe) = nint(E2Col(ts:pe)%max_tl * Metadata%ac_freq) + end where + + if (present(CorrSet)) CorrSet(:, :) = 0.0_dbl + DefTlagUsed = .false. + !> calculate actual time-lags according to the chosen method + select case(trim(TlagMeth)) case ('constant') !> constant timelags are set equal to default values (user selected) RowLags(ts:pe) = def_rl(ts:pe) TLag(ts:pe) = E2Col(ts:pe)%def_tl ActTLag(ts:pe) = E2Col(ts:pe)%def_tl DefTlagUsed(ts:pe) = .true. - case ('maxcov', 'maxcov&default') + case ('maxcov', 'maxcov&default', 'tlag_opt') !> covariance maximization method, with or without default do j = ts, pe !> Only for present variables, @@ -105,384 +139,453 @@ subroutine TimeLagHandle(TlagMeth, Set, nrow, ncol, ActTLag, TLag, & ActTLag(j) = TLag(j) !> If no max cov has been detected within the interval, \n !> sets the time lag to the suggested values - if (TlagMeth == 'maxcov&default') then + if ((TlagMeth == 'maxcov&default') .or. (TlagMeth == 'tlag_opt')) then if ( (RowLags(j) == min_rl(j)) .or. (RowLags(j) == max_rl(j)) ) then DefTlagUsed(j) = .true. - TLag(j) = dble(def_rl(j)) / Metadata%ac_freq + TLag(j) = real(def_rl(j), kind=dbl) / Metadata%ac_freq RowLags(j) = def_rl(j) end if end if else RowLags(j) = 0 - TLag(j) = 0d0 - ActTLag(j) = 0d0 - end if + TLag(j) = 0.0_dbl + ActTLag(j) = 0.0_dbl + end if + end do + case ('maxfft') + !> covariance maximization using Fourier transform + do j=ts, pe + !> Only for variables present + if (E2Col(j)%present) then + FirstCol(:) = Set(:, w) + SecondCol(:) = Set(:, j) + ! invert columns because opposite sign convention + call fftmax(SecondCol(:), FirstCol(:), error, & + min_rl(j), max_rl(j), Metadata%ac_freq, & + TLag(j), RowLags(j), ncorr, CrossCorr(:)) + ActTLag(j) = TLag(j) + if ( (RowLags(j) == min_rl(j)) .or. (RowLags(j) == max_rl(j)) ) then + DefTlagUsed(j) = .true. + TLag(j) = real(def_rl(j), kind=dbl) / Metadata%ac_freq + RowLags(j) = def_rl(j) + end if + if (present(CorrSet)) then + CorrSet(:, j) = CrossCorr(:) + CorrSet(size(CorrSet, 1), j) = real(ncorr, dbl) + CorrSet(size(CorrSet, 1)-1, j) = real(RowLags(j), dbl) + call CovMax(min_rl(j), max_rl(j), & + FirstCol, SecondCol, size(FirstCol), & + TlagMaxCov, RowLagMaxCov) + if ( (RowLagMaxCov == min_rl(j)) .or. (RowLagMaxCov == max_rl(j)) ) then + CorrSet(size(CorrSet, 1)-2, j) = real(def_rl(j), dbl) + else + CorrSet(size(CorrSet, 1)-2, j) = real(RowLagMaxCov, dbl) + end if + endif + else + RowLags(j) = 0 + TLag(j) = 0.0_dbl + ActTLag(j) = 0.0_dbl + end if end do case ('none') !> not compensating for timelags RowLags(ts:pe) = 0 - TLag(ts:pe) = 0d0 - end select - - if (.not. InTimelagOpt) then - !> For closed path instruments, calculate H2O covariances - !> for time-lags of other scalars from the same instrument - Stats%h2ocov_tl_co2 = error - Stats%h2ocov_tl_ch4 = error - Stats%h2ocov_tl_gas4 = error - if (E2Col(h2o)%present & - .and. E2Col(h2o)%instr%path_type == 'closed') then - ColW(1:nrow) = Set(1:nrow, w) - ColH2O(1:nrow) = Set(1:nrow, h2o) - if (E2Col(co2)%present & - .and. E2Col(co2)%instr%model == E2Col(h2o)%instr%model & - .and. RowLags(co2) > 0) & - call CovarianceW(ColW, ColH2O, size(ColW), & + TLag(ts:pe) = 0.0_dbl + end select + + if (.not. InTimelagOpt) then + !> For closed path instruments, calculate H2O covariances + !> for time-lags of other scalars from the same instrument + Stats%h2ocov_tl_co2 = error + Stats%h2ocov_tl_ch4 = error + Stats%h2ocov_tl_gas4 = error + if (E2Col(h2o)%present & + .and. E2Col(h2o)%instr%path_type == 'closed') then + ColW(1:nrow) = Set(1:nrow, w) + ColH2O(1:nrow) = Set(1:nrow, h2o) + if (E2Col(co2)%present & + .and. E2Col(co2)%instr%model == E2Col(h2o)%instr%model & + .and. RowLags(co2) > 0) & + call CovarianceW(ColW, ColH2O, size(ColW), & RowLags(co2), Stats%h2ocov_tl_co2) - if (E2Col(ch4)%present & - .and. E2Col(ch4)%instr%model == E2Col(h2o)%instr%model & - .and. RowLags(ch4) > 0) & - call CovarianceW(ColW, ColH2O, size(ColW), & + if (E2Col(ch4)%present & + .and. E2Col(ch4)%instr%model == E2Col(h2o)%instr%model & + .and. RowLags(ch4) > 0) & + call CovarianceW(ColW, ColH2O, size(ColW), & RowLags(ch4), Stats%h2ocov_tl_ch4) - if (E2Col(gas4)%present & - .and. E2Col(gas4)%instr%model == E2Col(h2o)%instr%model & - .and. RowLags(gas4) > 0) & - call CovarianceW(ColW, ColH2O, size(ColW), & - RowLags(gas4), Stats%h2ocov_tl_gas4) - end if + if (E2Col(gas4)%present & + .and. E2Col(gas4)%instr%model == E2Col(h2o)%instr%model & + .and. RowLags(gas4) > 0) & + call CovarianceW(ColW, ColH2O, size(ColW), & + RowLags(gas4), Stats%h2ocov_tl_gas4) + end if - !> Calculate cell temperature covariances with - !> time-lags of scalars from the same instrument - Stats%tc_cov_tl_co2 = error - Stats%tc_cov_tl_h2o = error - Stats%tc_cov_tl_ch4 = error - Stats%tc_cov_tl_gas4 = error - if (E2Col(tc)%present) then - !> Store vertical wind component and tc in ad-hoc arrays - ColW(1:nrow) = Set(1:nrow, w) - ColTC(1:nrow) = Set(1:nrow, tc) - if (E2Col(co2)%present & - .and. E2Col(co2)%instr%model == E2Col(tc)%instr%model & - .and. RowLags(co2) > 0) & - call CovarianceW(ColW, ColTC, size(ColTC), & + !> Calculate cell temperature covariances with + !> time-lags of scalars from the same instrument + Stats%tc_cov_tl_co2 = error + Stats%tc_cov_tl_h2o = error + Stats%tc_cov_tl_ch4 = error + Stats%tc_cov_tl_gas4 = error + if (E2Col(tc)%present) then + !> Store vertical wind component and tc in ad-hoc arrays + ColW(1:nrow) = Set(1:nrow, w) + ColTC(1:nrow) = Set(1:nrow, tc) + if (E2Col(co2)%present & + .and. E2Col(co2)%instr%model == E2Col(tc)%instr%model & + .and. RowLags(co2) > 0) & + call CovarianceW(ColW, ColTC, size(ColTC), & RowLags(co2), Stats%tc_cov_tl_co2) - if (E2Col(h2o)%present & - .and. E2Col(h2o)%instr%model == E2Col(tc)%instr%model & - .and. RowLags(h2o) > 0) & - call CovarianceW(ColW, ColTC, size(ColTC), & + if (E2Col(h2o)%present & + .and. E2Col(h2o)%instr%model == E2Col(tc)%instr%model & + .and. RowLags(h2o) > 0) & + call CovarianceW(ColW, ColTC, size(ColTC), & RowLags(h2o), Stats%tc_cov_tl_h2o) - if (E2Col(ch4)%present & - .and. E2Col(ch4)%instr%model == E2Col(tc)%instr%model & - .and. RowLags(ch4) > 0) & - call CovarianceW(ColW, ColTC, size(ColTC), & + if (E2Col(ch4)%present & + .and. E2Col(ch4)%instr%model == E2Col(tc)%instr%model & + .and. RowLags(ch4) > 0) & + call CovarianceW(ColW, ColTC, size(ColTC), & RowLags(ch4), Stats%tc_cov_tl_ch4) - if (E2Col(gas4)%present & - .and. E2Col(gas4)%instr%model == E2Col(tc)%instr%model & - .and. RowLags(gas4) > 0) & - call CovarianceW(ColW, ColTC, size(ColTC), & + if (E2Col(gas4)%present & + .and. E2Col(gas4)%instr%model == E2Col(tc)%instr%model & + .and. RowLags(gas4) > 0) & + call CovarianceW(ColW, ColTC, size(ColTC), & RowLags(gas4), Stats%tc_cov_tl_gas4) + end if end if - end if - - !> Align data according to relevant time-lags, - !> filling remaining with error code. - do j = u, pe - if (E2Col(j)%present) then - if (RowLags(j) >= 0) then - !> For positive lags - do i = 1, nrow - RowLags(j) - TmpSet(i, j) = Set(i + RowLags(j), j) - end do - do i = nrow - Rowlags(j) + 1, nrow - TmpSet(i, j) = error - end do + + !> Align data according to relevant time-lags, + !> filling remaining with error code. + do j = u, pe + if (E2Col(j)%present) then + if (RowLags(j) >= 0) then + !> For positive lags + do i = 1, nrow - RowLags(j) + TmpSet(i, j) = Set(i + RowLags(j), j) + end do + do i = nrow - Rowlags(j) + 1, nrow + TmpSet(i, j) = error + end do + else + !> For negative lags + do i = 1, abs(RowLags(j)) + TmpSet(i, j) = error + end do + do i = abs(RowLags(j)) + 1, nrow + TmpSet(i, j) = Set(i + RowLags(j), j) + end do + end if else - !> For negative lags - do i = 1, abs(RowLags(j)) - TmpSet(i, j) = error - end do - do i = abs(RowLags(j)) + 1, nrow - TmpSet(i, j) = Set(i + RowLags(j), j) - end do + TmpSet(1:nrow, j) = error end if + end do + Set = TmpSet + if (.not. InTimelagOpt) write(*,'(a)') ' Done.' + + end subroutine TimeLagHandle + + !******************************************************************************* + ! + ! \brief Performs covariance analysis for determining the "optimal" \n + ! time lag, the one that maximizes the covariance. + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !******************************************************************************* + subroutine CovMax(lagmin, lagmax, Col1, Col2, nrow, TLag, RLag) + + use m_numeric_kinds, only: dbl + use m_rp_global_var + + implicit none + + !> in/out variables + integer, intent(in) :: nrow + integer, intent(in) :: lagmin + integer, intent(in) :: lagmax + real(kind = dbl), intent(in) :: Col1(nrow) + real(kind = dbl), intent(in) :: Col2(nrow) + integer, intent(out) :: RLag + real(kind = dbl), intent(out) :: TLag + + !> local variables + integer :: i = 0 + integer :: ii = 0 + integer :: N2 + real(kind = dbl), allocatable :: ShSet(:, :) + real(kind = dbl), allocatable :: ShPrimes(:, :) + real(kind = dbl) :: CovMat(2,2) + real(kind = dbl) :: Cov + real(kind = dbl) :: MaxCov + + Cov = 0.0_dbl + MaxCov = 0.0_dbl + TLag = 0.0_dbl + do i = lagmin, lagmax + N2 = nrow - abs(i) + allocate(ShSet(N2, 2)) + allocate(ShPrimes(N2, 2)) + + !> Align the two timeseries at the current time-lag + do ii = 1, N2 + if (i < 0) then + ShSet(ii, 1) = Col1(ii - i) + ShSet(ii, 2) = Col2(ii) + else + ShSet(ii, 1) = Col1(ii) + ShSet(ii, 2) = Col2(ii + i) + end if + end do + + !> Block average + ShPrimes = ShSet + + !> Linear detrending + ! call VariableLinearDetrending(ShSet(:, 1), ShPrimes(:, 1), N2) + ! call VariableLinearDetrending(ShSet(:, 2), ShPrimes(:, 2), N2) + + !> Stochastic detrending + ! call VariableStochasticDetrending(ShSet(:, 1), ShPrimes(:, 1), N2) + ! call VariableStochasticDetrending(ShSet(:, 2), ShPrimes(:, 2), N2) + + call CovarianceMatrixNoError(ShPrimes, size(ShPrimes, 1), size(ShPrimes, 2), CovMat, error) + Cov = CovMat(1, 2) + + !> Max cov and actual time lag + if (abs(Cov) > MaxCov) then + MaxCov = abs(Cov) + TLag = real(i, kind=dbl) / Metadata%ac_freq + RLag = i + end if + deallocate(ShSet) + deallocate(ShPrimes) + end do + + end subroutine CovMax + + + !*************************************************************************** + ! + ! \brief Calculate covariance between two arrays using an imposed \n + ! time-lag. + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine CovarianceW(col1, col2, nrow, lag, cov) + + use m_numeric_kinds, only: dbl + use m_rp_global_var + + implicit none + + !> in/out variables + integer, intent(in) :: nrow + integer, intent(in) :: lag + real(kind = dbl), intent(in) :: col1(nrow) + real(kind = dbl), intent(in) :: col2(nrow) + real(kind = dbl), intent(out) :: cov + + !> local variables + integer :: i + integer :: N2 + real(kind = dbl) ::sum1 + real(kind = dbl) ::sum2 + + sum1 = 0.0_dbl + sum2 = 0.0_dbl + Cov = 0.0_dbl + N2 = 0 + do i = 1, nrow - lag + if (col1(i) /= error .and. col2(i+lag) /= error) then + N2 = N2 + 1 + Cov = Cov + col1(i) * col2(i+lag) + sum1 = sum1 + col1(i) + sum2 = sum2 + col2(i+lag) + end if + end do + + if (N2 /= 0) then + sum1 = sum1 / real(N2, kind=dbl) + sum2 = sum2 / real(N2, kind=dbl) + cov = cov / real(N2, kind=dbl) + cov = cov - sum1 * sum2 else - TmpSet(1:nrow, j) = error + cov = error end if - end do - Set = TmpSet - if (.not. InTimelagOpt) write(*,'(a)') ' Done.' -end subroutine TimeLagHandle - -!******************************************************************************* -! -! \brief Performs covariance analysis for determining the "optimal" \n -! time lag, the one that maximizes the covariance. -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!******************************************************************************* -subroutine CovMax(lagmin, lagmax, Col1, Col2, nrow, TLag, RLag) - use m_rp_global_var - implicit none - !> in/out variables - integer, intent(in) :: nrow - integer, intent(in) :: lagmin - integer, intent(in) :: lagmax - real(kind = dbl), intent(in) :: Col1(nrow) - real(kind = dbl), intent(in) :: Col2(nrow) - integer, intent(out) :: RLag - real(kind = dbl), intent(out) :: TLag - !> local variables - integer :: i = 0 - integer :: ii = 0 - integer :: N2 - real(kind = dbl), allocatable :: ShSet(:, :) - real(kind = dbl), allocatable :: ShPrimes(:, :) - real(kind = dbl) :: CovMat(2,2) - real(kind = dbl) :: Cov - real(kind = dbl) :: MaxCov - - Cov = 0.d0 - MaxCov = 0.d0 - TLag = 0.d0 - do i = lagmin, lagmax - N2 = nrow - abs(i) - allocate(ShSet(N2, 2)) - allocate(ShPrimes(N2, 2)) - - !> Align the two timeseries at the current time-lag - do ii = 1, N2 - if (i < 0) then - ShSet(ii, 1) = Col1(ii - i) - ShSet(ii, 2) = Col2(ii) + + end subroutine CovarianceW + + !*************************************************************************** + ! + ! \brief Stochastic Detrending + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine VariableStochasticDetrending(Var, Primes, N) + + use m_common_global_var + + implicit none + + !> in/out variables + integer, intent(in) :: N + real(kind = dbl), intent(in) :: Var(N) + real(kind = dbl), intent(out) :: Primes(N) + + !> local variables + integer :: i + + Primes(1) = error + do i = 2, N + if (Var(i) /= error .and. Var(i-1) /= error) then + Primes(i) = Var(i) - Var(i-1) else - ShSet(ii, 1) = Col1(ii) - ShSet(ii, 2) = Col2(ii + i) + Primes(i) = error end if end do - !> Block average - ShPrimes = ShSet + end subroutine VariableStochasticDetrending - !> Linear detrending - ! call VariableLinearDetrending(ShSet(:, 1), ShPrimes(:, 1), N2) - ! call VariableLinearDetrending(ShSet(:, 2), ShPrimes(:, 2), N2) + !*************************************************************************** + ! + ! \brief Linear detrending of one time series + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine VariableLinearDetrending(Var, Primes, N) - !> Stochastic detrending - ! call VariableStochasticDetrending(ShSet(:, 1), ShPrimes(:, 1), N2) - ! call VariableStochasticDetrending(ShSet(:, 2), ShPrimes(:, 2), N2) + use m_rp_global_var - call CovarianceMatrixNoError(ShPrimes, size(ShPrimes, 1), size(ShPrimes, 2), CovMat, error) - Cov = CovMat(1, 2) + implicit none - !> Max cov and actual time lag - if (abs(Cov) > MaxCov) then - MaxCov = abs(Cov) - TLag = dble(i) / Metadata%ac_freq - RLag = i - end if - deallocate(ShSet) - deallocate(ShPrimes) - end do -end subroutine CovMax - - -!*************************************************************************** -! -! \brief Calculate covariance between two arrays using an imposed \n -! time-lag. -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine CovarianceW(col1, col2, nrow, lag, cov) - use m_rp_global_var - implicit none - !> in/out variables - integer, intent(in) :: nrow - integer, intent(in) :: lag - real(kind = dbl), intent(in) :: col1(nrow) - real(kind = dbl), intent(in) :: col2(nrow) - real(kind = dbl), intent(out) :: cov - !> local variables - integer :: i - integer :: N2 - real(kind = dbl) ::sum1 - real(kind = dbl) ::sum2 - - sum1 = 0d0 - sum2 = 0d0 - Cov = 0d0 - N2 = 0 - do i = 1, nrow - lag - if (col1(i) /= error .and. col2(i+lag) /= error) then - N2 = N2 + 1 - Cov = Cov + col1(i) * col2(i+lag) - sum1 = sum1 + col1(i) - sum2 = sum2 + col2(i+lag) - end if - end do - - if (N2 /= 0) then - sum1 = sum1 / dble(N2) - sum2 = sum2 / dble(N2) - cov = cov / dble(N2) - cov = cov - sum1 * sum2 - else - cov = error - end if -end subroutine CovarianceW - -!*************************************************************************** -! -! \brief Stochastic Detrending -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine VariableStochasticDetrending(Var, Primes, N) - use m_common_global_var - implicit none - !> in/out variables - integer, intent(in) :: N - real(kind = dbl), intent(in) :: Var(N) - real(kind = dbl), intent(out) :: Primes(N) - !> local variables - integer :: i - - Primes(1) = error - do i = 2, N - if (Var(i) /= error .and. Var(i-1) /= error) then - Primes(i) = Var(i) - Var(i-1) - else - Primes(i) = error - end if - end do -end subroutine VariableStochasticDetrending - -!*************************************************************************** -! -! \brief Linear detrending of one time series -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine VariableLinearDetrending(Var, Primes, N) - use m_rp_global_var - implicit none - !> in/out variables - integer, intent(in) :: N - real(kind = dbl), intent(in) :: Var(N) - real(kind = dbl), intent(out) :: Primes(N) - !> Local variables - real(kind = dbl) :: Trend(N) - - call CalculateTrend(Var, Trend, N) - call Detrend(Var, Trend, Primes, N) - -end subroutine VariableLinearDetrending - -!*************************************************************************** -! -! \brief Remove trend from time series -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine Detrend(Var, Trend, Primes, N) - use m_rp_global_var - implicit none - !> in/out variables - integer, intent(in) :: N - real(kind = dbl), intent(in) :: Var(N) - real(kind = dbl), intent(in) :: Trend(N) - real(kind = dbl), intent(out) :: Primes(N) - - - Primes = error - where (Var /= error .and. Trend /= error) - Primes = Var - Trend - end where -end subroutine Detrend - -!*************************************************************************** -! -! \brief Calculate linear trend in time series -! \author Gerardo Fratini -! \note -! \sa -! \bug -! \deprecated -! \test -! \todo -!*************************************************************************** -subroutine CalculateTrend(Var, Trend, N) - use m_rp_global_var - implicit none - !> in/out variables - integer, intent(in) :: N - real(kind = dbl), intent(in) :: Var(N) - real(kind = dbl), intent(out) :: Trend(N) - !> local variables - integer :: i - integer :: nn - integer :: mm - real(kind = dbl) :: sumx1 - real(kind = dbl) :: sumx2 - real(kind = dbl) :: mean - real(kind = dbl) :: sumtime - real(kind = dbl) :: sumtime2 - real(kind = dbl) :: b - - - !> Linear regression - sumx1 = 0d0 - sumx2 = 0d0 - sumtime = 0d0 - sumtime2 = 0d0 - nn = 0 - do i = 1, N - if (Var(i) /= error) then - nn = nn + 1 - sumx1 = sumx1 + (Var(i) * (dble(nn - 1))) - sumx2 = sumx2 + Var(i) - sumtime = sumtime + (dble(nn - 1)) - sumtime2 = sumtime2 + (dble(nn - 1))**2 - end if - end do - if (nn /= 0) then - mean = sumx2 / dble(nn) - end if - - !> Trend - mm = 0 - b = (sumx1 - (sumx2 * sumtime) / dble(nn)) / (sumtime2 - (sumtime * sumtime) / dble(nn)) - do i = 1, N - mm = mm + 1 - if (Var(i) /= error) then - Trend(i) = mean + b * (dble(mm - 1) - sumtime / dble(nn)) - else - Trend(i) = error + !> in/out variables + integer, intent(in) :: N + real(kind = dbl), intent(in) :: Var(N) + real(kind = dbl), intent(out) :: Primes(N) + + !> Local variables + real(kind = dbl) :: Trend(N) + + call CalculateTrend(Var, Trend, N) + call Detrend(Var, Trend, Primes, N) + + end subroutine VariableLinearDetrending + + !*************************************************************************** + ! + ! \brief Remove trend from time series + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine Detrend(Var, Trend, Primes, N) + + use m_rp_global_var + + implicit none + + !> in/out variables + integer, intent(in) :: N + real(kind = dbl), intent(in) :: Var(N) + real(kind = dbl), intent(in) :: Trend(N) + real(kind = dbl), intent(out) :: Primes(N) + + Primes = error + where (Var /= error .and. Trend /= error) + Primes = Var - Trend + end where + + end subroutine Detrend + + !*************************************************************************** + ! + ! \brief Calculate linear trend in time series + ! \author Gerardo Fratini + ! \note + ! \sa + ! \bug + ! \deprecated + ! \test + ! \todo + !*************************************************************************** + subroutine CalculateTrend(Var, Trend, N) + + use m_numeric_kinds, only: dbl + use m_rp_global_var + + implicit none + + !> in/out variables + integer, intent(in) :: N + real(kind = dbl), intent(in) :: Var(N) + real(kind = dbl), intent(out) :: Trend(N) + + !> local variables + integer :: i + integer :: nn + integer :: mm + real(kind = dbl) :: sumx1 + real(kind = dbl) :: sumx2 + real(kind = dbl) :: mean + real(kind = dbl) :: sumtime + real(kind = dbl) :: sumtime2 + real(kind = dbl) :: b + + + !> Linear regression + sumx1 = 0.0_dbl + sumx2 = 0.0_dbl + sumtime = 0.0_dbl + sumtime2 = 0.0_dbl + nn = 0 + do i = 1, N + if (Var(i) /= error) then + nn = nn + 1 + sumx1 = sumx1 + (Var(i) * (real(nn - 1, kind=dbl))) + sumx2 = sumx2 + Var(i) + sumtime = sumtime + (real(nn - 1, kind=dbl)) + sumtime2 = sumtime2 + (real(nn - 1, kind=dbl))**2 + end if + end do + if (nn /= 0) then + mean = sumx2 / real(nn, kind=dbl) end if - end do -end subroutine CalculateTrend + + !> Trend + mm = 0 + b = (sumx1 - (sumx2 * sumtime) / real(nn, kind=dbl)) / (sumtime2 - (sumtime * sumtime) / real(nn, kind=dbl)) + do i = 1, N + mm = mm + 1 + if (Var(i) /= error) then + Trend(i) = mean + b * (real(mm - 1, kind=dbl) - sumtime / real(nn, kind=dbl)) + else + Trend(i) = error + end if + end do + + end subroutine CalculateTrend + +end module mo_timelag_handle diff --git a/src/src_rp/write_out_fluxnet.f90 b/src/src_rp/write_out_fluxnet.f90 index 07e2c0c..de0201b 100644 --- a/src/src_rp/write_out_fluxnet.f90 +++ b/src/src_rp/write_out_fluxnet.f90 @@ -711,6 +711,8 @@ subroutine WriteOutFluxnet(StDiff, DtDiff, STFlg, DTFlg) call AddIntDatumToDataline(3, dataline, EddyProProj%err_label) case('tlag_opt') call AddIntDatumToDataline(4, dataline, EddyProProj%err_label) + case('maxfft') + call AddIntDatumToDataline(5, dataline, EddyProProj%err_label) end select !> WPL terms if (EddyProProj%wpl) then @@ -837,4 +839,4 @@ subroutine WriteOutFluxnet(StDiff, DtDiff, STFlg, DTFlg) dataline = replace2(dataline, ',Infinity,', ',' // trim(EddyProProj%err_label) // ',') write(uflxnt, '(a)') dataline(1:len_trim(dataline) - 1) -end subroutine WriteOutFluxnet \ No newline at end of file +end subroutine WriteOutFluxnet