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