program incomp * incomp system * The code features * incompressible MHD; kinematic dynamo * spheriod in precession frame; Omegap=Omegapx * @ Runge-Kutta in time: 2nd and 3rd order(TVD), 4th order(non-TVD); ********************************************************************* c parameter( mtm=4, mn=4, mngp=30000, mx1=51, my1=51, mz1=51 ) parameter( mx2=71, my2=71, mz2=61+1 ) parameter( mx3=71, my3=71, mz3=61+1 ) c for grid 5 and 5b and 5 ex integer nphi, nmu, nnu, nmuh parameter (nphi=64*2, nmu=nphi, nnu=nphi/2, nmuh=nmu/2) real amu(nmu), aaanu(nnu), aphi(nphi), amuh(nmuh) integer ig5(nphi+2, nmuh+2, nnu+2), ngp5(nphi+2, nmuh+2, nnu+2, 3) real drngp5(nphi+2, nmuh+2, nnu+2, 3) integer ig5b(nphi+2,nnu+2), ngp5b(nphi+2, nnu+2,3) real drngp5b(nphi+2,nnu+2,3), g5b(nphi+2,nnu+2,3) real uc5(nphi+2, nmuh+2, nnu+2, 3), uc5b(nphi+2, nnu+2, 3) real tmp5b(nphi+2, nnu+2) real uc5old(nphi+2, nmuh+2, nnu+2, 3) real cc, aa, aa2, amu0, philength, amulength, anulength real dphi, dmu, dnu, pi, pphi, aamu, aanu c for double real uc5p(nphi, nmuh, nnu),uc5pdouble(nphi, nmu, nnu) real uc5pex(nphi+2, nmuh+2, nnu+2) real bndrynu(nphi,nmu,2), bndrymu(nphi,nnu) real bndrynumu(nphi,2), errmax, diff real uc5bndry(nphi,nnu,2), data2(nphi,nnu) c for 5 ex and Grid 1, 2, 3 c real uc5ex(nphi+2, nmuh+2, nnu+2) integer ngp15(mx1,my1,mz1,3) real drngp15(mx1,my1,mz1,3) integer ngp25(mx2,my2,mz2,3) real drngp25(mx2,my2,mz2,3) integer ngp35(mx3,my3,mz3,3) real drngp35(mx3,my3,mz3,3) integer ngp25b(mx2,my2,2) real drngp25b(mx2,my2,2) integer ngp35b(mx3,my3,2) real drngp35b(mx3,my3,2) c c c for B bndry integer mth, mphi,mwsave,mx4,my4,mz4,imax,mmax,jmax,lmax,lmmax,lmmax1 parameter(mth=3*22,mphi=3*3*2**4,mwsave=2*mphi+15, 1 mx4=mth,my4=mphi) parameter(imax=mphi, mmax=imax/3*2, jmax=mth,lmax=mmax, 1 lmmax=lmax+mmax,lmmax1=lmmax+1) real ub4(mth,mphi,2,6),rhsb4(mth,mphi,1,1,mtm) 1 , g4(mth,mphi,2), dr42(mngp,3), dr42b(mngp,3) 1 , dr43(mngp,3), dr43b(mngp,3) real uc4(mth,mphi,3) integer ig4(mth,mphi), ngp42(mngp,3) ,ngp43(mngp,3) 1 ,ngp42b(mngp,3) ,ngp43b(mngp,3) real wsave(mwsave) real gausspt(jmax), snj(jmax) c 1 ,rrr(0:mmax,jmax,jmax) ,hhh(0:mmax,jmax,jmax) c 2 ,ttt(0:mmax,jmax,jmax),fff(0:mmax,jmax,jmax) c common/bbndryv/gausspt,snj, rrr,hhh,ttt,fff common/bbndryv/gausspt, snj dimension uc1(mx1,my1,mz1,mn), rhs1(mx1,my1,mz1,mn-1,mtm) 1 , ig1(mx1,my1,mz1), g1(mx1,my1,mz1,3), rhsp1(mx1,my1,mz1) 1 , ngp12(mngp,3), dr12(mngp,3) 1 , ngp13(mngp,3), dr13(mngp,3) dimension uc2(mx2,my2,mz2,mn), rhs2(mx2,my2,mz2,mn-1,mtm) 1 , ig2(mx2,my2,mz2), g2(mx2,my2,mz2,3), trans2(mx2,my2,mz2,3,3) 1 , ngp21(mngp,3), dr21(mngp,3), rhsp2(mx2,my2,mz2) 1 , ngp23(mngp,3), dr23(mngp,3), eb2(mx2,my2,3) 1 , uc2bndry(mx2,my2,3,9), ub2bndry(mx2,my2,3,9) dimension uc3(mx3,my3,mz3,mn), rhs3(mx3,my3,mz3,mn-1,mtm) 1 , ig3(mx3,my3,mz3), g3(mx3,my3,mz3,3), trans3(mx3,my3,mz3,3,3) 1 , ngp31(mngp,3), dr31(mngp,3), rhsp3(mx3,my3,mz3) 1 , ngp32(mngp,3), dr32(mngp,3), eb3(mx3,my3,3) 1 , uc3bndry(mx3,my3,3,9), ub3bndry(mx3,my3,3,9) real ub1(mx1,my1,mz1,mn), rhsb1(mx1,my1,mz1,mn-1,mtm) real dr24(mngp,3), uv2bndry(mx2,my2,3,3) 1 , udv2bndry(mx2,my2,3) integer ngp24(mngp,3) real ub2(mx2,my2,mz2,mn), rhsb2(mx2,my2,mz2,mn-1,mtm) real ub2s(mx2,my2), tmpb2(mx2,my2) real dr34(mngp,3), uv3bndry(mx3,my3,3,3) 1 , udv3bndry(mx3,my3,3) integer ngp34(mngp,3) real ub3(mx3,my3,mz3,mn), rhsb3(mx3,my3,mz3,mn-1,mtm) real ub3s(mx3,my3) real ub5(nphi+2, nnu+2), rhsb5(nphi+2, nnu+2, mtm) character*12 real_clock(2) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c initialization for b bndry call rffti(mphi,wsave) call bbndryini c usage call bbndry(uc4,mth,mphi,wsave,mwsave) c for grid 5 cc=0.8 amu0=0.5*(alog(1.+cc)-alog(1.-cc)) aa2=1.-cc*cc aa=sqrt(aa2) pi=4.*atan(1.) philength=2.*pi amulength=2.*amu0 anulength=pi dphi = philength / float(nphi) dmu = amulength / float(nmu) dnu = anulength / float(nnu) c do i = 1, nphi aphi(i) = (i-1) * dphi enddo do j = 1, nmu amu(j) = -amu0 + (float(j)-0.5) * dmu enddo do j = 1, nmuh amuh(j) = (float(j)-0.5) * dmu enddo do k = 1, nnu aaanu(k) = (float(k)-0.5) * dnu enddo ifirst=0 c c parameters factor=cc ca=1. cb=ca*factor omega=1. omegap=0.25 anu=0.00375 eta=.00375*0.5 omegapx=omegap dr1=2.*0.65/(mx1-1) ds1=dr1 dt1=dr1 dr2=2./float(mx2-1) ds2=2./float(my2-1) dt2=(1.-0.4)/float(mz2-2) dr3=2./float(mx3-1) ds3=2./float(my3-1) dt3=(1.-0.4)/float(mz3-2) ds4=2.*3.14159265359/(float(my4)) dt4=dt3 c lrstrt=0, initialization; =1 restart c tf= final time; mt: order in time integration lrstrt=1 ntot=250700 tf=600.*4. mt=2 cfl=0.6 c************** begin reading in parameters *********************** nx1=mx1 ny1=my1 nz1=mz1 nxs1=1 nxe1=nx1 nys1=1 nye1=ny1 nzs1=1 nze1=nz1 nx2=mx2 ny2=my2 nz2=mz2 nxs2=1 nxe2=nx2 nys2=1 nye2=ny2 nzs2=1 nze2=nz2-1 nx3=mx3 ny3=my3 nz3=mz3 nxs3=1 nxe3=nx3 nys3=1 nye3=ny3 nzs3=1 nze3=nz3-1 nx4=mx4 ny4=my4 nz4=mz4 nxs4=1 nxe4=nx4 nys4=1 nye4=ny4 c read grid info c G1 read(81) ig1, g1 icount=0 do i=1,nx1 do j=1,ny1 do k=1,nz1 if(ig1(i,j,k).eq.-2) then icount=icount+1 read(82, 821) (ngp12(icount,m),m=1,3), (dr12(icount,m),m=1,3) 821 format(3i5,3e20.12) end if end do end do end do numngp12=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount icount=0 do i=1,nx1 do j=1,ny1 do k=1,nz1 if(ig1(i,j,k).eq.-3) then icount=icount+1 read(83, 821) (ngp13(icount,m),m=1,3), (dr13(icount,m),m=1,3) end if end do end do end do numngp13=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c G2 read(84) ig2, g2, trans2 icount=0 do i=1,nx2 do j=1,ny2 do k=1,nz2 if(ig2(i,j,k).eq.-1) then icount=icount+1 read(85, 821) (ngp21(icount,m),m=1,3), (dr21(icount,m),m=1,3) end if end do end do end do numngp21=icount icount=0 do i=1,nx2 do j=1,ny2 do k=1,nz2 if(ig2(i,j,k).eq.-3) then icount=icount+1 read(86, 821) (ngp23(icount,m),m=1,3), (dr23(icount,m),m=1,3) end if end do end do end do numngp23=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c G3 read(87) ig3, g3, trans3 icount=0 do i=1,nx3 do j=1,ny3 do k=1,nz3 if(ig3(i,j,k).eq.-1) then icount=icount+1 read(88, 821) (ngp31(icount,m),m=1,3), (dr31(icount,m),m=1,3) end if end do end do end do numngp31=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount icount=0 do i=1,nx3 do j=1,ny3 do k=1,nz3 if(ig3(i,j,k).eq.-2) then icount=icount+1 read(89, 821) (ngp32(icount,m),m=1,3), (dr32(icount,m),m=1,3) end if end do end do end do numngp32=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c for G5 and G5b read(71) ig5, ngp5, drngp5, ig5b, ngp5b, drngp5b read(72) ngp15, drngp15, ngp25, drngp25, ngp35, drngp35 read(73) ngp25b, drngp25b, ngp35b, drngp35b c set up coefficients in grids 2 and 3 igrid=2 call bndryvdd(uc2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 call bndryvdd(uc3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c set up coefficients in grids 2 and 3 igrid=2 call bndryBdd(ub2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 call bndryBdd(ub3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c G4 read(94) xi0,dxi,ig4, g4 c c write(*,*) 'xi0, coshxio', xi0, cosh(xi0), ca, cb c stop c from G2 for points at xi-dxi on Grid 4 icount=0 do i=1,nx4 do j=1,ny4 if(ig4(i,j).eq.-2) then icount=icount+1 read(90, 821) (ngp42(icount,m),m=1,3), (dr42(icount,m),m=1,3) end if end do end do numngp42=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c from G3 for points at xi-dxi on Grid 4 icount=0 do i=1,nx4 do j=1,ny4 if(ig4(i,j).eq.-3) then icount=icount+1 read(91, 821) (ngp43(icount,m),m=1,3), (dr43(icount,m),m=1,3) end if end do end do numngp43=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c c from G2 for points at xi on Grid 4 icount=0 do i=1,nx4 do j=1,ny4 if(ig4(i,j).eq.-2) then icount=icount+1 read(95, 821) (ngp42b(icount,m),m=1,3), (dr42b(icount,m),m=1,3) end if end do end do numngp42b=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c from G3 for points at xi on Grid 4 icount=0 do i=1,nx4 do j=1,ny4 if(ig4(i,j).eq.-3) then icount=icount+1 read(96, 821) (ngp43b(icount,m),m=1,3), (dr43b(icount,m),m=1,3) end if end do end do numngp43b=icount if(icount.gt.mngp) 1 write(*,*) 'trouble in interpolating points', icount c c G2 from G4 c from G2 icount=0 k=nz2-1 do i=1,nx2 do j=1,ny2 if(ig2(i,j,k).eq.2) then icount=icount+1 read(92, 821) (ngp24(icount,m),m=1,3), (dr24(icount,m),m=1,3) end if end do end do numngp24=icount c c G3 from G4 c from G3 icount=0 k=nz3-1 do i=1,nx3 do j=1,ny3 if(ig3(i,j,k).eq.3) then icount=icount+1 read(93, 821) (ngp34(icount,m),m=1,3), (dr34(icount,m),m=1,3) end if end do end do numngp34=icount c c Initial state: c if( lrstrt .ne. 0 ) then c restart read(8) nts,tc,uc1,uc2,uc3, ub1, ub2, ub3, ub5 write(*,*) 'nts= ', nts close(8) do i=1,nphi+2 do k=1,nnu+2 uc5b(i,k,1)=ub5(i,k) uc5b(i,k,2)=0. uc5b(i,k,3)=0. end do end do else c initialization nts = 0 tc = 0.0 write(*,*) 'error! setup by running WebMHDinit.f ... stop' stop 1102 format(3f10.5,i3,4e16.6) 1103 format(3f10.5,i3,3e16.6) end if c *************** end of setting up initial condition **************** c *************** end of setting up initial condition **************** istop = 0 call date_and_time(real_clock(1),real_clock(2)) print *, real_clock(1), real_clock(2) call setg5b(g5b,nphi,nnu,dphi,dnu,aa,amu0) ifort=10 do 1001 nt = nts+1, ntot do 1000 io = 1, mt c(i) c set dt c if(io.eq.1) then anumax=anu if(eta.gt.anu) anumax=eta igrid=1 call setdt(g1,ig1,uc1,mx1,my1,mz1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,dtime1,anumax,cfl) igrid=2 call setdt(g2,ig2,uc2,mx2,my2,mz2, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,dtime2,anumax,cfl) igrid=3 call setdt(g3,ig3,uc3,mx3,my3,mz3, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,dtime3,anumax,cfl) dtime=amin1(amin1(dtime1,dtime2), dtime3) dtime=dtime/sqrt(3.) dtime=amin1(dtime, 2.*3.1415926/50.) c c dtime=dtime unstable c dtime=dtime/2./1. if( ( tc + dtime ) .ge. tf ) then dtime = tf - tc istop = 1 endif cc cc write(9,*) 'nt,dtime=',nt,dtime end if c (ii) induction c for grid 1 igrid=1 call induction1(uc1, ub1, g1,rhsb1,ig1,mx1,my1,mz1,dr1,ds1,dt1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,io) c for grid 2 igrid=2 call induction2(uc2, ub2,g2, trans2,rhsb2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,io) c for grid 3 igrid=3 call induction2(uc3, ub3,g3, trans3,rhsb3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,io) c call rk for grid 1,2, and 3 igrid=1 call rk(ub1,rhsb1,ig1,mx1,my1,mz1,mt,io,dtime, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid) igrid=2 call rk(ub2,rhsb2,ig2,mx2,my2,mz2,mt,io,dtime, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 call rk(ub3,rhsb3,ig3,mx3,my3,mz3,mt,io,dtime, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c c c interpolating data among grids and set bndry conditions c c c points on grid 2 from grid 3 igrid=-3 call interpv2(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c find B on surface using divB=0 igrid=2 igridi=-3 call bndrybaa(ub2,ub2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,igridi) igrid=2 call bndrybbb(ub2,ub2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 igridi=-2 call bndrybaa(ub3,ub3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,igridi) igrid=3 call bndrybbb(ub3,ub3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c points on grid 2 from grid 3 igrid=-3 call interpv(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c cccc cc (2) find Br and Bth at R on G4 c this section OK igrid=-2 call interpBr4R(ub4, g4, ig4, mx4,my4, igrid, 1 nxs4,nxe4,nys4,nye4, ngp42b, dr42b, 1 numngp42b, ub2,g2,mx2,my2,mz2, dr2,ds2,dt2,mngp,xi0) igrid=-3 call interpBr4R(ub4, g4, ig4, mx4,my4, igrid, 1 nxs4,nxe4,nys4,nye4, ngp43b, dr43b, 1 numngp43b, ub3,g3,mx3,my3,mz3, dr3,ds3,dt3,mngp,xi0) ccc ccc test to have integral of B_normal=0 c part (1) k=nze2 do i=1,nx2 do j=1,ny2 do m=1,3 eb2(i,j,m)=ub2(i,j,k,m) end do end do end do k=nze3 do i=1,nx3 do j=1,ny3 do m=1,3 eb3(i,j,m)=ub3(i,j,k,m) end do end do end do c points on grid 2 from grid 3 igrid=-3 call interpE2(Eb2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1,ngp23, dr23, 1 numngp23, Eb3,mx3,my3,mz3, dr3,ds3,dt3,mngp,io) c grid 3 from grid 2 igrid=-2 call interpE2(Eb3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1,ngp32, dr32, 1 numngp32, Eb2,mx2,my2,mz2, dr2,ds2,dt2,mngp,io) c move E to UC5b c bndry of G5 from grid 2 and from grid3 igrid = 2 call interpE5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, Eb2, mx2, my2, mz2, dr2, ds2, dt2, xi0, aa, io) c from grid 3 igrid = 3 call interpE5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, Eb3, mx3, my3, mz3, dr3, ds3, dt3, xi0, aa, io) c call setg5b(g5b,nphi,nnu,dphi,dnu,aa,amu0) call uc5bmu(uc5b, nphi, nnu, dphi,dmu, dnu, aa, amu0) c write(*,*) 'after induction2' call integral5b(uc5b, nphi, nnu, dphi,dmu, dnu, aa, amu0, 1 sum, sumabs, vol) c part(2) modify ub4 sum=sum/vol call modify(ub4,mx4,my4,sum) cccc c (3) get dbxi/dxi, bth, bphi, Dxi, Dth, and Dphi c this program OK with dipole in either x or z direction call bbndry1(ub4,mx4,my4,wsave,mwsave) c (4) from Br Bth and Bphi at R find Bx By Bz in Grid 2 and 3 c grid 2 igrid=2 c dr4 not used in the subroutine dr4=0. call interpB2(ub2, ig2, mx2,my2,mz2, igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2, 1 ngp24, dr24, numngp24, ub4,g4,mx4,my4,dr4,ds4,mngp,xi0) c grid 3 igrid=3 call interpB2(ub3, ig3, mx3,my3,mz3, igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3, 1 ngp34, dr34, numngp34, ub4,g4,mx4,my4,dr4,ds4,mngp,xi0) c c c interpolating data among grids and set bndry conditions c c c points on grid 2 from grid 3 igrid=-3 call interpv2(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c interpolating points on G1, obtaining from G2 igrid=-2 call interpv1(ub1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp12, dr12, numngp12, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c interpolating points on G1, obtaining from G3 igrid=-3 call interpv1(ub1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp13, dr13, numngp13, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c points on grid 2 from grid 1 igrid=-1 call interpv1(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2, 1 ngp21, dr21, numngp21, ub1,mx1,my1,mz1, dr1,ds1,dt1,mngp) c points on grid 2 from grid 3 igrid=-3 call interpv2(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 1 igrid=-1 call interpv1(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3, 1 ngp31, dr31, numngp31, ub1,mx1,my1,mz1, dr1,ds1,dt1,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c find B at the guard points (nze2+1 and nze3+1) by extrapolation c--- igrid=2 call getBbndry(ub2,ig2,mx2,my2,mz2,dr2,ds2,dt2, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, igrid) igrid=3 call getBbndry(ub3,ig3,mx3,my3,mz3,dr3,ds3,dt3, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, igrid) c points on grid 2 from grid 3 igrid=-3 call interpv2(ub2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, ub3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(ub3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, ub2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c fluid equation c for grid 1 igrid=1 call motion1(uc1,g1, rhs1,ig1,mx1,my1,mz1,dr1,ds1,dt1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,io) c for grid 2 igrid=2 call motion2(uc2,g2, trans2,rhs2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,io) c for grid 3 igrid=3 call motion2(uc3,g3, trans3,rhs3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,io) c solve pressure eq c interpolating data among grids and set bndry conditions c c c points on grid 2 from grid 3 igrid=-3 call interpRHS2(rhs2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1,ngp23, dr23, 1 numngp23, rhs3,mx3,my3,mz3, dr3,ds3,dt3,mngp,io) c grid 3 from grid 2 igrid=-2 call interpRHS2(rhs3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1,ngp32, dr32, 1 numngp32, rhs2,mx2,my2,mz2, dr2,ds2,dt2,mngp,io) c interpolating points on G1, obtaining from G2 igrid=-2 call interpRHS1(rhs1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp12, dr12, numngp12, rhs2,mx2,my2,mz2, dr2,ds2,dt2,mngp,io) c interpolating points on G1, obtaining from G3 igrid=-3 call interpRHS1(rhs1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp13, dr13, numngp13, rhs3,mx3,my3,mz3, dr3,ds3,dt3,mngp,io) c points on grid 2 from grid 1 igrid=-1 call interpRHS1(rhs2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2, 1 ngp21, dr21, numngp21, rhs1,mx1,my1,mz1, dr1,ds1,dt1,mngp,io) c points on grid 2 from grid 3 igrid=-3 call interpRHS2(rhs2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, rhs3,mx3,my3,mz3, dr3,ds3,dt3,mngp,io) c grid 3 from grid 1 igrid=-1 call interpRHS1(rhs3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3, 1 ngp31, dr31, numngp31, rhs1,mx1,my1,mz1, dr1,ds1,dt1,mngp,io) c grid 3 from grid 2 igrid=-2 call interpRHS2(rhs3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, rhs2,mx2,my2,mz2, dr2,ds2,dt2,mngp,io) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) c modifications: (a) find u* on G5 and its bndry c (b) on G5 find div u* and solve Laplacian(p)=div u* c subject the bndry condition Grad p= u*_mu c (c) find grad p and get u(new)= u*- grad p c (d) find u(new) on G1, G2, and G3 c igrid=1 call interpRHS5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, rhs1, mx1, my1, mz1, dr1, ds1, dt1, io) c from grid 2 igrid=2 call interpRHS5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, rhs2, mx2, my2, mz2, dr2, ds2, dt2, io) c from grid 3 igrid=3 call interpRHS5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, rhs3, mx3, my3, mz3, dr3, ds3, dt3, io) c bndry of G5 from grid 2 and from grid3 igrid = 2 call interpRHS5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, rhs2, mx2, my2, mz2, dr2, ds2, dt2, xi0, aa, io) c from grid 3 igrid = 3 call interpRHS5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, rhs3, mx3, my3, mz3, dr3, ds3, dt3, xi0, aa, io) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) call bndryuc5b(uc5b, nphi, nmuh, nnu) ccc c move uc5 and uc5b to uc5 c call getuc5(uc5, uc5b, nphi, nmuh, nnu) c c Compute div u on G5 call divu5(uc5, uc5p, nphi, nmuh, nnu, dphi,dmu,dnu,aa) c double the grid call doublediv(uc5p, uc5pdouble, nphi, nmu, nnu) c set bndry condition on UC5b call Vn5mu0(uc5b, uc5bndry, nphi, nnu, aphi, aaanu, amu0,aa) c (b3) find Vn at negative mu0 (amu=-amu0) call Vn5nmu0(uc5bndry, nphi, nnu) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) call PoisSpheroid(uc5pdouble, uc5bndry, bndrynu, bndrymu, 1 bndrynumu, aphi, amu, aaanu, nphi, nmu, nnu, aa, dphi, dmu, dnu) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) cc move to uc5pex call reducep(uc5pex, uc5pdouble, bndrynu, bndrymu, 1 bndrynumu, nphi, nmu, nnu) c move to grid 1,2 and 3 c (d2) get p on grid 2, 3, and 1 c grid 1 igrid=1 call interpPf5(uc1, ig1, mx1,my1,mz1, igrid, nxs1,nxe1,nys1,nye1, 1 nzs1,nze1, ngp15, drngp15, uc5pex, nphi+2,nmuh+2,nnu+2, 1 dphi, dmu, dnu) c grid 2 igrid=2 call interpPf5(uc2, ig2, mx2,my2,mz2, igrid, nxs2,nxe2,nys2,nye2, 1 nzs2,nze2+1, ngp25, drngp25, uc5pex, nphi+2,nmuh+2,nnu+2, 1 dphi, dmu, dnu) c grid 3 igrid=3 call interpPf5(uc3, ig3, mx3,my3,mz3, igrid, nxs3,nxe3,nys3,nye3, 1 nzs3,nze3+1, ngp35, drngp35, uc5pex, nphi+2,nmuh+2,nnu+2, 1 dphi, dmu, dnu) c v at new step: v=v*-grad(p) c for grid 1 igrid=1 call newRHS1(rhs1, uc1,g1, ig1,mx1,my1,mz1,dr1,ds1,dt1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,io) c for grid 2 igrid=2 call newRHS2(rhs2,uc2,uc2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,io) c for grid 3 igrid=3 call newRHS2(rhs3,uc3,uc3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,io) c c c igrid=1 call rk(uc1,rhs1,ig1,mx1,my1,mz1,mt,io,dtime, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid) igrid=2 call rk(uc2,rhs2,ig2,mx2,my2,mz2,mt,io,dtime, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 call rk(uc3,rhs3,ig3,mx3,my3,mz3,mt,io,dtime, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c c interpolating data among grids and set bndry conditions c c c points on grid 2 from grid 3 igrid=-3 call interpv2(uc2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, uc3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(uc3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, uc2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c interpolating points on G1, obtaining from G2 igrid=-2 call interpv1(uc1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp12, dr12, numngp12, uc2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c interpolating points on G1, obtaining from G3 igrid=-3 call interpv1(uc1, ig1,mx1,my1,mz1,igrid, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1, 1 ngp13, dr13, numngp13, uc3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c points on grid 2 from grid 1 igrid=-1 call interpv1(uc2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2, 1 ngp21, dr21, numngp21, uc1,mx1,my1,mz1, dr1,ds1,dt1,mngp) c points on grid 2 from grid 3 igrid=-3 call interpv2(uc2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, uc3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 1 igrid=-1 call interpv1(uc3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3, 1 ngp31, dr31, numngp31, uc1,mx1,my1,mz1, dr1,ds1,dt1,mngp) c grid 3 from grid 2 igrid=-2 call interpv2(uc3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, uc2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c c set guard values for v c c c igrid=2 igridi=-3 call bndryvaa(uc2,uc2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid,igridi) igrid=2 call bndryvbb(uc2,uc2bndry,g2, trans2,ig2,mx2,my2,mz2, 1 dr2,ds2,dt2, nxs2,nxe2,nys2,nye2,nzs2,nze2,igrid) igrid=3 igridi=-2 call bndryvaa(uc3,uc3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid,igridi) igrid=3 call bndryvbb(uc3,uc3bndry,g3, trans3,ig3,mx3,my3,mz3, 1 dr3,ds3,dt3, nxs3,nxe3,nys3,nye3,nzs3,nze3,igrid) c points on grid 2 from grid 3 igrid=-3 call interpv(uc2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1, 1 ngp23, dr23, numngp23, uc3,mx3,my3,mz3, dr3,ds3,dt3,mngp) c grid 3 from grid 2 igrid=-2 call interpv(uc3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1, 1 ngp32, dr32, numngp32, uc2,mx2,my2,mz2, dr2,ds2,dt2,mngp) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) 1000 continue tc = tc + dtime 1101 format(3e17.8,i5,e17.8) c energy igrid=1 call energy(uc1,ig1,g1,mx1,my1,mz1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,eke1) igrid=2 call energy(uc2,ig2,g2,mx2,my2,mz2, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1,igrid,eke2) igrid=3 call energy(uc3,ig3,g3,mx3,my3,mz3, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1,igrid,eke3) igrid=1 call energy(ub1,ig1,g1,mx1,my1,mz1, 1 nxs1,nxe1,nys1,nye1,nzs1,nze1,igrid,ebe1) igrid=2 call energy(ub2,ig2,g2,mx2,my2,mz2, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1,igrid,ebe2) igrid=3 call energy(ub3,ig3,g3,mx3,my3,mz3, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1,igrid,ebe3) write(61,1091) nt,tc, eke1,eke2,eke3,ebe1,ebe2,ebe3 write(*,1091) nt,tc, eke1,eke2,eke3,ebe1,ebe2,ebe3 1091 format(i7,7e15.7) 1092 format(i7,3e15.7) if(mod(nt,10).eq.0) then igrid=1 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, uc1, mx1, my1, mz1, dr1, ds1, dt1) c from grid 2 igrid=2 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, uc2, mx2, my2, mz2, dr2, ds2, dt2) c from grid 3 igrid=3 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, uc3, mx3, my3, mz3, dr3, ds3, dt3) call energy5(uc5, nphi,nmuh,nnu,dmu,dnu,dphi,aa, eke51,eke52) call energyV5(uc5, nphi,nmuh,nnu,dmu,dnu,dphi,aa, eke51t,eke52t 1 , eke510, eke520) c for B igrid=1 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, ub1, mx1, my1, mz1, dr1, ds1, dt1) c from grid 2 igrid=2 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, ub2, mx2, my2, mz2, dr2, ds2, dt2) c from grid 3 igrid=3 call interpv5(uc5, ig5, ngp5, drngp5, nphi, nmuh, nnu, 1 igrid, ub3, mx3, my3, mz3, dr3, ds3, dt3) call energy5(uc5, nphi,nmuh,nnu,dmu,dnu,dphi,aa, ebe51,ebe52) write(*, '(i7,5e15.7)') nt, tc, eke51,eke52,ebe51, ebe52 write(63,'(i7,5e15.7)') nt, tc, eke51,eke52,ebe51, ebe52 write(64,'(i7,5e15.7)') nt, tc, eke51t,eke52t,eke510, eke520 end if if(mod(nt,50).eq.0) then k=nze2 do i=1,nx2 do j=1,ny2 do m=1,3 eb2(i,j,m)=ub2(i,j,k,m) end do end do end do k=nze3 do i=1,nx3 do j=1,ny3 do m=1,3 eb3(i,j,m)=ub3(i,j,k,m) end do end do end do c points on grid 2 from grid 3 igrid=-3 call interpE2(Eb2,ig2, mx2, my2, mz2,igrid, 1 nxs2,nxe2,nys2,nye2,nzs2,nze2+1,ngp23, dr23, 1 numngp23, Eb3,mx3,my3,mz3, dr3,ds3,dt3,mngp,io) c grid 3 from grid 2 igrid=-2 call interpE2(Eb3,ig3, mx3, my3, mz3,igrid, 1 nxs3,nxe3,nys3,nye3,nzs3,nze3+1,ngp32, dr32, 1 numngp32, Eb2,mx2,my2,mz2, dr2,ds2,dt2,mngp,io) c move E to UC5b c bndry of G5 from grid 2 and from grid3 igrid = 2 call interpE5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, Eb2, mx2, my2, mz2, dr2, ds2, dt2, xi0, aa, io) c from grid 3 igrid = 3 call interpE5b(uc5b, ig5b, ngp5b, drngp5b, nphi, nnu, 1 igrid, Eb3, mx3, my3, mz3, dr3, ds3, dt3, xi0, aa, io) call uc5bmu(uc5b, nphi, nnu, dphi,dmu, dnu, aa, amu0) c write(*,*) 'after induction2' call integral5b(uc5b, nphi, nnu, dphi,dmu, dnu, aa, amu0, 1 sum, sumabs, vol) write(62,1092) nt,tc, sum, sumabs write(*,1092) nt,tc, sum, sumabs end if if( istop.eq.1 ) goto 1002 1001 continue *****678*************** end time evolution *************************** 1002 continue call date_and_time(real_clock(1),real_clock(2)) print *, real_clock(1), real_clock(2) 1004 continue 9991 format(3i4,4e13.5) write(99) nt-1,tc,uc1,uc2,uc3, ub1, ub2, ub3, ub5 stop end subroutine setg5b(g5b,nphi, nnu, dphi, dnu,aa, amu0) dimension g5b(nphi+2, nnu+2, 3) aamu= amu0 sinhmu=sinh(aamu) coshmu=cosh(aamu) c now compute -curl(E)_mu do 200 i = 1, nphi+2 pphi=(i-2) * dphi cosphi=cos(pphi) sinphi=sin(pphi) do 200 k = 1, nnu+2 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) g5b(i,k,1)=aa*coshmu*sinnu*cosphi g5b(i,k,2)=aa*coshmu*sinnu*sinphi g5b(i,k,3)=aa*sinhmu*cosnu 200 continue return end subroutine rk(uc,rhs,ig,mx,my,mz,mt,io,dt, 1 nxs,nxe,nys,nye,nzs,nze,igrid) parameter( mtm=4, mn=3) dimension uc(mx,my,mz,mn+1),rhs(mx,my,mz,mn,mtm),ig(mx,my,mz) if( io.lt.1 .or. io.gt.mt ) then write(*,*) 'Check the RK iteration controller "io"!' endif * mt = 2 ---> 2nd order Runge-Kutta (TVD) if(mt.eq.2) then cc cc nnn=0 cc if( io.eq.1 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + dt * rhs(i,j,k,m,1) enddo end if enddo enddo end do else do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + 0.5 * dt * (-rhs(i,j,k,m,1) & + rhs(i,j,k,m,2)) cc cc if(nnn.le.20) then cc write(9,*) i,j,k,m,uc(i,j,k,m),dt, rhs(i,j,k,m,2) cc nnn=nnn+1 cc end if cc enddo end if enddo enddo end do endif endif * mt = 3 ---> 3rd order Runge-Kutta (TVD) if(mt.eq.3) then if( io.eq.1 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + dt * rhs(i,j,k,m,1) enddo end if enddo enddo end do else if( io.eq.2 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + 0.25 * dt * (-3.*rhs(i,j,k,m,1) & + rhs(i,j,k,m,2)) enddo end if enddo end do enddo else do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + dt * (-rhs(i,j,k,m,1) & - rhs(i,j,k,m,2) + 8.*rhs(i,j,k,m,3) ) / 12. enddo end if enddo end do enddo endif endif * mt = 4 ---> 4th order Runge-Kutta (non-TVD) if(mt.eq.4) then if( io.eq.1 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + 0.5 * dt * rhs(i,j,k,m,1) enddo end if enddo end do enddo else if( io.eq.2 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + 0.5 * dt * (-rhs(i,j,k,m,1) & + rhs(i,j,k,m,2)) enddo end if end do enddo enddo else if( io.eq.3 ) then do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + 0.5 * dt * ( -rhs(i,j,k,m,2) & + 2.*rhs(i,j,k,m,3) ) enddo end if enddo end do enddo else do k = nzs, nze do j = nys, nye do i = nxs, nxe if(ig(i,j,k).eq.igrid) then do m = 1, mn uc(i,j,k,m) = uc(i,j,k,m) + dt * ( rhs(i,j,k,m,1) & + 2.*rhs(i,j,k,m,2) & - 4.*rhs(i,j,k,m,3) + rhs(i,j,k,m,4) ) / 6. enddo end if end do enddo enddo endif endif return end subroutine integral5b(uc5b,nphi, nnu, dphi,dmu, dnu,aa, amu0, 1 sum, sumabs, vol) dimension uc5b(nphi+2, nnu+2, 3) vol=0. sum=0. sumabs=0. aamu= amu0 sinhmu=sinh(aamu) coshmu=cosh(aamu) c now compute -curl(E)_mu do 200 i = 2, nphi+1 pphi=(i-2) * dphi do 200 k = 2, nnu+1 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) vol=vol+aa**2*coshmu*sinnu*sqrt(sinhmu**2+cosnu**2) sum=sum+aa**2*coshmu*sinnu*sqrt(sinhmu**2+cosnu**2)*uc5b(i,k,1) sumabs=sumabs 1 +aa**2*coshmu*sinnu*sqrt(sinhmu**2+cosnu**2)*abs(uc5b(i,k,1)) 200 continue c write(*,*) 'sum, sumabs=', sum, sumabs return end subroutine newRHS2(rhs,uc,ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io) parameter (mtm=4, mn=4) dimension rhs(mx,my,mz,3,mtm) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3), d2u(3) dimension ucbndry(mx,my,3,9) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c for grid 2 do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points c c drdx(1,1)=dr/dx, drdx(1,2)=dr/dy, drdx(1,3)=dr/dz, c drdx(2,1)=ds/dx, drdx(2,2)=ds/dy, drdx(2,3)=ds/dz, c drdx(3,1)=dt/dx, drdx(3,2)=dt/dy, drdx(3,3)=dt/dz. do m=1,3 do n=1,3 drdx(m,n)=trans(i,j,k,m,n) end do end do c dpdr(1)=dp/dr, dpdr(2)=dp/ds, dpdr(3)=dp/dt. m=4 dpdr(1)=(uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dr) dpdr(2)=(uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*ds) dpdr(3)=(uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dt) c c dpdx(1)=dp/dx, dpdx(2)=dp/dy, dpdx(3)=dp/dz do n=1,3 dpdx(n)=dpdr(1)*drdx(1,n)+dpdr(2)*drdx(2,n)+ dpdr(3)*drdx(3,n) end do c rhs(i,j,k,1,io) = rhs(i,j,k,1,io)- dpdx(1) rhs(i,j,k,2,io) = rhs(i,j,k,2,io)- dpdx(2) rhs(i,j,k,3,io) = rhs(i,j,k,3,io)- dpdx(3) end if 200 continue c on bndry c cL=sqrt(ca**2-cb**2) k = nze do 300 i = nxs, nxe do 300 j = nys, nye if (ig(i,j,k).eq.igrid) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi c coshksi=ca/cL c sinhksi=cb/cL c costh=z/cb c sinth=sqrt(x*x+y*y)/ca c if(sinth.gt.1.e-10) then c sinphi=y/(ca*sinth) c cosphi=x/(ca*sinth) c else c sinphi=0. c cosphi=1. c end if c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,2,4) sinhksi= ucbndry(i,j,2,5) costh= ucbndry(i,j,2,6) sinth= ucbndry(i,j,2,7) cosphi= ucbndry(i,j,2,8) sinphi= ucbndry(i,j,2,9) c gg=1./sqrt(costh**2+sinhksi**2) c set vksi=0 (bndry condition) vksi=0. vth = gg*( (rhs(i,j,k,1,io)* cosphi + rhs(i,j,k,2,io)* sinphi) 1 * coshksi* costh 1 - rhs(i,j,k,3,io)* sinhksi* sinth ) vphi = -rhs(i,j,k,1,io)* sinphi + rhs(i,j,k,2,io)* cosphi c c now convert to vx, vy, and vz c rhs(i,j,k,1,io) = gg*cosphi*(vksi*sinhksi*sinth+vth*coshksi*costh) 1 -sinphi*vphi rhs(i,j,k,2,io) = gg*sinphi*(vksi*sinhksi*sinth+vth*coshksi*costh) 1 +cosphi*vphi rhs(i,j,k,3,io) = gg*(coshksi*costh*vksi-sinhksi*sinth*vth) end if 300 continue return end subroutine motion2(uc,g,trans,rhs,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io, cost, sint) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension rhs(mx,my,mz,mn-1,mtm), g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3), d2u(3) dimension duudx(3,3), duudr(3,3,3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c for grid 2 c consta=2.* ca**2*omegap/ (ca**2-cb**2) c constb=2.* cb**2*omegap/ (ca**2-cb**2) cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) c vx=uc(i,j,k,1) c vy=uc(i,j,k,2) c vz=uc(i,j,k,3) c c drdx(1,1)=dr/dx, drdx(1,2)=dr/dy, drdx(1,3)=dr/dz, c drdx(2,1)=ds/dx, drdx(2,2)=ds/dy, drdx(2,3)=ds/dz, c drdx(3,1)=dt/dx, drdx(3,2)=dt/dy, drdx(3,3)=dt/dz. do m=1,3 do n=1,3 drdx(m,n)=trans(i,j,k,m,n) end do end do c c dudr(1,1)=dux/dr, dudr(1,2)=dux/ds, dudt(1,3)=dux/dt, c dudr(2,1)=duy/dr, dudr(2,2)=duy/ds, dudt(2,3)=duy/dt, c dudr(3,1)=duz/dr, dudr(3,2)=duz/ds, dudt(3,3)=duz/dt. do m=1,3 dudr(m,1)=(uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dr) dudr(m,2)=(uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*ds) dudr(m,3)=(uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dt) end do c c c duudr(1,1,1)=d(ux ux)/dr, duudr(1,1,2)=d(ux ux)/ds, duudr(1,1,3)=d(ux ux)/dt c duudr(1,2,1)=d(ux uy)/dr, duudr(1,2,2)=d(ux uy)/ds, duudr(1,2,3)=d(ux uy)/dt c duudr(1,3,1)=d(ux uz)/dr, duudr(1,3,2)=d(ux uz)/ds, duudr(1,3,3)=d(ux uz)/dt c duudr(2,2,1)=d(uy uy)/dr, duudr(2,2,2)=d(uy uy)/ds, duudr(2,2,3)=d(uy uy)/dt c duudr(2,3,1)=d(uy uz)/dr, duudr(2,3,2)=d(uy uz)/ds, duudr(2,3,3)=d(uy uz)/dt c duudr(3,3,1)=d(uz uz)/dr, duudr(3,3,2)=d(uz uz)/ds, duudr(3,3,3)=d(uz uz)/dt c duudr(2,1,m)=duudr(1,2,m) c duudr(3,1,m)=duudr(1,3,m) c duudr(3,2,m)=duudr(2,3,m) c c the following routine can be simplified because of duudr(2,1,:)=duudr(2,1,:) etc do n=1,3 do m=1,3 duudr(m,n,1)=(uc(i+1,j,k,m)*uc(i+1,j,k,n) 1 -uc(i-1,j,k,m)*uc(i-1,j,k,n))/(2.* dr) duudr(m,n,2)=(uc(i,j+1,k,m)*uc(i,j+1,k,n) 1 -uc(i,j-1,k,m)*uc(i,j-1,k,n))/(2.* ds) duudr(m,n,3)=(uc(i,j,k+1,m)*uc(i,j,k+1,n) 1 -uc(i,j,k-1,m)*uc(i,j,k-1,n))/(2.* dt) end do end do c c duudx(1,1)=d(ux ux)/dx, duudx(1,2)=d(uy ux)/dy, duudx(1,3)=d(uz ux)/dz c duudx(2,1)=d(ux uy)/dx, duudx(2,2)=d(uy uy)/dy, duudx(2,3)=d(uz uy)/dz c duudx(3,1)=d(ux uz)/dx, duudx(3,2)=d(uy uz)/dy, duudx(3,3)=d(uz u3)/dz do n=1,3 do m=1,3 duudx(m,n)=duudr(n,m,1)*drdx(1,n)+duudr(n,m,2)*drdx(2,n) 1 +duudr(n,m,3)*drdx(3,n) end do end do c d2uxdr(1,1,1)=d2ux/dr/dr, d2uxdr(1,1,2)=d2ux/dr/ds, c d2uxdr(1,1,3)=d2ux/dr/dt, c d2uxdr(1,2,1)=d2ux/ds/dr, d2uxdr(1,2,2)=d2ux/ds/ds, c d2uxdr(1,2,3)=d2ux/ds/dt, c d2uxdr(1,3,1)=d2ux/dt/dr, d2uxdr(1,3,2)=d2ux/dt/ds, c d2uxdr(1,3,3)=d2ux/dt/dt, c d2uxdr(2,1,1)=d2uy/dr/dr; d2uxdr(3,1,1)=d2uz/dr/dr. do m=1,3 d2uxdr(m,1,1)=(uc(i+1,j,k,m)-2.*uc(i,j,k,m)+ uc(i-1,j,k,m))/dr**2 d2uxdr(m,1,2)=(uc(i+1,j+1,k,m)-uc(i+1,j-1,k,m) 1 -uc(i-1,j+1,k,m)+uc(i-1,j-1,k,m))/(4.*dr*ds) d2uxdr(m,1,3)=(uc(i+1,j,k+1,m)-uc(i+1,j,k-1,m) 1 -uc(i-1,j,k+1,m)+uc(i-1,j,k-1,m))/(4.*dr*dt) d2uxdr(m,2,2)=(uc(i,j+1,k,m)-2.*uc(i,j,k,m)+ uc(i,j-1,k,m))/ds**2 d2uxdr(m,2,3)=(uc(i,j+1,k+1,m)-uc(i,j+1,k-1,m) 1 -uc(i,j-1,k+1,m)+uc(i,j-1,k-1,m))/(4.*ds*dt) d2uxdr(m,3,3)=(uc(i,j,k+1,m)-2.*uc(i,j,k,m)+ uc(i,j,k-1,m))/dt**2 d2uxdr(m,2,1)=d2uxdr(m,1,2) d2uxdr(m,3,1)=d2uxdr(m,1,3) d2uxdr(m,3,2)=d2uxdr(m,2,3) end do c c c drxdr(1,1,1)=d(drdx)/dr, drxdr(1,1,2)=d(drdx)/ds, drxdr(1,1,3)=d(drdx)/dt, c drxdr(2,1,1)=d(dsdx)/dr, drxdr(2,1,2)=d(dsdx)/ds, drxdr(2,1,3)=d(dsdx)/dt, c drxdr(3,1,1)=d(dtdx)/dr, drxdr(3,1,2)=d(dtdx)/ds, drxdr(3,1,3)=d(dsdx)/dt. c c drxdr(1,2,1)=d(drdy)/dr, drxdr(1,2,2)=d(drdy)/ds, drxdr(1,2,3)=d(drdy)/dt, c drxdr(2,2,1)=d(dsdy)/dr, drxdr(2,2,2)=d(dsdy)/ds, drxdr(2,2,3)=d(dsdy)/dt, c drxdr(3,2,1)=d(dtdy)/dr, drxdr(3,2,2)=d(dtdy)/ds, drxdr(3,2,3)=d(dtdy)/dt. c c drxdr(1,3,1)=d(drdz)/dr, drxdr(1,3,2)=d(drdz)/ds, drxdr(1,3,3)=d(drdz)/dt, c drxdr(2,3,1)=d(dsdz)/dr, drxdr(2,3,2)=d(dsdz)/ds, drxdr(2,3,3)=d(dsdz)/dt, c drxdr(3,3,1)=d(dtdz)/dr, drxdr(3,3,2)=d(dtdz)/ds, drxdr(3,3,3)=d(dtdz)/dt. c do m=1,3 do n=1,3 drxdr(m,n,1)=(trans(i+1,j,k,m,n)- trans(i-1,j,k,m,n))/(2.*dr) drxdr(m,n,2)=(trans(i,j+1,k,m,n)- trans(i,j-1,k,m,n))/(2.*ds) drxdr(m,n,3)=(trans(i,j,k+1,m,n)- trans(i,j,k-1,m,n))/(2.*dt) end do end do c c dudx(1,1)=dux/dx, dudx(1,2)=dux/dy dudx(1,3)=dux/dz c dudx(2,1)=duy/dx, dudx(2,2)=duy/dy dudx(2,3)=duy/dz c dudx(3,1)=duz/dx, dudx(3,2)=duz/dy dudx(3,3)=duy/dz do m=1,3 do n=1,3 dudx(m,n)=dudr(m,1)*drdx(1,n)+dudr(m,2)*drdx(2,n) 1 + dudr(m,3)*drdx(3,n) end do end do c c Laplacian(Ux): d2Uxdxx+d2Uxdyy+d2Uxdzz do nn=1,3 d2u(nn)=0 do n=1,3 do mm=1,3 do m=1,3 d2u(nn)=d2u(nn)+d2uxdr(nn,mm,m)*drdx(mm,n)*drdx(m,n) 1 +drxdr(m,n,mm)*drdx(mm,n)*dudr(nn,m) end do end do end do end do rhs(i,j,k,1,io) = c -d(vx vx)/dx - d(vy vx)/dy - d(vz vx)/dz 1 -duudx(1,1)-duudx(1,2)-duudx(1,3) 1 + y*dudx(1,1)-(x-oetamu*z)*dudx(1,2) - amu*y*dudx(1,3) 1 + uc(i,j,k,2) + anu*d2u(1) rhs(i,j,k,2,io) = c -d(vx vy)/dx - d(vy vy)/dy - d(vz vy)/dz 1 -duudx(2,1)-duudx(2,2)-duudx(2,3) 1 + y*dudx(2,1)-(x-oetamu*z)*dudx(2,2) - amu*y*dudx(2,3) 1 - uc(i,j,k,1) + (oetamu+2.*omegap)*uc(i,j,k,3) + anu*d2u(2) rhs(i,j,k,3,io) = c -d(vx vz)/dx - d(vy vz)/dy - d(vz vz)/dz 1 -duudx(3,1)-duudx(3,2)-duudx(3,3) 1 + y*dudx(3,1)-(x-oetamu*z)*dudx(3,2) - amu*y*dudx(3,3) 1 - (amu+2.*omegap)*uc(i,j,k,2) + anu*d2u(3) end if 200 continue return end subroutine setdt(g1,ig,uc,mx,my,mz 1 ,nxs,nxe,nys,nye,nzs,nze,igrid,dt,anumax,cfl) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), ig(mx,my,mz), g1(mx,my,mz,3) common /var1/omega,omegap, omegapx,omegapz,ca,cb,anu,eta,factor cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu dt=1.e20 do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then vx0 = -g1(i,j,k,2) vy0 = g1(i,j,k,1) -oetamu *g1(i,j,k,3) vz0 = amu * g1(i,j,k,2) dr=sqrt((g1(i+1,j+1,k+1,1)-g1(i,j,k,1))**2 1 +(g1(i+1,j+1,k+1,2)-g1(i,j,k,2))**2 1 +(g1(i+1,j+1,k+1,3)-g1(i,j,k,3))**2) v=sqrt((uc(i,j,k,1)+vx0)**2+(uc(i,j,k,2)+vy0)**2 1 +(uc(i,j,k,3)+vz0)**2) if (v.ne. 0.) dt=amin1(dt,dr/v*cfl) dt=amin1(dt,0.2*dr**2/anumax) c if(i.ge.11 .and. j.ge.10 .and. k.ge.18) then c write(*,*) i,j,k,dt,dr,v c end if end if 200 continue return end subroutine newRHS1(rhs,uc,g,ig,mx,my,mz,dx,dy,dz, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io) parameter (mtm=4, mn=4) dimension rhs(mx,my,mz,3,mtm),uc(mx,my,mz,mn), 1 ig(mx,my,mz), g(mx,my,mz,3) dimension dudx(3,3), dpdx(3), d2u(3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c for grid 1 consta=2.* ca**2*omegap/ (ca**2-cb**2) constb=2.* cb**2*omegap/ (ca**2-cb**2) do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points m=4 rhs(i,j,k,1,io)=rhs(i,j,k,1,io) 1 - (uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dx) rhs(i,j,k,2,io)=rhs(i,j,k,2,io) 1 - (uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*dy) rhs(i,j,k,3,io)=rhs(i,j,k,3,io) 1 - (uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dz) end if 200 continue return end subroutine motion1(uc,g,rhs,ig,mx,my,mz,dx,dy,dz, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io, cost, sint) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), ig(mx,my,mz), g(mx,my,mz,3) dimension rhs(mx,my,mz,mn-1,mtm) dimension dudx(3,3), dpdx(3), d2u(3), duudx(3,3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c for grid 1 c consta=2.* ca**2*omegap/ (ca**2-cb**2) c constb=2.* cb**2*omegap/ (ca**2-cb**2) cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) c vx=uc(i,j,k,1) c vy=uc(i,j,k,2) c vz=uc(i,j,k,3) c c duudx(1,1)=d(ux ux)/dx, duudx(1,2)=d(uy ux)/dy, duudx(1,3)=d(uz ux)/dz c duudx(2,1)=d(ux uy)/dx, duudx(2,2)=d(uy uy)/dy, duudx(2,3)=d(uz uy)/dz c duudx(3,1)=d(ux uz)/dx, duudx(3,2)=d(uy uz)/dy, duudx(3,3)=d(uz uz)/dz do m=1,3 duudx(m,1)= (uc(i+1,j,k,1)*uc(i+1,j,k,m) 1 -uc(i-1,j,k,1)*uc(i-1,j,k,m))/(2.*dx) duudx(m,2)= (uc(i,j+1,k,2)*uc(i,j+1,k,m) 1 -uc(i,j-1,k,2)*uc(i,j-1,k,m))/(2.*dy) duudx(m,3)= (uc(i,j,k+1,3)*uc(i,j,k+1,m) 1 -uc(i,j,k-1,3)*uc(i,j,k-1,m))/(2.*dz) end do C c dudx(1,1)=dux/dx, dudx(1,2)=dux/dy dudx(1,3)=dux/dz c dudx(2,1)=duy/dx, dudx(2,2)=duy/dy dudx(2,3)=duy/dz c dudx(3,1)=duz/dx, dudx(3,2)=duz/dy dudx(3,3)=duy/dz do m=1,3 dudx(m,1)= (uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dx) dudx(m,2)= (uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*dy) dudx(m,3)= (uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dz) end do c c Laplacian(Ux): d2u(1)=d2(ux); d2u(2)=d2(uy); d2u(3)=d2(uz) do m=1,3 d2u(m)=(uc(i+1,j,k,m)-2.*uc(i,j,k,m)+uc(i-1,j,k,m))/dx**2 1 +(uc(i,j+1,k,m)-2.*uc(i,j,k,m)+uc(i,j-1,k,m))/dy**2 1 +(uc(i,j,k+1,m)-2.*uc(i,j,k,m)+uc(i,j,k-1,m))/dz**2 end do c rhs(i,j,k,1,io) = c -d(vx vx)/dx - d(vy vx)/dy - d(vz vx)/dz 1 -duudx(1,1)-duudx(1,2)-duudx(1,3) + 1 y*dudx(1,1)-(x-oetamu*z)*dudx(1,2) - amu*y*dudx(1,3) 1 + uc(i,j,k,2) + anu*d2u(1) rhs(i,j,k,2,io) = c -d(vx vy)/dx - d(vy vy)/dy - d(vz vy)/dz 1 -duudx(2,1)-duudx(2,2)-duudx(2,3) + 1 y*dudx(2,1)-(x-oetamu*z)*dudx(2,2) - amu*y*dudx(2,3) 1 - uc(i,j,k,1) + (oetamu+2.*omegap)*uc(i,j,k,3) + anu*d2u(2) rhs(i,j,k,3,io) = c -d(vx vz)/dx - d(vy vz)/dy - d(vz vz)/dz 1 -duudx(3,1)-duudx(3,2)-duudx(3,3) + 1 y*dudx(3,1)-(x-oetamu*z)*dudx(3,2) - amu*y*dudx(3,3) 1 - (amu+2.*omegap)*uc(i,j,k,2) + anu*d2u(3) end if 200 continue return end subroutine bndryBaa(uc,ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid, igridI) c ig=igrid --> interior point c igridI --> interpolation points parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells dimension ucbndry(mx,my,3,9) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) c find v on the 2nd inner point k=nze-2 do 200 i = nxs, nxe do 200 j = nys, nye c c interior points and also bndry points from other grid if (ig(i,j,k).eq.igrid .or. ig(i,j,k) .eq. igridI) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,1,4) sinhksi= ucbndry(i,j,1,5) costh= ucbndry(i,j,1,6) sinth= ucbndry(i,j,1,7) cosphi= ucbndry(i,j,1,8) sinphi= ucbndry(i,j,1,9) c gg=1./sqrt(costh**2+sinhksi**2) c vksi, vth, vphi ucbndry(i,j,1,1)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * sinhksi* sinth 1 + uc(i,j,k,3)* coshksi* costh ) ucbndry(i,j,1,2)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * coshksi* costh 1 - uc(i,j,k,3)* sinhksi* sinth ) ucbndry(i,j,1,3)=- uc(i,j,k,1)* sinphi + uc(i,j,k,2)* cosphi end if 200 continue c find v on first inner boundary k=nze-1 do 300 i = nxs, nxe do 300 j = nys, nye if (ig(i,j,k).eq.igrid .or. ig(i,j,k) .eq. igridI) then c if (ig(i,j,k).eq.igrid) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,2,4) sinhksi= ucbndry(i,j,2,5) costh= ucbndry(i,j,2,6) sinth= ucbndry(i,j,2,7) cosphi= ucbndry(i,j,2,8) sinphi= ucbndry(i,j,2,9) c gg=1./sqrt(costh**2+sinhksi**2) c vksi, vth, vphi ucbndry(i,j,2,1)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * sinhksi* sinth 1 + uc(i,j,k,3)* coshksi* costh ) c ucbndry(i,j,2,1)=0. ucbndry(i,j,2,2)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * coshksi* costh 1 - uc(i,j,k,3)* sinhksi* sinth ) ucbndry(i,j,2,3)=- uc(i,j,k,1)* sinphi + uc(i,j,k,2)* cosphi end if 300 continue return end subroutine bndryBbb(uc,ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells dimension ucbndry(mx,my,3,9), dxdksi(3), drdksi(3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) c find v on the first inner point k=nze-1 kk=nze do 200 i = nxs, nxe do 200 j = nys, nye if (ig(i,j,k).eq.igrid) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,2,4) sinhksi= ucbndry(i,j,2,5) costh= ucbndry(i,j,2,6) sinth= ucbndry(i,j,2,7) cosphi= ucbndry(i,j,2,8) sinphi= ucbndry(i,j,2,9) c gg=1./sqrt(costh**2+sinhksi**2) c c drdx(1,1)=dr/dx, drdx(1,2)=dr/dy, drdx(1,3)=dr/dz, c drdx(2,1)=ds/dx, drdx(2,2)=ds/dy, drdx(2,3)=ds/dz, c drdx(3,1)=dt/dx, drdx(3,2)=dt/dy, drdx(3,3)=dt/dz. do m=1,3 do n=1,3 drdx(m,n)=trans(i,j,k,m,n) end do end do c c testing here assume Bth(nze)=Bth(nze-2), Bphi(nze)=Bphi(nze-2) c vthG=ucbndry(i,j,1,2) vphiG=ucbndry(i,j,1,3) c c div v=0 c c c dudr(1,1)=dux/dr, dudr(1,2)=dux/ds, dudt(1,3)=dux/dt, c dudr(2,1)=duy/dr, dudr(2,2)=duy/ds, dudt(2,3)=duy/dt, c dudr(3,1)=duz/dr, dudr(3,2)=duz/ds, dudt(3,3)=duz/dt. do m=1,3 dudr(m,1)=(uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dr) dudr(m,2)=(uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*ds) c dudr(m,3)=(uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dt) end do aa=dudr(1,1)*drdx(1,1)+dudr(1,2)*drdx(2,1) 1 + dudr(2,1)*drdx(1,2)+dudr(2,2)*drdx(2,2) 1 + dudr(3,1)*drdx(1,3)+dudr(3,2)*drdx(2,3) c at the guard point: vx= ax vksi + bx vth + cx vphi c vy= ay vksi + by vth + cy vphi c similarly for vz c guard point c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,3,4) sinhksi= ucbndry(i,j,3,5) costh= ucbndry(i,j,3,6) sinth= ucbndry(i,j,3,7) cosphi= ucbndry(i,j,3,8) sinphi= ucbndry(i,j,3,9) gg=1./sqrt(costh**2+sinhksi**2) ax=gg*sinhksi*sinth*cosphi bx=gg*coshksi*costh*cosphi cx=-sinphi ay=gg*sinhksi*sinth*sinphi by=gg*coshksi*costh*sinphi cy=+cosphi az=gg*coshksi*costh bz=-gg*sinhksi*sinth cz=0. c aa=2*dt*aa+(bx*vthG+cx*vphiG)*drdx(3,1) 1 + (by*vthG+cy*vphiG)*drdx(3,2) 1 +(bz*vthG+cz*vphiG)*drdx(3,3) 1 - uc(i,j,nze-2,1)*drdx(3,1) - uc(i,j,nze-2,2)*drdx(3,2) 1 - uc(i,j,nze-2,3)*drdx(3,3) vksiG=-aa/(ax*drdx(3,1)+ay*drdx(3,2)+az*drdx(3,3)) c now combine them to form vxG, vyG, and vzG uc(i,j,kk,1)=ax*vksiG+bx*vthG+cx*vphiG uc(i,j,kk,2)=ay*vksiG+by*vthG+cy*vphiG uc(i,j,kk,3)=az*vksiG+bz*vthG+cz*vphiG c if(i.eq.30.and.j.eq.30) then c write(*,*) 'in bndrybbb', i,j c write(*,*) vksig, vthg, vphig c write(*,*) ax,bx,cx c write(*,*) uc(i,j,kk,1), uc(i,j,kk,2),uc(i,j,kk,3) c end if c end if 200 continue return end subroutine bndryBdd(ubbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid) c ubbndry(i,j,k,m) c k=1,2,3: k=1 => k=nze-2 (2nd inner point) c k=2 k=nze-1 inner point c k=3 k=nze bndry point c m=1,2,3 vx,vy, vz c m=4,5 coshksi, sinhksi c m=6,7 costh, sinth c m=8,9 cosphi sinphi parameter (mtm=4, mn=4) dimension ubbndry(mx,my,3,9), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells c dimension ucbndry(mx,my,3,3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) cL2=cL*cL kk=0 do 200 k = nze-2, nze kk=kk+1 do 200 i = nxs, nxe do 200 j = nys, nye x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) c compute cosh(ksi), costh, and sinphi and cosphi rr=x*x+y*y r=sqrt(rr) zz=z*z bb=-(1+(rr+zz)/cL2) cc=rr/cL2 Q=0.5* (-bb+sqrt(bb**2-4.*cc)) coshksi=sqrt(Q) sinhksi=sqrt(Q-1.) sinth=r/(cL*coshksi) costh=z/(cL*sinhksi) if(r.ge.1.e-7) then cosphi=x/r sinphi=y/r else sinphi=0. cosphi=1. end if c save them in ucbndry ubbndry(i,j,kk,4)=coshksi ubbndry(i,j,kk,5)=sinhksi ubbndry(i,j,kk,6)=costh ubbndry(i,j,kk,7)=sinth ubbndry(i,j,kk,8)=cosphi ubbndry(i,j,kk,9)=sinphi 200 continue return end subroutine bndryvaa(uc,ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid, igridI) c ig=igrid --> interior point c igridI --> interpolation points parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells dimension ucbndry(mx,my,3,9) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) c find v on the first inner point k=nze-1 do 200 i = nxs, nxe do 200 j = nys, nye c c interior points and also bndry points from other grid if (ig(i,j,k).eq.igrid .or. ig(i,j,k) .eq. igridI) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,1,4) sinhksi= ucbndry(i,j,1,5) costh= ucbndry(i,j,1,6) sinth= ucbndry(i,j,1,7) cosphi= ucbndry(i,j,1,8) sinphi= ucbndry(i,j,1,9) c gg=1./sqrt(costh**2+sinhksi**2) c vksi, vth, vphi ucbndry(i,j,1,1)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * sinhksi* sinth 1 + uc(i,j,k,3)* coshksi* costh ) ucbndry(i,j,1,2)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * coshksi* costh 1 - uc(i,j,k,3)* sinhksi* sinth ) ucbndry(i,j,1,3)=- uc(i,j,k,1)* sinphi + uc(i,j,k,2)* cosphi end if 200 continue c find v on boundary k=nze do 300 i = nxs, nxe do 300 j = nys, nye if (ig(i,j,k).eq.igrid .or. ig(i,j,k) .eq. igridI) then c if (ig(i,j,k).eq.igrid) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,2,4) sinhksi= ucbndry(i,j,2,5) costh= ucbndry(i,j,2,6) sinth= ucbndry(i,j,2,7) cosphi= ucbndry(i,j,2,8) sinphi= ucbndry(i,j,2,9) c gg=1./sqrt(costh**2+sinhksi**2) c vksi, vth, vphi c ucbndry(i,j,2,1)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) c 1 * sinhksi* sinth c 1 + uc(i,j,k,3)* coshksi* costh ) ucbndry(i,j,2,1)=0. ucbndry(i,j,2,2)=gg*( (uc(i,j,k,1)* cosphi + uc(i,j,k,2)* sinphi) 1 * coshksi* costh 1 - uc(i,j,k,3)* sinhksi* sinth ) ucbndry(i,j,2,3)=- uc(i,j,k,1)* sinphi + uc(i,j,k,2)* cosphi end if 300 continue return end subroutine bndryvbb(uc,ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells dimension ucbndry(mx,my,3,9), dxdksi(3), drdksi(3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) c find v on the first inner point k=nze kk=nze+1 do 200 i = nxs, nxe do 200 j = nys, nye if (ig(i,j,k).eq.igrid) then c interior points c x = g(i,j,k,1) c y = g(i,j,k,2) c z = g(i,j,k,3) c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,2,4) sinhksi= ucbndry(i,j,2,5) costh= ucbndry(i,j,2,6) sinth= ucbndry(i,j,2,7) cosphi= ucbndry(i,j,2,8) sinphi= ucbndry(i,j,2,9) c gg=1./sqrt(costh**2+sinhksi**2) c c drdx(1,1)=dr/dx, drdx(1,2)=dr/dy, drdx(1,3)=dr/dz, c drdx(2,1)=ds/dx, drdx(2,2)=ds/dy, drdx(2,3)=ds/dz, c drdx(3,1)=dt/dx, drdx(3,2)=dt/dy, drdx(3,3)=dt/dz. do m=1,3 do n=1,3 drdx(m,n)=trans(i,j,k,m,n) end do end do c c dxdksi(1)=dx/dksi, dxdksi(2)=dy/dksi, dxdksi(3)=dz/dksi dxdksi(1)=cL*sinhksi*sinth*cosphi dxdksi(2)=cL*sinhksi*sinth*sinphi dxdksi(3)=cL*coshksi*costh c drdksi(1)=dr/dksi= dr/dx dx/dksi + dr/dy dy/dksi + dr/dz dz/dksi c drdksi(2)=ds/dksi= ds/dx dx/dksi + ds/dy dy/dksi + ds/dz dz/dksi c drdksi(3)=dt/dksi= dt/dx dx/dksi + dt/dy dy/dksi + dt/dz dz/dksi do n=1,3 drdksi(n)=0. do m=1,3 drdksi(n)=drdksi(n)+drdx(n,m)*dxdksi(m) end do end do c dpdr(1)=dvth/dr, dpdr(2)=dvth/ds, dpdr(3)=dvth/dt. m=2 dpdr(1)=(ucbndry(i+1,j,2,m)-ucbndry(i-1,j,2,m))/(2.*dr) dpdr(2)=(ucbndry(i,j+1,2,m)-ucbndry(i,j-1,2,m))/(2.*ds) c dvth/dksi=0 c vthG=ucbndry(i,j,1,m) c 1 -2.*dt* (dpdr(1)*drdksi(1)+ dpdr(2)*drdksi(2)) / drdksi(3) c stress free c dvth/dksi=gg^2*coshksi*sinhksi*vth vthG=ucbndry(i,j,1,m) 1 +2.*dt* (gg*gg*coshksi*sinhksi*ucbndry(i,j,2,2) 2 -dpdr(1)*drdksi(1)- dpdr(2)*drdksi(2)) / drdksi(3) c dpdr(1)=dvphi/dr, dpdr(2)=dvphi/ds, dpdr(3)=dvphi/dt. m=3 dpdr(1)=(ucbndry(i+1,j,2,m)-ucbndry(i-1,j,2,m))/(2.*dr) dpdr(2)=(ucbndry(i,j+1,2,m)-ucbndry(i,j-1,2,m))/(2.*ds) cc dvphi/dksi=0 cc vphiG=ucbndry(i,j,1,m) cc 1 -2.*dt* (dpdr(1)*drdksi(1)+ dpdr(2)*drdksi(2)) / drdksi(3) c c stress free: c dvphi/dksi=sinhksi/coshksi*vphi vphiG=ucbndry(i,j,1,m) 1 +2.*dt* (sinhksi/coshksi*ucbndry(i,j,2,3) 2 -dpdr(1)*drdksi(1)- dpdr(2)*drdksi(2)) / drdksi(3) c c div v=0 c c c dudr(1,1)=dux/dr, dudr(1,2)=dux/ds, dudt(1,3)=dux/dt, c dudr(2,1)=duy/dr, dudr(2,2)=duy/ds, dudt(2,3)=duy/dt, c dudr(3,1)=duz/dr, dudr(3,2)=duz/ds, dudt(3,3)=duz/dt. do m=1,3 dudr(m,1)=(uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dr) dudr(m,2)=(uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*ds) c dudr(m,3)=(uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dt) end do aa=dudr(1,1)*drdx(1,1)+dudr(1,2)*drdx(2,1) 1 + dudr(2,1)*drdx(1,2)+dudr(2,2)*drdx(2,2) 1 + dudr(3,1)*drdx(1,3)+dudr(3,2)*drdx(2,3) c at the guard point: vx= ax vksi + bx vth + cx vphi c vy= ay vksi + by vth + cy vphi c similarly for vz c guard point c into spheroidal coordinate ksi, th, phi coshksi= ucbndry(i,j,3,4) sinhksi= ucbndry(i,j,3,5) costh= ucbndry(i,j,3,6) sinth= ucbndry(i,j,3,7) cosphi= ucbndry(i,j,3,8) sinphi= ucbndry(i,j,3,9) gg=1./sqrt(costh**2+sinhksi**2) ax=gg*sinhksi*sinth*cosphi bx=gg*coshksi*costh*cosphi cx=-sinphi ay=gg*sinhksi*sinth*sinphi by=gg*coshksi*costh*sinphi cy=+cosphi az=gg*coshksi*costh bz=-gg*sinhksi*sinth cz=0. c aa=2*dt*aa+(bx*vthG+cx*vphiG)*drdx(3,1) 1 + (by*vthG+cy*vphiG)*drdx(3,2) 1 +(bz*vthG+cz*vphiG)*drdx(3,3) 1 - uc(i,j,nze-1,1)*drdx(3,1) - uc(i,j,nze-1,2)*drdx(3,2) 1 - uc(i,j,nze-1,3)*drdx(3,3) vksiG=-aa/(ax*drdx(3,1)+ay*drdx(3,2)+az*drdx(3,3)) c now combine them to form vxG, vyG, and vzG uc(i,j,kk,1)=ax*vksiG+bx*vthG+cx*vphiG uc(i,j,kk,2)=ay*vksiG+by*vthG+cy*vphiG uc(i,j,kk,3)=az*vksiG+bz*vthG+cz*vphiG c end if 200 continue return end subroutine bndryvdd(ucbndry,g,trans,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid) c ucbndry(i,j,k,m) c k=1,2,3: k=1 => k=nze-1 (inner point) c k=2 k=nze bndry point c k=3 k=nze+1 guard point c m=1,2,3 vx,vy, vz c m=4,5 coshksi, sinhksi c m=6,7 costh, sinth c m=8,9 cosphi sinphi parameter (mtm=4, mn=4) dimension ucbndry(mx,my,3,9), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2uxdr(3,3,3), drxdr(3,3,3) c ucbndry=vksi, vth, vphi (spheroidal) at 3 shells c dimension ucbndry(mx,my,3,3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) cL2=cL*cL kk=0 do 200 k = nze-1, nze+1 kk=kk+1 do 200 i = nxs, nxe do 200 j = nys, nye x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) c compute cosh(ksi), costh, and sinphi and cosphi rr=x*x+y*y r=sqrt(rr) zz=z*z bb=-(1+(rr+zz)/cL2) cc=rr/cL2 Q=0.5* (-bb+sqrt(bb**2-4.*cc)) coshksi=sqrt(Q) sinhksi=sqrt(Q-1.) sinth=r/(cL*coshksi) costh=z/(cL*sinhksi) if(r.ge.1.e-7) then cosphi=x/r sinphi=y/r else sinphi=0. cosphi=1. end if c save them in ucbndry ucbndry(i,j,kk,4)=coshksi ucbndry(i,j,kk,5)=sinhksi ucbndry(i,j,kk,6)=costh ucbndry(i,j,kk,7)=sinth ucbndry(i,j,kk,8)=cosphi ucbndry(i,j,kk,9)=sinphi 200 continue return end subroutine interpv1(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp) dimension uc1(mx,my,mz,4), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,mz2,4) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 (3d interpolation) intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then c if(i.eq.14 .and.j.eq.24 .and. k.eq.57) then c temppp=1. c end if intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt do m=1,3 fmm0 = uc2(ngpi-1,ngpj-1, ngpk ,m) fm00 = uc2(ngpi-1,ngpj, ngpk ,m) fm10 = uc2(ngpi-1,ngpj+1, ngpk ,m) f0m0 = uc2(ngpi,ngpj-1, ngpk ,m) f000 = uc2(ngpi,ngpj, ngpk ,m) f010 = uc2(ngpi,ngpj+1, ngpk ,m) f1m0 = uc2(ngpi+1,ngpj-1, ngpk ,m) f100 = uc2(ngpi+1,ngpj, ngpk ,m) f110 = uc2(ngpi+1,ngpj+1, ngpk ,m) fmm1 = uc2(ngpi-1,ngpj-1,ngpk+1 ,m) fm01 = uc2(ngpi-1,ngpj,ngpk+1 ,m) fm11 = uc2(ngpi-1,ngpj+1,ngpk+1 ,m) f0m1 = uc2(ngpi,ngpj-1,ngpk+1 ,m) f001 = uc2(ngpi,ngpj,ngpk+1 ,m) f011 = uc2(ngpi,ngpj+1,ngpk+1 ,m) f1m1 = uc2(ngpi+1,ngpj-1,ngpk+1 ,m) f101 = uc2(ngpi+1,ngpj,ngpk+1 ,m) f111 = uc2(ngpi+1,ngpj+1,ngpk+1 ,m) fmmm = uc2(ngpi-1,ngpj-1,ngpk-1 ,m) fm0m = uc2(ngpi-1,ngpj,ngpk-1 ,m) fm1m = uc2(ngpi-1,ngpj+1,ngpk-1 ,m) f0mm = uc2(ngpi,ngpj-1,ngpk-1 ,m) f00m = uc2(ngpi,ngpj,ngpk-1 ,m) f01m = uc2(ngpi,ngpj+1,ngpk-1 ,m) f1mm = uc2(ngpi+1,ngpj-1,ngpk-1 ,m) f10m = uc2(ngpi+1,ngpj,ngpk-1 ,m) f11m = uc2(ngpi+1,ngpj+1,ngpk-1 ,m) c000=f000 c100=0.5*(f100-fm00) c010=0.5*(f010-f0m0) c001=0.5*(f001-f00m) c200=0.5*(-2.*f000+f100+fm00) c020=0.5*(-2.*f000 + f010 + f0m0) c002=0.5*(-2.* f000 + f001 + f00m) c110=0.25*(f110 - f1m0 - fm10 + fmm0) c011=0.25*(f011 - f01m - f0m1 + f0mm) c101=0.25*(f101 - f10m - fm01 + fm0m) c210=0.25*(-2.* f010 + 2.* f0m0 + f110 - f1m0 + fm10 - fmm0) c201=0.25*(-2.* f001 + 2.* f00m + f101 - f10m + fm01 - fm0m) c120=0.25*(-2.*f100 + f110 + f1m0 + 2.*fm00 - fm10 - fmm0) c021=0.25*(-2.*f001 + 2.*f00m + f011 - f01m + f0m1 - f0mm) c102=0.25*(-2.*f100 + f101 + f10m + 2.*fm00 - fm01 - fm0m) c012=0.25*(-2.*f010 + f011 + f01m + 2.*f0m0 - f0m1 - f0mm) c111=0.125*(f111 - f11m - f1m1 + f1mm - fm11 + fm1m + fmm1 - fmmm) c220=0.25*(4.*f000 - 2.*f010 - 2.*f0m0 - 2.*f100 + f110 1 + f1m0 - 2.*fm00 + fm10 + fmm0) c202=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f100 + f101 1 + f10m - 2.*fm00 + fm01 + fm0m) c022=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f010 + f011 1 + f01m - 2.*f0m0 + f0m1 + f0mm) c211=0.125*(-2.*f011 + 2.*f01m + 2.*f0m1 - 2.*f0mm 1 + f111 - f11m - f1m1 + f1mm + fm11 - fm1m - fmm1 + fmmm) c121=0.125*(-2.*f101 + 2.*f10m + f111 - f11m 1 + f1m1 - f1mm + 2.*fm01 - 2.*fm0m - fm11 + fm1m - fmm1 + fmmm ) c112=0.125*(-2.*f110 + f111 + f11m + 2.*f1m0 1 - f1m1 - f1mm + 2.*fm10 - fm11 - fm1m - 2.*fmm0 + fmm1 + fmmm) c221=0.125*(4.*f001 - 4.*f00m - 2.*f011 + 2.*f01m 1 - 2.*f0m1 + 2.*f0mm - 2.*f101 + 2.*f10m + f111 1 - f11m + f1m1 - f1mm - 2.*fm01 + 2.*fm0m 1 + fm11 -fm1m + fmm1 - fmmm ) c212=0.125*(4.*f010 - 2.*f011 - 2.*f01m - 4.*f0m0 1 + 2.*f0m1 + 2.*f0mm - 2.*f110 1 + f111 + f11m + 2.*f1m0 - f1m1 - f1mm - 2.*fm10 + fm11 + fm1m 1 + 2.*fmm0 - fmm1 - fmmm) c122=0.125*(4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 1 + f1m1 + f1mm - 4.*fm00 + 2.*fm01 + 2.*fm0m 1 + 2.*fm10 - fm11 - fm1m + 2.*fmm0 - fmm1 - fmmm) c222=0.125*(-8.*f000 + 4.*f001 + 4.*f00m + 4.*f010 1 - 2.*f011 - 2.*f01m + 4.*f0m0 - 2.*f0m1 - 2.*f0mm 1 + 4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 + f1m1 + f1mm + 4.*fm00 1 - 2.*fm01 - 2.*fm0m - 2.*fm10 + fm11 1 + fm1m - 2.*fmm0 + fmm1 + fmmm) uc1(i,j,k,m)= 1 c000 + c100*alpha + c010*beta + c001*gamma + 1 c200*alpha**2 + c020*beta**2 + c002*gamma**2 + 1 c110*alpha*beta + c011*beta*gamma + c101*alpha*gamma + 1 c210*alpha**2*beta + c201*alpha**2*gamma 1 + c120*alpha*beta**2 + c021*beta**2*gamma + 1 c102*alpha*gamma**2 + c012*beta*gamma**2 + c111*alpha*beta*gamma 1 + c220*alpha**2*beta**2 + c202*alpha**2*gamma**2 1 + c022*beta**2*gamma**2 + 1 c211*alpha**2*beta*gamma + c121*alpha*beta**2*gamma 1 + c112*alpha*beta*gamma**2 + 1 c221*alpha**2*beta**2*gamma + c212*alpha**2*beta*gamma**2 1 + c122*alpha*beta**2*gamma**2 + 1 c222*alpha**2*beta**2*gamma**2 end do end if 10 continue return end subroutine interpRHS1(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp,io) parameter(mtm=4) dimension uc1(mx,my,mz,3,mtm), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,mz2,3,mtm) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 (3d interpolation) intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then c if(i.eq.14 .and.j.eq.24 .and. k.eq.57) then c temppp=1. c end if intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt do m=1,3 fmm0 = uc2(ngpi-1,ngpj-1, ngpk, m, io) fm00 = uc2(ngpi-1,ngpj, ngpk, m, io) fm10 = uc2(ngpi-1,ngpj+1, ngpk, m, io) f0m0 = uc2(ngpi,ngpj-1, ngpk, m, io) f000 = uc2(ngpi,ngpj, ngpk, m, io) f010 = uc2(ngpi,ngpj+1, ngpk, m, io) f1m0 = uc2(ngpi+1,ngpj-1, ngpk, m, io) f100 = uc2(ngpi+1,ngpj, ngpk, m, io) f110 = uc2(ngpi+1,ngpj+1, ngpk, m, io) fmm1 = uc2(ngpi-1,ngpj-1,ngpk+1, m, io) fm01 = uc2(ngpi-1,ngpj,ngpk+1, m, io) fm11 = uc2(ngpi-1,ngpj+1,ngpk+1, m, io) f0m1 = uc2(ngpi,ngpj-1,ngpk+1, m, io) f001 = uc2(ngpi,ngpj,ngpk+1, m, io) f011 = uc2(ngpi,ngpj+1,ngpk+1, m, io) f1m1 = uc2(ngpi+1,ngpj-1,ngpk+1, m, io) f101 = uc2(ngpi+1,ngpj,ngpk+1, m, io) f111 = uc2(ngpi+1,ngpj+1,ngpk+1, m, io) fmmm = uc2(ngpi-1,ngpj-1,ngpk-1, m, io) fm0m = uc2(ngpi-1,ngpj,ngpk-1, m, io) fm1m = uc2(ngpi-1,ngpj+1,ngpk-1, m, io) f0mm = uc2(ngpi,ngpj-1,ngpk-1, m, io) f00m = uc2(ngpi,ngpj,ngpk-1, m, io) f01m = uc2(ngpi,ngpj+1,ngpk-1, m, io) f1mm = uc2(ngpi+1,ngpj-1,ngpk-1, m, io) f10m = uc2(ngpi+1,ngpj,ngpk-1, m, io) f11m = uc2(ngpi+1,ngpj+1,ngpk-1, m, io) c000=f000 c100=0.5*(f100-fm00) c010=0.5*(f010-f0m0) c001=0.5*(f001-f00m) c200=0.5*(-2.*f000+f100+fm00) c020=0.5*(-2.*f000 + f010 + f0m0) c002=0.5*(-2.* f000 + f001 + f00m) c110=0.25*(f110 - f1m0 - fm10 + fmm0) c011=0.25*(f011 - f01m - f0m1 + f0mm) c101=0.25*(f101 - f10m - fm01 + fm0m) c210=0.25*(-2.* f010 + 2.* f0m0 + f110 - f1m0 + fm10 - fmm0) c201=0.25*(-2.* f001 + 2.* f00m + f101 - f10m + fm01 - fm0m) c120=0.25*(-2.*f100 + f110 + f1m0 + 2.*fm00 - fm10 - fmm0) c021=0.25*(-2.*f001 + 2.*f00m + f011 - f01m + f0m1 - f0mm) c102=0.25*(-2.*f100 + f101 + f10m + 2.*fm00 - fm01 - fm0m) c012=0.25*(-2.*f010 + f011 + f01m + 2.*f0m0 - f0m1 - f0mm) c111=0.125*(f111 - f11m - f1m1 + f1mm - fm11 + fm1m + fmm1 - fmmm) c220=0.25*(4.*f000 - 2.*f010 - 2.*f0m0 - 2.*f100 + f110 1 + f1m0 - 2.*fm00 + fm10 + fmm0) c202=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f100 + f101 1 + f10m - 2.*fm00 + fm01 + fm0m) c022=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f010 + f011 1 + f01m - 2.*f0m0 + f0m1 + f0mm) c211=0.125*(-2.*f011 + 2.*f01m + 2.*f0m1 - 2.*f0mm 1 + f111 - f11m - f1m1 + f1mm + fm11 - fm1m - fmm1 + fmmm) c121=0.125*(-2.*f101 + 2.*f10m + f111 - f11m 1 + f1m1 - f1mm + 2.*fm01 - 2.*fm0m - fm11 + fm1m - fmm1 + fmmm ) c112=0.125*(-2.*f110 + f111 + f11m + 2.*f1m0 1 - f1m1 - f1mm + 2.*fm10 - fm11 - fm1m - 2.*fmm0 + fmm1 + fmmm) c221=0.125*(4.*f001 - 4.*f00m - 2.*f011 + 2.*f01m 1 - 2.*f0m1 + 2.*f0mm - 2.*f101 + 2.*f10m + f111 1 - f11m + f1m1 - f1mm - 2.*fm01 + 2.*fm0m 1 + fm11 -fm1m + fmm1 - fmmm ) c212=0.125*(4.*f010 - 2.*f011 - 2.*f01m - 4.*f0m0 1 + 2.*f0m1 + 2.*f0mm - 2.*f110 1 + f111 + f11m + 2.*f1m0 - f1m1 - f1mm - 2.*fm10 + fm11 + fm1m 1 + 2.*fmm0 - fmm1 - fmmm) c122=0.125*(4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 1 + f1m1 + f1mm - 4.*fm00 + 2.*fm01 + 2.*fm0m 1 + 2.*fm10 - fm11 - fm1m + 2.*fmm0 - fmm1 - fmmm) c222=0.125*(-8.*f000 + 4.*f001 + 4.*f00m + 4.*f010 1 - 2.*f011 - 2.*f01m + 4.*f0m0 - 2.*f0m1 - 2.*f0mm 1 + 4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 + f1m1 + f1mm + 4.*fm00 1 - 2.*fm01 - 2.*fm0m - 2.*fm10 + fm11 1 + fm1m - 2.*fmm0 + fmm1 + fmmm) uc1(i,j,k,m,io)= 1 c000 + c100*alpha + c010*beta + c001*gamma + 1 c200*alpha**2 + c020*beta**2 + c002*gamma**2 + 1 c110*alpha*beta + c011*beta*gamma + c101*alpha*gamma + 1 c210*alpha**2*beta + c201*alpha**2*gamma 1 + c120*alpha*beta**2 + c021*beta**2*gamma + 1 c102*alpha*gamma**2 + c012*beta*gamma**2 + c111*alpha*beta*gamma 1 + c220*alpha**2*beta**2 + c202*alpha**2*gamma**2 1 + c022*beta**2*gamma**2 + 1 c211*alpha**2*beta*gamma + c121*alpha*beta**2*gamma 1 + c112*alpha*beta*gamma**2 + 1 c221*alpha**2*beta**2*gamma + c212*alpha**2*beta*gamma**2 1 + c122*alpha*beta**2*gamma**2 + 1 c222*alpha**2*beta**2*gamma**2 end do end if 10 continue return end subroutine interpv2(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp) dimension uc1(mx,my,mz,4), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,mz2,4) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 (3d interpolation) intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then c if(i.eq.14 .and.j.eq.24 .and. k.eq.57) then c temppp=1. c end if intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt c gamma should be zero! -> interpolation on [r, s] surface do m=1,3 fmm = uc2(ngpi-1, ngpj-1 , ngpk, m) fm0 = uc2(ngpi-1, ngpj , ngpk, m) fm1 = uc2(ngpi-1, ngpj+1 , ngpk, m) f0m = uc2(ngpi, ngpj-1 , ngpk, m) f00 = uc2(ngpi, ngpj , ngpk, m) f01 = uc2(ngpi, ngpj+1 , ngpk, m) f1m = uc2(ngpi+1, ngpj-1 , ngpk, m) f10 = uc2(ngpi+1, ngpj , ngpk, m) f11 = uc2(ngpi+1, ngpj+1 , ngpk, m) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) uc1(i,j,k,m)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do end if 10 continue return end subroutine interpRHS2(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp,io) parameter(mtm=4) dimension uc1(mx,my,mz,3,mtm), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,mz2,3,mtm) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 (3d interpolation) intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then c if(i.eq.14 .and.j.eq.24 .and. k.eq.57) then c temppp=1. c end if intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt c gamma should be zero! -> interpolation on [r, s] surface do m=1,3 fmm = uc2(ngpi-1, ngpj-1 , ngpk, m, io) fm0 = uc2(ngpi-1, ngpj , ngpk, m, io) fm1 = uc2(ngpi-1, ngpj+1 , ngpk, m, io) f0m = uc2(ngpi, ngpj-1 , ngpk, m, io) f00 = uc2(ngpi, ngpj , ngpk, m, io) f01 = uc2(ngpi, ngpj+1 , ngpk, m, io) f1m = uc2(ngpi+1, ngpj-1 , ngpk, m, io) f10 = uc2(ngpi+1, ngpj , ngpk, m, io) f11 = uc2(ngpi+1, ngpj+1 , ngpk, m, io) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) uc1(i,j,k,m,io)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do end if 10 continue return end subroutine interpE2(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp,io) parameter(mtm=4) dimension uc1(mx,my,3), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,3) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 (3d interpolation) intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then intnum=intnum+1 if(k.eq.nze-1) then ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt c gamma should be zero! -> interpolation on [r, s] surface do m=1,3 fmm = uc2(ngpi-1, ngpj-1 , m) fm0 = uc2(ngpi-1, ngpj , m) fm1 = uc2(ngpi-1, ngpj+1 , m) f0m = uc2(ngpi, ngpj-1 , m) f00 = uc2(ngpi, ngpj , m) f01 = uc2(ngpi, ngpj+1 , m) f1m = uc2(ngpi+1, ngpj-1 , m) f10 = uc2(ngpi+1, ngpj , m) f11 = uc2(ngpi+1, ngpj+1 , m) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) uc1(i,j,m)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do end if end if 10 continue return end subroutine interpv(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc2,mx2,my2,mz2, dr,ds,dt,mngp) dimension uc1(mx,my,mz,4), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3) dimension uc2(mx2,my2,mz2,4) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze if(ig(i,j,k).eq.igrid) then c if(i.eq.14 .and.j.eq.24 .and. k.eq.57) then c temppp=1. c end if intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt if(ngpk.ne.nze) then do m=1,3 uc111=uc2(ngpi,ngpj,ngpk,m) uc121=uc2(ngpi,ngpj+1,ngpk,m) uc211=uc2(ngpi+1,ngpj,ngpk,m) uc221=uc2(ngpi+1,ngpj+1,ngpk,m) uc112=uc2(ngpi,ngpj,ngpk+1,m) uc122=uc2(ngpi,ngpj+1,ngpk+1,m) uc212=uc2(ngpi+1,ngpj,ngpk+1,m) uc222=uc2(ngpi+1,ngpj+1,ngpk+1,m) uc1old=uc1(i,j,k,m) uc1(i,j,k,m)=((1.-alpha)*(1.-beta)*uc2(ngpi,ngpj,ngpk,m) 1 +(1.-alpha)* beta *uc2(ngpi,ngpj+1,ngpk,m) 1 + alpha*(1.-beta)*uc2(ngpi+1,ngpj,ngpk,m) 1 + alpha*beta*uc2(ngpi+1,ngpj+1,ngpk,m))*(1.-gamma) 1 +((1.-alpha)*(1.-beta)*uc2(ngpi,ngpj,ngpk+1,m) 1 +(1.-alpha)* beta *uc2(ngpi,ngpj+1,ngpk+1,m) 1 + alpha*(1.-beta)*uc2(ngpi+1,ngpj,ngpk+1,m) 1 + alpha*beta*uc2(ngpi+1,ngpj+1,ngpk+1,m))*gamma end do else c ngpk=nze do m=1,3 uc111=uc2(ngpi,ngpj,ngpk,m) uc121=uc2(ngpi,ngpj+1,ngpk,m) uc211=uc2(ngpi+1,ngpj,ngpk,m) uc221=uc2(ngpi+1,ngpj+1,ngpk,m) uc1old=uc1(i,j,k,m) uc1(i,j,k,m)=((1.-alpha)*(1.-beta)*uc2(ngpi,ngpj,ngpk,m) 1 +(1.-alpha)* beta *uc2(ngpi,ngpj+1,ngpk,m) 1 + alpha*(1.-beta)*uc2(ngpi+1,ngpj,ngpk,m) 1 + alpha*beta*uc2(ngpi+1,ngpj+1,ngpk,m)) end do end if end if 10 continue return end subroutine setup(uc,ig,g,mx,my,mz, 1 nxs,nxe,nys,nye,nzs,nze,igrid) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), g(mx,my,mz,3), ig(mx,my,mz) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor c factor=0.8 c ca=1. c cb=ca*factor c2=cb**2 pi=3.14159265359 aa0=1.e-3*30.*4. c aa0=1. c aa1=0.0150871 * aa0 aa2=-0.0446851* aa0 aa3=-0.166318* aa0 aa4=0.073174* aa0 aa5=0.177694* aa0 aa6=0.0861582* aa0 aa7=0.755539* aa0 aa8=-0.0767787* aa0 do i=nxs, nxe do j=nys, nye do k=nzs, nze c if(ig(i,j,k).eq.igrid) then x=g(i,j,k,1) y=g(i,j,k,2) z=g(i,j,k,3) u1x =(y**2-z**2/c2) u1y = - x * y u1z = x * z u2x =(1.- x**2 - 2.* y**2 - 2. * z**2/c2) u2y =x* y u2z =x* z u3x=x * y u3y=+(z*z/c2 - x*x) u3z= - y* z u4x=x* y u4y=+(1. - 2. * x*x - y*y - 2.* z*z/c2) u4z=+ y *z u5x=-x* z /c2 u5y=+y* z/c2 u5z=+ (x*x-y*y) u6x=x * z /c2 u6y=+y * z/c2 u6z=+ (1.- 2.* x*x- 2.* y*y- z*z/c2) u7x=y * z /c2 u7y=0. u7z= - x * y u8x=0. u8y= - x * z /c2 u8z=+x * y uc(i,j,k,1)=aa1*u1x+aa2*u2x+ aa3*u3x+aa4*u4x+ 1 aa5*u5x+aa6*u6x+ aa7*u7x+aa8*u8x uc(i,j,k,2)=aa1*u1y+aa2*u2y+ aa3*u3y+aa4*u4y+ 1 aa5*u5y+aa6*u6y+ aa7*u7y+aa8*u8y uc(i,j,k,3)=aa1*u1z+aa2*u2z+ aa3*u3z+aa4*u4z+ 1 aa5*u5z+aa6*u6z+ aa7*u7z+aa8*u8z uc(i,j,k,4)=0. c end if end do end do end do return end subroutine energy(uc,ig,g,mx,my,mz, 1 nxs,nxe,nys,nye,nzs,nze,igrid,ekeout) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), g(mx,my,mz,3), ig(mx,my,mz) pi=3.14159265359 eke=0. do 100 i=nxs, nxe do 100 j=nys, nye do 100 k=nzs, nze if(ig(i,j,k).eq.igrid) then eke=eke+0.5*(uc(i,j,k,1)**2+uc(i,j,k,2)**2+uc(i,j,k,3)**2) end if 100 continue ekeout=eke c write(9,*) 'eke=',eke return end subroutine energy5(uc5,nphi, nmuh, nnu, dmu, dnu, dphi, aa, 1 eke1, eke2) dimension uc5(nphi+2,nmuh+2,nnu+2,3) eke1=0. eke2=0. do j = 2, nmuh+1 aamu= (j-1.5) *dmu sinhmu=sinh(aamu) coshmu=cosh(aamu) do i = 2, nphi+1 pphi=(i-2) * dphi cosphi=cos(pphi) sinphi=sin(pphi) do k = 2, nnu/2+1 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) eke1=eke1+ 0.5*(uc5(i,j,k,1)**2 1 + uc5(i,j,k,2)**2 + uc5(i,j,k,3)**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) end do do k = nnu/2+2, nnu+1 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) eke2=eke2+ 0.5*(uc5(i,j,k,1)**2 1 + uc5(i,j,k,2)**2 + uc5(i,j,k,3)**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) end do end do end do eke1=eke1*dmu*dnu*dphi eke2=eke2*dmu*dnu*dphi return end subroutine energyV5(uc5,nphi, nmuh, nnu, dmu, dnu, dphi, aa, 1 eke1, eke2, eke10, eke20) dimension uc5(nphi+2,nmuh+2,nnu+2,3) common /var1/ omega, omegap, omegapx,omegapz,ca,cb,anu,eta,factor cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu eke1=0. eke2=0. eke10=0. eke20=0. do j = 2, nmuh+1 aamu= (j-1.5) *dmu sinhmu=sinh(aamu) coshmu=cosh(aamu) do i = 2, nphi+1 pphi=(i-2) * dphi cosphi=cos(pphi) sinphi=sin(pphi) do k = 2, nnu/2+1 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) x=aa*coshmu*sinnu*cosphi y=aa*coshmu*sinnu*sinphi z=aa*sinhmu*cosnu vx0 = -y*1. vy0 = x*1. -oetamu *z vz0 = amu * y eke10=eke10+ 0.5*( vx0**2 1 + vy0**2 + vz0**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) eke1=eke1+ 0.5*( (uc5(i,j,k,1)+vx0)**2 1 + (uc5(i,j,k,2)+vy0)**2 + (uc5(i,j,k,3)+vz0)**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) end do do k = nnu/2+2, nnu+1 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) x=aa*coshmu*sinnu*cosphi y=aa*coshmu*sinnu*sinphi z=aa*sinhmu*cosnu vx0 = -y vy0 = x -oetamu *z vz0 = amu * y eke20=eke20+ 0.5*( vx0**2 1 + vy0**2 + vz0**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) eke2=eke2+ 0.5*( (uc5(i,j,k,1)+vx0)**2 1 + (uc5(i,j,k,2)+vy0)**2 + (uc5(i,j,k,3)+vz0)**2) 2 *aa**3*coshmu*sinnu*(sinhmu**2+cosnu**2) end do end do end do eke1=eke1*dmu*dnu*dphi eke2=eke2*dmu*dnu*dphi eke10=eke10*dmu*dnu*dphi eke20=eke20*dmu*dnu*dphi return end subroutine interpv5(uc5, ig5, ngp5, drngp5, mx5, my5, mz5, 1 igrid, uc, mx,my,mz, dr, ds, dt) dimension uc5(mx5+2,my5+2,mz5+2,3), ig5(mx5+2,my5+2,mz5+2) 1 ,ngp5(mx5+2,my5+2,mz5+2,3),drngp5(mx5+2,my5+2,mz5+2,3) dimension uc(mx,my,mz,4) c input uc(mx,my,mz) c output uc5(mx5,my5,mz5) interpolated from uc c c find div on Grid 5 from Grid 1, 2, or 3 c do 10 i=2, mx5+1 do 10 j=2, my5+1 do 10 k=2, mz5+1 if(ig5(i,j,k).eq.igrid) then ngpi=ngp5(i,j,k,1) ngpj=ngp5(i,j,k,2) ngpk=ngp5(i,j,k,3) ddr=drngp5(i,j,k,1) dds=drngp5(i,j,k,2) ddt=drngp5(i,j,k,3) c write(*,*) i,j, ngpi,ngpj,ngpk, ddr, dds,ddt alpha=ddr/dr beta=dds/ds gamma=ddt/dt c do m=1,3 fmm0 = uc(ngpi-1,ngpj-1, ngpk, m) fm00 = uc(ngpi-1,ngpj, ngpk, m) fm10 = uc(ngpi-1,ngpj+1, ngpk, m) f0m0 = uc(ngpi,ngpj-1, ngpk, m) f000 = uc(ngpi,ngpj, ngpk, m) f010 = uc(ngpi,ngpj+1, ngpk, m) f1m0 = uc(ngpi+1,ngpj-1, ngpk, m) f100 = uc(ngpi+1,ngpj, ngpk, m) f110 = uc(ngpi+1,ngpj+1, ngpk, m) fmm1 = uc(ngpi-1,ngpj-1,ngpk+1, m) fm01 = uc(ngpi-1,ngpj,ngpk+1, m) fm11 = uc(ngpi-1,ngpj+1,ngpk+1, m) f0m1 = uc(ngpi,ngpj-1,ngpk+1, m) f001 = uc(ngpi,ngpj,ngpk+1, m) f011 = uc(ngpi,ngpj+1,ngpk+1, m) f1m1 = uc(ngpi+1,ngpj-1,ngpk+1, m) f101 = uc(ngpi+1,ngpj,ngpk+1, m) f111 = uc(ngpi+1,ngpj+1,ngpk+1, m) fmmm = uc(ngpi-1,ngpj-1,ngpk-1, m) fm0m = uc(ngpi-1,ngpj,ngpk-1, m) fm1m = uc(ngpi-1,ngpj+1,ngpk-1, m) f0mm = uc(ngpi,ngpj-1,ngpk-1, m) f00m = uc(ngpi,ngpj,ngpk-1, m) f01m = uc(ngpi,ngpj+1,ngpk-1, m) f1mm = uc(ngpi+1,ngpj-1,ngpk-1, m) f10m = uc(ngpi+1,ngpj,ngpk-1, m) f11m = uc(ngpi+1,ngpj+1,ngpk-1, m) c000=f000 c100=0.5*(f100-fm00) c010=0.5*(f010-f0m0) c001=0.5*(f001-f00m) c200=0.5*(-2.*f000+f100+fm00) c020=0.5*(-2.*f000 + f010 + f0m0) c002=0.5*(-2.* f000 + f001 + f00m) c110=0.25*(f110 - f1m0 - fm10 + fmm0) c011=0.25*(f011 - f01m - f0m1 + f0mm) c101=0.25*(f101 - f10m - fm01 + fm0m) c210=0.25*(-2.* f010 + 2.* f0m0 + f110 - f1m0 + fm10 - fmm0) c201=0.25*(-2.* f001 + 2.* f00m + f101 - f10m + fm01 - fm0m) c120=0.25*(-2.*f100 + f110 + f1m0 + 2.*fm00 - fm10 - fmm0) c021=0.25*(-2.*f001 + 2.*f00m + f011 - f01m + f0m1 - f0mm) c102=0.25*(-2.*f100 + f101 + f10m + 2.*fm00 - fm01 - fm0m) c012=0.25*(-2.*f010 + f011 + f01m + 2.*f0m0 - f0m1 - f0mm) c111=0.125*(f111 - f11m - f1m1 + f1mm - fm11 + fm1m + fmm1 - fmmm) c220=0.25*(4.*f000 - 2.*f010 - 2.*f0m0 - 2.*f100 + f110 1 + f1m0 - 2.*fm00 + fm10 + fmm0) c202=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f100 + f101 1 + f10m - 2.*fm00 + fm01 + fm0m) c022=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f010 + f011 1 + f01m - 2.*f0m0 + f0m1 + f0mm) c211=0.125*(-2.*f011 + 2.*f01m + 2.*f0m1 - 2.*f0mm 1 + f111 - f11m - f1m1 + f1mm + fm11 - fm1m - fmm1 + fmmm) c121=0.125*(-2.*f101 + 2.*f10m + f111 - f11m 1 + f1m1 - f1mm + 2.*fm01 - 2.*fm0m - fm11 + fm1m - fmm1 + fmmm ) c112=0.125*(-2.*f110 + f111 + f11m + 2.*f1m0 1 - f1m1 - f1mm + 2.*fm10 - fm11 - fm1m - 2.*fmm0 + fmm1 + fmmm) c221=0.125*(4.*f001 - 4.*f00m - 2.*f011 + 2.*f01m 1 - 2.*f0m1 + 2.*f0mm - 2.*f101 + 2.*f10m + f111 1 - f11m + f1m1 - f1mm - 2.*fm01 + 2.*fm0m 1 + fm11 -fm1m + fmm1 - fmmm ) c212=0.125*(4.*f010 - 2.*f011 - 2.*f01m - 4.*f0m0 1 + 2.*f0m1 + 2.*f0mm - 2.*f110 1 + f111 + f11m + 2.*f1m0 - f1m1 - f1mm - 2.*fm10 + fm11 + fm1m 1 + 2.*fmm0 - fmm1 - fmmm) c122=0.125*(4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 1 + f1m1 + f1mm - 4.*fm00 + 2.*fm01 + 2.*fm0m 1 + 2.*fm10 - fm11 - fm1m + 2.*fmm0 - fmm1 - fmmm) c222=0.125*(-8.*f000 + 4.*f001 + 4.*f00m + 4.*f010 1 - 2.*f011 - 2.*f01m + 4.*f0m0 - 2.*f0m1 - 2.*f0mm 1 + 4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 + f1m1 + f1mm + 4.*fm00 1 - 2.*fm01 - 2.*fm0m - 2.*fm10 + fm11 1 + fm1m - 2.*fmm0 + fmm1 + fmmm) uc5(i,j,k,m)= 1 c000 + c100*alpha + c010*beta + c001*gamma + 1 c200*alpha**2 + c020*beta**2 + c002*gamma**2 + 1 c110*alpha*beta + c011*beta*gamma + c101*alpha*gamma + 1 c210*alpha**2*beta + c201*alpha**2*gamma 1 + c120*alpha*beta**2 + c021*beta**2*gamma + 1 c102*alpha*gamma**2 + c012*beta*gamma**2 + c111*alpha*beta*gamma 1 + c220*alpha**2*beta**2 + c202*alpha**2*gamma**2 1 + c022*beta**2*gamma**2 + 1 c211*alpha**2*beta*gamma + c121*alpha*beta**2*gamma 1 + c112*alpha*beta*gamma**2 + 1 c221*alpha**2*beta**2*gamma + c212*alpha**2*beta*gamma**2 1 + c122*alpha*beta**2*gamma**2 + 1 c222*alpha**2*beta**2*gamma**2 end do end if 10 continue return end subroutine interpRHS5(uc5, ig5, ngp5, drngp5, mx5, my5, mz5, 1 igrid, uc, mx,my,mz, dr, ds, dt, io) parameter(mtm=4) dimension uc5(mx5+2,my5+2,mz5+2,3), ig5(mx5+2,my5+2,mz5+2) 1 ,ngp5(mx5+2,my5+2,mz5+2,3),drngp5(mx5+2,my5+2,mz5+2,3) dimension uc(mx,my,mz,3,mtm) c input uc(mx,my,mz) c output uc5(mx5,my5,mz5) interpolated from uc c c find div on Grid 5 from Grid 1, 2, or 3 c do 10 i=2, mx5+1 do 10 j=2, my5+1 do 10 k=2, mz5+1 if(ig5(i,j,k).eq.igrid) then ngpi=ngp5(i,j,k,1) ngpj=ngp5(i,j,k,2) ngpk=ngp5(i,j,k,3) ddr=drngp5(i,j,k,1) dds=drngp5(i,j,k,2) ddt=drngp5(i,j,k,3) c write(*,*) i,j, ngpi,ngpj,ngpk, ddr, dds,ddt alpha=ddr/dr beta=dds/ds gamma=ddt/dt c do m=1,3 fmm0 = uc(ngpi-1,ngpj-1, ngpk, m, io) fm00 = uc(ngpi-1,ngpj, ngpk, m, io) fm10 = uc(ngpi-1,ngpj+1, ngpk, m, io) f0m0 = uc(ngpi,ngpj-1, ngpk, m, io) f000 = uc(ngpi,ngpj, ngpk, m, io) f010 = uc(ngpi,ngpj+1, ngpk, m, io) f1m0 = uc(ngpi+1,ngpj-1, ngpk, m, io) f100 = uc(ngpi+1,ngpj, ngpk, m, io) f110 = uc(ngpi+1,ngpj+1, ngpk, m, io) fmm1 = uc(ngpi-1,ngpj-1,ngpk+1, m, io) fm01 = uc(ngpi-1,ngpj,ngpk+1, m, io) fm11 = uc(ngpi-1,ngpj+1,ngpk+1, m, io) f0m1 = uc(ngpi,ngpj-1,ngpk+1, m, io) f001 = uc(ngpi,ngpj,ngpk+1, m, io) f011 = uc(ngpi,ngpj+1,ngpk+1, m, io) f1m1 = uc(ngpi+1,ngpj-1,ngpk+1, m, io) f101 = uc(ngpi+1,ngpj,ngpk+1, m, io) f111 = uc(ngpi+1,ngpj+1,ngpk+1, m, io) fmmm = uc(ngpi-1,ngpj-1,ngpk-1, m, io) fm0m = uc(ngpi-1,ngpj,ngpk-1, m, io) fm1m = uc(ngpi-1,ngpj+1,ngpk-1, m, io) f0mm = uc(ngpi,ngpj-1,ngpk-1, m, io) f00m = uc(ngpi,ngpj,ngpk-1, m, io) f01m = uc(ngpi,ngpj+1,ngpk-1, m, io) f1mm = uc(ngpi+1,ngpj-1,ngpk-1, m, io) f10m = uc(ngpi+1,ngpj,ngpk-1, m, io) f11m = uc(ngpi+1,ngpj+1,ngpk-1, m, io) c000=f000 c100=0.5*(f100-fm00) c010=0.5*(f010-f0m0) c001=0.5*(f001-f00m) c200=0.5*(-2.*f000+f100+fm00) c020=0.5*(-2.*f000 + f010 + f0m0) c002=0.5*(-2.* f000 + f001 + f00m) c110=0.25*(f110 - f1m0 - fm10 + fmm0) c011=0.25*(f011 - f01m - f0m1 + f0mm) c101=0.25*(f101 - f10m - fm01 + fm0m) c210=0.25*(-2.* f010 + 2.* f0m0 + f110 - f1m0 + fm10 - fmm0) c201=0.25*(-2.* f001 + 2.* f00m + f101 - f10m + fm01 - fm0m) c120=0.25*(-2.*f100 + f110 + f1m0 + 2.*fm00 - fm10 - fmm0) c021=0.25*(-2.*f001 + 2.*f00m + f011 - f01m + f0m1 - f0mm) c102=0.25*(-2.*f100 + f101 + f10m + 2.*fm00 - fm01 - fm0m) c012=0.25*(-2.*f010 + f011 + f01m + 2.*f0m0 - f0m1 - f0mm) c111=0.125*(f111 - f11m - f1m1 + f1mm - fm11 + fm1m + fmm1 - fmmm) c220=0.25*(4.*f000 - 2.*f010 - 2.*f0m0 - 2.*f100 + f110 1 + f1m0 - 2.*fm00 + fm10 + fmm0) c202=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f100 + f101 1 + f10m - 2.*fm00 + fm01 + fm0m) c022=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f010 + f011 1 + f01m - 2.*f0m0 + f0m1 + f0mm) c211=0.125*(-2.*f011 + 2.*f01m + 2.*f0m1 - 2.*f0mm 1 + f111 - f11m - f1m1 + f1mm + fm11 - fm1m - fmm1 + fmmm) c121=0.125*(-2.*f101 + 2.*f10m + f111 - f11m 1 + f1m1 - f1mm + 2.*fm01 - 2.*fm0m - fm11 + fm1m - fmm1 + fmmm ) c112=0.125*(-2.*f110 + f111 + f11m + 2.*f1m0 1 - f1m1 - f1mm + 2.*fm10 - fm11 - fm1m - 2.*fmm0 + fmm1 + fmmm) c221=0.125*(4.*f001 - 4.*f00m - 2.*f011 + 2.*f01m 1 - 2.*f0m1 + 2.*f0mm - 2.*f101 + 2.*f10m + f111 1 - f11m + f1m1 - f1mm - 2.*fm01 + 2.*fm0m 1 + fm11 -fm1m + fmm1 - fmmm ) c212=0.125*(4.*f010 - 2.*f011 - 2.*f01m - 4.*f0m0 1 + 2.*f0m1 + 2.*f0mm - 2.*f110 1 + f111 + f11m + 2.*f1m0 - f1m1 - f1mm - 2.*fm10 + fm11 + fm1m 1 + 2.*fmm0 - fmm1 - fmmm) c122=0.125*(4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 1 + f1m1 + f1mm - 4.*fm00 + 2.*fm01 + 2.*fm0m 1 + 2.*fm10 - fm11 - fm1m + 2.*fmm0 - fmm1 - fmmm) c222=0.125*(-8.*f000 + 4.*f001 + 4.*f00m + 4.*f010 1 - 2.*f011 - 2.*f01m + 4.*f0m0 - 2.*f0m1 - 2.*f0mm 1 + 4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 + f1m1 + f1mm + 4.*fm00 1 - 2.*fm01 - 2.*fm0m - 2.*fm10 + fm11 1 + fm1m - 2.*fmm0 + fmm1 + fmmm) uc5(i,j,k,m)= 1 c000 + c100*alpha + c010*beta + c001*gamma + 1 c200*alpha**2 + c020*beta**2 + c002*gamma**2 + 1 c110*alpha*beta + c011*beta*gamma + c101*alpha*gamma + 1 c210*alpha**2*beta + c201*alpha**2*gamma 1 + c120*alpha*beta**2 + c021*beta**2*gamma + 1 c102*alpha*gamma**2 + c012*beta*gamma**2 + c111*alpha*beta*gamma 1 + c220*alpha**2*beta**2 + c202*alpha**2*gamma**2 1 + c022*beta**2*gamma**2 + 1 c211*alpha**2*beta*gamma + c121*alpha*beta**2*gamma 1 + c112*alpha*beta*gamma**2 + 1 c221*alpha**2*beta**2*gamma + c212*alpha**2*beta*gamma**2 1 + c122*alpha*beta**2*gamma**2 + 1 c222*alpha**2*beta**2*gamma**2 end do end if 10 continue return end subroutine interpRHS5b(uc5b,ig5b, ngp5b, drngp5b, 1 mx5b,my5b, igrid, uc2, mx2,my2,mz2, dr,ds,dt, xi, aa, io) c parameter(mtm=4) c mx5b=nphi, my5b=nnu dimension uc5b(mx5b+2,my5b+2,2), 1 ig5b(mx5b+2,my5b+2),ngp5b(mx5b+2,my5b+2,3) 1 , drngp5b(mx5b+2,my5b+2,3) dimension uc2(mx2,my2,mz2,3,mtm) c ccc do 10 i=2, mx5b+1 do 10 j=2, my5b+1 if(ig5b(i,j).eq.igrid) then ngpi=ngp5b(i,j,1) ngpj=ngp5b(i,j,2) ngpk=ngp5b(i,j,3) ddr=drngp5b(i,j,1) dds=drngp5b(i,j,2) ddt=drngp5b(i,j,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt c do m=1,3 fmm = uc2(ngpi-1, ngpj-1 , ngpk, m, io) fm0 = uc2(ngpi-1, ngpj , ngpk, m, io) fm1 = uc2(ngpi-1, ngpj+1 ,ngpk, m, io) f0m = uc2(ngpi, ngpj-1 ,ngpk, m, io) f00 = uc2(ngpi, ngpj ,ngpk, m, io) f01 = uc2(ngpi, ngpj+1 ,ngpk, m, io) f1m = uc2(ngpi+1, ngpj-1 ,ngpk, m, io) f10 = uc2(ngpi+1, ngpj ,ngpk, m, io) f11 = uc2(ngpi+1, ngpj+1 ,ngpk, m, io) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) uc5b(i,j,m)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do end if 10 continue return end subroutine interpE5b(uc5b,ig5b, ngp5b, drngp5b, 1 mx5b,my5b, igrid, uc2, mx2,my2,mz2, dr,ds,dt, xi, aa, io) c parameter(mtm=4) c mx5b=nphi, my5b=nnu dimension uc5b(mx5b+2,my5b+2,2), 1 ig5b(mx5b+2,my5b+2),ngp5b(mx5b+2,my5b+2,3) 1 , drngp5b(mx5b+2,my5b+2,3) dimension uc2(mx2,my2,3) c ccc do 10 i=2, mx5b+1 do 10 j=2, my5b+1 if(ig5b(i,j).eq.igrid) then ngpi=ngp5b(i,j,1) ngpj=ngp5b(i,j,2) ngpk=ngp5b(i,j,3) ddr=drngp5b(i,j,1) dds=drngp5b(i,j,2) ddt=drngp5b(i,j,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt c do m=1,3 fmm = uc2(ngpi-1, ngpj-1 , m) fm0 = uc2(ngpi-1, ngpj , m) fm1 = uc2(ngpi-1, ngpj+1 ,m) f0m = uc2(ngpi, ngpj-1 ,m) f00 = uc2(ngpi, ngpj ,m) f01 = uc2(ngpi, ngpj+1 ,m) f1m = uc2(ngpi+1, ngpj-1 ,m) f10 = uc2(ngpi+1, ngpj ,m) f11 = uc2(ngpi+1, ngpj+1 ,m) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) uc5b(i,j,m)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do end if 10 continue return end subroutine divu5(uc5ex,divu,nphi,nmuh, nnu, dphi,dmu,dnu,aa) dimension divu(nphi, nmuh, nnu), uc5ex(nphi+2,nmuh+2, nnu+2,3) icount=0 c write(*,*) 'in divu5' do j = 1, nmuh aamu= (j-.5) *dmu sinhmu=sinh(aamu) coshmu=cosh(aamu) do i = 1, nphi pphi=(i-1) * dphi cosphi=cos(pphi) sinphi=sin(pphi) do k = 1, nnu aanu= (k-.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) c g=1./sqrt(cosh(aamu)**2-sin(aanu)**2) g2=1./(cosh(aamu)**2-sin(aanu)**2) c here tmp=dVx/dx dvxdmu=(uc5ex(i+1,j+2,k+1,1)-uc5ex(i+1,j,k+1,1))/(2.*dmu) dvxdnu=(uc5ex(i+1,j+1,k+2,1)-uc5ex(i+1,j+1,k,1))/(2.*dnu) dvxdph=(uc5ex(i+2,j+1,k+1,1)-uc5ex(i,j+1,k+1,1))/(2.*dphi) dvxdnu1=dvxdnu if(k.eq.1) then dvxdnu= 1 (4.*uc5ex(i+1,j+1,k+2,1)-uc5ex(i+1,j+1,k+3,1) 1 -3.*uc5ex(i+1,j+1,k+1,1)) /(2.*dnu) end if if(k.eq.nnu) then dvxdnu= 1 (4.*uc5ex(i+1,j+1,k,1)-uc5ex(i+1,j+1,k-1,1) 1 -3.*uc5ex(i+1,j+1,k+1,1)) /(-2.*dnu) end if vx1=1./aa*(g2*sinhmu*sinnu*cosphi* dvxdmu 2 +g2*coshmu*cosnu*cosphi* dvxdnu ) 3 -1./aa*sinphi/(coshmu*sinnu)* dvxdph c here tmp=dVy/dy vy1=1./aa*(g2*sinhmu*sinnu*sinphi* 1 (uc5ex(i+1,j+2,k+1,2)-uc5ex(i+1,j,k+1,2))/(2.*dmu) 2 +g2*coshmu*cosnu*sinphi* 1 (uc5ex(i+1,j+1,k+2,2)-uc5ex(i+1,j+1,k,2))/(2.*dnu) ) 3 +1./aa*cosphi/(coshmu*sinnu)* 3 (uc5ex(i+2,j+1,k+1,2)-uc5ex(i,j+1,k+1,2))/(2.*dphi) c here tmp=dVz/dz vz1=1./aa*(g2*coshmu*cosnu* 1 (uc5ex(i+1,j+2,k+1,3)-uc5ex(i+1,j,k+1,3))/(2.*dmu) 2 -g2*sinhmu*sinnu* 1 (uc5ex(i+1,j+1,k+2,3)-uc5ex(i+1,j+1,k,3))/(2.*dnu) ) c x=aa*cosh(aamu)* sin(aanu)* cos(pphi) c y=aa*cosh(aamu)* sin(aanu)* sin(pphi) c z=aa*sinh(aamu)* cos(aanu) divu(i,j,k)=vx1+vy1+vz1 end do end do end do return end subroutine uc5bmu(uc5b,nphi, nnu, dphi,dmu, dnu,aa, amu0) dimension uc5b(nphi+2, nnu+2, 3) aamu= amu0 sinhmu=sinh(aamu) coshmu=cosh(aamu) do 100 i = 1, nphi+2 pphi=(i-2) * dphi cosphi=cos(pphi) sinphi=sin(pphi) do 100 k = 1, nnu+2 aanu= (k-1.5)* dnu cosnu=cos(aanu) sinnu=sin(aanu) g=1./sqrt(cosh(aamu)**2-sin(aanu)**2) ex=uc5b(i,k,1) ey=uc5b(i,k,2) ez=uc5b(i,k,3) c note enu=0., ephi=0. c E_x E_y E_z uc5b(i,k,1)=g*sinhmu*sinnu*cosphi*ex + 1 g*sinhmu*sinnu*sinphi*ey+ 1 g*coshmu*cosnu*ez 100 continue return end subroutine bndryuc5b(uc5b, nphi, nmuh, nnu) dimension uc5b(nphi+2, nnu+2, 3) c do k=2, nnu+1 uc5b(1,k,1)=uc5b(nphi+1,k,1) uc5b(1,k,2)=uc5b(nphi+1,k,2) uc5b(1,k,3)=uc5b(nphi+1,k,3) uc5b(nphi+2,k,1)=uc5b(2,k,1) uc5b(nphi+2,k,2)=uc5b(2,k,2) uc5b(nphi+2,k,3)=uc5b(2,k,3) end do do i= 1, nphi+2 ii=i+nphi/2 if(ii.gt. nphi+2) ii=ii-nphi do m= 1, 3 uc5b(i,1,m)= uc5b(ii,2,m) uc5b(i,nnu+2,m)=uc5b(ii,nnu+1,m) end do end do return end subroutine getuc5(uc5, uc5b, nphi, nmuh, nnu) dimension uc5(nphi+2, nmuh+2, nnu+2, 3), uc5b(nphi+2, nnu+2, 3) dimension data2(nphi,nmuh+2) real w(0:nphi/2-1), factorn integer ipp(0:2+nphi), kk(nphi) c c check ipp(0)=0 factorn=2./float(nphi) n1=nphi do i=1,n1/2 kk(2*i)=i-1 kk(2*i-1)=i-1 end do kk(2)=n1/2 j=nmuh+2 do i=2, nphi+1 do k=2, nnu+1 uc5(i,j,k,1)=uc5b(i,k,1) uc5(i,j,k,2)=uc5b(i,k,2) uc5(i,j,k,3)=uc5b(i,k,3) end do end do c icount=0 j=1 do i=2, nphi+1 do k=2, nnu+1 uc5(i,j,k,1)=uc5(i,2,nnu+3-k,1) uc5(i,j,k,2)=uc5(i,2,nnu+3-k,2) uc5(i,j,k,3)=uc5(i,2,nnu+3-k,3) c icount=icount+1 c if(icount.le.30) then c write(*,*) 'in getuc', i,j,k c write(*,*) (uc5(i,j,k,ii),ii=1,3) c end if end do end do c stop c do j=1, nmuh+2 do k=2, nnu+1 uc5(1,j,k,1)=uc5(nphi+1,j,k,1) uc5(1,j,k,2)=uc5(nphi+1,j,k,2) uc5(1,j,k,3)=uc5(nphi+1,j,k,3) uc5(nphi+2,j,k,1)=uc5(2,j,k,1) uc5(nphi+2,j,k,2)=uc5(2,j,k,2) uc5(nphi+2,j,k,3)=uc5(2,j,k,3) end do end do c k=1 c do m=1,3 c do j = 1, nmuh+2 c do i = 1, nphi c data2(i,j)=uc5(i+1,j,k+1,m) c end do c end do c do j = 1, nmuh+2 c call rdft(n1,1,data2(1,j),ipp,w) c end do c do i=1, nphi c ii=kk(i) c factor=1. c if(mod(ii,2).ne.0) factor=-1. c do j = 1, nmuh+2 c data2(i,j)=factor *data2(i,j) c end do c end do c do j = 1, nmuh+2 c call rdft(n1,-1,data2(1,j),ipp,w) c end do c do i = 1, nphi c do j = 1, nmuh+2 c uc5(i+1,j,1,m)=data2(i,j)*factorn c end do c end do c end do c k=nnu c do m=1,3 c do j = 1, nmuh+2 c do i = 1, nphi c data2(i,j)=uc5(i+1,j,k+1,m) c end do c end do c do j = 1, nmuh+2 c call rdft(n1,1,data2(1,j),ipp,w) c end do c do i=1, nphi c ii=kk(i) c factor=1. c if(mod(ii,2).ne.0) factor=-1. c do j = 1, nmuh+2 c data2(i,j)=factor *data2(i,j) c end do c end do c do j = 1, nmuh+2 c call rdft(n1,-1,data2(1,j),ipp,w) c end do c do i = 1, nphi c do j = 1, nmuh+2 c uc5(i+1,j,nnu+2,m)=data2(i,j)*factorn c end do c end do c end do c the above should be the same as the following c find values at nu=-dnu/2 and nu=pi+dnu/2 c using the fact f(-nu, phi)= f(nu, phi+pi) c f(pi+nu,phi)=f(pi-nu, phi+pi) c check this out do m= 1, 3 do j= 1, nmuh+2 do i= 1, nphi+2 ii=i+nphi/2 if(ii.gt. nphi+2) ii=ii-nphi c uc5(i,j,1,m)= uc5(i+nphi/2,j,2,m) c uc5(i,j,nnu+2,m)=uc5(i+nphi/2,j,nnu+1,m) uc5(i,j,1,m)= uc5(ii,j,2,m) uc5(i,j,nnu+2,m)=uc5(ii,j,nnu+1,m) end do end do end do c c linear extrapolation to j=nmuh+2 c note before the routine uc5ex(:,nmuh+2,:) is at mu=mu0 c from uc5b do m=1,3 do i = 1, nphi+2 do k = 1, nnu+2 uc5(i,nmuh+2,k,m)=2.* uc5(i,nmuh+2,k,m) -uc5(i,nmuh+1,k,m) end do end do end do c i=1 c j=1 c do k=1,10 c write(*,'(3i4,3e16.6)') i,j,k, (uc5(i,j,k,ii),ii=1,3) c end do return end subroutine doublediv(half, full, nphi, nmu, nnu) real half(nphi, nmu/2, nnu), full(nphi, nmu, nnu) c full system obtained from half system c mu>0 do i = 1, nphi do j = nmu/2+1, nmu do k = 1, nnu full(i,j,k)= half(i,j-nmu/2,k) end do end do end do c mu<0 by symmetry do i = 1, nphi do j = 1, nmu/2 do k = 1, nnu full(i,j,k)= full(i,nmu+1-j,nnu+1-k) end do end do end do return end subroutine reducep(halfex, full, bndrynu, 1 bndrymu, bndrymunu, nphi, nmu, nnu) real halfex(nphi+2, nmu/2+2, nnu+2), full(nphi, nmu, nnu) real bndrynu(nphi, nmu, 2) real bndrymu(nphi, nnu) real bndrymunu(nphi,2) do i = 1, nphi do j = nmu/2, nmu do k = 1, nnu halfex(i+1,j+1-nmu/2,k+1)= full(i,j,k) end do end do end do c for nu=-dnu/2 and nu=pi+dnu/2 do i = 1, nphi do j = nmu/2, nmu halfex(i+1,j+1-nmu/2,1)= bndrynu(i,j,1) halfex(i+1,j+1-nmu/2,nnu+2)= bndrynu(i,j,2) end do end do c for mu=nmu/2+2 in halfex j=nmu+1 do i = 1, nphi do k = 1, nnu halfex(i+1,j+1-nmu/2,k+1)= bndrymu(i,k) end do end do c for mu=nmu/2+2 and nu=-dnu/2, dnu/2+pi j=nmu+1 do i=1, nphi halfex(i+1,j+1-nmu/2,1)= bndrymunu(i,1) halfex(i+1,j+1-nmu/2,nnu+2)= bndrymunu(i,2) end do c for phi=-dphi and phi=2*pi do j = 1, nmu/2+2 do k = 1, nnu+2 halfex(1,j,k)=halfex(nphi+1,j,k) halfex(nphi+2,j,k)=halfex(2,j,k) end do end do return end subroutine Vn5nmu0(uc5bndry, nphi, nnu) real uc5bndry(nphi, nnu, 2) do i = 1, nphi do k = 1, nnu uc5bndry(i,k,2)= -uc5bndry(i,nnu+1-k,1) end do end do return end subroutine Vn5mu0(uc5b, uc5bndry, nphi, nnu, aphi, aaanu, amu0,aa) dimension uc5b(nphi+2, nnu+2,3), uc5bndry(nphi, nnu, 2) dimension aphi(nphi), aaanu(nnu) sinhxi=sinh(amu0) coshxi=cosh(amu0) do i=1, nphi pphi=aphi(i) cosphi=cos(pphi) sinphi=sin(pphi) do j=1, nnu aanu=aaanu(j) costh=cos(aanu) sinth=sin(aanu) c c x=aa*cosh(amu0)* sin(aanu)* cos(pphi) c y=aa*cosh(amu0)* sin(aanu)* sin(pphi) c z=aa*sinh(amu0)* cos(aanu) c uc5b(i+1,j+1,1)=exp(x+y+z) c uc5b(i+1,j+1,2)=exp(x+y+z) c uc5b(i+1,j+1,3)=exp(x+y+z) c uc5bndry(i,j,1)=aa*( 1 (uc5b(i+1,j+1,1)* cosphi + uc5b(i+1,j+1,2)* sinphi) 1 * sinhxi* sinth 1 + uc5b(i+1,j+1,3)* coshxi* costh ) end do end do return end subroutine interpPf5(uc1, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, uc2,mx2,my2,mz2, dr,ds,dt) dimension uc1(mx,my,mz,4), ig(mx,my,mz), ngp(mx,my,mz,3) 1 , drngp(mx,my,mz,3) dimension uc2(mx2,my2,mz2) c interpolating data among grids and set bndry conditions c c grid 1 from grid 2 do 10 i=nxs, nxe do 10 j=nys, nye do 10 k=nzs, nze c if(ig(i,j,k).eq.igrid) then if(ig(i,j,k).ne.0) then ngpi=ngp(i,j,k,1) ngpj=ngp(i,j,k,2) ngpk=ngp(i,j,k,3) ddr=drngp(i,j,k,1) dds=drngp(i,j,k,2) ddt=drngp(i,j,k,3) alpha=ddr/dr beta=dds/ds gamma=ddt/dt fmm0 = uc2(ngpi-1,ngpj-1, ngpk) fm00 = uc2(ngpi-1,ngpj, ngpk) fm10 = uc2(ngpi-1,ngpj+1, ngpk) f0m0 = uc2(ngpi,ngpj-1, ngpk) f000 = uc2(ngpi,ngpj, ngpk) f010 = uc2(ngpi,ngpj+1, ngpk) f1m0 = uc2(ngpi+1,ngpj-1, ngpk) f100 = uc2(ngpi+1,ngpj, ngpk) f110 = uc2(ngpi+1,ngpj+1, ngpk) fmm1 = uc2(ngpi-1,ngpj-1,ngpk+1) fm01 = uc2(ngpi-1,ngpj,ngpk+1) fm11 = uc2(ngpi-1,ngpj+1,ngpk+1) f0m1 = uc2(ngpi,ngpj-1,ngpk+1) f001 = uc2(ngpi,ngpj,ngpk+1) f011 = uc2(ngpi,ngpj+1,ngpk+1) f1m1 = uc2(ngpi+1,ngpj-1,ngpk+1) f101 = uc2(ngpi+1,ngpj,ngpk+1) f111 = uc2(ngpi+1,ngpj+1,ngpk+1) fmmm = uc2(ngpi-1,ngpj-1,ngpk-1) fm0m = uc2(ngpi-1,ngpj,ngpk-1) fm1m = uc2(ngpi-1,ngpj+1,ngpk-1) f0mm = uc2(ngpi,ngpj-1,ngpk-1) f00m = uc2(ngpi,ngpj,ngpk-1) f01m = uc2(ngpi,ngpj+1,ngpk-1) f1mm = uc2(ngpi+1,ngpj-1,ngpk-1) f10m = uc2(ngpi+1,ngpj,ngpk-1) f11m = uc2(ngpi+1,ngpj+1,ngpk-1) c000=f000 c100=0.5*(f100-fm00) c010=0.5*(f010-f0m0) c001=0.5*(f001-f00m) c200=0.5*(-2.*f000+f100+fm00) c020=0.5*(-2.*f000 + f010 + f0m0) c002=0.5*(-2.* f000 + f001 + f00m) c110=0.25*(f110 - f1m0 - fm10 + fmm0) c011=0.25*(f011 - f01m - f0m1 + f0mm) c101=0.25*(f101 - f10m - fm01 + fm0m) c210=0.25*(-2.* f010 + 2.* f0m0 + f110 - f1m0 + fm10 - fmm0) c201=0.25*(-2.* f001 + 2.* f00m + f101 - f10m + fm01 - fm0m) c120=0.25*(-2.*f100 + f110 + f1m0 + 2.*fm00 - fm10 - fmm0) c021=0.25*(-2.*f001 + 2.*f00m + f011 - f01m + f0m1 - f0mm) c102=0.25*(-2.*f100 + f101 + f10m + 2.*fm00 - fm01 - fm0m) c012=0.25*(-2.*f010 + f011 + f01m + 2.*f0m0 - f0m1 - f0mm) c111=0.125*(f111 - f11m - f1m1 + f1mm - fm11 + fm1m + fmm1 - fmmm) c220=0.25*(4.*f000 - 2.*f010 - 2.*f0m0 - 2.*f100 + f110 1 + f1m0 - 2.*fm00 + fm10 + fmm0) c202=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f100 + f101 1 + f10m - 2.*fm00 + fm01 + fm0m) c022=0.25*(4.*f000 - 2.*f001 - 2.*f00m - 2.*f010 + f011 1 + f01m - 2.*f0m0 + f0m1 + f0mm) c211=0.125*(-2.*f011 + 2.*f01m + 2.*f0m1 - 2.*f0mm 1 + f111 - f11m - f1m1 + f1mm + fm11 - fm1m - fmm1 + fmmm) c121=0.125*(-2.*f101 + 2.*f10m + f111 - f11m 1 + f1m1 - f1mm + 2.*fm01 - 2.*fm0m - fm11 + fm1m - fmm1 + fmmm ) c112=0.125*(-2.*f110 + f111 + f11m + 2.*f1m0 1 - f1m1 - f1mm + 2.*fm10 - fm11 - fm1m - 2.*fmm0 + fmm1 + fmmm) c221=0.125*(4.*f001 - 4.*f00m - 2.*f011 + 2.*f01m 1 - 2.*f0m1 + 2.*f0mm - 2.*f101 + 2.*f10m + f111 1 - f11m + f1m1 - f1mm - 2.*fm01 + 2.*fm0m 1 + fm11 -fm1m + fmm1 - fmmm ) c212=0.125*(4.*f010 - 2.*f011 - 2.*f01m - 4.*f0m0 1 + 2.*f0m1 + 2.*f0mm - 2.*f110 1 + f111 + f11m + 2.*f1m0 - f1m1 - f1mm - 2.*fm10 + fm11 + fm1m 1 + 2.*fmm0 - fmm1 - fmmm) c122=0.125*(4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 1 + f1m1 + f1mm - 4.*fm00 + 2.*fm01 + 2.*fm0m 1 + 2.*fm10 - fm11 - fm1m + 2.*fmm0 - fmm1 - fmmm) c222=0.125*(-8.*f000 + 4.*f001 + 4.*f00m + 4.*f010 1 - 2.*f011 - 2.*f01m + 4.*f0m0 - 2.*f0m1 - 2.*f0mm 1 + 4.*f100 - 2.*f101 - 2.*f10m - 2.*f110 1 + f111 + f11m - 2.*f1m0 + f1m1 + f1mm + 4.*fm00 1 - 2.*fm01 - 2.*fm0m - 2.*fm10 + fm11 1 + fm1m - 2.*fmm0 + fmm1 + fmmm) uc1(i,j,k,4)= 1 c000 + c100*alpha + c010*beta + c001*gamma + 1 c200*alpha**2 + c020*beta**2 + c002*gamma**2 + 1 c110*alpha*beta + c011*beta*gamma + c101*alpha*gamma + 1 c210*alpha**2*beta + c201*alpha**2*gamma 1 + c120*alpha*beta**2 + c021*beta**2*gamma + 1 c102*alpha*gamma**2 + c012*beta*gamma**2 + c111*alpha*beta*gamma 1 + c220*alpha**2*beta**2 + c202*alpha**2*gamma**2 1 + c022*beta**2*gamma**2 + 1 c211*alpha**2*beta*gamma + c121*alpha*beta**2*gamma 1 + c112*alpha*beta*gamma**2 + 1 c221*alpha**2*beta**2*gamma + c212*alpha**2*beta*gamma**2 1 + c122*alpha*beta**2*gamma**2 + 1 c222*alpha**2*beta**2*gamma**2 8811 format(3f10.6) 8812 format(4f10.6) end if 10 continue return end subroutine PoisSpheroid(data3, data3bndry, bndrynu, bndrymu, 1 bndrynumu, phi, amu, anu, n1, n2, n3, aa, dphi, dmu, dnu) implicit none c integer n1, n2, n3 real data3(n1,n2,n3), data3bndry(n1,n3,2) real bndrynu(n1,n2,2), bndrymu(n1,n3) real bndrynumu(n1,2) real w(0:n1/2-1), factorn integer ipp(0:2+n1), kk(n1) c for Blktri.f integer iflag, ierror real am(n2), bm(n2), cm(n2), bbm(n2) real an(n3), bn(n3), cn(n3), bbn(n3), yy(n2,n3), yyave c work space (here M=n2, N=n3) c C A ONE-DIMENSIONAL ARRAY THAT MUST BE C PROVIDED BY THE USER FOR WORK SPACE. C IF NP=1 DEFINE K=INT(LOG2(N))+1 AND C SET L=2**(K+1) THEN W MUST HAVE DIMENSION C (K-2)*L+K+5+MAX(2N,6M) real wsave(30000) c c real phi(n1), amu(n2), anu(n3), pphi, aamu, aanu, pi real aasin(n3), aacos(n3), aasinh(n2), aacosh(n2) real philength, amulength, anulength, dphi, dmu, dnu, dmu2, dnu2 real ssin, ccos, ccosh, ssinh, aa integer nphi, nmu, nnu, i, j, k, ii, imax imax=n1/2/3 ipp(0)=0 factorn=2./float(n1) nphi = n1 nmu = n2 nnu = n3 c dphi=phi(n1)-phi(n1-1) c dmu=amu(n2)-amu(n2-1) c dnu=anu(n3)-anu(n3-1) do j = 1, nmu aamu=amu(j) aasinh(j)=sinh(aamu) aacosh(j)=cosh(aamu) end do do k = 1, nnu aanu=anu(k) aasin(k)=sin(aanu) aacos(k)=cos(aanu) end do c c c kk do i=1,n1/2 kk(2*i)=i-1 kk(2*i-1)=i-1 end do kk(2)=n1/2 cc set AM, BM, CM, AN, BN, CN do j = 1, nmu c aamu=amu(j) ssinh=aasinh(j) ccosh=aacosh(j) am(j)=(1./dmu-0.5*ssinh/ccosh)/dmu bbm(j)= -2./dmu**2 cm(j)=(1./dmu+0.5*ssinh/ccosh)/dmu end do c conservative c do j = 1, nmu c aamu=amu(j) c ssinh=aasinh(j) c ccosh=aacosh(j) c am(j)=cosh(aamu-0.5*dmu)/(ccosh*dmu**2) c bbm(j)= -(cosh(aamu-0.5*dmu)+cosh(aamu+0.5*dmu))/(ccosh*dmu**2) c cm(j)=cosh(aamu+0.5*dmu)/(ccosh*dmu**2) c end do c for Neumann bndry condition j=nmu bbm(j)=bbm(j)+cm(j) j=1 bbm(j)=bbm(j)+am(j) do k = 1, nnu c aanu=anu(k) ccos=aacos(k) ssin=aasin(k) an(k)= (1./dnu- 0.5*ccos/ssin) /dnu bbn(k)= -2./dnu**2 cn(k)= (1./dnu+ 0.5*ccos/ssin) /dnu end do c conservative: c do k = 1, nnu c aanu=anu(k) c ccos=aacos(k) c ssin=aasin(k) c an(k)= sin(aanu-0.5*dnu)/(ssin*dnu**2) c bbn(k)=-(sin(aanu-0.5*dnu)+sin(aanu+0.5*dnu))/(ssin*dnu**2) c cn(k)= sin(aanu+0.5*dnu)/(ssin*dnu**2) c end do c c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) do j = 1, nmu do k = 1, nnu call rdft(n1,1,data3(1,j,k),ipp,w) end do end do do k = 1, nnu call rdft(n1,1,data3bndry(1,k,1),ipp,w) end do do k = 1, nnu call rdft(n1,1,data3bndry(1,k,2),ipp,w) end do do i=1, nphi ii=kk(i) if(ii.gt.imax) then do j = 1, nmu do k = 1, nnu data3(i,j,k)=0. end do end do end if if(ii.le.imax) then do k = 1, nnu bn(k) = bbn(k) - float(ii**2)/aasin(k)**2 end do do j = 1, nmu bm(j) = bbm(j) + float(ii**2)/aacosh(j)**2 end do c set bndry conditions for nu: bn(1)=bn(1)+(-1)**ii*an(1) bn(nnu)=bn(nnu)+(-1)**ii*cn(nnu) do j = 1, nmu do k = 1, nnu yy(j,k)=data3(i,j,k)*(aasinh(j)**2+aacos(k)**2)*aa**2 c yy(j,k)=data3(i,j,k)*aa**2 end do end do c if(ii.eq.0) then c do j = 1, nmu c do k = 1, nnu c yy(j,k)=(data3(i,j,k)-0.0001*0.) c 1 *(aasinh(j)**2+aacos(k)**2)*aa**2 c end do c end do c end if c bndry conditions at surface j=nmu do k=1, nnu yy(j,k)=yy(j,k)-cm(j)*data3bndry(i,k,1)*dmu end do j=1 do k=1, nnu yy(j,k)=yy(j,k)+am(j)*data3bndry(i,k,2)*dmu end do c if(i.le.4) then c write(*,*) 'yy=', i, yy(5,5), yy(5,6), yy(5,7) c write(*,*) 'An=', an(2), an(3), an(4) c write(*,*) 'Bn=', bn(2), bn(3), bn(4) c write(*,*) 'Cn=', cn(2), cn(3), cn(4) c write(*,*) 'Am=', am(2), am(3), am(4) c write(*,*) 'Bm=', bm(2), bm(3), bm(4) c write(*,*) 'Cm=', cm(2), cm(3), cm(4) c end if c iflag=0 c CALL BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,IERROR,W) CALL BLKTRI (IFLaG,1,Nnu,AN,BN,CN,1,nmu,AM,BM,CM,nmu, 1 yy,IERROR,Wsave) iflag=1 CALL BLKTRI (IFLaG,1,Nnu,AN,BN,CN,1,nmu,AM,BM,CM,nmu, 1 yy,IERROR,Wsave) c write(*,*) i, ierror do j = 1, nmu do k = 1, nnu data3(i,j,k)=yy(j,k) end do end do if(ii.eq.0) then yyave=0. do j = 1, nmu do k = 1, nnu yyave=yyave+yy(j,k) end do end do yyave=yyave/float(nmu*nnu) do j = 1, nmu do k = 1, nnu data3(i,j,k)=yy(j,k)-yyave c data3(i,j,k)=0. end do end do end if end if c for anu=-dnu/2 and anu=pi+dnu/2 if(mod(ii,2).eq.0) then do j=1, nmu bndrynu(i,j,1)=data3(i,j,1) bndrynu(i,j,2)=data3(i,j,nnu) end do else do j=1, nmu bndrynu(i,j,1)=-data3(i,j,1) bndrynu(i,j,2)=-data3(i,j,nnu) end do end if c for amu=amu0+dmu/2 do k = 1, nnu bndrymu(i,k)= data3(i, nmu, k)+ data3bndry(i,k,1) *dmu end do c for anu=-dnu/2 and anu=pi+dnu/2 and amu=amu0+dmu0/2 if(mod(ii,2).eq.0) then bndrynumu(i,1)=bndrymu(i,1) bndrynumu(i,2)=bndrymu(i,nnu) else bndrynumu(i,1)=-bndrymu(i,1) bndrynumu(i,2)=-bndrymu(i,nnu) end if end do do j = 1, nmu do k = 1, nnu call rdft(n1,-1,data3(1,j,k),ipp,w) end do end do c for anu=0 and pi do j=1, nmu call rdft(n1,-1,bndrynu(1,j,1),ipp,w) call rdft(n1,-1,bndrynu(1,j,2),ipp,w) end do c for amu=amu0+dmu/2 do k=1, nnu call rdft(n1,-1,bndrymu(1,k),ipp,w) end do c for anu=-dnu/2, pi+dnu/2 and mu=amu0+dmu/2 call rdft(n1,-1,bndrynumu(1,1),ipp,w) call rdft(n1,-1,bndrynumu(1,2),ipp,w) c call date_and_time(real_clock(1),real_clock(2)) c print *, real_clock(1), real_clock(2) do i = 1, nphi do j = 1, nmu do k = 1, nnu data3(i,j,k)=data3(i,j,k)*factorn end do end do end do do i = 1, nphi do j = 1, nmu bndrynu(i,j,1)=bndrynu(i,j,1)*factorn bndrynu(i,j,2)=bndrynu(i,j,2)*factorn end do end do do i = 1, nphi do k = 1, nnu bndrymu(i,k)=bndrymu(i,k)*factorn end do end do do i = 1, nphi bndrynumu(i,1)=bndrynumu(i,1)*factorn bndrynumu(i,2)=bndrynumu(i,2)*factorn end do return end c file blktri.f c c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c . . c . copyright (c) 1999 by UCAR . c . . c . UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH . c . . c . all rights reserved . c . . c . . c . FISHPACK version 4.0 . c . . c . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c c C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A C K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 4.0 , JUNE 1999) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C c SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y, c + IERROR,W) ! Fast Fourier/Cosine/Sine Transform ! dimension :one ! data length :power of 2 ! decimation :frequency ! radix :split-radix ! data :inplace ! table :use ! subroutines ! cdft: Complex Discrete Fourier Transform ! rdft: Real Discrete Fourier Transform ! ddct: Discrete Cosine Transform ! ddst: Discrete Sine Transform ! dfct: Cosine Transform of RDFT (Real Symmetric DFT) ! dfst: Sine Transform of RDFT (Real Anti-symmetric DFT) ! ! ! -------- Complex DFT (Discrete Fourier Transform) -------- ! [definition] ! ! X(k) = sum_j=0^n-1 x(j)*exp(2*pi*i*j*k/n), 0<=k ! X(k) = sum_j=0^n-1 x(j)*exp(-2*pi*i*j*k/n), 0<=k ! ip(0) = 0 ! first time only ! call cdft(2*n, 1, a, ip, w) ! ! ip(0) = 0 ! first time only ! call cdft(2*n, -1, a, ip, w) ! [parameters] ! 2*n :data length (integer) ! n >= 1, n = power of 2 ! a(0:2*n-1) :input/output data (real*8) ! input data ! a(2*j) = Re(x(j)), ! a(2*j+1) = Im(x(j)), 0<=j= 2+sqrt(n) ! strictly, ! length of ip >= ! 2+2**(int(log(n+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n/2-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! call cdft(2*n, -1, a, ip, w) ! is ! call cdft(2*n, 1, a, ip, w) ! do j = 0, 2 * n - 1 ! a(j) = a(j) / n ! end do ! . ! ! ! -------- Real DFT / Inverse of Real DFT -------- ! [definition] ! RDFT ! R(k) = sum_j=0^n-1 a(j)*cos(2*pi*j*k/n), 0<=k<=n/2 ! I(k) = sum_j=0^n-1 a(j)*sin(2*pi*j*k/n), 0 IRDFT (excluding scale) ! a(k) = (R(0) + R(n/2)*cos(pi*k))/2 + ! sum_j=1^n/2-1 R(j)*cos(2*pi*j*k/n) + ! sum_j=1^n/2-1 I(j)*sin(2*pi*j*k/n), 0<=k ! ip(0) = 0 ! first time only ! call rdft(n, 1, a, ip, w) ! ! ip(0) = 0 ! first time only ! call rdft(n, -1, a, ip, w) ! [parameters] ! n :data length (integer) ! n >= 2, n = power of 2 ! a(0:n-1) :input/output data (real*8) ! ! output data ! a(2*k) = R(k), 0<=k ! input data ! a(2*j) = R(j), 0<=j= 2+sqrt(n/2) ! strictly, ! length of ip >= ! 2+2**(int(log(n/2+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n/2-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! call rdft(n, 1, a, ip, w) ! is ! call rdft(n, -1, a, ip, w) ! do j = 0, n - 1 ! a(j) = a(j) * 2 / n ! end do ! . ! ! ! -------- DCT (Discrete Cosine Transform) / Inverse of DCT -------- ! [definition] ! IDCT (excluding scale) ! C(k) = sum_j=0^n-1 a(j)*cos(pi*j*(k+1/2)/n), 0<=k DCT ! C(k) = sum_j=0^n-1 a(j)*cos(pi*(j+1/2)*k/n), 0<=k ! ip(0) = 0 ! first time only ! call ddct(n, 1, a, ip, w) ! ! ip(0) = 0 ! first time only ! call ddct(n, -1, a, ip, w) ! [parameters] ! n :data length (integer) ! n >= 2, n = power of 2 ! a(0:n-1) :input/output data (real*8) ! output data ! a(k) = C(k), 0<=k= 2+sqrt(n/2) ! strictly, ! length of ip >= ! 2+2**(int(log(n/2+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n*5/4-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! call ddct(n, -1, a, ip, w) ! is ! a(0) = a(0) / 2 ! call ddct(n, 1, a, ip, w) ! do j = 0, n - 1 ! a(j) = a(j) * 2 / n ! end do ! . ! ! ! -------- DST (Discrete Sine Transform) / Inverse of DST -------- ! [definition] ! IDST (excluding scale) ! S(k) = sum_j=1^n A(j)*sin(pi*j*(k+1/2)/n), 0<=k DST ! S(k) = sum_j=0^n-1 a(j)*sin(pi*(j+1/2)*k/n), 0 ! ip(0) = 0 ! first time only ! call ddst(n, 1, a, ip, w) ! ! ip(0) = 0 ! first time only ! call ddst(n, -1, a, ip, w) ! [parameters] ! n :data length (integer) ! n >= 2, n = power of 2 ! a(0:n-1) :input/output data (real*8) ! ! input data ! a(j) = A(j), 0 ! output data ! a(k) = S(k), 0= 2+sqrt(n/2) ! strictly, ! length of ip >= ! 2+2**(int(log(n/2+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n*5/4-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! call ddst(n, -1, a, ip, w) ! is ! a(0) = a(0) / 2 ! call ddst(n, 1, a, ip, w) ! do j = 0, n - 1 ! a(j) = a(j) * 2 / n ! end do ! . ! ! ! -------- Cosine Transform of RDFT (Real Symmetric DFT) -------- ! [definition] ! C(k) = sum_j=0^n a(j)*cos(pi*j*k/n), 0<=k<=n ! [usage] ! ip(0) = 0 ! first time only ! call dfct(n, a, t, ip, w) ! [parameters] ! n :data length - 1 (integer) ! n >= 2, n = power of 2 ! a(0:n) :input/output data (real*8) ! output data ! a(k) = C(k), 0<=k<=n ! t(0:n/2) :work area (real*8) ! ip(0:*) :work area for bit reversal (integer) ! length of ip >= 2+sqrt(n/4) ! strictly, ! length of ip >= ! 2+2**(int(log(n/4+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n*5/8-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! a(0) = a(0) / 2 ! a(n) = a(n) / 2 ! call dfct(n, a, t, ip, w) ! is ! a(0) = a(0) / 2 ! a(n) = a(n) / 2 ! call dfct(n, a, t, ip, w) ! do j = 0, n ! a(j) = a(j) * 2 / n ! end do ! . ! ! ! -------- Sine Transform of RDFT (Real Anti-symmetric DFT) -------- ! [definition] ! S(k) = sum_j=1^n-1 a(j)*sin(pi*j*k/n), 0= 2, n = power of 2 ! a(0:n-1) :input/output data (real*8) ! output data ! a(k) = S(k), 0= 2+sqrt(n/4) ! strictly, ! length of ip >= ! 2+2**(int(log(n/4+0.5)/log(2.0))/2). ! ip(0),ip(1) are pointers of the cos/sin table. ! w(0:n*5/8-1) :cos/sin table (real*8) ! w(),ip() are initialized if ip(0) = 0. ! [remark] ! Inverse of ! call dfst(n, a, t, ip, w) ! is ! call dfst(n, a, t, ip, w) ! do j = 1, n - 1 ! a(j) = a(j) * 2 / n ! end do ! . ! ! ! Appendix : ! The cos/sin table is recalculated when the larger table required. ! w() and ip() are compatible with all routines. ! ! subroutine cdft(n, isgn, a, ip, w) integer n, isgn, ip(0 : *), nw real*8 a(0 : n - 1), w(0 : *) nw = ip(0) if (n .gt. 4 * nw) then nw = n / 4 call makewt(nw, ip, w) end if if (isgn .ge. 0) then call cftfsub(n, a, ip, nw, w) else call cftbsub(n, a, ip, nw, w) end if end ! subroutine rdft(n, isgn, a, ip, w) integer n, isgn, ip(0 : *), nw, nc real*8 a(0 : n - 1), w(0 : *), xi nw = ip(0) if (n .gt. 4 * nw) then nw = n / 4 call makewt(nw, ip, w) end if nc = ip(1) if (n .gt. 4 * nc) then nc = n / 4 call makect(nc, ip, w(nw)) end if if (isgn .ge. 0) then if (n .gt. 4) then call cftfsub(n, a, ip, nw, w) call rftfsub(n, a, nc, w(nw)) else if (n .eq. 4) then call cftfsub(n, a, ip, nw, w) end if xi = a(0) - a(1) a(0) = a(0) + a(1) a(1) = xi else a(1) = 0.5d0 * (a(0) - a(1)) a(0) = a(0) - a(1) if (n .gt. 4) then call rftbsub(n, a, nc, w(nw)) call cftbsub(n, a, ip, nw, w) else if (n .eq. 4) then call cftbsub(n, a, ip, nw, w) end if end if end ! subroutine ddct(n, isgn, a, ip, w) integer n, isgn, ip(0 : *), j, nw, nc real*8 a(0 : n - 1), w(0 : *), xr nw = ip(0) if (n .gt. 4 * nw) then nw = n / 4 call makewt(nw, ip, w) end if nc = ip(1) if (n .gt. nc) then nc = n call makect(nc, ip, w(nw)) end if if (isgn .lt. 0) then xr = a(n - 1) do j = n - 2, 2, -2 a(j + 1) = a(j) - a(j - 1) a(j) = a(j) + a(j - 1) end do a(1) = a(0) - xr a(0) = a(0) + xr if (n .gt. 4) then call rftbsub(n, a, nc, w(nw)) call cftbsub(n, a, ip, nw, w) else if (n .eq. 4) then call cftbsub(n, a, ip, nw, w) end if end if call dctsub(n, a, nc, w(nw)) if (isgn .ge. 0) then if (n .gt. 4) then call cftfsub(n, a, ip, nw, w) call rftfsub(n, a, nc, w(nw)) else if (n .eq. 4) then call cftfsub(n, a, ip, nw, w) end if xr = a(0) - a(1) a(0) = a(0) + a(1) do j = 2, n - 2, 2 a(j - 1) = a(j) - a(j + 1) a(j) = a(j) + a(j + 1) end do a(n - 1) = xr end if end ! subroutine ddst(n, isgn, a, ip, w) integer n, isgn, ip(0 : *), j, nw, nc real*8 a(0 : n - 1), w(0 : *), xr nw = ip(0) if (n .gt. 4 * nw) then nw = n / 4 call makewt(nw, ip, w) end if nc = ip(1) if (n .gt. nc) then nc = n call makect(nc, ip, w(nw)) end if if (isgn .lt. 0) then xr = a(n - 1) do j = n - 2, 2, -2 a(j + 1) = -a(j) - a(j - 1) a(j) = a(j) - a(j - 1) end do a(1) = a(0) + xr a(0) = a(0) - xr if (n .gt. 4) then call rftbsub(n, a, nc, w(nw)) call cftbsub(n, a, ip, nw, w) else if (n .eq. 4) then call cftbsub(n, a, ip, nw, w) end if end if call dstsub(n, a, nc, w(nw)) if (isgn .ge. 0) then if (n .gt. 4) then call cftfsub(n, a, ip, nw, w) call rftfsub(n, a, nc, w(nw)) else if (n .eq. 4) then call cftfsub(n, a, ip, nw, w) end if xr = a(0) - a(1) a(0) = a(0) + a(1) do j = 2, n - 2, 2 a(j - 1) = -a(j) - a(j + 1) a(j) = a(j) - a(j + 1) end do a(n - 1) = -xr end if end ! subroutine dfct(n, a, t, ip, w) integer n, ip(0 : *), j, k, l, m, mh, nw, nc real*8 a(0 : n), t(0 : n / 2), w(0 : *), xr, xi, yr, yi nw = ip(0) if (n .gt. 8 * nw) then nw = n / 8 call makewt(nw, ip, w) end if nc = ip(1) if (n .gt. 2 * nc) then nc = n / 2 call makect(nc, ip, w(nw)) end if m = n / 2 yi = a(m) xi = a(0) + a(n) a(0) = a(0) - a(n) t(0) = xi - yi t(m) = xi + yi if (n .gt. 2) then mh = m / 2 do j = 1, mh - 1 k = m - j xr = a(j) - a(n - j) xi = a(j) + a(n - j) yr = a(k) - a(n - k) yi = a(k) + a(n - k) a(j) = xr a(k) = yr t(j) = xi - yi t(k) = xi + yi end do t(mh) = a(mh) + a(n - mh) a(mh) = a(mh) - a(n - mh) call dctsub(m, a, nc, w(nw)) if (m .gt. 4) then call cftfsub(m, a, ip, nw, w) call rftfsub(m, a, nc, w(nw)) else if (m .eq. 4) then call cftfsub(m, a, ip, nw, w) end if a(n - 1) = a(0) - a(1) a(1) = a(0) + a(1) do j = m - 2, 2, -2 a(2 * j + 1) = a(j) + a(j + 1) a(2 * j - 1) = a(j) - a(j + 1) end do l = 2 m = mh do while (m .ge. 2) call dctsub(m, t, nc, w(nw)) if (m .gt. 4) then call cftfsub(m, t, ip, nw, w) call rftfsub(m, t, nc, w(nw)) else if (m .eq. 4) then call cftfsub(m, t, ip, nw, w) end if a(n - l) = t(0) - t(1) a(l) = t(0) + t(1) k = 0 do j = 2, m - 2, 2 k = k + 4 * l a(k - l) = t(j) - t(j + 1) a(k + l) = t(j) + t(j + 1) end do l = 2 * l mh = m / 2 do j = 0, mh - 1 k = m - j t(j) = t(m + k) - t(m + j) t(k) = t(m + k) + t(m + j) end do t(mh) = t(m + mh) m = mh end do a(l) = t(0) a(n) = t(2) - t(1) a(0) = t(2) + t(1) else a(1) = a(0) a(2) = t(0) a(0) = t(1) end if end ! subroutine dfst(n, a, t, ip, w) integer n, ip(0 : *), j, k, l, m, mh, nw, nc real*8 a(0 : n - 1), t(0 : n / 2 - 1), w(0 : *), xr, xi, yr, yi nw = ip(0) if (n .gt. 8 * nw) then nw = n / 8 call makewt(nw, ip, w) end if nc = ip(1) if (n .gt. 2 * nc) then nc = n / 2 call makect(nc, ip, w(nw)) end if if (n .gt. 2) then m = n / 2 mh = m / 2 do j = 1, mh - 1 k = m - j xr = a(j) + a(n - j) xi = a(j) - a(n - j) yr = a(k) + a(n - k) yi = a(k) - a(n - k) a(j) = xr a(k) = yr t(j) = xi + yi t(k) = xi - yi end do t(0) = a(mh) - a(n - mh) a(mh) = a(mh) + a(n - mh) a(0) = a(m) call dstsub(m, a, nc, w(nw)) if (m .gt. 4) then call cftfsub(m, a, ip, nw, w) call rftfsub(m, a, nc, w(nw)) else if (m .eq. 4) then call cftfsub(m, a, ip, nw, w) end if a(n - 1) = a(1) - a(0) a(1) = a(0) + a(1) do j = m - 2, 2, -2 a(2 * j + 1) = a(j) - a(j + 1) a(2 * j - 1) = -a(j) - a(j + 1) end do l = 2 m = mh do while (m .ge. 2) call dstsub(m, t, nc, w(nw)) if (m .gt. 4) then call cftfsub(m, t, ip, nw, w) call rftfsub(m, t, nc, w(nw)) else if (m .eq. 4) then call cftfsub(m, t, ip, nw, w) end if a(n - l) = t(1) - t(0) a(l) = t(0) + t(1) k = 0 do j = 2, m - 2, 2 k = k + 4 * l a(k - l) = -t(j) - t(j + 1) a(k + l) = t(j) - t(j + 1) end do l = 2 * l mh = m / 2 do j = 1, mh - 1 k = m - j t(j) = t(m + k) + t(m + j) t(k) = t(m + k) - t(m + j) end do t(0) = t(m + mh) m = mh end do a(l) = t(0) end if a(0) = 0 end ! ! -------- initializing routines -------- ! subroutine makewt(nw, ip, w) integer nw, ip(0 : *), j, nwh, nw0, nw1 real*8 w(0 : nw - 1), delta, wn4r, wk1r, wk1i, wk3r, wk3i ip(0) = nw ip(1) = 1 if (nw .gt. 2) then nwh = nw / 2 delta = atan(1.0d0) / nwh wn4r = cos(delta * nwh) w(0) = 1 w(1) = wn4r if (nwh .eq. 4) then w(2) = cos(delta * 2) w(3) = sin(delta * 2) else if (nwh .gt. 4) then call makeipt(nw, ip) w(2) = 0.5d0 / cos(delta * 2) w(3) = 0.5d0 / cos(delta * 6) do j = 4, nwh - 4, 4 w(j) = cos(delta * j) w(j + 1) = sin(delta * j) w(j + 2) = cos(3 * delta * j) w(j + 3) = -sin(3 * delta * j) end do end if nw0 = 0 do while (nwh .gt. 2) nw1 = nw0 + nwh nwh = nwh / 2 w(nw1) = 1 w(nw1 + 1) = wn4r if (nwh .eq. 4) then wk1r = w(nw0 + 4) wk1i = w(nw0 + 5) w(nw1 + 2) = wk1r w(nw1 + 3) = wk1i else if (nwh .gt. 4) then wk1r = w(nw0 + 4) wk3r = w(nw0 + 6) w(nw1 + 2) = 0.5d0 / wk1r w(nw1 + 3) = 0.5d0 / wk3r do j = 4, nwh - 4, 4 wk1r = w(nw0 + 2 * j) wk1i = w(nw0 + 2 * j + 1) wk3r = w(nw0 + 2 * j + 2) wk3i = w(nw0 + 2 * j + 3) w(nw1 + j) = wk1r w(nw1 + j + 1) = wk1i w(nw1 + j + 2) = wk3r w(nw1 + j + 3) = wk3i end do end if nw0 = nw1 end do end if end ! subroutine makeipt(nw, ip) integer nw, ip(0 : *), j, l, m, m2, p, q ip(2) = 0 ip(3) = 16 m = 2 l = nw do while (l .gt. 32) m2 = 2 * m q = 8 * m2 do j = m, m2 - 1 p = 4 * ip(j) ip(m + j) = p ip(m2 + j) = p + q end do m = m2 l = l / 4 end do end ! subroutine makect(nc, ip, c) integer nc, ip(0 : *), j, nch real*8 c(0 : nc - 1), delta ip(1) = nc if (nc .gt. 1) then nch = nc / 2 delta = atan(1.0d0) / nch c(0) = cos(delta * nch) c(nch) = 0.5d0 * c(0) do j = 1, nch - 1 c(j) = 0.5d0 * cos(delta * j) c(nc - j) = 0.5d0 * sin(delta * j) end do end if end ! ! -------- child routines -------- ! subroutine cftfsub(n, a, ip, nw, w) integer n, ip(0 : *), nw real*8 a(0 : n - 1), w(0 : nw - 1) if (n .gt. 8) then if (n .gt. 32) then call cftf1st(n, a, w(nw - n / 4)) if (n .gt. 512) then call cftrec4(n, a, nw, w) else if (n .gt. 128) then call cftleaf(n, 1, a, nw, w) else call cftfx41(n, a, nw, w) end if call bitrv2(n, ip, a) else if (n .eq. 32) then call cftf161(a, w(nw - 8)) call bitrv216(a) else call cftf081(a, w) call bitrv208(a) end if else if (n .eq. 8) then call cftf040(a) else if (n .eq. 4) then call cftx020(a) end if end ! subroutine cftbsub(n, a, ip, nw, w) integer n, ip(0 : *), nw real*8 a(0 : n - 1), w(0 : nw - 1) if (n .gt. 8) then if (n .gt. 32) then call cftb1st(n, a, w(nw - n / 4)) if (n .gt. 512) then call cftrec4(n, a, nw, w) else if (n .gt. 128) then call cftleaf(n, 1, a, nw, w) else call cftfx41(n, a, nw, w) end if call bitrv2conj(n, ip, a) else if (n .eq. 32) then call cftf161(a, w(nw - 8)) call bitrv216neg(a) else call cftf081(a, w) call bitrv208neg(a) end if else if (n .eq. 8) then call cftb040(a) else if (n .eq. 4) then call cftx020(a) end if end ! subroutine bitrv2(n, ip, a) integer n, ip(0 : *), j, j1, k, k1, l, m, nh, nm real*8 a(0 : n - 1), xr, xi, yr, yi m = 1 l = n / 4 do while (l .gt. 8) m = m * 2 l = l / 4 end do nh = n / 2 nm = 4 * m if (l .eq. 8) then do k = 0, m - 1 do j = 0, k - 1 j1 = 4 * j + 2 * ip(m + k) k1 = 4 * k + 2 * ip(m + j) xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh k1 = k1 + 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 + nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + 2 k1 = k1 + nh xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh k1 = k1 - 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 + nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do k1 = 4 * k + 2 * ip(m + k) j1 = k1 + 2 k1 = k1 + nh xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - 2 k1 = k1 - nh xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh + 2 k1 = k1 + nh + 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh + nm k1 = k1 + 2 * nm - 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do else do k = 0, m - 1 do j = 0, k - 1 j1 = 4 * j + ip(m + k) k1 = 4 * k + ip(m + j) xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh k1 = k1 + 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + 2 k1 = k1 + nh xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh k1 = k1 - 2 xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do k1 = 4 * k + ip(m + k) j1 = k1 + 2 k1 = k1 + nh xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + nm xr = a(j1) xi = a(j1 + 1) yr = a(k1) yi = a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do end if end ! subroutine bitrv2conj(n, ip, a) integer n, ip(0 : *), j, j1, k, k1, l, m, nh, nm real*8 a(0 : n - 1), xr, xi, yr, yi m = 1 l = n / 4 do while (l .gt. 8) m = m * 2 l = l / 4 end do nh = n / 2 nm = 4 * m if (l .eq. 8) then do k = 0, m - 1 do j = 0, k - 1 j1 = 4 * j + 2 * ip(m + k) k1 = 4 * k + 2 * ip(m + j) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh k1 = k1 + 2 xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 + nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + 2 k1 = k1 + nh xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh k1 = k1 - 2 xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 + nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do k1 = 4 * k + 2 * ip(m + k) j1 = k1 + 2 k1 = k1 + nh a(j1 - 1) = -a(j1 - 1) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi a(k1 + 3) = -a(k1 + 3) j1 = j1 + nm k1 = k1 + 2 * nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 - nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - 2 k1 = k1 - nh xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh + 2 k1 = k1 + nh + 2 xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh + nm k1 = k1 + 2 * nm - 2 a(j1 - 1) = -a(j1 - 1) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi a(k1 + 3) = -a(k1 + 3) end do else do k = 0, m - 1 do j = 0, k - 1 j1 = 4 * j + ip(m + k) k1 = 4 * k + ip(m + j) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nh k1 = k1 + 2 xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + 2 k1 = k1 + nh xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 + nm k1 = k1 + nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nh k1 = k1 - 2 xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi j1 = j1 - nm k1 = k1 - nm xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi end do k1 = 4 * k + ip(m + k) j1 = k1 + 2 k1 = k1 + nh a(j1 - 1) = -a(j1 - 1) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi a(k1 + 3) = -a(k1 + 3) j1 = j1 + nm k1 = k1 + nm a(j1 - 1) = -a(j1 - 1) xr = a(j1) xi = -a(j1 + 1) yr = a(k1) yi = -a(k1 + 1) a(j1) = yr a(j1 + 1) = yi a(k1) = xr a(k1 + 1) = xi a(k1 + 3) = -a(k1 + 3) end do end if end ! subroutine bitrv216(a) real*8 a(0 : 31), x1r, x1i, x2r, x2i, x3r, x3i, x4r, x4i real*8 x5r, x5i, x7r, x7i, x8r, x8i, x10r, x10i real*8 x11r, x11i, x12r, x12i, x13r, x13i, x14r, x14i x1r = a(2) x1i = a(3) x2r = a(4) x2i = a(5) x3r = a(6) x3i = a(7) x4r = a(8) x4i = a(9) x5r = a(10) x5i = a(11) x7r = a(14) x7i = a(15) x8r = a(16) x8i = a(17) x10r = a(20) x10i = a(21) x11r = a(22) x11i = a(23) x12r = a(24) x12i = a(25) x13r = a(26) x13i = a(27) x14r = a(28) x14i = a(29) a(2) = x8r a(3) = x8i a(4) = x4r a(5) = x4i a(6) = x12r a(7) = x12i a(8) = x2r a(9) = x2i a(10) = x10r a(11) = x10i a(14) = x14r a(15) = x14i a(16) = x1r a(17) = x1i a(20) = x5r a(21) = x5i a(22) = x13r a(23) = x13i a(24) = x3r a(25) = x3i a(26) = x11r a(27) = x11i a(28) = x7r a(29) = x7i end ! subroutine bitrv216neg(a) real*8 a(0 : 31), x1r, x1i, x2r, x2i, x3r, x3i, x4r, x4i real*8 x5r, x5i, x6r, x6i, x7r, x7i, x8r, x8i real*8 x9r, x9i, x10r, x10i, x11r, x11i, x12r, x12i real*8 x13r, x13i, x14r, x14i, x15r, x15i x1r = a(2) x1i = a(3) x2r = a(4) x2i = a(5) x3r = a(6) x3i = a(7) x4r = a(8) x4i = a(9) x5r = a(10) x5i = a(11) x6r = a(12) x6i = a(13) x7r = a(14) x7i = a(15) x8r = a(16) x8i = a(17) x9r = a(18) x9i = a(19) x10r = a(20) x10i = a(21) x11r = a(22) x11i = a(23) x12r = a(24) x12i = a(25) x13r = a(26) x13i = a(27) x14r = a(28) x14i = a(29) x15r = a(30) x15i = a(31) a(2) = x15r a(3) = x15i a(4) = x7r a(5) = x7i a(6) = x11r a(7) = x11i a(8) = x3r a(9) = x3i a(10) = x13r a(11) = x13i a(12) = x5r a(13) = x5i a(14) = x9r a(15) = x9i a(16) = x1r a(17) = x1i a(18) = x14r a(19) = x14i a(20) = x6r a(21) = x6i a(22) = x10r a(23) = x10i a(24) = x2r a(25) = x2i a(26) = x12r a(27) = x12i a(28) = x4r a(29) = x4i a(30) = x8r a(31) = x8i end ! subroutine bitrv208(a) real*8 a(0 : 15), x1r, x1i, x3r, x3i, x4r, x4i, x6r, x6i x1r = a(2) x1i = a(3) x3r = a(6) x3i = a(7) x4r = a(8) x4i = a(9) x6r = a(12) x6i = a(13) a(2) = x4r a(3) = x4i a(6) = x6r a(7) = x6i a(8) = x1r a(9) = x1i a(12) = x3r a(13) = x3i end ! subroutine bitrv208neg(a) real*8 a(0 : 15), x1r, x1i, x2r, x2i, x3r, x3i, x4r, x4i real*8 x5r, x5i, x6r, x6i, x7r, x7i x1r = a(2) x1i = a(3) x2r = a(4) x2i = a(5) x3r = a(6) x3i = a(7) x4r = a(8) x4i = a(9) x5r = a(10) x5i = a(11) x6r = a(12) x6i = a(13) x7r = a(14) x7i = a(15) a(2) = x7r a(3) = x7i a(4) = x3r a(5) = x3i a(6) = x5r a(7) = x5i a(8) = x1r a(9) = x1i a(10) = x6r a(11) = x6i a(12) = x2r a(13) = x2i a(14) = x4r a(15) = x4i end ! subroutine cftf1st(n, a, w) integer n, j, j0, j1, j2, j3, k, m, mh real*8 a(0 : n - 1), w(0 : *) real*8 wn4r, csc1, csc3, wk1r, wk1i, wk3r, wk3i real*8 wd1r, wd1i, wd3r, wd3i real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i mh = n / 8 m = 2 * mh j1 = m j2 = j1 + m j3 = j2 + m x0r = a(0) + a(j2) x0i = a(1) + a(j2 + 1) x1r = a(0) - a(j2) x1i = a(1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(0) = x0r + x2r a(1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i a(j2) = x1r - x3i a(j2 + 1) = x1i + x3r a(j3) = x1r + x3i a(j3 + 1) = x1i - x3r wn4r = w(1) csc1 = w(2) csc3 = w(3) wd1r = 1 wd1i = 0 wd3r = 1 wd3i = 0 k = 0 do j = 2, mh - 6, 4 k = k + 4 wk1r = csc1 * (wd1r + w(k)) wk1i = csc1 * (wd1i + w(k + 1)) wk3r = csc3 * (wd3r + w(k + 2)) wk3i = csc3 * (wd3i + w(k + 3)) wd1r = w(k) wd1i = w(k + 1) wd3r = w(k + 2) wd3i = w(k + 3) j1 = j + m j2 = j1 + m j3 = j2 + m x0r = a(j) + a(j2) x0i = a(j + 1) + a(j2 + 1) x1r = a(j) - a(j2) x1i = a(j + 1) - a(j2 + 1) y0r = a(j + 2) + a(j2 + 2) y0i = a(j + 3) + a(j2 + 3) y1r = a(j + 2) - a(j2 + 2) y1i = a(j + 3) - a(j2 + 3) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) y2r = a(j1 + 2) + a(j3 + 2) y2i = a(j1 + 3) + a(j3 + 3) y3r = a(j1 + 2) - a(j3 + 2) y3i = a(j1 + 3) - a(j3 + 3) a(j) = x0r + x2r a(j + 1) = x0i + x2i a(j + 2) = y0r + y2r a(j + 3) = y0i + y2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i a(j1 + 2) = y0r - y2r a(j1 + 3) = y0i - y2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wk1r * x0r - wk1i * x0i a(j2 + 1) = wk1r * x0i + wk1i * x0r x0r = y1r - y3i x0i = y1i + y3r a(j2 + 2) = wd1r * x0r - wd1i * x0i a(j2 + 3) = wd1r * x0i + wd1i * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3) = wk3r * x0r + wk3i * x0i a(j3 + 1) = wk3r * x0i - wk3i * x0r x0r = y1r + y3i x0i = y1i - y3r a(j3 + 2) = wd3r * x0r + wd3i * x0i a(j3 + 3) = wd3r * x0i - wd3i * x0r j0 = m - j j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) + a(j2) x0i = a(j0 + 1) + a(j2 + 1) x1r = a(j0) - a(j2) x1i = a(j0 + 1) - a(j2 + 1) y0r = a(j0 - 2) + a(j2 - 2) y0i = a(j0 - 1) + a(j2 - 1) y1r = a(j0 - 2) - a(j2 - 2) y1i = a(j0 - 1) - a(j2 - 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) y2r = a(j1 - 2) + a(j3 - 2) y2i = a(j1 - 1) + a(j3 - 1) y3r = a(j1 - 2) - a(j3 - 2) y3i = a(j1 - 1) - a(j3 - 1) a(j0) = x0r + x2r a(j0 + 1) = x0i + x2i a(j0 - 2) = y0r + y2r a(j0 - 1) = y0i + y2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i a(j1 - 2) = y0r - y2r a(j1 - 1) = y0i - y2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wk1i * x0r - wk1r * x0i a(j2 + 1) = wk1i * x0i + wk1r * x0r x0r = y1r - y3i x0i = y1i + y3r a(j2 - 2) = wd1i * x0r - wd1r * x0i a(j2 - 1) = wd1i * x0i + wd1r * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3) = wk3i * x0r + wk3r * x0i a(j3 + 1) = wk3i * x0i - wk3r * x0r x0r = y1r + y3i x0i = y1i - y3r a(j3 - 2) = wd3i * x0r + wd3r * x0i a(j3 - 1) = wd3i * x0i - wd3r * x0r end do wk1r = csc1 * (wd1r + wn4r) wk1i = csc1 * (wd1i + wn4r) wk3r = csc3 * (wd3r - wn4r) wk3i = csc3 * (wd3i - wn4r) j0 = mh j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0 - 2) + a(j2 - 2) x0i = a(j0 - 1) + a(j2 - 1) x1r = a(j0 - 2) - a(j2 - 2) x1i = a(j0 - 1) - a(j2 - 1) x2r = a(j1 - 2) + a(j3 - 2) x2i = a(j1 - 1) + a(j3 - 1) x3r = a(j1 - 2) - a(j3 - 2) x3i = a(j1 - 1) - a(j3 - 1) a(j0 - 2) = x0r + x2r a(j0 - 1) = x0i + x2i a(j1 - 2) = x0r - x2r a(j1 - 1) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2 - 2) = wk1r * x0r - wk1i * x0i a(j2 - 1) = wk1r * x0i + wk1i * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3 - 2) = wk3r * x0r + wk3i * x0i a(j3 - 1) = wk3r * x0i - wk3i * x0r x0r = a(j0) + a(j2) x0i = a(j0 + 1) + a(j2 + 1) x1r = a(j0) - a(j2) x1i = a(j0 + 1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(j0) = x0r + x2r a(j0 + 1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wn4r * (x0r - x0i) a(j2 + 1) = wn4r * (x0i + x0r) x0r = x1r + x3i x0i = x1i - x3r a(j3) = -wn4r * (x0r + x0i) a(j3 + 1) = -wn4r * (x0i - x0r) x0r = a(j0 + 2) + a(j2 + 2) x0i = a(j0 + 3) + a(j2 + 3) x1r = a(j0 + 2) - a(j2 + 2) x1i = a(j0 + 3) - a(j2 + 3) x2r = a(j1 + 2) + a(j3 + 2) x2i = a(j1 + 3) + a(j3 + 3) x3r = a(j1 + 2) - a(j3 + 2) x3i = a(j1 + 3) - a(j3 + 3) a(j0 + 2) = x0r + x2r a(j0 + 3) = x0i + x2i a(j1 + 2) = x0r - x2r a(j1 + 3) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2 + 2) = wk1i * x0r - wk1r * x0i a(j2 + 3) = wk1i * x0i + wk1r * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3 + 2) = wk3i * x0r + wk3r * x0i a(j3 + 3) = wk3i * x0i - wk3r * x0r end ! subroutine cftb1st(n, a, w) integer n, j, j0, j1, j2, j3, k, m, mh real*8 a(0 : n - 1), w(0 : *) real*8 wn4r, csc1, csc3, wk1r, wk1i, wk3r, wk3i real*8 wd1r, wd1i, wd3r, wd3i real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i mh = n / 8 m = 2 * mh j1 = m j2 = j1 + m j3 = j2 + m x0r = a(0) + a(j2) x0i = -a(1) - a(j2 + 1) x1r = a(0) - a(j2) x1i = -a(1) + a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(0) = x0r + x2r a(1) = x0i - x2i a(j1) = x0r - x2r a(j1 + 1) = x0i + x2i a(j2) = x1r + x3i a(j2 + 1) = x1i + x3r a(j3) = x1r - x3i a(j3 + 1) = x1i - x3r wn4r = w(1) csc1 = w(2) csc3 = w(3) wd1r = 1 wd1i = 0 wd3r = 1 wd3i = 0 k = 0 do j = 2, mh - 6, 4 k = k + 4 wk1r = csc1 * (wd1r + w(k)) wk1i = csc1 * (wd1i + w(k + 1)) wk3r = csc3 * (wd3r + w(k + 2)) wk3i = csc3 * (wd3i + w(k + 3)) wd1r = w(k) wd1i = w(k + 1) wd3r = w(k + 2) wd3i = w(k + 3) j1 = j + m j2 = j1 + m j3 = j2 + m x0r = a(j) + a(j2) x0i = -a(j + 1) - a(j2 + 1) x1r = a(j) - a(j2) x1i = -a(j + 1) + a(j2 + 1) y0r = a(j + 2) + a(j2 + 2) y0i = -a(j + 3) - a(j2 + 3) y1r = a(j + 2) - a(j2 + 2) y1i = -a(j + 3) + a(j2 + 3) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) y2r = a(j1 + 2) + a(j3 + 2) y2i = a(j1 + 3) + a(j3 + 3) y3r = a(j1 + 2) - a(j3 + 2) y3i = a(j1 + 3) - a(j3 + 3) a(j) = x0r + x2r a(j + 1) = x0i - x2i a(j + 2) = y0r + y2r a(j + 3) = y0i - y2i a(j1) = x0r - x2r a(j1 + 1) = x0i + x2i a(j1 + 2) = y0r - y2r a(j1 + 3) = y0i + y2i x0r = x1r + x3i x0i = x1i + x3r a(j2) = wk1r * x0r - wk1i * x0i a(j2 + 1) = wk1r * x0i + wk1i * x0r x0r = y1r + y3i x0i = y1i + y3r a(j2 + 2) = wd1r * x0r - wd1i * x0i a(j2 + 3) = wd1r * x0i + wd1i * x0r x0r = x1r - x3i x0i = x1i - x3r a(j3) = wk3r * x0r + wk3i * x0i a(j3 + 1) = wk3r * x0i - wk3i * x0r x0r = y1r - y3i x0i = y1i - y3r a(j3 + 2) = wd3r * x0r + wd3i * x0i a(j3 + 3) = wd3r * x0i - wd3i * x0r j0 = m - j j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) + a(j2) x0i = -a(j0 + 1) - a(j2 + 1) x1r = a(j0) - a(j2) x1i = -a(j0 + 1) + a(j2 + 1) y0r = a(j0 - 2) + a(j2 - 2) y0i = -a(j0 - 1) - a(j2 - 1) y1r = a(j0 - 2) - a(j2 - 2) y1i = -a(j0 - 1) + a(j2 - 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) y2r = a(j1 - 2) + a(j3 - 2) y2i = a(j1 - 1) + a(j3 - 1) y3r = a(j1 - 2) - a(j3 - 2) y3i = a(j1 - 1) - a(j3 - 1) a(j0) = x0r + x2r a(j0 + 1) = x0i - x2i a(j0 - 2) = y0r + y2r a(j0 - 1) = y0i - y2i a(j1) = x0r - x2r a(j1 + 1) = x0i + x2i a(j1 - 2) = y0r - y2r a(j1 - 1) = y0i + y2i x0r = x1r + x3i x0i = x1i + x3r a(j2) = wk1i * x0r - wk1r * x0i a(j2 + 1) = wk1i * x0i + wk1r * x0r x0r = y1r + y3i x0i = y1i + y3r a(j2 - 2) = wd1i * x0r - wd1r * x0i a(j2 - 1) = wd1i * x0i + wd1r * x0r x0r = x1r - x3i x0i = x1i - x3r a(j3) = wk3i * x0r + wk3r * x0i a(j3 + 1) = wk3i * x0i - wk3r * x0r x0r = y1r - y3i x0i = y1i - y3r a(j3 - 2) = wd3i * x0r + wd3r * x0i a(j3 - 1) = wd3i * x0i - wd3r * x0r end do wk1r = csc1 * (wd1r + wn4r) wk1i = csc1 * (wd1i + wn4r) wk3r = csc3 * (wd3r - wn4r) wk3i = csc3 * (wd3i - wn4r) j0 = mh j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0 - 2) + a(j2 - 2) x0i = -a(j0 - 1) - a(j2 - 1) x1r = a(j0 - 2) - a(j2 - 2) x1i = -a(j0 - 1) + a(j2 - 1) x2r = a(j1 - 2) + a(j3 - 2) x2i = a(j1 - 1) + a(j3 - 1) x3r = a(j1 - 2) - a(j3 - 2) x3i = a(j1 - 1) - a(j3 - 1) a(j0 - 2) = x0r + x2r a(j0 - 1) = x0i - x2i a(j1 - 2) = x0r - x2r a(j1 - 1) = x0i + x2i x0r = x1r + x3i x0i = x1i + x3r a(j2 - 2) = wk1r * x0r - wk1i * x0i a(j2 - 1) = wk1r * x0i + wk1i * x0r x0r = x1r - x3i x0i = x1i - x3r a(j3 - 2) = wk3r * x0r + wk3i * x0i a(j3 - 1) = wk3r * x0i - wk3i * x0r x0r = a(j0) + a(j2) x0i = -a(j0 + 1) - a(j2 + 1) x1r = a(j0) - a(j2) x1i = -a(j0 + 1) + a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(j0) = x0r + x2r a(j0 + 1) = x0i - x2i a(j1) = x0r - x2r a(j1 + 1) = x0i + x2i x0r = x1r + x3i x0i = x1i + x3r a(j2) = wn4r * (x0r - x0i) a(j2 + 1) = wn4r * (x0i + x0r) x0r = x1r - x3i x0i = x1i - x3r a(j3) = -wn4r * (x0r + x0i) a(j3 + 1) = -wn4r * (x0i - x0r) x0r = a(j0 + 2) + a(j2 + 2) x0i = -a(j0 + 3) - a(j2 + 3) x1r = a(j0 + 2) - a(j2 + 2) x1i = -a(j0 + 3) + a(j2 + 3) x2r = a(j1 + 2) + a(j3 + 2) x2i = a(j1 + 3) + a(j3 + 3) x3r = a(j1 + 2) - a(j3 + 2) x3i = a(j1 + 3) - a(j3 + 3) a(j0 + 2) = x0r + x2r a(j0 + 3) = x0i - x2i a(j1 + 2) = x0r - x2r a(j1 + 3) = x0i + x2i x0r = x1r + x3i x0i = x1i + x3r a(j2 + 2) = wk1i * x0r - wk1r * x0i a(j2 + 3) = wk1i * x0i + wk1r * x0r x0r = x1r - x3i x0i = x1i - x3r a(j3 + 2) = wk3i * x0r + wk3r * x0i a(j3 + 3) = wk3i * x0i - wk3r * x0r end ! subroutine cftrec4(n, a, nw, w) integer n, nw, cfttree, isplt, j, k, m real*8 a(0 : n - 1), w(0 : nw - 1) m = n do while (m .gt. 512) m = m / 4 call cftmdl1(m, a(n - m), w(nw - m / 2)) end do call cftleaf(m, 1, a(n - m), nw, w) k = 0 do j = n - m, m, -m k = k + 1 isplt = cfttree(m, j, k, a, nw, w) call cftleaf(m, isplt, a(j - m), nw, w) end do end ! integer function cfttree(n, j, k, a, nw, w) integer n, j, k, nw, i, isplt, m real*8 a(0 : n - 1), w(0 : nw - 1) if (mod(k, 4) .ne. 0) then isplt = mod(k, 2) if (isplt .ne. 0) then call cftmdl1(n, a(j - n), w(nw - n / 2)) else call cftmdl2(n, a(j - n), w(nw - n)) end if else m = n i = k do while (mod(i, 4) .eq. 0) m = m * 4 i = i / 4 end do isplt = mod(i, 2) if (isplt .ne. 0) then do while (m .gt. 128) call cftmdl1(m, a(j - m), w(nw - m / 2)) m = m / 4 end do else do while (m .gt. 128) call cftmdl2(m, a(j - m), w(nw - m)) m = m / 4 end do end if end if cfttree = isplt end ! subroutine cftleaf(n, isplt, a, nw, w) integer n, isplt, nw real*8 a(0 : n - 1), w(0 : nw - 1) if (n .eq. 512) then call cftmdl1(128, a, w(nw - 64)) call cftf161(a, w(nw - 8)) call cftf162(a(32), w(nw - 32)) call cftf161(a(64), w(nw - 8)) call cftf161(a(96), w(nw - 8)) call cftmdl2(128, a(128), w(nw - 128)) call cftf161(a(128), w(nw - 8)) call cftf162(a(160), w(nw - 32)) call cftf161(a(192), w(nw - 8)) call cftf162(a(224), w(nw - 32)) call cftmdl1(128, a(256), w(nw - 64)) call cftf161(a(256), w(nw - 8)) call cftf162(a(288), w(nw - 32)) call cftf161(a(320), w(nw - 8)) call cftf161(a(352), w(nw - 8)) if (isplt .ne. 0) then call cftmdl1(128, a(384), w(nw - 64)) call cftf161(a(480), w(nw - 8)) else call cftmdl2(128, a(384), w(nw - 128)) call cftf162(a(480), w(nw - 32)) end if call cftf161(a(384), w(nw - 8)) call cftf162(a(416), w(nw - 32)) call cftf161(a(448), w(nw - 8)) else call cftmdl1(64, a, w(nw - 32)) call cftf081(a, w(nw - 8)) call cftf082(a(16), w(nw - 8)) call cftf081(a(32), w(nw - 8)) call cftf081(a(48), w(nw - 8)) call cftmdl2(64, a(64), w(nw - 64)) call cftf081(a(64), w(nw - 8)) call cftf082(a(80), w(nw - 8)) call cftf081(a(96), w(nw - 8)) call cftf082(a(112), w(nw - 8)) call cftmdl1(64, a(128), w(nw - 32)) call cftf081(a(128), w(nw - 8)) call cftf082(a(144), w(nw - 8)) call cftf081(a(160), w(nw - 8)) call cftf081(a(176), w(nw - 8)) if (isplt .ne. 0) then call cftmdl1(64, a(192), w(nw - 32)) call cftf081(a(240), w(nw - 8)) else call cftmdl2(64, a(192), w(nw - 64)) call cftf082(a(240), w(nw - 8)) end if call cftf081(a(192), w(nw - 8)) call cftf082(a(208), w(nw - 8)) call cftf081(a(224), w(nw - 8)) end if end ! subroutine cftmdl1(n, a, w) integer n, j, j0, j1, j2, j3, k, m, mh real*8 a(0 : n - 1), w(0 : *) real*8 wn4r, wk1r, wk1i, wk3r, wk3i real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i mh = n / 8 m = 2 * mh j1 = m j2 = j1 + m j3 = j2 + m x0r = a(0) + a(j2) x0i = a(1) + a(j2 + 1) x1r = a(0) - a(j2) x1i = a(1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(0) = x0r + x2r a(1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i a(j2) = x1r - x3i a(j2 + 1) = x1i + x3r a(j3) = x1r + x3i a(j3 + 1) = x1i - x3r wn4r = w(1) k = 0 do j = 2, mh - 2, 2 k = k + 4 wk1r = w(k) wk1i = w(k + 1) wk3r = w(k + 2) wk3i = w(k + 3) j1 = j + m j2 = j1 + m j3 = j2 + m x0r = a(j) + a(j2) x0i = a(j + 1) + a(j2 + 1) x1r = a(j) - a(j2) x1i = a(j + 1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(j) = x0r + x2r a(j + 1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wk1r * x0r - wk1i * x0i a(j2 + 1) = wk1r * x0i + wk1i * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3) = wk3r * x0r + wk3i * x0i a(j3 + 1) = wk3r * x0i - wk3i * x0r j0 = m - j j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) + a(j2) x0i = a(j0 + 1) + a(j2 + 1) x1r = a(j0) - a(j2) x1i = a(j0 + 1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(j0) = x0r + x2r a(j0 + 1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wk1i * x0r - wk1r * x0i a(j2 + 1) = wk1i * x0i + wk1r * x0r x0r = x1r + x3i x0i = x1i - x3r a(j3) = wk3i * x0r + wk3r * x0i a(j3 + 1) = wk3i * x0i - wk3r * x0r end do j0 = mh j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) + a(j2) x0i = a(j0 + 1) + a(j2 + 1) x1r = a(j0) - a(j2) x1i = a(j0 + 1) - a(j2 + 1) x2r = a(j1) + a(j3) x2i = a(j1 + 1) + a(j3 + 1) x3r = a(j1) - a(j3) x3i = a(j1 + 1) - a(j3 + 1) a(j0) = x0r + x2r a(j0 + 1) = x0i + x2i a(j1) = x0r - x2r a(j1 + 1) = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r a(j2) = wn4r * (x0r - x0i) a(j2 + 1) = wn4r * (x0i + x0r) x0r = x1r + x3i x0i = x1i - x3r a(j3) = -wn4r * (x0r + x0i) a(j3 + 1) = -wn4r * (x0i - x0r) end ! subroutine cftmdl2(n, a, w) integer n, j, j0, j1, j2, j3, k, kr, m, mh real*8 a(0 : n - 1), w(0 : *) real*8 wn4r, wk1r, wk1i, wk3r, wk3i, wd1r, wd1i, wd3r, wd3i real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i real*8 y0r, y0i, y2r, y2i mh = n / 8 m = 2 * mh wn4r = w(1) j1 = m j2 = j1 + m j3 = j2 + m x0r = a(0) - a(j2 + 1) x0i = a(1) + a(j2) x1r = a(0) + a(j2 + 1) x1i = a(1) - a(j2) x2r = a(j1) - a(j3 + 1) x2i = a(j1 + 1) + a(j3) x3r = a(j1) + a(j3 + 1) x3i = a(j1 + 1) - a(j3) y0r = wn4r * (x2r - x2i) y0i = wn4r * (x2i + x2r) a(0) = x0r + y0r a(1) = x0i + y0i a(j1) = x0r - y0r a(j1 + 1) = x0i - y0i y0r = wn4r * (x3r - x3i) y0i = wn4r * (x3i + x3r) a(j2) = x1r - y0i a(j2 + 1) = x1i + y0r a(j3) = x1r + y0i a(j3 + 1) = x1i - y0r k = 0 kr = 2 * m do j = 2, mh - 2, 2 k = k + 4 wk1r = w(k) wk1i = w(k + 1) wk3r = w(k + 2) wk3i = w(k + 3) kr = kr - 4 wd1i = w(kr) wd1r = w(kr + 1) wd3i = w(kr + 2) wd3r = w(kr + 3) j1 = j + m j2 = j1 + m j3 = j2 + m x0r = a(j) - a(j2 + 1) x0i = a(j + 1) + a(j2) x1r = a(j) + a(j2 + 1) x1i = a(j + 1) - a(j2) x2r = a(j1) - a(j3 + 1) x2i = a(j1 + 1) + a(j3) x3r = a(j1) + a(j3 + 1) x3i = a(j1 + 1) - a(j3) y0r = wk1r * x0r - wk1i * x0i y0i = wk1r * x0i + wk1i * x0r y2r = wd1r * x2r - wd1i * x2i y2i = wd1r * x2i + wd1i * x2r a(j) = y0r + y2r a(j + 1) = y0i + y2i a(j1) = y0r - y2r a(j1 + 1) = y0i - y2i y0r = wk3r * x1r + wk3i * x1i y0i = wk3r * x1i - wk3i * x1r y2r = wd3r * x3r + wd3i * x3i y2i = wd3r * x3i - wd3i * x3r a(j2) = y0r + y2r a(j2 + 1) = y0i + y2i a(j3) = y0r - y2r a(j3 + 1) = y0i - y2i j0 = m - j j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) - a(j2 + 1) x0i = a(j0 + 1) + a(j2) x1r = a(j0) + a(j2 + 1) x1i = a(j0 + 1) - a(j2) x2r = a(j1) - a(j3 + 1) x2i = a(j1 + 1) + a(j3) x3r = a(j1) + a(j3 + 1) x3i = a(j1 + 1) - a(j3) y0r = wd1i * x0r - wd1r * x0i y0i = wd1i * x0i + wd1r * x0r y2r = wk1i * x2r - wk1r * x2i y2i = wk1i * x2i + wk1r * x2r a(j0) = y0r + y2r a(j0 + 1) = y0i + y2i a(j1) = y0r - y2r a(j1 + 1) = y0i - y2i y0r = wd3i * x1r + wd3r * x1i y0i = wd3i * x1i - wd3r * x1r y2r = wk3i * x3r + wk3r * x3i y2i = wk3i * x3i - wk3r * x3r a(j2) = y0r + y2r a(j2 + 1) = y0i + y2i a(j3) = y0r - y2r a(j3 + 1) = y0i - y2i end do wk1r = w(m) wk1i = w(m + 1) j0 = mh j1 = j0 + m j2 = j1 + m j3 = j2 + m x0r = a(j0) - a(j2 + 1) x0i = a(j0 + 1) + a(j2) x1r = a(j0) + a(j2 + 1) x1i = a(j0 + 1) - a(j2) x2r = a(j1) - a(j3 + 1) x2i = a(j1 + 1) + a(j3) x3r = a(j1) + a(j3 + 1) x3i = a(j1 + 1) - a(j3) y0r = wk1r * x0r - wk1i * x0i y0i = wk1r * x0i + wk1i * x0r y2r = wk1i * x2r - wk1r * x2i y2i = wk1i * x2i + wk1r * x2r a(j0) = y0r + y2r a(j0 + 1) = y0i + y2i a(j1) = y0r - y2r a(j1 + 1) = y0i - y2i y0r = wk1i * x1r - wk1r * x1i y0i = wk1i * x1i + wk1r * x1r y2r = wk1r * x3r - wk1i * x3i y2i = wk1r * x3i + wk1i * x3r a(j2) = y0r - y2r a(j2 + 1) = y0i - y2i a(j3) = y0r + y2r a(j3 + 1) = y0i + y2i end ! subroutine cftfx41(n, a, nw, w) integer n, nw real*8 a(0 : n - 1), w(0 : nw - 1) if (n .eq. 128) then call cftf161(a, w(nw - 8)) call cftf162(a(32), w(nw - 32)) call cftf161(a(64), w(nw - 8)) call cftf161(a(96), w(nw - 8)) else call cftf081(a, w(nw - 8)) call cftf082(a(16), w(nw - 8)) call cftf081(a(32), w(nw - 8)) call cftf081(a(48), w(nw - 8)) end if end ! subroutine cftf161(a, w) real*8 a(0 : 31), w(0 : *), wn4r, wk1r, wk1i real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i real*8 y8r, y8i, y9r, y9i, y10r, y10i, y11r, y11i real*8 y12r, y12i, y13r, y13i, y14r, y14i, y15r, y15i wn4r = w(1) wk1r = w(2) wk1i = w(3) x0r = a(0) + a(16) x0i = a(1) + a(17) x1r = a(0) - a(16) x1i = a(1) - a(17) x2r = a(8) + a(24) x2i = a(9) + a(25) x3r = a(8) - a(24) x3i = a(9) - a(25) y0r = x0r + x2r y0i = x0i + x2i y4r = x0r - x2r y4i = x0i - x2i y8r = x1r - x3i y8i = x1i + x3r y12r = x1r + x3i y12i = x1i - x3r x0r = a(2) + a(18) x0i = a(3) + a(19) x1r = a(2) - a(18) x1i = a(3) - a(19) x2r = a(10) + a(26) x2i = a(11) + a(27) x3r = a(10) - a(26) x3i = a(11) - a(27) y1r = x0r + x2r y1i = x0i + x2i y5r = x0r - x2r y5i = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r y9r = wk1r * x0r - wk1i * x0i y9i = wk1r * x0i + wk1i * x0r x0r = x1r + x3i x0i = x1i - x3r y13r = wk1i * x0r - wk1r * x0i y13i = wk1i * x0i + wk1r * x0r x0r = a(4) + a(20) x0i = a(5) + a(21) x1r = a(4) - a(20) x1i = a(5) - a(21) x2r = a(12) + a(28) x2i = a(13) + a(29) x3r = a(12) - a(28) x3i = a(13) - a(29) y2r = x0r + x2r y2i = x0i + x2i y6r = x0r - x2r y6i = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r y10r = wn4r * (x0r - x0i) y10i = wn4r * (x0i + x0r) x0r = x1r + x3i x0i = x1i - x3r y14r = wn4r * (x0r + x0i) y14i = wn4r * (x0i - x0r) x0r = a(6) + a(22) x0i = a(7) + a(23) x1r = a(6) - a(22) x1i = a(7) - a(23) x2r = a(14) + a(30) x2i = a(15) + a(31) x3r = a(14) - a(30) x3i = a(15) - a(31) y3r = x0r + x2r y3i = x0i + x2i y7r = x0r - x2r y7i = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r y11r = wk1i * x0r - wk1r * x0i y11i = wk1i * x0i + wk1r * x0r x0r = x1r + x3i x0i = x1i - x3r y15r = wk1r * x0r - wk1i * x0i y15i = wk1r * x0i + wk1i * x0r x0r = y12r - y14r x0i = y12i - y14i x1r = y12r + y14r x1i = y12i + y14i x2r = y13r - y15r x2i = y13i - y15i x3r = y13r + y15r x3i = y13i + y15i a(24) = x0r + x2r a(25) = x0i + x2i a(26) = x0r - x2r a(27) = x0i - x2i a(28) = x1r - x3i a(29) = x1i + x3r a(30) = x1r + x3i a(31) = x1i - x3r x0r = y8r + y10r x0i = y8i + y10i x1r = y8r - y10r x1i = y8i - y10i x2r = y9r + y11r x2i = y9i + y11i x3r = y9r - y11r x3i = y9i - y11i a(16) = x0r + x2r a(17) = x0i + x2i a(18) = x0r - x2r a(19) = x0i - x2i a(20) = x1r - x3i a(21) = x1i + x3r a(22) = x1r + x3i a(23) = x1i - x3r x0r = y5r - y7i x0i = y5i + y7r x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) x0r = y5r + y7i x0i = y5i - y7r x3r = wn4r * (x0r - x0i) x3i = wn4r * (x0i + x0r) x0r = y4r - y6i x0i = y4i + y6r x1r = y4r + y6i x1i = y4i - y6r a(8) = x0r + x2r a(9) = x0i + x2i a(10) = x0r - x2r a(11) = x0i - x2i a(12) = x1r - x3i a(13) = x1i + x3r a(14) = x1r + x3i a(15) = x1i - x3r x0r = y0r + y2r x0i = y0i + y2i x1r = y0r - y2r x1i = y0i - y2i x2r = y1r + y3r x2i = y1i + y3i x3r = y1r - y3r x3i = y1i - y3i a(0) = x0r + x2r a(1) = x0i + x2i a(2) = x0r - x2r a(3) = x0i - x2i a(4) = x1r - x3i a(5) = x1i + x3r a(6) = x1r + x3i a(7) = x1i - x3r end ! subroutine cftf162(a, w) real*8 a(0 : 31), w(0 : *) real*8 wn4r, wk1r, wk1i, wk2r, wk2i, wk3r, wk3i real*8 x0r, x0i, x1r, x1i, x2r, x2i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i real*8 y8r, y8i, y9r, y9i, y10r, y10i, y11r, y11i real*8 y12r, y12i, y13r, y13i, y14r, y14i, y15r, y15i wn4r = w(1) wk1r = w(4) wk1i = w(5) wk3r = w(6) wk3i = -w(7) wk2r = w(8) wk2i = w(9) x1r = a(0) - a(17) x1i = a(1) + a(16) x0r = a(8) - a(25) x0i = a(9) + a(24) x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) y0r = x1r + x2r y0i = x1i + x2i y4r = x1r - x2r y4i = x1i - x2i x1r = a(0) + a(17) x1i = a(1) - a(16) x0r = a(8) + a(25) x0i = a(9) - a(24) x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) y8r = x1r - x2i y8i = x1i + x2r y12r = x1r + x2i y12i = x1i - x2r x0r = a(2) - a(19) x0i = a(3) + a(18) x1r = wk1r * x0r - wk1i * x0i x1i = wk1r * x0i + wk1i * x0r x0r = a(10) - a(27) x0i = a(11) + a(26) x2r = wk3i * x0r - wk3r * x0i x2i = wk3i * x0i + wk3r * x0r y1r = x1r + x2r y1i = x1i + x2i y5r = x1r - x2r y5i = x1i - x2i x0r = a(2) + a(19) x0i = a(3) - a(18) x1r = wk3r * x0r - wk3i * x0i x1i = wk3r * x0i + wk3i * x0r x0r = a(10) + a(27) x0i = a(11) - a(26) x2r = wk1r * x0r + wk1i * x0i x2i = wk1r * x0i - wk1i * x0r y9r = x1r - x2r y9i = x1i - x2i y13r = x1r + x2r y13i = x1i + x2i x0r = a(4) - a(21) x0i = a(5) + a(20) x1r = wk2r * x0r - wk2i * x0i x1i = wk2r * x0i + wk2i * x0r x0r = a(12) - a(29) x0i = a(13) + a(28) x2r = wk2i * x0r - wk2r * x0i x2i = wk2i * x0i + wk2r * x0r y2r = x1r + x2r y2i = x1i + x2i y6r = x1r - x2r y6i = x1i - x2i x0r = a(4) + a(21) x0i = a(5) - a(20) x1r = wk2i * x0r - wk2r * x0i x1i = wk2i * x0i + wk2r * x0r x0r = a(12) + a(29) x0i = a(13) - a(28) x2r = wk2r * x0r - wk2i * x0i x2i = wk2r * x0i + wk2i * x0r y10r = x1r - x2r y10i = x1i - x2i y14r = x1r + x2r y14i = x1i + x2i x0r = a(6) - a(23) x0i = a(7) + a(22) x1r = wk3r * x0r - wk3i * x0i x1i = wk3r * x0i + wk3i * x0r x0r = a(14) - a(31) x0i = a(15) + a(30) x2r = wk1i * x0r - wk1r * x0i x2i = wk1i * x0i + wk1r * x0r y3r = x1r + x2r y3i = x1i + x2i y7r = x1r - x2r y7i = x1i - x2i x0r = a(6) + a(23) x0i = a(7) - a(22) x1r = wk1i * x0r + wk1r * x0i x1i = wk1i * x0i - wk1r * x0r x0r = a(14) + a(31) x0i = a(15) - a(30) x2r = wk3i * x0r - wk3r * x0i x2i = wk3i * x0i + wk3r * x0r y11r = x1r + x2r y11i = x1i + x2i y15r = x1r - x2r y15i = x1i - x2i x1r = y0r + y2r x1i = y0i + y2i x2r = y1r + y3r x2i = y1i + y3i a(0) = x1r + x2r a(1) = x1i + x2i a(2) = x1r - x2r a(3) = x1i - x2i x1r = y0r - y2r x1i = y0i - y2i x2r = y1r - y3r x2i = y1i - y3i a(4) = x1r - x2i a(5) = x1i + x2r a(6) = x1r + x2i a(7) = x1i - x2r x1r = y4r - y6i x1i = y4i + y6r x0r = y5r - y7i x0i = y5i + y7r x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) a(8) = x1r + x2r a(9) = x1i + x2i a(10) = x1r - x2r a(11) = x1i - x2i x1r = y4r + y6i x1i = y4i - y6r x0r = y5r + y7i x0i = y5i - y7r x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) a(12) = x1r - x2i a(13) = x1i + x2r a(14) = x1r + x2i a(15) = x1i - x2r x1r = y8r + y10r x1i = y8i + y10i x2r = y9r - y11r x2i = y9i - y11i a(16) = x1r + x2r a(17) = x1i + x2i a(18) = x1r - x2r a(19) = x1i - x2i x1r = y8r - y10r x1i = y8i - y10i x2r = y9r + y11r x2i = y9i + y11i a(20) = x1r - x2i a(21) = x1i + x2r a(22) = x1r + x2i a(23) = x1i - x2r x1r = y12r - y14i x1i = y12i + y14r x0r = y13r + y15i x0i = y13i - y15r x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) a(24) = x1r + x2r a(25) = x1i + x2i a(26) = x1r - x2r a(27) = x1i - x2i x1r = y12r + y14i x1i = y12i - y14r x0r = y13r - y15i x0i = y13i + y15r x2r = wn4r * (x0r - x0i) x2i = wn4r * (x0i + x0r) a(28) = x1r - x2i a(29) = x1i + x2r a(30) = x1r + x2i a(31) = x1i - x2r end ! subroutine cftf081(a, w) real*8 a(0 : 15), w(0 : *) real*8 wn4r, x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i wn4r = w(1) x0r = a(0) + a(8) x0i = a(1) + a(9) x1r = a(0) - a(8) x1i = a(1) - a(9) x2r = a(4) + a(12) x2i = a(5) + a(13) x3r = a(4) - a(12) x3i = a(5) - a(13) y0r = x0r + x2r y0i = x0i + x2i y2r = x0r - x2r y2i = x0i - x2i y1r = x1r - x3i y1i = x1i + x3r y3r = x1r + x3i y3i = x1i - x3r x0r = a(2) + a(10) x0i = a(3) + a(11) x1r = a(2) - a(10) x1i = a(3) - a(11) x2r = a(6) + a(14) x2i = a(7) + a(15) x3r = a(6) - a(14) x3i = a(7) - a(15) y4r = x0r + x2r y4i = x0i + x2i y6r = x0r - x2r y6i = x0i - x2i x0r = x1r - x3i x0i = x1i + x3r x2r = x1r + x3i x2i = x1i - x3r y5r = wn4r * (x0r - x0i) y5i = wn4r * (x0r + x0i) y7r = wn4r * (x2r - x2i) y7i = wn4r * (x2r + x2i) a(8) = y1r + y5r a(9) = y1i + y5i a(10) = y1r - y5r a(11) = y1i - y5i a(12) = y3r - y7i a(13) = y3i + y7r a(14) = y3r + y7i a(15) = y3i - y7r a(0) = y0r + y4r a(1) = y0i + y4i a(2) = y0r - y4r a(3) = y0i - y4i a(4) = y2r - y6i a(5) = y2i + y6r a(6) = y2r + y6i a(7) = y2i - y6r end ! subroutine cftf082(a, w) real*8 a(0 : 15), w(0 : *) real*8 wn4r, wk1r, wk1i, x0r, x0i, x1r, x1i real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i wn4r = w(1) wk1r = w(2) wk1i = w(3) y0r = a(0) - a(9) y0i = a(1) + a(8) y1r = a(0) + a(9) y1i = a(1) - a(8) x0r = a(4) - a(13) x0i = a(5) + a(12) y2r = wn4r * (x0r - x0i) y2i = wn4r * (x0i + x0r) x0r = a(4) + a(13) x0i = a(5) - a(12) y3r = wn4r * (x0r - x0i) y3i = wn4r * (x0i + x0r) x0r = a(2) - a(11) x0i = a(3) + a(10) y4r = wk1r * x0r - wk1i * x0i y4i = wk1r * x0i + wk1i * x0r x0r = a(2) + a(11) x0i = a(3) - a(10) y5r = wk1i * x0r - wk1r * x0i y5i = wk1i * x0i + wk1r * x0r x0r = a(6) - a(15) x0i = a(7) + a(14) y6r = wk1i * x0r - wk1r * x0i y6i = wk1i * x0i + wk1r * x0r x0r = a(6) + a(15) x0i = a(7) - a(14) y7r = wk1r * x0r - wk1i * x0i y7i = wk1r * x0i + wk1i * x0r x0r = y0r + y2r x0i = y0i + y2i x1r = y4r + y6r x1i = y4i + y6i a(0) = x0r + x1r a(1) = x0i + x1i a(2) = x0r - x1r a(3) = x0i - x1i x0r = y0r - y2r x0i = y0i - y2i x1r = y4r - y6r x1i = y4i - y6i a(4) = x0r - x1i a(5) = x0i + x1r a(6) = x0r + x1i a(7) = x0i - x1r x0r = y1r - y3i x0i = y1i + y3r x1r = y5r - y7r x1i = y5i - y7i a(8) = x0r + x1r a(9) = x0i + x1i a(10) = x0r - x1r a(11) = x0i - x1i x0r = y1r + y3i x0i = y1i - y3r x1r = y5r + y7r x1i = y5i + y7i a(12) = x0r - x1i a(13) = x0i + x1r a(14) = x0r + x1i a(15) = x0i - x1r end ! subroutine cftf040(a) real*8 a(0 : 7), x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i x0r = a(0) + a(4) x0i = a(1) + a(5) x1r = a(0) - a(4) x1i = a(1) - a(5) x2r = a(2) + a(6) x2i = a(3) + a(7) x3r = a(2) - a(6) x3i = a(3) - a(7) a(0) = x0r + x2r a(1) = x0i + x2i a(2) = x1r - x3i a(3) = x1i + x3r a(4) = x0r - x2r a(5) = x0i - x2i a(6) = x1r + x3i a(7) = x1i - x3r end ! subroutine cftb040(a) real*8 a(0 : 7), x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i x0r = a(0) + a(4) x0i = a(1) + a(5) x1r = a(0) - a(4) x1i = a(1) - a(5) x2r = a(2) + a(6) x2i = a(3) + a(7) x3r = a(2) - a(6) x3i = a(3) - a(7) a(0) = x0r + x2r a(1) = x0i + x2i a(2) = x1r + x3i a(3) = x1i - x3r a(4) = x0r - x2r a(5) = x0i - x2i a(6) = x1r - x3i a(7) = x1i + x3r end ! subroutine cftx020(a) real*8 a(0 : 3), x0r, x0i x0r = a(0) - a(2) x0i = a(1) - a(3) a(0) = a(0) + a(2) a(1) = a(1) + a(3) a(2) = x0r a(3) = x0i end ! subroutine rftfsub(n, a, nc, c) integer n, nc, j, k, kk, ks, m real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr, xi, yr, yi m = n / 2 ks = 2 * nc / m kk = 0 do j = 2, m - 2, 2 k = n - j kk = kk + ks wkr = 0.5d0 - c(nc - kk) wki = c(kk) xr = a(j) - a(k) xi = a(j + 1) + a(k + 1) yr = wkr * xr - wki * xi yi = wkr * xi + wki * xr a(j) = a(j) - yr a(j + 1) = a(j + 1) - yi a(k) = a(k) + yr a(k + 1) = a(k + 1) - yi end do end ! subroutine rftbsub(n, a, nc, c) integer n, nc, j, k, kk, ks, m real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr, xi, yr, yi m = n / 2 ks = 2 * nc / m kk = 0 do j = 2, m - 2, 2 k = n - j kk = kk + ks wkr = 0.5d0 - c(nc - kk) wki = c(kk) xr = a(j) - a(k) xi = a(j + 1) + a(k + 1) yr = wkr * xr + wki * xi yi = wkr * xi - wki * xr a(j) = a(j) - yr a(j + 1) = a(j + 1) - yi a(k) = a(k) + yr a(k + 1) = a(k + 1) - yi end do end ! subroutine dctsub(n, a, nc, c) integer n, nc, j, k, kk, ks, m real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr m = n / 2 ks = nc / n kk = 0 do j = 1, m - 1 k = n - j kk = kk + ks wkr = c(kk) - c(nc - kk) wki = c(kk) + c(nc - kk) xr = wki * a(j) - wkr * a(k) a(j) = wkr * a(j) + wki * a(k) a(k) = xr end do a(m) = c(0) * a(m) end ! subroutine dstsub(n, a, nc, c) integer n, nc, j, k, kk, ks, m real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr m = n / 2 ks = nc / n kk = 0 do j = 1, m - 1 k = n - j kk = kk + ks wkr = c(kk) - c(nc - kk) wki = c(kk) + c(nc - kk) xr = wki * a(k) - wkr * a(j) a(k) = wkr * a(k) + wki * a(j) a(j) = xr end do a(m) = c(0) * a(m) end ! subroutine induction1(uc,ub,g,rhs,ig,mx,my,mz,dx,dy,dz, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), ig(mx,my,mz), g(mx,my,mz,3) dimension ub(mx,my,mz,mn) dimension rhs(mx,my,mz,mn-1,mtm) dimension dudx(3,3), dpdx(3), d2b(3), dbdx(3,3) common /var1/omega,omegap, omegapx,omegapz,ca,cb,anu,eta, factor c for grid 1 c consta=2.* ca**2*omegap/ (ca**2-cb**2) c constb=2.* cb**2*omegap/ (ca**2-cb**2) cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) vx0 = -y vy0 = x -oetamu *z vz0 = amu * y c dvx0dx=0. dvx0dy = -1. c dvx0dx = 0. dvy0dx = 1. dvy0dz = -oetamu dvz0dy = amu c vx=uc(i,j,k,1) c vy=uc(i,j,k,2) c vz=uc(i,j,k,3) c C also for dbdx c dudx(1,1)=dux/dx, dudx(1,2)=dux/dy dudx(1,3)=dux/dz c dudx(2,1)=duy/dx, dudx(2,2)=duy/dy dudx(2,3)=duy/dz c dudx(3,1)=duz/dx, dudx(3,2)=duz/dy dudx(3,3)=duy/dz do m=1,3 dudx(m,1)= (uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dx) dudx(m,2)= (uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*dy) dudx(m,3)= (uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dz) dbdx(m,1)= (ub(i+1,j,k,m)-ub(i-1,j,k,m))/(2.*dx) dbdx(m,2)= (ub(i,j+1,k,m)-ub(i,j-1,k,m))/(2.*dy) dbdx(m,3)= (ub(i,j,k+1,m)-ub(i,j,k-1,m))/(2.*dz) end do chere d2u=d2b c Laplacian(Ux): d2u(1)=d2(ux); d2u(2)=d2(uy); d2u(3)=d2(uz) do m=1,3 d2b(m)=(ub(i+1,j,k,m)-2.*ub(i,j,k,m)+ub(i-1,j,k,m))/dx**2 1 +(ub(i,j+1,k,m)-2.*ub(i,j,k,m)+ub(i,j-1,k,m))/dy**2 1 +(ub(i,j,k+1,m)-2.*ub(i,j,k,m)+ub(i,j,k-1,m))/dz**2 end do c rhs(i,j,k,1,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(1,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(1,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(1,3)) 1 +( ub(i,j,k,1)*(dudx(1,1)) 1 +ub(i,j,k,2)*(dudx(1,2)+dvx0dy) 1 +ub(i,j,k,3)*(dudx(1,3))) 1 + eta*d2b(1) rhs(i,j,k,2,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(2,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(2,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(2,3)) 1 +( ub(i,j,k,1)*(dudx(2,1)+dvy0dx) 1 +ub(i,j,k,2)*(dudx(2,2)) 1 +ub(i,j,k,3)*(dudx(2,3)+dvy0dz)) 1 + eta*d2b(2) rhs(i,j,k,3,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(3,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(3,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(3,3)) 1 +( ub(i,j,k,1)*(dudx(3,1)) 1 +ub(i,j,k,2)*(dudx(3,2)+dvz0dy) 1 +ub(i,j,k,3)*(dudx(3,3))) 1 + eta*d2b(3) end if 200 continue return end subroutine induction2(uc,ub,g,trans,rhs,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid, io) parameter (mtm=4, mn=4) dimension uc(mx,my,mz,mn), trans(mx,my,mz,3,3), ig(mx,my,mz) dimension ub(mx,my,mz,mn) dimension rhs(mx,my,mz,mn-1,mtm), g(mx,my,mz,3) dimension drdx(3,3), dudr(3,3), dudx(3,3), dpdr(3), dpdx(3) dimension d2bxdr(3,3,3), drxdr(3,3,3), d2b(3) dimension duudx(3,3), duudr(3,3,3) dimension dbdr(3,3), dbdx(3,3) common /var1/omega,omegap, omegapx,omegapz,ca,cb,anu,eta, factor c for grid 2 c consta=2.* ca**2*omegap/ (ca**2-cb**2) c constb=2.* cb**2*omegap/ (ca**2-cb**2) cc=cb aeta=1./cc**2-1 amu=2.*omegap/aeta oetamu=(1.+aeta)*amu do 200 i = nxs, nxe do 200 j = nys, nye do 200 k = nzs, nze if (ig(i,j,k).eq.igrid) then c interior points x = g(i,j,k,1) y = g(i,j,k,2) z = g(i,j,k,3) vx0 = -y vy0 = x -oetamu *z vz0 = amu * y c dvx0dx=0. dvx0dy = -1. c dvx0dx = 0. dvy0dx = 1. dvy0dz = -oetamu dvz0dy = amu c vx=uc(i,j,k,1) c vy=uc(i,j,k,2) c vz=uc(i,j,k,3) c c drdx(1,1)=dr/dx, drdx(1,2)=dr/dy, drdx(1,3)=dr/dz, c drdx(2,1)=ds/dx, drdx(2,2)=ds/dy, drdx(2,3)=ds/dz, c drdx(3,1)=dt/dx, drdx(3,2)=dt/dy, drdx(3,3)=dt/dz. do m=1,3 do n=1,3 drdx(m,n)=trans(i,j,k,m,n) end do end do c c dudr(1,1)=dux/dr, dudr(1,2)=dux/ds, dudt(1,3)=dux/dt, c dudr(2,1)=duy/dr, dudr(2,2)=duy/ds, dudt(2,3)=duy/dt, c dudr(3,1)=duz/dr, dudr(3,2)=duz/ds, dudt(3,3)=duz/dt. do m=1,3 dudr(m,1)=(uc(i+1,j,k,m)-uc(i-1,j,k,m))/(2.*dr) dudr(m,2)=(uc(i,j+1,k,m)-uc(i,j-1,k,m))/(2.*ds) dudr(m,3)=(uc(i,j,k+1,m)-uc(i,j,k-1,m))/(2.*dt) end do c dudx(1,1)=dux/dx, dudx(1,2)=dux/dy dudx(1,3)=dux/dz c dudx(2,1)=duy/dx, dudx(2,2)=duy/dy dudx(2,3)=duy/dz c dudx(3,1)=duz/dx, dudx(3,2)=duz/dy dudx(3,3)=duy/dz do m=1,3 do n=1,3 dudx(m,n)=dudr(m,1)*drdx(1,n)+dudr(m,2)*drdx(2,n) 1 + dudr(m,3)*drdx(3,n) end do end do c for B c dudr(1,1)=dux/dr, dudr(1,2)=dux/ds, dudt(1,3)=dux/dt, c dudr(2,1)=duy/dr, dudr(2,2)=duy/ds, dudt(2,3)=duy/dt, c dudr(3,1)=duz/dr, dudr(3,2)=duz/ds, dudt(3,3)=duz/dt. do m=1,3 dbdr(m,1)=(ub(i+1,j,k,m)-ub(i-1,j,k,m))/(2.*dr) dbdr(m,2)=(ub(i,j+1,k,m)-ub(i,j-1,k,m))/(2.*ds) dbdr(m,3)=(ub(i,j,k+1,m)-ub(i,j,k-1,m))/(2.*dt) end do c dudx(1,1)=dux/dx, dudx(1,2)=dux/dy dudx(1,3)=dux/dz c dudx(2,1)=duy/dx, dudx(2,2)=duy/dy dudx(2,3)=duy/dz c dudx(3,1)=duz/dx, dudx(3,2)=duz/dy dudx(3,3)=duy/dz do m=1,3 do n=1,3 dbdx(m,n)=dbdr(m,1)*drdx(1,n)+dbdr(m,2)*drdx(2,n) 1 + dbdr(m,3)*drdx(3,n) end do end do c c c d2uxdr(1,1,1)=d2ux/dr/dr, d2uxdr(1,1,2)=d2ux/dr/ds, c d2uxdr(1,1,3)=d2ux/dr/dt, c d2uxdr(1,2,1)=d2ux/ds/dr, d2uxdr(1,2,2)=d2ux/ds/ds, c d2uxdr(1,2,3)=d2ux/ds/dt, c d2uxdr(1,3,1)=d2ux/dt/dr, d2uxdr(1,3,2)=d2ux/dt/ds, c d2uxdr(1,3,3)=d2ux/dt/dt, c d2uxdr(2,1,1)=d2uy/dr/dr; d2uxdr(3,1,1)=d2uz/dr/dr. do m=1,3 d2bxdr(m,1,1)=(ub(i+1,j,k,m)-2.*ub(i,j,k,m)+ ub(i-1,j,k,m))/dr**2 d2bxdr(m,1,2)=(ub(i+1,j+1,k,m)-ub(i+1,j-1,k,m) 1 -ub(i-1,j+1,k,m)+ub(i-1,j-1,k,m))/(4.*dr*ds) d2bxdr(m,1,3)=(ub(i+1,j,k+1,m)-ub(i+1,j,k-1,m) 1 -ub(i-1,j,k+1,m)+ub(i-1,j,k-1,m))/(4.*dr*dt) d2bxdr(m,2,2)=(ub(i,j+1,k,m)-2.*ub(i,j,k,m)+ ub(i,j-1,k,m))/ds**2 d2bxdr(m,2,3)=(ub(i,j+1,k+1,m)-ub(i,j+1,k-1,m) 1 -ub(i,j-1,k+1,m)+ub(i,j-1,k-1,m))/(4.*ds*dt) d2bxdr(m,3,3)=(ub(i,j,k+1,m)-2.*ub(i,j,k,m)+ ub(i,j,k-1,m))/dt**2 d2bxdr(m,2,1)=d2bxdr(m,1,2) d2bxdr(m,3,1)=d2bxdr(m,1,3) d2bxdr(m,3,2)=d2bxdr(m,2,3) end do c c c drxdr(1,1,1)=d(drdx)/dr, drxdr(1,1,2)=d(drdx)/ds, drxdr(1,1,3)=d(drdx)/dt, c drxdr(2,1,1)=d(dsdx)/dr, drxdr(2,1,2)=d(dsdx)/ds, drxdr(2,1,3)=d(dsdx)/dt, c drxdr(3,1,1)=d(dtdx)/dr, drxdr(3,1,2)=d(dtdx)/ds, drxdr(3,1,3)=d(dsdx)/dt. c c drxdr(1,2,1)=d(drdy)/dr, drxdr(1,2,2)=d(drdy)/ds, drxdr(1,2,3)=d(drdy)/dt, c drxdr(2,2,1)=d(dsdy)/dr, drxdr(2,2,2)=d(dsdy)/ds, drxdr(2,2,3)=d(dsdy)/dt, c drxdr(3,2,1)=d(dtdy)/dr, drxdr(3,2,2)=d(dtdy)/ds, drxdr(3,2,3)=d(dtdy)/dt. c c drxdr(1,3,1)=d(drdz)/dr, drxdr(1,3,2)=d(drdz)/ds, drxdr(1,3,3)=d(drdz)/dt, c drxdr(2,3,1)=d(dsdz)/dr, drxdr(2,3,2)=d(dsdz)/ds, drxdr(2,3,3)=d(dsdz)/dt, c drxdr(3,3,1)=d(dtdz)/dr, drxdr(3,3,2)=d(dtdz)/ds, drxdr(3,3,3)=d(dtdz)/dt. c do m=1,3 do n=1,3 drxdr(m,n,1)=(trans(i+1,j,k,m,n)- trans(i-1,j,k,m,n))/(2.*dr) drxdr(m,n,2)=(trans(i,j+1,k,m,n)- trans(i,j-1,k,m,n))/(2.*ds) drxdr(m,n,3)=(trans(i,j,k+1,m,n)- trans(i,j,k-1,m,n))/(2.*dt) end do end do c c Laplacian(Ux): d2Uxdxx+d2Uxdyy+d2Uxdzz do nn=1,3 d2b(nn)=0 do n=1,3 do mm=1,3 do m=1,3 d2b(nn)=d2b(nn)+d2bxdr(nn,mm,m)*drdx(mm,n)*drdx(m,n) 1 +drxdr(m,n,mm)*drdx(mm,n)*dbdr(nn,m) end do end do end do end do rhs(i,j,k,1,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(1,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(1,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(1,3)) 1 +( ub(i,j,k,1)*(dudx(1,1)) 1 +ub(i,j,k,2)*(dudx(1,2)+dvx0dy) 1 +ub(i,j,k,3)*(dudx(1,3))) 1 + eta*d2b(1) rhs(i,j,k,2,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(2,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(2,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(2,3)) 1 +( ub(i,j,k,1)*(dudx(2,1)+dvy0dx) 1 +ub(i,j,k,2)*(dudx(2,2)) 1 +ub(i,j,k,3)*(dudx(2,3)+dvy0dz)) 1 + eta*d2b(2) rhs(i,j,k,3,io) = c -d (v B) + d(B v) +eta d2B c= -v dB + B dv +eta d2B c = -(vx dBx/dx+ vy dBx/dy + vz dBx/dz) c +(Bx dvx/dx+ By dvx/dy + Bz dvx/dz) +eta d2Bx 1 -( (uc(i,j,k,1)+vx0)*dbdx(3,1) 1 +(uc(i,j,k,2)+vy0)*dbdx(3,2) 1 +(uc(i,j,k,3)+vz0)*dbdx(3,3)) 1 +( ub(i,j,k,1)*(dudx(3,1)) 1 +ub(i,j,k,2)*(dudx(3,2)+dvz0dy) 1 +ub(i,j,k,3)*(dudx(3,3))) 1 + eta*d2b(3) end if 200 continue return end subroutine interpB2(uc2, ig, mx,my,mz, igrid, nxs,nxe,nys,nye, 1 nzs,nze, ngp, drngp, numngp, uc4,g4,mx4,my4,dr,ds,mngp,xi0) dimension uc2(mx,my,mz,4), ig(mx,my,mz), ngp(mngp,3) 1 , drngp(mngp,3),bx(2,2),by(2,2),bz(2,2) dimension uc4(mx4,my4,2,6), g4(mx4,my4,2) c c get B on R at grid 2 from grid 4 c c get b at th=0 c which we defined as an average c here br=bxi sinhxi=sinh(xi0) coshxi=cosh(xi0) sinhxi2=sinhxi**2 tpi=2.*3.14159265359 bx0=0. by0=0. bz0=0. in=1 th=g4(in,1,1) do jn=1,my4 phi=g4(in,jn,2) br= uc4(in,jn,1,1) bth= uc4(in,jn,1,2) bphi= uc4(in,jn,1,3) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) g=1./sqrt(sinhxi2+costh**2) a1= g* Sinhxi* Sinth* Cosphi a2= g* Sinhxi* Sinth* Sinphi a3= g* Coshxi*Costh b1= g* Coshxi* Costh* Cosphi b2= g* Coshxi* Costh* Sinphi b3= -g* Sinhxi* Sinth c1=- Sinphi c2= Cosphi c3=0 c vx= a1* vxi + b1* vth + c1 vphi c vy= a2* vxi + b2* vth + c2 vphi c vz= a3* vxi + b3* vth + c3 vphi bx0=bx0+a1*br+b1*bth+c1*bphi by0=by0+a2*br+b2*bth+c2*bphi bz0=bz0+a3*br+b3*bth end do bx0=bx0/float(my4) by0=by0/float(my4) bz0=bz0/float(my4) c get b at th=pi c which we defined as an average bxpi=0. bypi=0. bzpi=0. in=mx4 th=g4(in,1,1) do jn=1,my4 phi=g4(in,jn,2) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) br= uc4(in,jn,1,1) bth= uc4(in,jn,1,2) bphi= uc4(in,jn,1,3) g=1./sqrt(sinhxi2+costh**2) a1= g* Sinhxi* Sinth* Cosphi a2= g* Sinhxi* Sinth* Sinphi a3= g* Coshxi*Costh b1= g* Coshxi* Costh* Cosphi b2= g* Coshxi* Costh* Sinphi b3= -g* Sinhxi* Sinth c1=- Sinphi c2= Cosphi c3=0 c vx= a1* vxi + b1* vth + c1 vphi c vy= a2* vxi + b2* vth + c2 vphi c vz= a3* vxi + b3* vth + c3 vphi bxpi=bxpi+a1*br+b1*bth+c1*bphi bypi=bypi+a2*br+b2*bth+c2*bphi bzpi=bzpi+a3*br+b3*bth end do bxpi=bxpi/float(my4) bypi=bypi/float(my4) bzpi=bzpi/float(my4) c c k=nze intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye if(ig(i,j,k).eq.igrid) then intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ddr=drngp(intnum,1) dds=drngp(intnum,2) c alpha=ddr/dr beta=dds/ds c if(ngpi.eq.0) then c th=0 bx(1,1)=bx0 by(1,1)=by0 bz(1,1)=bz0 c th=dth in=1 ii=2 do jj=0,1 jn=ngpj+jj if(jn.gt.my4) jn=1 th=g4(in,jn,1) phi=g4(in,jn,2) br= uc4(in,jn,1,1) bth= uc4(in,jn,1,2) bphi= uc4(in,jn,1,3) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) g=1./sqrt(sinhxi2+costh**2) a1= g* Sinhxi* Sinth* Cosphi a2= g* Sinhxi* Sinth* Sinphi a3= g* Coshxi*Costh b1= g* Coshxi* Costh* Cosphi b2= g* Coshxi* Costh* Sinphi b3= -g* Sinhxi* Sinth c1=- Sinphi c2= Cosphi c3=0 c vx= a1* vxi + b1* vth + c1 vphi c vy= a2* vxi + b2* vth + c2 vphi c vz= a3* vxi + b3* vth + c3 vphi bx(ii,jj+1)=a1*br+b1*bth+c1*bphi by(ii,jj+1)=a2*br+b2*bth+c2*bphi bz(ii,jj+1)=a3*br+b3*bth end do alpha=ddr/g4(ngpi+1,ngpj,1) uc2(i,j,k,1)=bx(1,1)+(bx(2,1)-bx(1,1))*alpha 1 +(bx(2,2)-bx(2,1))*beta uc2(i,j,k,2)=by(1,1)+(by(2,1)-by(1,1))*alpha 1 +(by(2,2)-by(2,1))*beta uc2(i,j,k,3)=bz(1,1)+(bz(2,1)-bz(1,1))*alpha 1 +(bz(2,2)-bz(2,1))*beta c uc2(i,j,k,1)=bx0 c uc2(i,j,k,2)=by0 c uc2(i,j,k,3)=bz0 c diff=abs(bxold-uc2(i,j,k,1))+ c 1 abs(byold-uc2(i,j,k,2))+ c 1 abs(bzold-uc2(i,j,k,3)) c ratio=diff/(abs(bxold)+abs(byold)+abs(bzold)) c write(*,*) 't',i,j, diff, ratio, bxold, uc2(i,j,k,1) itest=1 end if c at > th(mx4) if(ngpi.eq.mx4) then do jj=1,2 bx(2,jj)=bxpi by(2,jj)=bypi bz(2,jj)=bzpi end do in=mx4 ii=0 do jj=0,1 jn=ngpj+jj if(jn.gt.my4) jn=1 th=g4(in,jn,1) phi=g4(in,jn,2) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) br= uc4(in,jn,1,1) bth= uc4(in,jn,1,2) bphi= uc4(in,jn,1,3) g=1./sqrt(sinhxi2+costh**2) a1= g* Sinhxi* Sinth* Cosphi a2= g* Sinhxi* Sinth* Sinphi a3= g* Coshxi*Costh b1= g* Coshxi* Costh* Cosphi b2= g* Coshxi* Costh* Sinphi b3= -g* Sinhxi* Sinth c1=- Sinphi c2= Cosphi c3=0 c vx= a1* vxi + b1* vth + c1 vphi c vy= a2* vxi + b2* vth + c2 vphi c vz= a3* vxi + b3* vth + c3 vphi bx(ii+1,jj+1)=a1*br+b1*bth+c1*bphi by(ii+1,jj+1)=a2*br+b2*bth+c2*bphi bz(ii+1,jj+1)=a3*br+b3*bth end do alpha=ddr/(3.14159265359-g4(ngpi,ngpj,1)) bxold=uc2(i,j,k,1) byold=uc2(i,j,k,2) bzold=uc2(i,j,k,3) uc2(i,j,k,1)=(1.-alpha)*(1.-beta)*bx(1,1) 1 +(1.-alpha)* beta *bx(1,2) 1 + alpha*(1.-beta)*bx(2,1) 1 + alpha*beta*bx(2,2) uc2(i,j,k,2)=(1.-alpha)*(1.-beta)*by(1,1) 1 +(1.-alpha)* beta *by(1,2) 1 + alpha*(1.-beta)*by(2,1) 1 + alpha*beta*by(2,2) uc2(i,j,k,3)=(1.-alpha)*(1.-beta)*bz(1,1) 1 +(1.-alpha)* beta *bz(1,2) 1 + alpha*(1.-beta)*bz(2,1) 1 + alpha*beta*bz(2,2) c uc2(i,j,k,1)=bxpi uc2(i,j,k,2)=bypi uc2(i,j,k,3)=bzpi c c diff=abs(bxold-uc2(i,j,k,1))+ c 1 abs(byold-uc2(i,j,k,2))+ c 1 abs(bzold-uc2(i,j,k,3)) c ratio=diff/(abs(bxold)+abs(byold)+abs(bzold)) c write(*,*) 'b',i,j, diff, ratio, bxold, uc2(i,j,k,1) itest=2 end if if(ngpi.ge.1.and.ngpi.lt.mx4) then do ii=0,1 do jj=0,1 in=ngpi+ii jn=ngpj+jj if(jn.gt.my4) jn=1 th=g4(in,jn,1) phi=g4(in,jn,2) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) br= uc4(in,jn,1,1) bth= uc4(in,jn,1,2) bphi= uc4(in,jn,1,3) g=1./sqrt(sinhxi2+costh**2) a1= g* Sinhxi* Sinth* Cosphi a2= g* Sinhxi* Sinth* Sinphi a3= g* Coshxi*Costh b1= g* Coshxi* Costh* Cosphi b2= g* Coshxi* Costh* Sinphi b3= -g* Sinhxi* Sinth c1=- Sinphi c2= Cosphi c3=0 c vx= a1* vxi + b1* vth + c1 vphi c vy= a2* vxi + b2* vth + c2 vphi c vz= a3* vxi + b3* vth + c3 vphi bx(ii+1,jj+1)=a1*br+b1*bth+c1*bphi by(ii+1,jj+1)=a2*br+b2*bth+c2*bphi bz(ii+1,jj+1)=a3*br+b3*bth end do end do alpha=ddr/(g4(ngpi+1,ngpj,1)-g4(ngpi,ngpj,1)) bxold=uc2(i,j,k,1) byold=uc2(i,j,k,2) bzold=uc2(i,j,k,3) uc2(i,j,k,1)=(1.-alpha)*(1.-beta)*bx(1,1) 1 +(1.-alpha)* beta *bx(1,2) 1 + alpha*(1.-beta)*bx(2,1) 1 + alpha*beta*bx(2,2) uc2(i,j,k,2)=(1.-alpha)*(1.-beta)*by(1,1) 1 +(1.-alpha)* beta *by(1,2) 1 + alpha*(1.-beta)*by(2,1) 1 + alpha*beta*by(2,2) uc2(i,j,k,3)=(1.-alpha)*(1.-beta)*bz(1,1) 1 +(1.-alpha)* beta *bz(1,2) 1 + alpha*(1.-beta)*bz(2,1) 1 + alpha*beta*bz(2,2) diff=abs(bxold-uc2(i,j,k,1))+ 1 abs(byold-uc2(i,j,k,2))+ 1 abs(bzold-uc2(i,j,k,3)) ratio=diff/(abs(bxold)+abs(byold)+abs(bzold)) c write(*,*) i,j, diff, ratio, bxold, uc2(i,j,k,1) c 8811 format(3f10.6) c 8812 format(4f10.6) itest=3 end if c write(*,*) 'itest=',itest c if(itest.eq.1 .or. itest.eq.2) then c iii=itest c end if c write(*,*) i,j, diff, ratio, bxold, uc2(i,j,k,1) end if 10 continue return end subroutine modify(uc4,mth,mphi,vol) c c input uc4(ith,jphi,1,1)=bksi at ksi c output uc4(ith,jphi,1,1)=bksi-vol implicit none integer mth, mphi integer i,j real uc4(mth,mphi,2,6), vol c c br at R into k space do j=1,mth do i=1,mphi uc4(j,i,1,1)=uc4(j,i,1,1)-vol end do end do return end subroutine bbndry1(uc4,mth,mphi,wsave,mwsave) c c This is to construct the matrices xxx,ttt,fff to make it easy c to add a potential field on S, the surface of the spheroid. c xxx gives dB_r/dx, ttt gives B_theta and fff gives B_phi. c This also constructs the three matrices needed for del^2B: c Dxi, Dth and Dfi, and two matrices for dBth/dxsi and dBfi/dxsi. c The test is not thorough. It checks simple m=0,1 and 2 cases. c The r coordinate here coxxesponds to ksi. c (REMINDER:in application the fff matrix must be multiplied c by i=sqrt(-1). All exp(im*phi) factors are omitted. The ttt c component is along increasing theta, not increasing c mu=cos(theta)) c c c input uc4(ith,jphi,1,1)=bksi at ksi c output uc4(ith,jphi,1,2:5)=bth, bphi, dBksi/dksi, dBth/dksi at R c output uc4(ith,jphi,1,6)=RHS1 c 2,1:2)=bksi, bth at ksi-dksi c 2,3:5)=Dksi, Dth, Dphi at R c 2,6)=RHS2 implicit none integer imax, jmax,lmax,lmmax,lmmax1,mmax integer mth, mphi, mwsave integer i,j,k,l,m,kk,kkk c mmax=mphi/3*2 c imax=mphi c jmax=mth parameter(imax=3*3*2**4, mmax=imax/3*2, jmax=3*22,lmax=mmax, 1 lmmax=lmax+mmax,lmmax1=lmmax+1) real wsave(mwsave), aimax real bb(imax) real uc4(mth,mphi,2,6) real gausspt(jmax),gausswt(jmax),snj(jmax),dg0(jmax) 6 ,xxx(0:mmax,jmax,jmax),ttt(0:mmax,jmax,jmax) 7 ,fff(0:mmax,jmax,jmax),Dxi(0:mmax,jmax,jmax) 8 ,Dth(0:mmax,jmax,jmax),Dfi(0:mmax,jmax,jmax) 9 ,dBth(0:mmax,jmax,jmax),dBfi(0:mmax,jmax,jmax) real tempr,tempt,tempf,tempx1,tempx2,tempth,tempfi 1 ,brak(imax,jmax), dbrdrk(imax,jmax), btak(imax,jmax) 1 ,bfak(imax,jmax) common/bbndryv/gausspt, snj,dg0, 1 xxx,ttt,fff,Dxi,Dth,Dfi,dBth,dBfi c c c c br at R into k space do j=1,jmax do i=1,imax bb(i)=uc4(j,i,1,1) end do call rfftf(imax,bb,wsave) do i=1,imax brak(i,j)=bb(i) end do end do c for m=1 kk=1 m=kk-1 kkk=kk c write(8,999) m do j=1,jmax tempr= dg0(j)*Brak(kkk,j) tempt=0. tempf=0. do k=1,jmax tempr=tempr+xxx(m,j,k)*Brak(kkk,k) tempt=tempt+ttt(m,j,k)*Brak(kkk,k) tempf=tempf+fff(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf end do do 60 kk=2,mmax/2 m=kk-1 kkk=2*kk-2 c write(8,999) m do 60 j=1,jmax tempr= dg0(j)*Brak(kkk,j) tempt=0. tempf=0. do k=1,jmax tempr=tempr+xxx(m,j,k)*Brak(kkk,k) tempt=tempt+ttt(m,j,k)*Brak(kkk,k) tempf=tempf+fff(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf 60 continue c do 70 kk=2,mmax/2 m=kk-1 kkk=2*kk-1 c write(8,999) m do 70 j=1,jmax tempr= dg0(j)*Brak(kkk,j) tempt=0. tempf=0. do k=1,jmax tempr=tempr+xxx(m,j,k)*Brak(kkk,k) tempt=tempt+ttt(m,j,k)*Brak(kkk,k) tempf=tempf+fff(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf 70 continue do j=1,jmax c dbrdrk(1,j)=0. c btak(1,j)=0. c bfak(1,j)=0. do i=mmax,imax dbrdrk(i,j)=0. btak(i,j)=0. bfak(i,j)=0. end do end do c c c dbr/dr aimax=1./float(imax) do 80 j=1,jmax do i=1,imax bb(i)=dbrdrk(i,j) end do call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,1,4)=bb(i)*aimax end do 80 continue c c c 998 format(i2,6(x,f12.5)) c 999 format(/,'Results for m=',i2/x,'j',7x,'dBr/dr',4x,'approx dBr/dr' c 1 ,3x,'Btheta',4x,'approx Btheta',4x,'Bphi',5x,'approx Bphi') c c bth do j=1,jmax do i=1,imax bb(i)=btak(i,j) end do call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,1,2)=bb(i) *aimax end do end do c c bphi do j=1,jmax c do i=1,imax c bb(i)=bfak(i,j) c end do bb(1)=bfak(1,j) if(abs(bb(1)).gt. 0.000001) write(*,*) 'bb(1) too big (bbndry)' do i=2,imax-2,2 bb(i)=-bfak(i+1,j) bb(i+1)=bfak(i,j) end do bb(imax)=0. call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,1,3)=bb(i) *aimax end do end do ccc Now for Dxi, Dth, and Dphi c for m=1 kk=1 m=kk-1 kkk=kk c write(8,999) m do j=1,jmax tempr=0. tempt=0. tempf=0. do k=1,jmax tempr=tempr+dxi(m,j,k)*Brak(kkk,k) tempt=tempt+dth(m,j,k)*Brak(kkk,k) tempf=tempf+dfi(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf end do do kk=2,mmax/2 m=kk-1 kkk=2*kk-2 c write(8,999) m do j=1,jmax tempr=0. tempt=0. tempf=0. do k=1,jmax tempr=tempr+dxi(m,j,k)*Brak(kkk,k) tempt=tempt+dth(m,j,k)*Brak(kkk,k) tempf=tempf+dfi(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf end do end do c do kk=2,mmax/2 m=kk-1 kkk=2*kk-1 c write(8,999) m do j=1,jmax tempr=0. tempt=0. tempf=0. do k=1,jmax tempr=tempr+dxi(m,j,k)*Brak(kkk,k) tempt=tempt+dth(m,j,k)*Brak(kkk,k) tempf=tempf+dfi(m,j,k)*Brak(kkk,k) end do dbrdrk(kkk,j)=tempr btak(kkk,j)=tempt bfak(kkk,j)=tempf end do end do do j=1,jmax c dbrdrk(1,j)=0. c btak(1,j)=0. c bfak(1,j)=0. do i=mmax,imax dbrdrk(i,j)=0. btak(i,j)=0. bfak(i,j)=0. end do end do c c c Dxi aimax=1./float(imax) do j=1,jmax do i=1,imax bb(i)=dbrdrk(i,j) end do call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,2,3)=bb(i)*aimax end do end do c Dth c aimax=1./float(imax) do j=1,jmax do i=1,imax bb(i)=btak(i,j) end do call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,2,4)=bb(i)*aimax end do end do c Dfi c aimax=1./float(imax) do j=1,jmax do i=1,imax bb(i)=bfak(i,j) end do call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,2,5)=bb(i)*aimax end do end do do j=1,jmax bb(1)=bfak(1,j) if(abs(bb(1)).gt. 0.000001) write(*,*) 'bb(1) too big (bbndry)' do i=2,imax-2,2 bb(i)=-bfak(i+1,j) bb(i+1)=bfak(i,j) end do bb(imax)=0. call rfftb(imax,bb,wsave) do i=1,imax uc4(j,i,2,5)=bb(i) *aimax end do end do c return end subroutine interpBr4R(uc4, g4,ig, mx4,my4, igrid, nxs,nxe,nys,nye, 1 ngp, drngp, numngp, uc2,g2,mx2,my2,mz2, dr,ds,dt,mngp,xi) dimension uc4(mx4,my4,2,6), g4(mx4,my4,2), ig(mx4,my4),ngp(mngp,3) 1 , drngp(mngp,3), bb(3) dimension uc2(mx2,my2,mz2,4),g2(mx2,my2,mz2,3) c c get Br on R at grid 4 from grid 2 and grid 3 sinhxi=sinh(xi) coshxi=cosh(xi) sinhxi2=sinhxi**2 intnum=0 do 10 i=nxs, nxe do 10 j=nys, nye th=g4(i,j,1) phi=g4(i,j,2) costh=cos(th) sinth=sin(th) cosphi=cos(phi) sinphi=sin(phi) g=1./sqrt(costh**2+sinhxi2) a1=g*sinhxi*sinth*cosphi b1=g*sinhxi*sinth*sinphi c1=g*coshxi*costh a2=g*coshxi*costh*cosphi b2=g*coshxi*costh*sinphi c2=-g*sinhxi*sinth if(ig(i,j).eq.igrid) then intnum=intnum+1 ngpi=ngp(intnum,1) ngpj=ngp(intnum,2) ngpk=ngp(intnum,3) ddr=drngp(intnum,1) dds=drngp(intnum,2) ddt=drngp(intnum,3) c write(*,*) i,j, ngpi,ngpj,ngpk, ddr, dds,ddt alpha=ddr/dr beta=dds/ds gamma=ddt/dt c do m=1,3 fmm = uc2(ngpi-1,ngpj-1, ngpk ,m) fm0 = uc2(ngpi-1,ngpj, ngpk ,m) fm1 = uc2(ngpi-1,ngpj+1, ngpk ,m) f0m = uc2(ngpi,ngpj-1, ngpk ,m) f00 = uc2(ngpi,ngpj, ngpk ,m) f01 = uc2(ngpi,ngpj+1, ngpk ,m) f1m = uc2(ngpi+1,ngpj-1, ngpk ,m) f10 = uc2(ngpi+1,ngpj, ngpk ,m) f11 = uc2(ngpi+1,ngpj+1, ngpk ,m) c00=f00 c01=0.5*(f01-f0m) c02=0.5*(-2.*f00 + f01 + f0m) c10=0.5*(f10 - fm0 ) c11=0.25*(f11 - f1m - fm1 + fmm) c12=0.25*(-2.*f10 + f11 + f1m + 2.*fm0 - fm1 - fmm) c20=0.5*(-2.*f00 + f10 + fm0) c21=0.25*(-2.*f01 + 2.*f0m + f11 - f1m + fm1 - fmm) c22=0.25*(4.*f00 - 2.*f01 - 2.*f0m - 2.*f10 1 + f11 + f1m - 2.*fm0 + fm1 + fmm) bb(m)= c00 + c10*alpha + c01 *beta + 1 c20*alpha**2 + c11*alpha *beta + c02 *beta**2 + 1 c21*alpha**2 *beta + c12*alpha *beta**2 + c22*alpha**2 *beta**2 end do uc4(i,j,1,1)=a1*bb(1)+b1*bb(2)+c1*bb(3) uc4(i,j,1,2)=a2*bb(1)+b2*bb(2)+c2*bb(3) c if(intnum.le.5) then c write(*,*) uc4(i,j,1,1), uc4(i,j,1,2) c write(*,*) ngpi, ngpj, ngpk, gamma, uc2(ngpi,ngpj,ngpk,1) c end if 8811 format(3f10.6) 8812 format(4f10.6) end if 10 continue return end subroutine getBbndry(ub,ig,mx,my,mz,dr,ds,dt, 1 nxs,nxe,nys,nye,nzs,nze, igrid) c ig=igrid --> interior point c c out-put Bx, By, Bz on surface parameter (mtm=4, mn=4) dimension ub(mx,my,mz,mn),ig(mx,my,mz) common /var1/omega,omegap, omegapx,omegapz,ca,cb,anu,eta, factor c ca: major radius (x, y); cb: minor radius (z) c cL=sqrt(ca**2-cb**2) c find B on the surface k=nze icount=0 do 200 i = nxs, nxe do 200 j = nys, nye c c interior points and also bndry points from other grid if (ig(i,j,k).ne.0) then c same as the next statement c if (ig(i,j,k).eq.igrid .or. ig(i,j,k) .eq. igridI) then c interior points c icount=icount+1 c if(icount.le.5) write(*,*) 'old', ub(i,j,k,1), c 1 ub(i,j,k,2),ub(i,j,k,3) do m=1,3 ub(i,j,k,m)=2.*ub(i,j,k-1,m)-ub(i,j,k-2,m) end do c if(icount.le.5) write(*,*) 'new', ub(i,j,k,1), c 1 ub(i,j,k,2),ub(i,j,k,3) end if 200 continue return end subroutine bbndryini c c This is to construct the matrices xxx,ttt,fff to make it easy c to add a potential field on S, the surface of the spheroid. c xxx gives dB_r/dx, ttt gives B_theta and fff gives B_phi. c This also constructs the three matrices needed for del^2B: c Dxi, Dth and Dfi, and two matrices for dBth/dxsi and dBfi/dxsi. c The test is not thorough. It checks simple m=0,1 and 2 cases. c The r coordinate here corresponds to ksi. c (REMINDER:in application the fff matrix must be multiplied c by i=sqrt(-1). All exp(im*phi) factors are omitted. The ttt c component is along increasing theta, not increasing mu=cos(theta)) c implicit none integer l,m,j,imax,jmax,k,lmax,lmmax,lmmax1,mmax parameter(imax=3*3*2**4,mmax=imax/3*2,lmax=mmax 1 ,lmmax=lmax+mmax,lmmax1=lmmax+1,jmax=3*22) c parameter(mmax=10,lmax=10,lmmax=lmax+mmax,lmmax1=lmmax+1,jmax=22) real gausspt(jmax),gausswt(jmax),snj(jmax),cnj(jmax),wt(jmax) 1 ,gg(jmax),gg2(jmax),gg3(jmax),dg(jmax),ddg(jmax) 2 ,dg0(jmax),dg1(jmax),dg2(jmax) 3 ,aa(0:lmmax,0:lmax),da,qq(0:lmmax,0:lmax) 4 ,vv(0:lmmax,0:lmax),dv,vvv(0:lmmax,0:lmax) 5 ,vaux(0:lmmax,0:lmax),clm(0:lmmax1,0:mmax) 6 ,xxx(0:mmax,jmax,jmax),ttt(0:mmax,jmax,jmax) 7 ,fff(0:mmax,jmax,jmax),Dxi(0:mmax,jmax,jmax) 8 ,Dth(0:mmax,jmax,jmax),Dfi(0:mmax,jmax,jmax) 9 ,dBth(0:mmax,jmax,jmax),dBfi(0:mmax,jmax,jmax) real c 0 Bxa(0:2,jmax),dBx(0:2,jmax),Bta(0:2,jmax),Bfa(0:2,jmax) c 1 ,dBc(0:2,jmax),Btc(0:2,jmax),Bfc(0:2,jmax) c 2 ,Dxa(0:2,jmax),Dta(0:2,jmax),Dfa(0:2,jmax) c 3 ,Dxc(0:2,jmax),Dtc(0:2,jmax),Dfc(0:2,jmax) c 4 ,dx(0:mmax,0:lmmax),xx(0:mmax,0:lmmax) 5 tempr,tempt,tempf,tempx1,tempx2,tempth,tempfi 6 ,tempBth,tempBfi,pj,pk,pjm,pjp,pder,thetaj,thetak,xb 7 ,c,xsi0,chxsi0,shxsi0,bigL,bigL2,c2,aux,aux0,aux1,aux2,rt,T 8 ,g,ga,sn,cn,sn2,cn2 c 9 ,P01,P02,P03,P11,P12,P13,P22,P23 c 9 ,D01,D02,D03,D11,D12,D13,D22,D23,capX,capX2,capX3,capX5 c real dBta(0:2,jmax),dBtc(0:2,jmax),dBfa(0:2,jmax),dBfc(0:2,jmax) c real costh, sinth, cosphi, sinphi, coshxi, sinhxi, xmax, x, y,z c 1 ,rrr, r3, bx, by, bz, a1, a2, a3, b1,b2,b3,c1,c2 c3, br,bth,bphi integer lmin common/bbndryv/gausspt, snj,dg0, 1 xxx,ttt,fff,Dxi,Dth,Dfi,dBth,dBfi c c open(unit=8,file='ForCC8.res') c c Define the spheroid and related quantities c=0.8 c bigL2=1.d0-c*c bigL=sqrt(bigL2) chxsi0=1.0/bigL shxsi0=c*chxsi0 xsi0=0.5*alog((1.+c)/(1.-c)) c write(8,997) c,xsi0,bigL call legrat(shxsi0,aa) c Convert aa to R/(dR/dksi) from R/(dR/dksibar) c Compute some useful xsi arrays: c qq=l(l+1)-m^2/cosh(xsi)^2,vv=R''/R', dv=dv/dxsi, vvv=R'''/R', c and vaux=(R''-tanh(xsi)R'-R/cosh(xsi)**2)/R'cosh(xsi). c write(8,764) do 10 m=0,mmax do 10 l=m,m+lmax aa(l,m)=bigL*aa(l,m) qq(l,m)=float(l*(l+1))-float(m*m)*bigL**2 vv(l,m)=aa(l,m)*qq(l,m)-c da=1.d0-aa(l,m)*vv(l,m) dv=qq(l,m)*da+(2.d0*float(m*m)*c*aa(l,m)-1.d0)*bigL2 vvv(l,m)=dv+vv(l,m)**2 vaux(l,m)=vv(l,m)-c-aa(l,m)*bigL2 c write(8,765) m,l,aa(l,m),qq(l,m),vv(l,m),vvv(l,m),vaux(l,m) 10 continue c c Calculate Gaussian points and weights, and also the g function c and associated arrays: dg=dg/g.dxsi, ddg=d^2g/g.dxsi^2, dg1=dg-tanh(xsi), c dg1=2dg+tanh(xsi), dg2=ddg+dg*tanh(xsi) call gquad(jmax,gausspt,gausswt) do 20 j=1,jmax snj(j)=sin(gausspt(j)) cnj(j)=cos(gausspt(j)) gg(j)=1.0/sqrt(chxsi0**2-snj(j)**2) gg2(j)=gg(j)**2 dg(j)=-shxsi0*chxsi0*gg2(j) ddg(j)=3.d0*dg(j)**2-gg2(j)*(shxsi0**2+chxsi0**2) dg0(j)=dg(j)-c dg1(j)=2.d0*dg(j)+c dg2(j)=ddg(j)+c*dg(j) 20 continue c write(8,777) 8,gg(8),gg2(8),dg(8),ddg(8),dg0(8),dg1(8),dg2(8) c write(8,777) 16,gg(16),gg2(16),dg(16),ddg(16) c 1 ,dg0(16),dg1(16),dg2(16) c c Compute coupling constants for computing the P_l^m derivative. do 30 m=0,mmax do 30 l=m,m+lmax+1 clm(l,m)=sqrt(float(l*l-m*m)/float(4*l*l-1)) 30 continue c c Compute xxx,ttt,fff,Dxi,Dth,Dfi,dBth and dBfi matrices. c Note:pder=dP_l^m(theta)/dtheta but recurrence relation c (using clm) gives sin(theta)dP_l^m(theta)/dtheta. c Note:tempx2 and tempBth below are the same but are used differently. c Note:the diffusion matrices Dxi,Dth,dfi contain the c L^2 factor in the denominators. do 40 m=0,mmax lmin=m if (m.eq.0) lmin=1 do 40 j=1,jmax thetaj=gausspt(j) sn=snj(j) do 40 k=1,jmax thetak=gausspt(k) tempf=0.d0 tempt=0.d0 tempr=0.d0 tempx1=0.d0 tempx2=0.d0 tempth=0.d0 tempfi=0.d0 tempBth=0.d0 tempBfi=0.d0 do 45 l=lmin,m+lmax call pbar(thetaj,l,m,pj) call pbar(thetaj,l+1,m,pjp) pder=float(l)*clm(l+1,m)*pjp if (l.ne.m) then call pbar(thetaj,l-1,m,pjm) pder=pder-float(l+1)*clm(l,m)*pjm endif pder=pder/sn call pbar(thetak,l,m,pk) aux=aa(l,m) aux1=pj*pk aux2=pder*pk tempf=tempf+aux1*aux tempr=tempr+aux1*qq(l,m)*aux tempt=tempt+aux2*aux tempx1=tempx1+(vvv(l,m)+2.d0*vv(l,m)*dg(j)+ddg(j))*aux1 tempx2=tempx2+(1.d0+dg(j)*aux)*aux2 tempth=tempth+(vv(l,m)+dg1(j)+dg2(j)*aux)*aux2 tempfi=tempfi+vaux(l,m)*aux1 tempBth=tempBth+(1.d0+dg(j)*aux)*aux2 tempBfi=tempBfi+(1.d0-c*aux)*aux1 45 continue aux=gg(j) aux1=gausswt(k)/gg(k) aux2=aux1*gg2(j)/bigL2 xxx(m,j,k)=aux1*aux*tempr ttt(m,j,k)=aux1*aux*tempt fff(m,j,k)=bigL*float(m)*aux1*tempf/sn Dxi(m,j,k)=aux2*aux 1 *(tempx1-2.d0*gg2(j)*snj(j)*cnj(j)*tempx2) Dth(m,j,k)=aux2*aux*tempth Dfi(m,j,k)=bigL*float(m)*aux2*tempfi/sn dBth(m,j,k)=aux*aux1*tempBth dBfi(m,j,k)=bigL*float(m)*aux1*tempBfi/sn 40 continue c return end c c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c subroutine legrat(x,rat) c Calculate rat(l,m)=Rlm/(dRlm/dx) by downward recursion. c Note: the x corresponds to ksibar not ksi, c Note (3/16/04): I tested this for small c (=0.1) and it c did not give an xx that agreed well with exact values.. c implicit none integer l,m,lmax,mmax,lmmax,lupper, imax parameter(imax=3*3*2**4, mmax=imax/3*2,lmax=mmax, 1 lmmax=lmax+mmax) c parameter(lmax=10,mmax=10,lmmax=lmax+mmax) real rat(0:lmmax,0:lmax),x,x2,temp,aux c x2=x*x do 1 m=0,mmax temp=1.d0 lupper=4*(m+lmax) do 1 l=lupper,m,-1 temp=1.d0/(1.d0+float((l+m+2)*(l-m+2))*temp 1 /(float((2*l+5)*(2*l+3))*x2)) if (l.le.m+lmax) rat(l,m)=temp 1 continue do 2 m=0,mmax do 2 l=m,m+lmax rat(l,m)=-(float(l+1)*x2+float((l+m+1)*(l-m+1)) 1 *rat(l,m)/float(2*l+3))/(x2+1.d0) 2 continue do 3 m=0,mmax do 3 l=m,m+lmax rat(l,m)=x/rat(l,m) 3 continue c return end c c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++=== c subroutine gquad(l,root,w) c c Finds the l roots (in theta) and associated gaussian weights c for the legendxe polynomial of degree l > 1. c Note: usually Gauss integration is done in mu=cos(theta) c with -1.le.mu.le.1. In converting from mu to theta c an extra factor of sin(theta) is required and this is c incorporated by the subroutine below. c Subroutine required: pbar c implicit none integer l,l1,l2,l3,l22,k,i real root(l),w(l),pi,del,co,p,p1,p2,s,t1,t2,theta c pi=4.d0*atan(1.d0) del=pi/float(4*l) l1=l+1 co=float(2*l+3)/float(l1**2) p2=1.d0 t2=-del l2=l/2 k=1 c do 10 i=1,l2 20 t1=t2 t2=t1+del theta=t2 call pbar(theta,l,0,p) p1=p2 p2=p if ((k*p2).gt.0.d0) go to 20 k=-k 40 s=(t2-t1)/(p2-p1) t1=t2 t2=t2-s*p2 theta=t2 call pbar(theta,l,0,p) p1=p2 p2=p if (abs(p).le.1.d-10) go to 30 if (p2.eq.p1) then write(6,*) 'sub gquad: zero = ',p,' at i = ',i go to 30 endif go to 40 30 root(i)=theta call pbar(theta,l1,0,p) w(i)=co*(sin(theta)/p)**2 10 continue c l22=2*l2 if (l22.eq.l) go to 70 l2=l2+1 theta=pi/2. root(l2)=theta call pbar(theta,l1,0,p) w(l2)=co/p**2 70 continue c l3=l2+1 do 50 i=l3,l root(i)=pi-root(l-i+1) w(i)=w(l-i+1) 50 continue c return end c c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c subroutine pbar(the,l,m,p) c c pbar calculates the value of the normalized associated c legendxe function of the first kind, of degree l, c of order m, for the real argument cos(the), c 0 .le. m .le. l c implicit none integer l,m,m1,i,j real the,p,p1,p2,s,c c s=sin(the) c=cos(the) p=1.0/sqrt(2.d0) if (m.eq.0) go to 22 do 20 i=1,m p=sqrt(float(2*i+1)/float(2*i))*s*p 20 continue 22 continue if (l.eq.m) return p1=1.d0 m1=m+1 do 30 j=m1,l p2=p1 p1=p p=2.d0*sqrt((float(j**2)-0.25d0)/float(j**2-m**2))*c*p1 $ -sqrt(float((2*j+1)*(j-m-1)*(j+m-1))/ $ float((2*j-3)*(j-m)*(j+m)))*p2 30 continue c return end cccCC c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c ccc rffti.f SUBROUTINE RFFTI (N,WSAVE) DIMENSION WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTI1 (N,WA,IFAC) DIMENSION WA(1) ,IFAC(1) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/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 IFAC(NF+2) = NTRY NL = NQ IF (NTRY .NE. 2) GO TO 107 IF (NF .EQ. 1) GO TO 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 CONTINUE IFAC(3) = 2 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF TPI = 6.28318530717959 ARGH = TPI/FLOAT(N) IS = 0 NFM1 = NF-1 L1 = 1 IF (NFM1 .EQ. 0) RETURN DO 110 K1=1,NFM1 IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IPM = IP-1 DO 109 J=1,IPM LD = LD+L1 I = IS ARGLD = FLOAT(LD)*ARGH FI = 0. DO 108 II=3,IDO,2 I = I+2 FI = FI+1. 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 cc rfftf.f SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , 1 WA1(1) DO 101 K=1,L1 CH(1,1,K) = CC(1,K,1)+CC(1,K,2) CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) 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 TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(1,2,K) = -CC(IDO,K,2) CH(IDO,1,K) = CC(IDO,K,1) 106 CONTINUE 107 RETURN END SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , 1 WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,.866025403784439/ DO 101 K=1,L1 CR2 = CC(1,K,2)+CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2 CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , 1 WA1(1) ,WA2(1) ,WA3(1) DATA HSQT2 /.7071067811865475/ DO 101 K=1,L1 TR1 = CC(1,K,2)+CC(1,K,4) TR2 = CC(1,K,1)+CC(1,K,3) CH(1,1,K) = TR1+TR2 CH(IDO,4,K) = TR2-TR1 CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) CH(1,3,K) = CC(1,K,4)-CC(1,K,2) 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 CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 CONTINUE DO 106 K=1,L1 TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) CH(IDO,1,K) = TR1+CC(IDO,K,1) CH(IDO,3,K) = CC(IDO,K,1)-TR1 CH(1,2,K) = TI1-CC(IDO,K,3) CH(1,4,K) = TI1+CC(IDO,K,3) 106 CONTINUE 107 RETURN END SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ DO 101 K=1,L1 CR2 = CC(1,K,5)+CC(1,K,2) CI5 = CC(1,K,5)-CC(1,K,2) CR3 = CC(1,K,4)+CC(1,K,3) CI4 = CC(1,K,4)-CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2+CR3 CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 CH(1,3,K) = TI11*CI5+TI12*CI4 CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 CH(1,5,K) = TI12*CI5-TI11*CI4 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) DATA TPI/6.28318530717959/ ARG = TPI/FLOAT(IP) DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 IPP2 = IP+2 IDP2 = IDO+2 NBD = (IDO-1)/2 IF (IDO .EQ. 1) GO TO 119 DO 101 IK=1,IDL1 CH2(IK,1) = C2(IK,1) 101 CONTINUE DO 103 J=2,IP DO 102 K=1,L1 CH(1,K,J) = C1(1,K,J) 102 CONTINUE 103 CONTINUE IF (NBD .GT. L1) 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(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(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(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 108 CONTINUE 109 CONTINUE 110 CONTINUE 111 IF (NBD .LT. L1) GO TO 115 DO 114 J=2,IPPH JC = IPP2-J DO 113 K=1,L1 DO 112 I=3,IDO,2 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(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(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 116 CONTINUE 117 CONTINUE 118 CONTINUE GO TO 121 119 DO 120 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 120 CONTINUE 121 DO 123 J=2,IPPH JC = IPP2-J DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) 122 CONTINUE 123 CONTINUE C AR1 = 1. AI1 = 0. 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(IK,L) = C2(IK,1)+AR1*C2(IK,2) CH2(IK,LC) = AI1*C2(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(IK,L) = CH2(IK,L)+AR2*C2(IK,J) CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE DO 129 J=2,IPPH DO 128 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+C2(IK,J) 128 CONTINUE 129 CONTINUE C IF (IDO .LT. L1) GO TO 132 DO 131 K=1,L1 DO 130 I=1,IDO CC(I,1,K) = CH(I,K,1) 130 CONTINUE 131 CONTINUE GO TO 135 132 DO 134 I=1,IDO DO 133 K=1,L1 CC(I,1,K) = CH(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(IDO,J2-2,K) = CH(1,K,J) CC(1,J2-1,K) = CH(1,K,JC) 136 CONTINUE 137 CONTINUE IF (IDO .EQ. 1) RETURN IF (NBD .LT. 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(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(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(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 142 CONTINUE 143 CONTINUE 144 CONTINUE RETURN END SUBROUTINE RFFTF (N,R,WSAVE) DIMENSION R(1) ,WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 1 L2 = N IW = N DO 111 K1=1,NF KH = NF-K1 IP = IFAC(KH+3) L1 = L2/IP IDO = N/L2 IDL1 = IDO*L1 IW = IW-(IP-1)*IDO NA = 1-NA IF (IP .NE. 4) GO TO 102 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 110 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) GO TO 110 102 IF (IP .NE. 2) GO TO 104 IF (NA .NE. 0) GO TO 103 CALL RADF2 (IDO,L1,C,CH,WA(IW)) GO TO 110 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) GO TO 110 104 IF (IP .NE. 3) GO TO 106 IX2 = IW+IDO IF (NA .NE. 0) GO TO 105 CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 110 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) GO TO 110 106 IF (IP .NE. 5) GO TO 108 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 107 CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 108 IF (IDO .EQ. 1) NA = 1-NA IF (NA .NE. 0) GO TO 109 CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) NA = 1 GO TO 110 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) NA = 0 110 L2 = L1 111 CONTINUE IF (NA .EQ. 1) RETURN DO 112 I=1,N C(I) = CH(I) 112 CONTINUE RETURN END ccc rfftb.f SUBROUTINE COSQB (N,X,WSAVE) DIMENSION X(1) ,WSAVE(1) DATA TSQRT2 /2.82842712474619/ IF (N-2) 101,102,103 101 X(1) = 4.*X(1) RETURN 102 X1 = 4.*(X(1)+X(2)) X(2) = TSQRT2*(X(1)-X(2)) X(1) = X1 RETURN 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1)) RETURN END SUBROUTINE COSQB1 (N,X,W,XH) DIMENSION X(1) ,W(1) ,XH(1) NS2 = (N+1)/2 NP2 = N+2 DO 101 I=3,N,2 XIM1 = X(I-1)+X(I) X(I) = X(I)-X(I-1) X(I-1) = XIM1 101 CONTINUE X(1) = X(1)+X(1) MODN = MOD(N,2) IF (MODN .EQ. 0) X(N) = X(N)+X(N) CALL RFFTB (N,X,XH) DO 102 K=2,NS2 KC = NP2-K XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) 102 CONTINUE IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) DO 103 K=2,NS2 KC = NP2-K X(K) = XH(K)+XH(KC) X(KC) = XH(K)-XH(KC) 103 CONTINUE X(1) = X(1)+X(1) RETURN END SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(1) DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) 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 CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) 106 CONTINUE 107 RETURN END SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(1) ,WA2(1) DATA TAUR,TAUI /-.5,.866025403784439/ DO 101 K=1,L1 TR2 = CC(IDO,2,K)+CC(IDO,2,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(1) ,WA2(1) ,WA3(1) DATA SQRT2 /1.414213562373095/ DO 101 K=1,L1 TR1 = CC(1,1,K)-CC(IDO,4,K) TR2 = CC(1,1,K)+CC(IDO,4,K) TR3 = CC(IDO,2,K)+CC(IDO,2,K) TR4 = CC(1,3,K)+CC(1,3,K) CH(1,K,1) = TR2+TR3 CH(1,K,2) = TR1-TR4 CH(1,K,3) = TR2-TR3 CH(1,K,4) = TR1+TR4 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 TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 103 CONTINUE 104 CONTINUE IF (MOD(IDO,2) .EQ. 1) RETURN 105 CONTINUE DO 106 K=1,L1 TI1 = CC(1,2,K)+CC(1,4,K) TI2 = CC(1,4,K)-CC(1,2,K) TR1 = CC(IDO,1,K)-CC(IDO,3,K) TR2 = CC(IDO,1,K)+CC(IDO,3,K) CH(IDO,K,1) = TR2+TR2 CH(IDO,K,2) = SQRT2*(TR1-TI1) CH(IDO,K,3) = TI2+TI2 CH(IDO,K,4) = -SQRT2*(TR1+TI1) 106 CONTINUE 107 RETURN END SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ DO 101 K=1,L1 TI5 = CC(1,3,K)+CC(1,3,K) TI4 = CC(1,5,K)+CC(1,5,K) TR2 = CC(IDO,2,K)+CC(IDO,2,K) TR3 = CC(IDO,4,K)+CC(IDO,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI5 = TI11*TI5+TI12*TI4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(1,K,5) = CR2+CI5 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+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(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 102 CONTINUE 103 CONTINUE RETURN END SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(1) DATA TPI/6.28318530717959/ ARG = TPI/FLOAT(IP) DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 NBD = (IDO-1)/2 IPP2 = IP+2 IPPH = (IP+1)/2 IF (IDO .LT. L1) GO TO 103 DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,1) = CC(I,1,K) 101 CONTINUE 102 CONTINUE GO TO 106 103 DO 105 I=1,IDO DO 104 K=1,L1 CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE 106 DO 108 J=2,IPPH JC = IPP2-J J2 = J+J DO 107 K=1,L1 CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) 107 CONTINUE 108 CONTINUE IF (IDO .EQ. 1) GO TO 116 IF (NBD .LT. 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(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(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(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 113 CONTINUE 114 CONTINUE 115 CONTINUE 116 AR1 = 1. AI1 = 0. 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(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) C2(IK,LC) = AI1*CH2(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(IK,L) = C2(IK,L)+AR2*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) 118 CONTINUE 119 CONTINUE 120 CONTINUE DO 122 J=2,IPPH DO 121 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 121 CONTINUE 122 CONTINUE DO 124 J=2,IPPH JC = IPP2-J DO 123 K=1,L1 CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) 123 CONTINUE 124 CONTINUE IF (IDO .EQ. 1) GO TO 132 IF (NBD .LT. L1) GO TO 128 DO 127 J=2,IPPH JC = IPP2-J DO 126 K=1,L1 DO 125 I=3,IDO,2 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(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(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 129 CONTINUE 130 CONTINUE 131 CONTINUE 132 CONTINUE IF (IDO .EQ. 1) RETURN DO 133 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 133 CONTINUE DO 135 J=2,IP DO 134 K=1,L1 C1(1,K,J) = CH(1,K,J) 134 CONTINUE 135 CONTINUE IF (NBD .GT. L1) 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(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(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(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 140 CONTINUE 141 CONTINUE 142 CONTINUE 143 RETURN END SUBROUTINE RFFTB (N,R,WSAVE) DIMENSION R(1) ,WSAVE(1) IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(1) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDL1 = IDO*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL RADB2 (IDO,L1,C,CH,WA(IW)) GO TO 105 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDO IF (NA .NE. 0) GO TO 107 CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 110 CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (IDO .EQ. 1) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDO 116 CONTINUE IF (NA .EQ. 0) RETURN DO 117 I=1,N C(I) = CH(I) 117 CONTINUE RETURN END SUBROUTINE SINQB (N,X,WSAVE) DIMENSION X(1) ,WSAVE(1) IF (N .GT. 1) GO TO 101 X(1) = 4.*X(1) RETURN 101 NS2 = N/2 DO 102 K=2,N,2 X(K) = -X(K) 102 CONTINUE CALL COSQB (N,X,WSAVE) DO 103 K=1,NS2 KC = N-K XHOLD = X(K) X(K) = X(KC+1) X(KC+1) = XHOLD 103 CONTINUE RETURN END