Scrambler
1
|
00001 !######################################################################### 00002 ! 00003 ! Copyright (C) 2003-2012 Department of Physics and Astronomy, 00004 ! University of Rochester, 00005 ! Rochester, NY 00006 ! 00007 ! problem.f90 of module Marquee 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 !######################################################################### 00025 00028 00032 00035 MODULE Problem 00036 USE DataDeclarations 00037 USE GlobalDeclarations 00038 USE PhysicsDeclarations 00039 USE Ambients 00040 IMPLICIT NONE ! It's safer to require explicit declarations 00041 SAVE ! Save module information 00042 PRIVATE ! Everything is implicitly private, i.e. accessible only 00043 ! to this module. 00044 PUBLIC :: ProblemModuleInit,ProblemGridInit,ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep 00045 REAL(KIND=qprec) :: ybounds(2), textspeed, backtextspeed, indexspeed, tstart, contrast, messagedx, rhoBackground, 00046 EnergyBackground, drho, dp, de, rhoMessage, EnergyMessage, period, dv, yperiod, ydv 00047 INTEGER(KIND=qPREC), DIMENSION(:,:), ALLOCATABLE :: message 00048 NAMELIST/ProblemData/ybounds, textspeed, backtextspeed, tstart, contrast, rhoBackGround, period, dv, yperiod, ydv 00049 INTEGER :: msize(2) 00050 REAL(KIND=qPREC) :: rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00051 00052 CONTAINS 00053 00055 SUBROUTINE ProblemModuleInit 00056 INTEGER :: iErr, i 00057 character(50) :: x 00058 TYPE(AmbientDef), POINTER :: Ambient 00059 NAMELIST /AmbientData/ rhoOut, pOut, vxOut, vyOut, vzOut, BxOut, ByOut, BzOut 00060 00061 OPEN(UNIT=PROBLEM_DATA_HANDLE,FILE='problem.data',STATUS='old', & 00062 FORM='formatted') 00063 READ(PROBLEM_DATA_HANDLE,NML=ProblemData) 00064 CALL CreateAmbient(Ambient) 00065 READ(PROBLEM_DATA_HANDLE,NML=AmbientData) 00066 Ambient%density=rhoOut 00067 Ambient%pressure=pOut 00068 Ambient%B(:)=(/BxOut, ByOut, BzOut/) 00069 Ambient%velocity(:)=(/vxOut, vyOut, vzOut/) 00070 00071 CLOSE(PROBLEM_DATA_HANDLE) 00072 OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='message.data', STATUS='old') 00073 READ(PROBLEM_DATA_HANDLE,*) msize 00074 ! write(*,*) "Message size=", msize 00075 ALLOCATE(message(PROBLEM_DATA_HANDLE+msize(1),msize(2))) 00076 message(1:10,:)=0 00077 write(x,'(A1,I10,A3)') "(",size(message,1),"I1)" 00078 write(*,*) x 00079 DO i=1,msize(2) 00080 READ(PROBLEM_DATA_HANDLE,x) message(11:,msize(2)+1-i) 00081 END DO 00082 CLOSE(PROBLEM_DATA_HANDLE) 00083 messagedx=(ybounds(2)-ybounds(1))/msize(2) 00084 indexspeed=textspeed/messagedx 00085 ! rhoBackground=rhoOut 00086 EnergyBackground=gamma7*pOut+half*rhoBackGround*backtextspeed**2 00087 rhoMessage=rhoBackground*contrast 00088 00089 EnergyMessage=gamma7*pOut+half*rhoMessage*textspeed**2 00090 00091 drho=rhoMessage-rhoBackground 00092 dp=-(rhoMessage*textspeed)+(rhoBackground*backtextspeed) 00093 write(*,'(5E13.2)') rhoMessage, textspeed, rhoBackground, backtextspeed, dp 00094 dE=EnergyMessage-EnergyBackground 00095 write(*,*) drho, dp 00096 write(*,*) 00097 write(*,*) (-rhoBackground*backtextspeed+dp)/(rhoBackGround+drho) 00098 00099 END SUBROUTINE ProblemModuleInit 00100 00103 SUBROUTINE ProblemGridInit(Info) 00104 ! Interface declarations 00105 TYPE (InfoDef) :: Info ! Data associated with this grid 00106 CALL ProblemBeforeStep(Info) 00107 END SUBROUTINE ProblemGridInit 00108 00111 SUBROUTINE ProblemBeforeStep(Info) 00112 ! Interface declarations 00113 TYPE (InfoDef) :: Info ! Data associated with this grid 00114 REAL (KIND=qPrec), POINTER, DIMENSION (:,:,:,:) :: q 00115 INTEGER :: i,j,k,mx,my,mz,rmbc,zrmbc,i0(2),j0(2), ii0, jj0, sample_res, ii, jj,level 00116 REAL(KIND=xprec) :: x,y,z,xl,yl,zl,dx,dy,dz,timeyr, xpos, xbounds(2), overlapxbounds(2), 00117 overlapybounds(2), fact, pos(2) 00118 ! 00119 level=Info%level 00120 q=>Info%q 00121 rmbc=levels(level)%gmbc(1) 00122 00123 00124 mx=Info%mX(1); my=Info%mX(2); mz=Info%mX(3) 00125 dx=levels(level)%dX; xl=Info%XBounds(1,1);yl=Info%xBounds(2,1) 00126 00127 !xposition of start of marqui 00128 xpos=GxBounds(1,2)-textspeed*(levels(level)%tnow-tstart) 00129 ! write(*,*) "xpos= ", xpos 00130 !x bounds of launch region 00131 xbounds(1)=max(xpos, GxBounds(1,2)) 00132 xbounds(2)=min(xpos+msize(1)*messagedx, GxBounds(1,2)+levels(ROOT_LEVEL)%gmbc(1)*levels(ROOT_LEVEL)%dX) 00133 00134 !overlap physical bounds of launch region with extended grid 00135 overlapxbounds(1)=max(xbounds(1),Info%xBounds(1,1)-rmbc*levels(level)%dx) 00136 overlapxbounds(2)=min(xbounds(2),Info%xBounds(1,1)+(Info%mX(1)+rmbc)*levels(level)%dx) 00137 overlapybounds(1)=max(ybounds(1),Info%xBounds(2,1)-rmbc*levels(level)%dx) 00138 overlapybounds(2)=min(ybounds(2),Info%xBounds(2,1)+(Info%mX(2)+rmbc)*levels(level)%dx) 00139 sample_res=max(nint(levels(level)%dx/messagedx),8) 00140 fact=1d0/real(sample_res)**2 00141 ! write(*,'(A,4E13.4)') "overlapbounds=", overlapxbounds, overlapybounds 00142 ! write(*,*) "sample_res=", sample_res 00143 IF (overlapxbounds(2) >= overlapxbounds(1) .AND. overlapybounds(2) >= overlapybounds(1)) THEN 00144 00145 i0(1)=max(1-rmbc, ceiling((overlapxbounds(1)-Info%xBounds(1,1))/levels(level)%dx)) !max(product(coarsenratio(0:Info%level-1))-Info%mGlobal(1,1)+1, 1-rmbc) 00146 i0(2)=min(Info%mX(1)+rmbc, floor((overlapxbounds(2)-Info%xBounds(1,1))/levels(level)%dx)) 00147 j0(1)=max(1-rmbc, ceiling((overlapybounds(1)-Info%xBounds(2,1))/levels(level)%dx)) !max(product(coarsenratio(0:Info%level-1))-Info%mGlobal(1,1)+1, 1-rmbc) 00148 j0(2)=min(Info%mX(2)+rmbc, floor((overlapybounds(2)-Info%xBounds(2,1))/levels(level)%dx)) 00149 ! write(*,'(A,4I)') "i0,j0= ", i0,j0 00150 IF (i0(1) <= i0(2) .AND. j0(1) <= j0(2)) THEN !zero out overlap region with background values 00151 q(i0(1):i0(2),j0(1):j0(2),1,:) = 0 00152 q(i0(1):i0(2),j0(1):j0(2),1,1) = rhoBackground 00153 q(i0(1):i0(2),j0(1):j0(2),1,2) = -Backtextspeed*rhoBackGround 00154 ! q(:,:,:,1,2)=-Backtextspeed*rhoBackGround 00155 ! write(*,*) -Backtextspeed*rhoBackGround 00156 ! IF (iE .ne. 0) q(i0(1):i0(2),j0(1):j0(2),:,1,iE) = gamma7*pOut!EnergyBackground 00157 ! return 00158 DO i=i0(1),i0(2) 00159 DO j=j0(1),j0(2) 00160 DO ii=1,sample_res 00161 DO jj=1,sample_res 00162 pos=Info%xBounds(1:2,1)+((real((/i,j/))-1d0) + 00163 ((/REAL(ii,8),REAL(jj,8)/)-half)/REAL(sample_res,8))*levels(level)%dX 00164 ii0=nint((pos(1)-xpos)/messagedx) 00165 jj0=nint((pos(2)-ybounds(1))/messagedx) 00166 IF (ii0 >= 1 .AND. ii0 <= msize(1) .AND. jj0 >= 1 .AND. jj0 <= msize(2)) THEN 00167 IF (message(ii0,jj0)==1) THEN 00168 q(i,j,1,1)=q(i,j,1,1)+drho*fact 00169 dp=-(rhoMessage*textspeed*(1d0+dv*cos(2d0*Pi*levels(level)%tnow/period))) + & 00170 (rhoBackground*backtextspeed) 00171 q(i,j,1,3)=q(i,j,1,3)+rhoMessage*textspeed*ydv*sin(2d0*Pi*levels(level)%tnow/yperiod)*fact 00172 q(i,j,1,2)=q(i,j,1,2)+dp*fact 00173 ! IF (iE .ne. 0) q(i,j,1,1,iE)=q(i,j,1,1,iE)+de*fact 00174 END IF 00175 END IF 00176 END DO 00177 END DO 00178 IF (iE .ne. 0) q(i,j,1,iE)= gamma7*pOut+half*SUM(q(i,j,1,2:3)**2)/q(i,j,1,1) 00179 END DO 00180 END DO 00181 END IF 00182 END IF 00183 END SUBROUTINE ProblemBeforeStep 00184 00187 SUBROUTINE ProblemAfterStep(Info) 00188 !! @brief Performs any post-step corrections that are required. 00189 !! @param Info A grid structure. 00190 TYPE (InfoDef) :: Info 00191 END SUBROUTINE ProblemAfterStep 00192 00195 SUBROUTINE ProblemSetErrFlag(Info) 00196 !! @brief Sets error flags according to problem-specific conditions.. 00197 !! @param Info A grid structure. 00198 TYPE (InfoDef) :: Info 00199 END SUBROUTINE ProblemSetErrFlag 00200 00201 SUBROUTINE ProblemBeforeGlobalStep(n) 00202 INTEGER :: n 00203 END SUBROUTINE ProblemBeforeGlobalStep 00204 00205 00206 END MODULE Problem 00207