Scrambler  1
FieldLoopAdvection/problem.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 !    problem.f90 of module FieldLoopAdvection 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 
00036 MODULE Problem
00037 
00038    USE DataDeclarations
00039    USE GlobalDeclarations
00040    USE PhysicsDeclarations
00041    USE Ambients
00042    IMPLICIT NONE
00043    SAVE
00044    PRIVATE
00045 
00046    PUBLIC ProblemModuleInit, ProblemGridInit, &
00047         ProblemBeforeStep, ProblemAfterStep, ProblemSetErrFlag, ProblemBeforeGlobalStep
00048 
00049    REAL(KIND=qPrec) :: rho,p,v(3),Ao,thickness,R,phi,theta
00050    REAL(KIND=qPREC), DIMENSION(:,:,:), ALLOCATABLE :: infoq
00051    INTEGER :: sample_res=16
00052 
00053    LOGICAL :: lCooling
00054    LOGICAL :: lResolutionTest=.false.
00055    INTEGER :: iCooling
00056 
00057 
00058 CONTAINS
00059 
00061    SUBROUTINE ProblemModuleInit
00062       INTEGER :: iErr
00063       TYPE(AmbientDef), POINTER :: Ambient
00064       NAMELIST /ProblemData/ rho,p,v,Ao,R,thickness,phi,theta,lCooling,iCooling, lResolutionTest
00065 
00066       OPEN(UNIT=PROBLEM_DATA_HANDLE, FILE='problem.data')
00067 
00068       READ(PROBLEM_DATA_HANDLE,NML=ProblemData)
00069 
00070       CLOSE(PROBLEM_DATA_HANDLE, IOSTAT=iErr)
00071 
00072 
00073       IF (nDim == 2 .AND. ((phi /= zero) .OR. (theta /= zero))) THEN
00074          PRINT *, "CalcConstantProblem() error: phi and theta need to be 0 in a 2D problem."
00075          STOP
00076       END IF
00077       NULLIFY(Ambient)
00078       CALL CreateAmbient(Ambient)
00079       Ambient%density=rho
00080       Ambient%pressure=p
00081       Ambient%velocity=v
00082    END SUBROUTINE ProblemModuleInit
00083 
00086    SUBROUTINE ProblemGridInit(Info)
00087       !! @brief Initializes the grid data according to the requirements of the problem.
00088       !! @param Info A grid structure.  
00089       TYPE (InfoDef) :: Info
00090       INTEGER :: i,j,k,l,m,ii,jj,kk
00091       INTEGER :: rmbc,zrmbc
00092       INTEGER :: mx, my, mz
00093       REAL(KIND=qPrec) :: pos(3), mini_pos(3), x_rotated(3), s, temp(3)
00094       REAL(KIND=qPrec), DIMENSION(:,:,:,:), ALLOCATABLE :: A
00095       INTEGER :: iErr
00096 
00097 
00098       !    IF (ALLOCATED(A))  DEALLOCATE(A)
00099 
00100       ! Calculating the number of ghost cells on each side of the grid.
00101       rmbc = levels(Info%level)%gmbc(1)!CoarsenRatio(Info%level-1) * mbc
00102       SELECT CASE(nDim)
00103       CASE(2)
00104          zrmbc=0
00105       CASE(3)
00106          zrmbc=rmbc
00107       END SELECT
00108 
00109       mx = Info%mX(1)
00110       my = Info%mX(2)
00111       mz = Info%mX(3)
00112       ! write(*,*) Info%mX, Info%xBounds
00113       !        write(*,*) Info%level
00114       !        write(*,*) levels(Info%level)%dx
00115       CALL ConvertTotalToInternalEnergy(Info%q(1:Info%mX(1), 1:Info%mX(2), 1:Info%mX(3), :))
00116 
00117       IF (nDim == 3) THEN
00118 
00119          ALLOCATE(A(1-rmbc:mx+1+rmbc,1-rmbc:my+1+rmbc, 1-zrmbc:mz+1+zrmbc,3), STAT=iErr)
00120 
00121          IF (iErr /= 0) THEN
00122             PRINT *, "DomainInitProblem() error: u unable to allocate 3D array."
00123             STOP
00124          END IF
00125 
00126 
00127          A=0.0  ! A = Magnetic potential (B = curl(A)).
00128 
00129          DO k=1-zrmbc, mz+1+zrmbc
00130             DO j=1-rmbc, my+1+rmbc
00131                DO i=1-rmbc, mx+1+rmbc
00132                   DO ii=0,0
00133                      DO jj=0,0
00134                         DO kk=0,0
00135                            IF (maxval(abs(A(i,j,k,:))) == 0) THEN
00136                               !                            write(*,*) shape(pos)
00137                               !                            write(*,*) shape(Info%xBounds)
00138                               !                            write(*,*) pos
00139                               !                            write(*,*) Info%xBounds(1:3,1)
00140                               pos=Info%xBounds(1:3,1)
00141                               pos=levels(Info%level)%dx
00142                               pos=(/REAL(i,KIND=qPREC)-1d0, REAL(j,KIND=qPREC)-1d0, REAL(k,KIND=qPREC)-1d0/) * levels(Info%level)%dx
00143                               pos=(/REAL(i,8)-1, REAL(j,8)-1, REAL(k,8)-1/) * levels(Info%level)%dx
00144 
00145 
00146                               pos=Info%xBounds(1:3,1)+(/REAL(i,8)-1, REAL(j,8)-1, REAL(k,8)-1/) * levels(Info%level)%dx
00147                               pos(1)=pos(1)+(GxBounds(1,2)-GxBounds(1,1))*(modulo(ii+1,3)-1)
00148                               pos(2)=pos(2)+(GxBounds(2,2)-GxBounds(2,1))*(modulo(jj+1,3)-1)
00149                               pos(3)=pos(3)+(GxBounds(3,2)-GxBounds(3,1))*(modulo(kk+1,3)-1)
00150 
00151                               DO l=1,3
00152                                  mini_pos=pos
00153                                  DO m=1,sample_res
00154                                     mini_pos(l) = pos(l) + levels(Info%level)%dx*(REAL(m,8)-half)/REAL(sample_res,8) !sub sample each edge
00155                                     x_rotated=rotate_y(rotate_z(mini_pos,-phi),-theta) !rotate coordinates again so that vector along jet-axis is along x-axis
00156                                     s=sqrt(x_rotated(1)**2+x_rotated(2)**2)
00157                                     IF (abs(x_rotated(3)) < half*thickness .AND. s <= R) THEN !inside of loop region
00158                                        temp=emf_source_3D(s)
00159                                        A(i,j,k,l)=A(i,j,k,l)+temp(l)
00160                                     END IF
00161                                  END DO
00162                               END DO
00163                            END IF
00164                         END DO
00165                      END DO
00166                   END DO
00167                END DO
00168             END DO
00169          END DO
00170 
00171          A=A/REAL(sample_res, 8)
00172 
00173          ! Calculate magnetic fluxes from A (B = curl(A)).
00174 
00175          IF (MaintainAuxArrays) THEN
00176             Info%aux=0.0
00177 
00178             Info%aux(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc, 1)=&
00179                  (A(1-rmbc:mx+rmbc+1, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3) &
00180                  - A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 3))/levels(Info%level)%dX &
00181                  - (A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,2-zrmbc:mz+zrmbc+1, 2)&
00182                  - A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 2))/levels(Info%level)%dx
00183 
00184             Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc, 2)=&
00185                  (A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,2-zrmbc:mz+zrmbc+1, 1)&
00186                  - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx&
00187                  - (A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3)&
00188                  - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 3))/levels(Info%level)%dx
00189 
00190             Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc+1, 3)=&
00191                  (A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 2)&
00192                  - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 2))/levels(Info%level)%dx&
00193                  - (A(1-rmbc:mx+rmbc, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc+1, 1)&
00194                  - A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc+1, 1))/levels(Info%level)%dx
00195          END IF
00196          !       Info%q=0d0
00197 
00198          ! Calculate B-fields
00199          IF (MaintainAuxArrays) THEN
00200             forall(i=1-rmbc:mx+rmbc,j=1-rmbc:my+rmbc, k=1-zrmbc:mz+zrmbc)
00201                Info%q(i,j,k,iBx)=half*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1))
00202                Info%q(i,j,k,iBy)=half*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2))
00203                Info%q(i,j,k,iBz)=half*(Info%aux(i,j,k,3)+Info%aux(i,j,k+1,3))
00204             end forall
00205          END IF
00206 
00207          !       v = rotate_z(rotate_y(v,theta),phi)
00208       ELSE
00209 
00210          ! 2D case.
00211 
00212          ALLOCATE(A(1-rmbc:mx+rmbc+1,1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc,1), STAT=iErr)
00213 
00214          IF (iErr /= 0) THEN
00215             PRINT *, "DomainInitProblem() error: unable to allocate 2D array."
00216             STOP
00217          END IF
00218 
00219          A=0.0          ! A = magnetic potential.
00220 
00221          ! Initialize A.
00222          DO j=1-rmbc, my+rmbc+1
00223             DO i=1-rmbc, mx+rmbc+1
00224                DO ii=0,2 
00225                   DO jj=0,2
00226                      IF (maxval(abs(A(i,j,1,:))) == 0) THEN
00227                         pos=Info%xBounds(1:3,1)+(/REAL(i,8)-1, REAL(j,8)-1, 0d0/) * levels(Info%level)%dx
00228                         pos(1)=pos(1)+(GxBounds(1,2)-GxBounds(1,1))*(modulo(ii+1,3)-1)
00229                         pos(2)=pos(2)+(GxBounds(2,2)-GxBounds(2,1))*(modulo(jj+1,3)-1)
00230                         mini_pos=pos
00231                         x_rotated=mini_pos
00232                         s=sqrt(x_rotated(1)**2+x_rotated(2)**2)
00233                         IF (s <= R) THEN !inside of loop region
00234                            temp=emf_source_3D(s)
00235                            A(i,j,1,1)=temp(3)
00236                         END IF
00237                      END IF
00238                   END DO
00239                END DO
00240             END DO
00241          END DO
00242 
00243          ! Calculate magnetic fluxes (B = curl(A)).
00244          IF (MaintainAuxArrays) THEN
00245             Info%aux=0.0
00246 
00247             Info%aux(1-rmbc:mx+1+rmbc, 1-rmbc:my+rmbc, 1-zrmbc:mz+zrmbc, 1)=&
00248                  (A(1-rmbc:mx+rmbc+1, 2-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1) &
00249                  -A(1-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx
00250 
00251             Info%aux(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1, 1-zrmbc:mz+zrmbc, 2)=&
00252                  -(A(2-rmbc:mx+rmbc+1, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1)&
00253                  -A(1-rmbc:mx+rmbc, 1-rmbc:my+rmbc+1,1-zrmbc:mz+zrmbc, 1))/levels(Info%level)%dx
00254          END IF
00255 
00256          !       Info%q=0d0
00257 
00258          ! Calculate magnetic field values from fluxes.
00259          IF (MaintainAuxArrays) THEN
00260             forall(i=1-rmbc:mx+rmbc,j=1-rmbc:my+rmbc, k=1-zrmbc:mz+zrmbc)
00261                Info%q(i,j,k,iBx)=half*(Info%aux(i,j,k,1)+Info%aux(i+1,j,k,1))
00262                Info%q(i,j,k,iBy)=half*(Info%aux(i,j,k,2)+Info%aux(i,j+1,k,2))
00263             end forall
00264          END IF
00265 
00266       END IF
00267 
00268       ! Set other variables.
00269 
00270       !    Info%q(:,:,:,1)=rho
00271       !    Info%q(:,:,:,2)=rho*v(1)
00272       !    Info%q(:,:,:,3)=rho*v(2)
00273       !    Info%q(:,:,:,4)=rho*v(3)
00274 
00275       ! Calculate the total energy (E_total = E_thermal + E_kinetic + E_magnetic).
00276 
00277       CALL ConvertInternalToTotalEnergy(Info%q(1:Info%mX(1), 1:Info%mX(2), 1:Info%mX(3), :))
00278 
00279       DEALLOCATE(A)
00280 
00281    END SUBROUTINE ProblemGridInit
00282 
00285    SUBROUTINE ProblemBeforeStep(Info)
00286       !! @brief Performs any tasks required before the advance step.
00287       !! @param Info A grid structure.  
00288       TYPE (InfoDef) :: Info
00289       INTEGER, DIMENSION(0:2) :: Steps = (/1,4,11/)
00290       LOGICAL, DIMENSION(0:2) :: RestartTriggered=(/.false.,.false.,.false./)
00291       INTEGER :: i
00292       IF (Info%level > 2) RETURN
00293       i = levels(Info%level)%CurrentLevelStep
00294       IF (steps(Info%level) == i .AND. MPI_ID == 0 .AND. .NOT. RestartTriggered(Info%level)) THEN
00295          write(*,*) 'Processor ', MPI_ID, ' purposely requesting restart on level ', Info%level, 'step ', i, 'to test code'
00296          lRequestRestart=.true.
00297          RestartTriggered(Info%level)=.true.
00298       END IF
00299    END SUBROUTINE ProblemBeforeStep
00300 
00303   SUBROUTINE ProblemAfterStep(Info)
00304      !! @brief Performs any post-step corrections that are required.
00305      !! @param Info A grid structure.   
00306      TYPE (InfoDef) :: Info
00307      REAL(KIND=qPREC) :: dx, t, x, y, s, Bx, By, err
00308      INTEGER :: i,j
00309      IF (lResolutionTest) THEN
00310         t=levels(Info%level)%tnow+levels(Info%level)%dt
00311         IF (abs(t-.1d0) < 1e-6) THEN
00312            write(*,*) 'saving at t=', t
00313            ALLOCATE(infoq(1:Info%mX(1),1:Info%mX(2),2))
00314            infoq=Info%q(1:Info%mX(1),1:Info%mX(2),1,iBx:iBy)
00315         ELSE IF (abs(t-1.1) < 1e-6) THEN
00316            write(*,*) 'checking at t=', t
00317            dx=levels(Info%level)%dx
00318            err=0
00319            DO i=1, Info%mX(1)
00320               x = GxBounds(1,1)+modulo(Info%xBounds(1,1)+(REAL(i,8)+half)*dx - v(1)*(t-.1) - GxBounds(1,1), GxBounds(1,2)-GxBounds(1,1))
00321               DO j=1, Info%mX(2)
00322                  y = GxBounds(2,1)+modulo(Info%xBounds(2,1)+(REAL(j,8)+half)*dx - v(2)*(t-.1) - GxBounds(2,1), GxBounds(2,2)-GxBounds(2,1))
00323                  s=sqrt(x**2+y**2)
00324 !                 IF (s <= R) THEN 
00325 !                    Bx=-Ao*y/s
00326 !                    By=Ao*x/s
00327 !                 ELSE
00328 !                    Bx=0
00329 !                    By=0
00330 !                 END IF
00331                  if (r > R/2d0) THEN
00332                     err=err+sum(abs(infoq(i,j,:)-info%q(i,j,1,iBx:iBy)))*dx**2
00333                  END if
00334               END DO
00335            END DO
00336            write(*,*) 'resolution, error= ', dx, err
00337         END IF
00338      END IF
00339   END SUBROUTINE ProblemAfterStep
00340 
00343   SUBROUTINE ProblemSetErrFlag(Info)
00344         !! @brief Sets error flags according to problem-specific conditions..
00345         !! @param Info A grid structure.        
00346     TYPE (InfoDef) :: Info
00347   END SUBROUTINE ProblemSetErrFlag
00348 
00349   SUBROUTINE ProblemBeforeGlobalStep(n)
00350      INTEGER :: n
00351   END SUBROUTINE ProblemBeforeGlobalStep
00352 
00353 
00356   FUNCTION emf_source_3D(s)
00357     !! @param s A double-precision number.
00358     REAL(KIND=qPrec) :: s,w(3),emf_source_3D(3)
00359     w=(/0d0,0d0,1d0/)*Ao*(R-s)    
00360     emf_source_3D(1:3)=rotate_z(rotate_y(w,theta),phi) !rotate coordinates again so that vector along jet-axis is along x-axis
00361   END FUNCTION emf_source_3D
00362 
00363 
00364 END MODULE Problem
 All Classes Files Functions Variables