Scrambler  1
profiles.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 !    profiles.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 !#########################################################################
00024 
00025 MODULE Profiles
00026    USE GlobalDeclarations
00027    USE DataDeclarations
00028    USE PhysicsDeclarations
00029    USE Splines
00030    USE CommonFunctions
00031    USE PointGravitySrc
00032    USE Fields
00033    IMPLICIT NONE
00034 
00035 
00036    INTEGER, PARAMETER :: RADIAL = 0
00037 
00039    TYPE ProfileDef
00040       REAL(KIND=qPREC), DIMENSION(:,:), POINTER :: data => null()
00041       INTEGER, DIMENSION(:), ALLOCATABLE :: fields
00042       REAL(KIND=qPREC) :: dr = 0d0 ! length change for each index
00043       INTEGER :: mode = RADIAL ! profile type
00044    END TYPE ProfileDef
00045 
00046 CONTAINS
00047 
00048    SUBROUTINE createProfile(Profile, nPoints, fields, mode)
00049       TYPE(ProfileDef), POINTER :: Profile
00050       INTEGER :: nPoints
00051       INTEGER, DIMENSION(:) :: fields
00052       INTEGER, OPTIONAL :: mode
00053       ALLOCATE(Profile)
00054       IF (present(mode)) Profile%mode=mode
00055       ALLOCATE(Profile%fields(size(fields)))
00056       Profile%fields=fields
00057       ALLOCATE(Profile%data(nPoints, size(fields)+1)) !one slot for position
00058    END SUBROUTINE   CreateProfile
00059 
00060    SUBROUTINE UpdateProfile(Profile)
00061     TYPE(ProfileDef), POINTER :: Profile
00062     !update attributes that needs to be updated, if any
00063   END SUBROUTINE UpdateProfile
00064 
00065    ! cubic spline for arbitrary value in array
00066    FUNCTION getProfileValue(r,field,Profile)
00067       TYPE(ProfileDef), POINTER :: Profile
00068       REAL(KIND=qPREC) :: getProfileValue, r
00069       TYPE(SplineDef), POINTER :: spl
00070       INTEGER :: index, i, field, n
00071       REAL(KIND=qPREC), DIMENSION(:,:), POINTER :: data
00072       LOGICAL :: lWarned = .false.
00073       data => Profile%data
00074       n=sum(minloc(profile%fields, profile%fields == field))+1
00075       IF (n == 0) THEN
00076          IF (MPI_ID == 0) write(*,*) 'error unable to find field ', field, 'in profile%fields ', profile%fields
00077          STOP
00078       END IF
00079       IF ((r < data(1,1) .OR. r > data(size(data, 1), 1)) .AND. .NOT. lWarned) THEN
00080          PRINT*, '*** WARNING - profile is not defined for r = ', r, data(1,1), data(size(data,1),1)
00081          lWarned=.true.
00082       END IF
00083       DO index=2, size(data,1)-2
00084          IF (data(index,1) .gt. r) EXIT
00085       END DO
00086       CALL CreateSpline(spl, 4)
00087 
00088       spl%x(1) = data(index - 1,1)
00089       spl%x(2) = data(index ,1)
00090       spl%x(3) = data(index + 1,1)
00091       spl%x(4) = data(index + 2,1)
00092       spl%y(1) = data(index - 1, n)
00093       spl%y(2) = data(index , n)
00094       spl%y(3) = data(index + 1, n)
00095       spl%y(4) = data(index + 2, n)
00096       CALL SolveSpline(spl)
00097       getProfileValue = GetSplineValue(spl, r)
00098       CALL DestroySpline(spl)
00099    END FUNCTION getProfileValue
00100 
00101    ! calculated ideal pressure for hydrostatic equilibrium
00102    SUBROUTINE Profile_PointGravityHSE(Profile, PointGravityObj, p_inf)
00103       TYPE(ProfileDef), POINTER :: Profile
00104       TYPE(PointGravityDef), POINTER :: PointGravityObj
00105       REAL(KIND=qPREC) :: p_inf
00106       REAL(KIND=qPREC), DIMENSION(:,:), POINTER :: data
00107       INTEGER ::  i, npoints,  i_rho, i_press
00108 
00109       data => Profile%data
00110 
00111       npoints=size(data, 1)
00112       i_rho=sum(minloc(profile%fields, profile%fields == Mass_Field))+1
00113       i_Press=sum(minloc(profile%fields, profile%fields == P_Field))+1
00114 
00115       data(npoints, i_Press) = p_inf
00116 
00117       ! start from last entry and end up to first entry
00118       DO i=npoints-1, 2, -1
00119          !   dP/dr = f
00120          !   [P(i+1)-P(i)] / [r(i+1)-r(i)] = g(r(i+1/2))*rho(i+1/2)
00121          !   P(i) = P(i+1) - (r(i+1)-r(i))*g(r(i+1/2))*rho(i+1/2) where f(i+1/2) = half*(f(i)+f(i+1))
00122          data(i, i_Press)=data(i+1, i_Press)-sum(GravityForce( PointGravityObj%mass, (/half*(data(i,1)+data(i+1,1)),0d0,0d0/), PointGravityObj%soft_length, PointGravityObj%soft_function))*half*(data(i,i_rho)+data(i+1,i_rho)) * (data(i+1,1)-data(i,1))
00123       END DO
00124 
00125       
00126 
00127       
00128    END SUBROUTINE Profile_PointGravityHSE
00129 
00130 
00131 END MODULE Profiles
 All Classes Files Functions Variables