00001 c pd4fwt3ds_.F
00002 c*********************************************************************
00003 c* (c) Copyright 1994-2002 Brown Deer Technology, LLC.
00004 c* All rights reserved.
00005 c*********************************************************************
00006
00007 subroutine pd4fwt3ds(Sizef3d,ns,ks,size,sdata,wdata,iflag)
00008
00009 implicit none
00010
00011 c ****************************************
00012 c ***** COMMON BLOCKS AND PARAMETERS *****
00013 c ****************************************
00014
00015 #include "stormdef.h"
00016 real H0,H1,H2,H3
00017 parameter( H0 = STORMDEF_MATHCONST_D4H0 )
00018 parameter( H1 = STORMDEF_MATHCONST_D4H1 )
00019 parameter( H2 = STORMDEF_MATHCONST_D4H2 )
00020 parameter( H3 = STORMDEF_MATHCONST_D4H3 )
00021
00022 c *******************************
00023 c ***** VARIABLES EXCHANGED *****
00024 c *******************************
00025
00026 integer Sizef3d
00027 integer ns
00028 integer ks
00029 integer size
00030 real sdata(Sizef3d,Sizef3d,Sizef3d)
00031 real wdata(Sizef3d,Sizef3d,Sizef3d)
00032 integer iflag
00033
00034 c ***************************
00035 c ***** LOCAL VARIABLES *****
00036 c ***************************
00037
00038 integer i,j,k,ii,jj,kk
00039 integer ii1,ii2,ii3
00040 integer jj1,jj2,jj3
00041 integer kk1,kk2,kk3
00042 integer size1,size2
00043 real u(Sizef3d)
00044 real v(Sizef3d)
00045
00046 c ******************************
00047 c ***** EXTERNAL FUNCTIONS *****
00048 c ******************************
00049
00050 #ifdef STORM_FWT_FCHECKUSAGE
00051 if (size.lt.ns) then
00052 iflag=1
00053 return
00054 endif
00055 #endif
00056
00057 do i=1,size
00058 do j=1,size
00059 do k=1,size
00060 wdata(i,j,k)=sdata(i,j,k)
00061 enddo
00062 enddo
00063 enddo
00064
00065 if (size.eq.ns) then
00066 iflag=0
00067 return
00068 endif
00069
00070 size1=size
00071
00072 10 continue
00073
00074 size2=size1/2
00075
00076 c ##### index 1 #####
00077 do j=1,size1
00078 do k=1,size1
00079
00080 do i=1,size1
00081 u(i)=wdata(i,j,k)
00082 enddo
00083
00084 do i = 1,size2
00085 ii = 2*i - 1
00086 ii1 = mod(ii+1-1,size1)+1
00087 ii2 = mod(ii+2-1,size1)+1
00088 ii3 = mod(ii+3-1,size1)+1
00089 v(i) = H0*u(ii) + H1*u(ii1) + H2*u(ii2) + H3*u(ii3)
00090 v(size2+i) = H3*u(ii) - H2*u(ii1) + H1*u(ii2) - H0*u(ii3)
00091 enddo
00092
00093 do i=1,size1
00094 wdata(i,j,k)=v(i)
00095 enddo
00096
00097 enddo
00098 enddo
00099
00100 c ##### index 2 #####
00101 do i=1,size1
00102 do k=1,size1
00103
00104 do j=1,size1
00105 u(j)=wdata(i,j,k)
00106 enddo
00107
00108 do j = 1, size2
00109 jj = 2*j - 1
00110 jj1 = mod(jj+1-1,size1)+1
00111 jj2 = mod(jj+2-1,size1)+1
00112 jj3 = mod(jj+3-1,size1)+1
00113 v(j) = H0*u(jj) + H1*u(jj1) + H2*u(jj2) + H3*u(jj3)
00114 v(size2+j) = H3*u(jj) - H2*u(jj1) + H1*u(jj2) - H0*u(jj3)
00115 enddo
00116
00117 do j=1,size1
00118 wdata(i,j,k)=v(j)
00119 enddo
00120
00121 enddo
00122 enddo
00123
00124 c ##### index 3 #####
00125 do i=1,size1
00126 do j=1,size1
00127
00128 do k=1,size1
00129 u(k)=wdata(i,j,k)
00130 enddo
00131
00132 do k = 1, size2
00133 kk = 2*k - 1
00134 kk1 = mod(kk+1-1,size1)+1
00135 kk2 = mod(kk+2-1,size1)+1
00136 kk3 = mod(kk+3-1,size1)+1
00137 v(k) = H0*u(kk) + H1*u(kk1) + H2*u(kk2) + H3*u(kk3)
00138 v(size2+k) = H3*u(kk) - H2*u(kk1) + H1*u(kk2) - H0*u(kk3)
00139 enddo
00140
00141 do k=1,size1
00142 wdata(i,j,k)=v(k)
00143 enddo
00144
00145 enddo
00146 enddo
00147
00148 size1=size2
00149
00150 if (size1.gt.ns) then
00151 goto 10
00152 endif
00153
00154 #ifdef STORM_FWT_FCHECKUSAGE
00155 if (size1.ne.ns) then
00156 iflag=2
00157 return
00158 endif
00159 #endif
00160
00161 iflag=0
00162
00163 return
00164 end
00165
