#include "cppdefs.h" ! MODULE fftpack51 #ifdef INWAVE_SWAN_COUPLING ! !svn $Id: fftpack51.F 830 2017-01-24 21:21:11Z jcwarner $ !======================================================================= ! Copyright (c) 2002-2017 The ROMS/TOMS Group ! ! Licensed under a MIT/X style license ! ! See License_ROMS.txt ! ! Submitted by John C. Warner and Maitane Olabarrieta ! !======================================================================= ! ! ! MODULE CONTAINS: ! ! This is an open source fft code obtained from ! !https://people.sc.fsu.edu/~jburkardt/f_src/fftpack5.1d/fftpack5.1d.f90! ! Licensed under the GNU General Public License (GPL). ! ! Copyright (C) 1995-2004, Scientific Computing Division, ! ! University Corporation for Atmospheric Research ! ! !======================================================================= ! ! IMPLICIT NONE ! PRIVATE ! PUBLIC:: ! CONTAINS ! !*********************************************************************** ! subroutine c1f2kb ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F2KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,2) real ( kind = 8 ) ch(in2,l1,2,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,1,2) if ( ido <= 1 .and. na /= 1 ) then do k = 1, l1 chold1 = cc(1,k,1,1)+cc(1,k,1,2) cc(1,k,1,2) = cc(1,k,1,1)-cc(1,k,1,2) cc(1,k,1,1) = chold1 chold2 = cc(2,k,1,1)+cc(2,k,1,2) cc(2,k,1,2) = cc(2,k,1,1)-cc(2,k,1,2) cc(2,k,1,1) = chold2 end do return end if do k = 1, l1 ch(1,k,1,1) = cc(1,k,1,1)+cc(1,k,1,2) ch(1,k,2,1) = cc(1,k,1,1)-cc(1,k,1,2) ch(2,k,1,1) = cc(2,k,1,1)+cc(2,k,1,2) ch(2,k,2,1) = cc(2,k,1,1)-cc(2,k,1,2) end do do i = 2, ido do k = 1, l1 ch(1,k,1,i) = cc(1,k,i,1)+cc(1,k,i,2) tr2 = cc(1,k,i,1)-cc(1,k,i,2) ch(2,k,1,i) = cc(2,k,i,1)+cc(2,k,i,2) ti2 = cc(2,k,i,1)-cc(2,k,i,2) ch(2,k,2,i) = wa(i,1,1)*ti2+wa(i,1,2)*tr2 ch(1,k,2,i) = wa(i,1,1)*tr2-wa(i,1,2)*ti2 end do end do return end subroutine c1f2kf ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F2KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,2) real ( kind = 8 ) ch(in2,l1,2,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,1,2) if ( ido <= 1 ) then sn = 1.0D+00 / real ( 2 * l1, kind = 8 ) if ( na == 1 ) then do k = 1, l1 ch(1,k,1,1) = sn*(cc(1,k,1,1)+cc(1,k,1,2)) ch(1,k,2,1) = sn*(cc(1,k,1,1)-cc(1,k,1,2)) ch(2,k,1,1) = sn*(cc(2,k,1,1)+cc(2,k,1,2)) ch(2,k,2,1) = sn*(cc(2,k,1,1)-cc(2,k,1,2)) end do else do k = 1, l1 chold1 = sn*(cc(1,k,1,1)+cc(1,k,1,2)) cc(1,k,1,2) = sn*(cc(1,k,1,1)-cc(1,k,1,2)) cc(1,k,1,1) = chold1 chold2 = sn*(cc(2,k,1,1)+cc(2,k,1,2)) cc(2,k,1,2) = sn*(cc(2,k,1,1)-cc(2,k,1,2)) cc(2,k,1,1) = chold2 end do end if else do k = 1, l1 ch(1,k,1,1) = cc(1,k,1,1)+cc(1,k,1,2) ch(1,k,2,1) = cc(1,k,1,1)-cc(1,k,1,2) ch(2,k,1,1) = cc(2,k,1,1)+cc(2,k,1,2) ch(2,k,2,1) = cc(2,k,1,1)-cc(2,k,1,2) end do do i = 2, ido do k = 1, l1 ch(1,k,1,i) = cc(1,k,i,1)+cc(1,k,i,2) tr2 = cc(1,k,i,1)-cc(1,k,i,2) ch(2,k,1,i) = cc(2,k,i,1)+cc(2,k,i,2) ti2 = cc(2,k,i,1)-cc(2,k,i,2) ch(2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2 ch(1,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2 end do end do end if return end subroutine c1f3kb ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F3KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,3) real ( kind = 8 ) ch(in2,l1,3,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ), parameter :: taui = 0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,2,2) if ( ido <= 1 .and. na /= 1 ) then do k = 1, l1 tr2 = cc(1,k,1,2)+cc(1,k,1,3) cr2 = cc(1,k,1,1)+taur*tr2 cc(1,k,1,1) = cc(1,k,1,1)+tr2 ti2 = cc(2,k,1,2)+cc(2,k,1,3) ci2 = cc(2,k,1,1)+taur*ti2 cc(2,k,1,1) = cc(2,k,1,1)+ti2 cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3)) ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3)) cc(1,k,1,2) = cr2-ci3 cc(1,k,1,3) = cr2+ci3 cc(2,k,1,2) = ci2+cr3 cc(2,k,1,3) = ci2-cr3 end do else do k = 1, l1 tr2 = cc(1,k,1,2)+cc(1,k,1,3) cr2 = cc(1,k,1,1)+taur*tr2 ch(1,k,1,1) = cc(1,k,1,1)+tr2 ti2 = cc(2,k,1,2)+cc(2,k,1,3) ci2 = cc(2,k,1,1)+taur*ti2 ch(2,k,1,1) = cc(2,k,1,1)+ti2 cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3)) ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3)) ch(1,k,2,1) = cr2-ci3 ch(1,k,3,1) = cr2+ci3 ch(2,k,2,1) = ci2+cr3 ch(2,k,3,1) = ci2-cr3 end do do i = 2, ido do k = 1, l1 tr2 = cc(1,k,i,2)+cc(1,k,i,3) cr2 = cc(1,k,i,1)+taur*tr2 ch(1,k,1,i) = cc(1,k,i,1)+tr2 ti2 = cc(2,k,i,2)+cc(2,k,i,3) ci2 = cc(2,k,i,1)+taur*ti2 ch(2,k,1,i) = cc(2,k,i,1)+ti2 cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3)) ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3)) dr2 = cr2-ci3 dr3 = cr2+ci3 di2 = ci2+cr3 di3 = ci2-cr3 ch(2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2 ch(1,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2 ch(2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3 ch(1,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3 end do end do end if return end subroutine c1f3kf ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F3KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,3) real ( kind = 8 ) ch(in2,l1,3,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ), parameter :: taui = -0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,2,2) if ( ido <= 1 ) then sn = 1.0D+00 / real ( 3 * l1, kind = 8 ) if ( na /= 1 ) then do k = 1, l1 tr2 = cc(1,k,1,2)+cc(1,k,1,3) cr2 = cc(1,k,1,1)+taur*tr2 cc(1,k,1,1) = sn*(cc(1,k,1,1)+tr2) ti2 = cc(2,k,1,2)+cc(2,k,1,3) ci2 = cc(2,k,1,1)+taur*ti2 cc(2,k,1,1) = sn*(cc(2,k,1,1)+ti2) cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3)) ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3)) cc(1,k,1,2) = sn*(cr2-ci3) cc(1,k,1,3) = sn*(cr2+ci3) cc(2,k,1,2) = sn*(ci2+cr3) cc(2,k,1,3) = sn*(ci2-cr3) end do else do k = 1, l1 tr2 = cc(1,k,1,2)+cc(1,k,1,3) cr2 = cc(1,k,1,1)+taur*tr2 ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2) ti2 = cc(2,k,1,2)+cc(2,k,1,3) ci2 = cc(2,k,1,1)+taur*ti2 ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2) cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3)) ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3)) ch(1,k,2,1) = sn*(cr2-ci3) ch(1,k,3,1) = sn*(cr2+ci3) ch(2,k,2,1) = sn*(ci2+cr3) ch(2,k,3,1) = sn*(ci2-cr3) end do end if else do k = 1, l1 tr2 = cc(1,k,1,2)+cc(1,k,1,3) cr2 = cc(1,k,1,1)+taur*tr2 ch(1,k,1,1) = cc(1,k,1,1)+tr2 ti2 = cc(2,k,1,2)+cc(2,k,1,3) ci2 = cc(2,k,1,1)+taur*ti2 ch(2,k,1,1) = cc(2,k,1,1)+ti2 cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3)) ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3)) ch(1,k,2,1) = cr2-ci3 ch(1,k,3,1) = cr2+ci3 ch(2,k,2,1) = ci2+cr3 ch(2,k,3,1) = ci2-cr3 end do do i = 2, ido do k = 1, l1 tr2 = cc(1,k,i,2)+cc(1,k,i,3) cr2 = cc(1,k,i,1)+taur*tr2 ch(1,k,1,i) = cc(1,k,i,1)+tr2 ti2 = cc(2,k,i,2)+cc(2,k,i,3) ci2 = cc(2,k,i,1)+taur*ti2 ch(2,k,1,i) = cc(2,k,i,1)+ti2 cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3)) ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3)) dr2 = cr2-ci3 dr3 = cr2+ci3 di2 = ci2+cr3 di3 = ci2-cr3 ch(2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2 ch(1,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2 ch(2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3 ch(1,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3 end do end do end if return end subroutine c1f4kb ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F4KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,4) real ( kind = 8 ) ch(in2,l1,4,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa(ido,3,2) if ( ido <= 1 .and. na /= 1 ) then do k = 1, l1 ti1 = cc(2,k,1,1)-cc(2,k,1,3) ti2 = cc(2,k,1,1)+cc(2,k,1,3) tr4 = cc(2,k,1,4)-cc(2,k,1,2) ti3 = cc(2,k,1,2)+cc(2,k,1,4) tr1 = cc(1,k,1,1)-cc(1,k,1,3) tr2 = cc(1,k,1,1)+cc(1,k,1,3) ti4 = cc(1,k,1,2)-cc(1,k,1,4) tr3 = cc(1,k,1,2)+cc(1,k,1,4) cc(1,k,1,1) = tr2+tr3 cc(1,k,1,3) = tr2-tr3 cc(2,k,1,1) = ti2+ti3 cc(2,k,1,3) = ti2-ti3 cc(1,k,1,2) = tr1+tr4 cc(1,k,1,4) = tr1-tr4 cc(2,k,1,2) = ti1+ti4 cc(2,k,1,4) = ti1-ti4 end do else do k = 1, l1 ti1 = cc(2,k,1,1)-cc(2,k,1,3) ti2 = cc(2,k,1,1)+cc(2,k,1,3) tr4 = cc(2,k,1,4)-cc(2,k,1,2) ti3 = cc(2,k,1,2)+cc(2,k,1,4) tr1 = cc(1,k,1,1)-cc(1,k,1,3) tr2 = cc(1,k,1,1)+cc(1,k,1,3) ti4 = cc(1,k,1,2)-cc(1,k,1,4) tr3 = cc(1,k,1,2)+cc(1,k,1,4) ch(1,k,1,1) = tr2+tr3 ch(1,k,3,1) = tr2-tr3 ch(2,k,1,1) = ti2+ti3 ch(2,k,3,1) = ti2-ti3 ch(1,k,2,1) = tr1+tr4 ch(1,k,4,1) = tr1-tr4 ch(2,k,2,1) = ti1+ti4 ch(2,k,4,1) = ti1-ti4 end do do i = 2, ido do k = 1, l1 ti1 = cc(2,k,i,1)-cc(2,k,i,3) ti2 = cc(2,k,i,1)+cc(2,k,i,3) ti3 = cc(2,k,i,2)+cc(2,k,i,4) tr4 = cc(2,k,i,4)-cc(2,k,i,2) tr1 = cc(1,k,i,1)-cc(1,k,i,3) tr2 = cc(1,k,i,1)+cc(1,k,i,3) ti4 = cc(1,k,i,2)-cc(1,k,i,4) tr3 = cc(1,k,i,2)+cc(1,k,i,4) ch(1,k,1,i) = tr2+tr3 cr3 = tr2-tr3 ch(2,k,1,i) = ti2+ti3 ci3 = ti2-ti3 cr2 = tr1+tr4 cr4 = tr1-tr4 ci2 = ti1+ti4 ci4 = ti1-ti4 ch(1,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2 ch(2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2 ch(1,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3 ch(2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3 ch(1,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4 ch(2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4 end do end do end if return end subroutine c1f4kf ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F4KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,4) real ( kind = 8 ) ch(in2,l1,4,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa(ido,3,2) if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 4 * l1, kind = 8 ) if (na == 1) go to 106 do k = 1, l1 ti1 = cc(2,k,1,1)-cc(2,k,1,3) ti2 = cc(2,k,1,1)+cc(2,k,1,3) tr4 = cc(2,k,1,2)-cc(2,k,1,4) ti3 = cc(2,k,1,2)+cc(2,k,1,4) tr1 = cc(1,k,1,1)-cc(1,k,1,3) tr2 = cc(1,k,1,1)+cc(1,k,1,3) ti4 = cc(1,k,1,4)-cc(1,k,1,2) tr3 = cc(1,k,1,2)+cc(1,k,1,4) cc(1,k,1,1) = sn*(tr2+tr3) cc(1,k,1,3) = sn*(tr2-tr3) cc(2,k,1,1) = sn*(ti2+ti3) cc(2,k,1,3) = sn*(ti2-ti3) cc(1,k,1,2) = sn*(tr1+tr4) cc(1,k,1,4) = sn*(tr1-tr4) cc(2,k,1,2) = sn*(ti1+ti4) cc(2,k,1,4) = sn*(ti1-ti4) end do return 106 do 107 k = 1, l1 ti1 = cc(2,k,1,1)-cc(2,k,1,3) ti2 = cc(2,k,1,1)+cc(2,k,1,3) tr4 = cc(2,k,1,2)-cc(2,k,1,4) ti3 = cc(2,k,1,2)+cc(2,k,1,4) tr1 = cc(1,k,1,1)-cc(1,k,1,3) tr2 = cc(1,k,1,1)+cc(1,k,1,3) ti4 = cc(1,k,1,4)-cc(1,k,1,2) tr3 = cc(1,k,1,2)+cc(1,k,1,4) ch(1,k,1,1) = sn*(tr2+tr3) ch(1,k,3,1) = sn*(tr2-tr3) ch(2,k,1,1) = sn*(ti2+ti3) ch(2,k,3,1) = sn*(ti2-ti3) ch(1,k,2,1) = sn*(tr1+tr4) ch(1,k,4,1) = sn*(tr1-tr4) ch(2,k,2,1) = sn*(ti1+ti4) ch(2,k,4,1) = sn*(ti1-ti4) 107 continue return 102 do 103 k = 1, l1 ti1 = cc(2,k,1,1)-cc(2,k,1,3) ti2 = cc(2,k,1,1)+cc(2,k,1,3) tr4 = cc(2,k,1,2)-cc(2,k,1,4) ti3 = cc(2,k,1,2)+cc(2,k,1,4) tr1 = cc(1,k,1,1)-cc(1,k,1,3) tr2 = cc(1,k,1,1)+cc(1,k,1,3) ti4 = cc(1,k,1,4)-cc(1,k,1,2) tr3 = cc(1,k,1,2)+cc(1,k,1,4) ch(1,k,1,1) = tr2+tr3 ch(1,k,3,1) = tr2-tr3 ch(2,k,1,1) = ti2+ti3 ch(2,k,3,1) = ti2-ti3 ch(1,k,2,1) = tr1+tr4 ch(1,k,4,1) = tr1-tr4 ch(2,k,2,1) = ti1+ti4 ch(2,k,4,1) = ti1-ti4 103 continue do 105 i = 2, ido do 104 k = 1, l1 ti1 = cc(2,k,i,1)-cc(2,k,i,3) ti2 = cc(2,k,i,1)+cc(2,k,i,3) ti3 = cc(2,k,i,2)+cc(2,k,i,4) tr4 = cc(2,k,i,2)-cc(2,k,i,4) tr1 = cc(1,k,i,1)-cc(1,k,i,3) tr2 = cc(1,k,i,1)+cc(1,k,i,3) ti4 = cc(1,k,i,4)-cc(1,k,i,2) tr3 = cc(1,k,i,2)+cc(1,k,i,4) ch(1,k,1,i) = tr2+tr3 cr3 = tr2-tr3 ch(2,k,1,i) = ti2+ti3 ci3 = ti2-ti3 cr2 = tr1+tr4 cr4 = tr1-tr4 ci2 = ti1+ti4 ci4 = ti1-ti4 ch(1,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2 ch(2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2 ch(1,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3 ch(2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3 ch(1,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4 ch(2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4 104 continue 105 continue return end subroutine c1f5kb ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F5KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,5) real ( kind = 8 ) ch(in2,l1,5,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: ti11 = 0.9510565162951536D+00 real ( kind = 8 ), parameter :: ti12 = 0.5877852522924731D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ), parameter :: tr11 = 0.3090169943749474D+00 real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00 real ( kind = 8 ) wa(ido,4,2) if ( 1 < ido .or. na == 1) go to 102 do k = 1, l1 ti5 = cc(2,k,1,2)-cc(2,k,1,5) ti2 = cc(2,k,1,2)+cc(2,k,1,5) ti4 = cc(2,k,1,3)-cc(2,k,1,4) ti3 = cc(2,k,1,3)+cc(2,k,1,4) tr5 = cc(1,k,1,2)-cc(1,k,1,5) tr2 = cc(1,k,1,2)+cc(1,k,1,5) tr4 = cc(1,k,1,3)-cc(1,k,1,4) tr3 = cc(1,k,1,3)+cc(1,k,1,4) chold1 = cc(1,k,1,1)+tr2+tr3 chold2 = cc(2,k,1,1)+ti2+ti3 cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3 cc(1,k,1,1) = chold1 cc(2,k,1,1) = chold2 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 cc(1,k,1,2) = cr2-ci5 cc(1,k,1,5) = cr2+ci5 cc(2,k,1,2) = ci2+cr5 cc(2,k,1,3) = ci3+cr4 cc(1,k,1,3) = cr3-ci4 cc(1,k,1,4) = cr3+ci4 cc(2,k,1,4) = ci3-cr4 cc(2,k,1,5) = ci2-cr5 end do return 102 do 103 k = 1, l1 ti5 = cc(2,k,1,2)-cc(2,k,1,5) ti2 = cc(2,k,1,2)+cc(2,k,1,5) ti4 = cc(2,k,1,3)-cc(2,k,1,4) ti3 = cc(2,k,1,3)+cc(2,k,1,4) tr5 = cc(1,k,1,2)-cc(1,k,1,5) tr2 = cc(1,k,1,2)+cc(1,k,1,5) tr4 = cc(1,k,1,3)-cc(1,k,1,4) tr3 = cc(1,k,1,3)+cc(1,k,1,4) ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3 ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3 cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,k,2,1) = cr2-ci5 ch(1,k,5,1) = cr2+ci5 ch(2,k,2,1) = ci2+cr5 ch(2,k,3,1) = ci3+cr4 ch(1,k,3,1) = cr3-ci4 ch(1,k,4,1) = cr3+ci4 ch(2,k,4,1) = ci3-cr4 ch(2,k,5,1) = ci2-cr5 103 continue do 105 i = 2, ido do 104 k = 1, l1 ti5 = cc(2,k,i,2)-cc(2,k,i,5) ti2 = cc(2,k,i,2)+cc(2,k,i,5) ti4 = cc(2,k,i,3)-cc(2,k,i,4) ti3 = cc(2,k,i,3)+cc(2,k,i,4) tr5 = cc(1,k,i,2)-cc(1,k,i,5) tr2 = cc(1,k,i,2)+cc(1,k,i,5) tr4 = cc(1,k,i,3)-cc(1,k,i,4) tr3 = cc(1,k,i,3)+cc(1,k,i,4) ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3 ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3 cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 dr3 = cr3-ci4 dr4 = cr3+ci4 di3 = ci3+cr4 di4 = ci3-cr4 dr5 = cr2+ci5 dr2 = cr2-ci5 di5 = ci2-cr5 di2 = ci2+cr5 ch(1,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2 ch(2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2 ch(1,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3 ch(2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3 ch(1,k,4,i) = wa(i,3,1)*dr4-wa(i,3,2)*di4 ch(2,k,4,i) = wa(i,3,1)*di4+wa(i,3,2)*dr4 ch(1,k,5,i) = wa(i,4,1)*dr5-wa(i,4,2)*di5 ch(2,k,5,i) = wa(i,4,1)*di5+wa(i,4,2)*dr5 104 continue 105 continue return end subroutine c1f5kf ( ido, l1, na, cc, in1, ch, in2, wa ) !*****************************************************************************80 ! !! C1F5KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,l1,ido,5) real ( kind = 8 ) ch(in2,l1,5,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: ti11 = -0.9510565162951536D+00 real ( kind = 8 ), parameter :: ti12 = -0.5877852522924731D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ), parameter :: tr11 = 0.3090169943749474D+00 real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00 real ( kind = 8 ) wa(ido,4,2) if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 5 * l1, kind = 8 ) if (na == 1) go to 106 do k = 1, l1 ti5 = cc(2,k,1,2)-cc(2,k,1,5) ti2 = cc(2,k,1,2)+cc(2,k,1,5) ti4 = cc(2,k,1,3)-cc(2,k,1,4) ti3 = cc(2,k,1,3)+cc(2,k,1,4) tr5 = cc(1,k,1,2)-cc(1,k,1,5) tr2 = cc(1,k,1,2)+cc(1,k,1,5) tr4 = cc(1,k,1,3)-cc(1,k,1,4) tr3 = cc(1,k,1,3)+cc(1,k,1,4) chold1 = sn*(cc(1,k,1,1)+tr2+tr3) chold2 = sn*(cc(2,k,1,1)+ti2+ti3) cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3 cc(1,k,1,1) = chold1 cc(2,k,1,1) = chold2 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 cc(1,k,1,2) = sn*(cr2-ci5) cc(1,k,1,5) = sn*(cr2+ci5) cc(2,k,1,2) = sn*(ci2+cr5) cc(2,k,1,3) = sn*(ci3+cr4) cc(1,k,1,3) = sn*(cr3-ci4) cc(1,k,1,4) = sn*(cr3+ci4) cc(2,k,1,4) = sn*(ci3-cr4) cc(2,k,1,5) = sn*(ci2-cr5) end do return 106 do 107 k = 1, l1 ti5 = cc(2,k,1,2)-cc(2,k,1,5) ti2 = cc(2,k,1,2)+cc(2,k,1,5) ti4 = cc(2,k,1,3)-cc(2,k,1,4) ti3 = cc(2,k,1,3)+cc(2,k,1,4) tr5 = cc(1,k,1,2)-cc(1,k,1,5) tr2 = cc(1,k,1,2)+cc(1,k,1,5) tr4 = cc(1,k,1,3)-cc(1,k,1,4) tr3 = cc(1,k,1,3)+cc(1,k,1,4) ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2+tr3) ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2+ti3) cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,k,2,1) = sn*(cr2-ci5) ch(1,k,5,1) = sn*(cr2+ci5) ch(2,k,2,1) = sn*(ci2+cr5) ch(2,k,3,1) = sn*(ci3+cr4) ch(1,k,3,1) = sn*(cr3-ci4) ch(1,k,4,1) = sn*(cr3+ci4) ch(2,k,4,1) = sn*(ci3-cr4) ch(2,k,5,1) = sn*(ci2-cr5) 107 continue return 102 do 103 k = 1, l1 ti5 = cc(2,k,1,2)-cc(2,k,1,5) ti2 = cc(2,k,1,2)+cc(2,k,1,5) ti4 = cc(2,k,1,3)-cc(2,k,1,4) ti3 = cc(2,k,1,3)+cc(2,k,1,4) tr5 = cc(1,k,1,2)-cc(1,k,1,5) tr2 = cc(1,k,1,2)+cc(1,k,1,5) tr4 = cc(1,k,1,3)-cc(1,k,1,4) tr3 = cc(1,k,1,3)+cc(1,k,1,4) ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3 ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3 cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,k,2,1) = cr2-ci5 ch(1,k,5,1) = cr2+ci5 ch(2,k,2,1) = ci2+cr5 ch(2,k,3,1) = ci3+cr4 ch(1,k,3,1) = cr3-ci4 ch(1,k,4,1) = cr3+ci4 ch(2,k,4,1) = ci3-cr4 ch(2,k,5,1) = ci2-cr5 103 continue do 105 i = 2, ido do 104 k = 1, l1 ti5 = cc(2,k,i,2)-cc(2,k,i,5) ti2 = cc(2,k,i,2)+cc(2,k,i,5) ti4 = cc(2,k,i,3)-cc(2,k,i,4) ti3 = cc(2,k,i,3)+cc(2,k,i,4) tr5 = cc(1,k,i,2)-cc(1,k,i,5) tr2 = cc(1,k,i,2)+cc(1,k,i,5) tr4 = cc(1,k,i,3)-cc(1,k,i,4) tr3 = cc(1,k,i,3)+cc(1,k,i,4) ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3 ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3 cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 dr3 = cr3-ci4 dr4 = cr3+ci4 di3 = ci3+cr4 di4 = ci3-cr4 dr5 = cr2+ci5 dr2 = cr2-ci5 di5 = ci2-cr5 di2 = ci2+cr5 ch(1,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2 ch(2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2 ch(1,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3 ch(2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3 ch(1,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4 ch(2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4 ch(1,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5 ch(2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5 104 continue 105 continue return end subroutine c1fgkb ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa ) !*****************************************************************************80 ! !! C1FGKB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 integer ( kind = 4 ) lid real ( kind = 8 ) cc(in1,l1,ip,ido) real ( kind = 8 ) cc1(in1,lid,ip) real ( kind = 8 ) ch(in2,l1,ido,ip) real ( kind = 8 ) ch1(in2,lid,ip) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) idlj integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) j integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) ki integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) na real ( kind = 8 ) wa(ido,ip-1,2) real ( kind = 8 ) wai real ( kind = 8 ) war ipp2 = ip+2 ipph = (ip+1)/2 do ki=1,lid ch1(1,ki,1) = cc1(1,ki,1) ch1(2,ki,1) = cc1(2,ki,1) end do do 111 j=2,ipph jc = ipp2-j do 112 ki=1,lid ch1(1,ki,j) = cc1(1,ki,j)+cc1(1,ki,jc) ch1(1,ki,jc) = cc1(1,ki,j)-cc1(1,ki,jc) ch1(2,ki,j) = cc1(2,ki,j)+cc1(2,ki,jc) ch1(2,ki,jc) = cc1(2,ki,j)-cc1(2,ki,jc) 112 continue 111 continue do 118 j=2,ipph do 117 ki=1,lid cc1(1,ki,1) = cc1(1,ki,1)+ch1(1,ki,j) cc1(2,ki,1) = cc1(2,ki,1)+ch1(2,ki,j) 117 continue 118 continue do 116 l=2,ipph lc = ipp2-l do 113 ki=1,lid cc1(1,ki,l) = ch1(1,ki,1)+wa(1,l-1,1)*ch1(1,ki,2) cc1(1,ki,lc) = wa(1,l-1,2)*ch1(1,ki,ip) cc1(2,ki,l) = ch1(2,ki,1)+wa(1,l-1,1)*ch1(2,ki,2) cc1(2,ki,lc) = wa(1,l-1,2)*ch1(2,ki,ip) 113 continue do 115 j=3,ipph jc = ipp2-j idlj = mod((l-1)*(j-1),ip) war = wa(1,idlj,1) wai = wa(1,idlj,2) do 114 ki=1,lid cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j) cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc) cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j) cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc) 114 continue 115 continue 116 continue if( 1 < ido .or. na == 1) go to 136 do 120 j=2,ipph jc = ipp2-j do 119 ki=1,lid chold1 = cc1(1,ki,j)-cc1(2,ki,jc) chold2 = cc1(1,ki,j)+cc1(2,ki,jc) cc1(1,ki,j) = chold1 cc1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc) cc1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc) cc1(1,ki,jc) = chold2 119 continue 120 continue return 136 do 137 ki=1,lid ch1(1,ki,1) = cc1(1,ki,1) ch1(2,ki,1) = cc1(2,ki,1) 137 continue do 135 j=2,ipph jc = ipp2-j do 134 ki=1,lid ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc) ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc) ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc) ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc) 134 continue 135 continue if (ido == 1) then return end if do 131 i=1,ido do 130 k = 1, l1 cc(1,k,1,i) = ch(1,k,i,1) cc(2,k,1,i) = ch(2,k,i,1) 130 continue 131 continue do 123 j=2,ip do 122 k = 1, l1 cc(1,k,j,1) = ch(1,k,1,j) cc(2,k,j,1) = ch(2,k,1,j) 122 continue 123 continue do 126 j=2,ip do 125 i = 2, ido do 124 k = 1, l1 cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) & -wa(i,j-1,2)*ch(2,k,i,j) cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) & +wa(i,j-1,2)*ch(1,k,i,j) 124 continue 125 continue 126 continue return end subroutine c1fgkf ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa ) !*****************************************************************************80 ! !! C1FGKF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 integer ( kind = 4 ) lid real ( kind = 8 ) cc(in1,l1,ip,ido) real ( kind = 8 ) cc1(in1,lid,ip) real ( kind = 8 ) ch(in2,l1,ido,ip) real ( kind = 8 ) ch1(in2,lid,ip) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) idlj integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) j integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) ki integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) wa(ido,ip-1,2) real ( kind = 8 ) wai real ( kind = 8 ) war ipp2 = ip+2 ipph = (ip+1)/2 do ki=1,lid ch1(1,ki,1) = cc1(1,ki,1) ch1(2,ki,1) = cc1(2,ki,1) end do do 111 j=2,ipph jc = ipp2-j do 112 ki=1,lid ch1(1,ki,j) = cc1(1,ki,j)+cc1(1,ki,jc) ch1(1,ki,jc) = cc1(1,ki,j)-cc1(1,ki,jc) ch1(2,ki,j) = cc1(2,ki,j)+cc1(2,ki,jc) ch1(2,ki,jc) = cc1(2,ki,j)-cc1(2,ki,jc) 112 continue 111 continue do 118 j=2,ipph do 117 ki=1,lid cc1(1,ki,1) = cc1(1,ki,1)+ch1(1,ki,j) cc1(2,ki,1) = cc1(2,ki,1)+ch1(2,ki,j) 117 continue 118 continue do 116 l=2,ipph lc = ipp2-l do 113 ki=1,lid cc1(1,ki,l) = ch1(1,ki,1)+wa(1,l-1,1)*ch1(1,ki,2) cc1(1,ki,lc) = -wa(1,l-1,2)*ch1(1,ki,ip) cc1(2,ki,l) = ch1(2,ki,1)+wa(1,l-1,1)*ch1(2,ki,2) cc1(2,ki,lc) = -wa(1,l-1,2)*ch1(2,ki,ip) 113 continue do 115 j=3,ipph jc = ipp2-j idlj = mod((l-1)*(j-1),ip) war = wa(1,idlj,1) wai = -wa(1,idlj,2) do 114 ki=1,lid cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j) cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc) cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j) cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc) 114 continue 115 continue 116 continue if ( 1 < ido ) go to 136 sn = 1.0D+00 / real ( ip * l1, kind = 8 ) if (na == 1) go to 146 do 149 ki=1,lid cc1(1,ki,1) = sn*cc1(1,ki,1) cc1(2,ki,1) = sn*cc1(2,ki,1) 149 continue do 120 j=2,ipph jc = ipp2-j do 119 ki=1,lid chold1 = sn*(cc1(1,ki,j)-cc1(2,ki,jc)) chold2 = sn*(cc1(1,ki,j)+cc1(2,ki,jc)) cc1(1,ki,j) = chold1 cc1(2,ki,jc) = sn*(cc1(2,ki,j)-cc1(1,ki,jc)) cc1(2,ki,j) = sn*(cc1(2,ki,j)+cc1(1,ki,jc)) cc1(1,ki,jc) = chold2 119 continue 120 continue return 146 do 147 ki=1,lid ch1(1,ki,1) = sn*cc1(1,ki,1) ch1(2,ki,1) = sn*cc1(2,ki,1) 147 continue do 145 j=2,ipph jc = ipp2-j do 144 ki=1,lid ch1(1,ki,j) = sn*(cc1(1,ki,j)-cc1(2,ki,jc)) ch1(2,ki,j) = sn*(cc1(2,ki,j)+cc1(1,ki,jc)) ch1(1,ki,jc) = sn*(cc1(1,ki,j)+cc1(2,ki,jc)) ch1(2,ki,jc) = sn*(cc1(2,ki,j)-cc1(1,ki,jc)) 144 continue 145 continue return 136 do 137 ki=1,lid ch1(1,ki,1) = cc1(1,ki,1) ch1(2,ki,1) = cc1(2,ki,1) 137 continue do 135 j=2,ipph jc = ipp2-j do 134 ki=1,lid ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc) ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc) ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc) ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc) 134 continue 135 continue do 131 i=1,ido do 130 k = 1, l1 cc(1,k,1,i) = ch(1,k,i,1) cc(2,k,1,i) = ch(2,k,i,1) 130 continue 131 continue do 123 j=2,ip do 122 k = 1, l1 cc(1,k,j,1) = ch(1,k,1,j) cc(2,k,j,1) = ch(2,k,1,j) 122 continue 123 continue do 126 j=2,ip do 125 i = 2, ido do 124 k = 1, l1 cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) & +wa(i,j-1,2)*ch(2,k,i,j) cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) & -wa(i,j-1,2)*ch(1,k,i,j) 124 continue 125 continue 126 continue return end subroutine c1fm1b ( n, inc, c, ch, wa, fnf, fac ) !*****************************************************************************80 ! !! C1FM1B is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none complex ( kind = 8 ) c(*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(*) real ( kind = 8 ) fnf integer ( kind = 4 ) ido integer ( kind = 4 ) inc integer ( kind = 4 ) inc2 integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) k integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) lid integer ( kind = 4 ) n integer ( kind = 4 ) na integer ( kind = 4 ) nbr integer ( kind = 4 ) nf real ( kind = 8 ) wa(*) inc2 = inc+inc nf = fnf na = 0 l1 = 1 iw = 1 do k1=1,nf ip = fac(k1) l2 = ip*l1 ido = n/l2 lid = l1*ido nbr = 1+na+2*min(ip-2,4) go to (52,62,53,63,54,64,55,65,56,66),nbr 52 call c1f2kb (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 62 call c1f2kb (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 53 call c1f3kb (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 63 call c1f3kb (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 54 call c1f4kb (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 64 call c1f4kb (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 55 call c1f5kb (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 65 call c1f5kb (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 56 call c1fgkb (ido,ip,l1,lid,na,c,c,inc2,ch,ch,2,wa(iw)) go to 120 66 call c1fgkb (ido,ip,l1,lid,na,ch,ch,2,c,c,inc2,wa(iw)) 120 l1 = l2 iw = iw+(ip-1)*(ido+ido) if(ip <= 5) na = 1-na end do return end subroutine c1fm1f ( n, inc, c, ch, wa, fnf, fac ) !*****************************************************************************80 ! !! C1FM1F is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none complex ( kind = 8 ) c(*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(*) real ( kind = 8 ) fnf integer ( kind = 4 ) ido integer ( kind = 4 ) inc integer ( kind = 4 ) inc2 integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) lid integer ( kind = 4 ) n integer ( kind = 4 ) na integer ( kind = 4 ) nbr integer ( kind = 4 ) nf real ( kind = 8 ) wa(*) inc2 = inc+inc nf = fnf na = 0 l1 = 1 iw = 1 do k1=1,nf ip = fac(k1) l2 = ip*l1 ido = n/l2 lid = l1*ido nbr = 1+na+2*min(ip-2,4) go to (52,62,53,63,54,64,55,65,56,66),nbr 52 call c1f2kf (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 62 call c1f2kf (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 53 call c1f3kf (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 63 call c1f3kf (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 54 call c1f4kf (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 64 call c1f4kf (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 55 call c1f5kf (ido,l1,na,c,inc2,ch,2,wa(iw)) go to 120 65 call c1f5kf (ido,l1,na,ch,2,c,inc2,wa(iw)) go to 120 56 call c1fgkf (ido,ip,l1,lid,na,c,c,inc2,ch,ch,2,wa(iw)) go to 120 66 call c1fgkf (ido,ip,l1,lid,na,ch,ch,2,c,c,inc2,wa(iw)) 120 l1 = l2 iw = iw+(ip-1)*(ido+ido) if(ip <= 5) na = 1-na end do return end subroutine cfft1b ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! CFFT1B: complex double precision backward fast Fourier transform, 1D. ! ! Discussion: ! ! CFFT1B computes the one-dimensional Fourier transform of a single ! periodic sequence within a complex array. This transform is referred ! to as the backward transform or Fourier synthesis, transforming the ! sequence from spectral to physical space. ! ! This transform is normalized since a call to CFFT1B followed ! by a call to CFFT1F (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array C, of two consecutive elements within the sequence to be transformed. ! ! Input/output, complex ( kind = 8 ) C(LENC) containing the sequence to be ! transformed. ! ! Input, integer ( kind = 4 ) LENC, the dimension of the C array. ! LENC must be at least INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFT1I before the first call to routine CFFT1F ! or CFFT1B for a given transform length N. WSAVE's contents may be ! re-used for subsequent calls to CFFT1F and CFFT1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENC not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lenc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(lenc) integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) iw1 integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) ier = 0 if (lenc < inc * ( n - 1 ) + 1 ) then ier = 1 call xerfft ( 'cfft1b ', 4 ) else if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 4 ) then ier = 2 call xerfft ( 'cfft1b ', 6 ) else if ( lenwrk < 2 * n ) then ier = 3 call xerfft ( 'cfft1b ', 8 ) end if if ( n == 1 ) then return end if iw1 = n + n + 1 call c1fm1b ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) ) return end subroutine cfft1f ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! CFFT1F: complex double precision forward fast Fourier transform, 1D. ! ! Discussion: ! ! CFFT1F computes the one-dimensional Fourier transform of a single ! periodic sequence within a complex array. This transform is referred ! to as the forward transform or Fourier analysis, transforming the ! sequence from physical to spectral space. ! ! This transform is normalized since a call to CFFT1F followed ! by a call to CFFT1B (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array C, of two consecutive elements within the sequence to be transformed. ! ! Input/output, complex ( kind = 8 ) C(LENC) containing the sequence to ! be transformed. ! ! Input, integer ( kind = 4 ) LENC, the dimension of the C array. ! LENC must be at least INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFT1I before the first call to routine CFFT1F ! or CFFT1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to CFFT1F and CFFT1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENC not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lenc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(lenc) integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) iw1 integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) ier = 0 if (lenc < inc*(n-1) + 1) then ier = 1 call xerfft ('cfft1f ', 4) else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) + 4) then ier = 2 call xerfft ('cfft1f ', 6) else if (lenwrk < 2*n) then ier = 3 call xerfft ('cfft1f ', 8) end if if (n == 1) then return end if iw1 = n + n + 1 call c1fm1f ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) ) return end subroutine cfft1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! CFFT1I: initialization for CFFT1B and CFFT1F. ! ! Discussion: ! ! CFFT1I initializes array WSAVE for use in its companion routines ! CFFT1B and CFFT1F. Routine CFFT1I must be called before the first ! call to CFFT1B or CFFT1F, and after whenever the value of integer ! N changes. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product ! of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used ! in routines CFFT1B or CFFT1F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough. implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) iw1 integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 ))& & + 4) then ier = 2 call xerfft ('cfftmi ', 3) end if if ( n == 1 ) then return end if iw1 = n+n+1 call r8_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) ) return end subroutine cfft2b ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! CFFT2B: complex double precision backward fast Fourier transform, 2D. ! ! Discussion: ! ! CFFT2B computes the two-dimensional discrete Fourier transform of a ! complex periodic array. This transform is known as the backward ! transform or Fourier synthesis, transforming from spectral to ! physical space. Routine CFFT2B is normalized, in that a call to ! CFFT2B followed by a call to CFFT2F (or vice-versa) reproduces the ! original array within roundoff error. ! ! On 10 May 2010, this code was modified by changing the value ! of an index into the WSAVE array. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDIM, the first dimension of C. ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension of the two-dimensional complex array C. The value ! of L must be less than or equal to that of LDIM. The transform is ! most efficient when L is a product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed in ! the second dimension of the two-dimensional complex array C. The transform ! is most efficient when M is a product of small primes. ! ! Input/output, complex ( kind = 8 ) C(LDIM,M), on intput, the array of ! two dimensions containing the (L,M) subarray to be transformed. On ! output, the transformed data. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFT2I before the first call to routine CFFT2F ! or CFFT2B with transform lengths L and M. WSAVE's contents may be ! re-used for subsequent calls to CFFT2F and CFFT2B with the same ! transform lengths L and M. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*L*M. ! ! Output, integer ( kind = 4 ) IER, the error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 5, input parameter LDIM < L; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) m integer ( kind = 4 ) ldim integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(ldim,m) integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw integer ( kind = 4 ) l real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) ier = 0 if ( ldim < l ) then ier = 5 call xerfft ('cfft2b', -2) return else if (lensav < 2*l + int(log( real ( l, kind = 8 ))/log( 2.0D+00 )) + & 2*m + int(log( real ( m, kind = 8 ))/log( 2.0D+00 )) +8) then ier = 2 call xerfft ('cfft2b', 6) return else if (lenwrk < 2*l*m) then ier = 3 call xerfft ('cfft2b', 8) return end if ! ! transform x lines of c array ! iw = 2*l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 )) + 3 call cfftmb(l, 1, m, ldim, c, (l-1) + ldim*(m-1) +1, & wsave(iw), 2*m + int(log( real ( m, kind = 8 ))/log( 2.0D+00 )) + 4, & work, 2*l*m, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cfft2b',-5) return end if ! ! transform y lines of c array ! iw = 1 call cfftmb (m, ldim, l, 1, c, (m-1)*ldim + l, & wsave(iw), 2*l + int(log( real ( l, kind = 8 ) )/log( 2.0D+00 )) + 4, & work, 2*m*l, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cfft2b',-5) end if return end subroutine cfft2f ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! CFFT2F: complex double precision forward fast Fourier transform, 2D. ! ! Discussion: ! ! CFFT2F computes the two-dimensional discrete Fourier transform of ! a complex periodic array. This transform is known as the forward ! transform or Fourier analysis, transforming from physical to ! spectral space. Routine CFFT2F is normalized, in that a call to ! CFFT2F followed by a call to CFFT2B (or vice-versa) reproduces the ! original array within roundoff error. ! ! On 10 May 2010, this code was modified by changing the value ! of an index into the WSAVE array. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDIM, the first dimension of the array C. ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension of the two-dimensional complex array C. The value ! of L must be less than or equal to that of LDIM. The transform is most ! efficient when L is a product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed ! in the second dimension of the two-dimensional complex array C. The ! transform is most efficient when M is a product of small primes. ! ! Input/output, complex ( kind = 8 ) C(LDIM,M), on input, the array of two ! dimensions containing the (L,M) subarray to be transformed. On output, the ! transformed data. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFT2I before the first call to routine CFFT2F ! or CFFT2B with transform lengths L and M. WSAVE's contents may be re-used ! for subsequent calls to CFFT2F and CFFT2B having those same ! transform lengths. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*L*M. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 5, input parameter LDIM < L; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) m integer ( kind = 4 ) ldim integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(ldim,m) integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw integer ( kind = 4 ) l real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) ier = 0 if ( ldim < l ) then ier = 5 call xerfft ('cfft2f', -2) return else if (lensav < & 2*l + int(log( real ( l, kind = 8 ))/log( 2.0D+00 )) + & 2*m + int(log( real ( m, kind = 8 ))/log( 2.0D+00 )) +8) then ier = 2 call xerfft ('cfft2f', 6) return else if (lenwrk < 2*l*m) then ier = 3 call xerfft ('cfft2f', 8) return end if ! ! transform x lines of c array ! iw = 2*l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 )) + 3 call cfftmf ( l, 1, m, ldim, c, (l-1) + ldim*(m-1) +1, & wsave(iw), & 2*m + int(log( real ( m, kind = 8 ) )/log( 2.0D+00 )) + 4, & work, 2*l*m, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cfft2f',-5) return end if ! ! transform y lines of c array ! iw = 1 call cfftmf (m, ldim, l, 1, c, (m-1)*ldim + l, & wsave(iw), 2*l + int(log( real ( l, kind = 8 ) )/log( 2.0D+00 )) + 4, & work, 2*m*l, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cfft2f',-5) end if return end subroutine cfft2i ( l, m, wsave, lensav, ier ) !*****************************************************************************80 ! !! CFFT2I: initialization for CFFT2B and CFFT2F. ! ! Discussion: ! ! CFFT2I initializes real array WSAVE for use in its companion ! routines CFFT2F and CFFT2B for computing two-dimensional fast ! Fourier transforms of complex data. Prime factorizations of L and M, ! together with tabulations of the trigonometric functions, are ! computed and stored in array WSAVE. ! ! On 10 May 2010, this code was modified by changing the value ! of an index into the WSAVE array. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension. The transform is most efficient when L is a ! product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed ! in the second dimension. The transform is most efficient when M is a ! product of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), contains the prime factors of L ! and M, and also certain trigonometric values which will be used in ! routines CFFT2B or CFFT2F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw integer ( kind = 4 ) l integer ( kind = 4 ) m real ( kind = 8 ) wsave(lensav) ier = 0 if ( lensav < 2 * l + int ( log ( real ( l, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 2 * m + int ( log ( real ( m, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 8 ) then ier = 2 call xerfft ('cfft2i', 4) return end if call cfftmi ( l, wsave(1), 2 * l + int ( log ( real ( l, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 4, ier1 ) if ( ier1 /= 0) then ier = 20 call xerfft ('cfft2i',-5) return end if call cfftmi ( m, & wsave(2*l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 )) + 3), & 2*m + int(log( real ( m, kind = 8 ) )/log( 2.0D+00 )) + 4, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cfft2i',-5) end if return end subroutine cfftmb ( lot, jump, n, inc, c, lenc, wsave, lensav, work, & lenwrk, ier ) !*****************************************************************************80 ! !! CFFTMB: complex double precision backward FFT, 1D, multiple vectors. ! ! Discussion: ! ! CFFTMB computes the one-dimensional Fourier transform of multiple ! periodic sequences within a complex array. This transform is referred ! to as the backward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. This transform is ! normalized since a call to CFFTMF followed by a call to CFFTMB (or ! vice-versa) reproduces the original array within roundoff error. ! ! The parameters INC, JUMP, N and LOT are consistent if equality ! I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT ! implies I1=I2 and J1=J2. For multiple FFTs to execute correctly, ! input variables INC, JUMP, N and LOT must be consistent, otherwise ! at least one array element mistakenly is transformed more than once. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array C. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array C, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array C, of two consecutive elements within the same sequence to be ! transformed. ! ! Input/output, complex ( kind = 8 ) C(LENC), an array containing LOT ! sequences, each having length N, to be transformed. C can have any ! number of dimensions, but the total number of locations must be at least ! LENC. On output, C contains the transformed sequences. ! ! Input, integer ( kind = 4 ) LENC, the dimension of the C array. ! LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFTMI before the first call to routine CFFTMF ! or CFFTMB for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit ! 1, input parameter LENC not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC, JUMP, N, LOT are not consistent. ! implicit none integer ( kind = 4 ) lenc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(lenc) integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) iw1 integer ( kind = 4 ) jump integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) logical xercon ier = 0 if (lenc < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('cfftmb ', 6) else if (lensav < 2*n + int(log( real ( n, kind = 8 )) & /log( 2.0D+00 )) + 4) then ier = 2 call xerfft ('cfftmb ', 8) else if (lenwrk < 2*lot*n) then ier = 3 call xerfft ('cfftmb ', 10) else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('cfftmb ', -1) end if if (n == 1) then return end if iw1 = n+n+1 call cmfm1b (lot,jump,n,inc,c,work,wsave,wsave(iw1),wsave(iw1+1)) return end subroutine cfftmf ( lot, jump, n, inc, c, lenc, wsave, lensav, work, & lenwrk, ier ) !*****************************************************************************80 ! !! CFFTMF: complex double precision forward FFT, 1D, multiple vectors. ! ! Discussion: ! ! CFFTMF computes the one-dimensional Fourier transform of multiple ! periodic sequences within a complex array. This transform is referred ! to as the forward transform or Fourier analysis, transforming the ! sequences from physical to spectral space. This transform is ! normalized since a call to CFFTMF followed by a call to CFFTMB ! (or vice-versa) reproduces the original array within roundoff error. ! ! The parameters integers INC, JUMP, N and LOT are consistent if equality ! I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT ! implies I1=I2 and J1=J2. For multiple FFTs to execute correctly, ! input variables INC, JUMP, N and LOT must be consistent, otherwise ! at least one array element mistakenly is transformed more than once. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be ! transformed within array C. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, ! in array C, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array C, of two consecutive elements within the same sequence to be ! transformed. ! ! Input/output, complex ( kind = 8 ) C(LENC), array containing LOT sequences, ! each having length N, to be transformed. C can have any number of ! dimensions, but the total number of locations must be at least LENC. ! ! Input, integer ( kind = 4 ) LENC, the dimension of the C array. ! LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to CFFTMI before the first call to routine CFFTMF ! or CFFTMB for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0 successful exit; ! 1 input parameter LENC not big enough; ! 2 input parameter LENSAV not big enough; ! 3 input parameter LENWRK not big enough; ! 4 input parameters INC, JUMP, N, LOT are not consistent. ! implicit none integer ( kind = 4 ) lenc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk complex ( kind = 8 ) c(lenc) integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) iw1 integer ( kind = 4 ) jump integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) logical xercon ier = 0 if (lenc < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('cfftmf ', 6) else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) + 4) then ier = 2 call xerfft ('cfftmf ', 8) else if (lenwrk < 2*lot*n) then ier = 3 call xerfft ('cfftmf ', 10) else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('cfftmf ', -1) end if if (n == 1) then return end if iw1 = n+n+1 call cmfm1f (lot,jump,n,inc,c,work,wsave,wsave(iw1),wsave(iw1+1)) return end subroutine cfftmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! CFFTMI: initialization for CFFTMB and CFFTMF. ! ! Discussion: ! ! CFFTMI initializes array WSAVE for use in its companion routines ! CFFTMB and CFFTMF. CFFTMI must be called before the first call ! to CFFTMB or CFFTMF, and after whenever the value of integer N changes. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used in ! routines CFFTMB or CFFTMF. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) iw1 integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) + 4) then ier = 2 call xerfft ('cfftmi ', 3) end if if (n == 1) then return end if iw1 = n+n+1 call r8_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) ) return end subroutine cmf2kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF2KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,2) real ( kind = 8 ) ch(2,in2,l1,2,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,1,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido .or. na == 1 ) go to 102 do k = 1, l1 do m1=1,m1d,im1 chold1 = cc(1,m1,k,1,1)+cc(1,m1,k,1,2) cc(1,m1,k,1,2) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2) cc(1,m1,k,1,1) = chold1 chold2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,2) cc(2,m1,k,1,2) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2) cc(2,m1,k,1,1) = chold2 end do end do return 102 continue do k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2) ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2) ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2) ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2) end do end do do i = 2, ido do k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2) tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2) ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2) ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2) ch(2,m2,k,2,i) = wa(i,1,1)*ti2+wa(i,1,2)*tr2 ch(1,m2,k,2,i) = wa(i,1,1)*tr2-wa(i,1,2)*ti2 end do end do end do return end subroutine cmf2kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF2KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,2) real ( kind = 8 ) ch(2,in2,l1,2,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lid integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) n integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,1,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 2 * l1, kind = 8 ) if (na == 1) go to 106 do k = 1, l1 do m1=1,m1d,im1 chold1 = sn*(cc(1,m1,k,1,1)+cc(1,m1,k,1,2)) cc(1,m1,k,1,2) = sn*(cc(1,m1,k,1,1)-cc(1,m1,k,1,2)) cc(1,m1,k,1,1) = chold1 chold2 = sn*(cc(2,m1,k,1,1)+cc(2,m1,k,1,2)) cc(2,m1,k,1,2) = sn*(cc(2,m1,k,1,1)-cc(2,m1,k,1,2)) cc(2,m1,k,1,1) = chold2 end do end do return 106 do 107 k = 1, l1 m2 = m2s do 107 m1=1,m1d,im1 m2 = m2+im2 ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+cc(1,m1,k,1,2)) ch(1,m2,k,2,1) = sn*(cc(1,m1,k,1,1)-cc(1,m1,k,1,2)) ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+cc(2,m1,k,1,2)) ch(2,m2,k,2,1) = sn*(cc(2,m1,k,1,1)-cc(2,m1,k,1,2)) 107 continue return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2) ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2) ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2) ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2) 103 continue do i = 2, ido do k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2) tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2) ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2) ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2) ch(2,m2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2 ch(1,m2,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2 end do end do end do return end subroutine cmf3kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF3KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,3) real ( kind = 8 ) ch(2,in2,l1,3,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ), parameter :: taui = 0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,2,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido .or. na == 1) go to 102 do k = 1, l1 do m1=1,m1d,im1 tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3) cr2 = cc(1,m1,k,1,1)+taur*tr2 cc(1,m1,k,1,1) = cc(1,m1,k,1,1)+tr2 ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3) ci2 = cc(2,m1,k,1,1)+taur*ti2 cc(2,m1,k,1,1) = cc(2,m1,k,1,1)+ti2 cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3)) ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3)) cc(1,m1,k,1,2) = cr2-ci3 cc(1,m1,k,1,3) = cr2+ci3 cc(2,m1,k,1,2) = ci2+cr3 cc(2,m1,k,1,3) = ci2-cr3 end do end do return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3) cr2 = cc(1,m1,k,1,1)+taur*tr2 ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2 ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3) ci2 = cc(2,m1,k,1,1)+taur*ti2 ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2 cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3)) ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3)) ch(1,m2,k,2,1) = cr2-ci3 ch(1,m2,k,3,1) = cr2+ci3 ch(2,m2,k,2,1) = ci2+cr3 ch(2,m2,k,3,1) = ci2-cr3 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3) cr2 = cc(1,m1,k,i,1)+taur*tr2 ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2 ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3) ci2 = cc(2,m1,k,i,1)+taur*ti2 ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2 cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3)) ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3)) dr2 = cr2-ci3 dr3 = cr2+ci3 di2 = ci2+cr3 di3 = ci2-cr3 ch(2,m2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2 ch(1,m2,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2 ch(2,m2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3 ch(1,m2,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3 104 continue 105 continue return end subroutine cmf3kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF3KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,3) real ( kind = 8 ) ch(2,in2,l1,3,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ), parameter :: taui = -0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa(ido,2,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 3 * l1, kind = 8 ) if (na == 1) go to 106 do 101 k = 1, l1 do 101 m1=1,m1d,im1 tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3) cr2 = cc(1,m1,k,1,1)+taur*tr2 cc(1,m1,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3) ci2 = cc(2,m1,k,1,1)+taur*ti2 cc(2,m1,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2) cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3)) ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3)) cc(1,m1,k,1,2) = sn*(cr2-ci3) cc(1,m1,k,1,3) = sn*(cr2+ci3) cc(2,m1,k,1,2) = sn*(ci2+cr3) cc(2,m1,k,1,3) = sn*(ci2-cr3) 101 continue return 106 do 107 k = 1, l1 m2 = m2s do 107 m1=1,m1d,im1 m2 = m2+im2 tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3) cr2 = cc(1,m1,k,1,1)+taur*tr2 ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3) ci2 = cc(2,m1,k,1,1)+taur*ti2 ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2) cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3)) ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3)) ch(1,m2,k,2,1) = sn*(cr2-ci3) ch(1,m2,k,3,1) = sn*(cr2+ci3) ch(2,m2,k,2,1) = sn*(ci2+cr3) ch(2,m2,k,3,1) = sn*(ci2-cr3) 107 continue return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3) cr2 = cc(1,m1,k,1,1)+taur*tr2 ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2 ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3) ci2 = cc(2,m1,k,1,1)+taur*ti2 ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2 cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3)) ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3)) ch(1,m2,k,2,1) = cr2-ci3 ch(1,m2,k,3,1) = cr2+ci3 ch(2,m2,k,2,1) = ci2+cr3 ch(2,m2,k,3,1) = ci2-cr3 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3) cr2 = cc(1,m1,k,i,1)+taur*tr2 ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2 ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3) ci2 = cc(2,m1,k,i,1)+taur*ti2 ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2 cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3)) ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3)) dr2 = cr2-ci3 dr3 = cr2+ci3 di2 = ci2+cr3 di3 = ci2-cr3 ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2 ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2 ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3 ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3 104 continue 105 continue return end subroutine cmf4kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF4KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,4) real ( kind = 8 ) ch(2,in2,l1,4,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa(ido,3,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido .or. na == 1) go to 102 do k = 1, l1 do m1=1,m1d,im1 ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3) ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3) tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2) ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4) tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3) tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3) ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4) cc(1,m1,k,1,1) = tr2+tr3 cc(1,m1,k,1,3) = tr2-tr3 cc(2,m1,k,1,1) = ti2+ti3 cc(2,m1,k,1,3) = ti2-ti3 cc(1,m1,k,1,2) = tr1+tr4 cc(1,m1,k,1,4) = tr1-tr4 cc(2,m1,k,1,2) = ti1+ti4 cc(2,m1,k,1,4) = ti1-ti4 end do end do return 102 continue do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3) ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3) tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2) ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4) tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3) tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3) ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = tr2+tr3 ch(1,m2,k,3,1) = tr2-tr3 ch(2,m2,k,1,1) = ti2+ti3 ch(2,m2,k,3,1) = ti2-ti3 ch(1,m2,k,2,1) = tr1+tr4 ch(1,m2,k,4,1) = tr1-tr4 ch(2,m2,k,2,1) = ti1+ti4 ch(2,m2,k,4,1) = ti1-ti4 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3) ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3) ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4) tr4 = cc(2,m1,k,i,4)-cc(2,m1,k,i,2) tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3) tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3) ti4 = cc(1,m1,k,i,2)-cc(1,m1,k,i,4) tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4) ch(1,m2,k,1,i) = tr2+tr3 cr3 = tr2-tr3 ch(2,m2,k,1,i) = ti2+ti3 ci3 = ti2-ti3 cr2 = tr1+tr4 cr4 = tr1-tr4 ci2 = ti1+ti4 ci4 = ti1-ti4 ch(1,m2,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2 ch(2,m2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2 ch(1,m2,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3 ch(2,m2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3 ch(1,m2,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4 ch(2,m2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4 104 continue 105 continue return end subroutine cmf4kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF4KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,4) real ( kind = 8 ) ch(2,in2,l1,4,ido) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa(ido,3,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 4 * l1, kind = 8 ) if (na == 1) go to 106 do 101 k = 1, l1 do 101 m1=1,m1d,im1 ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3) ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3) tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4) tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3) tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3) ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2) tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4) cc(1,m1,k,1,1) = sn*(tr2+tr3) cc(1,m1,k,1,3) = sn*(tr2-tr3) cc(2,m1,k,1,1) = sn*(ti2+ti3) cc(2,m1,k,1,3) = sn*(ti2-ti3) cc(1,m1,k,1,2) = sn*(tr1+tr4) cc(1,m1,k,1,4) = sn*(tr1-tr4) cc(2,m1,k,1,2) = sn*(ti1+ti4) cc(2,m1,k,1,4) = sn*(ti1-ti4) 101 continue return 106 do 107 k = 1, l1 m2 = m2s do 107 m1=1,m1d,im1 m2 = m2+im2 ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3) ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3) tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4) tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3) tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3) ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2) tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = sn*(tr2+tr3) ch(1,m2,k,3,1) = sn*(tr2-tr3) ch(2,m2,k,1,1) = sn*(ti2+ti3) ch(2,m2,k,3,1) = sn*(ti2-ti3) ch(1,m2,k,2,1) = sn*(tr1+tr4) ch(1,m2,k,4,1) = sn*(tr1-tr4) ch(2,m2,k,2,1) = sn*(ti1+ti4) ch(2,m2,k,4,1) = sn*(ti1-ti4) 107 continue return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3) ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3) tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4) tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3) tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3) ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2) tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = tr2+tr3 ch(1,m2,k,3,1) = tr2-tr3 ch(2,m2,k,1,1) = ti2+ti3 ch(2,m2,k,3,1) = ti2-ti3 ch(1,m2,k,2,1) = tr1+tr4 ch(1,m2,k,4,1) = tr1-tr4 ch(2,m2,k,2,1) = ti1+ti4 ch(2,m2,k,4,1) = ti1-ti4 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3) ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3) ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4) tr4 = cc(2,m1,k,i,2)-cc(2,m1,k,i,4) tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3) tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3) ti4 = cc(1,m1,k,i,4)-cc(1,m1,k,i,2) tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4) ch(1,m2,k,1,i) = tr2+tr3 cr3 = tr2-tr3 ch(2,m2,k,1,i) = ti2+ti3 ci3 = ti2-ti3 cr2 = tr1+tr4 cr4 = tr1-tr4 ci2 = ti1+ti4 ci4 = ti1-ti4 ch(1,m2,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2 ch(2,m2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2 ch(1,m2,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3 ch(2,m2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3 ch(1,m2,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4 ch(2,m2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4 104 continue 105 continue return end subroutine cmf5kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF5KB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,5) real ( kind = 8 ) ch(2,in2,l1,5,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: ti11 = 0.9510565162951536D+00 real ( kind = 8 ), parameter :: ti12 = 0.5877852522924731D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ), parameter :: tr11 = 0.3090169943749474D+00 real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00 real ( kind = 8 ) wa(ido,4,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido .or. na == 1) go to 102 do 101 k = 1, l1 do 101 m1=1,m1d,im1 ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5) ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4) tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5) tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5) tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4) chold1 = cc(1,m1,k,1,1)+tr2+tr3 chold2 = cc(2,m1,k,1,1)+ti2+ti3 cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3 cc(1,m1,k,1,1) = chold1 cc(2,m1,k,1,1) = chold2 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 cc(1,m1,k,1,2) = cr2-ci5 cc(1,m1,k,1,5) = cr2+ci5 cc(2,m1,k,1,2) = ci2+cr5 cc(2,m1,k,1,3) = ci3+cr4 cc(1,m1,k,1,3) = cr3-ci4 cc(1,m1,k,1,4) = cr3+ci4 cc(2,m1,k,1,4) = ci3-cr4 cc(2,m1,k,1,5) = ci2-cr5 101 continue return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5) ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4) tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5) tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5) tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3 ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3 cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,m2,k,2,1) = cr2-ci5 ch(1,m2,k,5,1) = cr2+ci5 ch(2,m2,k,2,1) = ci2+cr5 ch(2,m2,k,3,1) = ci3+cr4 ch(1,m2,k,3,1) = cr3-ci4 ch(1,m2,k,4,1) = cr3+ci4 ch(2,m2,k,4,1) = ci3-cr4 ch(2,m2,k,5,1) = ci2-cr5 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5) ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5) ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4) ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4) tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5) tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5) tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4) tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4) ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3 ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3 cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 dr3 = cr3-ci4 dr4 = cr3+ci4 di3 = ci3+cr4 di4 = ci3-cr4 dr5 = cr2+ci5 dr2 = cr2-ci5 di5 = ci2-cr5 di2 = ci2+cr5 ch(1,m2,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2 ch(2,m2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2 ch(1,m2,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3 ch(2,m2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3 ch(1,m2,k,4,i) = wa(i,3,1)*dr4-wa(i,3,2)*di4 ch(2,m2,k,4,i) = wa(i,3,1)*di4+wa(i,3,2)*dr4 ch(1,m2,k,5,i) = wa(i,4,1)*dr5-wa(i,4,2)*di5 ch(2,m2,k,5,i) = wa(i,4,1)*di5+wa(i,4,2)*dr5 104 continue 105 continue return end subroutine cmf5kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa ) !*****************************************************************************80 ! !! CMF5KF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(2,in1,l1,ido,5) real ( kind = 8 ) ch(2,in2,l1,5,ido) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: ti11 = -0.9510565162951536D+00 real ( kind = 8 ), parameter :: ti12 = -0.5877852522924731D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ), parameter :: tr11 = 0.3090169943749474D+00 real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00 real ( kind = 8 ) wa(ido,4,2) m1d = (lot-1)*im1+1 m2s = 1-im2 if ( 1 < ido ) go to 102 sn = 1.0D+00 / real ( 5 * l1, kind = 8 ) if (na == 1) go to 106 do 101 k = 1, l1 do 101 m1=1,m1d,im1 ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5) ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4) tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5) tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5) tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4) chold1 = sn*(cc(1,m1,k,1,1)+tr2+tr3) chold2 = sn*(cc(2,m1,k,1,1)+ti2+ti3) cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3 cc(1,m1,k,1,1) = chold1 cc(2,m1,k,1,1) = chold2 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 cc(1,m1,k,1,2) = sn*(cr2-ci5) cc(1,m1,k,1,5) = sn*(cr2+ci5) cc(2,m1,k,1,2) = sn*(ci2+cr5) cc(2,m1,k,1,3) = sn*(ci3+cr4) cc(1,m1,k,1,3) = sn*(cr3-ci4) cc(1,m1,k,1,4) = sn*(cr3+ci4) cc(2,m1,k,1,4) = sn*(ci3-cr4) cc(2,m1,k,1,5) = sn*(ci2-cr5) 101 continue return 106 do 107 k = 1, l1 m2 = m2s do 107 m1=1,m1d,im1 m2 = m2+im2 ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5) ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4) tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5) tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5) tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2+tr3) ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2+ti3) cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,m2,k,2,1) = sn*(cr2-ci5) ch(1,m2,k,5,1) = sn*(cr2+ci5) ch(2,m2,k,2,1) = sn*(ci2+cr5) ch(2,m2,k,3,1) = sn*(ci3+cr4) ch(1,m2,k,3,1) = sn*(cr3-ci4) ch(1,m2,k,4,1) = sn*(cr3+ci4) ch(2,m2,k,4,1) = sn*(ci3-cr4) ch(2,m2,k,5,1) = sn*(ci2-cr5) 107 continue return 102 do 103 k = 1, l1 m2 = m2s do 103 m1=1,m1d,im1 m2 = m2+im2 ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5) ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5) ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4) ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4) tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5) tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5) tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4) tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4) ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3 ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3 cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 ch(1,m2,k,2,1) = cr2-ci5 ch(1,m2,k,5,1) = cr2+ci5 ch(2,m2,k,2,1) = ci2+cr5 ch(2,m2,k,3,1) = ci3+cr4 ch(1,m2,k,3,1) = cr3-ci4 ch(1,m2,k,4,1) = cr3+ci4 ch(2,m2,k,4,1) = ci3-cr4 ch(2,m2,k,5,1) = ci2-cr5 103 continue do 105 i = 2, ido do 104 k = 1, l1 m2 = m2s do 104 m1=1,m1d,im1 m2 = m2+im2 ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5) ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5) ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4) ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4) tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5) tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5) tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4) tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4) ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3 ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3 cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3 ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3 cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3 ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3 cr5 = ti11*tr5+ti12*tr4 ci5 = ti11*ti5+ti12*ti4 cr4 = ti12*tr5-ti11*tr4 ci4 = ti12*ti5-ti11*ti4 dr3 = cr3-ci4 dr4 = cr3+ci4 di3 = ci3+cr4 di4 = ci3-cr4 dr5 = cr2+ci5 dr2 = cr2-ci5 di5 = ci2-cr5 di2 = ci2+cr5 ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2 ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2 ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3 ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3 ch(1,m2,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4 ch(2,m2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4 ch(1,m2,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5 ch(2,m2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5 104 continue 105 continue return end subroutine cmfgkb ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, & ch, ch1, im2, in2, wa ) !*****************************************************************************80 ! !! CMFGKB is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 integer ( kind = 4 ) lid real ( kind = 8 ) cc(2,in1,l1,ip,ido) real ( kind = 8 ) cc1(2,in1,lid,ip) real ( kind = 8 ) ch(2,in2,l1,ido,ip) real ( kind = 8 ) ch1(2,in2,lid,ip) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) idlj integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) j integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) ki integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) wa(ido,ip-1,2) real ( kind = 8 ) wai real ( kind = 8 ) war m1d = (lot-1)*im1+1 m2s = 1-im2 ipp2 = ip+2 ipph = (ip+1)/2 do ki=1,lid m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,1) = cc1(1,m1,ki,1) ch1(2,m2,ki,1) = cc1(2,m1,ki,1) end do end do do j=2,ipph jc = ipp2-j do ki=1,lid m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,j) = cc1(1,m1,ki,j)+cc1(1,m1,ki,jc) ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)-cc1(1,m1,ki,jc) ch1(2,m2,ki,j) = cc1(2,m1,ki,j)+cc1(2,m1,ki,jc) ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(2,m1,ki,jc) end do end do end do 111 continue do 118 j=2,ipph do 117 ki=1,lid m2 = m2s do 117 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,1) = cc1(1,m1,ki,1)+ch1(1,m2,ki,j) cc1(2,m1,ki,1) = cc1(2,m1,ki,1)+ch1(2,m2,ki,j) 117 continue 118 continue do 116 l=2,ipph lc = ipp2-l do 113 ki=1,lid m2 = m2s do 113 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,l) = ch1(1,m2,ki,1)+wa(1,l-1,1)*ch1(1,m2,ki,2) cc1(1,m1,ki,lc) = wa(1,l-1,2)*ch1(1,m2,ki,ip) cc1(2,m1,ki,l) = ch1(2,m2,ki,1)+wa(1,l-1,1)*ch1(2,m2,ki,2) cc1(2,m1,ki,lc) = wa(1,l-1,2)*ch1(2,m2,ki,ip) 113 continue do 115 j=3,ipph jc = ipp2-j idlj = mod((l-1)*(j-1),ip) war = wa(1,idlj,1) wai = wa(1,idlj,2) do 114 ki=1,lid m2 = m2s do 114 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,l) = cc1(1,m1,ki,l)+war*ch1(1,m2,ki,j) cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc)+wai*ch1(1,m2,ki,jc) cc1(2,m1,ki,l) = cc1(2,m1,ki,l)+war*ch1(2,m2,ki,j) cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc)+wai*ch1(2,m2,ki,jc) 114 continue 115 continue 116 continue if( 1 < ido .or. na == 1) go to 136 do 120 j=2,ipph jc = ipp2-j do 119 ki=1,lid do 119 m1=1,m1d,im1 chold1 = cc1(1,m1,ki,j)-cc1(2,m1,ki,jc) chold2 = cc1(1,m1,ki,j)+cc1(2,m1,ki,jc) cc1(1,m1,ki,j) = chold1 cc1(2,m1,ki,jc) = cc1(2,m1,ki,j)-cc1(1,m1,ki,jc) cc1(2,m1,ki,j) = cc1(2,m1,ki,j)+cc1(1,m1,ki,jc) cc1(1,m1,ki,jc) = chold2 119 continue 120 continue return 136 do 137 ki=1,lid m2 = m2s do 137 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,1) = cc1(1,m1,ki,1) ch1(2,m2,ki,1) = cc1(2,m1,ki,1) 137 continue do 135 j=2,ipph jc = ipp2-j do 134 ki=1,lid m2 = m2s do 134 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,j) = cc1(1,m1,ki,j)-cc1(2,m1,ki,jc) ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)+cc1(2,m1,ki,jc) ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(1,m1,ki,jc) ch1(2,m2,ki,j) = cc1(2,m1,ki,j)+cc1(1,m1,ki,jc) 134 continue 135 continue if (ido == 1) then return end if do 131 i=1,ido do 130 k = 1, l1 m2 = m2s do 130 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,1,i) = ch(1,m2,k,i,1) cc(2,m1,k,1,i) = ch(2,m2,k,i,1) 130 continue 131 continue do 123 j=2,ip do 122 k = 1, l1 m2 = m2s do 122 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,j,1) = ch(1,m2,k,1,j) cc(2,m1,k,j,1) = ch(2,m2,k,1,j) 122 continue 123 continue do 126 j=2,ip do 125 i = 2, ido do 124 k = 1, l1 m2 = m2s do 124 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,j,i) = wa(i,j-1,1)*ch(1,m2,k,i,j) & -wa(i,j-1,2)*ch(2,m2,k,i,j) cc(2,m1,k,j,i) = wa(i,j-1,1)*ch(2,m2,k,i,j) & +wa(i,j-1,2)*ch(1,m2,k,i,j) 124 continue 125 continue 126 continue return end subroutine cmfgkf ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, & ch, ch1, im2, in2, wa ) !*****************************************************************************80 ! !! CMFGKF is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 integer ( kind = 4 ) lid real ( kind = 8 ) cc(2,in1,l1,ip,ido) real ( kind = 8 ) cc1(2,in1,lid,ip) real ( kind = 8 ) ch(2,in2,l1,ido,ip) real ( kind = 8 ) ch1(2,in2,lid,ip) real ( kind = 8 ) chold1 real ( kind = 8 ) chold2 integer ( kind = 4 ) i integer ( kind = 4 ) idlj integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) j integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) ki integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) lot integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) na real ( kind = 8 ) sn real ( kind = 8 ) wa(ido,ip-1,2) real ( kind = 8 ) wai real ( kind = 8 ) war m1d = (lot-1)*im1+1 m2s = 1-im2 ipp2 = ip+2 ipph = (ip+1)/2 do 110 ki=1,lid m2 = m2s do 110 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,1) = cc1(1,m1,ki,1) ch1(2,m2,ki,1) = cc1(2,m1,ki,1) 110 continue do 111 j=2,ipph jc = ipp2-j do 112 ki=1,lid m2 = m2s do 112 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,j) = cc1(1,m1,ki,j)+cc1(1,m1,ki,jc) ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)-cc1(1,m1,ki,jc) ch1(2,m2,ki,j) = cc1(2,m1,ki,j)+cc1(2,m1,ki,jc) ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(2,m1,ki,jc) 112 continue 111 continue do 118 j=2,ipph do 117 ki=1,lid m2 = m2s do 117 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,1) = cc1(1,m1,ki,1)+ch1(1,m2,ki,j) cc1(2,m1,ki,1) = cc1(2,m1,ki,1)+ch1(2,m2,ki,j) 117 continue 118 continue do 116 l=2,ipph lc = ipp2-l do 113 ki=1,lid m2 = m2s do 113 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,l) = ch1(1,m2,ki,1)+wa(1,l-1,1)*ch1(1,m2,ki,2) cc1(1,m1,ki,lc) = -wa(1,l-1,2)*ch1(1,m2,ki,ip) cc1(2,m1,ki,l) = ch1(2,m2,ki,1)+wa(1,l-1,1)*ch1(2,m2,ki,2) cc1(2,m1,ki,lc) = -wa(1,l-1,2)*ch1(2,m2,ki,ip) 113 continue do 115 j=3,ipph jc = ipp2-j idlj = mod((l-1)*(j-1),ip) war = wa(1,idlj,1) wai = -wa(1,idlj,2) do 114 ki=1,lid m2 = m2s do 114 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,l) = cc1(1,m1,ki,l)+war*ch1(1,m2,ki,j) cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc)+wai*ch1(1,m2,ki,jc) cc1(2,m1,ki,l) = cc1(2,m1,ki,l)+war*ch1(2,m2,ki,j) cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc)+wai*ch1(2,m2,ki,jc) 114 continue 115 continue 116 continue if ( 1 < ido ) go to 136 sn = 1.0D+00 / real ( ip * l1, kind = 8 ) if (na == 1) go to 146 do 149 ki=1,lid m2 = m2s do 149 m1=1,m1d,im1 m2 = m2+im2 cc1(1,m1,ki,1) = sn*cc1(1,m1,ki,1) cc1(2,m1,ki,1) = sn*cc1(2,m1,ki,1) 149 continue do 120 j=2,ipph jc = ipp2-j do 119 ki=1,lid do 119 m1=1,m1d,im1 chold1 = sn*(cc1(1,m1,ki,j)-cc1(2,m1,ki,jc)) chold2 = sn*(cc1(1,m1,ki,j)+cc1(2,m1,ki,jc)) cc1(1,m1,ki,j) = chold1 cc1(2,m1,ki,jc) = sn*(cc1(2,m1,ki,j)-cc1(1,m1,ki,jc)) cc1(2,m1,ki,j) = sn*(cc1(2,m1,ki,j)+cc1(1,m1,ki,jc)) cc1(1,m1,ki,jc) = chold2 119 continue 120 continue return 146 do 147 ki=1,lid m2 = m2s do 147 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,1) = sn*cc1(1,m1,ki,1) ch1(2,m2,ki,1) = sn*cc1(2,m1,ki,1) 147 continue do 145 j=2,ipph jc = ipp2-j do 144 ki=1,lid m2 = m2s do 144 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,j) = sn*(cc1(1,m1,ki,j)-cc1(2,m1,ki,jc)) ch1(2,m2,ki,j) = sn*(cc1(2,m1,ki,j)+cc1(1,m1,ki,jc)) ch1(1,m2,ki,jc) = sn*(cc1(1,m1,ki,j)+cc1(2,m1,ki,jc)) ch1(2,m2,ki,jc) = sn*(cc1(2,m1,ki,j)-cc1(1,m1,ki,jc)) 144 continue 145 continue return 136 do 137 ki=1,lid m2 = m2s do 137 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,1) = cc1(1,m1,ki,1) ch1(2,m2,ki,1) = cc1(2,m1,ki,1) 137 continue do 135 j=2,ipph jc = ipp2-j do 134 ki=1,lid m2 = m2s do 134 m1=1,m1d,im1 m2 = m2+im2 ch1(1,m2,ki,j) = cc1(1,m1,ki,j)-cc1(2,m1,ki,jc) ch1(2,m2,ki,j) = cc1(2,m1,ki,j)+cc1(1,m1,ki,jc) ch1(1,m2,ki,jc) = cc1(1,m1,ki,j)+cc1(2,m1,ki,jc) ch1(2,m2,ki,jc) = cc1(2,m1,ki,j)-cc1(1,m1,ki,jc) 134 continue 135 continue do 131 i=1,ido do 130 k = 1, l1 m2 = m2s do 130 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,1,i) = ch(1,m2,k,i,1) cc(2,m1,k,1,i) = ch(2,m2,k,i,1) 130 continue 131 continue do 123 j=2,ip do 122 k = 1, l1 m2 = m2s do 122 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,j,1) = ch(1,m2,k,1,j) cc(2,m1,k,j,1) = ch(2,m2,k,1,j) 122 continue 123 continue do 126 j=2,ip do 125 i = 2, ido do 124 k = 1, l1 m2 = m2s do 124 m1=1,m1d,im1 m2 = m2+im2 cc(1,m1,k,j,i) = wa(i,j-1,1)*ch(1,m2,k,i,j) & +wa(i,j-1,2)*ch(2,m2,k,i,j) cc(2,m1,k,j,i) = wa(i,j-1,1)*ch(2,m2,k,i,j) & -wa(i,j-1,2)*ch(1,m2,k,i,j) 124 continue 125 continue 126 continue return end subroutine cmfm1b ( lot, jump, n, inc, c, ch, wa, fnf, fac ) !*****************************************************************************80 ! !! CMFM1B is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none complex ( kind = 8 ) c(*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(*) real ( kind = 8 ) fnf integer ( kind = 4 ) ido integer ( kind = 4 ) inc integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) jump integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) lid integer ( kind = 4 ) lot integer ( kind = 4 ) n integer ( kind = 4 ) na integer ( kind = 4 ) nbr integer ( kind = 4 ) nf real ( kind = 8 ) wa(*) nf = int ( fnf ) na = 0 l1 = 1 iw = 1 do 125 k1=1,nf ip = fac(k1) l2 = ip*l1 ido = n/l2 lid = l1*ido nbr = 1+na+2*min(ip-2,4) go to (52,62,53,63,54,64,55,65,56,66),nbr 52 call cmf2kb (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 62 call cmf2kb (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 53 call cmf3kb (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 63 call cmf3kb (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 54 call cmf4kb (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 64 call cmf4kb (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 55 call cmf5kb (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 65 call cmf5kb (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 56 call cmfgkb (lot,ido,ip,l1,lid,na,c,c,jump,inc,ch,ch,1,lot,wa(iw)) go to 120 66 call cmfgkb (lot,ido,ip,l1,lid,na,ch,ch,1,lot,c,c, & jump,inc,wa(iw)) 120 l1 = l2 iw = iw+(ip-1)*(ido+ido) if(ip <= 5) na = 1-na 125 continue return end subroutine cmfm1f ( lot, jump, n, inc, c, ch, wa, fnf, fac ) !*****************************************************************************80 ! !! CMFM1F is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none complex ( kind = 8 ) c(*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(*) real ( kind = 8 ) fnf integer ( kind = 4 ) ido integer ( kind = 4 ) inc integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) jump integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) lid integer ( kind = 4 ) lot integer ( kind = 4 ) n integer ( kind = 4 ) na integer ( kind = 4 ) nbr integer ( kind = 4 ) nf real ( kind = 8 ) wa(*) nf = int ( fnf ) na = 0 l1 = 1 iw = 1 do 125 k1=1,nf ip = fac(k1) l2 = ip*l1 ido = n/l2 lid = l1*ido nbr = 1+na+2*min(ip-2,4) go to (52,62,53,63,54,64,55,65,56,66),nbr 52 call cmf2kf (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 62 call cmf2kf (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 53 call cmf3kf (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 63 call cmf3kf (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 54 call cmf4kf (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 64 call cmf4kf (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 55 call cmf5kf (lot,ido,l1,na,c,jump,inc,ch,1,lot,wa(iw)) go to 120 65 call cmf5kf (lot,ido,l1,na,ch,1,lot,c,jump,inc,wa(iw)) go to 120 56 call cmfgkf (lot,ido,ip,l1,lid,na,c,c,jump,inc,ch,ch,1,lot,wa(iw)) go to 120 66 call cmfgkf (lot,ido,ip,l1,lid,na,ch,ch,1,lot,c,c, & jump,inc,wa(iw)) 120 l1 = l2 iw = iw+(ip-1)*(ido+ido) if(ip <= 5) na = 1-na 125 continue return end subroutine cosq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! COSQ1B: real double precision backward cosine quarter wave transform, 1D. ! ! Discussion: ! ! COSQ1B computes the one-dimensional Fourier transform of a sequence ! which is a cosine series with odd wave numbers. This transform is ! referred to as the backward transform or Fourier synthesis, transforming ! the sequence from spectral to physical space. ! ! This transform is normalized since a call to COSQ1B followed ! by a call to COSQ1F (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of elements to be transformed ! in the sequence. The transform is most efficient when N is a ! product of small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR); on input, containing the sequence ! to be transformed, and on output, containing the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSQ1I before the first call to routine COSQ1F ! or COSQ1B for a given transform length N. WSAVE's contents may be ! re-used for subsequent calls to COSQ1F and COSQ1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) lenx integer ( kind = 4 ) n real ( kind = 8 ) ssqrt2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1 ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('cosq1b', 6) return else if (lensav < & 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosq1b', 8) return else if (lenwrk < n) then ier = 3 call xerfft ('cosq1b', 10) return end if if (n-2) 300,102,103 102 ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 ) x1 = x(1,1)+x(1,2) x(1,2) = ssqrt2*(x(1,1)-x(1,2)) x(1,1) = x1 return 103 call cosqb1 (n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosq1b',-5) end if 300 continue return end subroutine cosq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! COSQ1F: real double precision forward cosine quarter wave transform, 1D. ! ! Discussion: ! ! COSQ1F computes the one-dimensional Fourier transform of a sequence ! which is a cosine series with odd wave numbers. This transform is ! referred to as the forward transform or Fourier analysis, transforming ! the sequence from physical to spectral space. ! ! This transform is normalized since a call to COSQ1F followed ! by a call to COSQ1B (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of elements to be transformed ! in the sequence. The transform is most efficient when N is a ! product of small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR); on input, containing the sequence ! to be transformed, and on output, containing the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSQ1I before the first call to routine COSQ1F ! or COSQ1B for a given transform length N. WSAVE's contents may be ! re-used for subsequent calls to COSQ1F and COSQ1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) n integer ( kind = 4 ) lenx real ( kind = 8 ) ssqrt2 real ( kind = 8 ) tsqx real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('cosq1f', 6) return else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosq1f', 8) return else if (lenwrk < n) then ier = 3 call xerfft ('cosq1f', 10) return end if if (n-2) 102,101,103 101 ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 ) tsqx = ssqrt2*x(1,2) x(1,2) = 0.5D+00 *x(1,1)-tsqx x(1,1) = 0.5D+00 *x(1,1)+tsqx 102 return 103 call cosqf1 (n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosq1f',-5) end if return end subroutine cosq1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! COSQ1I: initialization for COSQ1B and COSQ1F. ! ! Discussion: ! ! COSQ1I initializes array WSAVE for use in its companion routines ! COSQ1F and COSQ1B. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product ! of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of N ! and also containing certain trigonometric values which will be used ! in routines COSQ1B or COSQ1F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt real ( kind = 8 ) fk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) lnsv integer ( kind = 4 ) n real ( kind = 8 ) pih real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosq1i', 3) return end if pih = 2.0D+00 * atan ( 1.0D+00 ) dt = pih / real ( n, kind = 8 ) fk = 0.0D+00 do k=1,n fk = fk + 1.0D+00 wsave(k) = cos(fk*dt) end do lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4 call rfft1i (n, wsave(n+1), lnsv, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosq1i',-5) end if return end subroutine cosqb1 ( n, inc, x, wsave, work, ier ) !*****************************************************************************80 ! !! COSQB1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np2 integer ( kind = 4 ) ns2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xim1 ier = 0 ns2 = (n+1)/2 np2 = n+2 do i=3,n,2 xim1 = x(1,i-1)+x(1,i) x(1,i) = 0.5D+00 * (x(1,i-1)-x(1,i)) x(1,i-1) = 0.5D+00 * xim1 end do x(1,1) = 0.5D+00 * x(1,1) modn = mod(n,2) if (modn == 0 ) then x(1,n) = 0.5D+00 * x(1,n) end if lenx = inc*(n-1) + 1 lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = n call rfft1b(n,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosqb1',-5) return end if do k=2,ns2 kc = np2-k work(k) = wsave(k-1)*x(1,kc)+wsave(kc-1)*x(1,k) work(kc) = wsave(k-1)*x(1,k)-wsave(kc-1)*x(1,kc) end do if (modn == 0) then x(1,ns2+1) = wsave(ns2)*(x(1,ns2+1)+x(1,ns2+1)) end if do k=2,ns2 kc = np2-k x(1,k) = work(k)+work(kc) x(1,kc) = work(k)-work(kc) end do x(1,1) = x(1,1)+x(1,1) return end subroutine cosqf1 ( n, inc, x, wsave, work, ier ) !*****************************************************************************80 ! !! COSQF1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np2 integer ( kind = 4 ) ns2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xim1 ier = 0 ns2 = (n+1)/2 np2 = n+2 do k=2,ns2 kc = np2-k work(k) = x(1,k)+x(1,kc) work(kc) = x(1,k)-x(1,kc) end do modn = mod(n,2) if (modn == 0) then work(ns2+1) = x(1,ns2+1)+x(1,ns2+1) end if do k=2,ns2 kc = np2-k x(1,k) = wsave(k-1)*work(kc)+wsave(kc-1)*work(k) x(1,kc) = wsave(k-1)*work(k) -wsave(kc-1)*work(kc) end do if (modn == 0) then x(1,ns2+1) = wsave(ns2)*work(ns2+1) end if lenx = inc*(n-1) + 1 lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = n call rfft1f(n,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosqf1',-5) return end if do i=3,n,2 xim1 = 0.5D+00 * (x(1,i-1)+x(1,i)) x(1,i) = 0.5D+00 * (x(1,i-1)-x(1,i)) x(1,i-1) = xim1 end do return end subroutine cosqmb ( lot, jump, n, inc, x, lenx, wsave, lensav, work, lenwrk, & ier ) !*****************************************************************************80 ! !! COSQMB: real double precision backward cosine quarter wave, multiple vectors. ! ! Discussion: ! ! COSQMB computes the one-dimensional Fourier transform of multiple ! sequences, each of which is a cosine series with odd wave numbers. ! This transform is referred to as the backward transform or Fourier ! synthesis, transforming the sequences from spectral to physical space. ! ! This transform is normalized since a call to COSQMB followed ! by a call to COSQMF (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, ! in array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), array containing LOT sequences, ! each having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSQMI before the first call to routine COSQMF ! or COSQMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COSQMF and COSQMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) ssqrt2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1 logical xercon ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('cosqmb', 6) return else if (lensav < & 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosqmb', 8) return else if (lenwrk < lot*n) then ier = 3 call xerfft ('cosqmb', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('cosqmb', -1) return end if lj = (lot-1)*jump+1 if (n-2) 101,102,103 101 do m=1,lj,jump x(m,1) = x(m,1) end do return 102 ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 ) do m=1,lj,jump x1 = x(m,1)+x(m,2) x(m,2) = ssqrt2*(x(m,1)-x(m,2)) x(m,1) = x1 end do return 103 call mcsqb1 (lot,jump,n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosqmb',-5) end if return end subroutine cosqmf ( lot, jump, n, inc, x, lenx, wsave, lensav, work, & lenwrk, ier ) !*****************************************************************************80 ! !! COSQMF: real double precision forward cosine quarter wave, multiple vectors. ! ! Discussion: ! ! COSQMF computes the one-dimensional Fourier transform of multiple ! sequences within a real array, where each of the sequences is a ! cosine series with odd wave numbers. This transform is referred to ! as the forward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. ! ! This transform is normalized since a call to COSQMF followed ! by a call to COSQMB (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), array containing LOT sequences, ! each having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSQMI before the first call to routine COSQMF ! or COSQMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COSQMF and COSQMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) ssqrt2 real ( kind = 8 ) tsqx real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('cosqmf', 6) return else if (lensav < & 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosqmf', 8) return else if (lenwrk < lot*n) then ier = 3 call xerfft ('cosqmf', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('cosqmf', -1) return end if lj = (lot-1)*jump+1 if (n-2) 102,101,103 101 ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 ) do m=1,lj,jump tsqx = ssqrt2*x(m,2) x(m,2) = 0.5D+00 * x(m,1)-tsqx x(m,1) = 0.5D+00 * x(m,1)+tsqx end do 102 return 103 call mcsqf1 (lot,jump,n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosqmf',-5) end if return end subroutine cosqmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! COSQMI: initialization for COSQMB and COSQMF. ! ! Discussion: ! ! COSQMI initializes array WSAVE for use in its companion routines ! COSQMF and COSQMB. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of ! N and also containing certain trigonometric values which will be used ! in routines COSQMB or COSQMF. ! ! Input, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt real ( kind = 8 ) fk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) lnsv integer ( kind = 4 ) n real ( kind = 8 ) pih real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cosqmi', 3) return end if pih = 2.0D+00 * atan ( 1.0D+00 ) dt = pih/real ( n, kind = 8 ) fk = 0.0D+00 do k=1,n fk = fk + 1.0D+00 wsave(k) = cos(fk*dt) end do lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4 call rfftmi (n, wsave(n+1), lnsv, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cosqmi',-5) end if return end subroutine cost1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! COST1B: real double precision backward cosine transform, 1D. ! ! Discussion: ! ! COST1B computes the one-dimensional Fourier transform of an even ! sequence within a real array. This transform is referred to as ! the backward transform or Fourier synthesis, transforming the sequence ! from spectral to physical space. ! ! This transform is normalized since a call to COST1B followed ! by a call to COST1F (or vice-versa) reproduces the original array ! within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N-1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing the sequence to ! be transformed. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COST1I before the first call to routine COST1F ! or COST1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COST1F and COST1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N-1. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) lenx integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('cost1b', 6) return else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cost1b', 8) return else if (lenwrk < n-1) then ier = 3 call xerfft ('cost1b', 10) return end if if (n == 1) then return end if call costb1 (n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cost1b',-5) end if return end subroutine cost1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! COST1F: real double precision forward cosine transform, 1D. ! ! Discussion: ! ! COST1F computes the one-dimensional Fourier transform of an even ! sequence within a real array. This transform is referred to as the ! forward transform or Fourier analysis, transforming the sequence ! from physical to spectral space. ! ! This transform is normalized since a call to COST1F followed by a call ! to COST1B (or vice-versa) reproduces the original array within ! roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N-1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing the sequence to ! be transformed. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COST1I before the first call to routine COST1F ! or COST1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COST1F and COST1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N-1. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) lenx integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('cost1f', 6) return else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cost1f', 8) return else if (lenwrk < n-1) then ier = 3 call xerfft ('cost1f', 10) return end if if (n == 1) then return end if call costf1(n,inc,x,wsave,work,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cost1f',-5) end if return end subroutine cost1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! COST1I: initialization for COST1B and COST1F. ! ! Discussion: ! ! COST1I initializes array WSAVE for use in its companion routines ! COST1F and COST1B. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N-1 is a product ! of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, dimension of WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of ! N and also containing certain trigonometric values which will be used in ! routines COST1B or COST1F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt real ( kind = 8 ) fk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lnsv integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) pi real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('cost1i', 3) return end if if ( n <= 3 ) then return end if nm1 = n-1 np1 = n+1 ns2 = n/2 pi = 4.0D+00 * atan ( 1.0D+00 ) dt = pi/ real ( nm1, kind = 8 ) fk = 0.0D+00 do k=2,ns2 kc = np1-k fk = fk + 1.0D+00 wsave(k) = 2.0D+00 * sin(fk*dt) wsave(kc) = 2.0D+00 * cos(fk*dt) end do lnsv = nm1 + int(log( real ( nm1, kind = 8 ) )/log( 2.0D+00 )) +4 call rfft1i (nm1, wsave(n+1), lnsv, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('cost1i',-5) end if return end subroutine costb1 ( n, inc, x, wsave, work, ier ) !*****************************************************************************80 ! !! COSTB1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum real ( kind = 8 ) fnm1s2 real ( kind = 8 ) fnm1s4 integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1h real ( kind = 8 ) x1p3 real ( kind = 8 ) x2 real ( kind = 8 ) xi ier = 0 nm1 = n-1 np1 = n+1 ns2 = n/2 if (n-2) 106,101,102 101 x1h = x(1,1)+x(1,2) x(1,2) = x(1,1)-x(1,2) x(1,1) = x1h return 102 if ( 3 < n ) go to 103 x1p3 = x(1,1)+x(1,3) x2 = x(1,2) x(1,2) = x(1,1)-x(1,3) x(1,1) = x1p3+x2 x(1,3) = x1p3-x2 return 103 x(1,1) = x(1,1)+x(1,1) x(1,n) = x(1,n)+x(1,n) dsum = x(1,1)-x(1,n) x(1,1) = x(1,1)+x(1,n) do k=2,ns2 kc = np1-k t1 = x(1,k)+x(1,kc) t2 = x(1,k)-x(1,kc) dsum = dsum+wsave(kc)*t2 t2 = wsave(k)*t2 x(1,k) = t1-t2 x(1,kc) = t1+t2 end do modn = mod(n,2) if (modn == 0) go to 124 x(1,ns2+1) = x(1,ns2+1)+x(1,ns2+1) 124 lenx = inc*(nm1-1) + 1 lnsv = nm1 + int(log( real ( nm1, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = nm1 call rfft1f(nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('costb1',-5) return end if fnm1s2 = real ( nm1, kind = 8 ) / 2.0D+00 dsum = 0.5D+00 * dsum x(1,1) = fnm1s2*x(1,1) if(mod(nm1,2) /= 0) go to 30 x(1,nm1) = x(1,nm1)+x(1,nm1) 30 fnm1s4 = real ( nm1, kind = 8 ) / 4.0D+00 do i=3,n,2 xi = fnm1s4*x(1,i) x(1,i) = fnm1s4*x(1,i-1) x(1,i-1) = dsum dsum = dsum+xi end do if (modn /= 0) return x(1,n) = dsum 106 continue return end subroutine costf1 ( n, inc, x, wsave, work, ier ) !*****************************************************************************80 ! !! COSTF1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) snm1 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) tx2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1h real ( kind = 8 ) x1p3 real ( kind = 8 ) xi ier = 0 nm1 = n-1 np1 = n+1 ns2 = n/2 if (n-2) 200,101,102 101 x1h = x(1,1)+x(1,2) x(1,2) = 0.5D+00 * (x(1,1)-x(1,2)) x(1,1) = 0.5D+00 * x1h go to 200 102 if ( 3 < n ) go to 103 x1p3 = x(1,1)+x(1,3) tx2 = x(1,2)+x(1,2) x(1,2) = 0.5D+00 * (x(1,1)-x(1,3)) x(1,1) = 0.25D+00 *(x1p3+tx2) x(1,3) = 0.25D+00 *(x1p3-tx2) go to 200 103 dsum = x(1,1)-x(1,n) x(1,1) = x(1,1)+x(1,n) do k=2,ns2 kc = np1-k t1 = x(1,k)+x(1,kc) t2 = x(1,k)-x(1,kc) dsum = dsum+wsave(kc)*t2 t2 = wsave(k)*t2 x(1,k) = t1-t2 x(1,kc) = t1+t2 end do modn = mod(n,2) if (modn == 0) go to 124 x(1,ns2+1) = x(1,ns2+1)+x(1,ns2+1) 124 lenx = inc*(nm1-1) + 1 lnsv = nm1 + int(log( real ( nm1, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = nm1 call rfft1f(nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('costf1',-5) go to 200 end if snm1 = 1.0D+00 / real ( nm1, kind = 8 ) dsum = snm1*dsum if(mod(nm1,2) /= 0) go to 30 x(1,nm1) = x(1,nm1)+x(1,nm1) 30 do i=3,n,2 xi = 0.5D+00 * x(1,i) x(1,i) = 0.5D+00 * x(1,i-1) x(1,i-1) = dsum dsum = dsum+xi end do if (modn /= 0) go to 117 x(1,n) = dsum 117 x(1,1) = 0.5D+00 * x(1,1) x(1,n) = 0.5D+00 * x(1,n) 200 continue return end subroutine costmb ( lot, jump, n, inc, x, lenx, wsave, lensav, work, & lenwrk, ier ) !*****************************************************************************80 ! !! COSTMB: real double precision backward cosine transform, multiple vectors. ! ! Discussion: ! ! COSTMB computes the one-dimensional Fourier transform of multiple ! even sequences within a real array. This transform is referred to ! as the backward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. ! ! This transform is normalized since a call to COSTMB followed ! by a call to COSTMF (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N-1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), array containing LOT sequences, ! each having length N. On input, the data to be transformed; on output, ! the transormed data. R can have any number of dimensions, but the total ! number of locations must be at least LENR. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSTMI before the first call to routine COSTMF ! or COSTMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COSTMF and COSTMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*(N+1). ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw1 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('costmb', 6) return else if (lensav < & 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('costmb', 8) return else if (lenwrk < lot*(n+1)) then ier = 3 call xerfft ('costmb', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('costmb', -1) return end if iw1 = lot+lot+1 call mcstb1(lot,jump,n,inc,x,wsave,work,work(iw1),ier1) if (ier1 /= 0) then ier = 20 call xerfft ('costmb',-5) end if return end subroutine costmf ( lot, jump, n, inc, x, lenx, wsave, lensav, work, & lenwrk, ier ) !*****************************************************************************80 ! !! COSTMF: real double precision forward cosine transform, multiple vectors. ! ! Discussion: ! ! COSTMF computes the one-dimensional Fourier transform of multiple ! even sequences within a real array. This transform is referred to ! as the forward transform or Fourier analysis, transforming the ! sequences from physical to spectral space. ! ! This transform is normalized since a call to COSTMF followed ! by a call to COSTMB (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, ! in array R, of the first elements of two consecutive sequences to ! be transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N-1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), array containing LOT sequences, ! each having length N. On input, the data to be transformed; on output, ! the transormed data. R can have any number of dimensions, but the total ! number of locations must be at least LENR. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to COSTMI before the first call to routine COSTMF ! or COSTMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to COSTMF and COSTMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*(N+1). ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw1 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('costmf', 6) return else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('costmf', 8) return else if (lenwrk < lot*(n+1)) then ier = 3 call xerfft ('costmf', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('costmf', -1) return end if iw1 = lot+lot+1 call mcstf1(lot,jump,n,inc,x,wsave,work,work(iw1),ier1) if (ier1 /= 0) then ier = 20 call xerfft ('costmf',-5) end if return end subroutine costmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! COSTMI: initialization for COSTMB and COSTMF. ! ! Discussion: ! ! COSTMI initializes array WSAVE for use in its companion routines ! COSTMF and COSTMB. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4 ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of N ! and also containing certain trigonometric values which will be used ! in routines COSTMB or COSTMF. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt real ( kind = 8 ) fk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lnsv integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) pi real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('costmi', 3) return end if if (n <= 3) then return end if nm1 = n-1 np1 = n+1 ns2 = n/2 pi = 4.0D+00 * atan ( 1.0D+00 ) dt = pi/ real ( nm1, kind = 8 ) fk = 0.0D+00 do k=2,ns2 kc = np1-k fk = fk + 1.0D+00 wsave(k) = 2.0D+00 * sin(fk*dt) wsave(kc) = 2.0D+00 * cos(fk*dt) end do lnsv = nm1 + int(log( real ( nm1, kind = 8 ) )/log( 2.0D+00 )) +4 call rfftmi (nm1, wsave(n+1), lnsv, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('costmi',-5) end if return end subroutine mcsqb1 (lot,jump,n,inc,x,wsave,work,ier) !*****************************************************************************80 ! !! MCSQB1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lot integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np2 integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lot,*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xim1 ier = 0 lj = (lot-1)*jump+1 ns2 = (n+1)/2 np2 = n+2 do i=3,n,2 do m=1,lj,jump xim1 = x(m,i-1)+x(m,i) x(m,i) = 0.5D+00 * (x(m,i-1)-x(m,i)) x(m,i-1) = 0.5D+00 * xim1 end do end do do m=1,lj,jump x(m,1) = 0.5D+00 * x(m,1) end do modn = mod(n,2) if (modn == 0) then do m=1,lj,jump x(m,n) = 0.5D+00 * x(m,n) end do end if lenx = (lot-1)*jump + inc*(n-1) + 1 lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = lot*n call rfftmb(lot,jump,n,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('mcsqb1',-5) return end if do k=2,ns2 kc = np2-k m1 = 0 do m=1,lj,jump m1 = m1 + 1 work(m1,k) = wsave(k-1)*x(m,kc)+wsave(kc-1)*x(m,k) work(m1,kc) = wsave(k-1)*x(m,k)-wsave(kc-1)*x(m,kc) end do end do if (modn == 0) then do m=1,lj,jump x(m,ns2+1) = wsave(ns2)*(x(m,ns2+1)+x(m,ns2+1)) end do end if do k=2,ns2 kc = np2-k m1 = 0 do m=1,lj,jump m1 = m1 + 1 x(m,k) = work(m1,k)+work(m1,kc) x(m,kc) = work(m1,k)-work(m1,kc) end do end do do m=1,lj,jump x(m,1) = x(m,1)+x(m,1) end do return end subroutine mcsqf1 (lot,jump,n,inc,x,wsave,work,ier) !*****************************************************************************80 ! !! MCSQF1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lot integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lj integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np2 integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lot,*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xim1 ier = 0 lj = (lot-1)*jump+1 ns2 = (n+1)/2 np2 = n+2 do k=2,ns2 kc = np2-k m1 = 0 do m=1,lj,jump m1 = m1 + 1 work(m1,k) = x(m,k)+x(m,kc) work(m1,kc) = x(m,k)-x(m,kc) end do end do modn = mod(n,2) if (modn == 0) then m1 = 0 do m=1,lj,jump m1 = m1 + 1 work(m1,ns2+1) = x(m,ns2+1)+x(m,ns2+1) end do end if do 102 k=2,ns2 kc = np2-k m1 = 0 do 302 m=1,lj,jump m1 = m1 + 1 x(m,k) = wsave(k-1)*work(m1,kc)+wsave(kc-1)*work(m1,k) x(m,kc) = wsave(k-1)*work(m1,k) -wsave(kc-1)*work(m1,kc) 302 continue 102 continue if (modn /= 0) go to 303 m1 = 0 do 304 m=1,lj,jump m1 = m1 + 1 x(m,ns2+1) = wsave(ns2)*work(m1,ns2+1) 304 continue 303 continue lenx = (lot-1)*jump + inc*(n-1) + 1 lnsv = n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) + 4 lnwk = lot*n call rfftmf(lot,jump,n,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('mcsqf1',-5) go to 400 end if do 103 i=3,n,2 do 203 m=1,lj,jump xim1 = 0.5D+00 * (x(m,i-1)+x(m,i)) x(m,i) = 0.5D+00 * (x(m,i-1)-x(m,i)) x(m,i-1) = xim1 203 continue 103 continue 400 continue return end subroutine mcstb1(lot,jump,n,inc,x,wsave,dsum,work,ier) !*****************************************************************************80 ! !! MCSTB1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum(*) real ( kind = 8 ) fnm1s2 real ( kind = 8 ) fnm1s4 integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1h real ( kind = 8 ) x1p3 real ( kind = 8 ) x2 real ( kind = 8 ) xi ier = 0 nm1 = n-1 np1 = n+1 ns2 = n/2 lj = (lot-1)*jump+1 if (n-2) 106,101,102 101 do 111 m=1,lj,jump x1h = x(m,1)+x(m,2) x(m,2) = x(m,1)-x(m,2) x(m,1) = x1h 111 continue return 102 if ( 3 < n ) go to 103 do 112 m=1,lj,jump x1p3 = x(m,1)+x(m,3) x2 = x(m,2) x(m,2) = x(m,1)-x(m,3) x(m,1) = x1p3+x2 x(m,3) = x1p3-x2 112 continue return 103 do m=1,lj,jump x(m,1) = x(m,1)+x(m,1) x(m,n) = x(m,n)+x(m,n) end do m1 = 0 do m=1,lj,jump m1 = m1+1 dsum(m1) = x(m,1)-x(m,n) x(m,1) = x(m,1)+x(m,n) end do do 104 k=2,ns2 m1 = 0 do 114 m=1,lj,jump m1 = m1+1 kc = np1-k t1 = x(m,k)+x(m,kc) t2 = x(m,k)-x(m,kc) dsum(m1) = dsum(m1)+wsave(kc)*t2 t2 = wsave(k)*t2 x(m,k) = t1-t2 x(m,kc) = t1+t2 114 continue 104 continue modn = mod(n,2) if (modn == 0) go to 124 do 123 m=1,lj,jump x(m,ns2+1) = x(m,ns2+1)+x(m,ns2+1) 123 continue 124 continue lenx = (lot-1)*jump + inc*(nm1-1) + 1 lnsv = nm1 + int(log( real ( nm1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = lot*nm1 call rfftmf(lot,jump,nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('mcstb1',-5) go to 106 end if fnm1s2 = real ( nm1, kind = 8 ) / 2.0D+00 m1 = 0 do 10 m=1,lj,jump m1 = m1+1 dsum(m1) = 0.5D+00 * dsum(m1) x(m,1) = fnm1s2 * x(m,1) 10 continue if(mod(nm1,2) /= 0) go to 30 do 20 m=1,lj,jump x(m,nm1) = x(m,nm1)+x(m,nm1) 20 continue 30 fnm1s4 = real ( nm1, kind = 8 ) / 4.0D+00 do 105 i=3,n,2 m1 = 0 do 115 m=1,lj,jump m1 = m1+1 xi = fnm1s4*x(m,i) x(m,i) = fnm1s4*x(m,i-1) x(m,i-1) = dsum(m1) dsum(m1) = dsum(m1)+xi 115 continue 105 continue if (modn /= 0) return m1 = 0 do m=1,lj,jump m1 = m1+1 x(m,n) = dsum(m1) end do 106 continue return end subroutine mcstf1(lot,jump,n,inc,x,wsave,dsum,work,ier) !*****************************************************************************80 ! !! MCSTF1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum(*) integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) nm1 integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) snm1 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) tx2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) x1h real ( kind = 8 ) x1p3 real ( kind = 8 ) xi ier = 0 nm1 = n-1 np1 = n+1 ns2 = n/2 lj = (lot-1)*jump+1 if (n-2) 200,101,102 101 do 111 m=1,lj,jump x1h = x(m,1)+x(m,2) x(m,2) = 0.5D+00 * (x(m,1)-x(m,2)) x(m,1) = 0.5D+00 * x1h 111 continue go to 200 102 if ( 3 < n ) go to 103 do 112 m=1,lj,jump x1p3 = x(m,1)+x(m,3) tx2 = x(m,2)+x(m,2) x(m,2) = 0.5D+00 * (x(m,1)-x(m,3)) x(m,1) = 0.25D+00 * (x1p3+tx2) x(m,3) = 0.25D+00 * (x1p3-tx2) 112 continue go to 200 103 m1 = 0 do 113 m=1,lj,jump m1 = m1+1 dsum(m1) = x(m,1)-x(m,n) x(m,1) = x(m,1)+x(m,n) 113 continue do 104 k=2,ns2 m1 = 0 do 114 m=1,lj,jump m1 = m1+1 kc = np1-k t1 = x(m,k)+x(m,kc) t2 = x(m,k)-x(m,kc) dsum(m1) = dsum(m1)+wsave(kc)*t2 t2 = wsave(k)*t2 x(m,k) = t1-t2 x(m,kc) = t1+t2 114 continue 104 continue modn = mod(n,2) if (modn == 0) go to 124 do 123 m=1,lj,jump x(m,ns2+1) = x(m,ns2+1)+x(m,ns2+1) 123 continue 124 continue lenx = (lot-1)*jump + inc*(nm1-1) + 1 lnsv = nm1 + int(log( real ( nm1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = lot*nm1 call rfftmf(lot,jump,nm1,inc,x,lenx,wsave(n+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('mcstf1',-5) return end if snm1 = 1.0D+00 / real ( nm1, kind = 8 ) do 10 m=1,lot dsum(m) = snm1*dsum(m) 10 continue if(mod(nm1,2) /= 0) go to 30 do 20 m=1,lj,jump x(m,nm1) = x(m,nm1)+x(m,nm1) 20 continue 30 do 105 i=3,n,2 m1 = 0 do 115 m=1,lj,jump m1 = m1+1 xi = 0.5D+00 * x(m,i) x(m,i) = 0.5D+00 * x(m,i-1) x(m,i-1) = dsum(m1) dsum(m1) = dsum(m1)+xi 115 continue 105 continue if (modn /= 0) go to 117 m1 = 0 do m=1,lj,jump m1 = m1+1 x(m,n) = dsum(m1) end do 117 continue do m=1,lj,jump x(m,1) = 0.5D+00 * x(m,1) x(m,n) = 0.5D+00 * x(m,n) end do 200 continue return end subroutine mradb2 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1) !*****************************************************************************80 ! !! MRADB2 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,2,l1) real ( kind = 8 ) ch(in2,ido,l1,2) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) wa1(ido) m1d = (m-1)*im1+1 m2s = 1-im2 do k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,1) = cc(m1,1,1,k)+cc(m1,ido,2,k) ch(m2,1,k,2) = cc(m1,1,1,k)-cc(m1,ido,2,k) end do end do if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,1) = cc(m1,i-1,1,k)+cc(m1,ic-1,2,k) ch(m2,i,k,1) = cc(m1,i,1,k)-cc(m1,ic,2,k) ch(m2,i-1,k,2) = wa1(i-2)*(cc(m1,i-1,1,k)-cc(m1,ic-1,2,k)) & -wa1(i-1)*(cc(m1,i,1,k)+cc(m1,ic,2,k)) ch(m2,i,k,2) = wa1(i-2)*(cc(m1,i,1,k)+cc(m1,ic,2,k))+wa1(i-1) & *(cc(m1,i-1,1,k)-cc(m1,ic-1,2,k)) 1002 continue 103 continue 104 continue if (mod(ido,2) == 1) return 105 do 106 k = 1, l1 m2 = m2s do 1003 m1=1,m1d,im1 m2 = m2+im2 ch(m2,ido,k,1) = cc(m1,ido,1,k)+cc(m1,ido,1,k) ch(m2,ido,k,2) = -(cc(m1,1,2,k)+cc(m1,1,2,k)) 1003 continue 106 continue 107 continue return end subroutine mradb3 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2) !*****************************************************************************80 ! !! MRADB3 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,3,l1) real ( kind = 8 ) ch(in2,ido,l1,3) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) taui real ( kind = 8 ) taur real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) m1d = (m-1)*im1+1 m2s = 1-im2 arg= 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00 taur=cos(arg) taui=sin(arg) do k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,1) = cc(m1,1,1,k)+ 2.0D+00 *cc(m1,ido,2,k) ch(m2,1,k,2) = cc(m1,1,1,k)+( 2.0D+00 *taur)*cc(m1,ido,2,k) & -( 2.0D+00 *taui)*cc(m1,1,3,k) ch(m2,1,k,3) = cc(m1,1,1,k)+( 2.0D+00 *taur)*cc(m1,ido,2,k) & + 2.0D+00 *taui*cc(m1,1,3,k) end do end do if (ido == 1) then return end if idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,1) = cc(m1,i-1,1,k)+(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) ch(m2,i,k,1) = cc(m1,i,1,k)+(cc(m1,i,3,k)-cc(m1,ic,2,k)) ch(m2,i-1,k,2) = wa1(i-2)* & ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))- & (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) & -wa1(i-1)* & ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))+ & (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) ch(m2,i,k,2) = wa1(i-2)* & ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))+ & (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) & +wa1(i-1)* & ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))- & (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) ch(m2,i-1,k,3) = wa2(i-2)* & ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))+ & (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) & -wa2(i-1)* & ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))- & (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) ch(m2,i,k,3) = wa2(i-2)* & ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))- & (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) & +wa2(i-1)* & ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))+ & (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) 1002 continue 102 continue 103 continue return end subroutine mradb4 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3) !*****************************************************************************80 ! !! MRADB4 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,4,l1) real ( kind = 8 ) ch(in2,ido,l1,4) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) sqrt2 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) m1d = (m-1)*im1+1 m2s = 1-im2 sqrt2=sqrt( 2.0D+00 ) do 101 k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,3) = (cc(m1,1,1,k)+cc(m1,ido,4,k)) & -(cc(m1,ido,2,k)+cc(m1,ido,2,k)) ch(m2,1,k,1) = (cc(m1,1,1,k)+cc(m1,ido,4,k)) & +(cc(m1,ido,2,k)+cc(m1,ido,2,k)) ch(m2,1,k,4) = (cc(m1,1,1,k)-cc(m1,ido,4,k)) & +(cc(m1,1,3,k)+cc(m1,1,3,k)) ch(m2,1,k,2) = (cc(m1,1,1,k)-cc(m1,ido,4,k)) & -(cc(m1,1,3,k)+cc(m1,1,3,k)) end do 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,1) = (cc(m1,i-1,1,k)+cc(m1,ic-1,4,k)) & +(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) ch(m2,i,k,1) = (cc(m1,i,1,k)-cc(m1,ic,4,k)) & +(cc(m1,i,3,k)-cc(m1,ic,2,k)) ch(m2,i-1,k,2)=wa1(i-2)*((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k)) & -(cc(m1,i,3,k)+cc(m1,ic,2,k)))-wa1(i-1) & *((cc(m1,i,1,k)+cc(m1,ic,4,k))+(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))) ch(m2,i,k,2)=wa1(i-2)*((cc(m1,i,1,k)+cc(m1,ic,4,k)) & +(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))+wa1(i-1) & *((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k))-(cc(m1,i,3,k)+cc(m1,ic,2,k))) ch(m2,i-1,k,3)=wa2(i-2)*((cc(m1,i-1,1,k)+cc(m1,ic-1,4,k)) & -(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))-wa2(i-1) & *((cc(m1,i,1,k)-cc(m1,ic,4,k))-(cc(m1,i,3,k)-cc(m1,ic,2,k))) ch(m2,i,k,3)=wa2(i-2)*((cc(m1,i,1,k)-cc(m1,ic,4,k)) & -(cc(m1,i,3,k)-cc(m1,ic,2,k)))+wa2(i-1) & *((cc(m1,i-1,1,k)+cc(m1,ic-1,4,k))-(cc(m1,i-1,3,k) & +cc(m1,ic-1,2,k))) ch(m2,i-1,k,4)=wa3(i-2)*((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k)) & +(cc(m1,i,3,k)+cc(m1,ic,2,k)))-wa3(i-1) & *((cc(m1,i,1,k)+cc(m1,ic,4,k))-(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))) ch(m2,i,k,4)=wa3(i-2)*((cc(m1,i,1,k)+cc(m1,ic,4,k)) & -(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))+wa3(i-1) & *((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k))+(cc(m1,i,3,k)+cc(m1,ic,2,k))) 1002 continue 103 continue 104 continue if (mod(ido,2) == 1) return 105 continue do 106 k = 1, l1 m2 = m2s do 1003 m1=1,m1d,im1 m2 = m2+im2 ch(m2,ido,k,1) = (cc(m1,ido,1,k)+cc(m1,ido,3,k)) & +(cc(m1,ido,1,k)+cc(m1,ido,3,k)) ch(m2,ido,k,2) = sqrt2*((cc(m1,ido,1,k)-cc(m1,ido,3,k)) & -(cc(m1,1,2,k)+cc(m1,1,4,k))) ch(m2,ido,k,3) = (cc(m1,1,4,k)-cc(m1,1,2,k)) & +(cc(m1,1,4,k)-cc(m1,1,2,k)) ch(m2,ido,k,4) = -sqrt2*((cc(m1,ido,1,k)-cc(m1,ido,3,k)) & +(cc(m1,1,2,k)+cc(m1,1,4,k))) 1003 continue 106 continue 107 continue return end subroutine mradb5 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3,wa4) !*****************************************************************************80 ! !! MRADB5 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,5,l1) real ( kind = 8 ) ch(in2,ido,l1,5) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) ti11 real ( kind = 8 ) ti12 real ( kind = 8 ) tr11 real ( kind = 8 ) tr12 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) wa4(ido) m1d = (m-1)*im1+1 m2s = 1-im2 arg= 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 5.0D+00 tr11=cos(arg) ti11=sin(arg) tr12=cos( 2.0D+00 *arg) ti12=sin( 2.0D+00 *arg) do 101 k = 1, l1 m2 = m2s do 1001 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,1) = cc(m1,1,1,k)+ 2.0D+00 *cc(m1,ido,2,k) & + 2.0D+00 *cc(m1,ido,4,k) ch(m2,1,k,2) = (cc(m1,1,1,k)+tr11* 2.0D+00 *cc(m1,ido,2,k) & +tr12* 2.0D+00 *cc(m1,ido,4,k))-(ti11* 2.0D+00 *cc(m1,1,3,k) & +ti12* 2.0D+00 *cc(m1,1,5,k)) ch(m2,1,k,3) = (cc(m1,1,1,k)+tr12* 2.0D+00 *cc(m1,ido,2,k) & +tr11* 2.0D+00 *cc(m1,ido,4,k))-(ti12* 2.0D+00 *cc(m1,1,3,k) & -ti11* 2.0D+00 *cc(m1,1,5,k)) ch(m2,1,k,4) = (cc(m1,1,1,k)+tr12* 2.0D+00 *cc(m1,ido,2,k) & +tr11* 2.0D+00 *cc(m1,ido,4,k))+(ti12* 2.0D+00 *cc(m1,1,3,k) & -ti11* 2.0D+00 *cc(m1,1,5,k)) ch(m2,1,k,5) = (cc(m1,1,1,k)+tr11* 2.0D+00 *cc(m1,ido,2,k) & +tr12* 2.0D+00 *cc(m1,ido,4,k))+(ti11* 2.0D+00 *cc(m1,1,3,k) & +ti12* 2.0D+00 *cc(m1,1,5,k)) 1001 continue 101 continue if (ido == 1) return idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,1) = cc(m1,i-1,1,k)+(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)) ch(m2,i,k,1) = cc(m1,i,1,k)+(cc(m1,i,3,k)-cc(m1,ic,2,k)) & +(cc(m1,i,5,k)-cc(m1,ic,4,k)) ch(m2,i-1,k,2) = wa1(i-2)*((cc(m1,i-1,1,k)+tr11* & (cc(m1,i-1,3,k)+cc(m1,ic-1,2,k))+tr12 & *(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti11*(cc(m1,i,3,k) & +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) & -wa1(i-1)*((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) & +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))+(ti11*(cc(m1,i-1,3,k) & -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) ch(m2,i,k,2) = wa1(i-2)*((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k) & -cc(m1,ic,2,k))+tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k))) & +(ti11*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))+ti12 & *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k))))+wa1(i-1) & *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k) & +cc(m1,ic-1,2,k))+tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k))) & -(ti11*(cc(m1,i,3,k)+cc(m1,ic,2,k))+ti12 & *(cc(m1,i,5,k)+cc(m1,ic,4,k)))) ch(m2,i-1,k,3) = wa2(i-2) & *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti12*(cc(m1,i,3,k) & +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) & -wa2(i-1) & *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- & cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) & +(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 & *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) ch(m2,i,k,3) = wa2(i-2) & *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- & cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) & +(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 & *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) & +wa2(i-1) & *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti12*(cc(m1,i,3,k) & +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) ch(m2,i-1,k,4) = wa3(i-2) & *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti12*(cc(m1,i,3,k) & +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) & -wa3(i-1) & *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- & cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) & -(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 & *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) ch(m2,i,k,4) = wa3(i-2) & *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- & cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) & -(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 & *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) & +wa3(i-1) & *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti12*(cc(m1,i,3,k) & +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) ch(m2,i-1,k,5) = wa4(i-2) & *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti11*(cc(m1,i,3,k) & +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) & -wa4(i-1) & *((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) & +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))-(ti11*(cc(m1,i-1,3,k) & -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) ch(m2,i,k,5) = wa4(i-2) & *((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) & +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))-(ti11*(cc(m1,i-1,3,k) & -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) & +wa4(i-1) & *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) & +tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti11*(cc(m1,i,3,k) & +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) 1002 continue 102 continue 103 continue return end subroutine mradbg (m,ido,ip,l1,idl1,cc,c1,c2,im1,in1,ch,ch2,im2,in2,wa) !*****************************************************************************80 ! !! MRADBG is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(in1,ido,l1,ip) real ( kind = 8 ) c2(in1,idl1,ip) real ( kind = 8 ) cc(in1,ido,ip,l1) real ( kind = 8 ) ch(in2,ido,l1,ip) real ( kind = 8 ) ch2(in2,idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) idp2 integer ( kind = 4 ) ik integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) nbd real ( kind = 8 ) tpi real ( kind = 8 ) wa(ido) m1d = ( m - 1 ) * im1 + 1 m2s = 1 - im2 tpi = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) arg = tpi / real ( ip, kind = 8 ) dcp = cos ( arg ) dsp = sin ( arg ) idp2 = ido + 2 nbd = (ido-1)/2 ipp2 = ip+2 ipph = (ip+1)/2 if (ido < l1) go to 103 do k = 1, l1 do i=1,ido m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(m2,i,k,1) = cc(m1,i,1,k) end do end do end do go to 106 103 do 105 i=1,ido do 104 k = 1, l1 m2 = m2s do 1004 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i,k,1) = cc(m1,i,1,k) 1004 continue 104 continue 105 continue 106 do 108 j=2,ipph jc = ipp2-j j2 = j+j do 107 k = 1, l1 m2 = m2s do 1007 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,j) = cc(m1,ido,j2-2,k)+cc(m1,ido,j2-2,k) ch(m2,1,k,jc) = cc(m1,1,j2-1,k)+cc(m1,1,j2-1,k) 1007 continue 107 continue 108 continue if (ido == 1) go to 116 if (nbd < l1) go to 112 do 111 j=2,ipph jc = ipp2-j do 110 k = 1, l1 do 109 i=3,ido,2 ic = idp2-i m2 = m2s do 1009 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = cc(m1,i-1,2*j-1,k)+cc(m1,ic-1,2*j-2,k) ch(m2,i-1,k,jc) = cc(m1,i-1,2*j-1,k)-cc(m1,ic-1,2*j-2,k) ch(m2,i,k,j) = cc(m1,i,2*j-1,k)-cc(m1,ic,2*j-2,k) ch(m2,i,k,jc) = cc(m1,i,2*j-1,k)+cc(m1,ic,2*j-2,k) 1009 continue 109 continue 110 continue 111 continue go to 116 112 do 115 j=2,ipph jc = ipp2-j do 114 i=3,ido,2 ic = idp2-i do 113 k = 1, l1 m2 = m2s do 1013 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = cc(m1,i-1,2*j-1,k)+cc(m1,ic-1,2*j-2,k) ch(m2,i-1,k,jc) = cc(m1,i-1,2*j-1,k)-cc(m1,ic-1,2*j-2,k) ch(m2,i,k,j) = cc(m1,i,2*j-1,k)-cc(m1,ic,2*j-2,k) ch(m2,i,k,jc) = cc(m1,i,2*j-1,k)+cc(m1,ic,2*j-2,k) 1013 continue 113 continue 114 continue 115 continue 116 ar1 = 1.0D+00 ai1 = 0.0D+00 do 120 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 117 ik=1,idl1 m2 = m2s do 1017 m1=1,m1d,im1 m2 = m2+im2 c2(m1,ik,l) = ch2(m2,ik,1)+ar1*ch2(m2,ik,2) c2(m1,ik,lc) = ai1*ch2(m2,ik,ip) 1017 continue 117 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 119 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 118 ik=1,idl1 m2 = m2s do 1018 m1=1,m1d,im1 m2 = m2+im2 c2(m1,ik,l) = c2(m1,ik,l)+ar2*ch2(m2,ik,j) c2(m1,ik,lc) = c2(m1,ik,lc)+ai2*ch2(m2,ik,jc) 1018 continue 118 continue 119 continue 120 continue do 122 j=2,ipph do 121 ik=1,idl1 m2 = m2s do 1021 m1=1,m1d,im1 m2 = m2+im2 ch2(m2,ik,1) = ch2(m2,ik,1)+ch2(m2,ik,j) 1021 continue 121 continue 122 continue do 124 j=2,ipph jc = ipp2-j do 123 k = 1, l1 m2 = m2s do 1023 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,j) = c1(m1,1,k,j)-c1(m1,1,k,jc) ch(m2,1,k,jc) = c1(m1,1,k,j)+c1(m1,1,k,jc) 1023 continue 123 continue 124 continue if (ido == 1) go to 132 if (nbd < l1) go to 128 do 127 j=2,ipph jc = ipp2-j do 126 k = 1, l1 do 125 i=3,ido,2 m2 = m2s do 1025 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = c1(m1,i-1,k,j)-c1(m1,i,k,jc) ch(m2,i-1,k,jc) = c1(m1,i-1,k,j)+c1(m1,i,k,jc) ch(m2,i,k,j) = c1(m1,i,k,j)+c1(m1,i-1,k,jc) ch(m2,i,k,jc) = c1(m1,i,k,j)-c1(m1,i-1,k,jc) 1025 continue 125 continue 126 continue 127 continue go to 132 128 do 131 j=2,ipph jc = ipp2-j do 130 i=3,ido,2 do 129 k = 1, l1 m2 = m2s do 1029 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = c1(m1,i-1,k,j)-c1(m1,i,k,jc) ch(m2,i-1,k,jc) = c1(m1,i-1,k,j)+c1(m1,i,k,jc) ch(m2,i,k,j) = c1(m1,i,k,j)+c1(m1,i-1,k,jc) ch(m2,i,k,jc) = c1(m1,i,k,j)-c1(m1,i-1,k,jc) 1029 continue 129 continue 130 continue 131 continue 132 continue if (ido == 1) return do 133 ik=1,idl1 m2 = m2s do 1033 m1=1,m1d,im1 m2 = m2+im2 c2(m1,ik,1) = ch2(m2,ik,1) 1033 continue 133 continue do 135 j=2,ip do 134 k = 1, l1 m2 = m2s do 1034 m1=1,m1d,im1 m2 = m2+im2 c1(m1,1,k,j) = ch(m2,1,k,j) 1034 continue 134 continue 135 continue if (l1 < nbd ) go to 139 is = -ido do 138 j=2,ip is = is+ido idij = is do 137 i=3,ido,2 idij = idij+2 do 136 k = 1, l1 m2 = m2s do 1036 m1=1,m1d,im1 m2 = m2+im2 c1(m1,i-1,k,j) = wa(idij-1)*ch(m2,i-1,k,j)-wa(idij)* ch(m2,i,k,j) c1(m1,i,k,j) = wa(idij-1)*ch(m2,i,k,j)+wa(idij)* ch(m2,i-1,k,j) 1036 continue 136 continue 137 continue 138 continue go to 143 139 is = -ido do 142 j=2,ip is = is+ido do 141 k = 1, l1 idij = is do 140 i=3,ido,2 idij = idij+2 m2 = m2s do 1040 m1=1,m1d,im1 m2 = m2+im2 c1(m1,i-1,k,j) = wa(idij-1)*ch(m2,i-1,k,j)-wa(idij)*ch(m2,i,k,j) c1(m1,i,k,j) = wa(idij-1)*ch(m2,i,k,j)+wa(idij)*ch(m2,i-1,k,j) 1040 continue 140 continue 141 continue 142 continue 143 continue return end subroutine mradf2 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1) !*****************************************************************************80 ! !! MRADF2 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,l1,2) real ( kind = 8 ) ch(in2,ido,2,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) wa1(ido) m1d = (m-1)*im1+1 m2s = 1-im2 do 101 k = 1, l1 m2 = m2s do m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,1,k) = cc(m1,1,k,1)+cc(m1,1,k,2) ch(m2,ido,2,k) = cc(m1,1,k,1)-cc(m1,1,k,2) end do 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i m2 = m2s do 1003 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i,1,k) = cc(m1,i,k,1)+(wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2)) ch(m2,ic,2,k) = (wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* & cc(m1,i-1,k,2))-cc(m1,i,k,1) ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+(wa1(i-2)*cc(m1,i-1,k,2)+ & wa1(i-1)*cc(m1,i,k,2)) ch(m2,ic-1,2,k) = cc(m1,i-1,k,1)-(wa1(i-2)*cc(m1,i-1,k,2)+ & wa1(i-1)*cc(m1,i,k,2)) 1003 continue 103 continue 104 continue if (mod(ido,2) == 1) return 105 do 106 k = 1, l1 m2 = m2s do 1006 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,2,k) = -cc(m1,ido,k,2) ch(m2,ido,1,k) = cc(m1,ido,k,1) 1006 continue 106 continue 107 continue return end subroutine mradf3 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2) !*****************************************************************************80 ! !! MRADF3 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,l1,3) real ( kind = 8 ) ch(in2,ido,3,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) taui real ( kind = 8 ) taur real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) m1d = (m-1)*im1+1 m2s = 1-im2 arg= 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00 taur=cos(arg) taui=sin(arg) do 101 k = 1, l1 m2 = m2s do 1001 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,1,k) = cc(m1,1,k,1)+(cc(m1,1,k,2)+cc(m1,1,k,3)) ch(m2,1,3,k) = taui*(cc(m1,1,k,3)-cc(m1,1,k,2)) ch(m2,ido,2,k) = cc(m1,1,k,1)+taur*(cc(m1,1,k,2)+cc(m1,1,k,3)) 1001 continue 101 continue if (ido == 1) then return end if idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ & wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))) ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))) ch(m2,i-1,3,k) = (cc(m1,i-1,k,1)+taur*((wa1(i-2)* & cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* & cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))))+(taui*((wa1(i-2)* & cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa2(i-2)* & cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3)))) ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)+taur*((wa1(i-2)* & cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* & cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))))-(taui*((wa1(i-2)* & cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa2(i-2)* & cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3)))) ch(m2,i,3,k) = (cc(m1,i,k,1)+taur*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))))+(taui*((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))) ch(m2,ic,2,k) = (taui*((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2))))-(cc(m1,i,k,1)+taur*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3)))) 1002 continue 102 continue 103 continue return end subroutine mradf4 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3) !*****************************************************************************80 ! !! MRADF4 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,l1,4) real ( kind = 8 ) ch(in2,ido,4,l1) real ( kind = 8 ) hsqt2 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) hsqt2=sqrt( 2.0D+00 ) / 2.0D+00 m1d = (m-1)*im1+1 m2s = 1-im2 do 101 k = 1, l1 m2 = m2s do 1001 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,1,k) = (cc(m1,1,k,2)+cc(m1,1,k,4)) & +(cc(m1,1,k,1)+cc(m1,1,k,3)) ch(m2,ido,4,k) = (cc(m1,1,k,1)+cc(m1,1,k,3)) & -(cc(m1,1,k,2)+cc(m1,1,k,4)) ch(m2,ido,2,k) = cc(m1,1,k,1)-cc(m1,1,k,3) ch(m2,1,3,k) = cc(m1,1,k,4)-cc(m1,1,k,2) 1001 continue 101 continue if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i m2 = m2s do 1003 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,1,k) = ((wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4)))+(cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ & wa2(i-1)*cc(m1,i,k,3))) ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ & wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i-1,k,2)+ & wa1(i-1)*cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4)+ & wa3(i-1)*cc(m1,i,k,4))) ch(m2,i,1,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* & cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4)))+(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- & wa2(i-1)*cc(m1,i-1,k,3))) ch(m2,ic,4,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* & cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4)))-(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- & wa2(i-1)*cc(m1,i-1,k,3))) ch(m2,i-1,3,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* & cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4)))+(cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ & wa2(i-1)*cc(m1,i,k,3))) ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ & wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* & cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4))) ch(m2,i,3,k) = ((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))+(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- & wa2(i-1)*cc(m1,i-1,k,3))) ch(m2,ic,2,k) = ((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))-(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- & wa2(i-1)*cc(m1,i-1,k,3))) 1003 continue 103 continue 104 continue if (mod(ido,2) == 1) return 105 continue do 106 k = 1, l1 m2 = m2s do 1006 m1=1,m1d,im1 m2 = m2+im2 ch(m2,ido,1,k) = (hsqt2*(cc(m1,ido,k,2)-cc(m1,ido,k,4)))+ & cc(m1,ido,k,1) ch(m2,ido,3,k) = cc(m1,ido,k,1)-(hsqt2*(cc(m1,ido,k,2)- & cc(m1,ido,k,4))) ch(m2,1,2,k) = (-hsqt2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))- & cc(m1,ido,k,3) ch(m2,1,4,k) = (-hsqt2*(cc(m1,ido,k,2)+cc(m1,ido,k,4)))+ & cc(m1,ido,k,3) 1006 continue 106 continue 107 continue return end subroutine mradf5 (m,ido,l1,cc,im1,in1,ch,im2,in2,wa1,wa2,wa3,wa4) !*****************************************************************************80 ! !! MRADF5 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,l1,5) real ( kind = 8 ) ch(in2,ido,5,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) k integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s real ( kind = 8 ) ti11 real ( kind = 8 ) ti12 real ( kind = 8 ) tr11 real ( kind = 8 ) tr12 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) wa4(ido) m1d = (m-1)*im1+1 m2s = 1-im2 arg= 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 5.0D+00 tr11=cos(arg) ti11=sin(arg) tr12=cos( 2.0D+00 *arg) ti12=sin( 2.0D+00 *arg) do 101 k = 1, l1 m2 = m2s do 1001 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,1,k) = cc(m1,1,k,1)+(cc(m1,1,k,5)+cc(m1,1,k,2))+ & (cc(m1,1,k,4)+cc(m1,1,k,3)) ch(m2,ido,2,k) = cc(m1,1,k,1)+tr11*(cc(m1,1,k,5)+cc(m1,1,k,2))+ & tr12*(cc(m1,1,k,4)+cc(m1,1,k,3)) ch(m2,1,3,k) = ti11*(cc(m1,1,k,5)-cc(m1,1,k,2))+ti12* & (cc(m1,1,k,4)-cc(m1,1,k,3)) ch(m2,ido,4,k) = cc(m1,1,k,1)+tr12*(cc(m1,1,k,5)+cc(m1,1,k,2))+ & tr11*(cc(m1,1,k,4)+cc(m1,1,k,3)) ch(m2,1,5,k) = ti12*(cc(m1,1,k,5)-cc(m1,1,k,2))-ti11* & (cc(m1,1,k,4)-cc(m1,1,k,3)) 1001 continue 101 continue if (ido == 1) return idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ & wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* & cc(m1,i,k,5)))+((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))+(wa3(i-2)*cc(m1,i-1,k,4)+ & wa3(i-1)*cc(m1,i,k,4))) ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* & cc(m1,i-1,k,5)))+((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4))) ch(m2,i-1,3,k) = cc(m1,i-1,k,1)+tr11* & ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) & +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+tr12* & ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) & +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))+ti11* & ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) & -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+ti12* & ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) & -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))) ch(m2,ic-1,2,k) = cc(m1,i-1,k,1)+tr11* & ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) & +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+tr12* & ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) & +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))-(ti11* & ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) & -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+ti12* & ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) & -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4)))) ch(m2,i,3,k) = (cc(m1,i,k,1)+tr11*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* & cc(m1,i-1,k,5)))+tr12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4))))+(ti11*((wa4(i-2)*cc(m1,i-1,k,5)+ & wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))+ti12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3)))) ch(m2,ic,2,k) = (ti11*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* & cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))+ti12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))))-(cc(m1,i,k,1)+tr11*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* & cc(m1,i-1,k,5)))+tr12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4)))) ch(m2,i-1,5,k) = (cc(m1,i-1,k,1)+tr12*((wa1(i-2)* & cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* & cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+tr11*((wa2(i-2)* & cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* & cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))+(ti12*((wa1(i-2)* & cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* & cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-ti11*((wa2(i-2)* & cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* & cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4)))) ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+tr12*((wa1(i-2)* & cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* & cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+tr11*((wa2(i-2)* & cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* & cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))-(ti12*((wa1(i-2)* & cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* & cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-ti11*((wa2(i-2)* & cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* & cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4)))) ch(m2,i,5,k) = (cc(m1,i,k,1)+tr12*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* & cc(m1,i-1,k,5)))+tr11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4))))+(ti12*((wa4(i-2)*cc(m1,i-1,k,5)+ & wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))-ti11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3)))) ch(m2,ic,4,k) = (ti12*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* & cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* & cc(m1,i,k,2)))-ti11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* & cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* & cc(m1,i,k,3))))-(cc(m1,i,k,1)+tr12*((wa1(i-2)*cc(m1,i,k,2)- & wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* & cc(m1,i-1,k,5)))+tr11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* & cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* & cc(m1,i-1,k,4)))) 1002 continue 102 continue 103 continue return end subroutine mradfg (m,ido,ip,l1,idl1,cc,c1,c2,im1,in1,ch,ch2,im2,in2,wa) !*****************************************************************************80 ! !! MRADFG is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(in1,ido,l1,ip) real ( kind = 8 ) c2(in1,idl1,ip) real ( kind = 8 ) cc(in1,ido,ip,l1) real ( kind = 8 ) ch(in2,ido,l1,ip) real ( kind = 8 ) ch2(in2,idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) idp2 integer ( kind = 4 ) ik integer ( kind = 4 ) im1 integer ( kind = 4 ) im2 integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) m1d integer ( kind = 4 ) m2 integer ( kind = 4 ) m2s integer ( kind = 4 ) nbd real ( kind = 8 ) tpi real ( kind = 8 ) wa(ido) m1d = (m-1)*im1+1 m2s = 1-im2 tpi= 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) arg = tpi / real ( ip, kind = 8 ) dcp = cos(arg) dsp = sin(arg) ipph = (ip+1)/2 ipp2 = ip+2 idp2 = ido+2 nbd = (ido-1)/2 if (ido == 1) go to 119 do 101 ik=1,idl1 m2 = m2s do 1001 m1=1,m1d,im1 m2 = m2+im2 ch2(m2,ik,1) = c2(m1,ik,1) 1001 continue 101 continue do 103 j=2,ip do 102 k = 1, l1 m2 = m2s do 1002 m1=1,m1d,im1 m2 = m2+im2 ch(m2,1,k,j) = c1(m1,1,k,j) 1002 continue 102 continue 103 continue if ( l1 < nbd ) go to 107 is = -ido do 106 j=2,ip is = is+ido idij = is do 105 i=3,ido,2 idij = idij+2 do 104 k = 1, l1 m2 = m2s do 1004 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = wa(idij-1)*c1(m1,i-1,k,j)+wa(idij)*c1(m1,i,k,j) ch(m2,i,k,j) = wa(idij-1)*c1(m1,i,k,j)-wa(idij)*c1(m1,i-1,k,j) 1004 continue 104 continue 105 continue 106 continue go to 111 107 is = -ido do 110 j=2,ip is = is+ido do 109 k = 1, l1 idij = is do 108 i=3,ido,2 idij = idij+2 m2 = m2s do 1008 m1=1,m1d,im1 m2 = m2+im2 ch(m2,i-1,k,j) = wa(idij-1)*c1(m1,i-1,k,j)+wa(idij)*c1(m1,i,k,j) ch(m2,i,k,j) = wa(idij-1)*c1(m1,i,k,j)-wa(idij)*c1(m1,i-1,k,j) 1008 continue 108 continue 109 continue 110 continue 111 if (nbd < l1) go to 115 do 114 j=2,ipph jc = ipp2-j do 113 k = 1, l1 do 112 i=3,ido,2 m2 = m2s do 1012 m1=1,m1d,im1 m2 = m2+im2 c1(m1,i-1,k,j) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc) c1(m1,i-1,k,jc) = ch(m2,i,k,j)-ch(m2,i,k,jc) c1(m1,i,k,j) = ch(m2,i,k,j)+ch(m2,i,k,jc) c1(m1,i,k,jc) = ch(m2,i-1,k,jc)-ch(m2,i-1,k,j) 1012 continue 112 continue 113 continue 114 continue go to 121 115 do 118 j=2,ipph jc = ipp2-j do 117 i=3,ido,2 do 116 k = 1, l1 m2 = m2s do 1016 m1=1,m1d,im1 m2 = m2+im2 c1(m1,i-1,k,j) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc) c1(m1,i-1,k,jc) = ch(m2,i,k,j)-ch(m2,i,k,jc) c1(m1,i,k,j) = ch(m2,i,k,j)+ch(m2,i,k,jc) c1(m1,i,k,jc) = ch(m2,i-1,k,jc)-ch(m2,i-1,k,j) 1016 continue 116 continue 117 continue 118 continue go to 121 119 do 120 ik=1,idl1 m2 = m2s do 1020 m1=1,m1d,im1 m2 = m2+im2 c2(m1,ik,1) = ch2(m2,ik,1) 1020 continue 120 continue 121 do 123 j=2,ipph jc = ipp2-j do 122 k = 1, l1 m2 = m2s do 1022 m1=1,m1d,im1 m2 = m2+im2 c1(m1,1,k,j) = ch(m2,1,k,j)+ch(m2,1,k,jc) c1(m1,1,k,jc) = ch(m2,1,k,jc)-ch(m2,1,k,j) 1022 continue 122 continue 123 continue ar1 = 1.0D+00 ai1 = 0.0D+00 do 127 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 124 ik=1,idl1 m2 = m2s do 1024 m1=1,m1d,im1 m2 = m2+im2 ch2(m2,ik,l) = c2(m1,ik,1)+ar1*c2(m1,ik,2) ch2(m2,ik,lc) = ai1*c2(m1,ik,ip) 1024 continue 124 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 126 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 125 ik=1,idl1 m2 = m2s do 1025 m1=1,m1d,im1 m2 = m2+im2 ch2(m2,ik,l) = ch2(m2,ik,l)+ar2*c2(m1,ik,j) ch2(m2,ik,lc) = ch2(m2,ik,lc)+ai2*c2(m1,ik,jc) 1025 continue 125 continue 126 continue 127 continue do 129 j=2,ipph do 128 ik=1,idl1 m2 = m2s do 1028 m1=1,m1d,im1 m2 = m2+im2 ch2(m2,ik,1) = ch2(m2,ik,1)+c2(m1,ik,j) 1028 continue 128 continue 129 continue if (ido < l1) go to 132 do 131 k = 1, l1 do 130 i=1,ido m2 = m2s do 1030 m1=1,m1d,im1 m2 = m2+im2 cc(m1,i,1,k) = ch(m2,i,k,1) 1030 continue 130 continue 131 continue go to 135 132 do 134 i=1,ido do 133 k = 1, l1 m2 = m2s do 1033 m1=1,m1d,im1 m2 = m2+im2 cc(m1,i,1,k) = ch(m2,i,k,1) 1033 continue 133 continue 134 continue 135 do 137 j=2,ipph jc = ipp2-j j2 = j+j do 136 k = 1, l1 m2 = m2s do 1036 m1=1,m1d,im1 m2 = m2+im2 cc(m1,ido,j2-2,k) = ch(m2,1,k,j) cc(m1,1,j2-1,k) = ch(m2,1,k,jc) 1036 continue 136 continue 137 continue if (ido == 1) return if (nbd < l1) go to 141 do 140 j=2,ipph jc = ipp2-j j2 = j+j do 139 k = 1, l1 do 138 i=3,ido,2 ic = idp2-i m2 = m2s do 1038 m1=1,m1d,im1 m2 = m2+im2 cc(m1,i-1,j2-1,k) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc) cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j)-ch(m2,i-1,k,jc) cc(m1,i,j2-1,k) = ch(m2,i,k,j)+ch(m2,i,k,jc) cc(m1,ic,j2-2,k) = ch(m2,i,k,jc)-ch(m2,i,k,j) 1038 continue 138 continue 139 continue 140 continue return 141 do 144 j=2,ipph jc = ipp2-j j2 = j+j do 143 i=3,ido,2 ic = idp2-i do 142 k = 1, l1 m2 = m2s do 1042 m1=1,m1d,im1 m2 = m2+im2 cc(m1,i-1,j2-1,k) = ch(m2,i-1,k,j)+ch(m2,i-1,k,jc) cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j)-ch(m2,i-1,k,jc) cc(m1,i,j2-1,k) = ch(m2,i,k,j)+ch(m2,i,k,jc) cc(m1,ic,j2-2,k) = ch(m2,i,k,jc)-ch(m2,i,k,j) 1042 continue 142 continue 143 continue 144 continue return end subroutine mrftb1 (m,im,n,in,c,ch,wa,fac) !*****************************************************************************80 ! !! MRFTB1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) in integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) c(in,*) real ( kind = 8 ) ch(m,*) real ( kind = 8 ) fac(15) real ( kind = 8 ) half real ( kind = 8 ) halfm integer ( kind = 4 ) i integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) im integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) m2 integer ( kind = 4 ) modn integer ( kind = 4 ) na integer ( kind = 4 ) nf integer ( kind = 4 ) nl real ( kind = 8 ) wa(n) nf = fac(2) na = 0 do k1=1,nf ip = fac(k1+2) na = 1-na if(ip <= 5) go to 10 if(k1 == nf) go to 10 na = 1-na 10 continue end do half = 0.5D+00 halfm = -0.5D+00 modn = mod(n,2) nl = n-2 if(modn /= 0) nl = n-1 if (na == 0) go to 120 m2 = 1-im do 117 i=1,m m2 = m2+im ch(i,1) = c(m2,1) ch(i,n) = c(m2,n) 117 continue do 118 j=2,nl,2 m2 = 1-im do 118 i=1,m m2 = m2+im ch(i,j) = half*c(m2,j) ch(i,j+1) = halfm*c(m2,j+1) 118 continue go to 124 120 continue do 122 j=2,nl,2 m2 = 1-im do 122 i=1,m m2 = m2+im c(m2,j) = half*c(m2,j) c(m2,j+1) = halfm*c(m2,j+1) 122 continue 124 l1 = 1 iw = 1 do 116 k1=1,nf ip = fac(k1+2) l2 = ip*l1 ido = n/l2 idl1 = ido*l1 if (ip /= 4) go to 103 ix2 = iw+ido ix3 = ix2+ido if (na /= 0) go to 101 call mradb4 (m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3)) go to 102 101 call mradb4 (m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3)) 102 na = 1-na go to 115 103 if (ip /= 2) go to 106 if (na /= 0) go to 104 call mradb2 (m,ido,l1,c,im,in,ch,1,m,wa(iw)) go to 105 104 call mradb2 (m,ido,l1,ch,1,m,c,im,in,wa(iw)) 105 na = 1-na go to 115 106 if (ip /= 3) go to 109 ix2 = iw+ido if (na /= 0) go to 107 call mradb3 (m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2)) go to 108 107 call mradb3 (m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2)) 108 na = 1-na go to 115 109 if (ip /= 5) go to 112 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na /= 0) go to 110 call mradb5 (m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 111 110 call mradb5 (m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3),wa(ix4)) 111 na = 1-na go to 115 112 if (na /= 0) go to 113 call mradbg (m,ido,ip,l1,idl1,c,c,c,im,in,ch,ch,1,m,wa(iw)) go to 114 113 call mradbg (m,ido,ip,l1,idl1,ch,ch,ch,1,m,c,c,im,in,wa(iw)) 114 if (ido == 1) na = 1-na 115 l1 = l2 iw = iw+(ip-1)*ido 116 continue return end subroutine mrftf1 (m,im,n,in,c,ch,wa,fac) !*****************************************************************************80 ! !! MRFTF1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) in integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) c(in,*) real ( kind = 8 ) ch(m,*) real ( kind = 8 ) fac(15) integer ( kind = 4 ) i integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) im integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) kh integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) m2 integer ( kind = 4 ) modn integer ( kind = 4 ) na integer ( kind = 4 ) nf integer ( kind = 4 ) nl real ( kind = 8 ) sn real ( kind = 8 ) tsn real ( kind = 8 ) tsnm real ( kind = 8 ) wa(n) nf = fac(2) na = 1 l2 = n iw = n do 111 k1=1,nf kh = nf-k1 ip = fac(kh+3) l1 = l2/ip ido = n/l2 idl1 = ido*l1 iw = iw-(ip-1)*ido na = 1-na if (ip /= 4) go to 102 ix2 = iw+ido ix3 = ix2+ido if (na /= 0) go to 101 call mradf4 (m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3)) go to 110 101 call mradf4 (m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3)) go to 110 102 if (ip /= 2) go to 104 if (na /= 0) go to 103 call mradf2 (m,ido,l1,c,im,in,ch,1,m,wa(iw)) go to 110 103 call mradf2 (m,ido,l1,ch,1,m,c,im,in,wa(iw)) go to 110 104 if (ip /= 3) go to 106 ix2 = iw+ido if (na /= 0) go to 105 call mradf3 (m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2)) go to 110 105 call mradf3 (m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2)) go to 110 106 if (ip /= 5) go to 108 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na /= 0) go to 107 call mradf5(m,ido,l1,c,im,in,ch,1,m,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 107 call mradf5(m,ido,l1,ch,1,m,c,im,in,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 108 if (ido == 1) na = 1-na if (na /= 0) go to 109 call mradfg (m,ido,ip,l1,idl1,c,c,c,im,in,ch,ch,1,m,wa(iw)) na = 1 go to 110 109 call mradfg (m,ido,ip,l1,idl1,ch,ch,ch,1,m,c,c,im,in,wa(iw)) na = 0 110 l2 = l1 111 continue sn = 1.0D+00 / real ( n, kind = 8 ) tsn = 2.0D+00 / real ( n, kind = 8 ) tsnm = -tsn modn = mod(n,2) nl = n-2 if(modn /= 0) nl = n-1 if (na /= 0) go to 120 m2 = 1-im do i=1,m m2 = m2+im c(m2,1) = sn*ch(i,1) end do do j=2,nl,2 m2 = 1-im do i=1,m m2 = m2+im c(m2,j) = tsn*ch(i,j) c(m2,j+1) = tsnm*ch(i,j+1) end do end do if(modn /= 0) return m2 = 1-im do 119 i=1,m m2 = m2+im c(m2,n) = sn*ch(i,n) 119 continue return 120 m2 = 1-im do 121 i=1,m m2 = m2+im c(m2,1) = sn*c(m2,1) 121 continue do 122 j=2,nl,2 m2 = 1-im do 122 i=1,m m2 = m2+im c(m2,j) = tsn*c(m2,j) c(m2,j+1) = tsnm*c(m2,j+1) 122 continue if(modn /= 0) return m2 = 1-im do i=1,m m2 = m2+im c(m2,n) = sn*c(m2,n) end do return end subroutine mrfti1 (n,wa,fac) !*****************************************************************************80 ! !! MRFTI1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number for which factorization and ! other information is needed. ! ! Output, real ( kind = 8 ) WA(N), trigonometric information. ! ! Output, real ( kind = 8 ) FAC(15), factorization information. FAC(1) is ! N, FAC(2) is NF, the number of factors, and FAC(3:NF+2) are the factors. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) arg real ( kind = 8 ) argh real ( kind = 8 ) argld real ( kind = 8 ) fac(15) real ( kind = 8 ) fi integer ( kind = 4 ) i integer ( kind = 4 ) ib integer ( kind = 4 ) ido integer ( kind = 4 ) ii integer ( kind = 4 ) ip integer ( kind = 4 ) ipm integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) ld integer ( kind = 4 ) nf integer ( kind = 4 ) nfm1 integer ( kind = 4 ) nl integer ( kind = 4 ) nq integer ( kind = 4 ) nr integer ( kind = 4 ) ntry integer ( kind = 4 ) ntryh(4) real ( kind = 8 ) tpi real ( kind = 8 ) wa(n) save ntryh data ntryh / 4, 2, 3, 5 / nl = n nf = 0 j = 0 101 j = j+1 if (j-4) 102,102,103 102 ntry = ntryh(j) go to 104 103 ntry = ntry+2 104 nq = nl/ntry nr = nl-ntry*nq if (nr) 101,105,101 105 nf = nf+1 fac(nf+2) = ntry nl = nq if (ntry /= 2) go to 107 do i=2,nf ib = nf-i+2 fac(ib+2) = fac(ib+1) end do fac(3) = 2 107 if (nl /= 1) go to 104 fac(1) = n fac(2) = nf tpi = 8.0D+00 * atan ( 1.0D+00 ) argh = tpi / real ( n, kind = 8 ) is = 0 nfm1 = nf-1 l1 = 1 do k1=1,nfm1 ip = fac(k1+2) ld = 0 l2 = l1*ip ido = n/l2 ipm = ip-1 do j=1,ipm ld = ld+l1 i = is argld = real ( ld, kind = 8 ) * argh fi = 0.0D+00 do ii=3,ido,2 i = i+2 fi = fi + 1.0D+00 arg = fi*argld wa(i-1) = cos ( arg ) wa(i) = sin ( arg ) end do is = is+ido end do l1 = l2 end do return end subroutine msntb1(lot,jump,n,inc,x,wsave,dsum,xh,work,ier) !*****************************************************************************80 ! !! MSNTB1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lot real ( kind = 8 ) dsum(*) real ( kind = 8 ) fnp1s4 integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lj integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lnxh integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) srt3s2 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xh(lot,*) real ( kind = 8 ) xhold ier = 0 lj = (lot-1)*jump+1 if (n-2) 200,102,103 102 srt3s2 = sqrt( 3.0D+00 )/ 2.0D+00 do m=1,lj,jump xhold = srt3s2*(x(m,1)+x(m,2)) x(m,2) = srt3s2*(x(m,1)-x(m,2)) x(m,1) = xhold end do go to 200 103 np1 = n+1 ns2 = n/2 do 104 k=1,ns2 kc = np1-k m1 = 0 do 114 m=1,lj,jump m1 = m1+1 t1 = x(m,k)-x(m,kc) t2 = wsave(k)*(x(m,k)+x(m,kc)) xh(m1,k+1) = t1+t2 xh(m1,kc+1) = t2-t1 114 continue 104 continue modn = mod(n,2) if (modn == 0) go to 124 m1 = 0 do 123 m=1,lj,jump m1 = m1+1 xh(m1,ns2+2) = 4.0D+00 * x(m,ns2+1) 123 continue 124 do m=1,lot xh(m,1) = 0.0D+00 end do lnxh = lot-1 + lot*(np1-1) + 1 lnsv = np1 + int(log( real ( np1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = lot*np1 call rfftmf(lot,1,np1,lot,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('msntb1',-5) go to 200 end if if(mod(np1,2) /= 0) go to 30 do m=1,lot xh(m,np1) = xh(m,np1)+xh(m,np1) end do 30 fnp1s4 = real ( np1 ) / 4.0D+00 m1 = 0 do 125 m=1,lj,jump m1 = m1+1 x(m,1) = fnp1s4*xh(m1,1) dsum(m1) = x(m,1) 125 continue do 105 i=3,n,2 m1 = 0 do 115 m=1,lj,jump m1 = m1+1 x(m,i-1) = fnp1s4*xh(m1,i) dsum(m1) = dsum(m1)+fnp1s4*xh(m1,i-1) x(m,i) = dsum(m1) 115 continue 105 continue if (modn /= 0) go to 200 m1 = 0 do 116 m=1,lj,jump m1 = m1+1 x(m,n) = fnp1s4*xh(m1,n+1) 116 continue 200 continue return end subroutine msntf1(lot,jump,n,inc,x,wsave,dsum,xh,work,ier) !*****************************************************************************80 ! !! MSNTF1 is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lot real ( kind = 8 ) dsum(*) integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lj integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lnxh integer ( kind = 4 ) m integer ( kind = 4 ) m1 integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) sfnp1 real ( kind = 8 ) ssqrt3 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xh(lot,*) real ( kind = 8 ) xhold ier = 0 lj = (lot-1)*jump+1 if (n-2) 101,102,103 102 ssqrt3 = 1.0D+00 / sqrt ( 3.0D+00 ) do m=1,lj,jump xhold = ssqrt3*(x(m,1)+x(m,2)) x(m,2) = ssqrt3*(x(m,1)-x(m,2)) x(m,1) = xhold end do 101 go to 200 103 np1 = n+1 ns2 = n/2 do 104 k=1,ns2 kc = np1-k m1 = 0 do 114 m=1,lj,jump m1 = m1 + 1 t1 = x(m,k)-x(m,kc) t2 = wsave(k)*(x(m,k)+x(m,kc)) xh(m1,k+1) = t1+t2 xh(m1,kc+1) = t2-t1 114 continue 104 continue modn = mod(n,2) if (modn == 0) go to 124 m1 = 0 do 123 m=1,lj,jump m1 = m1 + 1 xh(m1,ns2+2) = 4.0D+00 * x(m,ns2+1) 123 continue 124 do 127 m=1,lot xh(m,1) = 0.0D+00 127 continue lnxh = lot-1 + lot*(np1-1) + 1 lnsv = np1 + int(log( real ( np1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = lot*np1 call rfftmf(lot,1,np1,lot,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('msntf1',-5) go to 200 end if if(mod(np1,2) /= 0) go to 30 do 20 m=1,lot xh(m,np1) = xh(m,np1)+xh(m,np1) 20 continue 30 sfnp1 = 1.0D+00 / real ( np1, kind = 8 ) m1 = 0 do 125 m=1,lj,jump m1 = m1+1 x(m,1) = 0.5D+00 * xh(m1,1) dsum(m1) = x(m,1) 125 continue do 105 i=3,n,2 m1 = 0 do 115 m=1,lj,jump m1 = m1+1 x(m,i-1) = 0.5D+00 * xh(m1,i) dsum(m1) = dsum(m1)+ 0.5D+00 * xh(m1,i-1) x(m,i) = dsum(m1) 115 continue 105 continue if (modn /= 0) go to 200 m1 = 0 do m=1,lj,jump m1 = m1+1 x(m,n) = 0.5D+00 * xh(m1,n+1) end do 200 continue return end subroutine r1f2kb (ido,l1,cc,in1,ch,in2,wa1) !*****************************************************************************80 ! !! R1F2KB is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,2,l1) real ( kind = 8 ) ch(in2,ido,l1,2) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) wa1(ido) do k = 1, l1 ch(1,1,k,1) = cc(1,1,1,k)+cc(1,ido,2,k) ch(1,1,k,2) = cc(1,1,1,k)-cc(1,ido,2,k) end do if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i ch(1,i-1,k,1) = cc(1,i-1,1,k)+cc(1,ic-1,2,k) ch(1,i,k,1) = cc(1,i,1,k)-cc(1,ic,2,k) ch(1,i-1,k,2) = wa1(i-2)*(cc(1,i-1,1,k)-cc(1,ic-1,2,k)) & -wa1(i-1)*(cc(1,i,1,k)+cc(1,ic,2,k)) ch(1,i,k,2) = wa1(i-2)*(cc(1,i,1,k)+cc(1,ic,2,k))+wa1(i-1) & *(cc(1,i-1,1,k)-cc(1,ic-1,2,k)) 103 continue 104 continue if (mod(ido,2) == 1) return 105 do 106 k = 1, l1 ch(1,ido,k,1) = cc(1,ido,1,k)+cc(1,ido,1,k) ch(1,ido,k,2) = -(cc(1,1,2,k)+cc(1,1,2,k)) 106 continue 107 continue return end subroutine r1f2kf (ido,l1,cc,in1,ch,in2,wa1) !*****************************************************************************80 ! !! R1F1KF is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) ch(in2,ido,2,l1) real ( kind = 8 ) cc(in1,ido,l1,2) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) wa1(ido) do k = 1, l1 ch(1,1,1,k) = cc(1,1,k,1)+cc(1,1,k,2) ch(1,ido,2,k) = cc(1,1,k,1)-cc(1,1,k,2) end do if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do i=3,ido,2 ic = idp2-i ch(1,i,1,k) = cc(1,i,k,1)+(wa1(i-2)*cc(1,i,k,2) & -wa1(i-1)*cc(1,i-1,k,2)) ch(1,ic,2,k) = (wa1(i-2)*cc(1,i,k,2) & -wa1(i-1)*cc(1,i-1,k,2))-cc(1,i,k,1) ch(1,i-1,1,k) = cc(1,i-1,k,1)+(wa1(i-2)*cc(1,i-1,k,2) & +wa1(i-1)*cc(1,i,k,2)) ch(1,ic-1,2,k) = cc(1,i-1,k,1)-(wa1(i-2)*cc(1,i-1,k,2) & +wa1(i-1)*cc(1,i,k,2)) end do 104 continue if (mod(ido,2) == 1) return 105 do 106 k = 1, l1 ch(1,1,2,k) = -cc(1,ido,k,2) ch(1,ido,1,k) = cc(1,ido,k,1) 106 continue 107 continue return end subroutine r1f3kb (ido,l1,cc,in1,ch,in2,wa1,wa2) !*****************************************************************************80 ! !! R1F3KB is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,3,l1) real ( kind = 8 ) ch(in2,ido,l1,3) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) taui real ( kind = 8 ) taur real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00 taur = cos ( arg ) taui = sin ( arg ) do k = 1, l1 ch(1,1,k,1) = cc(1,1,1,k) + 2.0D+00 * cc(1,ido,2,k) ch(1,1,k,2) = cc(1,1,1,k) + ( 2.0D+00 * taur ) * cc(1,ido,2,k) & - ( 2.0D+00 *taui)*cc(1,1,3,k) ch(1,1,k,3) = cc(1,1,1,k) + ( 2.0D+00 *taur)*cc(1,ido,2,k) & + 2.0D+00 *taui*cc(1,1,3,k) end do if (ido == 1) then return end if idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k)) ch(1,i-1,k,2) = wa1(i-2)* & ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- & (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) & -wa1(i-1)* & ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ & (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) ch(1,i,k,2) = wa1(i-2)* & ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ & (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) & +wa1(i-1)* & ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- & (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) ch(1,i-1,k,3) = wa2(i-2)* & ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ & (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) & -wa2(i-1)* & ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- & (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) ch(1,i,k,3) = wa2(i-2)* & ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- & (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) & +wa2(i-1)* & ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ & (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) 102 continue 103 continue return end subroutine r1f3kf (ido,l1,cc,in1,ch,in2,wa1,wa2) !*****************************************************************************80 ! !! R1F3KF is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,l1,3) real ( kind = 8 ) ch(in2,ido,3,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) taui real ( kind = 8 ) taur real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) arg= 2.0D+00 * 4.0D+00 * atan( 1.0D+00 )/ 3.0D+00 taur=cos(arg) taui=sin(arg) do k = 1, l1 ch(1,1,1,k) = cc(1,1,k,1)+(cc(1,1,k,2)+cc(1,1,k,3)) ch(1,1,3,k) = taui*(cc(1,1,k,3)-cc(1,1,k,2)) ch(1,ido,2,k) = cc(1,1,k,1)+taur*(cc(1,1,k,2)+cc(1,1,k,3)) end do if (ido == 1) then return end if idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ & wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))) ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))) ch(1,i-1,3,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* & cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* & cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))+(taui*((wa1(i-2)* & cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* & cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3)))) ch(1,ic-1,2,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* & cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* & cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))-(taui*((wa1(i-2)* & cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* & cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3)))) ch(1,i,3,k) = (cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))))+(taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))) ch(1,ic,2,k) = (taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2))))-(cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3)))) 102 continue 103 continue return end subroutine r1f4kb (ido,l1,cc,in1,ch,in2,wa1,wa2,wa3) !*****************************************************************************80 ! !! R1F4KB is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,4,l1) real ( kind = 8 ) ch(in2,ido,l1,4) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) sqrt2 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) sqrt2=sqrt( 2.0D+00 ) do k = 1, l1 ch(1,1,k,3) = (cc(1,1,1,k)+cc(1,ido,4,k)) & -(cc(1,ido,2,k)+cc(1,ido,2,k)) ch(1,1,k,1) = (cc(1,1,1,k)+cc(1,ido,4,k)) & +(cc(1,ido,2,k)+cc(1,ido,2,k)) ch(1,1,k,4) = (cc(1,1,1,k)-cc(1,ido,4,k)) & +(cc(1,1,3,k)+cc(1,1,3,k)) ch(1,1,k,2) = (cc(1,1,1,k)-cc(1,ido,4,k)) & -(cc(1,1,3,k)+cc(1,1,3,k)) end do if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i ch(1,i-1,k,1) = (cc(1,i-1,1,k)+cc(1,ic-1,4,k)) & +(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) ch(1,i,k,1) = (cc(1,i,1,k)-cc(1,ic,4,k)) & +(cc(1,i,3,k)-cc(1,ic,2,k)) ch(1,i-1,k,2)=wa1(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) & -(cc(1,i,3,k)+cc(1,ic,2,k)))-wa1(i-1) & *((cc(1,i,1,k)+cc(1,ic,4,k))+(cc(1,i-1,3,k)-cc(1,ic-1,2,k))) ch(1,i,k,2)=wa1(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) & +(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa1(i-1) & *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))-(cc(1,i,3,k)+cc(1,ic,2,k))) ch(1,i-1,k,3)=wa2(i-2)*((cc(1,i-1,1,k)+cc(1,ic-1,4,k)) & -(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))-wa2(i-1) & *((cc(1,i,1,k)-cc(1,ic,4,k))-(cc(1,i,3,k)-cc(1,ic,2,k))) ch(1,i,k,3)=wa2(i-2)*((cc(1,i,1,k)-cc(1,ic,4,k)) & -(cc(1,i,3,k)-cc(1,ic,2,k)))+wa2(i-1) & *((cc(1,i-1,1,k)+cc(1,ic-1,4,k))-(cc(1,i-1,3,k) & +cc(1,ic-1,2,k))) ch(1,i-1,k,4)=wa3(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) & +(cc(1,i,3,k)+cc(1,ic,2,k)))-wa3(i-1) & *((cc(1,i,1,k)+cc(1,ic,4,k))-(cc(1,i-1,3,k)-cc(1,ic-1,2,k))) ch(1,i,k,4)=wa3(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) & -(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa3(i-1) & *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))+(cc(1,i,3,k)+cc(1,ic,2,k))) 103 continue 104 continue if (mod(ido,2) == 1) return 105 continue do 106 k = 1, l1 ch(1,ido,k,1) = (cc(1,ido,1,k)+cc(1,ido,3,k)) & +(cc(1,ido,1,k)+cc(1,ido,3,k)) ch(1,ido,k,2) = sqrt2*((cc(1,ido,1,k)-cc(1,ido,3,k)) & -(cc(1,1,2,k)+cc(1,1,4,k))) ch(1,ido,k,3) = (cc(1,1,4,k)-cc(1,1,2,k)) & +(cc(1,1,4,k)-cc(1,1,2,k)) ch(1,ido,k,4) = -sqrt2*((cc(1,ido,1,k)-cc(1,ido,3,k)) & +(cc(1,1,2,k)+cc(1,1,4,k))) 106 continue 107 continue return end subroutine r1f4kf (ido,l1,cc,in1,ch,in2,wa1,wa2,wa3) !*****************************************************************************80 ! !! R1F4KF is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) cc(in1,ido,l1,4) real ( kind = 8 ) ch(in2,ido,4,l1) real ( kind = 8 ) hsqt2 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) hsqt2=sqrt( 2.0D+00 )/ 2.0D+00 do k = 1, l1 ch(1,1,1,k) = (cc(1,1,k,2)+cc(1,1,k,4))+(cc(1,1,k,1)+cc(1,1,k,3)) ch(1,ido,4,k) = (cc(1,1,k,1)+cc(1,1,k,3))-(cc(1,1,k,2)+cc(1,1,k,4)) ch(1,ido,2,k) = cc(1,1,k,1)-cc(1,1,k,3) ch(1,1,3,k) = cc(1,1,k,4)-cc(1,1,k,2) end do if (ido-2) 107,105,102 102 idp2 = ido+2 do 104 k = 1, l1 do 103 i=3,ido,2 ic = idp2-i ch(1,i-1,1,k) = ((wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4)))+(cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ & wa2(i-1)*cc(1,i,k,3))) ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ & wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i-1,k,2)+ & wa1(i-1)*cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+ & wa3(i-1)*cc(1,i,k,4))) ch(1,i,1,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* & cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4)))+(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- & wa2(i-1)*cc(1,i-1,k,3))) ch(1,ic,4,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* & cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4)))-(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- & wa2(i-1)*cc(1,i-1,k,3))) ch(1,i-1,3,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* & cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4)))+(cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ & wa2(i-1)*cc(1,i,k,3))) ch(1,ic-1,2,k) = (cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ & wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* & cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4))) ch(1,i,3,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))+(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- & wa2(i-1)*cc(1,i-1,k,3))) ch(1,ic,2,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))-(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- & wa2(i-1)*cc(1,i-1,k,3))) 103 continue 104 continue if (mod(ido,2) == 1) return 105 continue do 106 k = 1, l1 ch(1,ido,1,k) = (hsqt2*(cc(1,ido,k,2)-cc(1,ido,k,4)))+cc(1,ido,k,1) ch(1,ido,3,k) = cc(1,ido,k,1)-(hsqt2*(cc(1,ido,k,2)-cc(1,ido,k,4))) ch(1,1,2,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))-cc(1,ido,k,3) ch(1,1,4,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))+cc(1,ido,k,3) 106 continue 107 continue return end subroutine r1f5kb (ido,l1,cc,in1,ch,in2,wa1,wa2,wa3,wa4) !*****************************************************************************80 ! !! R1F5KB is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,5,l1) real ( kind = 8 ) ch(in2,ido,l1,5) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) ti11 real ( kind = 8 ) ti12 real ( kind = 8 ) tr11 real ( kind = 8 ) tr12 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) wa4(ido) arg= 2.0D+00 * 4.0D+00 * atan( 1.0D+00 ) / 5.0D+00 tr11=cos(arg) ti11=sin(arg) tr12=cos( 2.0D+00 *arg ) ti12=sin( 2.0D+00 *arg ) do k = 1, l1 ch(1,1,k,1) = cc(1,1,1,k)+ 2.0D+00 *cc(1,ido,2,k)+ 2.0D+00 *cc(1,ido,4,k) ch(1,1,k,2) = (cc(1,1,1,k)+tr11* 2.0D+00 *cc(1,ido,2,k) & +tr12* 2.0D+00 *cc(1,ido,4,k))-(ti11* 2.0D+00 *cc(1,1,3,k) & +ti12* 2.0D+00 *cc(1,1,5,k)) ch(1,1,k,3) = (cc(1,1,1,k)+tr12* 2.0D+00 *cc(1,ido,2,k) & +tr11* 2.0D+00 *cc(1,ido,4,k))-(ti12* 2.0D+00 *cc(1,1,3,k) & -ti11* 2.0D+00 *cc(1,1,5,k)) ch(1,1,k,4) = (cc(1,1,1,k)+tr12* 2.0D+00 *cc(1,ido,2,k) & +tr11* 2.0D+00 *cc(1,ido,4,k))+(ti12* 2.0D+00 *cc(1,1,3,k) & -ti11* 2.0D+00 *cc(1,1,5,k)) ch(1,1,k,5) = (cc(1,1,1,k)+tr11* 2.0D+00 *cc(1,ido,2,k) & +tr12* 2.0D+00 *cc(1,ido,4,k))+(ti11* 2.0D+00 *cc(1,1,3,k) & +ti12* 2.0D+00 *cc(1,1,5,k)) end do if (ido == 1) return idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +(cc(1,i-1,5,k)+cc(1,ic-1,4,k)) ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k)) & +(cc(1,i,5,k)-cc(1,ic,4,k)) ch(1,i-1,k,2) = wa1(i-2)*((cc(1,i-1,1,k)+tr11* & (cc(1,i-1,3,k)+cc(1,ic-1,2,k))+tr12 & *(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti11*(cc(1,i,3,k) & +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) & -wa1(i-1)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) & +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))+(ti11*(cc(1,i-1,3,k) & -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) ch(1,i,k,2) = wa1(i-2)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k) & -cc(1,ic,2,k))+tr12*(cc(1,i,5,k)-cc(1,ic,4,k))) & +(ti11*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))+ti12 & *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))+wa1(i-1) & *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k) & +cc(1,ic-1,2,k))+tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k))) & -(ti11*(cc(1,i,3,k)+cc(1,ic,2,k))+ti12 & *(cc(1,i,5,k)+cc(1,ic,4,k)))) ch(1,i-1,k,3) = wa2(i-2) & *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) & +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) & -wa2(i-1) & *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- & cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) & +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 & *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) ch(1,i,k,3) = wa2(i-2) & *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- & cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) & +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 & *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) & +wa2(i-1) & *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) & +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) ch(1,i-1,k,4) = wa3(i-2) & *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) & +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) & -wa3(i-1) & *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- & cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) & -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 & *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) ch(1,i,k,4) = wa3(i-2) & *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- & cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) & -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 & *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) & +wa3(i-1) & *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) & +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) ch(1,i-1,k,5) = wa4(i-2) & *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) & +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) & -wa4(i-1) & *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) & +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) & -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) ch(1,i,k,5) = wa4(i-2) & *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) & +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) & -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) & +wa4(i-1) & *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) & +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) & +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) 102 continue 103 continue return end subroutine r1f5kf (ido,l1,cc,in1,ch,in2,wa1,wa2,wa3,wa4) !*****************************************************************************80 ! !! R1F5KF is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) l1 real ( kind = 8 ) arg real ( kind = 8 ) cc(in1,ido,l1,5) real ( kind = 8 ) ch(in2,ido,5,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idp2 integer ( kind = 4 ) k real ( kind = 8 ) ti11 real ( kind = 8 ) ti12 real ( kind = 8 ) tr11 real ( kind = 8 ) tr12 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) wa4(ido) arg= 2.0D+00 * 4.0D+00 * atan( 1.0D+00 ) / 5.0D+00 tr11=cos(arg) ti11=sin(arg) tr12=cos( 2.0D+00 *arg) ti12=sin( 2.0D+00 *arg) do k = 1, l1 ch(1,1,1,k) = cc(1,1,k,1)+(cc(1,1,k,5)+cc(1,1,k,2))+ & (cc(1,1,k,4)+cc(1,1,k,3)) ch(1,ido,2,k) = cc(1,1,k,1)+tr11*(cc(1,1,k,5)+cc(1,1,k,2))+ & tr12*(cc(1,1,k,4)+cc(1,1,k,3)) ch(1,1,3,k) = ti11*(cc(1,1,k,5)-cc(1,1,k,2))+ti12* & (cc(1,1,k,4)-cc(1,1,k,3)) ch(1,ido,4,k) = cc(1,1,k,1)+tr12*(cc(1,1,k,5)+cc(1,1,k,2))+ & tr11*(cc(1,1,k,4)+cc(1,1,k,3)) ch(1,1,5,k) = ti12*(cc(1,1,k,5)-cc(1,1,k,2))-ti11* & (cc(1,1,k,4)-cc(1,1,k,3)) end do if (ido == 1) return idp2 = ido+2 do 103 k = 1, l1 do 102 i=3,ido,2 ic = idp2-i ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ & wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* & cc(1,i,k,5)))+((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))+(wa3(i-2)*cc(1,i-1,k,4)+ & wa3(i-1)*cc(1,i,k,4))) ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* & cc(1,i-1,k,5)))+((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4))) ch(1,i-1,3,k) = cc(1,i-1,k,1)+tr11* & ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) & +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* & ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) & +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))+ti11* & ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) & -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* & ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) & -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))) ch(1,ic-1,2,k) = cc(1,i-1,k,1)+tr11* & ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) & +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* & ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) & +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))-(ti11* & ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) & -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* & ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) & -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4)))) ch(1,i,3,k) = (cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* & cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4))))+(ti11*((wa4(i-2)*cc(1,i-1,k,5)+ & wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3)))) ch(1,ic,2,k) = (ti11*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* & cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))))-(cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* & cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4)))) ch(1,i-1,5,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* & cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* & cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* & cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* & cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))+(ti12*((wa1(i-2)* & cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* & cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* & cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* & cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4)))) ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* & cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* & cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* & cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* & cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))-(ti12*((wa1(i-2)* & cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* & cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* & cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* & cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4)))) ch(1,i,5,k) = (cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* & cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4))))+(ti12*((wa4(i-2)*cc(1,i-1,k,5)+ & wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3)))) ch(1,ic,4,k) = (ti12*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* & cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* & cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* & cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* & cc(1,i,k,3))))-(cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- & wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* & cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* & cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* & cc(1,i-1,k,4)))) 102 continue 103 continue return end subroutine r1fgkb (ido,ip,l1,idl1,cc,c1,c2,in1,ch,ch2,in2,wa) !*****************************************************************************80 ! !! R1FGKB is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(in1,ido,l1,ip) real ( kind = 8 ) c2(in1,idl1,ip) real ( kind = 8 ) cc(in1,ido,ip,l1) real ( kind = 8 ) ch(in2,ido,l1,ip) real ( kind = 8 ) ch2(in2,idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) idp2 integer ( kind = 4 ) ik integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) nbd real ( kind = 8 ) tpi real ( kind = 8 ) wa(ido) tpi= 2.0D+00 * 4.0D+00 * atan( 1.0D+00 ) arg = tpi / real ( ip, kind = 8 ) dcp = cos(arg) dsp = sin(arg) idp2 = ido+2 nbd = (ido-1)/2 ipp2 = ip+2 ipph = (ip+1)/2 if (ido < l1) go to 103 do k = 1, l1 do i=1,ido ch(1,i,k,1) = cc(1,i,1,k) end do end do go to 106 103 continue do i=1,ido do k = 1, l1 ch(1,i,k,1) = cc(1,i,1,k) end do end do 106 do 108 j=2,ipph jc = ipp2-j j2 = j+j do 107 k = 1, l1 ch(1,1,k,j) = cc(1,ido,j2-2,k)+cc(1,ido,j2-2,k) ch(1,1,k,jc) = cc(1,1,j2-1,k)+cc(1,1,j2-1,k) 1007 continue 107 continue 108 continue if (ido == 1) go to 116 if (nbd < l1) go to 112 do 111 j=2,ipph jc = ipp2-j do 110 k = 1, l1 do 109 i=3,ido,2 ic = idp2-i ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k) ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k) ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k) ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k) 109 continue 110 continue 111 continue go to 116 112 do 115 j=2,ipph jc = ipp2-j do 114 i=3,ido,2 ic = idp2-i do 113 k = 1, l1 ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k) ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k) ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k) ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k) 113 continue 114 continue 115 continue 116 ar1 = 1.0D+00 ai1 = 0.0D+00 do 120 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 117 ik=1,idl1 c2(1,ik,l) = ch2(1,ik,1)+ar1*ch2(1,ik,2) c2(1,ik,lc) = ai1*ch2(1,ik,ip) 117 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 119 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 118 ik=1,idl1 c2(1,ik,l) = c2(1,ik,l)+ar2*ch2(1,ik,j) c2(1,ik,lc) = c2(1,ik,lc)+ai2*ch2(1,ik,jc) 118 continue 119 continue 120 continue do 122 j=2,ipph do 121 ik=1,idl1 ch2(1,ik,1) = ch2(1,ik,1)+ch2(1,ik,j) 121 continue 122 continue do 124 j=2,ipph jc = ipp2-j do 123 k = 1, l1 ch(1,1,k,j) = c1(1,1,k,j)-c1(1,1,k,jc) ch(1,1,k,jc) = c1(1,1,k,j)+c1(1,1,k,jc) 123 continue 124 continue if (ido == 1) go to 132 if (nbd < l1) go to 128 do 127 j=2,ipph jc = ipp2-j do 126 k = 1, l1 do 125 i=3,ido,2 ch(1,i-1,k,j) = c1(1,i-1,k,j)-c1(1,i,k,jc) ch(1,i-1,k,jc) = c1(1,i-1,k,j)+c1(1,i,k,jc) ch(1,i,k,j) = c1(1,i,k,j)+c1(1,i-1,k,jc) ch(1,i,k,jc) = c1(1,i,k,j)-c1(1,i-1,k,jc) 125 continue 126 continue 127 continue go to 132 128 do 131 j=2,ipph jc = ipp2-j do 130 i=3,ido,2 do 129 k = 1, l1 ch(1,i-1,k,j) = c1(1,i-1,k,j)-c1(1,i,k,jc) ch(1,i-1,k,jc) = c1(1,i-1,k,j)+c1(1,i,k,jc) ch(1,i,k,j) = c1(1,i,k,j)+c1(1,i-1,k,jc) ch(1,i,k,jc) = c1(1,i,k,j)-c1(1,i-1,k,jc) 129 continue 130 continue 131 continue 132 continue if (ido == 1) return do 133 ik=1,idl1 c2(1,ik,1) = ch2(1,ik,1) 133 continue do 135 j=2,ip do 134 k = 1, l1 c1(1,1,k,j) = ch(1,1,k,j) 134 continue 135 continue if ( l1 < nbd ) go to 139 is = -ido do 138 j=2,ip is = is+ido idij = is do 137 i=3,ido,2 idij = idij+2 do 136 k = 1, l1 c1(1,i-1,k,j) = wa(idij-1)*ch(1,i-1,k,j)-wa(idij)*ch(1,i,k,j) c1(1,i,k,j) = wa(idij-1)*ch(1,i,k,j)+wa(idij)*ch(1,i-1,k,j) 136 continue 137 continue 138 continue go to 143 139 is = -ido do 142 j=2,ip is = is+ido do 141 k = 1, l1 idij = is do 140 i=3,ido,2 idij = idij+2 c1(1,i-1,k,j) = wa(idij-1)*ch(1,i-1,k,j)-wa(idij)*ch(1,i,k,j) c1(1,i,k,j) = wa(idij-1)*ch(1,i,k,j)+wa(idij)*ch(1,i-1,k,j) 140 continue 141 continue 142 continue 143 continue return end subroutine r1fgkf (ido,ip,l1,idl1,cc,c1,c2,in1,ch,ch2,in2,wa) !*****************************************************************************80 ! !! R1FGKF is an FFTPACK5.1 auxilliary function. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) in1 integer ( kind = 4 ) in2 integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(in1,ido,l1,ip) real ( kind = 8 ) c2(in1,idl1,ip) real ( kind = 8 ) cc(in1,ido,ip,l1) real ( kind = 8 ) ch(in2,ido,l1,ip) real ( kind = 8 ) ch2(in2,idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) idp2 integer ( kind = 4 ) ik integer ( kind = 4 ) ipp2 integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) nbd real ( kind = 8 ) tpi real ( kind = 8 ) wa(ido) tpi= 2.0D+00 * 4.0D+00 * atan( 1.0D+00 ) arg = tpi/real ( ip, kind = 8 ) dcp = cos(arg) dsp = sin(arg) ipph = (ip+1)/2 ipp2 = ip+2 idp2 = ido+2 nbd = (ido-1)/2 if (ido == 1) go to 119 do ik=1,idl1 ch2(1,ik,1) = c2(1,ik,1) end do do j=2,ip do k = 1, l1 ch(1,1,k,j) = c1(1,1,k,j) end do end do if ( l1 < nbd ) go to 107 is = -ido do 106 j=2,ip is = is+ido idij = is do 105 i=3,ido,2 idij = idij+2 do 104 k = 1, l1 ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij)*c1(1,i,k,j) ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij)*c1(1,i-1,k,j) 104 continue 105 continue 106 continue go to 111 107 is = -ido do 110 j=2,ip is = is+ido do 109 k = 1, l1 idij = is do 108 i=3,ido,2 idij = idij+2 ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij)*c1(1,i,k,j) ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij)*c1(1,i-1,k,j) 108 continue 109 continue 110 continue 111 if (nbd < l1) go to 115 do 114 j=2,ipph jc = ipp2-j do 113 k = 1, l1 do 112 i=3,ido,2 c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc) c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc) c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc) c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j) 112 continue 113 continue 114 continue go to 121 115 do 118 j=2,ipph jc = ipp2-j do 117 i=3,ido,2 do 116 k = 1, l1 c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc) c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc) c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc) c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j) 116 continue 117 continue 118 continue go to 121 119 do 120 ik=1,idl1 c2(1,ik,1) = ch2(1,ik,1) 120 continue 121 do 123 j=2,ipph jc = ipp2-j do 122 k = 1, l1 c1(1,1,k,j) = ch(1,1,k,j)+ch(1,1,k,jc) c1(1,1,k,jc) = ch(1,1,k,jc)-ch(1,1,k,j) 122 continue 123 continue ar1 = 1.0D+00 ai1 = 0.0D+00 do 127 l=2,ipph lc = ipp2-l ar1h = dcp*ar1-dsp*ai1 ai1 = dcp*ai1+dsp*ar1 ar1 = ar1h do 124 ik=1,idl1 ch2(1,ik,l) = c2(1,ik,1)+ar1*c2(1,ik,2) ch2(1,ik,lc) = ai1*c2(1,ik,ip) 124 continue dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do 126 j=3,ipph jc = ipp2-j ar2h = dc2*ar2-ds2*ai2 ai2 = dc2*ai2+ds2*ar2 ar2 = ar2h do 125 ik=1,idl1 ch2(1,ik,l) = ch2(1,ik,l)+ar2*c2(1,ik,j) ch2(1,ik,lc) = ch2(1,ik,lc)+ai2*c2(1,ik,jc) 125 continue 126 continue 127 continue do 129 j=2,ipph do 128 ik=1,idl1 ch2(1,ik,1) = ch2(1,ik,1)+c2(1,ik,j) 128 continue 129 continue if (ido < l1) go to 132 do 131 k = 1, l1 do 130 i=1,ido cc(1,i,1,k) = ch(1,i,k,1) 130 continue 131 continue go to 135 132 do 134 i=1,ido do 133 k = 1, l1 cc(1,i,1,k) = ch(1,i,k,1) 133 continue 134 continue 135 do 137 j=2,ipph jc = ipp2-j j2 = j+j do 136 k = 1, l1 cc(1,ido,j2-2,k) = ch(1,1,k,j) cc(1,1,j2-1,k) = ch(1,1,k,jc) 136 continue 137 continue if (ido == 1) return if (nbd < l1) go to 141 do 140 j=2,ipph jc = ipp2-j j2 = j+j do 139 k = 1, l1 do 138 i=3,ido,2 ic = idp2-i cc(1,i-1,j2-1,k) = ch(1,i-1,k,j)+ch(1,i-1,k,jc) cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j)-ch(1,i-1,k,jc) cc(1,i,j2-1,k) = ch(1,i,k,j)+ch(1,i,k,jc) cc(1,ic,j2-2,k) = ch(1,i,k,jc)-ch(1,i,k,j) 138 continue 139 continue 140 continue return 141 do 144 j=2,ipph jc = ipp2-j j2 = j+j do 143 i=3,ido,2 ic = idp2-i do 142 k = 1, l1 cc(1,i-1,j2-1,k) = ch(1,i-1,k,j)+ch(1,i-1,k,jc) cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j)-ch(1,i-1,k,jc) cc(1,i,j2-1,k) = ch(1,i,k,j)+ch(1,i,k,jc) cc(1,ic,j2-2,k) = ch(1,i,k,jc)-ch(1,i,k,j) 142 continue 143 continue 144 continue return end subroutine r2w ( ldr, ldw, l, m, r, w ) !*****************************************************************************80 ! !! R2W copies a 2D array, allowing for different leading dimensions. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDR, the leading dimension of R. ! ! Input, integer ( kind = 4 ) LDW, the leading dimension of W. ! ! Input, integer ( kind = 4 ) L, M, the number of rows and columns ! of information to be copied. ! ! Input, real ( kind = 8 ) R(LDR,M), the copied information. ! ! Output, real ( kind = 8 ) W(LDW,M), the original information. ! implicit none integer ( kind = 4 ) ldr integer ( kind = 4 ) ldw integer ( kind = 4 ) m integer ( kind = 4 ) l real ( kind = 8 ) r(ldr,m) real ( kind = 8 ) w(ldw,m) w(1:l,1:m) = r(1:l,1:m) return end subroutine r8_factor ( n, nf, fac ) !*****************************************************************************80 ! !! R8_FACTOR factors of an integer for real double precision computations. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number for which factorization and ! other information is needed. ! ! Output, integer ( kind = 4 ) NF, the number of factors. ! ! Output, real ( kind = 8 ) FAC(*), a list of factors of N. ! implicit none real ( kind = 8 ) fac(*) integer ( kind = 4 ) j integer ( kind = 4 ) n integer ( kind = 4 ) nf integer ( kind = 4 ) nl integer ( kind = 4 ) nq integer ( kind = 4 ) nr integer ( kind = 4 ) ntry nl = n nf = 0 j = 0 do while ( 1 < nl ) j = j + 1 if ( j == 1 ) then ntry = 4 else if ( j == 2 ) then ntry = 2 else if ( j == 3 ) then ntry = 3 else if ( j == 4 ) then ntry = 5 else ntry = ntry + 2 end if do nq = nl / ntry nr = nl - ntry * nq if ( nr /= 0 ) then exit end if nf = nf + 1 fac(nf) = real ( ntry, kind = 8 ) nl = nq end do end do return end subroutine r8_mcfti1 ( n, wa, fnf, fac ) !*****************************************************************************80 ! !! R8_MCFTI1 sets up factors and tables, real double precision arithmetic. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none real ( kind = 8 ) fac(*) real ( kind = 8 ) fnf integer ( kind = 4 ) ido integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) n integer ( kind = 4 ) nf real ( kind = 8 ) wa(*) ! ! Get the factorization of N. ! call r8_factor ( n, nf, fac ) fnf = real ( nf, kind = 8 ) iw = 1 l1 = 1 ! ! Set up the trigonometric tables. ! do k1 = 1, nf ip = int ( fac(k1) ) l2 = l1 * ip ido = n / l2 call r8_tables ( ido, ip, wa(iw) ) iw = iw + ( ip - 1 ) * ( ido + ido ) l1 = l2 end do return end subroutine r8_tables ( ido, ip, wa ) !*****************************************************************************80 ! !! R8_TABLES computes trigonometric tables, real double precision arithmetic. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) ip real ( kind = 8 ) arg1 real ( kind = 8 ) arg2 real ( kind = 8 ) arg3 real ( kind = 8 ) arg4 real ( kind = 8 ) argz integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) tpi real ( kind = 8 ) wa(ido,ip-1,2) tpi = 8.0D+00 * atan ( 1.0D+00 ) argz = tpi / real ( ip, kind = 8 ) arg1 = tpi / real ( ido * ip, kind = 8 ) do j = 2, ip arg2 = real ( j - 1, kind = 8 ) * arg1 do i = 1, ido arg3 = real ( i - 1, kind = 8 ) * arg2 wa(i,j-1,1) = cos ( arg3 ) wa(i,j-1,2) = sin ( arg3 ) end do if ( 5 < ip ) then arg4 = real ( j - 1, kind = 8 ) * argz wa(1,j-1,1) = cos ( arg4 ) wa(1,j-1,2) = sin ( arg4 ) end if end do return end subroutine rfft1b ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! RFFT1B: real double precision backward fast Fourier transform, 1D. ! ! Discussion: ! ! RFFT1B computes the one-dimensional Fourier transform of a periodic ! sequence within a real array. This is referred to as the backward ! transform or Fourier synthesis, transforming the sequence from ! spectral to physical space. This transform is normalized since a ! call to RFFT1B followed by a call to RFFT1F (or vice-versa) reproduces ! the original array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, the data to be ! transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFT1I before the first call to routine ! RFFT1F or RFFT1B for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough. ! implicit none integer ( kind = 4 ) lenr integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) n real ( kind = 8 ) r(lenr) real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) ier = 0 if (lenr < inc*(n-1) + 1) then ier = 1 call xerfft ('rfft1b ', 6) else if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfft1b ', 8) else if (lenwrk < n) then ier = 3 call xerfft ('rfft1b ', 10) end if if (n == 1) then return end if call rfftb1 (n,inc,r,work,wsave,wsave(n+1)) return end subroutine rfft1f ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! RFFT1F: real double precision forward fast Fourier transform, 1D. ! ! Discussion: ! ! RFFT1F computes the one-dimensional Fourier transform of a periodic ! sequence within a real array. This is referred to as the forward ! transform or Fourier analysis, transforming the sequence from physical ! to spectral space. This transform is normalized since a call to ! RFFT1F followed by a call to RFFT1B (or vice-versa) reproduces the ! original array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, contains the sequence ! to be transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFT1I before the first call to routine RFFT1F ! or RFFT1B for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough: ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough. ! implicit none integer ( kind = 4 ) lenr integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) r(lenr) ier = 0 if (lenr < inc*(n-1) + 1) then ier = 1 call xerfft ('rfft1f ', 6) else if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfft1f ', 8) else if (lenwrk < n) then ier = 3 call xerfft ('rfft1f ', 10) end if if (n == 1) then return end if call rfftf1 (n,inc,r,work,wsave,wsave(n+1)) return end subroutine rfft1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! RFFT1I: initialization for RFFT1B and RFFT1F. ! ! Discussion: ! ! RFFT1I initializes array WSAVE for use in its companion routines ! RFFT1B and RFFT1F. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of ! N and also containing certain trigonometric values which will be used in ! routines RFFT1B or RFFT1F. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfft1i ', 3) end if if (n == 1) then return end if call rffti1 (n,wsave(1),wsave(n+1)) return end subroutine rfft2b ( ldim, l, m, r, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! RFFT2B: real double precision backward fast Fourier transform, 2D. ! ! Discussion: ! ! RFFT2B computes the two-dimensional discrete Fourier transform of the ! complex Fourier coefficients a real periodic array. This transform is ! known as the backward transform or Fourier synthesis, transforming from ! spectral to physical space. Routine RFFT2B is normalized: a call to ! RFFT2B followed by a call to RFFT2F (or vice-versa) reproduces the ! original array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDIM, the first dimension of the 2D real ! array R, which must be at least 2*(L/2+1). ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension of the two-dimensional real array R. The value of ! L must be less than or equal to that of LDIM. The transform is most ! efficient when L is a product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed ! in the second dimension of the two-dimensional real array R. The transform ! is most efficient when M is a product of small primes. ! ! Input/output, real ( kind = 8 ) R(LDIM,M), the real array of two ! dimensions. On input, R contains the L/2+1-by-M complex subarray of ! spectral coefficients, on output, the physical coefficients. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFT2I before the first call to routine RFFT2F ! or RFFT2B with lengths L and M. WSAVE's contents may be re-used for ! subsequent calls to RFFT2F and RFFT2B with the same transform lengths ! L and M. ! ! Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE ! array. LENSAV must be at least L + M + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). WORK provides workspace, and ! its contents need not be saved between calls to routines RFFT2B and RFFT2F. ! ! Input, integer ( kind = 4 ) LENWRK, the number of elements in the WORK ! array. LENWRK must be at least LDIM*M. ! ! Output, integer ( kind = 4 ) IER, the error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 6, input parameter LDIM < 2*(L/2+1); ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) ldim integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) m integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) j integer ( kind = 4 ) l integer ( kind = 4 ) ldh integer ( kind = 4 ) ldw integer ( kind = 4 ) ldx integer ( kind = 4 ) lwsav integer ( kind = 4 ) mmsav integer ( kind = 4 ) modl integer ( kind = 4 ) modm integer ( kind = 4 ) mwsav real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) r(ldim,m) ier = 0 ! ! verify lensav ! lwsav = l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 ))+4 mwsav = 2*m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 mmsav = m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 modl = mod(l,2) modm = mod(m,2) if (lensav < lwsav+mwsav+mmsav) then ier = 2 call xerfft ('rfft2f', 6) return end if ! ! verify lenwrk ! if (lenwrk < (l+1)*m) then ier = 3 call xerfft ('rfft2f', 8) return end if ! ! verify ldim is as big as l ! if (ldim < l) then ier = 5 call xerfft ('rfft2f', -6) return end if ! ! transform second dimension of array ! do j=2,2*((m+1)/2)-1 r(1,j) = r(1,j)+r(1,j) end do do j=3,m,2 r(1,j) = -r(1,j) end do call rfftmb(1,1,m,ldim,r,m*ldim, & wsave(lwsav+mwsav+1),mmsav,work,lenwrk,ier1) ldh = int((l+1)/2) if( 1 < ldh ) then ldw = ldh+ldh ! ! r and work are switched because the the first dimension ! of the input to complex cfftmf must be even. ! call r2w(ldim,ldw,l,m,r,work) call cfftmb(ldh-1,1,m,ldh,work(2),ldh*m, & wsave(lwsav+1),mwsav,r,l*m, ier1) if(ier1/=0) then ier=20 call xerfft('rfft2b',-5) return end if call w2r(ldim,ldw,l,m,r,work) end if if(modl == 0) then do j=2,2*((m+1)/2)-1 r(l,j) = r(l,j)+r(l,j) end do do j=3,m,2 r(l,j) = -r(l,j) end do call rfftmb(1,1,m,ldim,r(l,1),m*ldim, & wsave(lwsav+mwsav+1),mmsav,work,lenwrk,ier1) end if ! ! transform first dimension of array ! ldx = 2*int((l+1)/2)-1 do i=2,ldx do j=1,m r(i,j) = r(i,j)+r(i,j) end do end do do j=1,m do i=3,ldx,2 r(i,j) = -r(i,j) end do end do call rfftmb(m,ldim,l,1,r,m*ldim,wsave(1), & l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 ))+4,work,lenwrk,ier1) if(ier1/=0) then ier=20 call xerfft('rfft2f',-5) return end if if(ier1/=0) then ier=20 call xerfft('rfft2f',-5) return end if 100 continue return end subroutine rfft2f ( ldim, l, m, r, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! ! RFFT2F: real double precision forward fast Fourier transform, 2D. ! ! Discussion: ! ! RFFT2F computes the two-dimensional discrete Fourier transform of a ! real periodic array. This transform is known as the forward transform ! or Fourier analysis, transforming from physical to spectral space. ! Routine RFFT2F is normalized: a call to RFFT2F followed by a call to ! RFFT2B (or vice-versa) reproduces the original array within roundoff ! error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDIM, the first dimension of the 2D real ! array R, which must be at least 2*(L/2+1). ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension of the two-dimensional real array R. The value ! of L must be less than or equal to that of LDIM. The transform is most ! efficient when L is a product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed ! in the second dimension of the two-dimensional real array R. The ! transform is most efficient when M is a product of small primes. ! ! Input/output, real ( kind = 8 ) R(LDIM,M), the real array of two ! dimensions. On input, containing the L-by-M physical data to be ! transformed. On output, the spectral coefficients. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFT2I before the first call to routine RFFT2F ! or RFFT2B with lengths L and M. WSAVE's contents may be re-used for ! subsequent calls to RFFT2F and RFFT2B with the same transform lengths. ! ! Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE ! array. LENSAV must be at least L + M + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK), provides workspace, and its ! contents need not be saved between calls to routines RFFT2F and RFFT2B. ! ! Input, integer ( kind = 4 ) LENWRK, the number of elements in the WORK ! array. LENWRK must be at least LDIM*M. ! ! Output, integer ( kind = 4 ) IER, the error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 6, input parameter LDIM < 2*(L+1); ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) ldim integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) m integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) j integer ( kind = 4 ) l integer ( kind = 4 ) ldh integer ( kind = 4 ) ldw integer ( kind = 4 ) ldx integer ( kind = 4 ) lwsav integer ( kind = 4 ) mmsav integer ( kind = 4 ) modl integer ( kind = 4 ) modm integer ( kind = 4 ) mwsav real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) r(ldim,m) ier = 0 ! ! verify lensav ! lwsav = l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 ))+4 mwsav = 2*m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 mmsav = m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 if (lensav < lwsav+mwsav+mmsav) then ier = 2 call xerfft ('rfft2f', 6) return end if ! ! verify lenwrk ! if (lenwrk < (l+1)*m) then ier = 3 call xerfft ('rfft2f', 8) return end if ! ! verify ldim is as big as l ! if (ldim < l) then ier = 5 call xerfft ('rfft2f', -6) return end if ! ! transform first dimension of array ! call rfftmf(m,ldim,l,1,r,m*ldim,wsave(1), & l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 ))+4,work,lenwrk,ier1) if(ier1 /= 0 ) then ier=20 call xerfft('rfft2f',-5) return end if ldx = 2*int((l+1)/2)-1 do i=2,ldx do j=1,m r(i,j) = 0.5D+00 * r(i,j) end do end do do j=1,m do i=3,ldx,2 r(i,j) = -r(i,j) end do end do ! ! reshuffle to add in nyquist imaginary components ! modl = mod(l,2) modm = mod(m,2) ! ! transform second dimension of array ! call rfftmf(1,1,m,ldim,r,m*ldim, & wsave(lwsav+mwsav+1),mmsav,work,lenwrk,ier1) do j=2,2*((m+1)/2)-1 r(1,j) = 0.5D+00 * r(1,j) end do do j=3,m,2 r(1,j) = -r(1,j) end do ldh = int((l+1)/2) if ( 1 < ldh ) then ldw = ldh+ldh ! ! r and work are switched because the the first dimension ! of the input to complex cfftmf must be even. ! call r2w(ldim,ldw,l,m,r,work) call cfftmf(ldh-1,1,m,ldh,work(2),ldh*m, & wsave(lwsav+1),mwsav,r,l*m, ier1) if(ier1 /= 0 ) then ier=20 call xerfft('rfft2f',-5) return end if call w2r(ldim,ldw,l,m,r,work) end if if(modl == 0) then call rfftmf(1,1,m,ldim,r(l,1),m*ldim, & wsave(lwsav+mwsav+1),mmsav,work,lenwrk,ier1) do j=2,2*((m+1)/2)-1 r(l,j) = 0.5D+00 * r(l,j) end do do j=3,m,2 r(l,j) = -r(l,j) end do end if if(ier1 /= 0 ) then ier=20 call xerfft('rfft2f',-5) return end if 100 continue return end subroutine rfft2i ( l, m, wsave, lensav, ier ) !*****************************************************************************80 ! !! RFFT2I: initialization for RFFT2B and RFFT2F. ! ! Discussion: ! ! RFFT2I initializes real array WSAVE for use in its companion routines ! RFFT2F and RFFT2B for computing the two-dimensional fast Fourier ! transform of real data. Prime factorizations of L and M, together with ! tabulations of the trigonometric functions, are computed and stored in ! array WSAVE. RFFT2I must be called prior to the first call to RFFT2F ! or RFFT2B. Separate WSAVE arrays are required for different values of ! L or M. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) L, the number of elements to be transformed ! in the first dimension. The transform is most efficient when L is a ! product of small primes. ! ! Input, integer ( kind = 4 ) M, the number of elements to be transformed ! in the second dimension. The transform is most efficient when M is a ! product of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE ! array. LENSAV must be at least L + M + INT(LOG(REAL(L))) ! + INT(LOG(REAL(M))) + 8. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of L and M, and also containing certain trigonometric values which ! will be used in routines RFFT2B or RFFT2F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) l integer ( kind = 4 ) lwsav integer ( kind = 4 ) m integer ( kind = 4 ) mmsav integer ( kind = 4 ) mwsav real ( kind = 8 ) wsave(lensav) ! ! initialize ier ! ier = 0 ! ! verify lensav ! lwsav = l+int(log( real ( l, kind = 8 ) )/log( 2.0D+00 ))+4 mwsav = 2*m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 mmsav = m+int(log( real ( m, kind = 8 ) )/log( 2.0D+00 ))+4 if (lensav < lwsav+mwsav+mmsav) then ier = 2 call xerfft ('rfft2i', 4) return end if call rfftmi (l, wsave(1), lwsav, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('rfft2i',-5) return end if call cfftmi (m, wsave(lwsav+1),mwsav,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('rfft2i',-5) return end if call rfftmi (m,wsave(lwsav+mwsav+1),mmsav, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('rfft2i',-5) return end if return end subroutine rfftb1 ( n, in, c, ch, wa, fac ) !*****************************************************************************80 ! !! RFFTB1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) in integer ( kind = 4 ) n real ( kind = 8 ) c(in,*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(15) real ( kind = 8 ) half real ( kind = 8 ) halfm integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) modn integer ( kind = 4 ) na integer ( kind = 4 ) nf integer ( kind = 4 ) nl real ( kind = 8 ) wa(n) nf = fac(2) na = 0 do 10 k1=1,nf ip = fac(k1+2) na = 1-na if(ip <= 5) go to 10 if(k1 == nf) go to 10 na = 1-na 10 continue half = 0.5D+00 halfm = -0.5D+00 modn = mod(n,2) nl = n-2 if(modn /= 0) nl = n-1 if (na == 0) go to 120 ch(1) = c(1,1) ch(n) = c(1,n) do j=2,nl,2 ch(j) = half*c(1,j) ch(j+1) = halfm*c(1,j+1) end do go to 124 120 do 122 j=2,nl,2 c(1,j) = half*c(1,j) c(1,j+1) = halfm*c(1,j+1) 122 continue 124 l1 = 1 iw = 1 do 116 k1=1,nf ip = fac(k1+2) l2 = ip*l1 ido = n/l2 idl1 = ido*l1 if (ip /= 4) go to 103 ix2 = iw+ido ix3 = ix2+ido if (na /= 0) go to 101 call r1f4kb (ido,l1,c,in,ch,1,wa(iw),wa(ix2),wa(ix3)) go to 102 101 call r1f4kb (ido,l1,ch,1,c,in,wa(iw),wa(ix2),wa(ix3)) 102 na = 1-na go to 115 103 if (ip /= 2) go to 106 if (na /= 0) go to 104 call r1f2kb (ido,l1,c,in,ch,1,wa(iw)) go to 105 104 call r1f2kb (ido,l1,ch,1,c,in,wa(iw)) 105 na = 1-na go to 115 106 if (ip /= 3) go to 109 ix2 = iw+ido if (na /= 0) go to 107 call r1f3kb (ido,l1,c,in,ch,1,wa(iw),wa(ix2)) go to 108 107 call r1f3kb (ido,l1,ch,1,c,in,wa(iw),wa(ix2)) 108 na = 1-na go to 115 109 if (ip /= 5) go to 112 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na /= 0) go to 110 call r1f5kb (ido,l1,c,in,ch,1,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 111 110 call r1f5kb (ido,l1,ch,1,c,in,wa(iw),wa(ix2),wa(ix3),wa(ix4)) 111 na = 1-na go to 115 112 if (na /= 0) go to 113 call r1fgkb (ido,ip,l1,idl1,c,c,c,in,ch,ch,1,wa(iw)) go to 114 113 call r1fgkb (ido,ip,l1,idl1,ch,ch,ch,1,c,c,in,wa(iw)) 114 if (ido == 1) na = 1-na 115 l1 = l2 iw = iw+(ip-1)*ido 116 continue return end subroutine rfftf1 ( n, in, c, ch, wa, fac ) !*****************************************************************************80 ! !! RFFTF1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) in integer ( kind = 4 ) n real ( kind = 8 ) c(in,*) real ( kind = 8 ) ch(*) real ( kind = 8 ) fac(15) integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) kh integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) modn integer ( kind = 4 ) na integer ( kind = 4 ) nf integer ( kind = 4 ) nl real ( kind = 8 ) sn real ( kind = 8 ) tsn real ( kind = 8 ) tsnm real ( kind = 8 ) wa(n) nf = int ( fac(2) ) na = 1 l2 = n iw = n do 111 k1=1,nf kh = nf-k1 ip = fac(kh+3) l1 = l2/ip ido = n/l2 idl1 = ido*l1 iw = iw-(ip-1)*ido na = 1-na if (ip /= 4) go to 102 ix2 = iw+ido ix3 = ix2+ido if (na /= 0) go to 101 call r1f4kf (ido,l1,c,in,ch,1,wa(iw),wa(ix2),wa(ix3)) go to 110 101 call r1f4kf (ido,l1,ch,1,c,in,wa(iw),wa(ix2),wa(ix3)) go to 110 102 if (ip /= 2) go to 104 if (na /= 0) go to 103 call r1f2kf (ido,l1,c,in,ch,1,wa(iw)) go to 110 103 call r1f2kf (ido,l1,ch,1,c,in,wa(iw)) go to 110 104 if (ip /= 3) go to 106 ix2 = iw+ido if (na /= 0) go to 105 call r1f3kf (ido,l1,c,in,ch,1,wa(iw),wa(ix2)) go to 110 105 call r1f3kf (ido,l1,ch,1,c,in,wa(iw),wa(ix2)) go to 110 106 if (ip /= 5) go to 108 ix2 = iw+ido ix3 = ix2+ido ix4 = ix3+ido if (na /= 0) go to 107 call r1f5kf (ido,l1,c,in,ch,1,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 107 call r1f5kf (ido,l1,ch,1,c,in,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 110 108 if (ido == 1) na = 1-na if (na /= 0) go to 109 call r1fgkf (ido,ip,l1,idl1,c,c,c,in,ch,ch,1,wa(iw)) na = 1 go to 110 109 call r1fgkf (ido,ip,l1,idl1,ch,ch,ch,1,c,c,in,wa(iw)) na = 0 110 l2 = l1 111 continue sn = 1.0D+00 / real ( n, kind = 8 ) tsn = 2.0D+00 / real ( n, kind = 8 ) tsnm = -tsn modn = mod(n,2) nl = n-2 if(modn /= 0) nl = n-1 if (na /= 0) go to 120 c(1,1) = sn*ch(1) do 118 j=2,nl,2 c(1,j) = tsn*ch(j) c(1,j+1) = tsnm*ch(j+1) 118 continue if(modn /= 0) return c(1,n) = sn*ch(n) return 120 c(1,1) = sn*c(1,1) do 122 j=2,nl,2 c(1,j) = tsn*c(1,j) c(1,j+1) = tsnm*c(1,j+1) 122 continue if(modn /= 0) return c(1,n) = sn*c(1,n) return end subroutine rffti1 ( n, wa, fac ) !*****************************************************************************80 ! !! RFFTI1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number for which factorization ! and other information is needed. ! ! Output, real ( kind = 8 ) WA(N), trigonometric information. ! ! Output, real ( kind = 8 ) FAC(15), factorization information. ! FAC(1) is N, FAC(2) is NF, the number of factors, and FAC(3:NF+2) are the ! factors. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) arg real ( kind = 8 ) argh real ( kind = 8 ) argld real ( kind = 8 ) fac(15) real ( kind = 8 ) fi integer ( kind = 4 ) i integer ( kind = 4 ) ib integer ( kind = 4 ) ido integer ( kind = 4 ) ii integer ( kind = 4 ) ip integer ( kind = 4 ) ipm integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) ld integer ( kind = 4 ) nf integer ( kind = 4 ) nfm1 integer ( kind = 4 ) nl integer ( kind = 4 ) nq integer ( kind = 4 ) nr integer ( kind = 4 ) ntry integer ( kind = 4 ) ntryh(4) real ( kind = 8 ) tpi real ( kind = 8 ) wa(n) save ntryh data ntryh / 4, 2, 3, 5 / nl = n nf = 0 j = 0 101 j = j+1 if (j-4) 102,102,103 102 ntry = ntryh(j) go to 104 103 ntry = ntry+2 104 nq = nl/ntry nr = nl-ntry*nq if (nr) 101,105,101 105 nf = nf+1 fac(nf+2) = ntry nl = nq if (ntry /= 2) go to 107 if (nf == 1) go to 107 do 106 i=2,nf ib = nf-i+2 fac(ib+2) = fac(ib+1) 106 continue fac(3) = 2 107 if (nl /= 1) go to 104 fac(1) = n fac(2) = nf tpi = 8.0D+00 * atan ( 1.0D+00 ) argh = tpi / real ( n, kind = 8 ) is = 0 nfm1 = nf-1 l1 = 1 if (nfm1 == 0) return do 110 k1=1,nfm1 ip = fac(k1+2) ld = 0 l2 = l1*ip ido = n/l2 ipm = ip-1 do 109 j=1,ipm ld = ld+l1 i = is argld = real ( ld, kind = 8 ) * argh fi = 0.0D+00 do 108 ii=3,ido,2 i = i+2 fi = fi + 1.0D+00 arg = fi*argld wa(i-1) = cos ( arg ) wa(i) = sin ( arg ) 108 continue is = is+ido 109 continue l1 = l2 110 continue return end subroutine rfftmb ( lot, jump, n, inc, r, lenr, wsave, lensav, work, lenwrk, & ier ) !*****************************************************************************80 ! !! RFFTMB: real double precision backward FFT, 1D, multiple vectors. ! ! Discussion: ! ! RFFTMB computes the one-dimensional Fourier transform of multiple ! periodic sequences within a real array. This transform is referred ! to as the backward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. ! ! This transform is normalized since a call to RFFTMB followed ! by a call to RFFTMF (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), real array containing LOT ! sequences, each having length N. R can have any number of dimensions, ! but the total number of locations must be at least LENR. On input, the ! spectral data to be transformed, on output the physical data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFTMI before the first call to routine RFFTMF ! or RFFTMB for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC, JUMP, N, LOT are not consistent. ! implicit none integer ( kind = 4 ) lenr integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) jump integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) r(lenr) real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) logical xercon ier = 0 if (lenr < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('rfftmb ', 6) return else if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfftmb ', 8) return else if (lenwrk < lot*n) then ier = 3 call xerfft ('rfftmb ', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('rfftmb ', -1) return end if if (n == 1) then return end if call mrftb1 (lot,jump,n,inc,r,work,wsave,wsave(n+1)) return end subroutine rfftmf ( lot, jump, n, inc, r, lenr, wsave, lensav, & work, lenwrk, ier ) !*****************************************************************************80 ! !! RFFTMF: real double precision forward FFT, 1D, multiple vectors. ! ! Discussion: ! ! RFFTMF computes the one-dimensional Fourier transform of multiple ! periodic sequences within a real array. This transform is referred ! to as the forward transform or Fourier analysis, transforming the ! sequences from physical to spectral space. ! ! This transform is normalized since a call to RFFTMF followed ! by a call to RFFTMB (or vice-versa) reproduces the original array ! within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), real array containing LOT ! sequences, each having length N. R can have any number of dimensions, but ! the total number of locations must be at least LENR. On input, the ! physical data to be transformed, on output the spectral data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1) + 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to RFFTMI before the first call to routine RFFTMF ! or RFFTMB for a given transform length N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC, JUMP, N, LOT are not consistent. ! implicit none integer ( kind = 4 ) lenr integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) inc integer ( kind = 4 ) jump integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) r(lenr) real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) logical xercon ier = 0 if (lenr < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('rfftmf ', 6) return else if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfftmf ', 8) return else if (lenwrk < lot*n) then ier = 3 call xerfft ('rfftmf ', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('rfftmf ', -1) return end if if (n == 1) then return end if call mrftf1 (lot,jump,n,inc,r,work,wsave,wsave(n+1)) return end subroutine rfftmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! RFFTMI: initialization for RFFTMB and RFFTMF. ! ! Discussion: ! ! RFFTMI initializes array WSAVE for use in its companion routines ! RFFTMB and RFFTMF. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), work array containing the prime ! factors of N and also containing certain trigonometric ! values which will be used in routines RFFTMB or RFFTMF. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('rfftmi ', 3) return end if if (n == 1) then return end if call mrfti1 (n,wsave(1),wsave(n+1)) return end subroutine sinq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! SINQ1B: real double precision backward sine quarter wave transform, 1D. ! ! Discussion: ! ! SINQ1B computes the one-dimensional Fourier transform of a sequence ! which is a sine series with odd wave numbers. This transform is ! referred to as the backward transform or Fourier synthesis, ! transforming the sequence from spectral to physical space. ! ! This transform is normalized since a call to SINQ1B followed ! by a call to SINQ1F (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, the sequence to be ! transformed. On output, the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINQ1I before the first call to routine SINQ1F ! or SINQ1B for a given transform length N. WSAVE's contents may be ! re-used for subsequent calls to SINQ1F and SINQ1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, the error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) n integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xhold ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('sinq1b', 6) else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinq1b', 8) else if (lenwrk < n) then ier = 3 call xerfft ('sinq1b', 10) end if if ( 1 < n ) go to 101 ! ! x(1,1) = 4.*x(1,1) line disabled by dick valent 08/26/2010 ! return 101 ns2 = n/2 do 102 k=2,n,2 x(1,k) = -x(1,k) 102 continue call cosq1b (n,inc,x,lenx,wsave,lensav,work,lenwrk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinq1b',-5) return end if do 103 k=1,ns2 kc = n-k xhold = x(1,k) x(1,k) = x(1,kc+1) x(1,kc+1) = xhold 103 continue return end subroutine sinq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! SINQ1F: real double precision forward sine quarter wave transform, 1D. ! ! Discussion: ! ! SINQ1F computes the one-dimensional Fourier transform of a sequence ! which is a sine series of odd wave numbers. This transform is ! referred to as the forward transform or Fourier analysis, transforming ! the sequence from physical to spectral space. ! ! This transform is normalized since a call to SINQ1F followed ! by a call to SINQ1B (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, the sequence to be ! transformed. On output, the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINQ1I before the first call to routine SINQ1F ! or SINQ1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINQ1F and SINQ1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least N. ! ! Output, integer ( kind = 4 ) IER, the error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) n integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xhold ier = 0 if ( lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('sinq1f', 6) return end if if ( lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinq1f', 8) return end if if (lenwrk < n) then ier = 3 call xerfft ('sinq1f', 10) return end if if (n == 1) then return end if ns2 = n/2 do k=1,ns2 kc = n-k xhold = x(1,k) x(1,k) = x(1,kc+1) x(1,kc+1) = xhold end do call cosq1f (n,inc,x,lenx,wsave,lensav,work,lenwrk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinq1f',-5) return end if do k=2,n,2 x(1,k) = -x(1,k) end do return end subroutine sinq1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! SINQ1I: initialization for SINQ1B and SINQ1F. ! ! Discussion: ! ! SINQ1I initializes array WSAVE for use in its companion routines ! SINQ1F and SINQ1B. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used ! in routines SINQ1B or SINQ1F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinq1i', 3) go to 300 end if call cosq1i (n, wsave, lensav, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinq1i',-5) end if 300 continue return end subroutine sinqmb ( lot, jump, n, inc, x, lenx, wsave, lensav, & work, lenwrk, ier ) !*****************************************************************************80 ! !! SINQMB: real double precision backward sine quarter wave, multiple vectors. ! ! Discussion: ! ! SINQMB computes the one-dimensional Fourier transform of multiple ! sequences within a real array, where each of the sequences is a ! sine series with odd wave numbers. This transform is referred to as ! the backward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. ! ! This transform is normalized since a call to SINQMB followed ! by a call to SINQMF (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences to be ! transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing LOT sequences, each ! having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINQMI before the first call to routine SINQMF ! or SINQMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINQMF and SINQMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon real ( kind = 8 ) xhold ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('sinqmb', 6) else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinqmb', 8) else if (lenwrk < lot*n) then ier = 3 call xerfft ('sinqmb', 10) else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('sinqmb', -1) end if lj = (lot-1)*jump+1 if (1 < n ) go to 101 do m=1,lj,jump x(m,1) = 4.0D+00 * x(m,1) end do return 101 ns2 = n/2 do k=2,n,2 do m=1,lj,jump x(m,k) = -x(m,k) end do end do call cosqmb (lot,jump,n,inc,x,lenx,wsave,lensav,work,lenwrk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinqmb',-5) go to 300 end if do 103 k=1,ns2 kc = n-k do 203 m=1,lj,jump xhold = x(m,k) x(m,k) = x(m,kc+1) x(m,kc+1) = xhold 203 continue 103 continue 300 continue return end subroutine sinqmf ( lot, jump, n, inc, x, lenx, wsave, lensav, & work, lenwrk, ier ) !*****************************************************************************80 ! !! SINQMF: real double precision forward sine quarter wave, multiple vectors. ! ! Discussion: ! ! SINQMF computes the one-dimensional Fourier transform of multiple ! sequences within a real array, where each sequence is a sine series ! with odd wave numbers. This transform is referred to as the forward ! transform or Fourier synthesis, transforming the sequences from ! spectral to physical space. ! ! This transform is normalized since a call to SINQMF followed ! by a call to SINQMB (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, ! in array R, of the first elements of two consecutive sequences to ! be transformed. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing LOT sequences, each ! having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINQMI before the first call to routine SINQMF ! or SINQMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINQMF and SINQMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*N. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) jump integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lenx integer ( kind = 4 ) lj integer ( kind = 4 ) lot integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) ns2 real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon real ( kind = 8 ) xhold ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('sinqmf', 6) return else if (lensav < 2*n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinqmf', 8) return else if (lenwrk < lot*n) then ier = 3 call xerfft ('sinqmf', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('sinqmf', -1) return end if if (n == 1) then return end if ns2 = n/2 lj = (lot-1)*jump+1 do 101 k=1,ns2 kc = n-k do m=1,lj,jump xhold = x(m,k) x(m,k) = x(m,kc+1) x(m,kc+1) = xhold end do 101 continue call cosqmf (lot,jump,n,inc,x,lenx,wsave,lensav,work,lenwrk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinqmf',-5) return end if do k=2,n,2 do m=1,lj,jump x(m,k) = -x(m,k) end do end do 300 continue return end subroutine sinqmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! SINQMI: initialization for SINQMB and SINQMF. ! ! Discussion: ! ! SINQMI initializes array WSAVE for use in its companion routines ! SINQMF and SINQMB. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used ! in routines SINQMB or SINQMF. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) n real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < 2*n + int(log( real ( n, kind = 8 ) )/log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sinqmi', 3) return end if call cosqmi (n, wsave, lensav, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sinqmi',-5) end if return end subroutine sint1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! SINT1B: real double precision backward sine transform, 1D. ! ! Discussion: ! ! SINT1B computes the one-dimensional Fourier transform of an odd ! sequence within a real array. This transform is referred to as ! the backward transform or Fourier synthesis, transforming the ! sequence from spectral to physical space. ! ! This transform is normalized since a call to SINT1B followed ! by a call to SINT1F (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N+1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, contains the sequence ! to be transformed, and on output, the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINT1I before the first call to routine SINT1F ! or SINT1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINT1F and SINT1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*N+2. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) lenx integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('sint1b', 6) return else if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 4 ) then ier = 2 call xerfft ('sint1b', 8) return else if (lenwrk < (2*n+2)) then ier = 3 call xerfft ('sint1b', 10) return end if call sintb1(n,inc,x,wsave,work,work(n+2),ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sint1b',-5) end if return end subroutine sint1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier ) !*****************************************************************************80 ! !! SINT1F: real double precision forward sine transform, 1D. ! ! Discussion: ! ! SINT1F computes the one-dimensional Fourier transform of an odd ! sequence within a real array. This transform is referred to as the ! forward transform or Fourier analysis, transforming the sequence ! from physical to spectral space. ! ! This transform is normalized since a call to SINT1F followed ! by a call to SINT1B (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N+1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, ! in array R, of two consecutive elements within the sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), on input, contains the sequence ! to be transformed, and on output, the transformed sequence. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINT1I before the first call to routine SINT1F ! or SINT1B for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINT1F and SINT1B with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least 2*N+2. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) lenx integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) ier = 0 if (lenx < inc*(n-1) + 1) then ier = 1 call xerfft ('sint1f', 6) return else if (lensav < n/2 + n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sint1f', 8) return else if (lenwrk < (2*n+2)) then ier = 3 call xerfft ('sint1f', 10) return end if call sintf1(n,inc,x,wsave,work,work(n+2),ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sint1f',-5) end if return end subroutine sint1i ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! SINT1I: initialization for SINT1B and SINT1F. ! ! Discussion: ! ! SINT1I initializes array WSAVE for use in its companion routines ! SINT1F and SINT1B. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. The transform is most efficient when N+1 is a product ! of small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used ! in routines SINT1B or SINT1F. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) lnsv integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) pi real ( kind = 8 ) wsave(lensav) ier = 0 if (lensav < n/2 + n + int(log( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sint1i', 3) return end if pi = 4.0D+00 * atan ( 1.0D+00 ) if (n <= 1) then return end if ns2 = n/2 np1 = n+1 dt = pi / real ( np1, kind = 8 ) do k=1,ns2 wsave(k) = 2.0D+00 *sin(k*dt) end do lnsv = np1 + int(log( real ( np1, kind = 8 ))/log( 2.0D+00 )) +4 call rfft1i (np1, wsave(ns2+1), lnsv, ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sint1i',-5) end if return end subroutine sintb1 ( n, inc, x, wsave, xh, work, ier ) !*****************************************************************************80 ! !! SINTB1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum real ( kind = 8 ) fnp1s4 integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lnxh integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) srt3s2 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xh(*) real ( kind = 8 ) xhold ier = 0 if (n-2) 200,102,103 102 srt3s2 = sqrt( 3.0D+00 ) / 2.0D+00 xhold = srt3s2*(x(1,1)+x(1,2)) x(1,2) = srt3s2*(x(1,1)-x(1,2)) x(1,1) = xhold return 103 np1 = n+1 ns2 = n/2 do 104 k=1,ns2 kc = np1-k t1 = x(1,k)-x(1,kc) t2 = wsave(k)*(x(1,k)+x(1,kc)) xh(k+1) = t1+t2 xh(kc+1) = t2-t1 104 continue modn = mod(n,2) if (modn == 0) go to 124 xh(ns2+2) = 4.0D+00 * x(1,ns2+1) 124 xh(1) = 0.0D+00 lnxh = np1 lnsv = np1 + int(log( real ( np1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = np1 call rfft1f(np1,1,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sintb1',-5) return end if if(mod(np1,2) /= 0) go to 30 xh(np1) = xh(np1)+xh(np1) 30 fnp1s4 = real ( np1, kind = 8 ) / 4.0D+00 x(1,1) = fnp1s4*xh(1) dsum = x(1,1) do i=3,n,2 x(1,i-1) = fnp1s4*xh(i) dsum = dsum+fnp1s4*xh(i-1) x(1,i) = dsum end do if ( modn == 0 ) then x(1,n) = fnp1s4*xh(n+1) end if 200 continue return end subroutine sintf1 ( n, inc, x, wsave, xh, work, ier ) !*****************************************************************************80 ! !! SINTF1 is an FFTPACK5.1 auxiliary routine. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! implicit none integer ( kind = 4 ) inc real ( kind = 8 ) dsum integer ( kind = 4 ) i integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) lnsv integer ( kind = 4 ) lnwk integer ( kind = 4 ) lnxh integer ( kind = 4 ) modn integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) sfnp1 real ( kind = 8 ) ssqrt3 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) work(*) real ( kind = 8 ) wsave(*) real ( kind = 8 ) x(inc,*) real ( kind = 8 ) xh(*) real ( kind = 8 ) xhold ier = 0 if (n-2) 200,102,103 102 ssqrt3 = 1.0D+00 / sqrt ( 3.0D+00 ) xhold = ssqrt3*(x(1,1)+x(1,2)) x(1,2) = ssqrt3*(x(1,1)-x(1,2)) x(1,1) = xhold go to 200 103 np1 = n+1 ns2 = n/2 do k=1,ns2 kc = np1-k t1 = x(1,k)-x(1,kc) t2 = wsave(k)*(x(1,k)+x(1,kc)) xh(k+1) = t1+t2 xh(kc+1) = t2-t1 end do modn = mod(n,2) if (modn == 0) go to 124 xh(ns2+2) = 4.0D+00 * x(1,ns2+1) 124 xh(1) = 0.0D+00 lnxh = np1 lnsv = np1 + int(log( real ( np1, kind = 8 ))/log( 2.0D+00 )) + 4 lnwk = np1 call rfft1f(np1,1,xh,lnxh,wsave(ns2+1),lnsv,work, lnwk,ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sintf1',-5) go to 200 end if if(mod(np1,2) /= 0) go to 30 xh(np1) = xh(np1)+xh(np1) 30 sfnp1 = 1.0D+00 / real ( np1, kind = 8 ) x(1,1) = 0.5D+00 * xh(1) dsum = x(1,1) do i=3,n,2 x(1,i-1) = 0.5D+00 * xh(i) dsum = dsum + 0.5D+00 * xh(i-1) x(1,i) = dsum end do if (modn /= 0) go to 200 x(1,n) = 0.5D+00 * xh(n+1) 200 continue return end subroutine sintmb ( lot, jump, n, inc, x, lenx, wsave, lensav, & work, lenwrk, ier ) !*****************************************************************************80 ! !! SINTMB: real double precision backward sine transform, multiple vectors. ! ! Discussion: ! ! SINTMB computes the one-dimensional Fourier transform of multiple ! odd sequences within a real array. This transform is referred to as ! the backward transform or Fourier synthesis, transforming the ! sequences from spectral to physical space. ! ! This transform is normalized since a call to SINTMB followed ! by a call to SINTMF (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed ! within the array R. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, in ! array R, of the first elements of two consecutive sequences. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N+1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing LOT sequences, each ! having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINTMI before the first call to routine SINTMF ! or SINTMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINTMF and SINTMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*(2*N+4). ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw1 integer ( kind = 4 ) iw2 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon ier = 0 if (lenx < (lot-1)*jump + inc*(n-1) + 1) then ier = 1 call xerfft ('sintmb', 6) return else if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) & /log( 2.0D+00 )) +4) then ier = 2 call xerfft ('sintmb', 8) return else if (lenwrk < lot*(2*n+4)) then ier = 3 call xerfft ('sintmb', 10) return else if (.not. xercon(inc,jump,n,lot)) then ier = 4 call xerfft ('sintmb', -1) return end if iw1 = lot+lot+1 iw2 = iw1+lot*(n+1) call msntb1(lot,jump,n,inc,x,wsave,work,work(iw1),work(iw2),ier1) if (ier1 /= 0) then ier = 20 call xerfft ('sintmb',-5) return end if return end subroutine sintmf ( lot, jump, n, inc, x, lenx, wsave, lensav, & work, lenwrk, ier ) !*****************************************************************************80 ! !! SINTMF: real double precision forward sine transform, multiple vectors. ! ! Discussion: ! ! SINTMF computes the one-dimensional Fourier transform of multiple ! odd sequences within a real array. This transform is referred to as ! the forward transform or Fourier analysis, transforming the sequences ! from physical to spectral space. ! ! This transform is normalized since a call to SINTMF followed ! by a call to SINTMB (or vice-versa) reproduces the original ! array within roundoff error. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LOT, the number of sequences to be ! transformed within. ! ! Input, integer ( kind = 4 ) JUMP, the increment between the locations, ! in array R, of the first elements of two consecutive sequences. ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N+1 is a product of ! small primes. ! ! Input, integer ( kind = 4 ) INC, the increment between the locations, in ! array R, of two consecutive elements within the same sequence. ! ! Input/output, real ( kind = 8 ) R(LENR), containing LOT sequences, each ! having length N. R can have any number of dimensions, but the total ! number of locations must be at least LENR. On input, R contains the data ! to be transformed, and on output, the transformed data. ! ! Input, integer ( kind = 4 ) LENR, the dimension of the R array. ! LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1. ! ! Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be ! initialized with a call to SINTMI before the first call to routine SINTMF ! or SINTMB for a given transform length N. WSAVE's contents may be re-used ! for subsequent calls to SINTMF and SINTMB with the same N. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Workspace, real ( kind = 8 ) WORK(LENWRK). ! ! Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array. ! LENWRK must be at least LOT*(2*N+4). ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 1, input parameter LENR not big enough; ! 2, input parameter LENSAV not big enough; ! 3, input parameter LENWRK not big enough; ! 4, input parameters INC,JUMP,N,LOT are not consistent; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) inc integer ( kind = 4 ) lensav integer ( kind = 4 ) lenwrk integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) iw1 integer ( kind = 4 ) iw2 integer ( kind = 4 ) jump integer ( kind = 4 ) lenx integer ( kind = 4 ) lot integer ( kind = 4 ) n real ( kind = 8 ) work(lenwrk) real ( kind = 8 ) wsave(lensav) real ( kind = 8 ) x(inc,*) logical xercon ier = 0 if ( lenx < ( lot - 1) * jump + inc * ( n - 1 ) + 1 ) then ier = 1 call xerfft ( 'sintmf', 6 ) return else if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 4 ) then ier = 2 call xerfft ( 'sintmf', 8 ) return else if ( lenwrk < lot * ( 2 * n + 4 ) ) then ier = 3 call xerfft ( 'sintmf', 10 ) return else if ( .not. xercon ( inc, jump, n, lot ) ) then ier = 4 call xerfft ( 'sintmf', -1 ) return end if iw1 = lot + lot + 1 iw2 = iw1 + lot * ( n + 1 ) call msntf1 ( lot, jump, n, inc, x, wsave, work, work(iw1), work(iw2), ier1 ) if ( ier1 /= 0 ) then ier = 20 call xerfft ( 'sintmf', -5 ) end if return end subroutine sintmi ( n, wsave, lensav, ier ) !*****************************************************************************80 ! !! SINTMI: initialization for SINTMB and SINTMF. ! ! Discussion: ! ! SINTMI initializes array WSAVE for use in its companion routines ! SINTMF and SINTMB. The prime factorization of N together with a ! tabulation of the trigonometric functions are computed and stored ! in array WSAVE. Separate WSAVE arrays are required for different ! values of N. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of each sequence to be ! transformed. The transform is most efficient when N is a product of ! small primes. ! ! Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array. ! LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4. ! ! Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors ! of N and also containing certain trigonometric values which will be used ! in routines SINTMB or SINTMF. ! ! Output, integer ( kind = 4 ) IER, error flag. ! 0, successful exit; ! 2, input parameter LENSAV not big enough; ! 20, input error returned by lower level routine. ! implicit none integer ( kind = 4 ) lensav real ( kind = 8 ) dt integer ( kind = 4 ) ier integer ( kind = 4 ) ier1 integer ( kind = 4 ) k integer ( kind = 4 ) lnsv integer ( kind = 4 ) n integer ( kind = 4 ) np1 integer ( kind = 4 ) ns2 real ( kind = 8 ) pi real ( kind = 8 ) wsave(lensav) ier = 0 if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) & / log ( 2.0D+00 ) ) + 4 ) then ier = 2 call xerfft ( 'sintmi', 3 ) return end if pi = 4.0D+00 * atan ( 1.0D+00 ) if ( n <= 1 ) then return end if ns2 = n / 2 np1 = n + 1 dt = pi / real ( np1, kind = 8 ) do k = 1, ns2 wsave(k) = 2.0D+00 * sin ( k * dt ) end do lnsv = np1 + int ( log ( real ( np1, kind = 8 ) ) / log ( 2.0D+00 ) ) + 4 call rfftmi ( np1, wsave(ns2+1), lnsv, ier1 ) if ( ier1 /= 0 ) then ier = 20 call xerfft ( 'sintmi', -5 ) end if return end subroutine w2r ( ldr, ldw, l, m, r, w ) !*****************************************************************************80 ! !! W2R copies a 2D array, allowing for different leading dimensions. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 13 May 2013 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) LDR, the leading dimension of R. ! ! Input, integer ( kind = 4 ) LDW, the leading dimension of W. ! ! Input, integer ( kind = 4 ) L, M, the number of rows and columns ! of information to be copied. ! ! Output, real ( kind = 8 ) R(LDR,M), the copied information. ! ! Input, real ( kind = 8 ) W(LDW,M), the original information. ! implicit none integer ( kind = 4 ) ldr integer ( kind = 4 ) ldw integer ( kind = 4 ) m integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) l real ( kind = 8 ) r(ldr,m) real ( kind = 8 ) w(ldw,m) do j = 1, m do i = 1, l r(i,j) = w(i,j) end do end do return end function xercon ( inc, jump, n, lot ) !*****************************************************************************80 ! !! XERCON checks INC, JUMP, N and LOT for consistency. ! ! Discussion: ! ! Positive integers INC, JUMP, N and LOT are "consistent" if, ! for any values I1 and I2 < N, and J1 and J2 < LOT, ! ! I1 * INC + J1 * JUMP = I2 * INC + J2 * JUMP ! ! can only occur if I1 = I2 and J1 = J2. ! ! For multiple FFT's to execute correctly, INC, JUMP, N and LOT must ! be consistent, or else at least one array element will be ! transformed more than once. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, integer ( kind = 4 ) INC, JUMP, N, LOT, the parameters to check. ! ! Output, logical XERCON, is TRUE if the parameters are consistent. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) inc integer ( kind = 4 ) j integer ( kind = 4 ) jnew integer ( kind = 4 ) jump integer ( kind = 4 ) lcm integer ( kind = 4 ) lot integer ( kind = 4 ) n logical xercon i = inc j = jump do while ( j /= 0 ) jnew = mod ( i, j ) i = j j = jnew end do ! ! LCM = least common multiple of INC and JUMP. ! lcm = ( inc * jump ) / i if ( lcm <= ( n - 1 ) * inc .and. lcm <= ( lot - 1 ) * jump ) then xercon = .false. else xercon = .true. end if return end subroutine xerfft ( srname, info ) !*****************************************************************************80 ! !! XERFFT is an error handler for the FFTPACK routines. ! ! Discussion: ! ! XERFFT is an error handler for FFTPACK version 5.1 routines. ! It is called by an FFTPACK 5.1 routine if an input parameter has an ! invalid value. A message is printed and execution stops. ! ! Installers may consider modifying the stop statement in order to ! call system-specific exception-handling facilities. ! ! License: ! ! Licensed under the GNU General Public License (GPL). ! Copyright (C) 1995-2004, Scientific Computing Division, ! University Corporation for Atmospheric Research ! ! Modified: ! ! 15 November 2011 ! ! Author: ! ! Original FORTRAN77 version by Paul Swarztrauber, Richard Valent. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Paul Swarztrauber, ! Vectorizing the Fast Fourier Transforms, ! in Parallel Computations, ! edited by G. Rodrigue, ! Academic Press, 1982. ! ! Paul Swarztrauber, ! Fast Fourier Transform Algorithms for Vector Computers, ! Parallel Computing, pages 45-63, 1984. ! ! Parameters: ! ! Input, character ( len = * ) SRNAME, the name of the calling routine. ! ! Input, integer ( kind = 4 ) INFO, an error code. When a single invalid ! parameter in the parameter list of the calling routine has been detected, ! INFO is the position of that parameter. In the case when an illegal ! combination of LOT, JUMP, N, and INC has been detected, the calling ! subprogram calls XERFFT with INFO = -1. ! implicit none integer ( kind = 4 ) info character ( len = * ) srname write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'XERFFT - Fatal error!' if ( 1 <= info ) then write ( *, '(a,a,a,i3,a)' ) ' On entry to ', trim ( srname ), & ' parameter number ', info, ' had an illegal value.' else if ( info == -1 ) then write ( *, '(a,a,a,a)' ) ' On entry to ', trim ( srname ), & ' parameters LOT, JUMP, N and INC are inconsistent.' else if ( info == -2 ) then write ( *, '(a,a,a,a)' ) ' On entry to ', trim ( srname ), & ' parameter L is greater than LDIM.' else if ( info == -3 ) then write ( *, '(a,a,a,a)' ) ' On entry to ', trim ( srname ), & ' parameter M is greater than MDIM.' else if ( info == -5 ) then write ( *, '(a,a,a,a)' ) ' Within ', trim ( srname ), & ' input error returned by lower level routine.' else if ( info == -6 ) then write ( *, '(a,a,a,a)' ) ' On entry to ', trim ( srname ), & ' parameter LDIM is less than 2*(L/2+1).' end if stop end #endif ! END MODULE fftpack51