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