Scrambler  1
processing_info_ops.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 !    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
 All Classes Files Functions Variables