Scrambler  1
spectra.f90
Go to the documentation of this file.
00001 !#########################################################################
00002 !               
00003 !    Copyright (C) 2003-2012 Department of Physics and Astronomy,
00004 !                            University of Rochester,
00005 !                            Rochester, NY
00006 !
00007 !    spectra.f90 is part of AstroBEAR.
00008 !
00009 !    AstroBEAR is free software: you can redistribute it and/or modify    
00010 !    it under the terms of the GNU General Public License as published by 
00011 !    the Free Software Foundation, either version 3 of the License, or    
00012 !    (at your option) any later version.
00013 !
00014 !    AstroBEAR is distributed in the hope that it will be useful, 
00015 !    but WITHOUT ANY WARRANTY; without even the implied warranty of
00016 !    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00017 !    GNU General Public License for more details.
00018 !
00019 !    You should have received a copy of the GNU General Public License
00020 !    along with AstroBEAR.  If not, see <http://www.gnu.org/licenses/>.
00021 !
00022 !#########################################################################
00023 MODULE Spectras
00024   USE TreeDeclarations
00025   USE DataDeclarations
00026   USE PhysicsDeclarations
00027   USE GlobalDeclarations
00028   USE EllipticDeclarations
00029   USE EOS
00030   USE ParticleDeclarations
00031   USE Fields
00032   USE IOBOV
00033   USE ProcessingDeclarations
00034   USE PFFT
00035   USE LayoutControl
00036   USE LayoutComms
00037   USE SlopeLim
00038   IMPLICIT NONE
00039   INTEGER, PARAMETER :: MAXIMUMSPECTRALEVEL=-1
00040   INTEGER, PARAMETER :: SCALAR_SPECT=0, VECTOR_SPECT=1
00041   INTEGER, PARAMETER :: NO_WINDOW=0, COSINE_WINDOW=1
00042   TYPE SpectraDef
00043      TYPE(FieldDef), ALLOCATABLE :: Fields(:)
00044      REAL(KIND=qPREC), DIMENSION(:,:), ALLOCATABLE :: Data
00045      INTEGER :: Level=MAXIMUMSPECTRALEVEL
00046      INTEGER, DIMENSION(3,2) :: mB
00047      INTEGER :: WindowFunction = NO_WINDOW
00048      REAL(KIND=qPREC) :: kmin
00049      REAL(KIND=qPREC) :: dk=1d0
00050      INTEGER :: Type = SCALAR_SPECT
00051      INTEGER :: method=CONSTANT_INTERP
00052      TYPE(SpectraDef), POINTER :: next      
00053   END TYPE SpectraDef
00054 
00055   TYPE(SpectraDef), POINTER :: FirstSpectra, LastSpectra
00056 
00057 CONTAINS
00058   SUBROUTINE SpectraInit()
00059     Nullify(FirstSpectra, LastSpectra)
00060   END SUBROUTINE SpectraInit
00061 
00062   SUBROUTINE CreateSpectra(Spectra, levelOpt)
00063     TYPE(SpectraDef), POINTER :: Spectra
00064     INTEGER, OPTIONAL :: levelOpt
00065     ALLOCATE(Spectra)
00066     CALL AddSpectraToList(Spectra)
00067     IF (present(levelOpt)) THEN
00068        Spectra%level = levelopt
00069        Spectra%mB(:,1)=1
00070        Spectra%mB(:,2)=levels(levelopt)%mX
00071     END IF
00072     NULLIFY(Spectra%next)
00073   END SUBROUTINE CreateSpectra
00074 
00075   SUBROUTINE DestroySpectra(Spectra)
00076     TYPE(SpectraDef), POINTER :: Spectra
00077     DEALLOCATE(Spectra)
00078     NULLIFY(Spectra)
00079   END SUBROUTINE DestroySpectra
00080 
00081   SUBROUTINE AddSpectraToList(Spectra)
00082     TYPE(SpectraDef),POINTER :: Spectra
00083     IF(.NOT. ASSOCIATED(FirstSpectra)) THEN ! First Spectra Object only
00084        FirstSpectra=>Spectra
00085        LastSpectra=>Spectra
00086     ELSE
00087        LastSpectra%next=>Spectra
00088        LastSpectra=>Spectra
00089     END IF
00090   END SUBROUTINE AddSpectraToList
00091 
00092   SUBROUTINE ProcessSpectras
00093     TYPE(SpectraDef), POINTER :: Spectra
00094     TYPE(PFFTPlanDef), POINTER :: plan
00095     INTEGER :: n,l,SpectraLevel, mB(3,2), mBw(3,2)
00096     TYPE(NodeDefList), POINTER :: NodeList
00097     TYPE(ParticleListDef), POINTER :: ParticleList
00098     CHARACTER(LEN=25) :: FileName
00099     INTEGER :: i,j,k
00100     REAL(KIND=qPREC) :: x,y,z, origin(3), mx(3), r, weight
00101     COMPLEX(8), DIMENSION(:,:,:,:), POINTER :: data, tempdata
00102     TYPE(LayoutDef), POINTER :: spectra_layout
00103     CHARACTER(LEN=5) :: str
00104     IF (MPI_ID == 0 .AND. ASSOCIATED(FirstSpectra)) THEN
00105        WRITE(FileName, '(A12,I5.5,A6)') 'out/Spectra_', current_frame, '.curve'
00106        OPEN(UNIT=SPECTRA_DATA_HANDLE, FILE=FileName, STATUS='UNKNOWN')
00107     END IF
00108 
00109     Spectra=>FirstSpectra
00110     DO WHILE (ASSOCIATED(Spectra))        
00111        
00112        IF (Spectra%Level == MAXIMUMSPECTRALEVEL) THEN
00113           SpectraLevel = FinestLevel
00114           mB(:,1)=1
00115           mB(:,2)=levels(SpectraLevel)%mX
00116        ELSE
00117           SpectraLevel = Spectra%Level
00118           mB=Spectra%mB
00119        END IF
00120 
00121        IF (Spectra%type==SCALAR_SPECT) THEN
00122           CALL CreatePlan(plan, SpectraLevel, mB, 1)
00123        ELSE
00124           CALL CreatePlan(plan, SpectraLevel, mB, nDim)
00125        END IF
00126 
00127        
00128        CALL CreateLayout(leveldown(mB, SpectraLevel, 0), spectra_layout)
00129        spectra_layout%level=0
00130        mB=spectra_layout%mB(MPI_ID, :,:)
00131        ALLOCATE(data(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), size(spectra%fields)))
00132        CALL LoadFieldIntoLayout(spectra_layout, data, Spectra%Fields%iD,0)
00133        
00134        CALL WindowData(Spectra%WindowFunction, spectra_layout, data)
00135        DO i=0, SpectraLevel-1
00136           CALL ProlongateLayout(spectra_layout, data, Spectra%method, Spectra%Fields%iD)
00137           
00138           !The problem with loading and windowing is that coarse cells will be windowed multiple times.  To avoid this we need to store the unwindowed coarse cells so that after windowing we can restore their values.
00139           mB=spectra_layout%mB(MPI_ID, :,:)
00140           ALLOCATE(tempdata(mB(1,1):mB(1,2), mB(2,1):mB(2,2), mB(3,1):mB(3,2), size(spectra%fields)))
00141           tempdata=data !make a copy
00142           data=UNDEFINED !set the new data to be undefined
00143           CALL LoadFieldIntoLayout(spectra_layout, data, Spectra%Fields%iD, i+1)
00144           !Now only refined cells will be defined
00145           !So we will flag those as undefined in our backup array
00146           WHERE(data/=UNDEFINED) tempdata=UNDEFINED
00147           CALL WindowData(Spectra%WindowFunction, spectra_layout, data)
00148           !Then we will use defined cells in the backup array to update the new array
00149           WHERE(tempdata /= UNDEFINED) data=tempdata
00150           DEALLOCATE(tempdata)
00151        END DO
00152        
00153        CALL TransferLayouts(spectra_layout, plan%layouts(1)%p, data, plan%data)      
00154 
00155        IF (Spectra%method == SPECTRAL_PROLONGATION) THEN
00156           write(str,'(A4,I1)') 'plan', MPI_ID
00157           CALL WriteBOV3DScalar(str, REAL((/lbound(plan%data,1), lbound(plan%data,2), lbound(plan%data,3)/)-1d0, KIND=qPREC), REAL((/ubound(plan%data,1), ubound(plan%data,2), ubound(plan%data,3)/), KIND=qPREC), 0d0, REAL(plan%data(:,:,:,1)), 'dens')
00158        END IF
00159 
00160        CALL ExecutePlan(plan, BACKWARD)
00161           
00162        CALL BinSpectra(Spectra, Spectralevel, plan%mB, plan%lmB, plan%data)
00163        CALL DestroyPlan(plan)
00164        CALL CollectSpectra(Spectra)
00165        CALL OutputSpectra(Spectra)
00166        DEALLOCATE(Spectra%Data)
00167        Spectra=>Spectra%next            
00168     END DO
00169     IF (MPI_ID == 0 .AND. ASSOCIATED(FirstSpectra)) CLOSE(SPECTRA_DATA_HANDLE)
00170 
00171   END SUBROUTINE ProcessSpectras
00172 
00173   SUBROUTINE CollectSpectra(Spectra)
00174     TYPE(SpectraDef), POINTER :: Spectra
00175     INTEGER :: iErr
00176     REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: totals
00177     IF (MPI_NP == 1) RETURN
00178     CALL MPI_ALLREDUCE(MPI_IN_PLACE, Spectra%Data, size(Spectra%Data), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
00179   END SUBROUTINE CollectSpectra
00180 
00181 
00182   SUBROUTINE OutputSpectra(Spectra)
00183     TYPE(SpectraDef), POINTER :: Spectra
00184     INTEGER :: i,j
00185     CHARACTER(LEN=9), PARAMETER :: DATAFORMAT = '(2E25.16)'
00186     IF (MPI_ID == 0) THEN
00187        SELECT CASE(Spectra%Type)
00188        CASE(SCALAR_SPECT)
00189           WRITE(SPECTRA_DATA_HANDLE, '(A2,3A)') '# ', TRIM(GetName(Spectra%Fields(1)))
00190           WRITE(SPECTRA_DATA_HANDLE, DATAFORMAT) 0d0, Spectra%data(1,1)
00191           DO j=2,size(Spectra%Data,1)
00192              WRITE(SPECTRA_DATA_HANDLE, DATAFORMAT) real(j-1), Spectra%Data(j,1)
00193           END DO
00194           WRITE(SPECTRA_DATA_HANDLE, *)
00195           WRITE(SPECTRA_DATA_HANDLE, *)
00196 
00197        CASE(VECTOR_SPECT)
00198           DO i=1,nDim+3
00199              IF (i <= nDim) THEN
00200                 WRITE(SPECTRA_DATA_HANDLE, '(A2,A)') '# ', TRIM(GetName(Spectra%Fields(i)))
00201              ELSEIF (i == nDim+1) THEN
00202                 WRITE(SPECTRA_DATA_HANDLE, '(A2,2A)') '# ', TRIM(GetName(Spectra%Fields(1))), '_total'
00203              ELSEIF (i == nDim+2) THEN
00204                 WRITE(SPECTRA_DATA_HANDLE, '(A2,2A)') '# ', TRIM(GetName(Spectra%Fields(1))), '_div'
00205              ELSEIF (i == nDim+3) THEN
00206                 WRITE(SPECTRA_DATA_HANDLE, '(A2,2A)') '# ', TRIM(GetName(Spectra%Fields(1))), '_sol'
00207              END IF
00208              WRITE(SPECTRA_DATA_HANDLE, DATAFORMAT) 0d0, Spectra%data(1,i)
00209              DO j=2,size(Spectra%Data,1)
00210                 WRITE(SPECTRA_DATA_HANDLE, DATAFORMAT) real(j-1), Spectra%Data(j,i)
00211              END DO
00212              WRITE(SPECTRA_DATA_HANDLE, *)
00213              WRITE(SPECTRA_DATA_HANDLE, *)
00214           END DO
00215        END SELECT
00216        
00217     END IF
00218   END SUBROUTINE OutputSpectra
00219 
00220 
00221   SUBROUTINE BinSpectra(Spectra, level, GmB, mB, data)
00222     TYPE(SpectraDef) :: Spectra
00223     INTEGER, DIMENSION(3,2) :: mB, Gmb
00224     COMPLEX(8), DIMENSION(:,:,:,:), POINTER :: data
00225     REAL(KIND=qPREC) :: kmax, kvec(3), k2, KE, KEc
00226     INTEGER :: nfields, nbins,i,j,k,bin, level
00227     COMPLEX(8) :: v(3), v2(3)
00228     kmax=maxval(levels(Level)%mx)*sqrt(REAL(nDim))
00229     nbins=ceiling(kmax)+1
00230     SELECT CASE(Spectra%type)
00231     CASE(SCALAR_SPECT)
00232        nFields=1
00233     CASE(VECTOR_SPECT)
00234        nFields=nDim+3 ! 1 for each component + 2 decompositions + total
00235     END SELECT
00236     ALLOCATE(Spectra%Data(nBins, nFields))
00237     Spectra%data=0
00238     DO i=mB(1,1), mB(1,2)
00239        DO j=mB(2,1), mB(2,2)
00240           DO k=mB(3,1), mB(3,2)
00241              kvec=SpectraK((/i,j,k/),Gmb)
00242              k2=sum(kvec**2)
00243              bin=nint(sqrt(k2))+1
00244 !             write(*,*) kvec, bin
00245              SELECT CASE(Spectra%type)
00246              CASE(SCALAR_SPECT)
00247                 Spectra%data(bin,1)=Spectra%data(bin,1)+abs(data(i,j,k,1)**2)
00248              CASE(VECTOR_SPECT)
00249                 v(1:nDim)=data(i,j,k,1:nDim)
00250                 v2(1:nDim)=abs(v(1:nDim)**2)
00251                 KE=sum(v2(1:nDim))
00252                 Spectra%data(bin,1:nDim)=Spectra%data(bin,1:nDim)+v2
00253                 Spectra%data(bin,nDim+1)=Spectra%data(bin,nDim+1)+KE
00254                 IF (ANY(kvec /= 0)) THEN ! Helmholtz decomposition
00255                    v=DOT_PRODUCT(kvec,v)*kvec/k2
00256                    KEc=sum(abs(v**2))
00257                    Spectra%data(bin,nDim+2)=Spectra%data(bin,nDim+2)+KEc
00258                    Spectra%data(bin,nDim+3)=Spectra%data(bin,nDim+3)+KE-KEc
00259                 END IF
00260              END SELECT
00261           END DO
00262        END DO
00263     END DO
00264     Spectra%data=Spectra%data/product(REAL(levels(level)%mX)**2)
00265   END SUBROUTINE BinSpectra
00266 
00267 
00268   SUBROUTINE WindowData(WindowFunction, layout, data)
00269      INTEGER :: WindowFunction
00270      TYPE(LayoutDef), POINTER :: layout
00271      COMPLEX(KIND=qPREC), DIMENSION(:,:,:,:), POINTER :: data
00272      INTEGER, DIMENSION(3,2) :: mB !global bounds of layout
00273      REAL(KIND=qPREC), DIMENSION(3) :: origin !Origin of layout
00274      REAL(KIND=qPREC), DIMENSION(3) :: radius !semi-principal axis
00275      INTEGER :: i,j,k
00276      REAL(KIND=qPREC) :: x,y,z,r,weight
00277      mB(:,1)=minval(layout%mB(:,:,1),1)
00278      mB(:,2)=maxval(layout%mB(:,:,2),1)
00279      origin=half*real(mB(:,1)+mB(:,2))
00280      radius=real((mB(:,2)-mB(:,1)+1))/2d0
00281      SELECT CASE (WindowFunction)
00282      CASE(COSINE_WINDOW)
00283         DO i=layout%mB(MPI_ID,1,1), layout%MB(MPI_ID,1,2)
00284            x=(REAL(i,KIND=qPREC)-origin(1))/radius(1)
00285            DO j=layout%MB(MPI_ID,2,1), layout%MB(MPI_ID,2,2)
00286               y=(REAL(j,KIND=qPREC)-origin(2))/radius(2)
00287               DO k=layout%MB(MPI_ID,3,1), layout%MB(MPI_ID,3,2)
00288                  z=(REAL(k,KIND=qPREC)-origin(3))/radius(3)
00289                  r=sqrt(x**2+y**2+z**2)
00290                  IF (r > 1d0) THEN
00291                     weight=0d0
00292                  ELSE
00293                     weight=cos(half*Pi*r)
00294                  END IF
00295                  data(i,j,k,:)=data(i,j,k,:)*weight
00296               END DO
00297            END DO
00298         END DO
00299      END SELECT
00300   END SUBROUTINE WindowData
00301 
00302 
00303 END MODULE Spectras
 All Classes Files Functions Variables