00001 c dpd4fwt2dsws_.F
00002 c*********************************************************************
00003 c* (c) Copyright 1994-2002 Brown Deer Technology, LLC.
00004 c* All rights reserved.
00005 c*********************************************************************
00006
00007 subroutine dpd4fwt2dsws(Sizef2d,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 Sizef2d
00027 integer ns
00028 integer ks
00029 integer size
00030 double precision sdata(Sizef2d,Sizef2d)
00031 double precision wdata(Sizef2d,Sizef2d)
00032 double precision ws(2*Sizef2d)
00033 integer iflag
00034
00035 c ***************************
00036 c ***** LOCAL VARIABLES *****
00037 c ***************************
00038
00039 integer i,j,ii,jj
00040 integer ii1,ii2,ii3
00041 integer jj1,jj2,jj3
00042 integer size1,size2
00043
00044 c ******************************
00045 c ***** EXTERNAL FUNCTIONS *****
00046 c ******************************
00047
00048 #ifdef STORM_FWT_FCHECKUSAGE
00049 if (size.lt.ns) then
00050 iflag=1
00051 return
00052 endif
00053 #endif
00054
00055 do i=1,size
00056 do j=1,size
00057 wdata(i,j)=sdata(i,j)
00058 enddo
00059 enddo
00060
00061 if (size.eq.ns) then
00062 iflag=0
00063 return
00064 endif
00065
00066 size1=size
00067
00068 10 continue
00069
00070 size2=size1/2
00071
00072 c ##### index 1 #####
00073 do j=1,size1
00074
00075 do i=1,size1
00076 ws(i)=wdata(i,j)
00077 enddo
00078
00079 do i = 1,size2
00080 ii = 2*i - 1
00081 ii1 = mod( ii+1-1, size1)+1
00082 ii2 = mod( ii+2-1, size1)+1
00083 ii3 = mod( ii+3-1, size1)+1
00084 ws(Sizef2d+i) = H0*ws(ii) + H1*ws(ii1)
00085 & + H2*ws(ii2) + H3*ws(ii3)
00086 ws(Sizef2d+size2+i) = H3*ws(ii) - H2*ws(ii1)
00087 & + H1*ws(ii2) - H0*ws(ii3)
00088 enddo
00089
00090 do i=1,size1
00091 wdata(i,j)=ws(Sizef2d+i)
00092 enddo
00093
00094 enddo
00095
00096 c ##### index 2 #####
00097 do i=1,size1
00098
00099 do j=1,size1
00100 ws(j)=wdata(i,j)
00101 enddo
00102
00103 do j = 1, size2
00104 jj = 2*j - 1
00105 jj1 = mod( jj+1-1, size1)+1
00106 jj2 = mod( jj+2-1, size1)+1
00107 jj3 = mod( jj+3-1, size1)+1
00108 ws(Sizef2d+j) = H0*ws(jj) + H1*ws(jj1)
00109 & + H2*ws(jj2) + H3*ws(jj3)
00110 ws(Sizef2d+size2+j) = H3*ws(jj) - H2*ws(jj1)
00111 & + H1*ws(jj2) - H0*ws(jj3)
00112 enddo
00113
00114 do j=1,size1
00115 wdata(i,j)=ws(Sizef2d+j)
00116 enddo
00117
00118 enddo
00119
00120 size1=size2
00121
00122 if (size1.gt.ns) then
00123 goto 10
00124 endif
00125
00126 #ifdef STORM_FWT_FCHECKUSAGE
00127 if (size1.ne.ns) then
00128 iflag=2
00129 return
00130 endif
00131 #endif
00132
00133 iflag=0
00134
00135 return
00136 end
00137
