Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! processing_info_ops.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 ProcessingInfoOps 00024 USE GlobalDeclarations 00025 USE DataDeclarations 00026 USE PhysicsDeclarations 00027 USE ProcessingDeclarations 00028 USE TreeDeclarations 00029 USE CoolingSrc 00030 USE SourceDeclarations 00031 USE EOS 00032 IMPLICIT NONE 00033 PUBLIC 00034 CONTAINS 00035 00036 SUBROUTINE StoreErrFlag(Info) 00037 TYPE(InfoDef) :: Info 00038 IF (Info%level < MaxLevel) THEN 00039 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iErrFlag)=Info%ErrFlag(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3)) 00040 ELSE 00041 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iErrFlag)=0 00042 END IF 00043 END SUBROUTINE StoreErrFlag 00044 00045 SUBROUTINE StoreMPI_ID(Info) 00046 TYPE(InfoDef) :: Info 00047 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iMPI_ID)=MPI_ID 00048 ! write(*,*) 'storing ', MPI_ID, iMPI_ID 00049 END SUBROUTINE StoreMPI_ID 00050 00051 00052 00053 SUBROUTINE StoreCoolingLength(Info) 00054 TYPE(InfoDef) :: Info 00055 REAL(KIND=qPREC), DIMENSION(:), ALLOCATABLE :: dqdt 00056 REAL(KIND=qPREC), DIMENSION(:), POINTER :: q 00057 INTEGER :: i,j,k 00058 ALLOCATE(dqdt(NrHydroVars)) 00059 DO i=1, Info%mX(1) 00060 DO j=1, Info%mX(2) 00061 DO k=1, Info%mX(3) 00062 dqdt=0 00063 q=>Info%q(i,j,k,1:NrHydroVars) 00064 CALL Cooling(q, dqdt, Cellpos(Info, i, j, k), levels(Info%level)%dx, CONSERVATIVE) 00065 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iCoolingLength)=-sqrt(gamma*Press(Info%q(i,j,k,:))/Info%q(i,j,k,1))*(q(iE)/dqdt(iE)) 00066 END DO 00067 END DO 00068 END DO 00069 DEALLOCATE(dqdt) 00070 END SUBROUTINE StoreCoolingLength 00071 00072 SUBROUTINE StoreTreeAvailability(node) 00073 TYPE(NodeDef) :: node 00074 TYPE(nodedeflist), pointer :: nodelist 00075 TYPE(InfoDef), POINTER :: Info 00076 INTEGER(8) :: neighbormask, overlapmask, childmask, parentmask 00077 INTEGER, PARAMETER :: MPI_TRACK = 0 00078 info=>node%info 00079 00080 IF (iNeighborMask > 0) THEN 00081 neighbormask=0 00082 IF (MPI_ID == MPI_TRACK) neighbormask = 1 00083 ! neighbormask=ibset(neighbormask, MPI_ID) 00084 nodelist=>node%neighbors 00085 DO WHILE (ASSOCIATED(nodelist)) 00086 ! neighbormask=ibset(neighbormask, nodelist%self%box%MPI_ID) 00087 IF ((nodelist%self%box%MPI_ID) == MPI_TRACK) neighbormask=1 00088 nodelist=>nodelist%next 00089 END DO 00090 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iNeighborMask)=REAL(neighbormask, kind=qprec) 00091 END IF 00092 IF (iOverlapMask > 0) THEN 00093 overlapmask=0 00094 IF (MPI_ID == MPI_TRACK) overlapmask=1 00095 ! overlapmask=ibset(overlapmask, MPI_ID) 00096 nodelist=>node%overlaps 00097 DO WHILE (ASSOCIATED(nodelist)) 00098 IF ((nodelist%self%box%MPI_ID) == MPI_TRACK) overlapmask=1 00099 ! overlapmask=ibset(overlapmask, nodelist%self%box%MPI_ID) 00100 nodelist=>nodelist%next 00101 END DO 00102 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iOverlapMask)=REAL(overlapmask, kind=qprec) 00103 END IF 00104 IF (iParentMask > 0) THEN 00105 parentmask=0 00106 IF (MPI_ID == MPI_TRACK) parentmask=1 00107 IF ((node%parent%box%MPI_ID) == MPI_TRACK) parentmask=1 00108 ! parentmask=ibset(parentmask, MPI_ID) 00109 ! parentmask=ibset(parentmask, node%parent%box%MPI_ID) 00110 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iParentMask)=REAL(parentmask, kind=qprec) 00111 00112 END IF 00113 IF (iChildMask > 0) THEN 00114 childmask=0 00115 IF (MPI_ID == MPI_TRACK) childmask=1 00116 ! childmask=ibset(childmask, MPI_ID) 00117 nodelist=>node%children 00118 DO WHILE (ASSOCIATED(nodelist)) 00119 IF ((nodelist%self%box%MPI_ID) == MPI_TRACK) childmask=1 00120 ! childmask=ibset(childmask, nodelist%self%box%MPI_ID) 00121 nodelist=>nodelist%next 00122 END DO 00123 Info%diagnostics(1:Info%mX(1),1:Info%mX(2),1:Info%mX(3),iChildmask)=REAL(childmask, kind=qprec) 00124 END IF 00125 END SUBROUTINE StoreTreeAvailability 00126 00127 END MODULE ProcessingInfoOps