Scrambler
1
|
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