├── .gitattributes ├── .gitignore ├── LICENSE.txt ├── Makefile ├── README.rst ├── adjac.f95 ├── adjac.f95.in ├── adjac_fft.f95 ├── adjac_fft.f95.in ├── adjac_tapeless.f95 ├── examples ├── bench_advection.f95 ├── bench_advection_adept.cpp ├── bench_simple.f95 ├── bench_simple_adept.cpp ├── bench_simple_adolc.cpp ├── bench_simple_cppad.cpp ├── bench_simple_numdiff.f95 ├── bench_simple_tapeless_adolc.cpp ├── bench_sparse.f95 ├── bench_sparse_adolc.cpp ├── laplacian.f95 └── simple.f95 ├── fftpack ├── zfftb1.f95 ├── zfftb1.f95.in ├── zfftf1.f95 ├── zfftf1.f95.in └── zffti1.f95 ├── generate.py └── tests ├── test_abs.f95 ├── test_fft.f95 ├── test_laplacian.cmp ├── test_laplacian.f95 ├── test_laplacian.test_tapeless.cmp ├── test_sqrt.f95 └── testutil.i /.gitattributes: -------------------------------------------------------------------------------- 1 | adjac.f95 binary 2 | adjac_tapeless.f95 binary 3 | adjac_fft.f95 binary 4 | fftpack/zfftf1.f95 binary 5 | fftpack/zfftb1.f95 binary 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.mod 3 | *.test 4 | *.test_tapeless 5 | *.out 6 | *.o 7 | *.so 8 | *.a 9 | /examples/bench_advection 10 | /examples/bench_advection_adept 11 | /examples/bench_advection_tapeless 12 | /examples/bench_simple 13 | /examples/bench_simple_adept 14 | /examples/bench_simple_adolc 15 | /examples/bench_simple_cppad 16 | /examples/bench_simple_numdiff 17 | /examples/bench_simple_numdiff_tapeless 18 | /examples/bench_simple_tapeless 19 | /examples/bench_simple_tapeless_adolc 20 | /examples/bench_sparse 21 | /examples/bench_sparse_adolc 22 | /examples/bench_sparse_tapeless 23 | /examples/laplacian 24 | /examples/laplacian_tapeless 25 | /examples/simple 26 | /examples/simple_tapeless 27 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | ============= 2 | adjac license 3 | ============= 4 | 5 | Copyright (c) 2014-2015, Pauli Virtanen 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 12 | 1. Redistributions of source code must retain the above copyright 13 | notice, this list of conditions and the following disclaimer. 14 | 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in the 17 | documentation and/or other materials provided with the distribution. 18 | 19 | 3. Neither the name of the copyright holder nor the names of 20 | contributors may be used to endorse or promote products derived from 21 | this software without specific prior written permission. 22 | 23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 24 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 25 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 26 | FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 27 | COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 28 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 29 | BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 30 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 31 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 32 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 33 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | 36 | ========= 37 | fftpack/* 38 | ========= 39 | 40 | The codes in directory fftpack/ are derived from the SLATEC/FFTPACK 41 | library at http://netlib.org/slatec/fishfft/ 42 | This library is in the public domain. 43 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | FC=gfortran 2 | CXX=g++ 3 | 4 | CXXFLAGS=-g -O3 -Wall 5 | FFLAGS=-g -O3 -Wall 6 | #FFLAGS=-ggdb -Og 7 | 8 | TESTS=$(patsubst %.f95,%.test,$(wildcard tests/test_*.f95)) $(patsubst %.f95,%.test_tapeless,$(wildcard tests/test_*.f95)) 9 | EXAMPLES=$(patsubst %.f95,%,$(wildcard examples/*.f95)) $(patsubst %.f95,%_tapeless,$(wildcard examples/*.f95)) 10 | CXXEXAMPLES=$(patsubst %.cpp,%,$(wildcard examples/*.cpp)) 11 | 12 | ADOLC_CFLAGS=-I/usr/include/adolc 13 | ADOLC_LIBS=-ladolc 14 | ADEPT_CFLAGS=-Iadept-1.0/include 15 | ADEPT_LIBS=-Ladept-1.0/lib -ladept 16 | CPPAD_CFLAGS=$(shell pkg-config --cflags cppad) 17 | CPPAD_LIBS=$(shell pkg-config --libs cppad) 18 | 19 | all: examples test libadjac.a libadjac_tapeless.a 20 | 21 | examples: $(EXAMPLES) 22 | 23 | test: $(TESTS) 24 | @rm -f tests/*.out; \ 25 | ok=0; \ 26 | for t in $(TESTS); do \ 27 | b="`basename $$t .test`"; \ 28 | b="`basename $$b .test_tapeless`"; \ 29 | c="$$t.cmp"; \ 30 | if test ! -f "$$c"; then c="tests/$$b.cmp"; fi; \ 31 | log="$$t.out"; \ 32 | echo "--------------------------------------------" > "$$log"; \ 33 | echo "$$b" >> "$$log"; \ 34 | echo "--------------------------------------------" >> "$$log"; \ 35 | echo -n "$$t... "; ./$$t >> "$$log" 2>&1; \ 36 | result=$$?; \ 37 | if test "$$result" = "0"; then \ 38 | if grep -q FAIL "$$log"; then result=1; else result=0; fi; \ 39 | fi; \ 40 | if test -f "$$c"; then \ 41 | if diff -b -u "$$log" "$$c" >> "$$log.tmp"; then true; else result=1; fi; \ 42 | fi; \ 43 | if test "$$result" = "0"; then echo "OK"; rm -f "$$log"; else echo "FAIL"; ok=1; fi; \ 44 | rm -f "$$log.tmp"; \ 45 | done; \ 46 | for f in tests/*.out; do test -f "$$f" && cat "$$f"; done; \ 47 | exit "$$ok" 48 | 49 | adjac.f95: adjac.f95.in generate.py 50 | python generate.py $< $@ 51 | 52 | adjac_tapeless.f95: adjac.f95.in generate.py 53 | python generate.py -DTAPELESS=True $< $@ 54 | 55 | adjac_fft.f95: adjac_fft.f95.in generate.py 56 | python generate.py $< $@ 57 | 58 | fftpack/%.f95: fftpack/%.f95.in generate.py 59 | python generate.py $< $@ 60 | 61 | %.o: %.f95 62 | @install -d build/base 63 | $(FC) $(FFLAGS) -Jbuild/base -c -o $@ $^ 64 | 65 | adjac_tapeless.o: adjac_tapeless.f95 66 | @install -d build/tapeless 67 | $(FC) $(FFLAGS) -Jbuild/tapeless -c -o $@ $^ 68 | 69 | %.o: %.c 70 | gcc -std=c99 $(FFLAGS) -c -o $@ $^ 71 | 72 | libadjac.a: adjac.o build/base/adjac_fft.o build/base/zfftf1.o build/base/zfftb1.o build/base/zffti1.o 73 | ar cru $@ $^ 74 | 75 | libadjac_tapeless.a: adjac_tapeless.o build/tapeless/adjac_fft.o build/tapeless/zfftf1.o build/tapeless/zfftb1.o build/tapeless/zffti1.o 76 | ar cru $@ $^ 77 | 78 | build/base/adjac_fft.o: adjac_fft.f95 adjac.o 79 | $(FC) $(FFLAGS) -Jbuild/base -c -o $@ $< 80 | 81 | build/base/zfftf1.o: fftpack/zfftf1.f95 adjac.o 82 | $(FC) $(FFLAGS) -Jbuild/base -c -o $@ $< 83 | 84 | build/base/zfftb1.o: fftpack/zfftb1.f95 adjac.o 85 | $(FC) $(FFLAGS) -Jbuild/base -c -o $@ $< 86 | 87 | build/base/zffti1.o: fftpack/zffti1.f95 88 | $(FC) $(FFLAGS) -Jbuild/base -c -o $@ $< 89 | 90 | build/tapeless/adjac_fft.o: adjac_fft.f95 adjac_tapeless.o 91 | $(FC) $(FFLAGS) -Jbuild/tapeless -c -o $@ $< 92 | 93 | build/tapeless/zfftf1.o: fftpack/zfftf1.f95 adjac_tapeless.o 94 | $(FC) $(FFLAGS) -Jbuild/tapeless -c -o $@ $< 95 | 96 | build/tapeless/zfftb1.o: fftpack/zfftb1.f95 adjac_tapeless.o 97 | $(FC) $(FFLAGS) -Jbuild/tapeless -c -o $@ $< 98 | 99 | build/tapeless/zffti1.o: fftpack/zffti1.f95 100 | $(FC) $(FFLAGS) -Jbuild/tapeless -c -o $@ $< 101 | 102 | tests/%.test: tests/%.f95 libadjac.a 103 | $(FC) $(FFLAGS) -Jbuild/base -o $@ -Itests $^ -L. -ladjac 104 | 105 | tests/%.test_tapeless: tests/%.f95 libadjac_tapeless.a 106 | $(FC) $(FFLAGS) -Jbuild/tapeless -o $@ -Itests $^ -L. -ladjac_tapeless 107 | 108 | examples/%: examples/%.f95 libadjac.a 109 | $(FC) $(FFLAGS) -Jbuild/base -o $@ $^ -L. -ladjac 110 | 111 | examples/%_tapeless: examples/%.f95 libadjac_tapeless.a 112 | $(FC) $(FFLAGS) -Jbuild/tapeless -o $@ $^ -L. -ladjac_tapeless 113 | 114 | examples/%_adolc: examples/%_adolc.cpp 115 | $(CXX) $(CXXFLAGS) $(ADOLC_CFLAGS) -o $@ $^ $(ADOLC_LIBS) 116 | 117 | examples/bench_simple_tapeless_adolc: examples/bench_simple_tapeless_adolc.cpp examples/bench_simple_adolc.cpp 118 | if pkg-config --atleast-version=2.5 adolc; then \ 119 | exec $(CXX) $(CXXFLAGS) $(ADOLC_CFLAGS) -o $@ $< $(ADOLC_LIBS); \ 120 | else \ 121 | exec $(CXX) $(CXXFLAGS) $(ADOLC_CFLAGS) -DOLD_TAPELESS -o $@ $< $(ADOLC_LIBS); \ 122 | fi 123 | 124 | examples/%_adept: examples/%_adept.cpp 125 | $(CXX) $(CXXFLAGS) $(ADEPT_CFLAGS) -o $@ $^ $(ADEPT_LIBS) 126 | 127 | examples/%_cppad: examples/%_cppad.cpp 128 | $(CXX) $(CXXFLAGS) $(CPPAD_CFLAGS) -o $@ $^ $(CPPAD_LIBS) 129 | 130 | compare_adolc: $(EXAMPLES) \ 131 | examples/bench_simple_adolc examples/bench_simple_tapeless_adolc examples/bench_sparse_adolc 132 | @echo "" 133 | @echo "-- bench_simple ----------------------------------------" 134 | @echo "* ADOLC (tape+eval)" 135 | time ./examples/bench_simple_adolc 136 | @echo "* ADOLC (tapeless)" 137 | time ./examples/bench_simple_tapeless_adolc 138 | @echo "* ADJAC" 139 | time ./examples/bench_simple 140 | @echo "* ADJAC (tapeless)" 141 | time ./examples/bench_simple_tapeless 142 | @echo "" 143 | @echo "-- bench_sparse ----------------------------------------" 144 | @echo "* ADOLC (tape+eval)" 145 | time ./examples/bench_sparse_adolc 146 | @echo "* ADJAC" 147 | time ./examples/bench_sparse 148 | @echo "* ADJAC (tapeless)" 149 | time ./examples/bench_sparse_tapeless 150 | 151 | compare_adept: $(EXAMPLES) examples/bench_simple_adept examples/bench_advection_adept 152 | @echo "" 153 | @echo "-- bench_simple ----------------------------------------" 154 | @echo "* ADEPT" 155 | time ./examples/bench_simple_adept 156 | @echo "* ADJAC" 157 | time ./examples/bench_simple 158 | @echo "* ADJAC (tapeless)" 159 | time ./examples/bench_simple_tapeless 160 | @echo "" 161 | @echo "-- bench_advection ----------------------------------------" 162 | @echo "* ADEPT" 163 | time ./examples/bench_advection_adept 164 | @echo "* ADJAC" 165 | time ./examples/bench_advection 166 | @echo "* ADJAC (tapeless)" 167 | time ./examples/bench_advection_tapeless 168 | 169 | compare_cppad: $(EXAMPLES) examples/bench_simple_cppad 170 | @echo "" 171 | @echo "-- bench_simple ----------------------------------------" 172 | @echo "* CPPAD" 173 | time ./examples/bench_simple_cppad 174 | @echo "* ADJAC" 175 | time ./examples/bench_simple 176 | @echo "* ADJAC (tapeless)" 177 | time ./examples/bench_simple_tapeless 178 | 179 | compare_numdiff: $(EXAMPLES) examples/bench_simple_numdiff 180 | @echo "" 181 | @echo "-- bench_simple ----------------------------------------" 182 | @echo "* Numerical differentiation" 183 | time ./examples/bench_simple_numdiff 184 | @echo "* ADJAC" 185 | time ./examples/bench_simple 186 | @echo "* ADJAC (tapeless)" 187 | time ./examples/bench_simple_tapeless 188 | 189 | clean: 190 | rm -rf $(EXAMPLES) $(TESTS) build tests/*.out *.o *.a *.mod $(CXXEXAMPLES) 191 | 192 | .PHONY: all test examples compare_adolc compare_adept 193 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | .. image:: https://zenodo.org/badge/23917/pv/adjac.svg 2 | :target: https://zenodo.org/badge/latestdoi/23917/pv/adjac 3 | 4 | ===== 5 | adjac 6 | ===== 7 | 8 | Automatic Differentiation for generating sparse Jacobians, using Fortran 95 and 9 | operator overloading. 10 | 11 | Provides three AD data types: 12 | 13 | - adjac_double: double precision AD variable 14 | - adjac_complex: double complex AD variable 15 | - adjac_complexan: double complex analytic AD variable 16 | 17 | and the support routines: 18 | 19 | - adjac_reset: initialize storage space 20 | - adjac_free: free storage space 21 | - adjac_set_independent: initialize independent variable (dy_i/dx_j = delta_ij) 22 | - adjac_get_value: get values from a dependent variables 23 | - adjac_get_coo_jacobian: get Jacobian in sparse coordinate format 24 | - adjac_get_dense_jacobian: get Jacobian as a full matrix 25 | 26 | The complex analytic adjac_complexan generates complex-valued 27 | Jacobians corresponding to the complex derivative, whereas 28 | adjac_complex can be used to generate real-valued Jacobians 29 | corresponding to separate derivatives vs. real and imaginary parts 30 | of the variables. In complex-analytic cases, the results will be 31 | equivalent, but adjac_complexan is more efficient computationally. 32 | 33 | The data types support operations =,*,+,-,matmul,exp,sin,cos,log,dble,aimag,conjg. 34 | However, adjac_complexan does not support operations that break complex analyticity. 35 | 36 | For more information about automatic differentiation, and other AD software , 37 | see http://autodiff.org/ Adjac performance appears to be roughly similar to 38 | ADOLC, and within a factor of 2-3 from ADEPT. 39 | 40 | Versions 41 | -------- 42 | 43 | There are two versions of ADJAC, ``adjac.f95`` and 44 | ``adjac_tapeless.f95`` which differ only in the internal 45 | implementation of the differentiation. Their performance and memory 46 | usage characteristics differ; ``adjac.f95`` usually needs more memory 47 | and can be faster, depending on the problem, whereas 48 | ``adjac_pure.f95`` needs less and may be slower. 49 | 50 | Fourier transforms 51 | ------------------ 52 | 53 | The supplied ``adjac_fft`` module provides discrete Fourier 54 | transforms: 55 | 56 | - ``fft(n, z)`` compute DFT in-place 57 | - ``ifft(n, z)`` compute inverse DFT in-place 58 | 59 | These are mainly useful in the tape mode, where they allow storing the 60 | FFT Jacobian with ``~ 4 n log(n)`` tape usage. 61 | 62 | Example 63 | ------- 64 | 65 | Adjac enables computation of the Jacobian of a multivariate function, 66 | requiring only slightly modified code computing the *value* of the 67 | function. 68 | 69 | For example, consider the following:: 70 | 71 | subroutine my_func(x, y) 72 | implicit none 73 | double complex, dimension(3), intent(in) :: x 74 | double complex, dimension(2), intent(out) :: y 75 | 76 | integer :: j 77 | do j = 1, 2 78 | y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2)) 79 | end do 80 | end subroutine my_func 81 | 82 | The following function calculates the same as the above, and in 83 | addition the partial derivatives with respect to `x`:: 84 | 85 | subroutine my_func_jac(x_value, y_value, dy_dx) 86 | use adjac 87 | implicit none 88 | double complex, dimension(3), intent(in) :: x_value 89 | double complex, dimension(2), intent(out) :: y_value 90 | double complex, dimension(2,3), intent(out) :: dy_dx 91 | 92 | type(adjac_complexan), dimension(3) :: x 93 | type(adjac_complexan), dimension(2) :: y 94 | integer :: j 95 | 96 | call adjac_reset() 97 | call adjac_set_independent(x, x_value) 98 | 99 | do j = 1, 2 100 | y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2)) 101 | end do 102 | 103 | call adjac_get_value(y, y_value) 104 | call adjac_get_dense_jacobian(y, dy_dx) 105 | end subroutine my_func_jac 106 | 107 | Note that the computational part of the code is unchanged. In general, 108 | only data type replacements of the form ``double precision -> 109 | adjac_double`` are usually necessary to make things work. 110 | 111 | See ``examples/*.f95`` for mode a usage examples. 112 | 113 | -------------------------------------------------------------------------------- /adjac.f95.in: -------------------------------------------------------------------------------- 1 | ! -*-f90-*- 2 | ! 3 | ! adjac: Automatic Differentiation for generating Jacobians. 4 | ! 5 | 6 | ! Copyright (c) 2014, Pauli Virtanen 7 | ! All rights reserved. 8 | ! 9 | ! Redistribution and use in source and binary forms, with or without 10 | ! modification, are permitted provided that the following conditions 11 | ! are met: 12 | ! 13 | ! 1. Redistributions of source code must retain the above copyright 14 | ! notice, this list of conditions and the following disclaimer. 15 | ! 16 | ! 2. Redistributions in binary form must reproduce the above copyright 17 | ! notice, this list of conditions and the following disclaimer in the 18 | ! documentation and/or other materials provided with the distribution. 19 | ! 20 | ! 3. Neither the name of the copyright holder nor the names of its 21 | ! contributors may be used to endorse or promote products derived from 22 | ! this software without specific prior written permission. 23 | ! 24 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 25 | ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 26 | ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 27 | ! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 28 | ! COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 29 | ! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 30 | ! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 31 | ! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 32 | ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 33 | ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 34 | ! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 35 | ! POSSIBILITY OF SUCH DAMAGE. 36 | 37 | {{default TAPELESS = False}} 38 | 39 | module adjac 40 | private 41 | 42 | ! NOTE: we would like to use derived type finalizers for memory 43 | ! deallocation. However, as of 2015-03-12, these are not fully 44 | ! implemented in gfortran, and will not be called e.g. on function 45 | ! returns that the code here extensively relies on. 46 | 47 | type, public :: adjac_double 48 | double precision :: value, vmul 49 | {{if TAPELESS}} 50 | ! Don't use default initializers, but rely on the compiler 51 | ! handling allocatable elements correctly. Hence, 52 | ! .not.allocated(v) implies n=0. 53 | integer :: n 54 | double precision, dimension(:), allocatable :: v 55 | integer, dimension(:), allocatable :: i 56 | {{else}} 57 | integer :: i = 0 58 | {{endif}} 59 | end type adjac_double 60 | 61 | type, public :: adjac_complexan 62 | complex(kind=kind(0d0)) :: value, vmul 63 | {{if TAPELESS}} 64 | integer :: n = 0 65 | complex(kind=kind(0d0)), dimension(:), allocatable :: v 66 | integer, dimension(:), allocatable :: i 67 | {{else}} 68 | integer :: i = 0 69 | {{endif}} 70 | end type adjac_complexan 71 | 72 | type, public :: adjac_complex 73 | type(adjac_double) :: re, im 74 | end type adjac_complex 75 | 76 | logical :: jac_product_mode = .false. 77 | 78 | {{if TAPELESS}} 79 | {{else}} 80 | ! DAG of differentials 81 | ! 82 | ! if (sum_map(1 + 2*(i-1)) .ne. 0) then 83 | ! ! dependent variable 84 | ! d_{i} = sum_mul(1+2*(i-1)) * d_{sum_map(1+2*(i-1))} + sum_mul(2+2*(i-1)) * d_{sum_map(2+2*(i-1))} 85 | ! else 86 | ! ! independent variable 87 | ! d_{i} = D_{i} 88 | ! 89 | integer, parameter :: block_size = 16 90 | integer :: free_a = 1, free_q = 1 91 | integer, dimension(:), allocatable :: sum_map_a, sum_map_q 92 | double precision, dimension(:), allocatable :: sum_mul_a 93 | complex(kind=kind(0d0)), dimension(:), allocatable :: sum_mul_q 94 | {{endif}} 95 | 96 | {{if TAPELESS}} 97 | {{default pure = "pure"}} 98 | {{default elemental = "pure elemental"}} 99 | {{else}} 100 | {{default pure = ""}} 101 | {{default elemental = "impure elemental"}} 102 | {{endif}} 103 | 104 | {{py: 105 | def binops(name): 106 | chrs = ['i', 'd', 'z'] 107 | ops = ['aa', 'bb', 'qq', 'ab', 'ba'] 108 | for c in chrs: 109 | ops += ['a'+c, 'b'+c, 'q'+c, c+'a', c+'b', c+'q'] 110 | oldops = list(ops) 111 | s = "\n".join(" module procedure " + name + "_" + op for op in ops) 112 | return s.lstrip() 113 | }} 114 | 115 | public assignment(=) 116 | interface assignment(=) 117 | module procedure assign_ai, assign_ad 118 | module procedure assign_bi, assign_bd, assign_bz, assign_ba 119 | module procedure assign_qi, assign_qd, assign_qz 120 | end interface 121 | 122 | public operator(+) 123 | interface operator(+) 124 | {{binops("add")}} 125 | module procedure pos_a, pos_b, pos_q 126 | end interface 127 | 128 | public operator(-) 129 | interface operator(-) 130 | {{binops("sub")}} 131 | module procedure neg_a, neg_b, neg_q 132 | end interface 133 | 134 | public operator(*) 135 | interface operator(*) 136 | {{binops("mul")}} 137 | end interface operator(*) 138 | 139 | public operator(/) 140 | interface operator(/) 141 | {{binops("div")}} 142 | end interface operator(/) 143 | 144 | public operator(**) 145 | interface operator(**) 146 | module procedure pow_ai, pow_ad, pow_qi, pow_qd, pow_qz 147 | end interface operator(**) 148 | 149 | public matmul 150 | interface matmul 151 | module procedure matmul_aa, matmul_ai, matmul_ia, matmul_ad, matmul_da 152 | module procedure matmul_bb, matmul_bz, matmul_zb 153 | module procedure matmul_qq, matmul_qi, matmul_iq, matmul_qd, matmul_dq, matmul_qz, matmul_zq 154 | end interface matmul 155 | 156 | public dble 157 | interface dble 158 | module procedure dble_a, dble_b 159 | end interface dble 160 | 161 | public aimag 162 | interface aimag 163 | module procedure aimag_b 164 | end interface aimag 165 | 166 | public conjg 167 | interface conjg 168 | module procedure conjg_b 169 | end interface conjg 170 | 171 | public abs 172 | interface abs 173 | module procedure abs_a, abs_b 174 | end interface abs 175 | 176 | public exp 177 | interface exp 178 | module procedure exp_a, exp_b, exp_q 179 | end interface exp 180 | 181 | public sin 182 | interface sin 183 | module procedure sin_a, sin_b, sin_q 184 | end interface sin 185 | 186 | public cos 187 | interface cos 188 | module procedure cos_a, cos_b, cos_q 189 | end interface cos 190 | 191 | public log 192 | interface log 193 | module procedure log_a, log_b, log_q 194 | end interface log 195 | 196 | public sqrt 197 | interface sqrt 198 | module procedure sqrt_a, sqrt_b, sqrt_q 199 | end interface sqrt 200 | 201 | interface adjac_set_independent 202 | module procedure set_independent_a, set_independent_q 203 | module procedure set_independent_many_a, set_independent_many_q 204 | end interface adjac_set_independent 205 | 206 | interface sum_taylor 207 | module procedure sum_taylor_a, sum_taylor_q 208 | end interface sum_taylor 209 | 210 | interface adjac_get_value 211 | module procedure get_value_one_a, get_value_one_q 212 | module procedure get_value_many_a, get_value_many_q 213 | end interface adjac_get_value 214 | 215 | interface adjac_get_dense_jacobian 216 | module procedure get_dense_jacobian_a, get_dense_jacobian_q 217 | end interface adjac_get_dense_jacobian 218 | 219 | interface adjac_get_coo_jacobian 220 | module procedure get_coo_jacobian_a, get_coo_jacobian_q 221 | end interface adjac_get_coo_jacobian 222 | 223 | public adjac_set_independent, adjac_get_value, & 224 | adjac_get_dense_jacobian, adjac_get_coo_jacobian, & 225 | adjac_reset, adjac_free 226 | contains 227 | 228 | subroutine fatal_error(msg) 229 | implicit none 230 | character(len=*), intent(in) :: msg 231 | write(*,*) 'adjac: error: ', trim(msg) 232 | stop 233 | end subroutine fatal_error 234 | 235 | subroutine adjac_reset(product_mode) 236 | implicit none 237 | logical, optional, intent(in) :: product_mode 238 | 239 | if (present(product_mode)) then 240 | jac_product_mode = product_mode 241 | end if 242 | 243 | {{if not TAPELESS}} 244 | free_a = 1 245 | free_q = 1 246 | {{endif}} 247 | end subroutine adjac_reset 248 | 249 | subroutine adjac_free() 250 | implicit none 251 | {{if not TAPELESS}} 252 | free_a = 1 253 | free_q = 1 254 | if (allocated(sum_map_a)) then 255 | deallocate(sum_map_a) 256 | deallocate(sum_mul_a) 257 | end if 258 | if (allocated(sum_map_q)) then 259 | deallocate(sum_map_q) 260 | deallocate(sum_mul_q) 261 | end if 262 | {{endif}} 263 | end subroutine adjac_free 264 | 265 | {{if not TAPELESS}} 266 | pure subroutine heap_siftup(heap, nheap, initpos) 267 | implicit none 268 | integer, intent(in) :: nheap 269 | integer, dimension(*), intent(inout) :: heap 270 | integer, intent(in) :: initpos 271 | 272 | integer :: pos, item, pos2, pos3 273 | 274 | pos = initpos 275 | pos2 = 2*pos 276 | 277 | item = heap(pos) 278 | do while (pos2 <= nheap) 279 | pos3 = pos2 + 1 280 | if (pos3 <= nheap .and. heap(pos3) >= heap(pos2)) then 281 | pos2 = pos3 282 | end if 283 | heap(pos) = heap(pos2) 284 | pos = pos2 285 | pos2 = 2*pos 286 | end do 287 | heap(pos) = item 288 | call heap_siftdown(heap, initpos, pos) 289 | end subroutine heap_siftup 290 | 291 | pure subroutine heap_siftdown(heap, initpos, pos0) 292 | implicit none 293 | integer, dimension(*), intent(inout) :: heap 294 | integer, intent(in) :: initpos, pos0 295 | 296 | integer :: item, pos, pos2 297 | 298 | pos = pos0 299 | item = heap(pos) 300 | do while (pos > initpos) 301 | pos2 = pos/2 302 | if (heap(pos2) < item) then 303 | heap(pos) = heap(pos2) 304 | else 305 | exit 306 | end if 307 | pos = pos2 308 | end do 309 | heap(pos) = item 310 | end subroutine heap_siftdown 311 | 312 | pure subroutine heap_push(heap, nheap, item) 313 | implicit none 314 | integer, intent(inout) :: nheap 315 | integer, dimension(*), intent(inout) :: heap 316 | integer, intent(in) :: item 317 | 318 | nheap = nheap + 1 319 | heap(nheap) = item 320 | call heap_siftdown(heap, 1, nheap) 321 | end subroutine heap_push 322 | 323 | pure subroutine heap_pop(heap, nheap, item) 324 | implicit none 325 | integer, intent(inout) :: nheap 326 | integer, dimension(*), intent(inout) :: heap 327 | integer, intent(out) :: item 328 | 329 | item = heap(1) 330 | heap(1) = heap(nheap) 331 | nheap = nheap - 1 332 | 333 | if (nheap.gt.1) then 334 | call heap_siftup(heap, nheap, 1) 335 | end if 336 | end subroutine heap_pop 337 | 338 | pure subroutine heap_pushpop(heap, nheap, item, item_out) 339 | implicit none 340 | integer, intent(inout) :: nheap 341 | integer, dimension(*), intent(inout) :: heap 342 | integer, intent(in) :: item 343 | integer, intent(out) :: item_out 344 | 345 | if (nheap > 0 .and. item < heap(1)) then 346 | item_out = heap(1) 347 | heap(1) = item 348 | if (nheap.gt.1) then 349 | call heap_siftup(heap, nheap, 1) 350 | end if 351 | else 352 | item_out = item 353 | end if 354 | end subroutine heap_pushpop 355 | {{endif}} 356 | 357 | {{for TYPE, FTYPE, CHR, CAST, FTYPES2 in [('adjac_double', 'double precision', 'a', 'real', [('integer', 'i'), 358 | ('double precision', 'd')]), 359 | ('adjac_complexan', 'complex(kind=kind(0d0))', 'q', 'cmplx', [('integer', 'i'), 360 | ('double precision', 'd'), 361 | ('complex(kind=kind(0d0))', 'z')])]}} 362 | 363 | {{if TAPELESS}} 364 | {{pure}} subroutine alloc_mem_{{CHR}}(x, n) 365 | {{else}} 366 | {{pure}} subroutine alloc_mem_{{CHR}}(x) 367 | {{endif}} 368 | implicit none 369 | type({{TYPE}}), intent(inout) :: x 370 | {{if TAPELESS}} 371 | integer, intent(in) :: n 372 | {{else}} 373 | integer, dimension(:), allocatable :: itmp 374 | {{FTYPE}}, dimension(:), allocatable :: tmp 375 | integer :: sz 376 | {{endif}} 377 | 378 | if (jac_product_mode) then 379 | return 380 | end if 381 | 382 | {{if TAPELESS}} 383 | if (allocated(x%i)) deallocate(x%i) 384 | if (allocated(x%v)) deallocate(x%v) 385 | x%n = n 386 | if (n > 0) then 387 | allocate(x%i(n), x%v(n)) 388 | end if 389 | {{else}} 390 | if (.not.allocated(sum_map_{{CHR}})) then 391 | sz = 0 392 | else 393 | sz = size(sum_map_{{CHR}}) 394 | end if 395 | 396 | if (sz < 2*free_{{CHR}} + 1) then 397 | ! Enlarge work space 398 | if (allocated(sum_map_{{CHR}})) then 399 | sz = sz + 2*free_{{CHR}} + 1 400 | allocate(itmp(sz), tmp(sz)) 401 | itmp(1:size(sum_map_{{CHR}})) = sum_map_{{CHR}}(:) 402 | tmp(1:size(sum_mul_{{CHR}})) = sum_mul_{{CHR}}(:) 403 | call move_alloc(itmp, sum_map_{{CHR}}) 404 | call move_alloc(tmp, sum_mul_{{CHR}}) 405 | else 406 | allocate(sum_map_{{CHR}}(100), sum_mul_{{CHR}}(100)) 407 | end if 408 | end if 409 | 410 | x%i = free_{{CHR}} 411 | free_{{CHR}} = free_{{CHR}} + 1 412 | {{endif}} 413 | end subroutine alloc_mem_{{CHR}} 414 | 415 | pure subroutine link_mem_{{CHR}}(dst, src) 416 | implicit none 417 | type({{TYPE}}), intent(inout) :: dst 418 | type({{TYPE}}), intent(in) :: src 419 | {{if TAPELESS}} 420 | integer :: n 421 | if (allocated(src%v)) then 422 | n = src%n 423 | else 424 | n = 0 425 | end if 426 | call alloc_mem_{{CHR}}(dst, n) 427 | dst%n = n 428 | if (n > 0) then 429 | dst%v(1:n) = src%v(1:n) 430 | dst%i(1:n) = src%i(1:n) 431 | end if 432 | {{else}} 433 | dst%i = src%i 434 | {{endif}} 435 | end subroutine link_mem_{{CHR}} 436 | 437 | pure subroutine free_mem_{{CHR}}(x) 438 | implicit none 439 | type({{TYPE}}), intent(inout) :: x 440 | {{if TAPELESS}} 441 | if (allocated(x%i)) deallocate(x%i) 442 | if (allocated(x%v)) deallocate(x%v) 443 | x%n = 0 444 | {{else}} 445 | x%i = 0 446 | {{endif}} 447 | end subroutine free_mem_{{CHR}} 448 | 449 | subroutine set_independent_{{CHR}}(x, xval, j, dx) 450 | implicit none 451 | type({{TYPE}}), intent(out) :: x 452 | {{FTYPE}}, intent(in) :: xval 453 | {{FTYPE}}, optional, intent(in) :: dx 454 | integer, intent(in) :: j 455 | 456 | x%value = xval 457 | if (jac_product_mode) then 458 | if (.not.present(dx)) then 459 | call fatal_error('no dx given to adjac_set_independent when jacobian product mode is active') 460 | end if 461 | x%vmul = dx 462 | else 463 | x%vmul = 1 464 | {{if TAPELESS}} 465 | call alloc_mem_{{CHR}}(x, 1) 466 | x%v(1) = 1 467 | x%i(1) = j 468 | {{else}} 469 | call alloc_mem_{{CHR}}(x) 470 | sum_map_{{CHR}}(1 + 2*(x%i-1)) = 0 471 | sum_map_{{CHR}}(2 + 2*(x%i-1)) = j 472 | {{endif}} 473 | end if 474 | end subroutine set_independent_{{CHR}} 475 | 476 | subroutine set_independent_many_{{CHR}}(x, xval, dx) 477 | implicit none 478 | type({{TYPE}}), dimension(:), intent(inout) :: x 479 | {{FTYPE}}, dimension(size(x)), intent(in) :: xval 480 | {{FTYPE}}, dimension(size(x)), optional, intent(in) :: dx 481 | 482 | integer :: j 483 | 484 | if (present(dx)) then 485 | do j = 1, size(x,1) 486 | call set_independent_{{CHR}}(x(j), xval(j), j, dx(j)) 487 | end do 488 | else 489 | do j = 1, size(x,1) 490 | call set_independent_{{CHR}}(x(j), xval(j), j) 491 | end do 492 | end if 493 | end subroutine set_independent_many_{{CHR}} 494 | 495 | subroutine get_value_one_{{CHR}}(y, val, dy) 496 | implicit none 497 | type({{TYPE}}), intent(in) :: y 498 | {{FTYPE}}, intent(out) :: val 499 | {{FTYPE}}, optional, intent(out) :: dy 500 | val = y%value 501 | if (present(dy)) then 502 | if (.not. jac_product_mode) then 503 | call fatal_error('call to adjac_get_value with dy when jacobian product mode is not active') 504 | end if 505 | dy = y%vmul 506 | end if 507 | end subroutine get_value_one_{{CHR}} 508 | 509 | subroutine get_value_many_{{CHR}}(y, val, dy) 510 | implicit none 511 | type({{TYPE}}), dimension(:), intent(in) :: y 512 | {{FTYPE}}, dimension(size(y,1)), intent(out) :: val 513 | {{FTYPE}}, dimension(size(y,1)), optional, intent(out) :: dy 514 | integer :: j 515 | do j = 1, size(val,1) 516 | val(j) = y(j)%value 517 | end do 518 | if (present(dy)) then 519 | if (.not. jac_product_mode) then 520 | call fatal_error('call to adjac_get_value with dy when jacobian product mode is not active') 521 | end if 522 | do j = 1, size(val,1) 523 | dy(j) = y(j)%vmul 524 | end do 525 | end if 526 | end subroutine get_value_many_{{CHR}} 527 | 528 | {{py: 529 | def walk_tape(ftype, chr, assign, accumulate=None, clear=None): 530 | if accumulate is None: 531 | accumulate = """ 532 | do concurrent (k=1:block_size) 533 | work(k,ia) = work(k,ia) + sum_mul_{chr}(1+2*(j-1)) * work(k,j) 534 | end do 535 | do concurrent (k=1:block_size) 536 | work(k,ib) = work(k,ib) + sum_mul_{chr}(2+2*(j-1)) * work(k,j) 537 | end do 538 | """.format(chr=chr) 539 | if clear is None: 540 | clear = """ 541 | do concurrent (k=1:block_size) 542 | work(k,j) = 0 543 | end do 544 | """ 545 | return """ 546 | ! Traverse the tape 547 | j_next = 0 548 | if (nwork > 0) then 549 | call heap_pop(iwork, nwork, j_next) 550 | end if 551 | do while (j_next > 0) 552 | j = j_next 553 | j_next = 0 554 | 555 | if (256*nwork > j) then 556 | ! Heap is too big, probably contains nearly all j values, 557 | ! and we are better off just looping through them 558 | nwork = j 559 | exit 560 | end if 561 | 562 | ia = sum_map_{chr}(1+2*(j-1)) 563 | ib = sum_map_{chr}(2+2*(j-1)) 564 | 565 | if (ia == 0) then 566 | {assign} 567 | else 568 | {accumulate} 569 | if (imask(ia) == 0 .and. imask(ib) == 0) then 570 | call heap_push(iwork, nwork, ia) 571 | call heap_pushpop(iwork, nwork, ib, j_next) 572 | imask(ia) = 1 573 | imask(ib) = 1 574 | else if (imask(ia) == 0) then 575 | call heap_pushpop(iwork, nwork, ia, j_next) 576 | imask(ia) = 1 577 | else if (imask(ib) == 0) then 578 | call heap_pushpop(iwork, nwork, ib, j_next) 579 | imask(ib) = 1 580 | end if 581 | end if 582 | {clear} 583 | imask(j) = 0 584 | 585 | if (nwork > 0 .and. j_next == 0) then 586 | call heap_pop(iwork, nwork, j_next) 587 | end if 588 | end do 589 | do j = nwork, 1, -1 590 | if (imask(j).ne.0) then 591 | ia = sum_map_{chr}(1+2*(j-1)) 592 | ib = sum_map_{chr}(2+2*(j-1)) 593 | if (ia == 0) then 594 | {assign} 595 | else 596 | {accumulate} 597 | imask(ia) = 1 598 | imask(ib) = 1 599 | end if 600 | {clear} 601 | imask(j) = 0 602 | end if 603 | end do 604 | """.format(ftype=ftype, chr=chr, assign=assign, accumulate=accumulate, clear=clear) 605 | }} 606 | 607 | subroutine get_dense_jacobian_{{CHR}}(y, jac_dense) 608 | implicit none 609 | type({{TYPE}}), dimension(:), intent(inout) :: y 610 | {{FTYPE}}, dimension(:,:), intent(out) :: jac_dense 611 | 612 | {{if not TAPELESS}} 613 | {{FTYPE}}, dimension(block_size,free_{{CHR}}) :: work 614 | integer, dimension(free_{{CHR}}) :: iwork, imask 615 | integer :: k, j, ia, ib, kmin, kmax, nwork, j_next 616 | 617 | if (jac_product_mode) then 618 | call fatal_error('call to adjac_get_dense_jacobian when jacobian product mode is active') 619 | end if 620 | 621 | jac_dense = 0 622 | 623 | work = 0 624 | imask = 0 625 | 626 | do kmin = 1, size(y,1), block_size 627 | kmax = min(kmin + block_size - 1, size(y,1)) 628 | 629 | nwork = 0 630 | do k = kmin, kmax, 1 631 | if (y(k)%i == 0) cycle 632 | work(k-kmin+1, y(k)%i) = y(k)%vmul 633 | call heap_push(iwork, nwork, y(k)%i) 634 | imask(y(k)%i) = 1 635 | end do 636 | 637 | {{walk_tape(FTYPE, CHR, "jac_dense(kmin:kmax,ib) = work(1:(kmax-kmin+1),j)")}} 638 | end do 639 | {{else}} 640 | integer :: i, p 641 | 642 | if (jac_product_mode) then 643 | call fatal_error('call to adjac_get_dense_jacobian when jacobian product mode is active') 644 | end if 645 | 646 | jac_dense = 0 647 | 648 | do concurrent (i=1:size(y,1)) 649 | if (allocated(y(i)%v)) then 650 | do p = 1, y(i)%n 651 | jac_dense(i, y(i)%i(p)) = jac_dense(i, y(i)%i(p)) & 652 | + y(i)%vmul * y(i)%v(p) 653 | end do 654 | end if 655 | end do 656 | {{endif}} 657 | end subroutine get_dense_jacobian_{{CHR}} 658 | 659 | subroutine get_coo_jacobian_{{CHR}}(y, nnz, jac_val, jac_i, jac_j) 660 | implicit none 661 | type({{TYPE}}), dimension(:), intent(inout) :: y 662 | {{FTYPE}}, dimension(:), allocatable, intent(inout) :: jac_val 663 | integer, dimension(:), allocatable, intent(inout) :: jac_i, jac_j 664 | integer, intent(out) :: nnz 665 | 666 | {{if not TAPELESS}} 667 | {{FTYPE}}, dimension(block_size,free_{{CHR}}) :: work 668 | integer, dimension(free_{{CHR}}) :: iwork, imask 669 | integer, dimension(:), allocatable :: itmp 670 | {{FTYPE}}, dimension(:), allocatable :: vtmp 671 | integer :: kmin, kmax, k, j, ia, ib, nwork, j_next, sz 672 | 673 | if (jac_product_mode) then 674 | call fatal_error('call to adjac_get_coo_jacobian when jacobian product mode is active') 675 | end if 676 | 677 | if (allocated(jac_val)) deallocate(jac_val) 678 | if (allocated(jac_i)) deallocate(jac_i) 679 | if (allocated(jac_j)) deallocate(jac_j) 680 | 681 | sz = free_{{CHR}} + 10 682 | allocate(jac_val(sz), jac_i(sz), jac_j(sz)) 683 | 684 | nnz = 0 685 | work = 0 686 | imask = 0 687 | 688 | do kmin = 1, size(y,1), block_size 689 | kmax = min(kmin + block_size - 1, size(y,1)) 690 | 691 | nwork = 0 692 | do k = kmin, kmax, 1 693 | if (y(k)%i == 0) cycle 694 | work(k-kmin+1, y(k)%i) = y(k)%vmul 695 | call heap_push(iwork, nwork, y(k)%i) 696 | imask(y(k)%i) = 1 697 | end do 698 | 699 | {{walk_tape(FTYPE, CHR, """ 700 | if (nnz + (kmax-kmin) + 1 >= sz) then 701 | ! Exponential overallocation 702 | sz = 2*sz + (kmax-kmin) + 1 703 | 704 | allocate(itmp(sz)) 705 | itmp(1:nnz) = jac_i(1:nnz) 706 | call move_alloc(itmp, jac_i) 707 | 708 | allocate(itmp(sz)) 709 | itmp(1:nnz) = jac_j(1:nnz) 710 | call move_alloc(itmp, jac_j) 711 | 712 | allocate(vtmp(sz)) 713 | vtmp(1:nnz) = jac_val(1:nnz) 714 | call move_alloc(vtmp, jac_val) 715 | end if 716 | do k = kmin, kmax 717 | if (work(k-kmin+1,j).ne.0) then 718 | nnz = nnz + 1 719 | jac_i(nnz) = k 720 | jac_j(nnz) = ib 721 | jac_val(nnz) = work(k-kmin+1,j) 722 | end if 723 | end do 724 | """)}} 725 | end do 726 | 727 | if (nnz .eq. 0) then 728 | if (allocated(jac_val)) deallocate(jac_val) 729 | if (allocated(jac_i)) deallocate(jac_i) 730 | if (allocated(jac_j)) deallocate(jac_j) 731 | else if (nnz < sz) then 732 | ! Shrink to size 733 | allocate(itmp(nnz)) 734 | itmp(1:nnz) = jac_i(1:nnz) 735 | call move_alloc(itmp, jac_i) 736 | allocate(itmp(nnz)) 737 | itmp(1:nnz) = jac_j(1:nnz) 738 | call move_alloc(itmp, jac_j) 739 | allocate(vtmp(nnz)) 740 | vtmp(1:nnz) = jac_val(1:nnz) 741 | call move_alloc(vtmp, jac_val) 742 | end if 743 | {{else}} 744 | integer :: i, k 745 | 746 | if (jac_product_mode) then 747 | call fatal_error('call to adjac_get_coo_jacobian when jacobian product mode is active') 748 | end if 749 | 750 | if (allocated(jac_val)) deallocate(jac_val) 751 | if (allocated(jac_i)) deallocate(jac_i) 752 | if (allocated(jac_j)) deallocate(jac_j) 753 | 754 | nnz = 0 755 | do i = 1, size(y,1) 756 | if (allocated(y(i)%v)) then 757 | nnz = nnz + y(i)%n 758 | end if 759 | end do 760 | 761 | allocate(jac_val(nnz), jac_i(nnz), jac_j(nnz)) 762 | 763 | k = 1 764 | do i = 1, size(y,1) 765 | if (allocated(y(i)%v)) then 766 | if (y(i)%n > 0) then 767 | jac_i(k:k+y(i)%n-1) = i 768 | jac_j(k:k+y(i)%n-1) = y(i)%i(1:y(i)%n) 769 | jac_val(k:k+y(i)%n-1) = y(i)%vmul * y(i)%v(1:y(i)%n) 770 | k = k + y(i)%n 771 | end if 772 | end if 773 | end do 774 | {{endif}} 775 | end subroutine get_coo_jacobian_{{CHR}} 776 | 777 | {{if TAPELESS}} 778 | pure subroutine sparse_vector_sum_{{CHR}}(alpha, beta, na, nb, nc, ia, ib, ic, va, vb, vc) 779 | ! Sum sparse vectors c = alpha*a + beta*b, with index and data arrays (ia,va), (ib,vb), (ic,vc) 780 | ! The output arrays are assumed to be big enough to hold the data. 781 | implicit none 782 | integer, intent(in) :: na, nb, ia(*), ib(*) 783 | integer, intent(inout) :: nc 784 | integer, intent(out) :: ic(*) 785 | {{FTYPE}}, intent(in) :: alpha, beta, va(*), vb(*) 786 | {{FTYPE}}, intent(out) :: vc(*) 787 | 788 | integer :: ja, jb, jc 789 | 790 | ja = 1 791 | jb = 1 792 | jc = 1 793 | 794 | do while (ja <= na .and. jb <= nb) 795 | if (ia(ja) < ib(jb)) then 796 | vc(jc) = alpha * va(ja) 797 | if (vc(jc) .ne. 0) then 798 | ic(jc) = ia(ja) 799 | jc = jc + 1 800 | end if 801 | ja = ja + 1 802 | else if (ia(ja) > ib(jb)) then 803 | vc(jc) = beta * vb(jb) 804 | if (vc(jc) .ne. 0) then 805 | ic(jc) = ib(jb) 806 | jc = jc + 1 807 | end if 808 | jb = jb + 1 809 | else 810 | vc(jc) = alpha * va(ja) + beta * vb(jb) 811 | if (vc(jc) .ne. 0) then 812 | ic(jc) = ia(ja) 813 | jc = jc + 1 814 | end if 815 | ja = ja + 1 816 | jb = jb + 1 817 | end if 818 | end do 819 | 820 | do while (ja <= na) 821 | vc(jc) = alpha * va(ja) 822 | if (vc(jc) .ne. 0) then 823 | ic(jc) = ia(ja) 824 | jc = jc + 1 825 | end if 826 | ja = ja + 1 827 | end do 828 | 829 | do while (jb <= nb) 830 | vc(jc) = beta * vb(jb) 831 | if (vc(jc) .ne. 0) then 832 | ic(jc) = ib(jb) 833 | jc = jc + 1 834 | end if 835 | jb = jb + 1 836 | end do 837 | 838 | nc = jc - 1 839 | end subroutine sparse_vector_sum_{{CHR}} 840 | {{endif}} 841 | 842 | {{pure}} subroutine sum_taylor_{{CHR}}(alphap, betap, a, b, c) 843 | ! c := alpha*a + beta*b 844 | use iso_c_binding 845 | implicit none 846 | {{FTYPE}}, intent(in) :: alphap, betap 847 | type({{TYPE}}), intent(in) :: a, b 848 | type({{TYPE}}), intent(inout) :: c 849 | 850 | if (jac_product_mode) then 851 | c%vmul = alphap * a%vmul + betap * b%vmul 852 | else 853 | {{if TAPELESS}} 854 | if (allocated(a%v) .and. allocated(b%v) .and. a%n > 0 .and. b%n > 0) then 855 | call alloc_mem_{{CHR}}(c, a%n + b%n) 856 | call sparse_vector_sum_{{CHR}}(alphap*a%vmul, betap*b%vmul, a%n, b%n, c%n, & 857 | a%i, b%i, c%i, & 858 | a%v, b%v, c%v) 859 | c%vmul = 1 860 | else if (allocated(a%v) .and. a%n > 0) then 861 | call alloc_mem_{{CHR}}(c, a%n) 862 | c%i(1:a%n) = a%i(1:a%n) 863 | c%v(1:a%n) = a%v(1:a%n) 864 | c%n = a%n 865 | c%vmul = alphap * a%vmul 866 | else if (allocated(b%v) .and. b%n > 0) then 867 | call alloc_mem_{{CHR}}(c, b%n) 868 | c%i(1:b%n) = b%i(1:b%n) 869 | c%v(1:b%n) = b%v(1:b%n) 870 | c%n = b%n 871 | c%vmul = betap * b%vmul 872 | else 873 | c%n = 0 874 | c%vmul = 0 875 | end if 876 | {{else}} 877 | if (a%vmul == 0 .or. a%i == 0 .or. alphap == 0) then 878 | c%vmul = betap * b%vmul 879 | c%i = b%i 880 | else if (b%vmul == 0 .or. b%i == 0 .or. betap == 0) then 881 | c%vmul = alphap * a%vmul 882 | c%i = a%i 883 | else if (a%i == b%i) then 884 | c%vmul = alphap * a%vmul + betap * b%vmul 885 | c%i = a%i 886 | else 887 | call alloc_mem_{{CHR}}(c) 888 | c%vmul = 1 889 | sum_map_{{CHR}}(1 + 2*(c%i-1)) = a%i 890 | sum_map_{{CHR}}(2 + 2*(c%i-1)) = b%i 891 | sum_mul_{{CHR}}(1 + 2*(c%i-1)) = alphap * a%vmul 892 | sum_mul_{{CHR}}(2 + 2*(c%i-1)) = betap * b%vmul 893 | end if 894 | {{endif}} 895 | end if 896 | end subroutine sum_taylor_{{CHR}} 897 | 898 | 899 | !-------------------------------------------------------------------------- 900 | ! Overloaded operators 901 | !-------------------------------------------------------------------------- 902 | 903 | !! 904 | !! assignment(=) 905 | !! 906 | 907 | {{for FTYPE2, CHR2 in FTYPES2}} 908 | pure elemental subroutine assign_{{CHR}}{{CHR2}}(x, y) 909 | implicit none 910 | type({{TYPE}}), intent(inout) :: x 911 | {{FTYPE2}}, intent(in) :: y 912 | call free_mem_{{CHR}}(x) 913 | x%value = y 914 | x%vmul = 0 915 | end subroutine assign_{{CHR}}{{CHR2}} 916 | {{endfor}} 917 | 918 | {{if TYPE == "adjac_double"}} 919 | {{for FTYPE2, CHR2 in FTYPES2}} 920 | pure elemental subroutine assign_b{{CHR2}}(x, y) 921 | implicit none 922 | type(adjac_complex), intent(inout) :: x 923 | {{FTYPE2}}, intent(in) :: y 924 | x%re = dble(y) 925 | x%im = 0d0 926 | end subroutine assign_b{{CHR2}} 927 | {{endfor}} 928 | 929 | pure elemental subroutine assign_bz(x, y) 930 | implicit none 931 | type(adjac_complex), intent(inout) :: x 932 | complex(kind=kind(0d0)), intent(in) :: y 933 | x%re = dble(y) 934 | x%im = aimag(y) 935 | end subroutine assign_bz 936 | 937 | pure elemental subroutine assign_ba(x, y) 938 | implicit none 939 | type(adjac_complex), intent(inout) :: x 940 | type({{TYPE}}), intent(in) :: y 941 | x%re = y 942 | x%im = 0d0 943 | end subroutine assign_ba 944 | {{endif}} 945 | 946 | !! 947 | !! operator(+) 948 | !! 949 | 950 | ! X + Y = x + y + (x_j + y_j) dj 951 | 952 | {{elemental}} function add_{{CHR}}{{CHR}}(x, y) result(z) 953 | implicit none 954 | type({{TYPE}}), intent(in) :: x, y 955 | type({{TYPE}}) :: z 956 | 957 | z%value = x%value + y%value 958 | call sum_taylor({{CAST}}(1d0, kind=kind(0d0)), {{CAST}}(1d0, kind=kind(0d0)), x, y, z) 959 | end function add_{{CHR}}{{CHR}} 960 | 961 | {{for FTYPE2, CHR2 in FTYPES2}} 962 | pure elemental function add_{{CHR}}{{CHR2}}(x, y) result(z) 963 | implicit none 964 | type({{TYPE}}), intent(in) :: x 965 | {{FTYPE2}}, intent(in) :: y 966 | type({{TYPE}}) :: z 967 | z%value = x%value + y 968 | z%vmul = x%vmul 969 | call link_mem_{{CHR}}(z, x) 970 | end function add_{{CHR}}{{CHR2}} 971 | 972 | pure elemental function add_{{CHR2}}{{CHR}}(x, y) result(z) 973 | implicit none 974 | {{FTYPE2}}, intent(in) :: x 975 | type({{TYPE}}), intent(in) :: y 976 | type({{TYPE}}) :: z 977 | z = y + x 978 | end function add_{{CHR2}}{{CHR}} 979 | {{endfor}} 980 | 981 | {{if TYPE == "adjac_double"}} 982 | pure elemental function add_az(x, y) result(z) 983 | implicit none 984 | type({{TYPE}}), intent(in) :: x 985 | complex(kind=kind(0d0)), intent(in) :: y 986 | type(adjac_complex) :: z 987 | z%re = x + dble(y) 988 | z%im = aimag(y) 989 | end function add_az 990 | 991 | pure elemental function add_za(x, y) result(z) 992 | implicit none 993 | complex(kind=kind(0d0)), intent(in) :: x 994 | type({{TYPE}}), intent(in) :: y 995 | type(adjac_complex) :: z 996 | z%re = dble(x) + y 997 | z%im = aimag(x) 998 | end function add_za 999 | 1000 | {{elemental}} function add_bb(x, y) result(z) 1001 | implicit none 1002 | type(adjac_complex), intent(in) :: x 1003 | type(adjac_complex), intent(in) :: y 1004 | type(adjac_complex) :: z 1005 | z%re = x%re + y%re 1006 | z%im = x%im + y%im 1007 | end function add_bb 1008 | 1009 | pure elemental function add_bz(x, y) result(z) 1010 | implicit none 1011 | type(adjac_complex), intent(in) :: x 1012 | complex(kind=kind(0d0)), intent(in) :: y 1013 | type(adjac_complex) :: z 1014 | z%re = x%re + dble(y) 1015 | z%im = x%im + aimag(y) 1016 | end function add_bz 1017 | 1018 | pure elemental function add_zb(x, y) result(z) 1019 | implicit none 1020 | complex(kind=kind(0d0)), intent(in) :: x 1021 | type(adjac_complex), intent(in) :: y 1022 | type(adjac_complex) :: z 1023 | z%re = dble(x) + y%re 1024 | z%im = aimag(x) + y%im 1025 | end function add_zb 1026 | 1027 | {{elemental}} function add_ba(x, y) result(z) 1028 | implicit none 1029 | type(adjac_complex), intent(in) :: x 1030 | type({{TYPE}}), intent(in) :: y 1031 | type(adjac_complex) :: z 1032 | z%re = x%re + y 1033 | z%im = x%im 1034 | end function add_ba 1035 | 1036 | {{elemental}} function add_ab(x, y) result(z) 1037 | implicit none 1038 | type({{TYPE}}), intent(in) :: x 1039 | type(adjac_complex), intent(in) :: y 1040 | type(adjac_complex) :: z 1041 | z%re = x + y%re 1042 | z%im = y%im 1043 | end function add_ab 1044 | 1045 | {{for FTYPE2, CHR2 in FTYPES2}} 1046 | pure elemental function add_b{{CHR2}}(x, y) result(z) 1047 | implicit none 1048 | type(adjac_complex), intent(in) :: x 1049 | {{FTYPE2}}, intent(in) :: y 1050 | type(adjac_complex) :: z 1051 | z = x + cmplx(y, kind=kind(0d0)) 1052 | end function add_b{{CHR2}} 1053 | 1054 | pure elemental function add_{{CHR2}}b(x, y) result(z) 1055 | implicit none 1056 | {{FTYPE2}}, intent(in) :: x 1057 | type(adjac_complex), intent(in) :: y 1058 | type(adjac_complex) :: z 1059 | z = cmplx(x, kind=kind(0d0)) + y 1060 | end function add_{{CHR2}}b 1061 | {{endfor}} 1062 | 1063 | {{endif}} 1064 | 1065 | !! 1066 | !! operator(+), unary 1067 | !! 1068 | 1069 | pure elemental function pos_{{CHR}}(x) result(z) 1070 | implicit none 1071 | type({{TYPE}}), intent(in) :: x 1072 | type({{TYPE}}) :: z 1073 | z = x 1074 | end function pos_{{CHR}} 1075 | 1076 | {{if TYPE == "adjac_double"}} 1077 | pure elemental function pos_b(x) result(z) 1078 | implicit none 1079 | type(adjac_complex), intent(in) :: x 1080 | type(adjac_complex) :: z 1081 | z = x 1082 | end function pos_b 1083 | {{endif}} 1084 | 1085 | !! 1086 | !! operator(-) 1087 | !! 1088 | 1089 | ! X - Y = x - y + (x_j - y_j) dj 1090 | 1091 | {{elemental}} function sub_{{CHR}}{{CHR}}(x, y) result(z) 1092 | implicit none 1093 | type({{TYPE}}), intent(in) :: x, y 1094 | type({{TYPE}}) :: z 1095 | 1096 | z%value = x%value - y%value 1097 | call sum_taylor({{CAST}}(1d0, kind=kind(0d0)), {{CAST}}(-1d0, kind=kind(0d0)), x, y, z) 1098 | end function sub_{{CHR}}{{CHR}} 1099 | 1100 | {{for FTYPE2, CHR2 in FTYPES2}} 1101 | pure elemental function sub_{{CHR}}{{CHR2}}(x, y) result(z) 1102 | implicit none 1103 | type({{TYPE}}), intent(in) :: x 1104 | {{FTYPE2}}, intent(in) :: y 1105 | type({{TYPE}}) :: z 1106 | z%value = x%value - y 1107 | z%vmul = x%vmul 1108 | call link_mem_{{CHR}}(z, x) 1109 | end function sub_{{CHR}}{{CHR2}} 1110 | 1111 | pure elemental function sub_{{CHR2}}{{CHR}}(x, y) result(z) 1112 | implicit none 1113 | {{FTYPE2}}, intent(in) :: x 1114 | type({{TYPE}}), intent(in) :: y 1115 | type({{TYPE}}) :: z 1116 | z%value = x - y%value 1117 | z%vmul = -y%vmul 1118 | call link_mem_{{CHR}}(z, y) 1119 | end function sub_{{CHR2}}{{CHR}} 1120 | {{endfor}} 1121 | 1122 | {{if TYPE == "adjac_double"}} 1123 | pure elemental function sub_az(x, y) result(z) 1124 | implicit none 1125 | type({{TYPE}}), intent(in) :: x 1126 | complex(kind=kind(0d0)), intent(in) :: y 1127 | type(adjac_complex) :: z 1128 | z%re = x - dble(y) 1129 | z%im = -aimag(y) 1130 | end function sub_az 1131 | 1132 | pure elemental function sub_za(x, y) result(z) 1133 | implicit none 1134 | complex(kind=kind(0d0)), intent(in) :: x 1135 | type({{TYPE}}), intent(in) :: y 1136 | type(adjac_complex) :: z 1137 | z%re = dble(x) - y 1138 | z%im = aimag(x) 1139 | end function sub_za 1140 | 1141 | {{elemental}} function sub_bb(x, y) result(z) 1142 | implicit none 1143 | type(adjac_complex), intent(in) :: x 1144 | type(adjac_complex), intent(in) :: y 1145 | type(adjac_complex) :: z 1146 | z%re = x%re - y%re 1147 | z%im = x%im - y%im 1148 | end function sub_bb 1149 | 1150 | pure elemental function sub_bz(x, y) result(z) 1151 | implicit none 1152 | type(adjac_complex), intent(in) :: x 1153 | complex(kind=kind(0d0)), intent(in) :: y 1154 | type(adjac_complex) :: z 1155 | z%re = x%re - dble(y) 1156 | z%im = x%im - aimag(y) 1157 | end function sub_bz 1158 | 1159 | pure elemental function sub_zb(x, y) result(z) 1160 | implicit none 1161 | complex(kind=kind(0d0)), intent(in) :: x 1162 | type(adjac_complex), intent(in) :: y 1163 | type(adjac_complex) :: z 1164 | z%re = dble(x) - y%re 1165 | z%im = aimag(x) - y%im 1166 | end function sub_zb 1167 | 1168 | {{elemental}} function sub_ba(x, y) result(z) 1169 | implicit none 1170 | type(adjac_complex), intent(in) :: x 1171 | type({{TYPE}}), intent(in) :: y 1172 | type(adjac_complex) :: z 1173 | z%re = x%re - y 1174 | z%im = x%im 1175 | end function sub_ba 1176 | 1177 | {{elemental}} function sub_ab(x, y) result(z) 1178 | implicit none 1179 | type({{TYPE}}), intent(in) :: x 1180 | type(adjac_complex), intent(in) :: y 1181 | type(adjac_complex) :: z 1182 | z%re = x - y%re 1183 | z%im = -y%im 1184 | end function sub_ab 1185 | 1186 | {{for FTYPE2, CHR2 in FTYPES2}} 1187 | pure elemental function sub_b{{CHR2}}(x, y) result(z) 1188 | implicit none 1189 | type(adjac_complex), intent(in) :: x 1190 | {{FTYPE2}}, intent(in) :: y 1191 | type(adjac_complex) :: z 1192 | z = x - cmplx(y, kind=kind(0d0)) 1193 | end function sub_b{{CHR2}} 1194 | 1195 | pure elemental function sub_{{CHR2}}b(x, y) result(z) 1196 | implicit none 1197 | {{FTYPE2}}, intent(in) :: x 1198 | type(adjac_complex), intent(in) :: y 1199 | type(adjac_complex) :: z 1200 | z = cmplx(x, kind=kind(0d0)) - y 1201 | end function sub_{{CHR2}}b 1202 | {{endfor}} 1203 | {{endif}} 1204 | 1205 | !! 1206 | !! operator(-), unary 1207 | !! 1208 | 1209 | pure elemental function neg_{{CHR}}(x) result(z) 1210 | implicit none 1211 | type({{TYPE}}), intent(in) :: x 1212 | type({{TYPE}}) :: z 1213 | z = 0d0 - x 1214 | end function neg_{{CHR}} 1215 | 1216 | {{if TYPE == "adjac_double"}} 1217 | pure elemental function neg_b(x) result(z) 1218 | implicit none 1219 | type(adjac_complex), intent(in) :: x 1220 | type(adjac_complex) :: z 1221 | z = (0d0,0d0) - x 1222 | end function neg_b 1223 | {{endif}} 1224 | 1225 | !! 1226 | !! operator(*) 1227 | !! 1228 | 1229 | ! X*Y = x*y + (x y_j + y x_j) dj 1230 | 1231 | {{elemental}} function mul_{{CHR}}{{CHR}}(x, y) result(z) 1232 | implicit none 1233 | type({{TYPE}}), intent(in) :: x, y 1234 | type({{TYPE}}) :: z 1235 | 1236 | z%value = x%value * y%value 1237 | call sum_taylor(y%value, x%value, x, y, z) 1238 | end function mul_{{CHR}}{{CHR}} 1239 | 1240 | {{for FTYPE2, CHR2 in FTYPES2}} 1241 | pure elemental function mul_{{CHR}}{{CHR2}}(x, y) result(z) 1242 | implicit none 1243 | type({{TYPE}}), intent(in) :: x 1244 | {{FTYPE2}}, intent(in) :: y 1245 | type({{TYPE}}) :: z 1246 | if (y == 0) then 1247 | z%value = 0 1248 | z%vmul = 0 1249 | call free_mem_{{CHR}}(z) 1250 | else 1251 | z%value = x%value * y 1252 | z%vmul = x%vmul * y 1253 | call link_mem_{{CHR}}(z, x) 1254 | end if 1255 | end function mul_{{CHR}}{{CHR2}} 1256 | 1257 | pure elemental function mul_{{CHR2}}{{CHR}}(x, y) result(z) 1258 | implicit none 1259 | {{FTYPE2}}, intent(in) :: x 1260 | type({{TYPE}}), intent(in) :: y 1261 | type({{TYPE}}) :: z 1262 | z = y * x 1263 | end function mul_{{CHR2}}{{CHR}} 1264 | {{endfor}} 1265 | 1266 | {{if TYPE == "adjac_double"}} 1267 | pure elemental function mul_az(x, y) result(z) 1268 | implicit none 1269 | type({{TYPE}}), intent(in) :: x 1270 | complex(kind=kind(0d0)), intent(in) :: y 1271 | type(adjac_complex) :: z 1272 | z%re = x * dble(y) 1273 | z%im = x * aimag(y) 1274 | end function mul_az 1275 | 1276 | pure elemental function mul_za(x, y) result(z) 1277 | implicit none 1278 | complex(kind=kind(0d0)), intent(in) :: x 1279 | type({{TYPE}}), intent(in) :: y 1280 | type(adjac_complex) :: z 1281 | z%re = dble(x) * y 1282 | z%im = aimag(x) * y 1283 | end function mul_za 1284 | 1285 | {{elemental}} function mul_bb(x, y) result(z) 1286 | implicit none 1287 | type(adjac_complex), intent(in) :: x 1288 | type(adjac_complex), intent(in) :: y 1289 | type(adjac_complex) :: z 1290 | z%re = x%re * y%re - x%im * y%im 1291 | z%im = x%re * y%im + x%im * y%re 1292 | end function mul_bb 1293 | 1294 | {{elemental}} function mul_bz(x, y) result(z) 1295 | implicit none 1296 | type(adjac_complex), intent(in) :: x 1297 | complex(kind=kind(0d0)), intent(in) :: y 1298 | type(adjac_complex) :: z 1299 | z%re = x%re * dble(y) - x%im * aimag(y) 1300 | z%im = x%re * aimag(y) + x%im * dble(y) 1301 | end function mul_bz 1302 | 1303 | {{elemental}} function mul_zb(x, y) result(z) 1304 | implicit none 1305 | complex(kind=kind(0d0)), intent(in) :: x 1306 | type(adjac_complex), intent(in) :: y 1307 | type(adjac_complex) :: z 1308 | z%re = dble(x) * y%re - aimag(x) * y%im 1309 | z%im = dble(x) * y%im + aimag(x) * y%re 1310 | end function mul_zb 1311 | 1312 | {{elemental}} function mul_ba(x, y) result(z) 1313 | implicit none 1314 | type(adjac_complex), intent(in) :: x 1315 | type({{TYPE}}), intent(in) :: y 1316 | type(adjac_complex) :: z 1317 | z%re = x%re * y 1318 | z%im = x%im * y 1319 | end function mul_ba 1320 | 1321 | {{elemental}} function mul_ab(x, y) result(z) 1322 | implicit none 1323 | type({{TYPE}}), intent(in) :: x 1324 | type(adjac_complex), intent(in) :: y 1325 | type(adjac_complex) :: z 1326 | z%re = x * y%re 1327 | z%im = x * y%im 1328 | end function mul_ab 1329 | 1330 | {{for FTYPE2, CHR2 in FTYPES2}} 1331 | {{elemental}} function mul_b{{CHR2}}(x, y) result(z) 1332 | implicit none 1333 | type(adjac_complex), intent(in) :: x 1334 | {{FTYPE2}}, intent(in) :: y 1335 | type(adjac_complex) :: z 1336 | z = x * cmplx(y, kind=kind(0d0)) 1337 | end function mul_b{{CHR2}} 1338 | 1339 | {{elemental}} function mul_{{CHR2}}b(x, y) result(z) 1340 | implicit none 1341 | {{FTYPE2}}, intent(in) :: x 1342 | type(adjac_complex), intent(in) :: y 1343 | type(adjac_complex) :: z 1344 | z = cmplx(x, kind=kind(0d0)) * y 1345 | end function mul_{{CHR2}}b 1346 | {{endfor}} 1347 | {{endif}} 1348 | 1349 | !! 1350 | !! operator(/) 1351 | !! 1352 | 1353 | ! X/Y = x/y + (x_j/y - x y_j/y**2) dj 1354 | 1355 | {{elemental}} function div_{{CHR}}{{CHR}}(x, y) result(z) 1356 | implicit none 1357 | type({{TYPE}}), intent(in) :: x, y 1358 | type({{TYPE}}) :: z 1359 | z%value = x%value / y%value 1360 | call sum_taylor(1d0/y%value, -x%value/(y%value**2), x, y, z) 1361 | end function div_{{CHR}}{{CHR}} 1362 | 1363 | {{for FTYPE2, CHR2 in FTYPES2}} 1364 | pure elemental function div_{{CHR}}{{CHR2}}(x, y) result(z) 1365 | implicit none 1366 | type({{TYPE}}), intent(in) :: x 1367 | {{FTYPE2}}, intent(in) :: y 1368 | type({{TYPE}}) :: z 1369 | z = (1d0 / y) * x 1370 | end function div_{{CHR}}{{CHR2}} 1371 | 1372 | pure elemental function div_{{CHR2}}{{CHR}}(x, y) result(z) 1373 | implicit none 1374 | {{FTYPE2}}, intent(in) :: x 1375 | type({{TYPE}}), intent(in) :: y 1376 | type({{TYPE}}) :: z 1377 | z = (-x / (y%value**2)) * y 1378 | z%value = x / y%value 1379 | end function div_{{CHR2}}{{CHR}} 1380 | {{endfor}} 1381 | 1382 | {{if TYPE == "adjac_double"}} 1383 | pure elemental function div_az(x, y) result(z) 1384 | implicit none 1385 | type({{TYPE}}), intent(in) :: x 1386 | complex(kind=kind(0d0)), intent(in) :: y 1387 | type(adjac_complex) :: z 1388 | complex(kind=kind(0d0)) :: q 1389 | q = conjg(y) / (dble(y)*dble(y) + aimag(y)*aimag(y)) 1390 | z%re = dble(q) * x 1391 | z%im = aimag(q) * x 1392 | end function div_az 1393 | 1394 | pure elemental function div_za(x, y) result(z) 1395 | implicit none 1396 | complex(kind=kind(0d0)), intent(in) :: x 1397 | type({{TYPE}}), intent(in) :: y 1398 | type(adjac_complex) :: z 1399 | z%re = dble(x) / y 1400 | z%im = aimag(x) / y 1401 | end function div_za 1402 | 1403 | {{elemental}} function div_bb(x, y) result(z) 1404 | implicit none 1405 | type(adjac_complex), intent(in) :: x 1406 | type(adjac_complex), intent(in) :: y 1407 | type(adjac_complex) :: z 1408 | z = x * conjg(y) / (dble(y)*dble(y) + aimag(y)*aimag(y)) 1409 | end function div_bb 1410 | 1411 | {{elemental}} function div_bz(x, y) result(z) 1412 | implicit none 1413 | type(adjac_complex), intent(in) :: x 1414 | complex(kind=kind(0d0)), intent(in) :: y 1415 | type(adjac_complex) :: z 1416 | z = x * conjg(y) / (dble(y)*dble(y) + aimag(y)*aimag(y)) 1417 | end function div_bz 1418 | 1419 | {{elemental}} function div_zb(x, y) result(z) 1420 | implicit none 1421 | complex(kind=kind(0d0)), intent(in) :: x 1422 | type(adjac_complex), intent(in) :: y 1423 | type(adjac_complex) :: z 1424 | z = x * conjg(y) / (dble(y)*dble(y) + aimag(y)*aimag(y)) 1425 | end function div_zb 1426 | 1427 | {{elemental}} function div_ba(x, y) result(z) 1428 | implicit none 1429 | type(adjac_complex), intent(in) :: x 1430 | type({{TYPE}}), intent(in) :: y 1431 | type(adjac_complex) :: z 1432 | z%re = x%re / y 1433 | z%im = x%im / y 1434 | end function div_ba 1435 | 1436 | {{elemental}} function div_ab(x, y) result(z) 1437 | implicit none 1438 | type({{TYPE}}), intent(in) :: x 1439 | type(adjac_complex), intent(in) :: y 1440 | type(adjac_complex) :: z 1441 | z = x * conjg(y) / (dble(y)*dble(y) + aimag(y)*aimag(y)) 1442 | end function div_ab 1443 | 1444 | {{for FTYPE2, CHR2 in FTYPES2}} 1445 | {{elemental}} function div_b{{CHR2}}(x, y) result(z) 1446 | implicit none 1447 | type(adjac_complex), intent(in) :: x 1448 | {{FTYPE2}}, intent(in) :: y 1449 | type(adjac_complex) :: z 1450 | z%re = x%re / y 1451 | z%im = x%im / y 1452 | end function div_b{{CHR2}} 1453 | 1454 | {{elemental}} function div_{{CHR2}}b(x, y) result(z) 1455 | implicit none 1456 | {{FTYPE2}}, intent(in) :: x 1457 | type(adjac_complex), intent(in) :: y 1458 | type(adjac_complex) :: z 1459 | z = cmplx(x, kind=kind(0d0)) / y 1460 | end function div_{{CHR2}}b 1461 | {{endfor}} 1462 | {{endif}} 1463 | 1464 | !! 1465 | !! operator(**) 1466 | !! 1467 | 1468 | {{for FTYPE2, CHR2 in FTYPES2}} 1469 | pure elemental function pow_{{CHR}}{{CHR2}}(x, y) result(z) 1470 | implicit none 1471 | type({{TYPE}}), intent(in) :: x 1472 | {{FTYPE2}}, intent(in) :: y 1473 | type({{TYPE}}) :: z 1474 | z = exp(y * log(x)) 1475 | end function pow_{{CHR}}{{CHR2}} 1476 | {{endfor}} 1477 | 1478 | !! 1479 | !! matmul 1480 | !! 1481 | 1482 | {{def matmulcode}} 1483 | integer i, j, k 1484 | 1485 | if (size(x,2) .ne. size(y,1)) then 1486 | write(*,*) 'invalid array sizes in matmul' 1487 | stop 1488 | end if 1489 | 1490 | do j = 1, size(y,2) 1491 | do i = 1, size(x,1) 1492 | z(i,j) = x(i,1)*y(1,j) 1493 | do k = 2, size(x,2) 1494 | z(i,j) = z(i,j) + x(i,k)*y(k,j) 1495 | end do 1496 | end do 1497 | end do 1498 | {{enddef}} 1499 | 1500 | function matmul_{{CHR}}{{CHR}}(x, y) result(z) 1501 | implicit none 1502 | type({{TYPE}}), dimension(:,:), intent(in) :: x, y 1503 | type({{TYPE}}), dimension(size(x,1),size(y,2)) :: z 1504 | {{matmulcode}} 1505 | end function matmul_{{CHR}}{{CHR}} 1506 | 1507 | {{for FTYPE2, CHR2 in FTYPES2}} 1508 | function matmul_{{CHR}}{{CHR2}}(x, y) result(z) 1509 | implicit none 1510 | type({{TYPE}}), dimension(:,:), intent(in) :: x 1511 | {{FTYPE2}}, dimension(:,:), intent(in) :: y 1512 | type({{TYPE}}), dimension(size(x,1),size(y,2)) :: z 1513 | {{matmulcode}} 1514 | end function matmul_{{CHR}}{{CHR2}} 1515 | 1516 | function matmul_{{CHR2}}{{CHR}}(x, y) result(z) 1517 | implicit none 1518 | {{FTYPE2}}, dimension(:,:), intent(in) :: x 1519 | type({{TYPE}}), dimension(:,:), intent(in) :: y 1520 | type({{TYPE}}), dimension(size(x,1),size(y,2)) :: z 1521 | {{matmulcode}} 1522 | end function matmul_{{CHR2}}{{CHR}} 1523 | {{endfor}} 1524 | 1525 | {{if TYPE == "adjac_double"}} 1526 | function matmul_bb(x, y) result(z) 1527 | implicit none 1528 | type(adjac_complex), dimension(:,:), intent(in) :: x, y 1529 | type(adjac_complex), dimension(size(x,1),size(y,2)) :: z 1530 | {{matmulcode}} 1531 | end function matmul_bb 1532 | 1533 | function matmul_bz(x, y) result(z) 1534 | implicit none 1535 | type(adjac_complex), dimension(:,:), intent(in) :: x 1536 | complex(kind=kind(0d0)), dimension(:,:), intent(in) :: y 1537 | type(adjac_complex), dimension(size(x,1),size(y,2)) :: z 1538 | {{matmulcode}} 1539 | end function matmul_bz 1540 | 1541 | function matmul_zb(x, y) result(z) 1542 | implicit none 1543 | complex(kind=kind(0d0)), dimension(:,:), intent(in) :: x 1544 | type(adjac_complex), dimension(:,:), intent(in) :: y 1545 | type(adjac_complex), dimension(size(x,1),size(y,2)) :: z 1546 | {{matmulcode}} 1547 | end function matmul_zb 1548 | {{endif}} 1549 | 1550 | !! 1551 | !! dble 1552 | !! 1553 | 1554 | {{if TYPE == "adjac_double"}} 1555 | pure elemental function dble_a(x) result(z) 1556 | implicit none 1557 | type(adjac_double), intent(in) :: x 1558 | type(adjac_double) :: z 1559 | z = x 1560 | end function dble_a 1561 | 1562 | pure elemental function dble_b(x) result(z) 1563 | implicit none 1564 | type(adjac_complex), intent(in) :: x 1565 | type(adjac_double) :: z 1566 | z = x%re 1567 | end function dble_b 1568 | {{endif}} 1569 | 1570 | !! 1571 | !! aimag 1572 | !! 1573 | 1574 | {{if TYPE == "adjac_double"}} 1575 | pure elemental function aimag_b(x) result(z) 1576 | implicit none 1577 | type(adjac_complex), intent(in) :: x 1578 | type(adjac_double) :: z 1579 | z = x%im 1580 | end function aimag_b 1581 | {{endif}} 1582 | 1583 | !! 1584 | !! conjg 1585 | !! 1586 | 1587 | {{if TYPE == "adjac_double"}} 1588 | pure elemental function conjg_b(x) result(z) 1589 | implicit none 1590 | type(adjac_complex), intent(in) :: x 1591 | type(adjac_complex) :: z 1592 | z%re = x%re 1593 | z%im = -x%im 1594 | end function conjg_b 1595 | {{endif}} 1596 | 1597 | !! 1598 | !! abs 1599 | !! 1600 | 1601 | {{if TYPE == "adjac_double"}} 1602 | pure elemental function abs_a(x) result(z) 1603 | implicit none 1604 | type(adjac_double), intent(in) :: x 1605 | type(adjac_double) :: z 1606 | if (x%value .ge. 0) then 1607 | z = x 1608 | else 1609 | z = -x 1610 | end if 1611 | end function abs_a 1612 | 1613 | {{elemental}} function abs_b(x) result(z) 1614 | implicit none 1615 | type(adjac_complex), intent(in) :: x 1616 | type(adjac_double) :: z 1617 | {{FTYPE}} :: v, dv_re, dv_im 1618 | v = hypot(x%re%value, x%im%value) 1619 | dv_re = x%re%value / v 1620 | dv_im = x%im%value / v 1621 | z = dv_re * x%re + dv_im * x%im 1622 | z%value = v 1623 | end function abs_b 1624 | {{endif}} 1625 | 1626 | !! 1627 | !! exp 1628 | !! 1629 | 1630 | pure elemental function exp_{{CHR}}(x) result(z) 1631 | implicit none 1632 | type({{TYPE}}), intent(in) :: x 1633 | type({{TYPE}}) :: z 1634 | {{FTYPE}} :: v, dv 1635 | v = exp(x%value) 1636 | dv = v 1637 | z = dv*x 1638 | z%value = v 1639 | end function exp_{{CHR}} 1640 | 1641 | {{if TYPE == "adjac_double"}} 1642 | {{elemental}} function exp_b(x) result(z) 1643 | implicit none 1644 | type(adjac_complex), intent(in) :: x 1645 | type(adjac_complex) :: z 1646 | complex(kind=kind(0d0)) :: v, dv 1647 | v = exp(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1648 | dv = v 1649 | z = dv*x 1650 | z%re%value = dble(v) 1651 | z%im%value = aimag(v) 1652 | end function exp_b 1653 | {{endif}} 1654 | 1655 | !! 1656 | !! sin 1657 | !! 1658 | 1659 | pure elemental function sin_{{CHR}}(x) result(z) 1660 | implicit none 1661 | type({{TYPE}}), intent(in) :: x 1662 | type({{TYPE}}) :: z 1663 | {{FTYPE}} :: v, dv 1664 | v = sin(x%value) 1665 | dv = cos(x%value) 1666 | z = dv*x 1667 | z%value = v 1668 | end function sin_{{CHR}} 1669 | 1670 | {{if TYPE == "adjac_double"}} 1671 | {{elemental}} function sin_b(x) result(z) 1672 | implicit none 1673 | type(adjac_complex), intent(in) :: x 1674 | type(adjac_complex) :: z 1675 | complex(kind=kind(0d0)) :: v, dv 1676 | v = sin(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1677 | dv = cos(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1678 | z = dv*x 1679 | z%re%value = dble(v) 1680 | z%im%value = aimag(v) 1681 | end function sin_b 1682 | {{endif}} 1683 | 1684 | !! 1685 | !! cos 1686 | !! 1687 | 1688 | pure elemental function cos_{{CHR}}(x) result(z) 1689 | implicit none 1690 | type({{TYPE}}), intent(in) :: x 1691 | type({{TYPE}}) :: z 1692 | {{FTYPE}} :: v, dv 1693 | v = cos(x%value) 1694 | dv = -sin(x%value) 1695 | z = dv*x 1696 | z%value = v 1697 | end function cos_{{CHR}} 1698 | 1699 | {{if TYPE == "adjac_double"}} 1700 | {{elemental}} function cos_b(x) result(z) 1701 | implicit none 1702 | type(adjac_complex), intent(in) :: x 1703 | type(adjac_complex) :: z 1704 | complex(kind=kind(0d0)) :: v, dv 1705 | v = cos(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1706 | dv = -sin(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1707 | z = dv*x 1708 | z%re%value = dble(v) 1709 | z%im%value = aimag(v) 1710 | end function cos_b 1711 | {{endif}} 1712 | 1713 | !! 1714 | !! log 1715 | !! 1716 | 1717 | pure elemental function log_{{CHR}}(x) result(z) 1718 | implicit none 1719 | type({{TYPE}}), intent(in) :: x 1720 | type({{TYPE}}) :: z 1721 | {{FTYPE}} :: v, dv 1722 | v = log(x%value) 1723 | dv = 1d0/x%value 1724 | z = dv*x 1725 | z%value = v 1726 | end function log_{{CHR}} 1727 | 1728 | {{if TYPE == "adjac_double"}} 1729 | {{elemental}} function log_b(x) result(z) 1730 | implicit none 1731 | type(adjac_complex), intent(in) :: x 1732 | type(adjac_complex) :: z 1733 | complex(kind=kind(0d0)) :: v, dv 1734 | v = log(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1735 | dv = 1d0/cmplx(x%re%value, x%im%value, kind=kind(0d0)) 1736 | z = dv*x 1737 | z%re%value = dble(v) 1738 | z%im%value = aimag(v) 1739 | end function log_b 1740 | {{endif}} 1741 | 1742 | !! 1743 | !! sqrt 1744 | !! 1745 | 1746 | pure elemental function sqrt_{{CHR}}(x) result(z) 1747 | implicit none 1748 | type({{TYPE}}), intent(in) :: x 1749 | type({{TYPE}}) :: z 1750 | {{FTYPE}} :: v, dv 1751 | v = sqrt(x%value) 1752 | dv = 0.5d0/v 1753 | z = dv*x 1754 | z%value = v 1755 | end function sqrt_{{CHR}} 1756 | 1757 | {{if TYPE == "adjac_double"}} 1758 | {{elemental}} function sqrt_b(x) result(z) 1759 | implicit none 1760 | type(adjac_complex), intent(in) :: x 1761 | type(adjac_complex) :: z 1762 | complex(kind=kind(0d0)) :: v, dv 1763 | v = sqrt(cmplx(x%re%value, x%im%value, kind=kind(0d0))) 1764 | dv = 0.5d0/v 1765 | z = dv*x 1766 | z%re%value = dble(v) 1767 | z%im%value = aimag(v) 1768 | end function sqrt_b 1769 | {{endif}} 1770 | {{endfor}} 1771 | 1772 | end module adjac 1773 | -------------------------------------------------------------------------------- /adjac_fft.f95: -------------------------------------------------------------------------------- 1 | !! NOTE: this file is autogenerated from adjac_fft.f95.in: do not edit manually 2 | module adjac_fft 3 | use adjac 4 | 5 | private 6 | public fft, ifft 7 | 8 | interface fft 9 | module procedure fft_a, fft_d, fft_b, fft_z 10 | end interface fft 11 | 12 | interface ifft 13 | module procedure ifft_a, ifft_d, ifft_b, ifft_z 14 | end interface ifft 15 | 16 | type(adjac_double), dimension(:), allocatable :: ch_a 17 | double precision, dimension(:), allocatable :: wa, ch_d 18 | integer, dimension(15) :: ifac 19 | contains 20 | subroutine fft_a(q) 21 | use adjac 22 | implicit none 23 | external :: zffti1, zfftf1 24 | type(adjac_double), dimension(:), contiguous, intent(inout) :: q 25 | integer :: n 26 | 27 | n = size(q)/2 28 | if (n.le.1) return 29 | 30 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 31 | if (allocated(wa)) deallocate(wa) 32 | allocate(wa(2*n)) 33 | call zffti1(n, wa, ifac) 34 | end if 35 | if (.not.allocated(ch_a) .or. size(ch_a) .ne. 2*n) then 36 | if (allocated(ch_a)) deallocate(ch_a) 37 | allocate(ch_a(2*n)) 38 | end if 39 | call zfftf1a(n, q, ch_a, wa, ifac) 40 | end subroutine fft_a 41 | 42 | subroutine ifft_a(q) 43 | use adjac 44 | implicit none 45 | external :: zffti1, zfftf1 46 | type(adjac_double), dimension(:), contiguous, intent(inout) :: q 47 | integer :: i, n 48 | 49 | n = size(q)/2 50 | if (n.le.1) return 51 | 52 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 53 | if (allocated(wa)) deallocate(wa) 54 | allocate(wa(2*n)) 55 | call zffti1(n, wa, ifac) 56 | end if 57 | if (.not.allocated(ch_a) .or. size(ch_a) .ne. 2*n) then 58 | if (allocated(ch_a)) deallocate(ch_a) 59 | allocate(ch_a(2*n)) 60 | end if 61 | call zfftb1a(n, q, ch_a, wa, ifac) 62 | 63 | do i = 1, size(q) 64 | q(i) = q(i) / n 65 | end do 66 | end subroutine ifft_a 67 | subroutine fft_d(q) 68 | use adjac 69 | implicit none 70 | external :: zffti1, zfftf1 71 | double precision, dimension(:), contiguous, intent(inout) :: q 72 | integer :: n 73 | 74 | n = size(q)/2 75 | if (n.le.1) return 76 | 77 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 78 | if (allocated(wa)) deallocate(wa) 79 | allocate(wa(2*n)) 80 | call zffti1(n, wa, ifac) 81 | end if 82 | if (.not.allocated(ch_d) .or. size(ch_d) .ne. 2*n) then 83 | if (allocated(ch_d)) deallocate(ch_d) 84 | allocate(ch_d(2*n)) 85 | end if 86 | call zfftf1d(n, q, ch_d, wa, ifac) 87 | end subroutine fft_d 88 | 89 | subroutine ifft_d(q) 90 | use adjac 91 | implicit none 92 | external :: zffti1, zfftf1 93 | double precision, dimension(:), contiguous, intent(inout) :: q 94 | integer :: i, n 95 | 96 | n = size(q)/2 97 | if (n.le.1) return 98 | 99 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 100 | if (allocated(wa)) deallocate(wa) 101 | allocate(wa(2*n)) 102 | call zffti1(n, wa, ifac) 103 | end if 104 | if (.not.allocated(ch_d) .or. size(ch_d) .ne. 2*n) then 105 | if (allocated(ch_d)) deallocate(ch_d) 106 | allocate(ch_d(2*n)) 107 | end if 108 | call zfftb1d(n, q, ch_d, wa, ifac) 109 | 110 | do i = 1, size(q) 111 | q(i) = q(i) / n 112 | end do 113 | end subroutine ifft_d 114 | subroutine fft_b(q) 115 | use adjac 116 | implicit none 117 | external :: zffti1, zfftf1 118 | type(adjac_complex), dimension(:), contiguous, intent(inout) :: q 119 | integer :: n 120 | 121 | n = size(q) 122 | if (n.le.1) return 123 | 124 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 125 | if (allocated(wa)) deallocate(wa) 126 | allocate(wa(2*n)) 127 | call zffti1(n, wa, ifac) 128 | end if 129 | if (.not.allocated(ch_a) .or. size(ch_a) .ne. 2*n) then 130 | if (allocated(ch_a)) deallocate(ch_a) 131 | allocate(ch_a(2*n)) 132 | end if 133 | call zfftf1a(n, q, ch_a, wa, ifac) 134 | end subroutine fft_b 135 | 136 | subroutine ifft_b(q) 137 | use adjac 138 | implicit none 139 | external :: zffti1, zfftf1 140 | type(adjac_complex), dimension(:), contiguous, intent(inout) :: q 141 | integer :: i, n 142 | 143 | n = size(q) 144 | if (n.le.1) return 145 | 146 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 147 | if (allocated(wa)) deallocate(wa) 148 | allocate(wa(2*n)) 149 | call zffti1(n, wa, ifac) 150 | end if 151 | if (.not.allocated(ch_a) .or. size(ch_a) .ne. 2*n) then 152 | if (allocated(ch_a)) deallocate(ch_a) 153 | allocate(ch_a(2*n)) 154 | end if 155 | call zfftb1a(n, q, ch_a, wa, ifac) 156 | 157 | do i = 1, size(q) 158 | q(i) = q(i) / n 159 | end do 160 | end subroutine ifft_b 161 | subroutine fft_z(q) 162 | use adjac 163 | implicit none 164 | external :: zffti1, zfftf1 165 | complex(kind=kind(0d0)), dimension(:), contiguous, intent(inout) :: q 166 | integer :: n 167 | 168 | n = size(q) 169 | if (n.le.1) return 170 | 171 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 172 | if (allocated(wa)) deallocate(wa) 173 | allocate(wa(2*n)) 174 | call zffti1(n, wa, ifac) 175 | end if 176 | if (.not.allocated(ch_d) .or. size(ch_d) .ne. 2*n) then 177 | if (allocated(ch_d)) deallocate(ch_d) 178 | allocate(ch_d(2*n)) 179 | end if 180 | call zfftf1d(n, q, ch_d, wa, ifac) 181 | end subroutine fft_z 182 | 183 | subroutine ifft_z(q) 184 | use adjac 185 | implicit none 186 | external :: zffti1, zfftf1 187 | complex(kind=kind(0d0)), dimension(:), contiguous, intent(inout) :: q 188 | integer :: i, n 189 | 190 | n = size(q) 191 | if (n.le.1) return 192 | 193 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 194 | if (allocated(wa)) deallocate(wa) 195 | allocate(wa(2*n)) 196 | call zffti1(n, wa, ifac) 197 | end if 198 | if (.not.allocated(ch_d) .or. size(ch_d) .ne. 2*n) then 199 | if (allocated(ch_d)) deallocate(ch_d) 200 | allocate(ch_d(2*n)) 201 | end if 202 | call zfftb1d(n, q, ch_d, wa, ifac) 203 | 204 | do i = 1, size(q) 205 | q(i) = q(i) / n 206 | end do 207 | end subroutine ifft_z 208 | end module adjac_fft 209 | -------------------------------------------------------------------------------- /adjac_fft.f95.in: -------------------------------------------------------------------------------- 1 | module adjac_fft 2 | use adjac 3 | 4 | private 5 | public fft, ifft 6 | 7 | interface fft 8 | module procedure fft_a, fft_d, fft_b, fft_z 9 | end interface fft 10 | 11 | interface ifft 12 | module procedure ifft_a, ifft_d, ifft_b, ifft_z 13 | end interface ifft 14 | 15 | type(adjac_double), dimension(:), allocatable :: ch_a 16 | double precision, dimension(:), allocatable :: wa, ch_d 17 | integer, dimension(15) :: ifac 18 | contains 19 | {{for TYPE, SUF, SIZE, SUF2 in [('type(adjac_double)', 'a', 'size(q)/2', 'a'), 20 | ('double precision', 'd', 'size(q)/2', 'd'), 21 | ('type(adjac_complex)', 'b', 'size(q)', 'a'), 22 | ('complex(kind=kind(0d0))', 'z', 'size(q)', 'd')]}} 23 | subroutine fft_{{SUF}}(q) 24 | use adjac 25 | implicit none 26 | external :: zffti1, zfftf1 27 | {{TYPE}}, dimension(:), contiguous, intent(inout) :: q 28 | integer :: n 29 | 30 | n = {{SIZE}} 31 | if (n.le.1) return 32 | 33 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 34 | if (allocated(wa)) deallocate(wa) 35 | allocate(wa(2*n)) 36 | call zffti1(n, wa, ifac) 37 | end if 38 | if (.not.allocated(ch_{{SUF2}}) .or. size(ch_{{SUF2}}) .ne. 2*n) then 39 | if (allocated(ch_{{SUF2}})) deallocate(ch_{{SUF2}}) 40 | allocate(ch_{{SUF2}}(2*n)) 41 | end if 42 | call zfftf1{{SUF2}}(n, q, ch_{{SUF2}}, wa, ifac) 43 | end subroutine fft_{{SUF}} 44 | 45 | subroutine ifft_{{SUF}}(q) 46 | use adjac 47 | implicit none 48 | external :: zffti1, zfftf1 49 | {{TYPE}}, dimension(:), contiguous, intent(inout) :: q 50 | integer :: i, n 51 | 52 | n = {{SIZE}} 53 | if (n.le.1) return 54 | 55 | if (.not.allocated(wa) .or. size(wa) .ne. 2*n) then 56 | if (allocated(wa)) deallocate(wa) 57 | allocate(wa(2*n)) 58 | call zffti1(n, wa, ifac) 59 | end if 60 | if (.not.allocated(ch_{{SUF2}}) .or. size(ch_{{SUF2}}) .ne. 2*n) then 61 | if (allocated(ch_{{SUF2}})) deallocate(ch_{{SUF2}}) 62 | allocate(ch_{{SUF2}}(2*n)) 63 | end if 64 | call zfftb1{{SUF2}}(n, q, ch_{{SUF2}}, wa, ifac) 65 | 66 | do i = 1, size(q) 67 | q(i) = q(i) / n 68 | end do 69 | end subroutine ifft_{{SUF}} 70 | {{endfor}} 71 | end module adjac_fft 72 | -------------------------------------------------------------------------------- /examples/bench_advection.f95: -------------------------------------------------------------------------------- 1 | program bench_advection 2 | implicit none 3 | integer, parameter :: nx = 100 4 | integer, parameter :: nt = 100 5 | integer, parameter :: nr = 500 6 | 7 | double precision, parameter :: pi = 4.0*atan(1.0) 8 | double precision :: q_init(nx) 9 | 10 | double precision, parameter :: dt = 0.125 11 | double precision :: jacobian(nx,nx) 12 | 13 | integer :: i 14 | 15 | do i = 1, nx 16 | q_init(i) = (0.5d0+0.5d0*sin(((i-1)*2d0*pi)/(nx-1.5d0)))+0.0001d0 17 | end do 18 | 19 | do i = 1, nr 20 | call doit(q_init, jacobian) 21 | if (i == 1) then 22 | write(*,*) jacobian(1,1:5) 23 | write(*,*) jacobian(2,1:5) 24 | write(*,*) jacobian(3,1:5) 25 | write(*,*) jacobian(4,1:5) 26 | write(*,*) jacobian(5,1:5) 27 | end if 28 | end do 29 | 30 | contains 31 | 32 | subroutine doit(q_init_values, jacobian) 33 | use adjac 34 | implicit none 35 | double precision, intent(in) :: q_init_values(nx) 36 | double precision, intent(out) :: jacobian(nx,nx) 37 | 38 | type(adjac_double) :: q_init(nx), q(nx) 39 | 40 | call adjac_reset() 41 | call adjac_set_independent(q_init, q_init_values) 42 | 43 | call toon(nt, dt, q_init, q) 44 | call adjac_get_dense_jacobian(q, jacobian) 45 | end subroutine doit 46 | 47 | subroutine lax_wendroff(nt, c, q_init, q) 48 | use adjac 49 | implicit none 50 | integer, intent(in) :: nt 51 | double precision, intent(in) :: c 52 | type(adjac_double), intent(in) :: q_init(nx) 53 | type(adjac_double), intent(inout) :: q(nx) 54 | 55 | type(adjac_double) :: flux(nx-1) 56 | integer :: i, j 57 | 58 | do i = 1, nx 59 | q(i) = q_init(i) 60 | end do 61 | 62 | do j = 1, nt 63 | do i = 1, nx-1 64 | flux(i) = 0.5d0*c*(q(i)+q(i+1)+c*(q(i)-q(i+1))) 65 | end do 66 | do i = 2, nx-1 67 | q(i) = q(i) + flux(i-1) - flux(i) 68 | end do 69 | q(1) = q(nx-1) 70 | q(nx) = q(2) 71 | end do 72 | end subroutine lax_wendroff 73 | 74 | subroutine toon(nt, c, q_init, q) 75 | use adjac 76 | implicit none 77 | integer, intent(in) :: nt 78 | double precision, intent(in) :: c 79 | type(adjac_double), intent(in) :: q_init(nx) 80 | type(adjac_double), intent(inout) :: q(nx) 81 | 82 | type(adjac_double) :: flux(nx-1) 83 | integer :: i, j 84 | 85 | do i = 1, nx 86 | q(i) = q_init(i) 87 | end do 88 | 89 | do j = 1, nt 90 | do i = 1, nx-1 91 | flux(i) = (exp(c*log(q(i)/q(i+1)))-1.0d0) * q(i)*q(i+1) / (q(i)-q(i+1)) 92 | end do 93 | do i = 2, nx-1 94 | q(i) = q(i) + flux(i-1) - flux(i) 95 | end do 96 | q(1) = q(nx-1) 97 | q(nx) = q(2) 98 | end do 99 | end subroutine toon 100 | end program bench_advection 101 | -------------------------------------------------------------------------------- /examples/bench_advection_adept.cpp: -------------------------------------------------------------------------------- 1 | /* Example code adapted from adept-1.0 advection example 2 | 3 | Copyright (C) 2012-2013 Robin Hogan and the University of Reading 4 | 5 | Contact email address: r.j.hogan@reading.ac.uk 6 | 7 | This file is part of the Adept library. 8 | 9 | This library is free software: you can redistribute it and/or modify 10 | it under the terms of the GNU General Public License as published by 11 | the Free Software Foundation, either version 3 of the License, or 12 | (at your option) any later version. 13 | 14 | This program is distributed in the hope that it will be useful, 15 | but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | GNU General Public License for more details. 18 | 19 | You should have received a copy of the GNU General Public License 20 | along with this program. If not, see . 21 | */ 22 | #include 23 | #include 24 | #include 25 | #include 26 | 27 | #include 28 | 29 | #define NX 100 30 | using namespace adept; 31 | 32 | // Lax-Wendroff scheme applied to linear advection 33 | void 34 | lax_wendroff(int nt, double c, const adouble q_init[NX], adouble q[NX]) 35 | { 36 | preallocate_statements((nt+1)*NX*3); 37 | preallocate_operations((nt+1)*NX*7); 38 | adouble flux[NX-1]; // Fluxes between boxes 39 | for (int i=0; i 2 | #include 3 | #include 4 | 5 | #include 6 | 7 | #define N 100 8 | #define FILLITER 10 9 | 10 | using adept::adouble; 11 | 12 | void laplacian(adouble x[N], adouble y[N]) 13 | { 14 | int i, p; 15 | y[0] = -2*x[0] + x[1]; 16 | y[N-1] = -2*x[N-1] + x[N-2]; 17 | for (i = 1; i < N-1; ++i) { 18 | y[i] = x[i-1] - 2*x[i] + x[i+1]; 19 | } 20 | for (p = 0; p < FILLITER; ++p) { 21 | for (i = 1; i < N-1; ++i) { 22 | y[i] = y[i-1] - 2*y[i] + y[i+1]/(3.1415 + y[i]); 23 | } 24 | } 25 | } 26 | 27 | void doit(double *x, double *y, double *J) 28 | { 29 | adept::Stack stack; 30 | adouble xad[N], yad[N]; 31 | int i; 32 | 33 | adept::set_values(xad, N, x); 34 | stack.new_recording(); 35 | 36 | laplacian(xad, yad); 37 | 38 | stack.independent(xad, N); 39 | stack.dependent(yad, N); 40 | stack.jacobian(J); 41 | 42 | for (i = 0; i < N; ++i) { 43 | y[i] = yad[i].value(); 44 | } 45 | } 46 | 47 | 48 | int main() { 49 | double x[N]; 50 | double y[N]; 51 | double J[N*N]; 52 | int rep, i, j; 53 | 54 | for (i = 0; i < N; ++i) { 55 | x[i] = 1.0 + i + 1; 56 | } 57 | 58 | for (rep = 0; rep < int(1e8/(N*N)); ++rep) { 59 | doit(x, y, J); 60 | } 61 | 62 | for (i = 0; i < 5; ++i) { 63 | std::cout << y[i] << std::endl; 64 | } 65 | for (i = 0; i < 5; ++i) { 66 | for (j = 0; j < 5; ++j) { 67 | std::cout << J[i + N*j] << " "; 68 | } 69 | std::cout << std::endl; 70 | } 71 | 72 | return 0; 73 | } 74 | -------------------------------------------------------------------------------- /examples/bench_simple_adolc.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define N 100 6 | #define FILLITER 10 7 | 8 | #ifdef ADOLC_TAPELESS 9 | #define NUMBER_DIRECTIONS N 10 | #ifdef OLD_TAPELESS 11 | #include 12 | #include 13 | typedef adtl::adouble adouble; 14 | ADOLC_TAPELESS_UNIQUE_INTERNALS; 15 | #else 16 | #include 17 | #include 18 | typedef adtl::adouble adouble; 19 | #endif 20 | #else 21 | #include 22 | #endif 23 | 24 | void laplacian(adouble x[N], adouble y[N]) 25 | { 26 | int i, p; 27 | y[0] = -2*x[0] + x[1]; 28 | y[N-1] = -2*x[N-1] + x[N-2]; 29 | for (i = 1; i < N-1; ++i) { 30 | y[i] = x[i-1] - 2*x[i] + x[i+1]; 31 | } 32 | for (p = 0; p < FILLITER; ++p) { 33 | for (i = 1; i < N-1; ++i) { 34 | y[i] = y[i-1] - 2*y[i] + y[i+1]/(3.1415+y[i]); 35 | } 36 | } 37 | } 38 | 39 | #ifdef ADOLC_TAPELESS 40 | void doit(double x[N], double y[N], double **J) 41 | { 42 | #ifndef OLD_TAPELESS 43 | adtl::setNumDir(N); 44 | #endif 45 | 46 | adouble xad[N], yad[N]; 47 | int i, j; 48 | 49 | for (i = 0; i < N; i++) { 50 | xad[i] = x[i]; 51 | xad[i].setADValue(i, 1); 52 | } 53 | laplacian(xad, yad); 54 | for (i = 0; i < N; i++) { 55 | y[i] = yad[i].getValue(); 56 | } 57 | for (i = 0; i < N; i++) { 58 | for (j = 0; j < N; j++) { 59 | J[i][j] = yad[i].getADValue(j); 60 | } 61 | } 62 | } 63 | #else 64 | void doit(double x[N], double y[N], double **J) 65 | { 66 | adouble xad[N], yad[N]; 67 | int i; 68 | 69 | trace_on(1); 70 | for (i = 0; i < N; i++) { 71 | xad[i] <<= x[i]; 72 | } 73 | laplacian(xad, yad); 74 | for (i = 0; i < N; i++) { 75 | yad[i] >>= y[i]; 76 | } 77 | trace_off(); 78 | 79 | jacobian(1, N, N, x, J); 80 | } 81 | #endif 82 | 83 | int main() { 84 | double x[N]; 85 | double y[N]; 86 | double **J; 87 | int rep, i, j; 88 | 89 | for (i = 0; i < N; ++i) { 90 | x[i] = 1.0 + i + 1; 91 | } 92 | 93 | J = myalloc2(N,N); 94 | 95 | for (rep = 0; rep < int(1e8/(N*N)); ++rep) { 96 | doit(x, y, J); 97 | } 98 | 99 | for (i = 0; i < 5; ++i) { 100 | for (j = 0; j < 5; ++j) { 101 | std::cout << J[i][j] << " "; 102 | } 103 | std::cout << std::endl; 104 | } 105 | 106 | return 0; 107 | } 108 | -------------------------------------------------------------------------------- /examples/bench_simple_cppad.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | #define N 100 7 | #define FILLITER 10 8 | 9 | #include 10 | 11 | using CppAD::AD; 12 | 13 | void laplacian(AD x[N], AD y[N]) 14 | { 15 | int i, p; 16 | y[0] = -2*x[0] + x[1]; 17 | y[N-1] = -2*x[N-1] + x[N-2]; 18 | for (i = 1; i < N-1; ++i) { 19 | y[i] = x[i-1] - 2*x[i] + x[i+1]; 20 | } 21 | for (p = 0; p < FILLITER; ++p) { 22 | for (i = 1; i < N-1; ++i) { 23 | y[i] = y[i-1] - 2*y[i] + y[i+1]/(3.1415+y[i]); 24 | } 25 | } 26 | } 27 | 28 | void doit(std::vector &x, std::vector &y, std::vector &J) 29 | { 30 | std::vector< AD > xad(N), yad(N); 31 | int i; 32 | 33 | for (i = 0; i < N; i++) { 34 | xad[i] = x[i]; 35 | } 36 | CppAD::Independent(xad); 37 | 38 | laplacian(xad.data(), yad.data()); 39 | 40 | CppAD::ADFun f(xad, yad); 41 | J = f.Jacobian(x); 42 | } 43 | 44 | int main() { 45 | std::vector x(N), y(N); 46 | std::vector J; 47 | int rep, i, j; 48 | 49 | for (i = 0; i < N; ++i) { 50 | x[i] = 1.0 + i + 1; 51 | } 52 | 53 | for (rep = 0; rep < 1 + int(1e8/(N*N)); ++rep) { 54 | doit(x, y, J); 55 | } 56 | 57 | for (i = 0; i < 5; ++i) { 58 | for (j = 0; j < 5; ++j) { 59 | std::cout << J[i*N + j] << " "; 60 | } 61 | std::cout << std::endl; 62 | } 63 | 64 | return 0; 65 | } 66 | -------------------------------------------------------------------------------- /examples/bench_simple_numdiff.f95: -------------------------------------------------------------------------------- 1 | program main 2 | use adjac 3 | 4 | integer, parameter :: n = 100, filliter = 10 5 | 6 | double precision :: xval(n), yval(n), J(n,n) 7 | integer :: rep, i 8 | 9 | do i = 1, n 10 | xval(i) = 1d0 + i 11 | end do 12 | 13 | do rep = 1, int(1e8/(n*n)) 14 | call doit(xval, yval, J) 15 | end do 16 | 17 | do i = 1, 5 18 | write(*,*) yval(i) 19 | end do 20 | do i = 1, 5 21 | write(*,*) real(J(i,1:5)) 22 | end do 23 | 24 | contains 25 | subroutine doit(xval, yval, J) 26 | implicit none 27 | double precision, intent(in) :: xval(n) 28 | double precision, intent(out) :: yval(n), J(n,n) 29 | double precision :: x(n), y(n) 30 | integer :: i 31 | double precision, parameter :: eps = 1d-7 32 | 33 | call laplacian(xval, yval) 34 | 35 | x = xval 36 | 37 | do i = 1, n 38 | x(i) = xval(i) + eps 39 | call laplacian(x, y) 40 | J(:,i) = (y - yval) / eps 41 | x(i) = xval(i) 42 | end do 43 | end subroutine doit 44 | 45 | subroutine laplacian(x, y) 46 | implicit none 47 | double precision, dimension(n), intent(in) :: x 48 | double precision, dimension(n), intent(out) :: y 49 | integer :: i, p 50 | 51 | y(1) = -2*x(1) + x(2) 52 | y(n) = -2*x(n) + x(n-1) 53 | do i = 2, n-1 54 | y(i) = x(i+1) - 2*x(i) + x(i-1) 55 | end do 56 | 57 | do p = 1, filliter 58 | do i = 2, n-1 59 | y(i) = y(i-1) - 2*y(i) + y(i+1)/(3.1415d0 + y(i)) 60 | end do 61 | end do 62 | 63 | end subroutine laplacian 64 | end program main 65 | -------------------------------------------------------------------------------- /examples/bench_simple_tapeless_adolc.cpp: -------------------------------------------------------------------------------- 1 | #define ADOLC_TAPELESS 2 | #include "bench_simple_adolc.cpp" 3 | -------------------------------------------------------------------------------- /examples/bench_sparse.f95: -------------------------------------------------------------------------------- 1 | program main 2 | use adjac 3 | 4 | integer, parameter :: blocksize = 128, n = blocksize*1000, filliter = 3 5 | 6 | double precision :: xval(n), yval(n) 7 | double precision, allocatable, dimension(:) :: jac_val 8 | integer, allocatable, dimension(:) :: jac_i, jac_j 9 | integer :: rep, i 10 | 11 | do i = 1, n 12 | xval(i) = 1d0 + i 13 | end do 14 | 15 | do rep = 1, 5 16 | if (rep > 1) then 17 | deallocate(jac_val, jac_i, jac_j) 18 | end if 19 | call doit(xval, yval, jac_val, jac_i, jac_j) 20 | end do 21 | 22 | write(*,*) 'nnz =', size(jac_val) 23 | write(*,*) 'sparsity =', (size(jac_val)*1d0)/(1d0*n)/(1d0*n) 24 | write(*,*) jac_val(1:5) 25 | write(*,*) jac_i(1:5) 26 | write(*,*) jac_j(1:5) 27 | 28 | contains 29 | subroutine doit(xval, yval, jac_val, jac_i, jac_j) 30 | implicit none 31 | double precision, intent(in) :: xval(n) 32 | double precision, intent(out) :: yval(n) 33 | type(adjac_double) :: x(n), y(n) 34 | double precision, allocatable, dimension(:), intent(inout) :: jac_val 35 | integer, allocatable, dimension(:), intent(inout) :: jac_i, jac_j 36 | integer :: nnz 37 | 38 | call adjac_reset() 39 | call adjac_set_independent(x, xval) 40 | call oper(x, y) 41 | 42 | call adjac_get_value(y, yval) 43 | call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j) 44 | end subroutine doit 45 | 46 | subroutine oper(x, y) 47 | implicit none 48 | type(adjac_double), dimension(n), intent(in) :: x 49 | type(adjac_double), dimension(n), intent(out) :: y 50 | integer :: i, k, p 51 | 52 | y(1) = -2*x(1) + x(2) 53 | y(n) = -2*x(n) + x(n-1) 54 | do i = 2, n-1 55 | y(i) = x(i+1) - 2*x(i) + x(i-1) 56 | end do 57 | 58 | do k = 1, n, blocksize 59 | do p = 1, filliter 60 | do i = k+1, k + blocksize-1 61 | y(i) = y(i-1) - 2*y(i) + y(i+1)/(3.1415d0 + y(i)) 62 | end do 63 | end do 64 | end do 65 | end subroutine oper 66 | end program main 67 | -------------------------------------------------------------------------------- /examples/bench_sparse_adolc.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #define BLOCKSIZE 128 6 | #define N (1000*BLOCKSIZE) 7 | #define FILLITER 3 8 | 9 | #include 10 | #include 11 | 12 | void laplacian(adouble x[N], adouble y[N]) 13 | { 14 | int i, p, k; 15 | y[0] = -2*x[0] + x[1]; 16 | y[N-1] = -2*x[N-1] + x[N-2]; 17 | for (i = 1; i < N-1; ++i) { 18 | y[i] = x[i-1] - 2*x[i] + x[i+1]; 19 | } 20 | for (k = 0; k < N; k += BLOCKSIZE) { 21 | for (p = 0; p < FILLITER; ++p) { 22 | for (i = k+1; i < k+BLOCKSIZE-1; ++i) { 23 | y[i] = y[i-1] - 2*y[i] + y[i+1]/(3.1415+y[i]); 24 | } 25 | } 26 | } 27 | } 28 | 29 | void doit(double x[N], double y[N], int *nnz, unsigned int **ii, unsigned int **jj, double **vv) 30 | { 31 | adouble xad[N], yad[N]; 32 | int options[4] = {0,0,0,0}; 33 | int i; 34 | 35 | trace_on(1); 36 | for (i = 0; i < N; i++) { 37 | xad[i] <<= x[i]; 38 | } 39 | laplacian(xad, yad); 40 | for (i = 0; i < N; i++) { 41 | yad[i] >>= y[i]; 42 | } 43 | trace_off(); 44 | 45 | options[0] = 0; 46 | sparse_jac(1, N, N, 0, x, nnz, ii, jj, vv, options); 47 | } 48 | 49 | int main() { 50 | double x[N]; 51 | double y[N]; 52 | 53 | int nnz; 54 | unsigned int *ii = NULL, *jj = NULL; 55 | double *vv = NULL; 56 | int rep, i, j; 57 | 58 | for (i = 0; i < N; ++i) { 59 | x[i] = 1.0 + i + 1; 60 | } 61 | 62 | for (rep = 0; rep < 5; ++rep) { 63 | free(ii); 64 | free(jj); 65 | free(vv); 66 | ii = NULL; 67 | jj = NULL; 68 | vv = NULL; 69 | doit(x, y, &nnz, &ii, &jj, &vv); 70 | } 71 | 72 | for (i = 0; i < 5; ++i) { 73 | std::cout << ii[i] << " "; 74 | } 75 | std::cout << std::endl; 76 | for (i = 0; i < 5; ++i) { 77 | std::cout << jj[i] << " "; 78 | } 79 | std::cout << std::endl; 80 | for (i = 0; i < 5; ++i) { 81 | std::cout << vv[i] << " "; 82 | } 83 | std::cout << std::endl; 84 | 85 | return 0; 86 | } 87 | -------------------------------------------------------------------------------- /examples/laplacian.f95: -------------------------------------------------------------------------------- 1 | ! 2 | ! Example: compute real-valued Laplacian 3 | ! 4 | program laplacian 5 | use adjac 6 | implicit none 7 | 8 | integer, parameter :: n = 5 9 | 10 | double precision, dimension(n) :: x_value 11 | double precision, dimension(n) :: y_value 12 | double precision, allocatable, dimension(:) :: jac_val 13 | integer, allocatable, dimension(:) :: jac_i, jac_j 14 | double precision, dimension(n,n) :: jac_dense 15 | 16 | type(adjac_double), dimension(n) :: x 17 | type(adjac_double), dimension(n) :: y 18 | integer :: j, nnz 19 | 20 | call adjac_reset() 21 | do j = 1, n 22 | x_value(j) = j-1 23 | end do 24 | call adjac_set_independent(x, x_value) 25 | 26 | ! Compute Laplacian 27 | y(1) = x(2) - 2*x(1) 28 | y(n) = x(n-1) - 2*x(n) 29 | do j = 2, n-1 30 | y(j) = x(j-1) - 2*x(j) + x(j+1) 31 | end do 32 | 33 | ! Obtain function value 34 | write(*,*) '-- values' 35 | call adjac_get_value(y, y_value) 36 | write(*,*) real(y_value) 37 | 38 | ! Obtain jacobian in dense format 39 | write(*,*) '-- dense laplacian' 40 | call adjac_get_dense_jacobian(y, jac_dense) 41 | do j = 1, n 42 | write(*,*) jac_dense(j,:) 43 | end do 44 | 45 | ! Obtain jacobian in sparse coordinate (i, j, value) format 46 | write(*,*) '-- COO laplacian' 47 | call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j) 48 | do j = 1, nnz 49 | write(*,*) jac_i(j), jac_j(j), real(jac_val(j)) 50 | end do 51 | 52 | call adjac_free() 53 | end program laplacian 54 | -------------------------------------------------------------------------------- /examples/simple.f95: -------------------------------------------------------------------------------- 1 | subroutine my_func(x, y) 2 | implicit none 3 | complex(kind=kind(0d0)), dimension(3), intent(in) :: x 4 | complex(kind=kind(0d0)), dimension(2), intent(out) :: y 5 | 6 | integer :: j 7 | do j = 1, 2 8 | y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2)) 9 | end do 10 | end subroutine my_func 11 | 12 | subroutine my_func_jac(x_value, y_value, dy_dx) 13 | use adjac 14 | implicit none 15 | complex(kind=kind(0d0)), dimension(3), intent(in) :: x_value 16 | complex(kind=kind(0d0)), dimension(2), intent(out) :: y_value 17 | complex(kind=kind(0d0)), dimension(2,3), intent(out) :: dy_dx 18 | 19 | type(adjac_complexan), dimension(3) :: x 20 | type(adjac_complexan), dimension(2) :: y 21 | integer :: j 22 | 23 | call adjac_reset() 24 | call adjac_set_independent(x, x_value) 25 | 26 | do j = 1, 2 27 | y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2)) 28 | end do 29 | 30 | call adjac_get_value(y, y_value) 31 | call adjac_get_dense_jacobian(y, dy_dx) 32 | call adjac_free() 33 | end subroutine my_func_jac 34 | 35 | program simple 36 | implicit none 37 | double precision, parameter :: dx = 1e-7 38 | 39 | complex(kind=kind(0d0)), dimension(3) :: x, x2 40 | complex(kind=kind(0d0)), dimension(2) :: y, y2 41 | complex(kind=kind(0d0)), dimension(2,3) :: dy_dx 42 | 43 | integer :: i 44 | 45 | do i = 1, 3 46 | x(i) = i + (0d0,1d0) * i**2 47 | end do 48 | 49 | ! Evaluate function values 50 | call my_func(x, y) 51 | write(*,*) '-- my_func:' 52 | write(*,*) y 53 | 54 | ! Find jacobian by numerical differentiation 55 | dy_dx = 0 56 | do i = 1, 3 57 | x2 = x 58 | x2(i) = x(i) + dx 59 | call my_func(x2, y2) 60 | dy_dx(:,i) = (y2 - y) / dx 61 | end do 62 | 63 | write(*,*) '-- Jacobian via numerical differentiation:' 64 | do i = 1, 2 65 | write(*,*) cmplx(dy_dx(i,:)) 66 | end do 67 | 68 | ! Get the same results via adjac 69 | dy_dx = 0 70 | call my_func_jac(x, y, dy_dx) 71 | write(*,*) '-- my_func_jac value:' 72 | write(*,*) y 73 | write(*,*) '-- my_func_jac Jacobian:' 74 | do i = 1, 2 75 | write(*,*) cmplx(dy_dx(i,:)) 76 | end do 77 | 78 | end program simple 79 | -------------------------------------------------------------------------------- /fftpack/zfftb1.f95: -------------------------------------------------------------------------------- 1 | !! NOTE: this file is autogenerated from zfftb1.f95.in: do not edit manually 2 | !***BEGIN PROLOGUE CFFTB1 3 | !***PURPOSE Compute the unnormalized inverse of CFFTF1. 4 | !***LIBRARY SLATEC (FFTPACK) 5 | !***CATEGORY J1A2 6 | !***TYPE COMPLEX (RFFTB1-S, CFFTB1-C) 7 | !***KEYWORDS FFTPACK, FOURIER TRANSFORM 8 | !***AUTHOR Swarztrauber, P. N., (NCAR) 9 | !***DESCRIPTION 10 | ! 11 | ! Subroutine CFFTB1 computes the backward complex discrete Fourier 12 | ! transform (the Fourier synthesis). Equivalently, CFFTB1 computes 13 | ! a complex periodic sequence from its Fourier coefficients. 14 | ! The transform is defined below at output parameter C. 15 | ! 16 | ! A call of CFFTF1 followed by a call of CFFTB1 will multiply the 17 | ! sequence by N. 18 | ! 19 | ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be 20 | ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). 21 | ! 22 | ! Input Parameters 23 | ! 24 | ! N the length of the complex sequence C. The method is 25 | ! more efficient when N is the product of small primes. 26 | ! 27 | ! C a complex array of length N which contains the sequence 28 | ! 29 | ! CH a real work array of length at least 2*N 30 | ! 31 | ! WA a real work array which must be dimensioned at least 2*N. 32 | ! 33 | ! IFAC an integer work array which must be dimensioned at least 15. 34 | ! 35 | ! The WA and IFAC arrays must be initialized by calling 36 | ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC 37 | ! arrays must be used for each different value of N. This 38 | ! initialization does not have to be repeated so long as N 39 | ! remains unchanged. Thus subsequent transforms can be 40 | ! obtained faster than the first. The same WA and IFAC arrays 41 | ! can be used by CFFTF1 and CFFTB1. 42 | ! 43 | ! Output Parameters 44 | ! 45 | ! C For J=1,...,N 46 | ! 47 | ! C(J)=the sum from K=1,...,N of 48 | ! 49 | ! C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) 50 | ! 51 | ! where I=SQRT(-1) 52 | ! 53 | ! NOTE: WA and IFAC contain initialization calculations which must 54 | ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 55 | ! 56 | !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel 57 | ! Computations (G. Rodrigue, ed.), Academic Press, 58 | ! 1982, pp. 51-83. 59 | !***ROUTINES CALLED PASSB, PASSB2, PASSB3, PASSB4, PASSB5 60 | !***REVISION HISTORY (YYMMDD) 61 | ! 790601 DATE WRITTEN 62 | ! 830401 Modified to use SLATEC library source file format. 63 | ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 64 | ! changing dummy array size declarations (1) to (*). 65 | ! 881128 Modified by Dick Valent to meet prologue standards. 66 | ! 891214 Prologue converted to Version 4.0 format. (BAB) 67 | ! 900131 Routine changed from subsidiary to user-callable. (WRB) 68 | ! 920501 Reformatted the REFERENCES section. (WRB) 69 | !***END PROLOGUE CFFTB1 70 | SUBROUTINE ZFFTB1a (N,C,CH,WA,IFAC) 71 | USE ADJAC 72 | IMPLICIT type(adjac_double) (A-H,O-Z) 73 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 74 | double precision wa 75 | NF = IFAC(2) 76 | NA = 0 77 | L1 = 1 78 | IW = 1 79 | DO 116 K1=1,NF 80 | IP = IFAC(K1+2) 81 | L2 = IP*L1 82 | IDO = N/L2 83 | IDOT = IDO+IDO 84 | IDL1 = IDOT*L1 85 | IF (IP .NE. 4) GO TO 103 86 | IX2 = IW+IDOT 87 | IX3 = IX2+IDOT 88 | IF (NA .NE. 0) GO TO 101 89 | CALL DPASSB4a (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 90 | GO TO 102 91 | 101 CALL DPASSB4a (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 92 | 102 NA = 1-NA 93 | GO TO 115 94 | 103 IF (IP .NE. 2) GO TO 106 95 | IF (NA .NE. 0) GO TO 104 96 | CALL DPASSB2a (IDOT,L1,C,CH,WA(IW)) 97 | GO TO 105 98 | 104 CALL DPASSB2a (IDOT,L1,CH,C,WA(IW)) 99 | 105 NA = 1-NA 100 | GO TO 115 101 | 106 IF (IP .NE. 3) GO TO 109 102 | IX2 = IW+IDOT 103 | IF (NA .NE. 0) GO TO 107 104 | CALL DPASSB3a (IDOT,L1,C,CH,WA(IW),WA(IX2)) 105 | GO TO 108 106 | 107 CALL DPASSB3a (IDOT,L1,CH,C,WA(IW),WA(IX2)) 107 | 108 NA = 1-NA 108 | GO TO 115 109 | 109 IF (IP .NE. 5) GO TO 112 110 | IX2 = IW+IDOT 111 | IX3 = IX2+IDOT 112 | IX4 = IX3+IDOT 113 | IF (NA .NE. 0) GO TO 110 114 | CALL DPASSB5a (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 115 | GO TO 111 116 | 110 CALL DPASSB5a (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 117 | 111 NA = 1-NA 118 | GO TO 115 119 | 112 IF (NA .NE. 0) GO TO 113 120 | CALL DPASSBa (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 121 | GO TO 114 122 | 113 CALL DPASSBa (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 123 | 114 IF (NAC .NE. 0) NA = 1-NA 124 | 115 L1 = L2 125 | IW = IW+(IP-1)*IDOT 126 | 116 CONTINUE 127 | IF (NA .EQ. 0) RETURN 128 | N2 = N+N 129 | DO 117 I=1,N2 130 | C(I) = CH(I) 131 | 117 CONTINUE 132 | RETURN 133 | END 134 | 135 | SUBROUTINE DPASSBa (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 136 | USE ADJAC 137 | IMPLICIT type(adjac_double) (A-H,O-Z) 138 | DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , & 139 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 140 | CH2(IDL1,IP) 141 | double precision wa, war, wai 142 | IDOT = IDO/2 143 | NT = IP*IDL1 144 | IPP2 = IP+2 145 | IPPH = (IP+1)/2 146 | IDP = IP*IDO 147 | ! 148 | IF (IDO .LT. L1) GO TO 106 149 | DO 103 J=2,IPPH 150 | JC = IPP2-J 151 | DO 102 K=1,L1 152 | DO 101 I=1,IDO 153 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 154 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 155 | 101 CONTINUE 156 | 102 CONTINUE 157 | 103 CONTINUE 158 | DO 105 K=1,L1 159 | DO 104 I=1,IDO 160 | CH(I,K,1) = CC(I,1,K) 161 | 104 CONTINUE 162 | 105 CONTINUE 163 | GO TO 112 164 | 106 DO 109 J=2,IPPH 165 | JC = IPP2-J 166 | DO 108 I=1,IDO 167 | DO 107 K=1,L1 168 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 169 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 170 | 107 CONTINUE 171 | 108 CONTINUE 172 | 109 CONTINUE 173 | DO 111 I=1,IDO 174 | DO 110 K=1,L1 175 | CH(I,K,1) = CC(I,1,K) 176 | 110 CONTINUE 177 | 111 CONTINUE 178 | 112 IDL = 2-IDO 179 | INC = 0 180 | DO 116 L=2,IPPH 181 | LC = IPP2-L 182 | IDL = IDL+IDO 183 | DO 113 IK=1,IDL1 184 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 185 | C2(IK,LC) = WA(IDL)*CH2(IK,IP) 186 | 113 CONTINUE 187 | IDLJ = IDL 188 | INC = INC+IDO 189 | DO 115 J=3,IPPH 190 | JC = IPP2-J 191 | IDLJ = IDLJ+INC 192 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 193 | WAR = WA(IDLJ-1) 194 | WAI = WA(IDLJ) 195 | DO 114 IK=1,IDL1 196 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 197 | C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 198 | 114 CONTINUE 199 | 115 CONTINUE 200 | 116 CONTINUE 201 | DO 118 J=2,IPPH 202 | DO 117 IK=1,IDL1 203 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 204 | 117 CONTINUE 205 | 118 CONTINUE 206 | DO 120 J=2,IPPH 207 | JC = IPP2-J 208 | DO 119 IK=2,IDL1,2 209 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 210 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 211 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 212 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 213 | 119 CONTINUE 214 | 120 CONTINUE 215 | NAC = 1 216 | IF (IDO .EQ. 2) RETURN 217 | NAC = 0 218 | DO 121 IK=1,IDL1 219 | C2(IK,1) = CH2(IK,1) 220 | 121 CONTINUE 221 | DO 123 J=2,IP 222 | DO 122 K=1,L1 223 | C1(1,K,J) = CH(1,K,J) 224 | C1(2,K,J) = CH(2,K,J) 225 | 122 CONTINUE 226 | 123 CONTINUE 227 | IF (IDOT .GT. L1) GO TO 127 228 | IDIJ = 0 229 | DO 126 J=2,IP 230 | IDIJ = IDIJ+2 231 | DO 125 I=4,IDO,2 232 | IDIJ = IDIJ+2 233 | DO 124 K=1,L1 234 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 235 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 236 | 124 CONTINUE 237 | 125 CONTINUE 238 | 126 CONTINUE 239 | RETURN 240 | 127 IDJ = 2-IDO 241 | DO 130 J=2,IP 242 | IDJ = IDJ+IDO 243 | DO 129 K=1,L1 244 | IDIJ = IDJ 245 | DO 128 I=4,IDO,2 246 | IDIJ = IDIJ+2 247 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 248 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 249 | 128 CONTINUE 250 | 129 CONTINUE 251 | 130 CONTINUE 252 | RETURN 253 | END 254 | 255 | SUBROUTINE DPASSB2a (IDO,L1,CC,CH,WA1) 256 | USE ADJAC 257 | IMPLICIT type(adjac_double) (A-H,O-Z) 258 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,& 259 | WA1(*) 260 | double precision wa1 261 | IF (IDO .GT. 2) GO TO 102 262 | DO 101 K=1,L1 263 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 264 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 265 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 266 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 267 | 101 CONTINUE 268 | RETURN 269 | 102 DO 104 K=1,L1 270 | DO 103 I=2,IDO,2 271 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 272 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 273 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 274 | TI2 = CC(I,1,K)-CC(I,2,K) 275 | CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 276 | CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 277 | 103 CONTINUE 278 | 104 CONTINUE 279 | RETURN 280 | END 281 | 282 | SUBROUTINE DPASSB3a (IDO,L1,CC,CH,WA1,WA2) 283 | USE ADJAC 284 | IMPLICIT type(adjac_double) (A-H,O-Z) 285 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,& 286 | WA1(*) ,WA2(*) 287 | double precision wa1, wa2,taur,taui 288 | ! *** TAUI IS SQRT(3)/2 *** 289 | DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ 290 | IF (IDO .NE. 2) GO TO 102 291 | DO 101 K=1,L1 292 | TR2 = CC(1,2,K)+CC(1,3,K) 293 | CR2 = CC(1,1,K)+TAUR*TR2 294 | CH(1,K,1) = CC(1,1,K)+TR2 295 | TI2 = CC(2,2,K)+CC(2,3,K) 296 | CI2 = CC(2,1,K)+TAUR*TI2 297 | CH(2,K,1) = CC(2,1,K)+TI2 298 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 299 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 300 | CH(1,K,2) = CR2-CI3 301 | CH(1,K,3) = CR2+CI3 302 | CH(2,K,2) = CI2+CR3 303 | CH(2,K,3) = CI2-CR3 304 | 101 CONTINUE 305 | RETURN 306 | 102 DO 104 K=1,L1 307 | DO 103 I=2,IDO,2 308 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 309 | CR2 = CC(I-1,1,K)+TAUR*TR2 310 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 311 | TI2 = CC(I,2,K)+CC(I,3,K) 312 | CI2 = CC(I,1,K)+TAUR*TI2 313 | CH(I,K,1) = CC(I,1,K)+TI2 314 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 315 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 316 | DR2 = CR2-CI3 317 | DR3 = CR2+CI3 318 | DI2 = CI2+CR3 319 | DI3 = CI2-CR3 320 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 321 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 322 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 323 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 324 | 103 CONTINUE 325 | 104 CONTINUE 326 | RETURN 327 | END 328 | 329 | 330 | SUBROUTINE DPASSB4a (IDO,L1,CC,CH,WA1,WA2,WA3) 331 | USE ADJAC 332 | IMPLICIT type(adjac_double) (A-H,O-Z) 333 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 334 | WA1(*) ,WA2(*) ,WA3(*) 335 | double precision wa1, wa2, wa3 336 | IF (IDO .NE. 2) GO TO 102 337 | DO 101 K=1,L1 338 | TI1 = CC(2,1,K)-CC(2,3,K) 339 | TI2 = CC(2,1,K)+CC(2,3,K) 340 | TR4 = CC(2,4,K)-CC(2,2,K) 341 | TI3 = CC(2,2,K)+CC(2,4,K) 342 | TR1 = CC(1,1,K)-CC(1,3,K) 343 | TR2 = CC(1,1,K)+CC(1,3,K) 344 | TI4 = CC(1,2,K)-CC(1,4,K) 345 | TR3 = CC(1,2,K)+CC(1,4,K) 346 | CH(1,K,1) = TR2+TR3 347 | CH(1,K,3) = TR2-TR3 348 | CH(2,K,1) = TI2+TI3 349 | CH(2,K,3) = TI2-TI3 350 | CH(1,K,2) = TR1+TR4 351 | CH(1,K,4) = TR1-TR4 352 | CH(2,K,2) = TI1+TI4 353 | CH(2,K,4) = TI1-TI4 354 | 101 CONTINUE 355 | RETURN 356 | 102 DO 104 K=1,L1 357 | DO 103 I=2,IDO,2 358 | TI1 = CC(I,1,K)-CC(I,3,K) 359 | TI2 = CC(I,1,K)+CC(I,3,K) 360 | TI3 = CC(I,2,K)+CC(I,4,K) 361 | TR4 = CC(I,4,K)-CC(I,2,K) 362 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 363 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 364 | TI4 = CC(I-1,2,K)-CC(I-1,4,K) 365 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 366 | CH(I-1,K,1) = TR2+TR3 367 | CR3 = TR2-TR3 368 | CH(I,K,1) = TI2+TI3 369 | CI3 = TI2-TI3 370 | CR2 = TR1+TR4 371 | CR4 = TR1-TR4 372 | CI2 = TI1+TI4 373 | CI4 = TI1-TI4 374 | CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 375 | CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 376 | CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 377 | CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 378 | CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 379 | CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 380 | 103 CONTINUE 381 | 104 CONTINUE 382 | RETURN 383 | END 384 | 385 | SUBROUTINE DPASSB5a (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 386 | USE ADJAC 387 | IMPLICIT type(adjac_double) (A-H,O-Z) 388 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,& 389 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 390 | double precision wa1, wa2, wa3, wa4, tr11, ti11, tr12, ti12 391 | ! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) 392 | ! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) 393 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 394 | 0.95105651629515357212D0, & 395 | -0.8090169943749474241D0,0.58778525229247312917D0/ 396 | IF (IDO .NE. 2) GO TO 102 397 | DO 101 K=1,L1 398 | TI5 = CC(2,2,K)-CC(2,5,K) 399 | TI2 = CC(2,2,K)+CC(2,5,K) 400 | TI4 = CC(2,3,K)-CC(2,4,K) 401 | TI3 = CC(2,3,K)+CC(2,4,K) 402 | TR5 = CC(1,2,K)-CC(1,5,K) 403 | TR2 = CC(1,2,K)+CC(1,5,K) 404 | TR4 = CC(1,3,K)-CC(1,4,K) 405 | TR3 = CC(1,3,K)+CC(1,4,K) 406 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 407 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 408 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 409 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 410 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 411 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 412 | CR5 = TI11*TR5+TI12*TR4 413 | CI5 = TI11*TI5+TI12*TI4 414 | CR4 = TI12*TR5-TI11*TR4 415 | CI4 = TI12*TI5-TI11*TI4 416 | CH(1,K,2) = CR2-CI5 417 | CH(1,K,5) = CR2+CI5 418 | CH(2,K,2) = CI2+CR5 419 | CH(2,K,3) = CI3+CR4 420 | CH(1,K,3) = CR3-CI4 421 | CH(1,K,4) = CR3+CI4 422 | CH(2,K,4) = CI3-CR4 423 | CH(2,K,5) = CI2-CR5 424 | 101 CONTINUE 425 | RETURN 426 | 102 DO 104 K=1,L1 427 | DO 103 I=2,IDO,2 428 | TI5 = CC(I,2,K)-CC(I,5,K) 429 | TI2 = CC(I,2,K)+CC(I,5,K) 430 | TI4 = CC(I,3,K)-CC(I,4,K) 431 | TI3 = CC(I,3,K)+CC(I,4,K) 432 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 433 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 434 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 435 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 436 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 437 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 438 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 439 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 440 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 441 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 442 | CR5 = TI11*TR5+TI12*TR4 443 | CI5 = TI11*TI5+TI12*TI4 444 | CR4 = TI12*TR5-TI11*TR4 445 | CI4 = TI12*TI5-TI11*TI4 446 | DR3 = CR3-CI4 447 | DR4 = CR3+CI4 448 | DI3 = CI3+CR4 449 | DI4 = CI3-CR4 450 | DR5 = CR2+CI5 451 | DR2 = CR2-CI5 452 | DI5 = CI2-CR5 453 | DI2 = CI2+CR5 454 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 455 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 456 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 457 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 458 | CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 459 | CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 460 | CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 461 | CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 462 | 103 CONTINUE 463 | 104 CONTINUE 464 | RETURN 465 | END 466 | SUBROUTINE ZFFTB1d (N,C,CH,WA,IFAC) 467 | USE ADJAC 468 | IMPLICIT double precision (A-H,O-Z) 469 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 470 | double precision wa 471 | NF = IFAC(2) 472 | NA = 0 473 | L1 = 1 474 | IW = 1 475 | DO 116 K1=1,NF 476 | IP = IFAC(K1+2) 477 | L2 = IP*L1 478 | IDO = N/L2 479 | IDOT = IDO+IDO 480 | IDL1 = IDOT*L1 481 | IF (IP .NE. 4) GO TO 103 482 | IX2 = IW+IDOT 483 | IX3 = IX2+IDOT 484 | IF (NA .NE. 0) GO TO 101 485 | CALL DPASSB4d (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 486 | GO TO 102 487 | 101 CALL DPASSB4d (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 488 | 102 NA = 1-NA 489 | GO TO 115 490 | 103 IF (IP .NE. 2) GO TO 106 491 | IF (NA .NE. 0) GO TO 104 492 | CALL DPASSB2d (IDOT,L1,C,CH,WA(IW)) 493 | GO TO 105 494 | 104 CALL DPASSB2d (IDOT,L1,CH,C,WA(IW)) 495 | 105 NA = 1-NA 496 | GO TO 115 497 | 106 IF (IP .NE. 3) GO TO 109 498 | IX2 = IW+IDOT 499 | IF (NA .NE. 0) GO TO 107 500 | CALL DPASSB3d (IDOT,L1,C,CH,WA(IW),WA(IX2)) 501 | GO TO 108 502 | 107 CALL DPASSB3d (IDOT,L1,CH,C,WA(IW),WA(IX2)) 503 | 108 NA = 1-NA 504 | GO TO 115 505 | 109 IF (IP .NE. 5) GO TO 112 506 | IX2 = IW+IDOT 507 | IX3 = IX2+IDOT 508 | IX4 = IX3+IDOT 509 | IF (NA .NE. 0) GO TO 110 510 | CALL DPASSB5d (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 511 | GO TO 111 512 | 110 CALL DPASSB5d (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 513 | 111 NA = 1-NA 514 | GO TO 115 515 | 112 IF (NA .NE. 0) GO TO 113 516 | CALL DPASSBd (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 517 | GO TO 114 518 | 113 CALL DPASSBd (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 519 | 114 IF (NAC .NE. 0) NA = 1-NA 520 | 115 L1 = L2 521 | IW = IW+(IP-1)*IDOT 522 | 116 CONTINUE 523 | IF (NA .EQ. 0) RETURN 524 | N2 = N+N 525 | DO 117 I=1,N2 526 | C(I) = CH(I) 527 | 117 CONTINUE 528 | RETURN 529 | END 530 | 531 | SUBROUTINE DPASSBd (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 532 | USE ADJAC 533 | IMPLICIT double precision (A-H,O-Z) 534 | DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , & 535 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 536 | CH2(IDL1,IP) 537 | double precision wa, war, wai 538 | IDOT = IDO/2 539 | NT = IP*IDL1 540 | IPP2 = IP+2 541 | IPPH = (IP+1)/2 542 | IDP = IP*IDO 543 | ! 544 | IF (IDO .LT. L1) GO TO 106 545 | DO 103 J=2,IPPH 546 | JC = IPP2-J 547 | DO 102 K=1,L1 548 | DO 101 I=1,IDO 549 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 550 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 551 | 101 CONTINUE 552 | 102 CONTINUE 553 | 103 CONTINUE 554 | DO 105 K=1,L1 555 | DO 104 I=1,IDO 556 | CH(I,K,1) = CC(I,1,K) 557 | 104 CONTINUE 558 | 105 CONTINUE 559 | GO TO 112 560 | 106 DO 109 J=2,IPPH 561 | JC = IPP2-J 562 | DO 108 I=1,IDO 563 | DO 107 K=1,L1 564 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 565 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 566 | 107 CONTINUE 567 | 108 CONTINUE 568 | 109 CONTINUE 569 | DO 111 I=1,IDO 570 | DO 110 K=1,L1 571 | CH(I,K,1) = CC(I,1,K) 572 | 110 CONTINUE 573 | 111 CONTINUE 574 | 112 IDL = 2-IDO 575 | INC = 0 576 | DO 116 L=2,IPPH 577 | LC = IPP2-L 578 | IDL = IDL+IDO 579 | DO 113 IK=1,IDL1 580 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 581 | C2(IK,LC) = WA(IDL)*CH2(IK,IP) 582 | 113 CONTINUE 583 | IDLJ = IDL 584 | INC = INC+IDO 585 | DO 115 J=3,IPPH 586 | JC = IPP2-J 587 | IDLJ = IDLJ+INC 588 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 589 | WAR = WA(IDLJ-1) 590 | WAI = WA(IDLJ) 591 | DO 114 IK=1,IDL1 592 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 593 | C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 594 | 114 CONTINUE 595 | 115 CONTINUE 596 | 116 CONTINUE 597 | DO 118 J=2,IPPH 598 | DO 117 IK=1,IDL1 599 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 600 | 117 CONTINUE 601 | 118 CONTINUE 602 | DO 120 J=2,IPPH 603 | JC = IPP2-J 604 | DO 119 IK=2,IDL1,2 605 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 606 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 607 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 608 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 609 | 119 CONTINUE 610 | 120 CONTINUE 611 | NAC = 1 612 | IF (IDO .EQ. 2) RETURN 613 | NAC = 0 614 | DO 121 IK=1,IDL1 615 | C2(IK,1) = CH2(IK,1) 616 | 121 CONTINUE 617 | DO 123 J=2,IP 618 | DO 122 K=1,L1 619 | C1(1,K,J) = CH(1,K,J) 620 | C1(2,K,J) = CH(2,K,J) 621 | 122 CONTINUE 622 | 123 CONTINUE 623 | IF (IDOT .GT. L1) GO TO 127 624 | IDIJ = 0 625 | DO 126 J=2,IP 626 | IDIJ = IDIJ+2 627 | DO 125 I=4,IDO,2 628 | IDIJ = IDIJ+2 629 | DO 124 K=1,L1 630 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 631 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 632 | 124 CONTINUE 633 | 125 CONTINUE 634 | 126 CONTINUE 635 | RETURN 636 | 127 IDJ = 2-IDO 637 | DO 130 J=2,IP 638 | IDJ = IDJ+IDO 639 | DO 129 K=1,L1 640 | IDIJ = IDJ 641 | DO 128 I=4,IDO,2 642 | IDIJ = IDIJ+2 643 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 644 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 645 | 128 CONTINUE 646 | 129 CONTINUE 647 | 130 CONTINUE 648 | RETURN 649 | END 650 | 651 | SUBROUTINE DPASSB2d (IDO,L1,CC,CH,WA1) 652 | USE ADJAC 653 | IMPLICIT double precision (A-H,O-Z) 654 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,& 655 | WA1(*) 656 | double precision wa1 657 | IF (IDO .GT. 2) GO TO 102 658 | DO 101 K=1,L1 659 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 660 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 661 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 662 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 663 | 101 CONTINUE 664 | RETURN 665 | 102 DO 104 K=1,L1 666 | DO 103 I=2,IDO,2 667 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 668 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 669 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 670 | TI2 = CC(I,1,K)-CC(I,2,K) 671 | CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 672 | CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 673 | 103 CONTINUE 674 | 104 CONTINUE 675 | RETURN 676 | END 677 | 678 | SUBROUTINE DPASSB3d (IDO,L1,CC,CH,WA1,WA2) 679 | USE ADJAC 680 | IMPLICIT double precision (A-H,O-Z) 681 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,& 682 | WA1(*) ,WA2(*) 683 | double precision wa1, wa2,taur,taui 684 | ! *** TAUI IS SQRT(3)/2 *** 685 | DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ 686 | IF (IDO .NE. 2) GO TO 102 687 | DO 101 K=1,L1 688 | TR2 = CC(1,2,K)+CC(1,3,K) 689 | CR2 = CC(1,1,K)+TAUR*TR2 690 | CH(1,K,1) = CC(1,1,K)+TR2 691 | TI2 = CC(2,2,K)+CC(2,3,K) 692 | CI2 = CC(2,1,K)+TAUR*TI2 693 | CH(2,K,1) = CC(2,1,K)+TI2 694 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 695 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 696 | CH(1,K,2) = CR2-CI3 697 | CH(1,K,3) = CR2+CI3 698 | CH(2,K,2) = CI2+CR3 699 | CH(2,K,3) = CI2-CR3 700 | 101 CONTINUE 701 | RETURN 702 | 102 DO 104 K=1,L1 703 | DO 103 I=2,IDO,2 704 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 705 | CR2 = CC(I-1,1,K)+TAUR*TR2 706 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 707 | TI2 = CC(I,2,K)+CC(I,3,K) 708 | CI2 = CC(I,1,K)+TAUR*TI2 709 | CH(I,K,1) = CC(I,1,K)+TI2 710 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 711 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 712 | DR2 = CR2-CI3 713 | DR3 = CR2+CI3 714 | DI2 = CI2+CR3 715 | DI3 = CI2-CR3 716 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 717 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 718 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 719 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 720 | 103 CONTINUE 721 | 104 CONTINUE 722 | RETURN 723 | END 724 | 725 | 726 | SUBROUTINE DPASSB4d (IDO,L1,CC,CH,WA1,WA2,WA3) 727 | USE ADJAC 728 | IMPLICIT double precision (A-H,O-Z) 729 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 730 | WA1(*) ,WA2(*) ,WA3(*) 731 | double precision wa1, wa2, wa3 732 | IF (IDO .NE. 2) GO TO 102 733 | DO 101 K=1,L1 734 | TI1 = CC(2,1,K)-CC(2,3,K) 735 | TI2 = CC(2,1,K)+CC(2,3,K) 736 | TR4 = CC(2,4,K)-CC(2,2,K) 737 | TI3 = CC(2,2,K)+CC(2,4,K) 738 | TR1 = CC(1,1,K)-CC(1,3,K) 739 | TR2 = CC(1,1,K)+CC(1,3,K) 740 | TI4 = CC(1,2,K)-CC(1,4,K) 741 | TR3 = CC(1,2,K)+CC(1,4,K) 742 | CH(1,K,1) = TR2+TR3 743 | CH(1,K,3) = TR2-TR3 744 | CH(2,K,1) = TI2+TI3 745 | CH(2,K,3) = TI2-TI3 746 | CH(1,K,2) = TR1+TR4 747 | CH(1,K,4) = TR1-TR4 748 | CH(2,K,2) = TI1+TI4 749 | CH(2,K,4) = TI1-TI4 750 | 101 CONTINUE 751 | RETURN 752 | 102 DO 104 K=1,L1 753 | DO 103 I=2,IDO,2 754 | TI1 = CC(I,1,K)-CC(I,3,K) 755 | TI2 = CC(I,1,K)+CC(I,3,K) 756 | TI3 = CC(I,2,K)+CC(I,4,K) 757 | TR4 = CC(I,4,K)-CC(I,2,K) 758 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 759 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 760 | TI4 = CC(I-1,2,K)-CC(I-1,4,K) 761 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 762 | CH(I-1,K,1) = TR2+TR3 763 | CR3 = TR2-TR3 764 | CH(I,K,1) = TI2+TI3 765 | CI3 = TI2-TI3 766 | CR2 = TR1+TR4 767 | CR4 = TR1-TR4 768 | CI2 = TI1+TI4 769 | CI4 = TI1-TI4 770 | CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 771 | CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 772 | CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 773 | CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 774 | CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 775 | CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 776 | 103 CONTINUE 777 | 104 CONTINUE 778 | RETURN 779 | END 780 | 781 | SUBROUTINE DPASSB5d (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 782 | USE ADJAC 783 | IMPLICIT double precision (A-H,O-Z) 784 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,& 785 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 786 | double precision wa1, wa2, wa3, wa4, tr11, ti11, tr12, ti12 787 | ! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) 788 | ! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) 789 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 790 | 0.95105651629515357212D0, & 791 | -0.8090169943749474241D0,0.58778525229247312917D0/ 792 | IF (IDO .NE. 2) GO TO 102 793 | DO 101 K=1,L1 794 | TI5 = CC(2,2,K)-CC(2,5,K) 795 | TI2 = CC(2,2,K)+CC(2,5,K) 796 | TI4 = CC(2,3,K)-CC(2,4,K) 797 | TI3 = CC(2,3,K)+CC(2,4,K) 798 | TR5 = CC(1,2,K)-CC(1,5,K) 799 | TR2 = CC(1,2,K)+CC(1,5,K) 800 | TR4 = CC(1,3,K)-CC(1,4,K) 801 | TR3 = CC(1,3,K)+CC(1,4,K) 802 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 803 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 804 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 805 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 806 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 807 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 808 | CR5 = TI11*TR5+TI12*TR4 809 | CI5 = TI11*TI5+TI12*TI4 810 | CR4 = TI12*TR5-TI11*TR4 811 | CI4 = TI12*TI5-TI11*TI4 812 | CH(1,K,2) = CR2-CI5 813 | CH(1,K,5) = CR2+CI5 814 | CH(2,K,2) = CI2+CR5 815 | CH(2,K,3) = CI3+CR4 816 | CH(1,K,3) = CR3-CI4 817 | CH(1,K,4) = CR3+CI4 818 | CH(2,K,4) = CI3-CR4 819 | CH(2,K,5) = CI2-CR5 820 | 101 CONTINUE 821 | RETURN 822 | 102 DO 104 K=1,L1 823 | DO 103 I=2,IDO,2 824 | TI5 = CC(I,2,K)-CC(I,5,K) 825 | TI2 = CC(I,2,K)+CC(I,5,K) 826 | TI4 = CC(I,3,K)-CC(I,4,K) 827 | TI3 = CC(I,3,K)+CC(I,4,K) 828 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 829 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 830 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 831 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 832 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 833 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 834 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 835 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 836 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 837 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 838 | CR5 = TI11*TR5+TI12*TR4 839 | CI5 = TI11*TI5+TI12*TI4 840 | CR4 = TI12*TR5-TI11*TR4 841 | CI4 = TI12*TI5-TI11*TI4 842 | DR3 = CR3-CI4 843 | DR4 = CR3+CI4 844 | DI3 = CI3+CR4 845 | DI4 = CI3-CR4 846 | DR5 = CR2+CI5 847 | DR2 = CR2-CI5 848 | DI5 = CI2-CR5 849 | DI2 = CI2+CR5 850 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 851 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 852 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 853 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 854 | CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 855 | CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 856 | CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 857 | CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 858 | 103 CONTINUE 859 | 104 CONTINUE 860 | RETURN 861 | END 862 | -------------------------------------------------------------------------------- /fftpack/zfftb1.f95.in: -------------------------------------------------------------------------------- 1 | !***BEGIN PROLOGUE CFFTB1 2 | !***PURPOSE Compute the unnormalized inverse of CFFTF1. 3 | !***LIBRARY SLATEC (FFTPACK) 4 | !***CATEGORY J1A2 5 | !***TYPE COMPLEX (RFFTB1-S, CFFTB1-C) 6 | !***KEYWORDS FFTPACK, FOURIER TRANSFORM 7 | !***AUTHOR Swarztrauber, P. N., (NCAR) 8 | !***DESCRIPTION 9 | ! 10 | ! Subroutine CFFTB1 computes the backward complex discrete Fourier 11 | ! transform (the Fourier synthesis). Equivalently, CFFTB1 computes 12 | ! a complex periodic sequence from its Fourier coefficients. 13 | ! The transform is defined below at output parameter C. 14 | ! 15 | ! A call of CFFTF1 followed by a call of CFFTB1 will multiply the 16 | ! sequence by N. 17 | ! 18 | ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be 19 | ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). 20 | ! 21 | ! Input Parameters 22 | ! 23 | ! N the length of the complex sequence C. The method is 24 | ! more efficient when N is the product of small primes. 25 | ! 26 | ! C a complex array of length N which contains the sequence 27 | ! 28 | ! CH a real work array of length at least 2*N 29 | ! 30 | ! WA a real work array which must be dimensioned at least 2*N. 31 | ! 32 | ! IFAC an integer work array which must be dimensioned at least 15. 33 | ! 34 | ! The WA and IFAC arrays must be initialized by calling 35 | ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC 36 | ! arrays must be used for each different value of N. This 37 | ! initialization does not have to be repeated so long as N 38 | ! remains unchanged. Thus subsequent transforms can be 39 | ! obtained faster than the first. The same WA and IFAC arrays 40 | ! can be used by CFFTF1 and CFFTB1. 41 | ! 42 | ! Output Parameters 43 | ! 44 | ! C For J=1,...,N 45 | ! 46 | ! C(J)=the sum from K=1,...,N of 47 | ! 48 | ! C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) 49 | ! 50 | ! where I=SQRT(-1) 51 | ! 52 | ! NOTE: WA and IFAC contain initialization calculations which must 53 | ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 54 | ! 55 | !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel 56 | ! Computations (G. Rodrigue, ed.), Academic Press, 57 | ! 1982, pp. 51-83. 58 | !***ROUTINES CALLED PASSB, PASSB2, PASSB3, PASSB4, PASSB5 59 | !***REVISION HISTORY (YYMMDD) 60 | ! 790601 DATE WRITTEN 61 | ! 830401 Modified to use SLATEC library source file format. 62 | ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 63 | ! changing dummy array size declarations (1) to (*). 64 | ! 881128 Modified by Dick Valent to meet prologue standards. 65 | ! 891214 Prologue converted to Version 4.0 format. (BAB) 66 | ! 900131 Routine changed from subsidiary to user-callable. (WRB) 67 | ! 920501 Reformatted the REFERENCES section. (WRB) 68 | !***END PROLOGUE CFFTB1 69 | {{for TYPE, SUF in [('type(adjac_double)', 'a'), 70 | ('double precision', 'd')]}} 71 | SUBROUTINE ZFFTB1{{SUF}} (N,C,CH,WA,IFAC) 72 | USE ADJAC 73 | IMPLICIT {{TYPE}} (A-H,O-Z) 74 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 75 | double precision wa 76 | NF = IFAC(2) 77 | NA = 0 78 | L1 = 1 79 | IW = 1 80 | DO 116 K1=1,NF 81 | IP = IFAC(K1+2) 82 | L2 = IP*L1 83 | IDO = N/L2 84 | IDOT = IDO+IDO 85 | IDL1 = IDOT*L1 86 | IF (IP .NE. 4) GO TO 103 87 | IX2 = IW+IDOT 88 | IX3 = IX2+IDOT 89 | IF (NA .NE. 0) GO TO 101 90 | CALL DPASSB4{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 91 | GO TO 102 92 | 101 CALL DPASSB4{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 93 | 102 NA = 1-NA 94 | GO TO 115 95 | 103 IF (IP .NE. 2) GO TO 106 96 | IF (NA .NE. 0) GO TO 104 97 | CALL DPASSB2{{SUF}} (IDOT,L1,C,CH,WA(IW)) 98 | GO TO 105 99 | 104 CALL DPASSB2{{SUF}} (IDOT,L1,CH,C,WA(IW)) 100 | 105 NA = 1-NA 101 | GO TO 115 102 | 106 IF (IP .NE. 3) GO TO 109 103 | IX2 = IW+IDOT 104 | IF (NA .NE. 0) GO TO 107 105 | CALL DPASSB3{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2)) 106 | GO TO 108 107 | 107 CALL DPASSB3{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 | 108 NA = 1-NA 109 | GO TO 115 110 | 109 IF (IP .NE. 5) GO TO 112 111 | IX2 = IW+IDOT 112 | IX3 = IX2+IDOT 113 | IX4 = IX3+IDOT 114 | IF (NA .NE. 0) GO TO 110 115 | CALL DPASSB5{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 116 | GO TO 111 117 | 110 CALL DPASSB5{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 118 | 111 NA = 1-NA 119 | GO TO 115 120 | 112 IF (NA .NE. 0) GO TO 113 121 | CALL DPASSB{{SUF}} (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 122 | GO TO 114 123 | 113 CALL DPASSB{{SUF}} (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 124 | 114 IF (NAC .NE. 0) NA = 1-NA 125 | 115 L1 = L2 126 | IW = IW+(IP-1)*IDOT 127 | 116 CONTINUE 128 | IF (NA .EQ. 0) RETURN 129 | N2 = N+N 130 | DO 117 I=1,N2 131 | C(I) = CH(I) 132 | 117 CONTINUE 133 | RETURN 134 | END 135 | 136 | SUBROUTINE DPASSB{{SUF}} (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 137 | USE ADJAC 138 | IMPLICIT {{TYPE}} (A-H,O-Z) 139 | DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , & 140 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 141 | CH2(IDL1,IP) 142 | double precision wa, war, wai 143 | IDOT = IDO/2 144 | NT = IP*IDL1 145 | IPP2 = IP+2 146 | IPPH = (IP+1)/2 147 | IDP = IP*IDO 148 | ! 149 | IF (IDO .LT. L1) GO TO 106 150 | DO 103 J=2,IPPH 151 | JC = IPP2-J 152 | DO 102 K=1,L1 153 | DO 101 I=1,IDO 154 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 155 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 156 | 101 CONTINUE 157 | 102 CONTINUE 158 | 103 CONTINUE 159 | DO 105 K=1,L1 160 | DO 104 I=1,IDO 161 | CH(I,K,1) = CC(I,1,K) 162 | 104 CONTINUE 163 | 105 CONTINUE 164 | GO TO 112 165 | 106 DO 109 J=2,IPPH 166 | JC = IPP2-J 167 | DO 108 I=1,IDO 168 | DO 107 K=1,L1 169 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 170 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 171 | 107 CONTINUE 172 | 108 CONTINUE 173 | 109 CONTINUE 174 | DO 111 I=1,IDO 175 | DO 110 K=1,L1 176 | CH(I,K,1) = CC(I,1,K) 177 | 110 CONTINUE 178 | 111 CONTINUE 179 | 112 IDL = 2-IDO 180 | INC = 0 181 | DO 116 L=2,IPPH 182 | LC = IPP2-L 183 | IDL = IDL+IDO 184 | DO 113 IK=1,IDL1 185 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 186 | C2(IK,LC) = WA(IDL)*CH2(IK,IP) 187 | 113 CONTINUE 188 | IDLJ = IDL 189 | INC = INC+IDO 190 | DO 115 J=3,IPPH 191 | JC = IPP2-J 192 | IDLJ = IDLJ+INC 193 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 194 | WAR = WA(IDLJ-1) 195 | WAI = WA(IDLJ) 196 | DO 114 IK=1,IDL1 197 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 198 | C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 199 | 114 CONTINUE 200 | 115 CONTINUE 201 | 116 CONTINUE 202 | DO 118 J=2,IPPH 203 | DO 117 IK=1,IDL1 204 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 205 | 117 CONTINUE 206 | 118 CONTINUE 207 | DO 120 J=2,IPPH 208 | JC = IPP2-J 209 | DO 119 IK=2,IDL1,2 210 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 211 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 212 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 213 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 214 | 119 CONTINUE 215 | 120 CONTINUE 216 | NAC = 1 217 | IF (IDO .EQ. 2) RETURN 218 | NAC = 0 219 | DO 121 IK=1,IDL1 220 | C2(IK,1) = CH2(IK,1) 221 | 121 CONTINUE 222 | DO 123 J=2,IP 223 | DO 122 K=1,L1 224 | C1(1,K,J) = CH(1,K,J) 225 | C1(2,K,J) = CH(2,K,J) 226 | 122 CONTINUE 227 | 123 CONTINUE 228 | IF (IDOT .GT. L1) GO TO 127 229 | IDIJ = 0 230 | DO 126 J=2,IP 231 | IDIJ = IDIJ+2 232 | DO 125 I=4,IDO,2 233 | IDIJ = IDIJ+2 234 | DO 124 K=1,L1 235 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 236 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 237 | 124 CONTINUE 238 | 125 CONTINUE 239 | 126 CONTINUE 240 | RETURN 241 | 127 IDJ = 2-IDO 242 | DO 130 J=2,IP 243 | IDJ = IDJ+IDO 244 | DO 129 K=1,L1 245 | IDIJ = IDJ 246 | DO 128 I=4,IDO,2 247 | IDIJ = IDIJ+2 248 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) 249 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 250 | 128 CONTINUE 251 | 129 CONTINUE 252 | 130 CONTINUE 253 | RETURN 254 | END 255 | 256 | SUBROUTINE DPASSB2{{SUF}} (IDO,L1,CC,CH,WA1) 257 | USE ADJAC 258 | IMPLICIT {{TYPE}} (A-H,O-Z) 259 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) ,& 260 | WA1(*) 261 | double precision wa1 262 | IF (IDO .GT. 2) GO TO 102 263 | DO 101 K=1,L1 264 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 265 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 266 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 267 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 268 | 101 CONTINUE 269 | RETURN 270 | 102 DO 104 K=1,L1 271 | DO 103 I=2,IDO,2 272 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 273 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 274 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 275 | TI2 = CC(I,1,K)-CC(I,2,K) 276 | CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 277 | CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 278 | 103 CONTINUE 279 | 104 CONTINUE 280 | RETURN 281 | END 282 | 283 | SUBROUTINE DPASSB3{{SUF}} (IDO,L1,CC,CH,WA1,WA2) 284 | USE ADJAC 285 | IMPLICIT {{TYPE}} (A-H,O-Z) 286 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) ,& 287 | WA1(*) ,WA2(*) 288 | double precision wa1, wa2,taur,taui 289 | ! *** TAUI IS SQRT(3)/2 *** 290 | DATA TAUR,TAUI /-0.5D0,0.86602540378443864676D0/ 291 | IF (IDO .NE. 2) GO TO 102 292 | DO 101 K=1,L1 293 | TR2 = CC(1,2,K)+CC(1,3,K) 294 | CR2 = CC(1,1,K)+TAUR*TR2 295 | CH(1,K,1) = CC(1,1,K)+TR2 296 | TI2 = CC(2,2,K)+CC(2,3,K) 297 | CI2 = CC(2,1,K)+TAUR*TI2 298 | CH(2,K,1) = CC(2,1,K)+TI2 299 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 300 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 301 | CH(1,K,2) = CR2-CI3 302 | CH(1,K,3) = CR2+CI3 303 | CH(2,K,2) = CI2+CR3 304 | CH(2,K,3) = CI2-CR3 305 | 101 CONTINUE 306 | RETURN 307 | 102 DO 104 K=1,L1 308 | DO 103 I=2,IDO,2 309 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 310 | CR2 = CC(I-1,1,K)+TAUR*TR2 311 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 312 | TI2 = CC(I,2,K)+CC(I,3,K) 313 | CI2 = CC(I,1,K)+TAUR*TI2 314 | CH(I,K,1) = CC(I,1,K)+TI2 315 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 316 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 317 | DR2 = CR2-CI3 318 | DR3 = CR2+CI3 319 | DI2 = CI2+CR3 320 | DI3 = CI2-CR3 321 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 322 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 323 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 324 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 325 | 103 CONTINUE 326 | 104 CONTINUE 327 | RETURN 328 | END 329 | 330 | 331 | SUBROUTINE DPASSB4{{SUF}} (IDO,L1,CC,CH,WA1,WA2,WA3) 332 | USE ADJAC 333 | IMPLICIT {{TYPE}} (A-H,O-Z) 334 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 335 | WA1(*) ,WA2(*) ,WA3(*) 336 | double precision wa1, wa2, wa3 337 | IF (IDO .NE. 2) GO TO 102 338 | DO 101 K=1,L1 339 | TI1 = CC(2,1,K)-CC(2,3,K) 340 | TI2 = CC(2,1,K)+CC(2,3,K) 341 | TR4 = CC(2,4,K)-CC(2,2,K) 342 | TI3 = CC(2,2,K)+CC(2,4,K) 343 | TR1 = CC(1,1,K)-CC(1,3,K) 344 | TR2 = CC(1,1,K)+CC(1,3,K) 345 | TI4 = CC(1,2,K)-CC(1,4,K) 346 | TR3 = CC(1,2,K)+CC(1,4,K) 347 | CH(1,K,1) = TR2+TR3 348 | CH(1,K,3) = TR2-TR3 349 | CH(2,K,1) = TI2+TI3 350 | CH(2,K,3) = TI2-TI3 351 | CH(1,K,2) = TR1+TR4 352 | CH(1,K,4) = TR1-TR4 353 | CH(2,K,2) = TI1+TI4 354 | CH(2,K,4) = TI1-TI4 355 | 101 CONTINUE 356 | RETURN 357 | 102 DO 104 K=1,L1 358 | DO 103 I=2,IDO,2 359 | TI1 = CC(I,1,K)-CC(I,3,K) 360 | TI2 = CC(I,1,K)+CC(I,3,K) 361 | TI3 = CC(I,2,K)+CC(I,4,K) 362 | TR4 = CC(I,4,K)-CC(I,2,K) 363 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 364 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 365 | TI4 = CC(I-1,2,K)-CC(I-1,4,K) 366 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 367 | CH(I-1,K,1) = TR2+TR3 368 | CR3 = TR2-TR3 369 | CH(I,K,1) = TI2+TI3 370 | CI3 = TI2-TI3 371 | CR2 = TR1+TR4 372 | CR4 = TR1-TR4 373 | CI2 = TI1+TI4 374 | CI4 = TI1-TI4 375 | CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 376 | CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 377 | CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 378 | CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 379 | CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 380 | CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 381 | 103 CONTINUE 382 | 104 CONTINUE 383 | RETURN 384 | END 385 | 386 | SUBROUTINE DPASSB5{{SUF}} (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 387 | USE ADJAC 388 | IMPLICIT {{TYPE}} (A-H,O-Z) 389 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) ,& 390 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 391 | double precision wa1, wa2, wa3, wa4, tr11, ti11, tr12, ti12 392 | ! *** TR11=COS(2*PI/5), TI11=SIN(2*PI/5) 393 | ! *** TR12=COS(4*PI/5), TI12=SIN(4*PI/5) 394 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 395 | 0.95105651629515357212D0, & 396 | -0.8090169943749474241D0,0.58778525229247312917D0/ 397 | IF (IDO .NE. 2) GO TO 102 398 | DO 101 K=1,L1 399 | TI5 = CC(2,2,K)-CC(2,5,K) 400 | TI2 = CC(2,2,K)+CC(2,5,K) 401 | TI4 = CC(2,3,K)-CC(2,4,K) 402 | TI3 = CC(2,3,K)+CC(2,4,K) 403 | TR5 = CC(1,2,K)-CC(1,5,K) 404 | TR2 = CC(1,2,K)+CC(1,5,K) 405 | TR4 = CC(1,3,K)-CC(1,4,K) 406 | TR3 = CC(1,3,K)+CC(1,4,K) 407 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 408 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 409 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 410 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 411 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 412 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 413 | CR5 = TI11*TR5+TI12*TR4 414 | CI5 = TI11*TI5+TI12*TI4 415 | CR4 = TI12*TR5-TI11*TR4 416 | CI4 = TI12*TI5-TI11*TI4 417 | CH(1,K,2) = CR2-CI5 418 | CH(1,K,5) = CR2+CI5 419 | CH(2,K,2) = CI2+CR5 420 | CH(2,K,3) = CI3+CR4 421 | CH(1,K,3) = CR3-CI4 422 | CH(1,K,4) = CR3+CI4 423 | CH(2,K,4) = CI3-CR4 424 | CH(2,K,5) = CI2-CR5 425 | 101 CONTINUE 426 | RETURN 427 | 102 DO 104 K=1,L1 428 | DO 103 I=2,IDO,2 429 | TI5 = CC(I,2,K)-CC(I,5,K) 430 | TI2 = CC(I,2,K)+CC(I,5,K) 431 | TI4 = CC(I,3,K)-CC(I,4,K) 432 | TI3 = CC(I,3,K)+CC(I,4,K) 433 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 434 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 435 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 436 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 437 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 438 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 439 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 440 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 441 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 442 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 443 | CR5 = TI11*TR5+TI12*TR4 444 | CI5 = TI11*TI5+TI12*TI4 445 | CR4 = TI12*TR5-TI11*TR4 446 | CI4 = TI12*TI5-TI11*TI4 447 | DR3 = CR3-CI4 448 | DR4 = CR3+CI4 449 | DI3 = CI3+CR4 450 | DI4 = CI3-CR4 451 | DR5 = CR2+CI5 452 | DR2 = CR2-CI5 453 | DI5 = CI2-CR5 454 | DI2 = CI2+CR5 455 | CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 456 | CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 457 | CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 458 | CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 459 | CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 460 | CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 461 | CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 462 | CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 463 | 103 CONTINUE 464 | 104 CONTINUE 465 | RETURN 466 | END 467 | {{endfor}} 468 | -------------------------------------------------------------------------------- /fftpack/zfftf1.f95: -------------------------------------------------------------------------------- 1 | !! NOTE: this file is autogenerated from zfftf1.f95.in: do not edit manually 2 | !***BEGIN PROLOGUE CFFTF1 3 | !***PURPOSE Compute the forward transform of a complex, periodic 4 | ! sequence. 5 | !***LIBRARY SLATEC (FFTPACK) 6 | !***CATEGORY J1A2 7 | !***TYPE COMPLEX (RFFTF1-S, CFFTF1-C) 8 | !***KEYWORDS FFTPACK, FOURIER TRANSFORM 9 | !***AUTHOR Swarztrauber, P. N., (NCAR) 10 | !***DESCRIPTION 11 | ! 12 | ! Subroutine CFFTF1 computes the forward complex discrete Fourier 13 | ! transform (the Fourier analysis). Equivalently, CFFTF1 computes 14 | ! the Fourier coefficients of a complex periodic sequence. 15 | ! The transform is defined below at output parameter C. 16 | ! 17 | ! The transform is not normalized. To obtain a normalized transform 18 | ! the output must be divided by N. Otherwise a call of CFFTF1 19 | ! followed by a call of CFFTB1 will multiply the sequence by N. 20 | ! 21 | ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be 22 | ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). 23 | ! 24 | ! Input Parameters 25 | ! 26 | ! N the length of the complex sequence C. The method is 27 | ! more efficient when N is the product of small primes. 28 | ! 29 | ! C a complex array of length N which contains the sequence 30 | ! 31 | ! CH a real work array of length at least 2*N 32 | ! 33 | ! WA a real work array which must be dimensioned at least 2*N. 34 | ! 35 | ! IFAC an integer work array which must be dimensioned at least 15. 36 | ! 37 | ! The WA and IFAC arrays must be initialized by calling 38 | ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC 39 | ! arrays must be used for each different value of N. This 40 | ! initialization does not have to be repeated so long as N 41 | ! remains unchanged. Thus subsequent transforms can be 42 | ! obtained faster than the first. The same WA and IFAC arrays 43 | ! can be used by CFFTF1 and CFFTB1. 44 | ! 45 | ! Output Parameters 46 | ! 47 | ! C For J=1,...,N 48 | ! 49 | ! C(J)=the sum from K=1,...,N of 50 | ! 51 | ! C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) 52 | ! 53 | ! where I=SQRT(-1) 54 | ! 55 | ! NOTE: WA and IFAC contain initialization calculations which must 56 | ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 57 | ! 58 | !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel 59 | ! Computations (G. Rodrigue, ed.), Academic Press, 60 | ! 1982, pp. 51-83. 61 | !***ROUTINES CALLED PASSF, PASSF2, PASSF3, PASSF4, PASSF5 62 | !***REVISION HISTORY (YYMMDD) 63 | ! 790601 DATE WRITTEN 64 | ! 830401 Modified to use SLATEC library source file format. 65 | ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 66 | ! changing dummy array size declarations (1) to (*). 67 | ! 881128 Modified by Dick Valent to meet prologue standards. 68 | ! 891214 Prologue converted to Version 4.0 format. (BAB) 69 | ! 900131 Routine changed from subsidiary to user-callable. (WRB) 70 | ! 920501 Reformatted the REFERENCES section. (WRB) 71 | !***END PROLOGUE CFFTF1 72 | SUBROUTINE ZFFTF1a (N,C,CH,WA,IFAC) 73 | USE ADJAC 74 | IMPLICIT type(adjac_double) (A-H,O-Z) 75 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 76 | double precision :: wa 77 | NF = IFAC(2) 78 | NA = 0 79 | L1 = 1 80 | IW = 1 81 | DO 116 K1=1,NF 82 | IP = IFAC(K1+2) 83 | L2 = IP*L1 84 | IDO = N/L2 85 | IDOT = IDO+IDO 86 | IDL1 = IDOT*L1 87 | IF (IP .NE. 4) GO TO 103 88 | IX2 = IW+IDOT 89 | IX3 = IX2+IDOT 90 | IF (NA .NE. 0) GO TO 101 91 | CALL DPASSF4a (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 92 | GO TO 102 93 | 101 CALL DPASSF4a (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 94 | 102 NA = 1-NA 95 | GO TO 115 96 | 103 IF (IP .NE. 2) GO TO 106 97 | IF (NA .NE. 0) GO TO 104 98 | CALL DPASSF2a (IDOT,L1,C,CH,WA(IW)) 99 | GO TO 105 100 | 104 CALL DPASSF2a (IDOT,L1,CH,C,WA(IW)) 101 | 105 NA = 1-NA 102 | GO TO 115 103 | 106 IF (IP .NE. 3) GO TO 109 104 | IX2 = IW+IDOT 105 | IF (NA .NE. 0) GO TO 107 106 | CALL DPASSF3a (IDOT,L1,C,CH,WA(IW),WA(IX2)) 107 | GO TO 108 108 | 107 CALL DPASSF3a (IDOT,L1,CH,C,WA(IW),WA(IX2)) 109 | 108 NA = 1-NA 110 | GO TO 115 111 | 109 IF (IP .NE. 5) GO TO 112 112 | IX2 = IW+IDOT 113 | IX3 = IX2+IDOT 114 | IX4 = IX3+IDOT 115 | IF (NA .NE. 0) GO TO 110 116 | CALL DPASSF5a (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 117 | GO TO 111 118 | 110 CALL DPASSF5a (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 119 | 111 NA = 1-NA 120 | GO TO 115 121 | 112 IF (NA .NE. 0) GO TO 113 122 | CALL DPASSFa (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 123 | GO TO 114 124 | 113 CALL DPASSFa (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 125 | 114 IF (NAC .NE. 0) NA = 1-NA 126 | 115 L1 = L2 127 | IW = IW+(IP-1)*IDOT 128 | 116 CONTINUE 129 | IF (NA .EQ. 0) RETURN 130 | N2 = N+N 131 | DO 117 I=1,N2 132 | C(I) = CH(I) 133 | 117 CONTINUE 134 | RETURN 135 | END 136 | 137 | SUBROUTINE DPASSFa (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 138 | USE ADJAC 139 | IMPLICIT type(adjac_double) (A-H,O-Z) 140 | DIMENSION CH(IDO,L1,IP) , CC(IDO,IP,L1), & 141 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 142 | CH2(IDL1,IP) 143 | double precision :: wa, war, wai 144 | IDOT = IDO/2 145 | NT = IP*IDL1 146 | IPP2 = IP+2 147 | IPPH = (IP+1)/2 148 | IDP = IP*IDO 149 | 150 | IF (IDO .LT. L1) GO TO 106 151 | DO 103 J=2,IPPH 152 | JC = IPP2-J 153 | DO 102 K=1,L1 154 | DO 101 I=1,IDO 155 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 156 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 157 | 101 CONTINUE 158 | 102 CONTINUE 159 | 103 CONTINUE 160 | DO 105 K=1,L1 161 | DO 104 I=1,IDO 162 | CH(I,K,1) = CC(I,1,K) 163 | 104 CONTINUE 164 | 105 CONTINUE 165 | GO TO 112 166 | 106 DO 109 J=2,IPPH 167 | JC = IPP2-J 168 | DO 108 I=1,IDO 169 | DO 107 K=1,L1 170 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 171 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 172 | 107 CONTINUE 173 | 108 CONTINUE 174 | 109 CONTINUE 175 | DO 111 I=1,IDO 176 | DO 110 K=1,L1 177 | CH(I,K,1) = CC(I,1,K) 178 | 110 CONTINUE 179 | 111 CONTINUE 180 | 112 IDL = 2-IDO 181 | INC = 0 182 | DO 116 L=2,IPPH 183 | LC = IPP2-L 184 | IDL = IDL+IDO 185 | DO 113 IK=1,IDL1 186 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 187 | C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 188 | 113 CONTINUE 189 | IDLJ = IDL 190 | INC = INC+IDO 191 | DO 115 J=3,IPPH 192 | JC = IPP2-J 193 | IDLJ = IDLJ+INC 194 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 195 | WAR = WA(IDLJ-1) 196 | WAI = WA(IDLJ) 197 | DO 114 IK=1,IDL1 198 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 199 | C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 200 | 114 CONTINUE 201 | 115 CONTINUE 202 | 116 CONTINUE 203 | DO 118 J=2,IPPH 204 | DO 117 IK=1,IDL1 205 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 206 | 117 CONTINUE 207 | 118 CONTINUE 208 | DO 120 J=2,IPPH 209 | JC = IPP2-J 210 | DO 119 IK=2,IDL1,2 211 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 212 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 213 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 214 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 215 | 119 CONTINUE 216 | 120 CONTINUE 217 | NAC = 1 218 | IF (IDO .EQ. 2) RETURN 219 | NAC = 0 220 | DO 121 IK=1,IDL1 221 | C2(IK,1) = CH2(IK,1) 222 | 121 CONTINUE 223 | DO 123 J=2,IP 224 | DO 122 K=1,L1 225 | C1(1,K,J) = CH(1,K,J) 226 | C1(2,K,J) = CH(2,K,J) 227 | 122 CONTINUE 228 | 123 CONTINUE 229 | IF (IDOT .GT. L1) GO TO 127 230 | IDIJ = 0 231 | DO 126 J=2,IP 232 | IDIJ = IDIJ+2 233 | DO 125 I=4,IDO,2 234 | IDIJ = IDIJ+2 235 | DO 124 K=1,L1 236 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 237 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 238 | 124 CONTINUE 239 | 125 CONTINUE 240 | 126 CONTINUE 241 | RETURN 242 | 127 IDJ = 2-IDO 243 | DO 130 J=2,IP 244 | IDJ = IDJ+IDO 245 | DO 129 K=1,L1 246 | IDIJ = IDJ 247 | DO 128 I=4,IDO,2 248 | IDIJ = IDIJ+2 249 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 250 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 251 | 128 CONTINUE 252 | 129 CONTINUE 253 | 130 CONTINUE 254 | RETURN 255 | END 256 | 257 | SUBROUTINE DPASSF2a (IDO,L1,CC,CH,WA1) 258 | USE ADJAC 259 | IMPLICIT type(adjac_double) (A-H,O-Z) 260 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , & 261 | WA1(*) 262 | double precision :: wa1 263 | IF (IDO .GT. 2) GO TO 102 264 | DO 101 K=1,L1 265 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 266 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 267 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 268 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 269 | 101 CONTINUE 270 | RETURN 271 | 102 DO 104 K=1,L1 272 | DO 103 I=2,IDO,2 273 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 274 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 275 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 276 | TI2 = CC(I,1,K)-CC(I,2,K) 277 | CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 278 | CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 279 | 103 CONTINUE 280 | 104 CONTINUE 281 | RETURN 282 | END 283 | 284 | SUBROUTINE DPASSF3a (IDO,L1,CC,CH,WA1,WA2) 285 | USE ADJAC 286 | IMPLICIT type(adjac_double) (A-H,O-Z) 287 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , & 288 | WA1(*) ,WA2(*) 289 | double precision :: wa1,wa2,TAUR,TAUI 290 | ! *** TAUI IS -SQRT(3)/2 *** 291 | DATA TAUR,TAUI /-0.5D0,-0.86602540378443864676D0/ 292 | IF (IDO .NE. 2) GO TO 102 293 | DO 101 K=1,L1 294 | TR2 = CC(1,2,K)+CC(1,3,K) 295 | CR2 = CC(1,1,K)+TAUR*TR2 296 | CH(1,K,1) = CC(1,1,K)+TR2 297 | TI2 = CC(2,2,K)+CC(2,3,K) 298 | CI2 = CC(2,1,K)+TAUR*TI2 299 | CH(2,K,1) = CC(2,1,K)+TI2 300 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 301 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 302 | CH(1,K,2) = CR2-CI3 303 | CH(1,K,3) = CR2+CI3 304 | CH(2,K,2) = CI2+CR3 305 | CH(2,K,3) = CI2-CR3 306 | 101 CONTINUE 307 | RETURN 308 | 102 DO 104 K=1,L1 309 | DO 103 I=2,IDO,2 310 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 311 | CR2 = CC(I-1,1,K)+TAUR*TR2 312 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 313 | TI2 = CC(I,2,K)+CC(I,3,K) 314 | CI2 = CC(I,1,K)+TAUR*TI2 315 | CH(I,K,1) = CC(I,1,K)+TI2 316 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 317 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 318 | DR2 = CR2-CI3 319 | DR3 = CR2+CI3 320 | DI2 = CI2+CR3 321 | DI3 = CI2-CR3 322 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 323 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 324 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 325 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 326 | 103 CONTINUE 327 | 104 CONTINUE 328 | RETURN 329 | END 330 | 331 | SUBROUTINE DPASSF4a (IDO,L1,CC,CH,WA1,WA2,WA3) 332 | USE ADJAC 333 | IMPLICIT type(adjac_double) (A-H,O-Z) 334 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 335 | WA1(*) ,WA2(*) ,WA3(*) 336 | double precision :: wa1, wa2, wa3 337 | IF (IDO .NE. 2) GO TO 102 338 | DO 101 K=1,L1 339 | TI1 = CC(2,1,K)-CC(2,3,K) 340 | TI2 = CC(2,1,K)+CC(2,3,K) 341 | TR4 = CC(2,2,K)-CC(2,4,K) 342 | TI3 = CC(2,2,K)+CC(2,4,K) 343 | TR1 = CC(1,1,K)-CC(1,3,K) 344 | TR2 = CC(1,1,K)+CC(1,3,K) 345 | TI4 = CC(1,4,K)-CC(1,2,K) 346 | TR3 = CC(1,2,K)+CC(1,4,K) 347 | CH(1,K,1) = TR2+TR3 348 | CH(1,K,3) = TR2-TR3 349 | CH(2,K,1) = TI2+TI3 350 | CH(2,K,3) = TI2-TI3 351 | CH(1,K,2) = TR1+TR4 352 | CH(1,K,4) = TR1-TR4 353 | CH(2,K,2) = TI1+TI4 354 | CH(2,K,4) = TI1-TI4 355 | 101 CONTINUE 356 | RETURN 357 | 102 DO 104 K=1,L1 358 | DO 103 I=2,IDO,2 359 | TI1 = CC(I,1,K)-CC(I,3,K) 360 | TI2 = CC(I,1,K)+CC(I,3,K) 361 | TI3 = CC(I,2,K)+CC(I,4,K) 362 | TR4 = CC(I,2,K)-CC(I,4,K) 363 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 364 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 365 | TI4 = CC(I-1,4,K)-CC(I-1,2,K) 366 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 367 | CH(I-1,K,1) = TR2+TR3 368 | CR3 = TR2-TR3 369 | CH(I,K,1) = TI2+TI3 370 | CI3 = TI2-TI3 371 | CR2 = TR1+TR4 372 | CR4 = TR1-TR4 373 | CI2 = TI1+TI4 374 | CI4 = TI1-TI4 375 | CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 376 | CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 377 | CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 378 | CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 379 | CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 380 | CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 381 | 103 CONTINUE 382 | 104 CONTINUE 383 | RETURN 384 | END 385 | 386 | SUBROUTINE DPASSF5a (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 387 | USE ADJAC 388 | IMPLICIT type(adjac_double) (A-H,O-Z) 389 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , & 390 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 391 | double precision :: wa1,wa2,wa3,wa4,TR11,TI11,TR12,TI12 392 | ! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) 393 | ! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) 394 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 395 | -0.95105651629515357212D0, & 396 | -0.8090169943749474241D0, -0.58778525229247312917D0/ 397 | IF (IDO .NE. 2) GO TO 102 398 | DO 101 K=1,L1 399 | TI5 = CC(2,2,K)-CC(2,5,K) 400 | TI2 = CC(2,2,K)+CC(2,5,K) 401 | TI4 = CC(2,3,K)-CC(2,4,K) 402 | TI3 = CC(2,3,K)+CC(2,4,K) 403 | TR5 = CC(1,2,K)-CC(1,5,K) 404 | TR2 = CC(1,2,K)+CC(1,5,K) 405 | TR4 = CC(1,3,K)-CC(1,4,K) 406 | TR3 = CC(1,3,K)+CC(1,4,K) 407 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 408 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 409 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 410 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 411 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 412 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 413 | CR5 = TI11*TR5+TI12*TR4 414 | CI5 = TI11*TI5+TI12*TI4 415 | CR4 = TI12*TR5-TI11*TR4 416 | CI4 = TI12*TI5-TI11*TI4 417 | CH(1,K,2) = CR2-CI5 418 | CH(1,K,5) = CR2+CI5 419 | CH(2,K,2) = CI2+CR5 420 | CH(2,K,3) = CI3+CR4 421 | CH(1,K,3) = CR3-CI4 422 | CH(1,K,4) = CR3+CI4 423 | CH(2,K,4) = CI3-CR4 424 | CH(2,K,5) = CI2-CR5 425 | 101 CONTINUE 426 | RETURN 427 | 102 DO 104 K=1,L1 428 | DO 103 I=2,IDO,2 429 | TI5 = CC(I,2,K)-CC(I,5,K) 430 | TI2 = CC(I,2,K)+CC(I,5,K) 431 | TI4 = CC(I,3,K)-CC(I,4,K) 432 | TI3 = CC(I,3,K)+CC(I,4,K) 433 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 434 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 435 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 436 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 437 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 438 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 439 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 440 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 441 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 442 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 443 | CR5 = TI11*TR5+TI12*TR4 444 | CI5 = TI11*TI5+TI12*TI4 445 | CR4 = TI12*TR5-TI11*TR4 446 | CI4 = TI12*TI5-TI11*TI4 447 | DR3 = CR3-CI4 448 | DR4 = CR3+CI4 449 | DI3 = CI3+CR4 450 | DI4 = CI3-CR4 451 | DR5 = CR2+CI5 452 | DR2 = CR2-CI5 453 | DI5 = CI2-CR5 454 | DI2 = CI2+CR5 455 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 456 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 457 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 458 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 459 | CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 460 | CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 461 | CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 462 | CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 463 | 103 CONTINUE 464 | 104 CONTINUE 465 | RETURN 466 | END 467 | SUBROUTINE ZFFTF1d (N,C,CH,WA,IFAC) 468 | USE ADJAC 469 | IMPLICIT double precision (A-H,O-Z) 470 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 471 | double precision :: wa 472 | NF = IFAC(2) 473 | NA = 0 474 | L1 = 1 475 | IW = 1 476 | DO 116 K1=1,NF 477 | IP = IFAC(K1+2) 478 | L2 = IP*L1 479 | IDO = N/L2 480 | IDOT = IDO+IDO 481 | IDL1 = IDOT*L1 482 | IF (IP .NE. 4) GO TO 103 483 | IX2 = IW+IDOT 484 | IX3 = IX2+IDOT 485 | IF (NA .NE. 0) GO TO 101 486 | CALL DPASSF4d (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 487 | GO TO 102 488 | 101 CALL DPASSF4d (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 489 | 102 NA = 1-NA 490 | GO TO 115 491 | 103 IF (IP .NE. 2) GO TO 106 492 | IF (NA .NE. 0) GO TO 104 493 | CALL DPASSF2d (IDOT,L1,C,CH,WA(IW)) 494 | GO TO 105 495 | 104 CALL DPASSF2d (IDOT,L1,CH,C,WA(IW)) 496 | 105 NA = 1-NA 497 | GO TO 115 498 | 106 IF (IP .NE. 3) GO TO 109 499 | IX2 = IW+IDOT 500 | IF (NA .NE. 0) GO TO 107 501 | CALL DPASSF3d (IDOT,L1,C,CH,WA(IW),WA(IX2)) 502 | GO TO 108 503 | 107 CALL DPASSF3d (IDOT,L1,CH,C,WA(IW),WA(IX2)) 504 | 108 NA = 1-NA 505 | GO TO 115 506 | 109 IF (IP .NE. 5) GO TO 112 507 | IX2 = IW+IDOT 508 | IX3 = IX2+IDOT 509 | IX4 = IX3+IDOT 510 | IF (NA .NE. 0) GO TO 110 511 | CALL DPASSF5d (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 512 | GO TO 111 513 | 110 CALL DPASSF5d (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 514 | 111 NA = 1-NA 515 | GO TO 115 516 | 112 IF (NA .NE. 0) GO TO 113 517 | CALL DPASSFd (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 518 | GO TO 114 519 | 113 CALL DPASSFd (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 520 | 114 IF (NAC .NE. 0) NA = 1-NA 521 | 115 L1 = L2 522 | IW = IW+(IP-1)*IDOT 523 | 116 CONTINUE 524 | IF (NA .EQ. 0) RETURN 525 | N2 = N+N 526 | DO 117 I=1,N2 527 | C(I) = CH(I) 528 | 117 CONTINUE 529 | RETURN 530 | END 531 | 532 | SUBROUTINE DPASSFd (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 533 | USE ADJAC 534 | IMPLICIT double precision (A-H,O-Z) 535 | DIMENSION CH(IDO,L1,IP) , CC(IDO,IP,L1), & 536 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 537 | CH2(IDL1,IP) 538 | double precision :: wa, war, wai 539 | IDOT = IDO/2 540 | NT = IP*IDL1 541 | IPP2 = IP+2 542 | IPPH = (IP+1)/2 543 | IDP = IP*IDO 544 | 545 | IF (IDO .LT. L1) GO TO 106 546 | DO 103 J=2,IPPH 547 | JC = IPP2-J 548 | DO 102 K=1,L1 549 | DO 101 I=1,IDO 550 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 551 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 552 | 101 CONTINUE 553 | 102 CONTINUE 554 | 103 CONTINUE 555 | DO 105 K=1,L1 556 | DO 104 I=1,IDO 557 | CH(I,K,1) = CC(I,1,K) 558 | 104 CONTINUE 559 | 105 CONTINUE 560 | GO TO 112 561 | 106 DO 109 J=2,IPPH 562 | JC = IPP2-J 563 | DO 108 I=1,IDO 564 | DO 107 K=1,L1 565 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 566 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 567 | 107 CONTINUE 568 | 108 CONTINUE 569 | 109 CONTINUE 570 | DO 111 I=1,IDO 571 | DO 110 K=1,L1 572 | CH(I,K,1) = CC(I,1,K) 573 | 110 CONTINUE 574 | 111 CONTINUE 575 | 112 IDL = 2-IDO 576 | INC = 0 577 | DO 116 L=2,IPPH 578 | LC = IPP2-L 579 | IDL = IDL+IDO 580 | DO 113 IK=1,IDL1 581 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 582 | C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 583 | 113 CONTINUE 584 | IDLJ = IDL 585 | INC = INC+IDO 586 | DO 115 J=3,IPPH 587 | JC = IPP2-J 588 | IDLJ = IDLJ+INC 589 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 590 | WAR = WA(IDLJ-1) 591 | WAI = WA(IDLJ) 592 | DO 114 IK=1,IDL1 593 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 594 | C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 595 | 114 CONTINUE 596 | 115 CONTINUE 597 | 116 CONTINUE 598 | DO 118 J=2,IPPH 599 | DO 117 IK=1,IDL1 600 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 601 | 117 CONTINUE 602 | 118 CONTINUE 603 | DO 120 J=2,IPPH 604 | JC = IPP2-J 605 | DO 119 IK=2,IDL1,2 606 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 607 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 608 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 609 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 610 | 119 CONTINUE 611 | 120 CONTINUE 612 | NAC = 1 613 | IF (IDO .EQ. 2) RETURN 614 | NAC = 0 615 | DO 121 IK=1,IDL1 616 | C2(IK,1) = CH2(IK,1) 617 | 121 CONTINUE 618 | DO 123 J=2,IP 619 | DO 122 K=1,L1 620 | C1(1,K,J) = CH(1,K,J) 621 | C1(2,K,J) = CH(2,K,J) 622 | 122 CONTINUE 623 | 123 CONTINUE 624 | IF (IDOT .GT. L1) GO TO 127 625 | IDIJ = 0 626 | DO 126 J=2,IP 627 | IDIJ = IDIJ+2 628 | DO 125 I=4,IDO,2 629 | IDIJ = IDIJ+2 630 | DO 124 K=1,L1 631 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 632 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 633 | 124 CONTINUE 634 | 125 CONTINUE 635 | 126 CONTINUE 636 | RETURN 637 | 127 IDJ = 2-IDO 638 | DO 130 J=2,IP 639 | IDJ = IDJ+IDO 640 | DO 129 K=1,L1 641 | IDIJ = IDJ 642 | DO 128 I=4,IDO,2 643 | IDIJ = IDIJ+2 644 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 645 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 646 | 128 CONTINUE 647 | 129 CONTINUE 648 | 130 CONTINUE 649 | RETURN 650 | END 651 | 652 | SUBROUTINE DPASSF2d (IDO,L1,CC,CH,WA1) 653 | USE ADJAC 654 | IMPLICIT double precision (A-H,O-Z) 655 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , & 656 | WA1(*) 657 | double precision :: wa1 658 | IF (IDO .GT. 2) GO TO 102 659 | DO 101 K=1,L1 660 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 661 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 662 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 663 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 664 | 101 CONTINUE 665 | RETURN 666 | 102 DO 104 K=1,L1 667 | DO 103 I=2,IDO,2 668 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 669 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 670 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 671 | TI2 = CC(I,1,K)-CC(I,2,K) 672 | CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 673 | CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 674 | 103 CONTINUE 675 | 104 CONTINUE 676 | RETURN 677 | END 678 | 679 | SUBROUTINE DPASSF3d (IDO,L1,CC,CH,WA1,WA2) 680 | USE ADJAC 681 | IMPLICIT double precision (A-H,O-Z) 682 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , & 683 | WA1(*) ,WA2(*) 684 | double precision :: wa1,wa2,TAUR,TAUI 685 | ! *** TAUI IS -SQRT(3)/2 *** 686 | DATA TAUR,TAUI /-0.5D0,-0.86602540378443864676D0/ 687 | IF (IDO .NE. 2) GO TO 102 688 | DO 101 K=1,L1 689 | TR2 = CC(1,2,K)+CC(1,3,K) 690 | CR2 = CC(1,1,K)+TAUR*TR2 691 | CH(1,K,1) = CC(1,1,K)+TR2 692 | TI2 = CC(2,2,K)+CC(2,3,K) 693 | CI2 = CC(2,1,K)+TAUR*TI2 694 | CH(2,K,1) = CC(2,1,K)+TI2 695 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 696 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 697 | CH(1,K,2) = CR2-CI3 698 | CH(1,K,3) = CR2+CI3 699 | CH(2,K,2) = CI2+CR3 700 | CH(2,K,3) = CI2-CR3 701 | 101 CONTINUE 702 | RETURN 703 | 102 DO 104 K=1,L1 704 | DO 103 I=2,IDO,2 705 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 706 | CR2 = CC(I-1,1,K)+TAUR*TR2 707 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 708 | TI2 = CC(I,2,K)+CC(I,3,K) 709 | CI2 = CC(I,1,K)+TAUR*TI2 710 | CH(I,K,1) = CC(I,1,K)+TI2 711 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 712 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 713 | DR2 = CR2-CI3 714 | DR3 = CR2+CI3 715 | DI2 = CI2+CR3 716 | DI3 = CI2-CR3 717 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 718 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 719 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 720 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 721 | 103 CONTINUE 722 | 104 CONTINUE 723 | RETURN 724 | END 725 | 726 | SUBROUTINE DPASSF4d (IDO,L1,CC,CH,WA1,WA2,WA3) 727 | USE ADJAC 728 | IMPLICIT double precision (A-H,O-Z) 729 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 730 | WA1(*) ,WA2(*) ,WA3(*) 731 | double precision :: wa1, wa2, wa3 732 | IF (IDO .NE. 2) GO TO 102 733 | DO 101 K=1,L1 734 | TI1 = CC(2,1,K)-CC(2,3,K) 735 | TI2 = CC(2,1,K)+CC(2,3,K) 736 | TR4 = CC(2,2,K)-CC(2,4,K) 737 | TI3 = CC(2,2,K)+CC(2,4,K) 738 | TR1 = CC(1,1,K)-CC(1,3,K) 739 | TR2 = CC(1,1,K)+CC(1,3,K) 740 | TI4 = CC(1,4,K)-CC(1,2,K) 741 | TR3 = CC(1,2,K)+CC(1,4,K) 742 | CH(1,K,1) = TR2+TR3 743 | CH(1,K,3) = TR2-TR3 744 | CH(2,K,1) = TI2+TI3 745 | CH(2,K,3) = TI2-TI3 746 | CH(1,K,2) = TR1+TR4 747 | CH(1,K,4) = TR1-TR4 748 | CH(2,K,2) = TI1+TI4 749 | CH(2,K,4) = TI1-TI4 750 | 101 CONTINUE 751 | RETURN 752 | 102 DO 104 K=1,L1 753 | DO 103 I=2,IDO,2 754 | TI1 = CC(I,1,K)-CC(I,3,K) 755 | TI2 = CC(I,1,K)+CC(I,3,K) 756 | TI3 = CC(I,2,K)+CC(I,4,K) 757 | TR4 = CC(I,2,K)-CC(I,4,K) 758 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 759 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 760 | TI4 = CC(I-1,4,K)-CC(I-1,2,K) 761 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 762 | CH(I-1,K,1) = TR2+TR3 763 | CR3 = TR2-TR3 764 | CH(I,K,1) = TI2+TI3 765 | CI3 = TI2-TI3 766 | CR2 = TR1+TR4 767 | CR4 = TR1-TR4 768 | CI2 = TI1+TI4 769 | CI4 = TI1-TI4 770 | CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 771 | CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 772 | CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 773 | CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 774 | CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 775 | CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 776 | 103 CONTINUE 777 | 104 CONTINUE 778 | RETURN 779 | END 780 | 781 | SUBROUTINE DPASSF5d (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 782 | USE ADJAC 783 | IMPLICIT double precision (A-H,O-Z) 784 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , & 785 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 786 | double precision :: wa1,wa2,wa3,wa4,TR11,TI11,TR12,TI12 787 | ! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) 788 | ! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) 789 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 790 | -0.95105651629515357212D0, & 791 | -0.8090169943749474241D0, -0.58778525229247312917D0/ 792 | IF (IDO .NE. 2) GO TO 102 793 | DO 101 K=1,L1 794 | TI5 = CC(2,2,K)-CC(2,5,K) 795 | TI2 = CC(2,2,K)+CC(2,5,K) 796 | TI4 = CC(2,3,K)-CC(2,4,K) 797 | TI3 = CC(2,3,K)+CC(2,4,K) 798 | TR5 = CC(1,2,K)-CC(1,5,K) 799 | TR2 = CC(1,2,K)+CC(1,5,K) 800 | TR4 = CC(1,3,K)-CC(1,4,K) 801 | TR3 = CC(1,3,K)+CC(1,4,K) 802 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 803 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 804 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 805 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 806 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 807 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 808 | CR5 = TI11*TR5+TI12*TR4 809 | CI5 = TI11*TI5+TI12*TI4 810 | CR4 = TI12*TR5-TI11*TR4 811 | CI4 = TI12*TI5-TI11*TI4 812 | CH(1,K,2) = CR2-CI5 813 | CH(1,K,5) = CR2+CI5 814 | CH(2,K,2) = CI2+CR5 815 | CH(2,K,3) = CI3+CR4 816 | CH(1,K,3) = CR3-CI4 817 | CH(1,K,4) = CR3+CI4 818 | CH(2,K,4) = CI3-CR4 819 | CH(2,K,5) = CI2-CR5 820 | 101 CONTINUE 821 | RETURN 822 | 102 DO 104 K=1,L1 823 | DO 103 I=2,IDO,2 824 | TI5 = CC(I,2,K)-CC(I,5,K) 825 | TI2 = CC(I,2,K)+CC(I,5,K) 826 | TI4 = CC(I,3,K)-CC(I,4,K) 827 | TI3 = CC(I,3,K)+CC(I,4,K) 828 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 829 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 830 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 831 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 832 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 833 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 834 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 835 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 836 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 837 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 838 | CR5 = TI11*TR5+TI12*TR4 839 | CI5 = TI11*TI5+TI12*TI4 840 | CR4 = TI12*TR5-TI11*TR4 841 | CI4 = TI12*TI5-TI11*TI4 842 | DR3 = CR3-CI4 843 | DR4 = CR3+CI4 844 | DI3 = CI3+CR4 845 | DI4 = CI3-CR4 846 | DR5 = CR2+CI5 847 | DR2 = CR2-CI5 848 | DI5 = CI2-CR5 849 | DI2 = CI2+CR5 850 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 851 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 852 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 853 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 854 | CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 855 | CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 856 | CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 857 | CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 858 | 103 CONTINUE 859 | 104 CONTINUE 860 | RETURN 861 | END 862 | -------------------------------------------------------------------------------- /fftpack/zfftf1.f95.in: -------------------------------------------------------------------------------- 1 | !***BEGIN PROLOGUE CFFTF1 2 | !***PURPOSE Compute the forward transform of a complex, periodic 3 | ! sequence. 4 | !***LIBRARY SLATEC (FFTPACK) 5 | !***CATEGORY J1A2 6 | !***TYPE COMPLEX (RFFTF1-S, CFFTF1-C) 7 | !***KEYWORDS FFTPACK, FOURIER TRANSFORM 8 | !***AUTHOR Swarztrauber, P. N., (NCAR) 9 | !***DESCRIPTION 10 | ! 11 | ! Subroutine CFFTF1 computes the forward complex discrete Fourier 12 | ! transform (the Fourier analysis). Equivalently, CFFTF1 computes 13 | ! the Fourier coefficients of a complex periodic sequence. 14 | ! The transform is defined below at output parameter C. 15 | ! 16 | ! The transform is not normalized. To obtain a normalized transform 17 | ! the output must be divided by N. Otherwise a call of CFFTF1 18 | ! followed by a call of CFFTB1 will multiply the sequence by N. 19 | ! 20 | ! The arrays WA and IFAC which are used by subroutine CFFTB1 must be 21 | ! initialized by calling subroutine CFFTI1 (N, WA, IFAC). 22 | ! 23 | ! Input Parameters 24 | ! 25 | ! N the length of the complex sequence C. The method is 26 | ! more efficient when N is the product of small primes. 27 | ! 28 | ! C a complex array of length N which contains the sequence 29 | ! 30 | ! CH a real work array of length at least 2*N 31 | ! 32 | ! WA a real work array which must be dimensioned at least 2*N. 33 | ! 34 | ! IFAC an integer work array which must be dimensioned at least 15. 35 | ! 36 | ! The WA and IFAC arrays must be initialized by calling 37 | ! subroutine CFFTI1 (N, WA, IFAC), and different WA and IFAC 38 | ! arrays must be used for each different value of N. This 39 | ! initialization does not have to be repeated so long as N 40 | ! remains unchanged. Thus subsequent transforms can be 41 | ! obtained faster than the first. The same WA and IFAC arrays 42 | ! can be used by CFFTF1 and CFFTB1. 43 | ! 44 | ! Output Parameters 45 | ! 46 | ! C For J=1,...,N 47 | ! 48 | ! C(J)=the sum from K=1,...,N of 49 | ! 50 | ! C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) 51 | ! 52 | ! where I=SQRT(-1) 53 | ! 54 | ! NOTE: WA and IFAC contain initialization calculations which must 55 | ! not be destroyed between calls of subroutine CFFTF1 or CFFTB1 56 | ! 57 | !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel 58 | ! Computations (G. Rodrigue, ed.), Academic Press, 59 | ! 1982, pp. 51-83. 60 | !***ROUTINES CALLED PASSF, PASSF2, PASSF3, PASSF4, PASSF5 61 | !***REVISION HISTORY (YYMMDD) 62 | ! 790601 DATE WRITTEN 63 | ! 830401 Modified to use SLATEC library source file format. 64 | ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 65 | ! changing dummy array size declarations (1) to (*). 66 | ! 881128 Modified by Dick Valent to meet prologue standards. 67 | ! 891214 Prologue converted to Version 4.0 format. (BAB) 68 | ! 900131 Routine changed from subsidiary to user-callable. (WRB) 69 | ! 920501 Reformatted the REFERENCES section. (WRB) 70 | !***END PROLOGUE CFFTF1 71 | {{for TYPE, SUF in [('type(adjac_double)', 'a'), 72 | ('double precision', 'd')]}} 73 | SUBROUTINE ZFFTF1{{SUF}} (N,C,CH,WA,IFAC) 74 | USE ADJAC 75 | IMPLICIT {{TYPE}} (A-H,O-Z) 76 | DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) 77 | double precision :: wa 78 | NF = IFAC(2) 79 | NA = 0 80 | L1 = 1 81 | IW = 1 82 | DO 116 K1=1,NF 83 | IP = IFAC(K1+2) 84 | L2 = IP*L1 85 | IDO = N/L2 86 | IDOT = IDO+IDO 87 | IDL1 = IDOT*L1 88 | IF (IP .NE. 4) GO TO 103 89 | IX2 = IW+IDOT 90 | IX3 = IX2+IDOT 91 | IF (NA .NE. 0) GO TO 101 92 | CALL DPASSF4{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) 93 | GO TO 102 94 | 101 CALL DPASSF4{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 95 | 102 NA = 1-NA 96 | GO TO 115 97 | 103 IF (IP .NE. 2) GO TO 106 98 | IF (NA .NE. 0) GO TO 104 99 | CALL DPASSF2{{SUF}} (IDOT,L1,C,CH,WA(IW)) 100 | GO TO 105 101 | 104 CALL DPASSF2{{SUF}} (IDOT,L1,CH,C,WA(IW)) 102 | 105 NA = 1-NA 103 | GO TO 115 104 | 106 IF (IP .NE. 3) GO TO 109 105 | IX2 = IW+IDOT 106 | IF (NA .NE. 0) GO TO 107 107 | CALL DPASSF3{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2)) 108 | GO TO 108 109 | 107 CALL DPASSF3{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2)) 110 | 108 NA = 1-NA 111 | GO TO 115 112 | 109 IF (IP .NE. 5) GO TO 112 113 | IX2 = IW+IDOT 114 | IX3 = IX2+IDOT 115 | IX4 = IX3+IDOT 116 | IF (NA .NE. 0) GO TO 110 117 | CALL DPASSF5{{SUF}} (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 118 | GO TO 111 119 | 110 CALL DPASSF5{{SUF}} (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 120 | 111 NA = 1-NA 121 | GO TO 115 122 | 112 IF (NA .NE. 0) GO TO 113 123 | CALL DPASSF{{SUF}} (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) 124 | GO TO 114 125 | 113 CALL DPASSF{{SUF}} (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 126 | 114 IF (NAC .NE. 0) NA = 1-NA 127 | 115 L1 = L2 128 | IW = IW+(IP-1)*IDOT 129 | 116 CONTINUE 130 | IF (NA .EQ. 0) RETURN 131 | N2 = N+N 132 | DO 117 I=1,N2 133 | C(I) = CH(I) 134 | 117 CONTINUE 135 | RETURN 136 | END 137 | 138 | SUBROUTINE DPASSF{{SUF}} (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) 139 | USE ADJAC 140 | IMPLICIT {{TYPE}} (A-H,O-Z) 141 | DIMENSION CH(IDO,L1,IP) , CC(IDO,IP,L1), & 142 | C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), & 143 | CH2(IDL1,IP) 144 | double precision :: wa, war, wai 145 | IDOT = IDO/2 146 | NT = IP*IDL1 147 | IPP2 = IP+2 148 | IPPH = (IP+1)/2 149 | IDP = IP*IDO 150 | 151 | IF (IDO .LT. L1) GO TO 106 152 | DO 103 J=2,IPPH 153 | JC = IPP2-J 154 | DO 102 K=1,L1 155 | DO 101 I=1,IDO 156 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 157 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 158 | 101 CONTINUE 159 | 102 CONTINUE 160 | 103 CONTINUE 161 | DO 105 K=1,L1 162 | DO 104 I=1,IDO 163 | CH(I,K,1) = CC(I,1,K) 164 | 104 CONTINUE 165 | 105 CONTINUE 166 | GO TO 112 167 | 106 DO 109 J=2,IPPH 168 | JC = IPP2-J 169 | DO 108 I=1,IDO 170 | DO 107 K=1,L1 171 | CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) 172 | CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 173 | 107 CONTINUE 174 | 108 CONTINUE 175 | 109 CONTINUE 176 | DO 111 I=1,IDO 177 | DO 110 K=1,L1 178 | CH(I,K,1) = CC(I,1,K) 179 | 110 CONTINUE 180 | 111 CONTINUE 181 | 112 IDL = 2-IDO 182 | INC = 0 183 | DO 116 L=2,IPPH 184 | LC = IPP2-L 185 | IDL = IDL+IDO 186 | DO 113 IK=1,IDL1 187 | C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) 188 | C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 189 | 113 CONTINUE 190 | IDLJ = IDL 191 | INC = INC+IDO 192 | DO 115 J=3,IPPH 193 | JC = IPP2-J 194 | IDLJ = IDLJ+INC 195 | IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP 196 | WAR = WA(IDLJ-1) 197 | WAI = WA(IDLJ) 198 | DO 114 IK=1,IDL1 199 | C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) 200 | C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 201 | 114 CONTINUE 202 | 115 CONTINUE 203 | 116 CONTINUE 204 | DO 118 J=2,IPPH 205 | DO 117 IK=1,IDL1 206 | CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 207 | 117 CONTINUE 208 | 118 CONTINUE 209 | DO 120 J=2,IPPH 210 | JC = IPP2-J 211 | DO 119 IK=2,IDL1,2 212 | CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) 213 | CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) 214 | CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) 215 | CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 216 | 119 CONTINUE 217 | 120 CONTINUE 218 | NAC = 1 219 | IF (IDO .EQ. 2) RETURN 220 | NAC = 0 221 | DO 121 IK=1,IDL1 222 | C2(IK,1) = CH2(IK,1) 223 | 121 CONTINUE 224 | DO 123 J=2,IP 225 | DO 122 K=1,L1 226 | C1(1,K,J) = CH(1,K,J) 227 | C1(2,K,J) = CH(2,K,J) 228 | 122 CONTINUE 229 | 123 CONTINUE 230 | IF (IDOT .GT. L1) GO TO 127 231 | IDIJ = 0 232 | DO 126 J=2,IP 233 | IDIJ = IDIJ+2 234 | DO 125 I=4,IDO,2 235 | IDIJ = IDIJ+2 236 | DO 124 K=1,L1 237 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 238 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 239 | 124 CONTINUE 240 | 125 CONTINUE 241 | 126 CONTINUE 242 | RETURN 243 | 127 IDJ = 2-IDO 244 | DO 130 J=2,IP 245 | IDJ = IDJ+IDO 246 | DO 129 K=1,L1 247 | IDIJ = IDJ 248 | DO 128 I=4,IDO,2 249 | IDIJ = IDIJ+2 250 | C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) 251 | C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 252 | 128 CONTINUE 253 | 129 CONTINUE 254 | 130 CONTINUE 255 | RETURN 256 | END 257 | 258 | SUBROUTINE DPASSF2{{SUF}} (IDO,L1,CC,CH,WA1) 259 | USE ADJAC 260 | IMPLICIT {{TYPE}} (A-H,O-Z) 261 | DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , & 262 | WA1(*) 263 | double precision :: wa1 264 | IF (IDO .GT. 2) GO TO 102 265 | DO 101 K=1,L1 266 | CH(1,K,1) = CC(1,1,K)+CC(1,2,K) 267 | CH(1,K,2) = CC(1,1,K)-CC(1,2,K) 268 | CH(2,K,1) = CC(2,1,K)+CC(2,2,K) 269 | CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 270 | 101 CONTINUE 271 | RETURN 272 | 102 DO 104 K=1,L1 273 | DO 103 I=2,IDO,2 274 | CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) 275 | TR2 = CC(I-1,1,K)-CC(I-1,2,K) 276 | CH(I,K,1) = CC(I,1,K)+CC(I,2,K) 277 | TI2 = CC(I,1,K)-CC(I,2,K) 278 | CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 279 | CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 280 | 103 CONTINUE 281 | 104 CONTINUE 282 | RETURN 283 | END 284 | 285 | SUBROUTINE DPASSF3{{SUF}} (IDO,L1,CC,CH,WA1,WA2) 286 | USE ADJAC 287 | IMPLICIT {{TYPE}} (A-H,O-Z) 288 | DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , & 289 | WA1(*) ,WA2(*) 290 | double precision :: wa1,wa2,TAUR,TAUI 291 | ! *** TAUI IS -SQRT(3)/2 *** 292 | DATA TAUR,TAUI /-0.5D0,-0.86602540378443864676D0/ 293 | IF (IDO .NE. 2) GO TO 102 294 | DO 101 K=1,L1 295 | TR2 = CC(1,2,K)+CC(1,3,K) 296 | CR2 = CC(1,1,K)+TAUR*TR2 297 | CH(1,K,1) = CC(1,1,K)+TR2 298 | TI2 = CC(2,2,K)+CC(2,3,K) 299 | CI2 = CC(2,1,K)+TAUR*TI2 300 | CH(2,K,1) = CC(2,1,K)+TI2 301 | CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) 302 | CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) 303 | CH(1,K,2) = CR2-CI3 304 | CH(1,K,3) = CR2+CI3 305 | CH(2,K,2) = CI2+CR3 306 | CH(2,K,3) = CI2-CR3 307 | 101 CONTINUE 308 | RETURN 309 | 102 DO 104 K=1,L1 310 | DO 103 I=2,IDO,2 311 | TR2 = CC(I-1,2,K)+CC(I-1,3,K) 312 | CR2 = CC(I-1,1,K)+TAUR*TR2 313 | CH(I-1,K,1) = CC(I-1,1,K)+TR2 314 | TI2 = CC(I,2,K)+CC(I,3,K) 315 | CI2 = CC(I,1,K)+TAUR*TI2 316 | CH(I,K,1) = CC(I,1,K)+TI2 317 | CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) 318 | CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) 319 | DR2 = CR2-CI3 320 | DR3 = CR2+CI3 321 | DI2 = CI2+CR3 322 | DI3 = CI2-CR3 323 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 324 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 325 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 326 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 327 | 103 CONTINUE 328 | 104 CONTINUE 329 | RETURN 330 | END 331 | 332 | SUBROUTINE DPASSF4{{SUF}} (IDO,L1,CC,CH,WA1,WA2,WA3) 333 | USE ADJAC 334 | IMPLICIT {{TYPE}} (A-H,O-Z) 335 | DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , & 336 | WA1(*) ,WA2(*) ,WA3(*) 337 | double precision :: wa1, wa2, wa3 338 | IF (IDO .NE. 2) GO TO 102 339 | DO 101 K=1,L1 340 | TI1 = CC(2,1,K)-CC(2,3,K) 341 | TI2 = CC(2,1,K)+CC(2,3,K) 342 | TR4 = CC(2,2,K)-CC(2,4,K) 343 | TI3 = CC(2,2,K)+CC(2,4,K) 344 | TR1 = CC(1,1,K)-CC(1,3,K) 345 | TR2 = CC(1,1,K)+CC(1,3,K) 346 | TI4 = CC(1,4,K)-CC(1,2,K) 347 | TR3 = CC(1,2,K)+CC(1,4,K) 348 | CH(1,K,1) = TR2+TR3 349 | CH(1,K,3) = TR2-TR3 350 | CH(2,K,1) = TI2+TI3 351 | CH(2,K,3) = TI2-TI3 352 | CH(1,K,2) = TR1+TR4 353 | CH(1,K,4) = TR1-TR4 354 | CH(2,K,2) = TI1+TI4 355 | CH(2,K,4) = TI1-TI4 356 | 101 CONTINUE 357 | RETURN 358 | 102 DO 104 K=1,L1 359 | DO 103 I=2,IDO,2 360 | TI1 = CC(I,1,K)-CC(I,3,K) 361 | TI2 = CC(I,1,K)+CC(I,3,K) 362 | TI3 = CC(I,2,K)+CC(I,4,K) 363 | TR4 = CC(I,2,K)-CC(I,4,K) 364 | TR1 = CC(I-1,1,K)-CC(I-1,3,K) 365 | TR2 = CC(I-1,1,K)+CC(I-1,3,K) 366 | TI4 = CC(I-1,4,K)-CC(I-1,2,K) 367 | TR3 = CC(I-1,2,K)+CC(I-1,4,K) 368 | CH(I-1,K,1) = TR2+TR3 369 | CR3 = TR2-TR3 370 | CH(I,K,1) = TI2+TI3 371 | CI3 = TI2-TI3 372 | CR2 = TR1+TR4 373 | CR4 = TR1-TR4 374 | CI2 = TI1+TI4 375 | CI4 = TI1-TI4 376 | CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 377 | CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 378 | CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 379 | CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 380 | CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 381 | CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 382 | 103 CONTINUE 383 | 104 CONTINUE 384 | RETURN 385 | END 386 | 387 | SUBROUTINE DPASSF5{{SUF}} (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) 388 | USE ADJAC 389 | IMPLICIT {{TYPE}} (A-H,O-Z) 390 | DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , & 391 | WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) 392 | double precision :: wa1,wa2,wa3,wa4,TR11,TI11,TR12,TI12 393 | ! *** TR11=COS(2*PI/5), TI11=-SIN(2*PI/5) 394 | ! *** TR12=-COS(4*PI/5), TI12=-SIN(4*PI/5) 395 | DATA TR11,TI11,TR12,TI12 /0.3090169943749474241D0, & 396 | -0.95105651629515357212D0, & 397 | -0.8090169943749474241D0, -0.58778525229247312917D0/ 398 | IF (IDO .NE. 2) GO TO 102 399 | DO 101 K=1,L1 400 | TI5 = CC(2,2,K)-CC(2,5,K) 401 | TI2 = CC(2,2,K)+CC(2,5,K) 402 | TI4 = CC(2,3,K)-CC(2,4,K) 403 | TI3 = CC(2,3,K)+CC(2,4,K) 404 | TR5 = CC(1,2,K)-CC(1,5,K) 405 | TR2 = CC(1,2,K)+CC(1,5,K) 406 | TR4 = CC(1,3,K)-CC(1,4,K) 407 | TR3 = CC(1,3,K)+CC(1,4,K) 408 | CH(1,K,1) = CC(1,1,K)+TR2+TR3 409 | CH(2,K,1) = CC(2,1,K)+TI2+TI3 410 | CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 411 | CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 412 | CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 413 | CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 414 | CR5 = TI11*TR5+TI12*TR4 415 | CI5 = TI11*TI5+TI12*TI4 416 | CR4 = TI12*TR5-TI11*TR4 417 | CI4 = TI12*TI5-TI11*TI4 418 | CH(1,K,2) = CR2-CI5 419 | CH(1,K,5) = CR2+CI5 420 | CH(2,K,2) = CI2+CR5 421 | CH(2,K,3) = CI3+CR4 422 | CH(1,K,3) = CR3-CI4 423 | CH(1,K,4) = CR3+CI4 424 | CH(2,K,4) = CI3-CR4 425 | CH(2,K,5) = CI2-CR5 426 | 101 CONTINUE 427 | RETURN 428 | 102 DO 104 K=1,L1 429 | DO 103 I=2,IDO,2 430 | TI5 = CC(I,2,K)-CC(I,5,K) 431 | TI2 = CC(I,2,K)+CC(I,5,K) 432 | TI4 = CC(I,3,K)-CC(I,4,K) 433 | TI3 = CC(I,3,K)+CC(I,4,K) 434 | TR5 = CC(I-1,2,K)-CC(I-1,5,K) 435 | TR2 = CC(I-1,2,K)+CC(I-1,5,K) 436 | TR4 = CC(I-1,3,K)-CC(I-1,4,K) 437 | TR3 = CC(I-1,3,K)+CC(I-1,4,K) 438 | CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 439 | CH(I,K,1) = CC(I,1,K)+TI2+TI3 440 | CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 441 | CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 442 | CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 443 | CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 444 | CR5 = TI11*TR5+TI12*TR4 445 | CI5 = TI11*TI5+TI12*TI4 446 | CR4 = TI12*TR5-TI11*TR4 447 | CI4 = TI12*TI5-TI11*TI4 448 | DR3 = CR3-CI4 449 | DR4 = CR3+CI4 450 | DI3 = CI3+CR4 451 | DI4 = CI3-CR4 452 | DR5 = CR2+CI5 453 | DR2 = CR2-CI5 454 | DI5 = CI2-CR5 455 | DI2 = CI2+CR5 456 | CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 457 | CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 458 | CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 459 | CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 460 | CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 461 | CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 462 | CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 463 | CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 464 | 103 CONTINUE 465 | 104 CONTINUE 466 | RETURN 467 | END 468 | {{endfor}} 469 | -------------------------------------------------------------------------------- /fftpack/zffti1.f95: -------------------------------------------------------------------------------- 1 | !*DECK CFFTI1 2 | SUBROUTINE ZFFTI1 (N,WA,IFAC) 3 | !***BEGIN PROLOGUE CFFTI1 4 | !***PURPOSE Initialize a real and an integer work array for CFFTF1 and 5 | ! CFFTB1. 6 | !***LIBRARY SLATEC (FFTPACK) 7 | !***CATEGORY J1A2 8 | !***TYPE COMPLEX (RFFTI1-S, CFFTI1-C) 9 | !***KEYWORDS FFTPACK, FOURIER TRANSFORM 10 | !***AUTHOR Swarztrauber, P. N., (NCAR) 11 | !***DESCRIPTION 12 | ! 13 | ! Subroutine CFFTI1 initializes the work arrays WA and IFAC which are 14 | ! used in both CFFTF1 and CFFTB1. The prime factorization of N and a 15 | ! tabulation of the trigonometric functions are computed and stored in 16 | ! IFAC and WA, respectively. 17 | ! 18 | ! Input Parameter 19 | ! 20 | ! N the length of the sequence to be transformed 21 | ! 22 | ! Output Parameters 23 | ! 24 | ! WA a real work array which must be dimensioned at least 2*N. 25 | ! 26 | ! IFAC an integer work array which must be dimensioned at least 15. 27 | ! 28 | ! The same work arrays can be used for both CFFTF1 and CFFTB1 29 | ! as long as N remains unchanged. Different WA and IFAC arrays 30 | ! are required for different values of N. The contents of 31 | ! WA and IFAC must not be changed between calls of CFFTF1 or 32 | ! CFFTB1. 33 | ! 34 | !***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel 35 | ! Computations (G. Rodrigue, ed.), Academic Press, 36 | ! 1982, pp. 51-83. 37 | !***ROUTINES CALLED (NONE) 38 | !***REVISION HISTORY (YYMMDD) 39 | ! 790601 DATE WRITTEN 40 | ! 830401 Modified to use SLATEC library source file format. 41 | ! 860115 Modified by Ron Boisvert to adhere to Fortran 77 by 42 | ! (a) changing dummy array size declarations (1) to (*), 43 | ! (b) changing references to intrinsic function FLOAT 44 | ! to REAL, and 45 | ! (c) changing definition of variable TPI by using 46 | ! FORTRAN intrinsic function ATAN instead of a DATA 47 | ! statement. 48 | ! 881128 Modified by Dick Valent to meet prologue standards. 49 | ! 890531 Changed all specific intrinsics to generic. (WRB) 50 | ! 891214 Prologue converted to Version 4.0 format. (BAB) 51 | ! 900131 Routine changed from subsidiary to user-callable. (WRB) 52 | ! 920501 Reformatted the REFERENCES section. (WRB) 53 | !***END PROLOGUE CFFTI1 54 | IMPLICIT DOUBLE PRECISION (A-H,O-Z) 55 | DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) 56 | DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ 57 | !***FIRST EXECUTABLE STATEMENT CFFTI1 58 | NL = N 59 | NF = 0 60 | J = 0 61 | 101 J = J+1 62 | IF (J.le.4) GO TO 102 63 | GO TO 103 64 | 102 NTRY = NTRYH(J) 65 | GO TO 104 66 | 103 NTRY = NTRYH(4)+2*(J-4) 67 | 104 NQ = NL/NTRY 68 | NR = NL-NTRY*NQ 69 | IF (NR.eq.0) GO TO 105 70 | GO TO 101 71 | 105 NF = NF+1 72 | IFAC(NF+2) = NTRY 73 | NL = NQ 74 | IF (NTRY .NE. 2) GO TO 107 75 | IF (NF .EQ. 1) GO TO 107 76 | DO 106 I=2,NF 77 | IB = NF-I+2 78 | IFAC(IB+2) = IFAC(IB+1) 79 | 106 CONTINUE 80 | IFAC(3) = 2 81 | 107 IF (NL .NE. 1) GO TO 104 82 | IFAC(1) = N 83 | IFAC(2) = NF 84 | TPI = 6.28318530717958647692D0 85 | ARGH = TPI/FLOAT(N) 86 | I = 2 87 | L1 = 1 88 | DO 110 K1=1,NF 89 | IP = IFAC(K1+2) 90 | LD = 0 91 | L2 = L1*IP 92 | IDO = N/L2 93 | IDOT = IDO+IDO+2 94 | IPM = IP-1 95 | DO 109 J=1,IPM 96 | I1 = I 97 | WA(I-1) = 1.0D0 98 | WA(I) = 0.0D0 99 | LD = LD+L1 100 | FI = 0.0D0 101 | ARGLD = FLOAT(LD)*ARGH 102 | DO 108 II=4,IDOT,2 103 | I = I+2 104 | FI = FI+1.D0 105 | ARG = FI*ARGLD 106 | WA(I-1) = COS(ARG) 107 | WA(I) = SIN(ARG) 108 | 108 CONTINUE 109 | IF (IP .LE. 5) GO TO 109 110 | WA(I1-1) = WA(I-1) 111 | WA(I1) = WA(I) 112 | 109 CONTINUE 113 | L1 = L2 114 | 110 CONTINUE 115 | RETURN 116 | END 117 | -------------------------------------------------------------------------------- /generate.py: -------------------------------------------------------------------------------- 1 | """ 2 | generate.py SRC DST 3 | """ 4 | import sys 5 | import os 6 | import argparse 7 | try: 8 | import tempita 9 | except ImportError: 10 | import Cython.Tempita as tempita 11 | 12 | 13 | def define_symbol(string): 14 | try: 15 | key, value = string.split('=', 1) 16 | return key, eval(value) 17 | except: 18 | raise argparse.ArgumentError("%r is not of the form key=value" % (string,)) 19 | 20 | 21 | def main(): 22 | p = argparse.ArgumentParser(usage=__doc__.strip()) 23 | p.add_argument('-D', '--define', type=define_symbol, action="append", default=[], 24 | metavar="NAME=VALUE", help="define a symbol in template") 25 | p.add_argument('src') 26 | p.add_argument('dst') 27 | args = p.parse_args() 28 | 29 | defines = dict(args.define) 30 | process(args.src, args.dst, defines) 31 | 32 | 33 | def process(src, dst, defines): 34 | with open(src, 'r') as f: 35 | text = f.read() 36 | tmpl = tempita.Template(text) 37 | out = tmpl.substitute(defines) 38 | 39 | src = os.path.basename(src) 40 | with open(dst, 'w') as f: 41 | if dst.endswith('.f95'): 42 | f.write("!! NOTE: this file is autogenerated from {}: do not edit manually\n".format(src)) 43 | else: 44 | f.write("/* NOTE: this file is autogenerated from {}: do not edit manually */\n".format(src)) 45 | f.write(out) 46 | 47 | sys.exit(0) 48 | 49 | 50 | if __name__ == "__main__": 51 | main() 52 | -------------------------------------------------------------------------------- /tests/test_abs.f95: -------------------------------------------------------------------------------- 1 | include 'testutil.i' 2 | 3 | program test_sqrt 4 | implicit none 5 | write(*,*) '-- a' 6 | call test_sqrt_a() 7 | write(*,*) '-- b' 8 | call test_sqrt_b() 9 | end program test_sqrt 10 | 11 | subroutine test_sqrt_a() 12 | use adjac 13 | use testutil 14 | implicit none 15 | 16 | double precision :: x_value, res_value(1), res_dvalue(1,1) 17 | type(adjac_double) :: x(1), res(1) 18 | 19 | call adjac_reset() 20 | 21 | x_value = -4d0 22 | call adjac_set_independent(x(1), x_value, 1) 23 | 24 | res = abs(x) 25 | 26 | call adjac_get_value(res, res_value) 27 | call adjac_get_dense_jacobian(res, res_dvalue) 28 | 29 | write(*,*) 'res =', res_value 30 | call assert_equal(res_value(1), abs(x_value)) 31 | 32 | write(*,*) 'jac =', res_dvalue 33 | call assert_equal(res_dvalue(1,1), -1d0) 34 | end subroutine test_sqrt_a 35 | 36 | subroutine test_sqrt_b() 37 | use adjac 38 | use testutil 39 | implicit none 40 | 41 | double complex :: x_value 42 | double precision :: res_value(1), res_dvalue(1,2) 43 | type(adjac_double) :: x_parts(2) 44 | type(adjac_complex) :: x(1) 45 | type(adjac_double) :: res(1) 46 | 47 | call adjac_reset() 48 | 49 | x_value = (3d0, 4d0) 50 | 51 | call adjac_set_independent(x_parts(1), dble(x_value), 1) 52 | call adjac_set_independent(x_parts(2), aimag(x_value), 2) 53 | 54 | x(1)%re = x_parts(1) 55 | x(1)%im = x_parts(2) 56 | 57 | res = abs(x) 58 | 59 | call adjac_get_value(res, res_value) 60 | call adjac_get_dense_jacobian(res, res_dvalue) 61 | 62 | write(*,*) 'res =', res_value 63 | call assert_equal(res_value(1), abs(x_value)) 64 | 65 | write(*,*) 'jac =', res_dvalue 66 | call assert_equal(res_dvalue(1,1), dble(x_value) / abs(x_value)) 67 | call assert_equal(res_dvalue(1,2), aimag(x_value) / abs(x_value)) 68 | end subroutine test_sqrt_b 69 | -------------------------------------------------------------------------------- /tests/test_fft.f95: -------------------------------------------------------------------------------- 1 | program test_fft 2 | use adjac 3 | use adjac_fft 4 | implicit none 5 | 6 | integer, parameter :: n = 127 7 | type(adjac_double), dimension(2,2*n,3) :: x 8 | double precision, dimension(2,2*n,3) :: x_value 9 | double precision, dimension(2*n,2*n) :: jac 10 | complex(kind=kind(0d0)) :: v1, v2 11 | integer :: i, j 12 | 13 | do i = 1, n 14 | x_value(1,2*i-1,2) = 1 + i + i**2 15 | x_value(1,2*i,2) = 0 16 | call adjac_set_independent(x(1,2*i-1,2), x_value(1,2*i-1,2), 2*i-1) 17 | call adjac_set_independent(x(1,2*i,2), x_value(1,2*i,2), 2*i) 18 | end do 19 | 20 | write(*,*) 'forward transform' 21 | call fft(x_value(1,:,2)) 22 | call fft(x(1,:,2)) 23 | call adjac_get_dense_jacobian(x(1,:,2), jac) 24 | 25 | do i = 1, n 26 | v1 = x(1,i,2)%value 27 | v2 = x_value(1,i,2) 28 | if (abs(v1 - v2) > 1d-10) then 29 | write(*,*) 'FAIL', i, v1, v2 30 | stop 31 | end if 32 | do j = 1, n 33 | v1 = jac(2*i-1,2*j-1) + (0,1)*jac(2*i,2*j-1) 34 | v2 = exp(-2*(0,3.141592653589793d0)*(i-1)*(j-1)/n) 35 | if (abs(v1 - v2) > 1d-10) then 36 | write(*,*) 'FAIL', i, j, v1, v2 37 | stop 38 | end if 39 | end do 40 | end do 41 | write(*,*) 'OK' 42 | 43 | write(*,*) 'inverse transform' 44 | call ifft(x_value(1,:,2)) 45 | call ifft(x(1,:,2)) 46 | call adjac_get_dense_jacobian(x(1,:,2), jac) 47 | 48 | do i = 1, n 49 | if (mod(i,2) == 1) then 50 | v2 = 1 + (1 + i/2) + (1 + i/2)**2 51 | else 52 | v2 = 0 53 | end if 54 | 55 | v1 = x(1,i,2)%value 56 | if (abs(v1 - v2) > 1d-10) then 57 | write(*,*) 'FAIL', 'avalue', i, v1, v2 58 | stop 59 | end if 60 | 61 | v2 = x_value(1,i,2) 62 | if (abs(v1 - v2) > 1d-10) then 63 | write(*,*) 'FAIL', 'value', i, v1, v2 64 | stop 65 | end if 66 | 67 | do j = 1, n 68 | v1 = jac(2*i-1,2*j-1) + (0,1)*jac(2*i,2*j-1) 69 | if (i == j) then 70 | v2 = 1 71 | else 72 | v2 = 0 73 | end if 74 | if (abs(v1 - v2) > 1d-10) then 75 | write(*,*) 'FAIL', i, j, v1, v2 76 | stop 77 | end if 78 | end do 79 | end do 80 | write(*,*) 'OK' 81 | end program test_fft 82 | -------------------------------------------------------------------------------- /tests/test_laplacian.cmp: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | test_laplacian 3 | -------------------------------------------- 4 | 1.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 5.0000000000000000 5 | 1.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 6 | 1.0000000000000000 -2.0000000000000000 1.0000000000000000 0.0000000000000000 0.0000000000000000 7 | 0.0000000000000000 1.0000000000000000 -2.0000000000000000 1.0000000000000000 0.0000000000000000 8 | 0.0000000000000000 0.0000000000000000 1.0000000000000000 -2.0000000000000000 1.0000000000000000 9 | 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 1.0000000000000000 10 | -- COO laplacian 11 | 4 5 1.00000000 12 | 5 5 1.00000000 13 | 3 4 1.00000000 14 | 4 4 -2.00000000 15 | 2 3 1.00000000 16 | 3 3 -2.00000000 17 | 4 3 1.00000000 18 | 2 2 -2.00000000 19 | 3 2 1.00000000 20 | 1 1 1.00000000 21 | 2 1 1.00000000 22 | jac product OK 23 | -------------------------------------------------------------------------------- /tests/test_laplacian.f95: -------------------------------------------------------------------------------- 1 | include 'testutil.i' 2 | 3 | program test_laplacian 4 | use adjac 5 | use testutil 6 | implicit none 7 | 8 | integer, parameter :: n = 5 9 | 10 | double precision, dimension(n) :: y_value 11 | double precision, dimension(n,n) :: jac 12 | double precision, allocatable, dimension(:) :: jac_val 13 | integer, allocatable, dimension(:) :: jac_i, jac_j 14 | 15 | double precision, dimension(n) :: p, xval, dy, dy2 16 | type(adjac_double), dimension(n) :: x 17 | type(adjac_double), dimension(n) :: y 18 | integer i, j, nnz 19 | 20 | call adjac_reset() 21 | do j = 1, n 22 | call adjac_set_independent(x(j), dble(j), j) 23 | end do 24 | 25 | ! Some calculation, for example the Laplacian plus nonlinearity 26 | call laplacian(x, y) 27 | call adjac_get_value(y, y_value) 28 | write(*,*) y_value 29 | 30 | ! Dense jacobian 31 | call adjac_get_dense_jacobian(y, jac) 32 | do i = 1, n 33 | write(*,*) jac(i,:) 34 | end do 35 | 36 | ! Obtain jacobian in sparse coordinate (i, j, value) format 37 | write(*,*) '-- COO laplacian' 38 | call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j) 39 | do j = 1, nnz 40 | write(*,*) jac_i(j), jac_j(j), real(jac_val(j)) 41 | end do 42 | 43 | ! Evaluate jacobian-vector products 44 | do j = 1, n 45 | p(j) = 1d0/(1 + j) 46 | xval(j) = dble(j) 47 | end do 48 | call adjac_reset(.true.) 49 | call adjac_set_independent(x, xval, p) 50 | call laplacian(x, y) 51 | call adjac_get_value(y, y_value, dy) 52 | dy2 = matmul(jac, p) 53 | 54 | if (maxval(abs(dy - dy2)) > 1d-12) then 55 | write(*,*) 'jac product FAIL' 56 | else 57 | write(*,*) 'jac product OK' 58 | end if 59 | contains 60 | subroutine laplacian(x, y) 61 | implicit none 62 | type(adjac_double), dimension(:), intent(in) :: x 63 | type(adjac_double), dimension(:), intent(out) :: y 64 | integer :: n 65 | n = size(x) 66 | y(1) = x(1) 67 | y(n) = x(n) 68 | do j = 2, n-1 69 | y(j) = x(j-1) - 2d0*x(j) + x(j+1) 70 | end do 71 | end subroutine laplacian 72 | end program test_laplacian 73 | -------------------------------------------------------------------------------- /tests/test_laplacian.test_tapeless.cmp: -------------------------------------------------------------------------------- 1 | -------------------------------------------- 2 | test_laplacian 3 | -------------------------------------------- 4 | 1.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 5.0000000000000000 5 | 1.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 6 | 1.0000000000000000 -2.0000000000000000 1.0000000000000000 0.0000000000000000 0.0000000000000000 7 | 0.0000000000000000 1.0000000000000000 -2.0000000000000000 1.0000000000000000 0.0000000000000000 8 | 0.0000000000000000 0.0000000000000000 1.0000000000000000 -2.0000000000000000 1.0000000000000000 9 | 0.0000000000000000 0.0000000000000000 0.0000000000000000 0.0000000000000000 1.0000000000000000 10 | -- COO laplacian 11 | 1 1 1.00000000 12 | 2 1 1.00000000 13 | 2 2 -2.00000000 14 | 2 3 1.00000000 15 | 3 2 1.00000000 16 | 3 3 -2.00000000 17 | 3 4 1.00000000 18 | 4 3 1.00000000 19 | 4 4 -2.00000000 20 | 4 5 1.00000000 21 | 5 5 1.00000000 22 | jac product OK 23 | -------------------------------------------------------------------------------- /tests/test_sqrt.f95: -------------------------------------------------------------------------------- 1 | include 'testutil.i' 2 | 3 | program test_sqrt 4 | implicit none 5 | write(*,*) '-- a' 6 | call test_sqrt_a() 7 | write(*,*) '-- b' 8 | call test_sqrt_b() 9 | write(*,*) '-- q' 10 | call test_sqrt_q() 11 | end program test_sqrt 12 | 13 | subroutine test_sqrt_a() 14 | use adjac 15 | use testutil 16 | implicit none 17 | 18 | double precision :: x_value, res_value(1), res_dvalue(1,1) 19 | type(adjac_double) :: x(1), res(1) 20 | 21 | call adjac_reset() 22 | 23 | x_value = 4d0 24 | call adjac_set_independent(x(1), x_value, 1) 25 | 26 | res = sqrt(x) 27 | 28 | call adjac_get_value(res, res_value) 29 | call adjac_get_dense_jacobian(res, res_dvalue) 30 | 31 | write(*,*) 'res =', res_value 32 | call assert_equal(res_value(1), sqrt(x_value)) 33 | 34 | write(*,*) 'jac =', res_dvalue 35 | call assert_equal(res_dvalue(1,1), 0.5d0/sqrt(x_value)) 36 | end subroutine test_sqrt_a 37 | 38 | subroutine test_sqrt_b() 39 | use adjac 40 | use testutil 41 | implicit none 42 | 43 | double complex :: x_value 44 | double precision :: res_value(2), res_dvalue(2,2) 45 | type(adjac_double) :: x_parts(2), res_parts(2) 46 | type(adjac_complex) :: x(1), res(1) 47 | 48 | call adjac_reset() 49 | 50 | x_value = (3d0, 4d0) 51 | 52 | call adjac_set_independent(x_parts(1), dble(x_value), 1) 53 | call adjac_set_independent(x_parts(2), aimag(x_value), 2) 54 | 55 | x(1)%re = x_parts(1) 56 | x(1)%im = x_parts(2) 57 | 58 | res = sqrt(x) 59 | 60 | res_parts(1) = res(1)%re 61 | res_parts(2) = res(1)%im 62 | 63 | call adjac_get_value(res_parts, res_value) 64 | call adjac_get_dense_jacobian(res_parts, res_dvalue) 65 | 66 | write(*,*) 'res =', res_value 67 | call assert_equal(res_value(1), dble(sqrt(x_value))) 68 | call assert_equal(res_value(2), aimag(sqrt(x_value))) 69 | 70 | write(*,*) 'jac =', res_dvalue 71 | call assert_equal(res_dvalue(1,1), dble(0.5d0/sqrt(x_value))) 72 | call assert_equal(res_dvalue(1,2), -aimag(0.5d0/sqrt(x_value))) 73 | call assert_equal(res_dvalue(2,1), aimag(0.5d0/sqrt(x_value))) 74 | call assert_equal(res_dvalue(2,2), dble(0.5d0/sqrt(x_value))) 75 | end subroutine test_sqrt_b 76 | 77 | subroutine test_sqrt_q() 78 | use adjac 79 | use testutil 80 | implicit none 81 | 82 | double complex :: x_value, res_value(1), res_dvalue(1,1) 83 | type(adjac_complexan) :: x(1), res(1) 84 | 85 | call adjac_reset() 86 | 87 | x_value = (3d0, 4d0) 88 | 89 | call adjac_set_independent(x(1), x_value, 1) 90 | 91 | res = sqrt(x) 92 | 93 | call adjac_get_value(res, res_value) 94 | call adjac_get_dense_jacobian(res, res_dvalue) 95 | 96 | write(*,*) 'res =', res_value 97 | call assert_equal(res_value(1), sqrt(x_value)) 98 | 99 | write(*,*) 'jac =', res_dvalue 100 | call assert_equal(res_dvalue(1,1), 0.5d0/sqrt(x_value)) 101 | end subroutine test_sqrt_q 102 | -------------------------------------------------------------------------------- /tests/testutil.i: -------------------------------------------------------------------------------- 1 | ! -*-f90-*- 2 | module testutil 3 | double precision, parameter :: default_eps = 1d-8 4 | 5 | interface assert_equal 6 | module procedure assert_equal_i, assert_equal_d, assert_equal_z 7 | end interface 8 | 9 | interface assert_close 10 | module procedure assert_close_i, assert_close_d, assert_close_z 11 | end interface 12 | 13 | contains 14 | 15 | subroutine assert_equal_i(a, b) 16 | implicit none 17 | integer, intent(in) :: a, b 18 | if (a.ne.b) then 19 | write(*,*) 'FAIL', a, '!=', b 20 | end if 21 | end subroutine assert_equal_i 22 | 23 | subroutine assert_equal_d(a, b) 24 | implicit none 25 | double precision, intent(in) :: a, b 26 | if (a.ne.b) then 27 | write(*,*) 'FAIL', a, '!=', b 28 | end if 29 | end subroutine assert_equal_d 30 | 31 | subroutine assert_equal_z(a, b) 32 | implicit none 33 | complex(kind=kind(0d0)), intent(in) :: a, b 34 | if (a.ne.b) then 35 | write(*,*) 'FAIL', a, '!=', b 36 | end if 37 | end subroutine assert_equal_z 38 | 39 | subroutine assert_close_i(a, b) 40 | implicit none 41 | integer, intent(in) :: a, b 42 | double precision :: eps = default_eps 43 | if (abs(a-b).gt.eps) then 44 | write(*,*) 'FAIL', a, '!=', b, '+-', eps 45 | end if 46 | end subroutine assert_close_i 47 | 48 | subroutine assert_close_d(a, b) 49 | implicit none 50 | double precision, intent(in) :: a, b 51 | double precision :: eps = default_eps 52 | if (abs(a-b).gt.eps) then 53 | write(*,*) 'FAIL', a, '!=', b, '+-', eps 54 | end if 55 | end subroutine assert_close_d 56 | 57 | subroutine assert_close_z(a, b) 58 | implicit none 59 | complex(kind=kind(0d0)), intent(in) :: a, b 60 | double precision :: eps = default_eps 61 | if (abs(a-b).gt.eps) then 62 | write(*,*) 'FAIL', a, '!=', b, '+-', eps 63 | end if 64 | end subroutine assert_close_z 65 | end module testutil 66 | --------------------------------------------------------------------------------