Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! histograms.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 Histograms 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 ProcessingDeclarations 00033 USE Shapes 00034 IMPLICIT NONE 00035 00036 TYPE HistogramDef 00037 TYPE(FieldDef) :: Field 00038 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: Data 00039 INTEGER :: Scale=LINEARSCALE 00040 REAL(KIND=qPREC) :: minvalue=MINOVERALL 00041 REAL(KIND=qPREC) :: maxvalue=MAXOVERALL 00042 INTEGER :: nBins=100 00043 TYPE(ShapeDef), POINTER :: shape 00044 TYPE(HistogramDef), POINTER :: next 00045 INTEGER :: WeightField=VOLUME 00046 END TYPE HistogramDef 00047 00048 TYPE(HistogramDef), POINTER :: FirstHistogram, LastHistogram 00049 SAVE 00050 CONTAINS 00051 SUBROUTINE HistogramInit() 00052 Nullify(FirstHistogram, LastHistogram) 00053 END SUBROUTINE HistogramInit 00054 00055 SUBROUTINE CreateHistogram(Histogram) 00056 TYPE(HistogramDef), POINTER :: Histogram 00057 ALLOCATE(Histogram) 00058 CALL AddHistogramToList(Histogram) 00059 NULLIFY(Histogram%next, Histogram%shape) 00060 END SUBROUTINE CreateHistogram 00061 00062 SUBROUTINE DestroyHistogram(Histogram) 00063 TYPE(HistogramDef), POINTER :: Histogram 00064 DEALLOCATE(Histogram) 00065 NULLIFY(Histogram) 00066 END SUBROUTINE DestroyHistogram 00067 00068 SUBROUTINE AddHistogramToList(Histogram) 00069 TYPE(HistogramDef),POINTER :: Histogram 00070 IF(.NOT. ASSOCIATED(FirstHistogram)) THEN ! First Histogram Object only 00071 FirstHistogram=>Histogram 00072 LastHistogram=>Histogram 00073 ELSE 00074 LastHistogram%next=>Histogram 00075 LastHistogram=>Histogram 00076 END IF 00077 END SUBROUTINE AddHistogramToList 00078 00079 SUBROUTINE ProcessHistograms 00080 TYPE(HistogramDef), POINTER :: Histogram 00081 INTEGER :: n 00082 TYPE(NodeDefList), POINTER :: NodeList 00083 TYPE(ParticleListDef), POINTER :: ParticleList 00084 REAL(KIND=qPREC) :: minvalue, maxvalue, dx, weight, rpos(3) 00085 CHARACTER(LEN=25) :: FileName 00086 00087 IF (MPI_ID == 0 .AND. ASSOCIATED(FirstHistogram)) THEN 00088 WRITE(FileName, '(A14,I5.5,A6)') 'out/Histogram_', current_frame, '.curve' 00089 OPEN(UNIT=HISTOGRAM_DATA_HANDLE, FILE=FileName, STATUS='UNKNOWN') 00090 END IF 00091 Histogram=>FirstHistogram 00092 DO WHILE (ASSOCIATED(Histogram)) 00093 ALLOCATE(Histogram%Data(Histogram%nBins)) 00094 Histogram%Data=0d0 00095 IF (Histogram%minvalue==MINOVERALL) THEN 00096 IF (ASSOCIATED(Histogram%shape)) THEN 00097 minvalue=FindMin(Histogram%Field, Histogram%Shape) 00098 ELSE 00099 minvalue=FindMin(Histogram%Field) 00100 END IF 00101 ELSE 00102 minvalue=Histogram%minvalue 00103 END IF 00104 IF (Histogram%maxvalue==MAXOVERALL) THEN 00105 IF (ASSOCIATED(Histogram%shape)) THEN 00106 maxvalue=FindMax(Histogram%Field, Histogram%shape) 00107 ELSE 00108 maxvalue=FindMax(Histogram%Field) 00109 END IF 00110 ELSE 00111 maxvalue=Histogram%maxvalue 00112 END IF 00113 IF (Histogram%Scale==LOGSCALE) THEN 00114 minvalue=log10(minvalue) 00115 maxvalue=log10(maxvalue) 00116 END IF 00117 dx=(maxvalue-minvalue)/REAL(Histogram%nbins) 00118 IF (Histogram%Field%Component==GASCOMP .OR. Histogram%Field%Component==BOTHCOMP) THEN 00119 DO n=0, MaxLevel 00120 Nodelist=>Nodes(n)%p 00121 DO WHILE (ASSOCIATED(NodeList)) 00122 CALL ProcessHistogram(Nodelist%self%info, Histogram, minvalue, maxvalue, dx) 00123 Nodelist=>Nodelist%next 00124 END DO 00125 END DO 00126 END IF 00127 IF (Histogram%Field%Component==PARTICLECOMP .OR. Histogram%Field%Component==BOTHCOMP) THEN 00128 ParticleList=>SinkParticles 00129 DO WHILE (ASSOCIATED(ParticleList)) 00130 IF (ASSOCIATED(Histogram%shape)) THEN 00131 IF (.NOT. IsInShape(Histogram%shape, ParticleList%self%xloc, rpos, levels(0)%tnow)) THEN 00132 ParticleList=>ParticleList%next 00133 CYCLE 00134 END IF 00135 END IF 00136 IF (Histogram%WeightField == VOLUME) THEN 00137 weight=1d0 00138 ELSEIF (Histogram%WeightField == MASS) THEN 00139 weight=ParticleList%self%q(1) 00140 ELSE 00141 weight=GetParticleField(ParticleList%self, Histogram%WeightField) 00142 END IF 00143 IF (Histogram%Scale==LOGSCALE) THEN 00144 CALL BinData(log10(GetParticleField(ParticleList%self, Histogram%Field%ID)), weight, Histogram%Data, minvalue, maxvalue, dx) 00145 ELSE 00146 CALL BinData(GetParticleField(ParticleList%self, Histogram%Field%ID), weight, Histogram%Data, minvalue, maxvalue, dx) 00147 END IF 00148 ParticleList=>ParticleList%next 00149 END DO 00150 END IF 00151 CALL CollectHistogram(Histogram) 00152 CALL OutputHistogram(Histogram, minvalue, maxvalue, dx) 00153 DEALLOCATE(Histogram%Data) 00154 Histogram=>Histogram%next 00155 END DO 00156 IF (MPI_ID == 0 .AND. ASSOCIATED(FirstHistogram)) CLOSE(HISTOGRAM_DATA_HANDLE) 00157 END SUBROUTINE ProcessHistograms 00158 00159 SUBROUTINE ProcessHistogram(Info, Histogram, minvalue, maxvalue, dx) 00160 TYPE(InfoDef) :: Info 00161 TYPE(HistogramDef) :: Histogram 00162 INTEGER :: i,j,k 00163 REAL(KIND=qPREC) :: dv, minvalue, maxvalue, dx, weight, pos(3), rpos(3) 00164 dv=levels(Info%level)%dx**nDim 00165 DO i=1, Info%mX(1) 00166 IF (iCylindrical /= NoCyl) dv=levels(Info%level)%dx**nDim*(Info%xBounds(1,1)+levels(Info%level)%dx*(REAL(i)-.5d0)) 00167 DO j=1, Info%mX(2) 00168 DO k=1, Info%mX(3) 00169 IF (Info%level < MaxLevel) THEN 00170 IF (Info%ChildMask(i,j,k) /= 0) THEN 00171 ! PRINT*, 'cycling' 00172 CYCLE 00173 END IF 00174 END IF 00175 pos=CellPos(Info, i, j, k) 00176 IF (ASSOCIATED(Histogram%shape)) THEN 00177 IF (.NOT. IsInShape(Histogram%shape, pos, rpos, levels(Info%level)%tnow)) CYCLE 00178 END IF 00179 00180 IF (Histogram%WeightField == VOLUME) THEN 00181 weight=dv 00182 ELSEIF (Histogram%WeightField == MASS) THEN 00183 weight=dv*Info%q(i,j,k,1) 00184 ELSE 00185 weight=dv*GetField(Info,i,j,k, Histogram%WeightField) 00186 END IF 00187 IF (Histogram%Scale==LOGSCALE) THEN 00188 CALL BinData(log10(GetField(Info,i,j,k, Histogram%Field%ID)), weight, Histogram%Data, minvalue, maxvalue, dx) 00189 ELSE 00190 CALL BinData(GetField(Info,i,j,k, Histogram%Field%ID), weight, Histogram%Data, minvalue, maxvalue, dx) 00191 END IF 00192 END DO 00193 END DO 00194 END DO 00195 END SUBROUTINE ProcessHistogram 00196 00197 SUBROUTINE BinData(data, weight, bins, minvalue, maxvalue, dx) 00198 REAL(KIND=qPREC) :: data, weight, minvalue, maxvalue, dx 00199 REAL(KIND=qPrec), DIMENSION(:) :: bins 00200 INTEGER :: iloc 00201 IF (isNAN(data)) RETURN 00202 iloc=max(1,min(size(bins), ceiling((data-minvalue)/dx))) 00203 bins(iloc)=bins(iloc)+weight 00204 END SUBROUTINE BinData 00205 00206 00207 SUBROUTINE CollectHistogram(Histogram) 00208 TYPE(HistogramDef), POINTER :: Histogram 00209 INTEGER :: iErr 00210 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: totals 00211 IF (MPI_NP == 1) RETURN 00212 CALL MPI_ALLREDUCE(MPI_IN_PLACE, Histogram%Data, Histogram%nbins, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr) 00213 END SUBROUTINE CollectHistogram 00214 00215 00216 SUBROUTINE OutputHistogram(Histogram, minvalue, maxvalue, dx) 00217 TYPE(HistogramDef), POINTER :: Histogram 00218 INTEGER :: i 00219 CHARACTER(LEN=9), PARAMETER :: DATAFORMAT = '(2E25.16)' 00220 REAL(KIND=qPREC) :: minvalue, maxvalue, dx 00221 IF (MPI_ID == 0) THEN 00222 WRITE(HISTOGRAM_DATA_HANDLE, '(A2,3A)') '# ', TRIM(WeightName(Histogram%weightfield)), '_weighted_',TRIM(GetName(Histogram%Field)) 00223 WRITE(HISTOGRAM_DATA_HANDLE, DATAFORMAT) minvalue, 0d0 00224 DO i=1,size(Histogram%Data) 00225 WRITE(HISTOGRAM_DATA_HANDLE, DATAFORMAT) minvalue+real(i-1)*dx, Histogram%Data(i)/dx 00226 WRITE(HISTOGRAM_DATA_HANDLE, DATAFORMAT) minvalue+real(i)*dx, Histogram%Data(i)/dx 00227 END DO 00228 WRITE(HISTOGRAM_DATA_HANDLE, DATAFORMAT) maxvalue, 0d0 00229 END IF 00230 END SUBROUTINE OutputHistogram 00231 00232 00233 FUNCTION WeightName(FieldID) 00234 CHARACTER(LEN=MAXFIELDSLENGTH) :: WeightName 00235 INTEGER :: FieldID 00236 IF (FieldID == VOLUME) THEN 00237 WeightName='volume' 00238 ELSEIF (FieldID == MASS) THEN 00239 WeightName='mass' 00240 ELSE 00241 WeightName=GetName(FieldID) 00242 END IF 00243 END FUNCTION WeightName 00244 00245 00246 END MODULE Histograms