diff --git a/CMakeLists.txt b/CMakeLists.txt index dbf5b16c..0690a5eb 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -49,17 +49,6 @@ mark_as_advanced(bricksize) set(MAXTUBESIZE 5000 CACHE STRING "Size of array buffer for holding flux tubes") add_compile_definitions(MAXTUBESIZE=${MAXTUBESIZE}) -#RCM grid size (required to be defined at compile time) -set(RCMSIZEI 180 CACHE STRING "RCM Grid: Number of Colatitude Cells") -set(RCMSIZEJ 361 CACHE STRING "RCM Grid: Number of Longitude Cells") -set(RCMSIZEK 160 CACHE STRING "RCM Grid: Number of Lambda Cells") -set(RCMWRAPJ 3 CACHE STRING "RCM Grid: Number of periodic wrap cells") -mark_as_advanced(RCMWRAPJ) -add_compile_definitions(RCMSIZEI=${RCMSIZEI}) -add_compile_definitions(RCMSIZEJ=${RCMSIZEJ}) -add_compile_definitions(RCMSIZEK=${RCMSIZEK}) -add_compile_definitions(RCMWRAPJ=${RCMWRAPJ}) - #------------- #Set default IC files file(GLOB GAMICDEF src/gamera/ICs/null.F90) @@ -204,12 +193,10 @@ add_custom_target(remix ALL) message("\tAdding executable remix.x") add_executable(remix.x src/drivers/remix.F90) add_executable(remix2remix.x src/drivers/remix2remix.F90) -add_executable(remix2rcm.x src/drivers/remix2rcm.F90) target_link_libraries(remix.x remixlib dragonkinglib baselib) target_link_libraries(remix2remix.x remixlib dragonkinglib baselib) -target_link_libraries(remix2rcm.x remixlib dragonkinglib baselib) add_dependencies(remixlib dragonkinglib) -add_dependencies(remix remix.x remix2remix.x remix2rcm.x dragonkinglib baselib) +add_dependencies(remix remix.x remix2remix.x dragonkinglib baselib) #------------- # ShellGrid Tester @@ -218,18 +205,6 @@ add_executable(testNewRMS.x src/drivers/testNewRMS.F90) target_link_libraries(testNewRMS.x baselib) add_dependencies(testNewRMS.x baselib) -#------------- -#Kaiju: RCM -message("Adding RCM module ...") -message("\tRCM Grid is of size ${RCMSIZEI} x ${RCMSIZEJ} x ${RCMSIZEK}") -#Add source -add_subdirectory(src/rcm) -add_custom_target(rcm ALL) -message("\tAdding executable rcm.x") -add_executable(rcm.x src/drivers/rcmx.F90) -target_link_libraries(rcm.x rcmlib baselib) -add_dependencies(rcm rcm.x baselib) - #------------- #Kaiju: RAIJU message("Adding RAIJU module ...") @@ -259,7 +234,7 @@ add_subdirectory(src/voltron) add_custom_target(voltron ALL) message("\tAdding executable voltron.x") add_executable(voltron.x src/drivers/voltronx.F90) -target_link_libraries(voltron.x baselib voltlib gamlib dragonkinglib remixlib chimplib rcmlib raijulib) +target_link_libraries(voltron.x baselib voltlib gamlib dragonkinglib remixlib chimplib raijulib) add_dependencies(voltron voltron.x) if(ENABLE_MPI) @@ -290,8 +265,7 @@ if(ENABLE_MPI) add_custom_target(voltron_mpi ALL) message("\tAdding executable voltron_mpi.x") add_executable(voltron_mpi.x src/drivers/voltron_mpix.F90) - target_link_libraries(voltron_mpi.x voltmpilib voltlib gammpilib gamlib dragonkinglib remixlib chimplib rcmlib basempilib baselib) -# target_link_libraries(voltron_mpi.x baselib basempilib voltmpilib voltlib gammpilib gamlib remixlib chimplib rcmlib raijulib) + target_link_libraries(voltron_mpi.x voltmpilib voltlib gammpilib gamlib dragonkinglib remixlib chimplib basempilib baselib) add_dependencies(voltron_mpi voltron_mpi.x) #------------- diff --git a/cmake/compilers.cmake b/cmake/compilers.cmake index 48fa1fbf..1b6605bc 100644 --- a/cmake/compilers.cmake +++ b/cmake/compilers.cmake @@ -140,7 +140,13 @@ elseif(CMAKE_Fortran_COMPILER_ID MATCHES GNU) endif() #Now do machine-dep options if (CMAKE_SYSTEM_NAME MATCHES Darwin) - string(APPEND CMAKE_Fortran_FLAGS " -Wl,-stack_size,0x40000000,-stack_addr,0xf0000000") + if (CMAKE_HOST_SYSTEM_PROCESSOR MATCHES arm64) + #Apple silicon + message("OSX Arch: ${CMAKE_HOST_SYSTEM_PROCESSOR}") + else() + #Older stuff, add big stack + string(APPEND CMAKE_Fortran_FLAGS " -Wl,-stack_size,0x40000000,-stack_addr,0xf0000000") + endif() endif() endif() diff --git a/src/base/defs/raijudefs.F90 b/src/base/defs/raijudefs.F90 index 8f5195e7..174e4b14 100644 --- a/src/base/defs/raijudefs.F90 +++ b/src/base/defs/raijudefs.F90 @@ -86,6 +86,7 @@ module raijudefs !! Fraction that a lambda channel must contribute to total pressure or density in order to be worthy of being evolved real(rp), parameter :: pressFracThreshDef = 0.01 !! If fraction of total pressure below lowest lambda bin is greater than this, we complain + real(rp), parameter :: def_tiote = 4.0 ! Coupling defaults real(rp), parameter :: def_vaFracThresh = 0.10 diff --git a/src/base/defs/rcmdefs.F90 b/src/base/defs/rcmdefs.F90 deleted file mode 100644 index d4c51dda..00000000 --- a/src/base/defs/rcmdefs.F90 +++ /dev/null @@ -1,68 +0,0 @@ -! Constants for RCM - -module rcmdefs - - ! preventing ip and rp from polluting rcm due to use association - use kdefs, ONLY: kip => ip, krp => rp - - implicit none - - private kip,krp - - INTEGER, parameter :: RCMIOVARS = 50 - - INTEGER, parameter :: ICONWRITERESTART = 31337 - INTEGER, parameter :: ICONWRITEOUTPUT = ICONWRITERESTART + 1 - INTEGER, parameter :: ICONRESTART = ICONWRITERESTART - 1 - INTEGER, parameter :: RCMCOLD = 0 - INTEGER, parameter :: RCMELECTRON = 1 - INTEGER, parameter :: RCMPROTON = 2 - INTEGER, parameter :: RCMOXYGEN = 3 - INTEGER, parameter :: RCMVIBRANIUM = 196 - INTEGER, parameter :: RCMNUMFLAV = 2 !Number of RCM flavors - INTEGER, PARAMETER :: isize = RCMSIZEI !RCM grid size in colatitude - INTEGER, PARAMETER :: jsize = RCMSIZEJ !RCM grid size in longitude - INTEGER, PARAMETER :: ksize = RCMSIZEK !RCM grid size in lambda - INTEGER, PARAMETER :: jwrap = RCMWRAPJ !RCM wrapper cells in j - INTEGER, PARAMETER :: nptmax = 50000 - INTEGER, PARAMETER :: iesize = 2 !Number of species flavors - INTEGER, PARAMETER :: ncoeff = 5 - INTEGER, PARAMETER :: kcsize = ksize !No idea why - LOGICAL, PARAMETER :: asci_flag = .FALSE. - LOGICAL, PARAMETER :: isGAMRCM = .TRUE. !Whether running coupled to Gamera - LOGICAL, PARAMETER :: doQuietRCM = .TRUE. - LOGICAL, PARAMETER :: doDiskWrite = .FALSE. - integer(kip), parameter :: RCMTOPCLOSED=-1,RCMTOPOPEN=+1,RCMTOPNULL=0 - REAL(krp) :: DenPP0 = 0.0 !Defining plasmasphere density cutoff, [#/cc] - REAL(krp), PARAMETER :: machine_tiny = 1.0e-32 - REAL(krp), PARAMETER :: tiote_RCM = 4.0 - - enum, bind(C) - enumerator :: ELOSS_FDG=1,ELOSS_SS,ELOSS_WM !Choice of electron loss model - end enum - - REAL(krp), PARAMETER :: bMin_C_DEF = 1.0 ![nT], default min allowable field strength - !For min-B value see Ohtani+Motoba 17 - REAL(krp), PARAMETER :: wImag_C_DEF = 0.10 !Default min allowable RCM "weight" (see rcmimag) - - !Dumb clawpack hard-coded values - REAL(krp), PARAMETER :: CLAW_MAXCFL = 0.95 - REAL(krp), PARAMETER :: CLAW_REGCFL = 0.80 - - !Standard config (CTU + Superbee) - INTEGER , PARAMETER :: ICLAW_TRANSORDER = 2 !2 is standard - INTEGER , PARAMETER :: ICLAW_LIMITER = +2 !Superbee - - !Toy config (Dim split + MC) - !INTEGER , PARAMETER :: ICLAW_TRANSORDER = -1 !2 is standard, maybe try -1? - !INTEGER , PARAMETER :: ICLAW_LIMITER = +4 !MC Limiter - - !Enumerators for rcm boundary shape - enum, bind(C) - enumerator :: RCMDOMELLIPSE=1,RCMDOMCONTOUR,RCMDOMNONE - endenum - !Enumerators for rcm grid type - enum, bind(C) - enumerator :: IMoutside=0,IMbuffer,IMactive - endenum -end module rcmdefs diff --git a/src/base/imaghelper.F90 b/src/base/imaghelper.F90 index b6013681..f7f855db 100644 --- a/src/base/imaghelper.F90 +++ b/src/base/imaghelper.F90 @@ -5,8 +5,8 @@ module imaghelper use earthhelper use math use geopack - use rcmdefs, ONLY: tiote_RCM - + use raijudefs, ONLY: def_tiote + implicit none !Stuff to calculate TM03 plasma sheet model @@ -341,13 +341,13 @@ module imaghelper endif call EvalTM03(xyzGSM_TM03,ionD,ionP,isIn) if (.not. isIn) then - TioTe = tiote_RCM + TioTe = def_tiote else ionT = DP2kT(ionD,ionP) eleT = Tps_dgsr2016(xyzGSM_DSGR16(XDIR),xyzGSM_DSGR16(YDIR),xyzGSM_DSGR16(ZDIR)) if ( (ionT /dev/null 2>&1") - - !Get some XML stuff - call getIDeckStr(XMLStr) - inpXML = New_XML_Input(trim(XMLStr),"Kaiju/RCM",.true.) - call inpXML%Set_Val(RunID,"sim/runid","rcmx") - RM%rcm_runid = trim(RunID) - - call inpXML%Set_Val(mhd_time_start,"time/T0" ,0.0) - call inpXML%Set_Val(mhd_time_end ,"time/tFin",36000.0) - call inpXML%Set_Val(mhd_dt, "time/dt" ,500.0) - - call inpXML%Set_Val(doRestart,"restart/doRes",.false.) - - !Set planet and ionosphere radius for rid_torcm to use - RM%planet_radius = re - RM%iono_radius = 6.5e6 - if (doRestart) then - call RCMRestartInfo(RM,inpXML,mhd_time_start,.true.) - write(*,*) 'Restarting RCM @ t = ', mhd_time_start - call rcm_mhd(mhd_time_start,mhd_dt,RM,RCMRESTART,iXML=inpXML) - doColdstart = .false. - else - ! initialize - call rcm_mhd(mhd_time_start,mhd_dt,RM,RCMINIT,iXML=inpXML) - endif - - write(*,*) 'Start / End / dt = ', mhd_time_start,mhd_time_end,mhd_dt - - !Setup IO - RM%rcm_nOut = 0 - call initRCMIO(RM,doRestart) - - !Set boundaries - rcm_boundary_s =35 - rcm_boundary_e =2 - - mhdtime = mhd_time_start - ! now run -! do mhdtime=mhd_time_start,mhd_time_end-mhd_dt,mhd_dt - do while (mhdtime <= mhd_time_end) - IF(.not.doRestart)then - rcmbndy = nint(rcm_boundary_s +& - (rcm_boundary_e-rcm_boundary_s)*(mhdtime-mhd_time_start)/(mhd_time_end-mhd_time_start),iprec) - write(*,'(a,g12.4,a,i5)')' At t =',mhdtime,' RCM boundary index =',rcmbndy - colat_boundary = sin(RM%gcolat(rcmbndy)) - write(*,*)RM%nLat_ion,RM%nLon_ion - ! compute flux tube volume and other items to pass to the RCM - do i=1,RM%nLat_ion - do j=1,RM%nLon_ion - Lvalue = 1.0/sin(RM%gcolat(i))**2 - RM%Vol(i,j) =32./35.*Lvalue**4/mdipole - RM%X_bmin(i,j,1) = Lvalue*cos(RM%glong(j))*re - RM%x_bmin(i,j,2) = Lvalue*sin(RM%glong(j))*re - RM%x_bmin(i,j,3) = 0.0 - RM%bmin(i,j) = mdipole/Lvalue**3 - RM%iopen(i,j) =-1 ! declare closed - RM%beta_average(i,j) = 0.1 - RM%Pave(i,j) = pmax * exp(-(Lvalue-Lmax)**2) + pmin - RM%Nave(i,j) = nmax * exp(-(Lvalue-Lmax)**2) + nmin - ! add a potential that goes to zero near the inner boundary 5/20 frt - sc = sin(colat_boundary) - sg = sin(RM%gcolat(i)) - if(RM%gcolat(i) < colat_boundary)then - RM%pot(i,j) = -potmax/2.*sin(RM%glong(j))*sg/sc - else - RM%pot(i,j) = -potmax/2.*sin(RM%glong(j))/sc/(1.-1./sc**2)*(sg-1./sg) - end if - - end do - end do - - ! set rcm boundary - RM%Vol(1:rcmbndy,:) = -1.0 - RM%iopen(1:rcmbndy,:) = 1 ! declare open - - ELSE - do i=1,RM%nLat_ion - do j=1,RM%nLon_ion - RM%Vol(i,j) = 1/abs(vm(i,j))**1.5 * sign(1.0d0,vm(i,j))*1.0e9 - RM%Bmin(i,j) = bmin(i,j) - RM%X_bmin(i,j,1) = xmin(i,j) - RM%X_bmin(i,j,2) = ymin(i,j) - RM%X_bmin(i,j,3) = zmin(i,j) - RM%iopen(i,j) = sign(vm(i,j),1.0d0) - RM%pot(i,j) = v(i,j) - end do - end do - END IF ! restart - - if (doColdstart)then - write(*,'(2(a,g14.4))')' calling rcm_mhd at time: ',mhdtime,' delta t=',mhd_dt - call rcm_mhd(mhdtime,mhd_dt,RM,RCMCOLDSTART) - doColdstart = .false. - else - write(*,'(2(a,g14.4))')' calling rcm_mhd at time: ',mhdtime,' delta t=',mhd_dt - call rcm_mhd(mhdtime,mhd_dt,RM,RCMADVANCE) - end if - - !Commenting out old-style output for now - !call write_2d(RM,mhdtime+mhd_dt) ! write out results - - call WriteRCM(RM,RM%rcm_nOut,mhdtime,mhdtime) - write(*,*) 'Total pressure = ', sum(RM%Prcm) - RM%rcm_nOut = RM%rcm_nOut+1 - - mhdtime = mhdtime + mhd_dt - end do - - ! done now close out - call rcm_mhd(mhdtime,mhd_dt,RM,RCMWRITETIMING) - - stop -end program rcmx - -subroutine write_2d(RM,time) - - use rcm_mhd_interfaces - use rcm_mhd_mod, ONLY: rcm_mhd - USE Rcm_mod_subs, ONLY : iprec,rprec - type(rcm_mhd_T),intent(in) :: RM - real(rprec),intent(in) :: time - character(len=15) :: fileout - character(len=5) :: ctime - integer(iprec) ::i,j - - write (ctime, '(i5.5)')int(time,iprec) - - fileout = adjustr('tomhd') //ctime// '.dat' - write(*,*)' writing file =',fileout - - open(unit=10,file=fileout,status='unknown') - - write(10,*)time - write(10,*)RM%nLat_ion - write(10,*)RM%nLon_ion - - do i=1,RM%nLat_ion - do j=1,RM%nLon_ion - write(10,'(4(g14.6,1x))')RM%X_bmin(i,j,1), RM%X_bmin(i,j,2), RM%Prcm(i,j), RM%Nrcm(i,j) - end do - end do - - close(10) - return -end subroutine write_2d - - - diff --git a/src/drivers/remix2rcm.F90 b/src/drivers/remix2rcm.F90 deleted file mode 100644 index 867b277e..00000000 --- a/src/drivers/remix2rcm.F90 +++ /dev/null @@ -1,98 +0,0 @@ - ! standalone remix copied and simplified from omega - ! hardcoding the current source to the test in Merkin&Lyon 2010 - -program MIX - use mixtypes - use mixdefs - use mixmain - use mixio - - implicit none - - ! Input deck - character(len=strLen) :: inpXML - - integer,parameter :: hmsphrs(2) = [NORTH,SOUTH] - real(rp),parameter :: tilt=0.23456 - type(mixApp_T) :: remixApp - - ! rcm stuff - integer :: i,j - integer :: isize = 200, jsize=100 - real(rp) :: rcmLowLat = 80., rcmHighLat = 20. ! in degrees colatitude - real(rp), dimension(:,:), allocatable :: rcmt, rcmp - real(rp), dimension(:,:), allocatable :: rcmPsi - type(mixGrid_T) :: rcmG - type(Map_T) :: rcmMap - - call readArgs(inpXML) - call init_mix(remixApp%ion,hmsphrs,inpXML,'mixtest',.false.) - call fill_fac(remixApp%ion) - call run_mix(remixApp%ion,tilt) - call writeMIX(remixApp%ion,0,1344._rp,1555._rp) - - call init_uniform(rcmG,jsize,isize,rcmLowLat*pi/180._rp,rcmHighLat*pi/180._rp,isSolverGrid=.false.) - call mix_set_map(remixApp%ion(NORTH)%G,rcmG,rcmMap) - call mix_map_grids(rcmMap,remixApp%ion(NORTH)%St%Vars(:,:,POT),rcmPsi) - - write(*,*) minval(remixApp%ion(NORTH)%St%Vars(:,:,POT)),maxval(remixApp%ion(NORTH)%St%Vars(:,:,POT)) - write(*,*) minval(rcmPsi),maxval(rcmPsi) - open(unit=10, file="rcm.dat") - do i=1,isize - do j=1,jsize - write(10,'(3f10.2)') rcmG%p(j,i),rcmG%t(j,i),rcmPsi(j,i) - enddo - enddo - close(10) - - contains - - subroutine readArgs(inpXML) - character(len=*),intent(inout) :: inpXML - integer :: Narg - logical :: fExist - - ! Input deck - Narg = command_argument_count() - if (Narg .eq. 0) then - write(*,*) 'No input deck specified, defaulting to Input.xml' - inpXML = "Input.xml" - else - call get_command_argument(1,inpXML) - endif - - write(*,*) 'Reading input deck from ', trim(inpXML) - inquire(file=inpXML,exist=fExist) - if (.not. fExist) then - write(*,*) 'Error opening input deck, exiting ...' - write(*,*) '' - stop - endif - - end subroutine readArgs - - subroutine fill_fac(I) - type(mixIon_T),dimension(:),intent(inout) :: I - - ! current setup - real(rp) :: thetaMin, thetaDelta - integer :: h,ii,jj - - thetaMin = 22.0_rp*PI/180. - thetaDelta = 12.0_rp*PI/180. - - do h=1,size(I) - do ii=1,I(h)%G%Np - do jj=1,I(h)%G%Nt - if(I(h)%G%t(ii,jj) .ge. thetaMin .and. I(h)%G%t(ii,jj) .le. (thetaMin+thetaDelta)) then - I(h)%St%Vars(ii,jj,FAC) = sin(I(h)%G%t(ii,jj)) * sin(I(h)%G%p(ii,jj)) -! I(h)%St%Vars(ii,jj,FAC) = Mollify(I(h)%G%t(ii,jj)-thetaMin-0.5*thetaDelta,thetaDelta) * sin(I(h)%G%p(ii,jj)) - else - I(h)%St%Vars(ii,jj,FAC) = 0.0_rp - endif - end do - end do - end do - end subroutine fill_fAC - -end program MIX diff --git a/src/drivers/tracex.F90 b/src/drivers/tracex.F90 index 2f24c65e..6fbbb50c 100644 --- a/src/drivers/tracex.F90 +++ b/src/drivers/tracex.F90 @@ -23,7 +23,7 @@ program tracex integer :: n,NumP real(rp), allocatable :: Xs(:,:) - type(fLine_T), allocatable :: fLs(:) + type(magLine_T), allocatable :: fLs(:) real(rp) :: wT !write(*,*) "Num threads=",omp_get_max_threads() @@ -65,7 +65,7 @@ program tracex !$OMP PARALLEL DO default(shared) & !$OMP schedule(dynamic) do n=1,NumP - call genStream(Model,ebState,Xs(n,:),Model%t,fLs(n)) + call genLine(Model,ebState,Xs(n,:),Model%t,fLs(n)) enddo call Toc("Tracer") diff --git a/src/rcm/CMakeLists.txt b/src/rcm/CMakeLists.txt deleted file mode 100644 index 0484d531..00000000 --- a/src/rcm/CMakeLists.txt +++ /dev/null @@ -1,9 +0,0 @@ -file(GLOB rcm_srcs_f90 *.F90) -file(GLOB rcm_srcs_f *.F) -if(CMAKE_Fortran_COMPILER_ID MATCHES Intel) - set_source_files_properties(${rcm_srcs_f} PROPERTIES COMPILE_FLAGS "-fixed -nowarn") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES GNU) - set_source_files_properties(${rcm_srcs_f} PROPERTIES COMPILE_FLAGS "-ffixed-form") -endif() -add_library(rcmlib ${rcm_srcs_f90} ${rcm_srcs_f}) -target_link_libraries(rcmlib baselib) diff --git a/src/rcm/READ_BEFORE_COMPILING_RCM b/src/rcm/READ_BEFORE_COMPILING_RCM deleted file mode 100644 index a8d6f1ac..00000000 --- a/src/rcm/READ_BEFORE_COMPILING_RCM +++ /dev/null @@ -1,2 +0,0 @@ -Compiling the RCM code requires 3rd-party software. Please, reach out -to Prof. Frank Toffoletto at with any questions. diff --git a/src/rcm/aanotes.f90.txt b/src/rcm/aanotes.f90.txt deleted file mode 100644 index e8821dba..00000000 --- a/src/rcm/aanotes.f90.txt +++ /dev/null @@ -1,32 +0,0 @@ -Rcm_mix(Bsm,Psi, Wsm, jpara_rcm,Eave,Fnum) -! all parameters are defined on 2D RCM grid in SM coordinates (theta,phi) -Intent(in):: Bsm ! mag. field vector (x,y,z) components in SM coordinates [T] - Psi ! potential [V] - -Intent(out):: Wsm ! 2D SM coordinates of the RCM grid (theta,phi) in radians - Jpara_rcm ! RCM field aligned current [A/m^2] - Eave[fluid] ! 3D array (theta,phi,fluid) including electron and potentially multiple ion fluids [J] - Fnum[fluid] ! 3D array (theta,phi,fluid) including electron and potential multiple ion fluids [#/m^2] -============== - -============== -Rcm_mhd(V,Pave,Nave,x_bmin,Bmin,mask,gamma,Prcm,Nrcm) -! all parameters are defined on 2D RCM grid in SM coordinates (theta,phi) -Intent(in):: V ! MHD flux tube volume [(Pa^1/gamma)*m/T] - Pave ! MHD pressure average over flux tube [Pa] - Nave ! MHD number density [#/m^3] - X_bmin ! location vector of the Bmin surface [m] - Bmin ! minimum magnetic field [T] - Mask ! open/closed field line (-1: closed; 1: open; 0: everything else) - Gamma ! polytropic index -Intent(out) :: Prcm ! RCM pressure including electron and potential multiple ion fluids [Pa] - Nrcm ! RCM density [#/m^3] -============== - -For defining types, include kdefs module and then equate your types to the following - - !Define variable precisions - integer, parameter :: sp = REAL32 - integer, parameter :: dp = REAL64 - integer, parameter :: ip = INT64 - \ No newline at end of file diff --git a/src/rcm/conversion_module.F90 b/src/rcm/conversion_module.F90 deleted file mode 100644 index d15e20ec..00000000 --- a/src/rcm/conversion_module.F90 +++ /dev/null @@ -1,77 +0,0 @@ -MODULE conversion_module - USE rcm_precision - USE rcmdefs - USE kdefs, ONLY : qp,QPI,PI - IMPLICIT NONE - REAL(rprec), ALLOCATABLE :: bndloc_old(:),almmin(:),almmax(:),almdel(:),& - eta_midnight(:) - REAL(rprec), ALLOCATABLE :: x0(:,:),y0(:,:),z0(:,:) - REAL(rprec), ALLOCATABLE :: x0_sm(:,:),y0_sm(:,:),z0_sm(:,:) - REAL(rprec), ALLOCATABLE :: te(:,:),ti(:,:),to(:,:),& - den(:,:),press(:,:),& - deno(:,:),presso(:,:),& - beta_average(:,:),wImag(:,:) - - REAL(rprec), ALLOCATABLE :: eeta_new(:,:,:) - INTEGER(iprec), ALLOCATABLE :: iopen(:,:),imin_j_old(:),inner_bndy(:) - - !Quad prec. parameters for erf difference - real(qp), parameter, private :: p = 0.3275911 , & - a1 = 0.254829592, & - a2 = -0.284496736, & - a3 = 1.421413741, & - a4 = -1.453152027, & - a5 = 1.061405429 - contains - - !Calculates difference of erfs - diff of exps, i.e. Eqn B5 from Pembroke+ 2012 - function erfexpdiff(A,xp,xm) result(eta) - real(rprec), intent(in) :: A,xp,xm - real(rprec) :: eta - - real(qp) :: qp,qm,tp,tm,ep,em,erfdiff,expdiff,etaq - qp = xp - qm = xm - - - tp = 1.0/(1.0+p*qp) - tm = 1.0/(1.0+p*qm) - ep = exp(-(qp**2.0)) - em = exp(-(qm**2.0)) - - !Difference of erf's using Abramowitz & Stegun, 7.1.26 - !erfdiff(qp,qm) = erf(qp)-erf(qm) - !erf(x) ~ 1 - (a1.t + a2.t^2 + a3.t^3 + a4.t^5 + a5.t^5)*exp(-x^2) + eps(x) - !t = 1/(1+px) - !|eps(x)| <= 1.5e-7 - !Explicitly remove canceling 1's for difference - erfdiff = - (a1*tp + a2*(tp**2.0) + a3*(tp**3.0) + a4*(tp**4.0) + a5*(tp**5.0))*ep & - + (a1*tm + a2*(tm**2.0) + a3*(tm**3.0) + a4*(tm**4.0) + a5*(tm**5.0))*em - - expdiff = 2.0*(qp*ep - qm*em)/sqrt(QPI) !Using quad prec PI - etaq = A*(erfdiff-expdiff) - eta = etaq !Cast back down to rp - end function erfexpdiff - - - ! function olderfexpdiff(A,x,y) result(z) - - ! real(rp), intent(in) :: A,x, y - ! real(rp) :: z - - ! !QUAD precision holders - ! real(qp) :: xq,yq,zq,differf,diffexp - - ! xq = x - ! yq = y - ! !Replacing erf(x)-erf(y) w/ erfc to avoid flooring to zero - ! differf = erfc(yq)-erfc(xq) - ! diffexp = xq*exp(-xq**2.0) - yq*exp(-yq**2.0) - ! diffexp = 2.0*diffexp/sqrt(PI) - - ! zq = A*(differf-diffexp) - ! z = zq - - ! end function olderfexpdiff - -END MODULE conversion_module diff --git a/src/rcm/etautils.F90 b/src/rcm/etautils.F90 deleted file mode 100644 index 3f12a57f..00000000 --- a/src/rcm/etautils.F90 +++ /dev/null @@ -1,562 +0,0 @@ -!Utilities for D/P <=> eta mapping - -MODULE etautils - USE kdefs, ONLY : TINY,Me_cgs,Mp_cgs - USE rcmdefs - USE rcm_precision - USE rice_housekeeping_module - USE constants, ONLY : mass_proton,mass_electron,nt,ev,tiote,boltz - USE Rcm_mod_subs, ONLY : kcsize,alamc,ikflavc - USE rcm_mhd_interfaces, ONLY : rcmPScl - USE conversion_module, ONLY : erfexpdiff - implicit none - - real(rp), private :: density_factor = 0.0 !module private density_factor using planet radius - real(rp), private :: pressure_factor = 0.0 - - real(rprec), private :: sclmass(RCMNUMFLAV) !xmass prescaled to proton - integer , private, dimension(RCMNUMFLAV,2) :: flavorBnds - - real(rp), private, parameter :: kapDefault = 6.0 - - real(rp), private, dimension(RCMNUMFLAV) :: kapDefs - - contains - - !Set density/pressure factors using planet radius - subroutine SetFactors(Rx) - real(rp), intent(in) :: Rx - integer :: n,k - - pressure_factor = 2./3.*ev/Rx*nt - density_factor = nt/Rx - - !Set scaled mass by hand here to avoid precision issues - sclmass(RCMELECTRON) = Me_cgs/Mp_cgs - sclmass(RCMPROTON) = 1.0 - - !Get flavor bounds - do n=1,RCMNUMFLAV - !NOTE: Doing stupid code to avoid findloc - - !Find first value - do k=1,kcsize - if (ikflavc(k) == n) exit - enddo - flavorBnds(n,1) = k - !Find last value - do k=flavorBnds(n,1),kcsize - if (ikflavc(k) /= n) exit - enddo - flavorBnds(n,2) = k-1 - enddo - - !Do fixes - if (use_plasmasphere) then - !Bump up electron min to avoid plasmasphere channel - flavorBnds(RCMELECTRON,1) = flavorBnds(RCMELECTRON,1) + 1 - endif - - !Set default kappa values if using kappa - kapDefs(RCMELECTRON) = 4.0 - kapDefs(RCMPROTON ) = kapDefault - - end subroutine SetFactors - - !Simple functions to access XXX factors - function GetDensityFactor() result(df) - real(rp) :: df - df = density_factor - end function GetDensityFactor - - function GetPressureFactor() result(pf) - real(rp) :: pf - pf = pressure_factor - end function GetPressureFactor - - !Convert single eta to density (RC/plasmasphere) and pressure - subroutine eta2DP(eta,vm,Drc,Dpp,Prc,doCharge0) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - REAL(rprec), intent(out) :: Drc,Dpp,Prc - logical , intent(in), optional :: doCharge0 - - integer :: klow - logical :: doC0 - - if (present(doCharge0)) then - doC0 = doCharge0 - else - doC0 = .false. - endif - - !Set lowest RC channel - if (use_plasmasphere) then - klow = 2 - else - klow = 1 - endif - - Drc = 0.0 - Dpp = 0.0 - Prc = 0.0 - - if (vm <= 0) return - - !Do RC channels - Prc = IntegratePressure(eta,vm,klow,kcsize) - Drc = IntegrateDensity (eta,vm,klow,kcsize,doC0) - - !Handle plasmasphere - if (use_plasmasphere) then - Dpp = density_factor*sclmass(RCMPROTON)*eta(1)*vm**1.5 - else - Dpp = 0.0 - endif - - end subroutine eta2DP - - !Get Pk - Pressure contribution from each channel - subroutine eta2Pk(eta,vm,Pk) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - REAL(rprec), intent(out) :: Pk(kcsize) - - integer :: k - REAL(rprec) :: dP - - Pk = 0.0 - if (vm <= 0) return - - do k=1,kcsize - dP = pressure_factor*ABS(alamc(k))*eta(k)*vm**2.5 - Pk(k) = dP - enddo - end subroutine eta2Pk - - !Integrate pressure from eta between channels k1,k2 - function IntegratePressure(eta,vm,k1,k2) result(P) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - integer , intent(in) :: k1,k2 - REAL(rprec) :: P - integer :: k - - P = 0.0 - if (vm <= 0) return - - do k=k1,k2 - !Pressure calc in pascals - P = P + pressure_factor*ABS(alamc(k))*eta(k)*vm**2.5 - enddo - end function IntegratePressure - - !Integrate density from eta between channels k1,k2 (neglect cold species) - !doCharge0: optional argument, whether to attempt to mock up charge neutrality mass in electron regions - function IntegrateDensity(eta,vm,k1,k2,doCharge0) result(D) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - integer , intent(in) :: k1,k2 - logical , intent(in), optional :: doCharge0 - - real(rp) :: D - logical :: doC0 - REAL(rprec) :: Di,De - integer :: k - - if (present(doCharge0)) then - doC0 = doCharge0 - else - doC0 = .false. - endif - - Di = 0.0 - De = 0.0 - if (vm <= 0) return - - do k=k1,k2 - !Density calc - if (alamc(k) > TINY) then - !Hot ion contribution - Di = Di + density_factor*sclmass(ikflavc(k))*eta(k)*vm**1.5 - else if (alamc(k) < TINY) then - !Cold ion counterparts to hot electrons - De = De + density_factor*sclmass(RCMPROTON)*eta(k)*vm**1.5 - endif - enddo !k loop - - if (doC0) then - D = max(Di,De) !Include mass from cold counterparts to hot electrons if needed - else - D = Di - endif - - end function IntegrateDensity - - !Get both ion and electron pressures - subroutine IntegratePressureIE(eta,vm,iP,eP) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - REAL(rprec), intent(out) :: iP,eP - - INTEGER(iprec) :: k - iP = 0.0 - eP = 0.0 - if (vm <= 0) return - do k=1,kcsize !Include psphere b/c it won't contribute - if (abs(alamc(k))TINY) then - !Ion pressure - iP = iP + pressure_factor*ABS(alamc(k))*eta(k)*vm**2.5 - else - !Elec pressure - eP = eP + pressure_factor*ABS(alamc(k))*eta(k)*vm**2.5 - endif - enddo - - end subroutine IntegratePressureIE - - !Get Ti/Te for a given eta - ! Ti/Te = Pi/Pe b/c Ni=Ne - function GetTioTe(eta,vm) result(TiovTe) - REAL(rprec), intent(in) :: eta(kcsize) - REAL(rprec), intent(in) :: vm - REAL(rprec) :: TiovTe - REAL(rprec) :: eP,iP - INTEGER(iprec) :: k - - TiovTe = 0.0 - if (vm <= 0) return - iP = 0.0 - eP = 0.0 - call IntegratePressureIE(eta,vm,iP,eP) - if (eP>TINY) then - TiovTe = iP/eP - else - TiovTe = 0.0 - endif - end function GetTioTe - - subroutine MaxVsKap(Drc,Prc,vm) - REAL(rprec), intent(in) :: Drc,Prc,vm - REAL(rprec), dimension(kcsize) :: etaMax,etaKap - REAL(rprec) :: Dm,Dk,Pm,Pk,Dpp - - call DP2eta(Drc,Prc,vm,etaMax,doRescaleO=.false.,doKapO=.false.) - call DP2eta(Drc,Prc,vm,etaKap,doRescaleO=.false.,doKapO=.true. ) - - call eta2DP(etaMax,vm,Dm,Dpp,Pm) - call eta2DP(etaKap,vm,Dk,Dpp,Pk) - - write(*,*) 'Max/Kap: D/P = ', Drc*1.0e-6,Dm*1.0e-6,Dk*1.0e-6,Prc*1.0e+9,Pm*1.0e+9,Pk*1.0e+9 - - end subroutine MaxVsKap - - !Convert given single density/pressure to eeta - !Optional flag to rescale moments or provide different Ti/Te - SUBROUTINE DP2eta(Drc,Prc,vm,eta,doRescaleO,tioteO,doKapO,kapO) - USE conversion_module, ONLY : almmax,almmin,erfexpdiff - REAL(rprec), intent(in) :: Drc,Prc,vm - REAL(rprec), intent(out) :: eta(kcsize) - logical , intent(in), optional :: doRescaleO,doKapO - REAL(rprec), intent(in), optional :: tioteO,kapO - - REAL(rprec) :: fac,TiovTe,Pion,Pele,kap - logical :: doRescale,doKap - - eta = 0.0 - kap = 0.0 - - if ( (vm<0) .or. (Drc= 0 forall lam - minScl = minval( A + B*abs(alamc(k1:kmax)) ) - if (minScl <= 0) then - !Bad A,B keep trying - cycle - else - !This is good, let's get out of here - return - endif - enddo - - !If still here, nothing worked. Use single moment rescaling - B = 0.0 - kmax = k2 - etaP = IntegratePressure(eta,vm,k1,k2) - - if (etaP*rcmPScl > TINY) then - A = P/etaP - else - A = 0.0 - endif - - END SUBROUTINE GetRescaleAB - -!====== - !Specific PSD types - !General form: Maxwell2Eta(Drc,vm,Tk,almin,almax,almc) - !almin/max/c are min/max and center of lambda bin - !Drc = Density [#/m3] - !vm = (nt/re)^0.667 - !Tk = Temperature [K] - - function Maxwell2Eta(Drc,vm,Tk,almin,almax,almc) result(etak) - real(rp), intent(in) :: Drc,vm,Tk,almin,almax,almc - real(rp) :: etak - - real(rp) :: A0,xp,xm - - A0 = (Drc/density_factor)/(vm**1.5) - xp = SQRT(ev*ABS(almax)*vm/boltz/Tk) - xm = SQRT(ev*ABS(almin)*vm/boltz/Tk) - - !Use quad prec calc of erf/exp differences, Pembroke+ Eqn B5 - etak = erfexpdiff(A0,xp,xm) - - end function Maxwell2Eta - - !NOTE: This is just adaped from other RCM code, seems to be eqn 3.12 from 10.1007/s11214-013-9982-9 - function Kappa2Eta(Drc,vm,Tk,almin,almax,almc,kapO) result(etak) - real(rp), intent(in) :: Drc,vm,Tk,almin,almax,almc - real(rp), intent(in), optional :: kapO - real(rp) :: etak - - real(rp) :: kap,kap15,Tev,E0_ev,E_ev - real(rp) :: A0,kapgam,kapbar,kArg,delscl - - if (present(kapO)) then - kap = kapO - else - kap = kapDefault - endif - - kap15 = kap-1.5 - Tev = Tk*Kbltz*erg2kev*(1.0e+3) !temperature in eV - E0_ev = Tev*kap15/kap - - E_ev = abs(almc)*vm !eV - - A0 = (2.0/sqrt(PI))*(Drc/density_factor)/(vm**1.5) - !TODO: Double check this extra factor of 2 - !A0 = 2.0*A0 - - kapgam = gamma(kap+1.0)/gamma(kap-0.5) - !TODO: Figure out k_0 vs. kappa where kappa - 1.5 = kappa_0 - kapbar = kap15 !Should be kap-3/2 or kap - !kapbar = kap !Using kap consistent w/ 10.1002/2015JA021166 - - kArg = 1.0 + (E_ev/E0_ev)/kapbar - delscl = vm*(almax-almin)/E0_ev - etak = A0*kapgam/(kapbar**1.5) * sqrt(E_ev/E0_ev)*delscl*((kArg)**(-kap-1.0)) - - end function Kappa2Eta - -END MODULE etautils diff --git a/src/rcm/ionosphere_exchange.F90 b/src/rcm/ionosphere_exchange.F90 deleted file mode 100644 index 06dda18a..00000000 --- a/src/rcm/ionosphere_exchange.F90 +++ /dev/null @@ -1,126 +0,0 @@ -MODULE ionosphere_exchange - use rcm_mhd_interfaces - use rcm_mod_subs, ONLY: isize, jsize, jwrap, colat, aloct - use kdefs, ONLY : PI - contains - - !> Allocate Ionosphere Grid variables and read Ion grid from "RCM-ion.dat". - !! Don't forget to deallocate! - SUBROUTINE setupIon(RM) - IMPLICIT NONE - type(rcm_mhd_T),intent(inout) ::RM - integer(iprec) :: lat,lon - - rm%nLat_ion = isize - rm%nLon_ion = jsize-jwrap+1 - - ALLOCATE( rm%gcolat(rm%nLat_ion) ) - ALLOCATE( rm%glong(rm%nLon_ion) ) - - ALLOCATE( rm%pot(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%nflx(rm%nLat_ion, rm%nLon_ion, 2) ) - ALLOCATE( rm%eng_avg(rm%nLat_ion, rm%nLon_ion, 2) ) - ALLOCATE( rm%flux(rm%nLat_ion, rm%nLon_ion, 2) ) - ALLOCATE( rm%fac(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Pave(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Nave(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Vol(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Bmin(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%X_bmin(rm%nLat_ion, rm%nLon_ion, 3) ) - ALLOCATE( rm%iopen(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Prcm(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Npsph(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Nrcm(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%beta_average(rm%nLat_ion, rm%nLon_ion)) - ALLOCATE( rm%sigmap(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%sigmah(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%latc(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%lonc(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Lb (rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Tb (rm%nLat_ion, rm%nLon_ion) ) - - ALLOCATE( rm%toMHD(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%losscone(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%radcurv(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%wIMAG(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%oxyfrac(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%Percm(rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%errD (rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%errP (rm%nLat_ion, rm%nLon_ion) ) - ALLOCATE( rm%nTrc (rm%nLat_ion, rm%nLon_ion) ) - - rm%gcolat (:) = colat (:,1) - rm%glong (:) = aloct (1,jwrap:jsize) - if (rm%glong(rm%nLon_ion) < pi) rm%glong(rm%nLon_ion) = rm%glong(rm%nLon_ion) + 2*pi - - ! initialize all other variables to 0 - rm%pot = 0.0 - rm%nflx = 0.0 - rm%eng_avg = 0.0 - rm%flux = 0.0 - rm%fac = 0.0 - rm%Pave = 0.0 - rm%Nave = 0.0 - rm%Vol = 0.0 - rm%Bmin = 0.0 - rm%X_bmin = 0.0 - rm%iopen = 0 - rm%Prcm = 0.0 - rm%Npsph = 0.0 - rm%Nrcm = 0.0 - rm%beta_average = 0.0 - rm%sigmap = 0.0 - rm%sigmah = 0.0 - rm%latc = 0.0 - rm%lonc = 0.0 - rm%Lb = 0.0 - rm%Tb = 0.0 - rm%toMHD = .False. - rm%losscone = 0.0 - rm%radcurv = 0.0 - rm%wIMAG = 0.0 - rm%oxyfrac = 0.0 - rm%Percm = 0.0 - rm%errD = 0.0 - rm%errP = 0.0 - rm%nTrc = 0 - - END SUBROUTINE setupIon - - !> Deallocate any variables allocated by setupIon. - SUBROUTINE tearDownIon(rm) - type(rcm_mhd_T),intent(inout) ::RM - - if (ALLOCATED(rm%pot)) DEALLOCATE(rm%pot) - if (ALLOCATED(rm%sigmap)) DEALLOCATE(rm%sigmap) - if (ALLOCATED(rm%sigmah)) DEALLOCATE(rm%sigmah) - if (ALLOCATED(rm%gcolat)) DEALLOCATE(rm%gcolat) - if (ALLOCATED(rm%glong)) DEALLOCATE(rm%glong) - if (ALLOCATED(rm%flux)) DEALLOCATE(rm%flux) - if (ALLOCATED(rm%fac)) DEALLOCATE(rm%fac) - if (ALLOCATED(rm%Pave)) DEALLOCATE(rm%Pave) - if (ALLOCATED(rm%Nave)) DEALLOCATE(rm%Nave) - if (ALLOCATED(rm%Vol)) DEALLOCATE(rm%Vol) - if (ALLOCATED(rm%Bmin)) DEALLOCATE(rm%Bmin) - if (ALLOCATED(rm%X_bmin)) DEALLOCATE(rm%X_bmin) - if (ALLOCATED(rm%iopen)) DEALLOCATE(rm%iopen) - if (ALLOCATED(rm%Prcm)) DEALLOCATE(rm%Prcm) - if (ALLOCATED(rm%Npsph)) DEALLOCATE(rm%Npsph) - if (ALLOCATED(rm%Nrcm)) DEALLOCATE(rm%Nrcm) - if (ALLOCATED(rm%beta_average)) DEALLOCATE(rm%beta_average) - if (ALLOCATED(rm%latc)) DEALLOCATE(rm%latc) - if (ALLOCATED(rm%lonc)) DEALLOCATE(rm%lonc) - if (ALLOCATED(rm%toMHD)) DEALLOCATE(rm%toMHD) - if (ALLOCATED(rm%losscone)) DEALLOCATE(rm%losscone) - if (ALLOCATED(rm%oxyfrac)) DEALLOCATE(rm%oxyfrac) - if (ALLOCATED(rm%Percm)) DEALLOCATE(rm%Percm) - if (ALLOCATED(rm%radcurv)) DEALLOCATE(rm%radcurv) - if (ALLOCATED(rm%wIMAG)) DEALLOCATE(rm%wIMAG) - if (ALLOCATED(rm%errD)) DEALLOCATE(rm%errD) - if (ALLOCATED(rm%errP)) DEALLOCATE(rm%errP) - if (ALLOCATED(rm%nTrc)) DEALLOCATE(rm%nTrc) - - END SUBROUTINE tearDownIon - - END MODULE ionosphere_exchange - diff --git a/src/rcm/lossutils.F90 b/src/rcm/lossutils.F90 deleted file mode 100644 index 190cc346..00000000 --- a/src/rcm/lossutils.F90 +++ /dev/null @@ -1,450 +0,0 @@ -!Utilities for loss calculations - -MODULE lossutils - USE kdefs, ONLY : TINY,PI,Mp_cgs,kev2J,Me_cgs,vc_cgs - USE rcm_precision - USE rcmdefs - USE math, ONLY : SmoothOpTSC,SmoothOperator33,ClampValue,LinRampUp - implicit none - - !Parameters for electron wave models - real(rprec), parameter :: Lo = 8.0 !Outer L, L > 8Re, strong scattering in charge - real(rprec), parameter :: Li = 7.0 !Middle L, L < 7Re, wave models in charge - real(rprec), parameter, private :: kev0 = 1.1 !Min value to allow [keV] - real(rprec), parameter, private :: nhigh = 100.D0 ! [/cc] ne>nhigh indicates inside plasmasphere. - real(rprec), parameter, private :: nlow = 10.D0 ! [/cc] necm/s - - !Timescale - tScl = cos(45*PI/180.0)**3.5 !Using Smith & Bewtra 1976 scaling - Tau = tScl*1.0/(Ngeo*V*Sig) - - cxrate = 1.0/Tau - END FUNCTION CXKaiju - - !Charge exchange cross-section for K [keV] and species ispc - !Sig in cm2 - !Using Lindsay & Stebbings 2005 - FUNCTION CXSigma(K,ispc) result(Sig) - real(rprec), intent(in) :: K - integer(iprec), intent(in) :: ispc - real(rprec) :: Sig - - real(rprec) :: Sig0, KSig,a1,a2,a3,B1,B2 - - Sig0 = 1.0e-16 - - select case(ispc) - case(RCMPROTON) - !Charge exchange cross-section for H+/H - !Cap for validity of CX cross-section - KSig = K - call ClampValue(KSig,0.005_rprec,250.0_rprec) - - a1 = 4.15 - a2 = 0.531 - a3 = 67.3 - - B1 = (a1-a2*log(KSig))**2.0 - B2 = 1.0-exp(-a3/KSig) - Sig = Sig0*B1*(B2**(4.5)) - case(RCMOXYGEN) - !Charge exchange cross-section for O+/H - !Cap for validity of CX cross-section - KSig = K - call ClampValue(KSig,0.025_rprec,600.0_rprec) - a1 = 3.13 - a2 = 0.170 - a3 = 87.5 - - B1 = (a1-a2*log(KSig))**2.0 - B2 = 1.0-exp(-a3/KSig) - Sig = Sig0*B1*(B2**(0.8)) - case default - Sig = 0.0 - end select - - END FUNCTION CXSigma - - !Geocoronal density afa L [#/cc], Taken from Ostgaard 2003 - FUNCTION OstgaardGeocorona(L) result(Ngeo) - real(rprec), intent(in) :: L - real(rprec) :: Ngeo - - Ngeo = 10000.0*exp(-L/1.02) + 70.0*exp(-L/8.2) - - END FUNCTION OstgaardGeocorona - - !Simple mock-up for FLC losses - FUNCTION FLCRat(ie,alam,vm,beq,rcurv,lossc) result(lossFLC) - use constants, only : radius_earth_m - use kdefs, only : TINY - use math, only : RampUp - IMPLICIT NONE - integer(iprec), intent(in) :: ie - real(rprec), intent(in) :: alam,vm,beq,rcurv,lossc - real(rprec) :: lossFLC - real(rprec) :: Np,bfp,ftv,K,V,TauSS,Rgyro,eps,earg - - bfp = beq/(sin(lossc)**2.0) !Foot point field strength, nT - ftv = (1.0/vm)**(3.0/2.0) !flux-tube volume Re/nT - K = alam*vm*1.0e-3 !Energy [keV] - - if (ie == RCMPROTON) then - Np = 1 !Number of nucleons - else - lossFLC = 0.0 - return - endif - - V = sqrt(2*K/Np)*sqrt(kev2J/(Mp_cgs*1.0e-3)) !V in m/s - - !Convert V from m/s to Re/s - V = V/radius_earth_m - - TauSS = 3*2*ftv*bfp/V !Strong scattering lifetime [s], assuming ion w/ gamma=1 - - Rgyro = (4.6e+3)*sqrt(K)/beq !Gyroradius of proton [km], assuming K in keV and beq in nT - Rgyro = Rgyro/(radius_earth_m*1.0e-3) !In terms of Re - eps = Rgyro/rcurv - - !Chen+ 2019, w/ correction - if (eps>TINY) then - !1/TauSS = Strong scattering loss rate - earg = eps**5.0 - lossFLC = min(1.0,100.0*earg)*(1/TauSS) !Rate, 1/s - else - lossFLC = 0.0 - endif - - END FUNCTION FLCRat - - FUNCTION RatefnC_tau_s(alam,vm,beq,lossc) result(TauSS) - ! Strong diffusion lifetime based on Schulz, 1974, 1998. - ! tau_s ~ [2*Psi*Bh/(1-eta)](gamma*m/p), where Psi is flux tube volume, Bh is |B| at field line foot point. - ! eta is backscatter rate at alitude h, here eta=2/3. - ! gamma = m/m0 is relativisitc factor, p is particle momentum. - ! = mc2/m0c2 = (m0c2+K)/m0c2 = 1+K/mec2 ! mec2=0.511 is me*c^2 in MeV - ! m = m0/sqrt(1-v^2/c^2) - ! V = c*1/sqrt(1-1/gammar2) - use kdefs, only : TINY,vc_cgs,Re_cgs,mec2 - use math, only : RampUp - IMPLICIT NONE - real(rprec), intent(in) :: alam,vm,beq,lossc - real(rprec) :: TauSS - real(rprec) :: bfp,ftv,K,V,gammar - bfp = beq/(sin(lossc)**2.0) ! Foot point field strength, nT - ftv = (1.0/vm)**(3.0/2.0) ! flux-tube volume Re/nT - K = abs(alam)*vm*1.0e-6 ! Energy [MeV] - gammar = 1.0+K/mec2 - V = vc_cgs*sqrt(1.0-1.0/gammar**2)/Re_cgs ! Re/s - TauSS = 3.D0*2.D0*ftv*bfp/V*gammar ! Strong scattering lifetime [s], assuming eta=2/3. - - END FUNCTION RatefnC_tau_s - - FUNCTION RatefnDW_tau_c(Kpx,mltx,Lx,Ekx) result(tau) - ! linearly interpolate tau from EWMTauInput to current MLT,L,Kp,Ek value - USE rice_housekeeping_module, ONLY: EWMTauInput - USE kdefs, ONLY: HUGE - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: Kpx, mltx,Lx,Ekx - REAL(rprec) :: tau - REAL(rprec) :: tauKMLE(2,2,2,2),tauMLE(2,2,2),tauLE(2,2),tauE(2)! tauKMLE(1,2,2,2) means tauKlMuLuEu, l:lower bound, u: upper bound in the NN method - REAL(rprec) :: dK,wK,dM,wM,dL,wL,dE,wE - INTEGER :: kL,kU,mL,mU,lL,lU,eL,eU - - - associate(Nm=>EWMTauInput%ChorusTauInput%Nm,Nl=>EWMTauInput%ChorusTauInput%Nl,Nk=>EWMTauInput%ChorusTauInput%Nk,Ne=>EWMTauInput%ChorusTauInput%Ne,& - Kpi=>EWMTauInput%ChorusTauInput%Kpi,MLTi=>EWMTauInput%ChorusTauInput%MLTi,Li=>EWMTauInput%ChorusTauInput%Li,Eki=>EWMTauInput%ChorusTauInput%Eki,& - taui=>EWMTauInput%ChorusTauInput%taui) - - ! Find the nearest neighbors in Kp - if (Kpx >= maxval(Kpi)) then - kL = Nk !use Kp maximum - kU = Nk - else if (Kpx <= minval(Kpi)) then - kL = 1 !use Kp minimum - kU = 1 - else - kL = maxloc(Kpi,dim=1,mask=(Kpi= maxval(MLTi)) .or. (mltx <= minval(MLTi))) then ! maxval of MLT is 24, minval of MLT is 0 - mL = 1 !use MLT = 0 - mU = 1 - else - mL = maxloc(MLTi,dim=1,mask=(MLTi= maxval(Li)) then - lL = Nl !use L maximum - lU = Nl - else if (Lx <= minval(Li)) then - lL = 1 ! use L minimum - lU = 1 - else - lL = maxloc(Li,dim=1,mask=(Li= maxval(Eki)) then - eL = Ne !use Ek maximum - eU = Ne - else - eL = maxloc(Eki,dim=1,mask=(Eki= f(L). - ! f(L) = 0.1328*L^2-2.1463*L+3.7857. - ! g(MLT) = 10^g0(MLT)/G0 - ! h(Kp) = 10^h0(Kp)/H0 - ! G0 = int_0^24(10^g0(MLT))dMLT / 24 = 782.3. - ! g0(MLT) = b2*MLT^2 + b1*MLT + b0 - ! H0 = 1315. - ! h0(Kp) = c2*Kp^2 + c1*Kp + c0 - - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: mltx,engx,kpx,Lshx ! engx in MeV. - REAL (rprec) :: lambda, tau, tau_av - REAL (rprec) :: MLT, L, E, K, L2, L3, L4, fL, E2, E3, E4, E5, LE - REAL (rprec) :: b0, b1, b2, G0, g0_MLT, g_MLT, c0, c1, c2, H0, h0_Kp, h_Kp - REAL (rprec), DIMENSION(20) :: le_pol - REAL(rprec), dimension(20), parameter :: a1_20 = [77.323, -92.641, -55.754, 44.497, 48.981, 8.9067, -10.704, & - -15.711, -3.3326, 1.5189, 1.294, 2.2546, 0.31889, -0.85916, & - -0.22182, 0.034318, 0.097248, -0.12192, -0.062765, 0.0063218] - - lambda = 0.D0 - tau = 1.D10 - MLT = mltx - L = Lshx ! L=3-6 - E = log10(engx) ! engx is Ek in MeV - call ClampValue(L,1.5_rprec,5.5_rprec) ! Clamp L to satisfy 1.5= f(L) - - b0 = 2.080 - b1 = 0.1773 - b2 = -0.007338 - G0 = 782.3 - g0_MLT = b2*MLT*MLT + b1*MLT + b0 - g_MLT = 10**g0_MLT/G0 - c0 = 2.598 - c1 = 0.2321 - c2 = -0.01414 - H0 = 1315.0 - K = min(kpx,5.0) ! 0nhigh) then - ! Region inside the plasmasphere, wave candidates: Hiss - tau_h = tScl*RatefnC_tau_h16(MLT,E,L,kpx) - LossR8_IMAG(1) = 1.0/tau_h - LossR8_IMAG(2) = HISS !wave type number for hiss - else - ! nlow <= nex <= nhigh, at the plume region, wave candidates: - ! Chorus and Hiss - tau_c = tScl*RatefnDW_tau_c(kpx,MLT,L,E) - tau_h = tScl*RatefnC_tau_h16(MLT,E,L,kpx) - - LossR8_IMAG(1) = (dlog(nhigh/nex)/tau_c + dlog(nex/nlow)/tau_h)/dlog(nhigh/nlow) ! use density-weighted loss rate - LossR8_IMAG(2) = (dlog(nhigh/nex)*CHORUS + dlog(nex/nlow)*HISS)/dlog(nhigh/nlow) - endif - - END FUNCTION LossR8_IMAG - - FUNCTION LossR8_PSHEET(alamx,vmx,beqx,losscx) - REAL (rprec), INTENT (IN) :: alamx,vmx,beqx,losscx - REAL (rprec) :: LossR8_PSHEET - REAL (rprec) :: TauSS - - TauSS = RatefnC_tau_s(alamx,vmx,beqx,losscx) - LossR8_PSHEET = 1.0/TauSS - LossR8_PSHEET = LossR8_PSHEET !SS rate - END FUNCTION LossR8_PSHEET - - !Calculate speed (Re/s) from energy [keV] for ELECTRONS - FUNCTION kev2V(keV) result(V) - use kdefs, only : Re_cgs,mec2 - REAL (rprec), INTENT (IN) :: keV - REAL (rprec) :: V - - REAL (rprec) :: E,gammar - - E = keV*1.0e-3 !Energy [MeV] - gammar = 1.0 + E/mec2 - - V = vc_cgs*sqrt(1.0-1.0/gammar**2)/Re_cgs ! Re/s - - END FUNCTION kev2V - -END MODULE lossutils diff --git a/src/rcm/mhd_scalars.F90 b/src/rcm/mhd_scalars.F90 deleted file mode 100644 index cf420ffb..00000000 --- a/src/rcm/mhd_scalars.F90 +++ /dev/null @@ -1,24 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -module mhd_scalars - !> Indices for status scalars to be sent from the MHD - !! Note: These must match up with the scalars on the sending side. -! USE Rcm_mod_subs, ONLY : rprec,iprec - USE rcm_precision - implicit none - integer(iprec), parameter, public :: KILL_SIGNAL = 1 !> 111=kil; 222=last exchange; else=keep running - integer(iprec), parameter, public :: YEAR = 2 - integer(iprec), parameter, public :: MONTH = 3 - integer(iprec), parameter, public :: DAY = 4 - integer(iprec), parameter, public :: HOUR = 5 - integer(iprec), parameter, public :: MINUTE = 6 - integer(iprec), parameter, public :: SECOND = 7 - integer(iprec), parameter, public :: DELTA_T = 8 !> # of seconds between exchange with coupled models - integer(iprec), parameter, public :: LABEL = 9 !> MHD Simulation Time step - integer(iprec), parameter, public :: NUMBER_OF_SCALARS = 9 - ! Scalars at index KILL_SIGNAL accept the following: - integer(iprec), parameter, public :: KILL_SIGNAL_CONTINUE = 0 - integer(iprec), parameter, public :: KILL_SIGNAL_SHUTDOWN = 111 - integer(iprec), parameter, public :: KILL_SIGNAL_LAST_EXCHANGE = 222 - integer(iprec), public :: iaScalars(NUMBER_OF_SCALARS) !> Status scalars sent from MHD - - end module mhd_scalars \ No newline at end of file diff --git a/src/rcm/modules.F90 b/src/rcm/modules.F90 deleted file mode 100644 index 3c2e35b8..00000000 --- a/src/rcm/modules.F90 +++ /dev/null @@ -1,210 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE CONSTANTS - USE rcm_precision - USE kdefs, ONLY : EarthPsi0,Re_cgs,Me_cgs,Mp_cgs,Mu0,Kbltz,eCharge - use rcmdefs, ONLY : isize,jsize,jwrap - REAL(rprec),PARAMETER :: radius_earth_m = Re_cgs*1.0e-2 ! Earth's radius in meters - REAL(rprec),PARAMETER :: boltz = Kbltz*1.0e-7 - REAl(rprec),PARAMETER :: mass_proton =Mp_cgs*1.0e-3 - REAL(rprec),PARAMETER :: mass_electron=Me_cgs*1.0e-3 - REAL(rprec),PARAMETER :: ev=eCharge - REAL(rprec),PARAMETER :: gamma=5.0/3.0 - REAL(rprec),PARAMETER :: big_vm = -1.0e5 - REAL(rprec),PARAMETER :: nt = 1.0e-9 - !REAL(rprec),PARAMETER :: tiote = 7.8 - REAL(rprec),PARAMETER :: tiote = 4.0 !Changed by K 5/9/20 - REAL(rprec),PARAMETER :: RCMCorot = EarthPsi0*1.0e+3 ! Convert corotation to V - -END MODULE CONSTANTS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MODULE rice_housekeeping_module - USE kdefs, ONLY : strLen - USE rcm_precision, only : iprec,rprec - use xml_input - use kronos - use strings - use earthhelper, ONLY : SetKp0 - use rcmdefs, ONLY : DenPP0, ELOSS_FDG, ELOSS_SS, ELOSS_WM - - IMPLICIT NONE - - LOGICAL :: L_write_rcmu = .false., & - L_write_rcmu_torcm = .false., & - L_write_tracing_debug = .false., & - L_write_vars_debug = .false. - - INTEGER(iprec) :: nSubstep = 4 - INTEGER(iprec) :: rcm_record - REAL(rprec) :: HighLatBD,LowLatBD - LOGICAL :: doLatStretch = .false. - LOGICAL :: doZeroLoss = .false. ! If true, absolutely no losses will be calculated - LOGICAL :: doFLCLoss = .false. !Use FLC losses - LOGICAL :: doNewCX = .true. !Use newer CX loss estimate - LOGICAL :: doSmoothDDV = .true. !Whether to smooth ij deriv of residual FTV - LOGICAL :: doSmoothBNDLOC = .true. !Whether to do bndloc smoothing - LOGICAL :: doPPSmooth = .true. !Try to smooth plasmapause - -! set this to true to tilt the dipole, must turn off corotation also - LOGICAL :: rcm_tilted = .false. -! set this to false to turn off the dynamic plasmasphere 07242020 sbao - LOGICAL :: dp_on = .true. - LOGICAL, PARAMETER :: use_plasmasphere = .true. - LOGICAL :: doAvg2MHD = .true. - LOGICAL :: doPPRefill = .false.!Whether to refill plasmasphere - LOGICAL :: doRelax = .true. !Whether to relax energy distribution - LOGICAL :: doQ0 = .true. !Whether to include implicit cold ions in tomhd moments - - INTEGER(iprec) :: ELOSSMETHOD - REAL(rprec) :: InitKp = 1.0, NowKp - LOGICAL :: doFLOut = .false. !Whether to output field lines (slow) - INTEGER(iprec) :: nSkipFL = 8 !Stride for outputting field lines - - LOGICAL :: doKapDef = .true. !Whether to do kappa by default - LOGICAL :: doRescaleDef = .true. !Whether to rescale D,P=>eta by default - REAL(rprec) :: staticR = 0.0 - REAL(rprec) :: LowLatMHD = 0.0 - REAL(rprec) :: rcm_pFloor = 0.0 !nPa - REAL(rprec) :: rcm_dFloor = 0.0 !#/cc - - REAL(rprec) :: epsPk = 1.0e-3 - - type RCMEllipse_T - !Ellipse parameters - real(rprec) :: xSun=12.5,xTail=-15.0,yDD=15.0 - logical :: isDynamic=.true. !Whether to update parameters - end type RCMEllipse_T - - type ChorusTauIn_T !electron lifetime for Chorus wave - integer(iprec) :: Nm=97, Nl=41, Nk=6 ,Ne=155 - real(rprec), ALLOCATABLE :: MLTi(:), Li(:), Kpi(:), Eki(:) - real(rprec), ALLOCATABLE :: taui(:,:,:,:) - end type ChorusTauIn_T - - type EWMTauIn_T !electron lifetime wave model input - logical :: useWM = .false. - type(ChorusTauIn_T) :: ChorusTauInput - end type EWMTauIn_T - - type(EWMTauIn_T) :: EWMTauInput - type(RCMEllipse_T) :: ellBdry - type(TimeSeries_T), private :: KpTS - - CONTAINS - - !Get RCM params from Kaiju-style XML file - subroutine RCM_MHD_Params_XML(iXML) - type(XML_Input_T), intent(in), optional :: iXML - character(len=strLen) :: inpXML,tmpStr - type(XML_Input_T) :: xmlInp - - if(present(iXML)) then - call iXML%GetFileStr(inpXML) - else - !Find input deck filename - call getIDeckStr(inpXML) - endif - - !Create new XML reader w/ RCM as root - xmlInp = New_XML_Input(trim(inpXML),'Kaiju/RCM',.true.) - - !Read various parameters - call xmlInp%Set_Val(L_write_rcmu_torcm,"output/toRCM",L_write_rcmu_torcm) - call xmlInp%Set_Val(L_write_rcmu,"output/toMHD",L_write_rcmu) - call xmlInp%Set_Val(L_write_vars_debug,"output/debug",L_write_vars_debug) - call xmlInp%Set_Val(nSkipFL,"output/nSkipFL",nSkipFL) - call xmlInp%Set_Val(doFLOut,"output/doFLOut",doFLOut) - call xmlInp%Set_Val(rcm_tilted,"tilt/isTilt",rcm_tilted) - - !Grid bounds - call xmlInp%Set_Val(HighLatBD,"grid/HiLat" ,75.0_rprec) - call xmlInp%Set_Val(LowLatBD ,"grid/LowLat",30.0_rprec) - call xmlInp%Set_Val(doLatStretch ,"grid/doLatStretch",.false.) - - !Ellipse parameters - call xmlInp%Set_Val(ellBdry%xSun ,"ellipse/xSun" ,ellBdry%xSun ) - call xmlInp%Set_Val(ellBdry%xTail,"ellipse/xTail",ellBdry%xTail) - call xmlInp%Set_Val(ellBdry%yDD ,"ellipse/yDD" ,ellBdry%yDD ) - call xmlInp%Set_Val(ellBdry%isDynamic,"ellipse/isDynamic" ,.true.) - - !Dynamic plasmaspehre parameters - call xmlInp%Set_Val(dp_on ,"plasmasphere/isDynamic",dp_on) - call xmlInp%Set_Val(InitKp ,"plasmasphere/initKp",InitKp) - call xmlInp%Set_Val(staticR ,'plasmasphere/staticR',staticR) - call xmlInp%Set_Val(doPPRefill ,'plasmasphere/doRefill',doPPRefill) - call xmlInp%Set_Val(DenPP0 ,'plasmasphere/DenPP0',DenPP0) - call xmlInp%Set_Val(doPPSmooth ,'plasmasphere/doPPSmooth',doPPSmooth) - - call SetKp0(InitKp) - NowKp = InitKp - - !Loss options - call xmlInp%Set_Val(doZeroLoss,"loss/doZeroLoss",doZeroLoss) - call xmlInp%Set_Val(doFLCLoss,"loss/doFLCLoss",doFLCLoss) - call xmlInp%Set_Val(tmpStr,"loss/eLossMethod","WM") - select case (tmpSTR) - case ("FDG") - ELOSSMETHOD = ELOSS_FDG - case ("SS") - ELOSSMETHOD = ELOSS_SS - case ("WM") - ELOSSMETHOD = ELOSS_WM - case default - stop "The electron loss type entered is not supported (Available options: WM, FDG, SS)." - end select - - call xmlInp%Set_Val(doNewCX ,"loss/doNewCX" ,doNewCX ) - call xmlInp%Set_Val(doRelax ,"loss/doRelax" ,doRelax ) - - !Tomhd parameters - call xmlInp%Set_Val(doAvg2MHD ,"tomhd/doAvg2MHD" ,doAvg2MHD ) - call xmlInp%Set_Val(doRelax ,"tomhd/doRelax" ,doRelax ) - call xmlInp%Set_Val(doQ0 ,"tomhd/doQ0" ,doQ0 ) - - - !Torcm parameters - call xmlInp%Set_Val(doKapDef ,"torcm/doKappa" ,doKapDef ) - call xmlInp%Set_Val(doRescaleDef ,"torcm/doRescale" ,doRescaleDef) - call xmlInp%Set_Val(doSmoothBNDLOC,"torcm/doSmoothBNDLOC" ,doSmoothBNDLOC) - - !Advance parameters - call xmlInp%Set_Val(nSubstep,"sim/nSubstep", nSubstep) - - !Advection - call xmlInp%Set_Val(doSmoothDDV,"advect/doSmoothDDV",doSmoothDDV) - call xmlInp%Set_Val(epsPk ,"advect/epsPk ",epsPk ) - - !Initialize Kp (and maybe other indices) time series - call xmlInp%Set_Val(KpTS%wID,"/Kaiju/Gamera/wind/tsfile","NONE") - call KpTS%initTS("Kp",doLoudO=.false.) - - !Get floors from gamera part of XML - ! call xmlInp%Set_Val(rcm_pFloor,"/Kaiju/gamera/floors/pFloor",rcm_pFloor) - ! call xmlInp%Set_Val(rcm_dFloor,"/Kaiju/gamera/floors/dFloor",rcm_dFloor) - - - end subroutine RCM_MHD_Params_XML - - !Update any indices in RCM that may be necessary - subroutine UpdateRCMIndices(time) - REAL(rprec), intent(in) :: time - INTEGER(iprec) :: n - REAL(rprec) :: t0,t,KpMax - - NowKp = InitKp - if (time<=0) return - - t0 = time - KpMax = 0.0 - !Loop over +/- 15min, find max Kp - do n=-1,+1 - t = t0 + 15.0*60.0*n - KpMax = max(KpMax,KpTS%evalAt(t)) - enddo - NowKp = KpMax - - end subroutine UpdateRCMIndices - -END MODULE rice_housekeeping_module diff --git a/src/rcm/precision.F90 b/src/rcm/precision.F90 deleted file mode 100644 index 31b8377e..00000000 --- a/src/rcm/precision.F90 +++ /dev/null @@ -1,8 +0,0 @@ -module rcm_precision - ! preventing rcm namespace pollution - use kdefs, ONLY: kip => ip, krp => rp - private kip,krp - ! use gamera precision - INTEGER, PARAMETER :: iprec = kip - INTEGER, PARAMETER :: rprec = krp -end module rcm_precision diff --git a/src/rcm/rcm_interfaces.F90 b/src/rcm/rcm_interfaces.F90 deleted file mode 100644 index 34b0e29a..00000000 --- a/src/rcm/rcm_interfaces.F90 +++ /dev/null @@ -1,229 +0,0 @@ -! File to hold RCM interfaces to other codes - - SUBROUTINE Grid_torcm (high_lat, low_lat, offseti, Re_external, Ri_external,doStretch) - - USE Rcm_mod_subs, imin_rcm=>imin - USE conversion_module, ONLY: x0,y0,z0 - USE rice_housekeeping_module, ONLY: rcm_tilted - USE constants, ONLY : RCMCorot - IMPLICIT NONE - - REAL(rprec), INTENT (IN) :: high_lat, low_lat, offseti, Re_external, Ri_external - LOGICAL, INTENT(IN) :: doStretch - - ! This routine will generate an ionospheric 2-D grid for the RCM - ! - ! INPUTS: - ! high_lat is starting latitude of grid (highest latitude, in degrees) - ! low_lat is ending latitude of grid (lowest latitude, in degrees) - ! offseti is offset location (NOTE: not used) - ! Re_external is Earth radius in meters - ! Ri_external is radius of Earth's ionospheric shell in meters - ! (hopefully Ri_external > Re_external) - ! - ! OUTPUTS/RESULTS: - ! an ascii file with grid arrays and parameters - ! - ! x0,y0,z0 = GSM locations of ionospheric grid points to be used for - ! tracing magnetic field lines later - ! [x0,y0,z0 arrays are assigned values in the module where - ! they are declared, not saved in a file] - ! 5/20/20 - removed assumption of jwarp=3, frt - - - INTEGER (iprec), PARAMETER :: imin = 1 - INTEGER(iprec) :: i, j - REAL(rprec) :: start, end, offset - REAL(rprec) :: glat (isize), teta (isize), phi (jsize) - real(rprec) :: x,dir - CHARACTER (LEN=15) :: grid_file='grid.dat' - - write(6,*)' setting up RCM grid' - - Re = Re_external / 1.0E+3 ! in km - Ri = Ri_external / 1.0E+3 ! in km - - i1 = isize + 1 - i2 = isize - 1 - j1 = jwrap - j2 = jsize - 1 - dlam = 1.0 / REAL(isize-1,rprec) - dpsi = (2.0*pi) / REAL(jsize-j1,rprec) - - - start = high_lat*DTR - end = low_lat*DTR - offset = offseti*DTR - - if(jsize==0)then - write(*,*)'grid_torcm:jsize =',jsize - stop - end if - - DO i = imin, isize - if (doStretch) then - glat(i) = start + (end-start) * Fun(REAL(i-imin)/REAL(isize-imin,rprec)) - else - !Do uniform spacing - glat(i) = start + (end-start) * REAL(i-imin)/REAL(isize-imin,rprec) - endif - teta(i) = pi/2 - glat(i) - END DO - - DO j = j1,j2 - phi(j) = (REAL(j,rprec)-REAL(j1,rprec))*pi /((REAL(jsize,rprec)-REAL(j1,rprec))/2.) - END DO - - DO j=1,j1-1 - phi(j) = phi(jsize-j1+j) - END DO - phi (jsize) = phi(j1) - - DO i = imin, isize - DO j = j1, j2 - colat(i,j) = ACOS(COS(teta(i))*COS(offset) + & - SIN(teta(i))*SIN(offset)*COS(phi(j))) - aloct(i,j) = ATAN2(SIN(teta(i))*SIN(phi(j)), & - SIN(teta(i))*COS(phi(j))*COS(offset)- & - COS(teta(i))*SIN(offset)) - IF (aloct(i,j).lt.0.0) aloct(i,j) = aloct(i,j)+2.0*pi - IF (aloct(i,j).gt.2.0*pi) aloct(i,j)=aloct(i,j)-2.0*pi - END DO - DO j=1,j1-1 - colat(i,j)=colat(i,jsize-j1+j) - aloct(i,j)=aloct(i,jsize-j1+j) - END DO - colat(i,jsize)=colat(i,j1) - aloct(i,jsize)=aloct(i,j1) - END DO - - DO j = 1, jsize - alpha (1,j) = (teta(2)-teta(1))/dlam - alpha (isize,j) = (teta(isize)-teta(isize-1))/dlam - DO i = imin+1,isize-1 - alpha(i,j) = 0.5*(teta(i+1)-teta(i-1))/dlam - END DO - do i=imin,isize - beta(i,j) = SIN(teta(i)) - END DO - END DO -! -! only add corotation in the non-tilted world -! all the other quantities have to be calculated - -!K: Notes for tilting -!vcorot = 0.0 (or RCMCorot=0) -!sini = two*COS(colat)/SQRT(one+three*COS(colat)**2) -!bir = two*(Re / Ri)**3*besu*COS(colat) - - if(rcm_tilted)then - vcorot = 0.0 - sini = 0.0 - bir = 0.0 - else - vcorot = -RCMCorot*(Re / Ri)*SIN(colat)**2 - sini = two*COS(colat)/SQRT(one+three*COS(colat)**2) - bir = two*(Re / Ri)**3*besu*COS(colat) - end if - - - RETURN - CONTAINS -! - FUNCTION Fun (x) - USE Rcm_mod_subs, ONLY : rprec - IMPLICIT NONE - REAL(rprec), INTENT (IN) :: x - REAL(rprec) :: Fun -! - REAL(rprec), PARAMETER :: a = 50.0, b=1.0, xm=0.001 -! - IF (x <= xm) THEN - Fun = (b-a)/xm*x**2/2.0+a*x - ELSE - Fun = ((a-b)*x**2/2.0+(b-a*xm)*x+xm/2.0*(a-b))/(1.0-xm) - END IF - Fun = Fun/(a+b)*2.0 - RETURN - END FUNCTION Fun - - END SUBROUTINE Grid_torcm - - SUBROUTINE Ionosphere_torcm(RM) - - ! This is where we transfer ionospheric - ! quantities onto the RCM ionospheric grid. - - USE Rcm_mod_subs - USE Ionosphere_exchange - USE rice_housekeeping_module - use rcm_mhd_interfaces - - IMPLICIT NONE - type(rcm_mhd_T),intent(inout) :: RM - - INTEGER (iprec) :: i,j - - ! Import ionosphere variables (Potential, Pedersen & Hall - ! conductances) from MIX coupler/solver and store results in variables - ! in ionosphere_intermediate module. - ! also transfers average pressure, density, flux tube volume, bmin, and xmin(x,y,z). - ! Note: The following calls MUST occur before this: - ! - intermediate_grid::setupIg() - - -! CALL ImportIonosphere - v (:,jwrap:jsize) = RM%pot (:, :) - do j=1,jwrap-1 - v (:, j) = v (:,jsize-jwrap+j) - end do - - qtplam (:,jwrap:jsize) = RM%sigmap (:, :) - do j=1,jwrap-1 - qtplam (:, j) = qtplam (:,jsize-jwrap+j) - end do - - qtped (:,jwrap:jsize) = RM%sigmap (:, :) - do j=1,jwrap-1 - qtped (:, j) = qtped (:,jsize-jwrap+j) - end do - - qthall (:,jwrap:jsize) = RM%sigmah (:, :) - do j=1,jwrap-1 - qthall (:, j) = qthall (:,jsize-jwrap+j) - end do - - ! Double conductances to account for two hemispheres - ! and correct for magnetic field inclination - - qtplam = qtplam * 2.0 * sinI - qtped = qtped * 2.0 / sinI - qthall = qthall * 2.0 - - -! writeout max and minvalues of ionosphere values - if(L_write_vars_debug)then - write(6,*)' Ionosphere torcm:' - write(6,*)' Max ionospheric potential =',maxval(v) - write(6,*)' Min ionospheric potential =',minval(v) - write(6,*)' Max ionospheric qtplam =',maxval(qtplam) - write(6,*)' Min ionospheric qtplam =',minval(qtplam) - write(6,*)' Max ionospheric qtped =',maxval(qtped) - write(6,*)' Min ionospheric qtped =',minval(qtped) - write(6,*)' Max ionospheric qthall =',maxval(qthall) - write(6,*)' Min ionospheric qthall =',minval(qthall) - end if - - ! In case RCM will solve for its own electric field, we - ! should set the boundary potential array. Here we assume - ! that RCM's high-latitude boundary has been already set - ! (call to torcm was made), and that the boundary is along - ! RCM grid points. If RCM uses potential from MIX, this - ! will go unused. - - DO j = 1, jsize - vbnd (j) = v (imin_j(j), j) - END DO - - RETURN - END SUBROUTINE Ionosphere_torcm diff --git a/src/rcm/rcm_mhd.F90 b/src/rcm/rcm_mhd.F90 deleted file mode 100644 index 9da5ce09..00000000 --- a/src/rcm/rcm_mhd.F90 +++ /dev/null @@ -1,279 +0,0 @@ -module rcm_mhd_mod - - use rcm_precision - use Rcm_mod_subs - use rcm_mhd_interfaces - use torcm_mod - use tomhd_mod - use rcm_mhd_io - use ionosphere_exchange, only : setupIon, tearDownIon - use rice_housekeeping_module - use rcm_timing_module - use files - use clocks - - implicit none - - contains - - subroutine rcm_mhd(mhdtime,mhdtimedt,RM,iflag,iXML) - ! version to couple to gamera - ! units are assumed to mks, except for distances which are in Re. - ! iflag = 0 - setup arrays, read in parameters (RCMINIT) - ! iflag = 1 - run rcm (RCMADVANCE) - ! iflag = 2 - Restart RCM (RCMWRITERESTART) - ! iflag = 10 - start from a cold start (RCMCOLDSTART) - ! iflag = -1 - stop, write out timing information (RCMWRITETIMING) - ! iflag = -2 - Write restart (icontrol = 31337) (RCMWRITERESTART) - ! iflag = -3 - Write H5 output (icontrol = 31338) (RCMWRITEOUTPUT) - - - ! 2/19 frt - !TODO: Remove unused variables - implicit none - type(XML_Input_T), intent(in), optional :: iXML - type(rcm_mhd_T),intent(inout) :: RM - real(rprec), intent(in) :: mhdtime,mhdtimedt - integer(iprec), intent(in) :: iflag - - integer(iprec) :: ierr !> Error code... - - real(rprec) :: itimei !> RCM(...) param: start time sbaotime - real(rprec) :: itimef !> RCM(...) param: end time - real(rprec) :: time0 = 0. ! coupling start time - real(rprec) :: ircm_dt - real(rprec) :: itimef_old = -1 - !using nSubstep from rice_housekeeping_module !> RCM(...) param: number of sub-time steps in program - real(rprec) :: t1, t2 !> Used for performance timing - - !> Model coupling variables - integer(iprec) :: exchangeNum = 0 - logical :: isFirstExchange - logical :: isLastExchange - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! bypass for now - time0 = 0. ! FIXME set for now - -! IsCoupledExternally = .TRUE. ! switch RCM to "coupled" mode before doing anything else - - !if (doRCMVerbose) write (*,'(TR1,A,L7)') 'Welcome to the RCM, IsCoupledExternally=', IsCoupledExternally - - ! setup rcm,time in integer format - itimei = mhdtime !floor(mhdtime-time0,iprec) - itimef = mhdtime + mhdtimedt !floor(mhdtime + mhdtimedt-time0,iprec) - ircm_dt = itimef - itimei - - ! finish up - if(iflag==RCMWRITETIMING)then - return ! do nothing - end if - - ! Write restart file - if (iflag==RCMWRITERESTART) then - CALL Rcm (itimei, itimef, nSubstep, icontrol=ICONWRITERESTART,stropt=RM%rcm_runid,nslcopt=RM%RCM_nRes) - return - endif - - ! Write output slice - if (iflag==RCMWRITEOUTPUT) then - CALL Rcm (itimei, itimef, nSubstep, icontrol=ICONWRITEOUTPUT,stropt=RM%rcm_runid,nslcopt=RM%RCM_nOut) - return - endif - - ! initialize - if( (iflag == RCMINIT) .or. (iflag == RCMRESTART) ) then !Do this for initialization and restart? - - !Read RCM/MHD params from XML - if(present(iXML)) then - CALL RCM_MHD_Params_XML(iXML) - else - CALL RCM_MHD_Params_XML - endif - - ! setup rcm - CALL Rcm (itimei, itimef, nSubstep, icontrol=0_iprec) - - call allocate_conversion_arrays (isize,jsize,kcsize) - - call Grid_torcm (HighLatBD,LowLatBD, 0.0_rprec, RM%planet_radius, RM%iono_radius,doLatStretch) ! set up RCM ionospheric grid here - ! Setup Ionosphere intermediate Grid by equating it to the RCM grid, without angular overlap: - call setupIon(RM) - - CALL Rcm (itimei, itimef, nSubstep, icontrol=1_iprec) - - ! icontrol of 2 also needs the input xml file - CALL Rcm (itimei, itimef, nSubstep, icontrol=2_iprec, iXML=iXML) - - if (iflag == RCMINIT) then - exchangeNum = 0 - endif - - ! restart - if (iflag == RCMRESTART) then - - !Read in HDF5 restart data - CALL Rcm (itimei, itimef, nSubstep, icontrol=ICONRESTART,stropt=RM%rcm_runid,nslcopt=RM%RCM_nRes) - exchangeNum = floor(itimef/(itimef-itimei)) ! Need to find another way of calculating exchangeNum - - !Testing call to tomhd here to fill in some moments - !call Tomhd (RM, ierr) - return - endif !restart - - return !We're done here - - end if !RCMINIT or RCMRESTART - - if(iflag==RCMADVANCE.or.iflag==RCMCOLDSTART) then ! run the rcm - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Determine exchange times... - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - isFirstExchange = (exchangeNum==0) - - if (doRCMVerbose) then -! write(*,*)'-----------rcm_mhd: rec=',rec - - write(6,*) 'itimei = ', itimei - write(6,*) 'exchangeNum = ', exchangeNum - WRITE (6,'(//)') - write (6,'(a,f12.4,a,f12.4,a,f12.4)') 'RCM: time=',itimei,' time0=',time0, ' Delta_t[s]=',ircm_dt - write (6,'(a,f12.4,a,f12.4)') 'RCM: _T_rcm[s] =', itimei, ' T_MHD=',mhdtime - WRITE (6,'(//)') - endif - - itimef_old = itimef - - - if (isFirstExchange) then ! Set RCM initial conditions on plasma: - call rcm (itimei, itimef, nSubstep, icontrol=3_iprec) - end if - - call UpdateRCMIndices(mhdtime) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Import data from MIX - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call cpu_time(t1) - if (doRCMVerbose) then - write(6,'(a,f12.4,a,i6)')'RCM: calling torcm with itimei=',itimei,' iflag=',iflag - call print_date_time(6_iprec) - endif - - call Tic("TORCM") - call torcm(RM,itimei,ierr,iflag) - call Toc("TORCM") - - if (ierr < 0 ) then - write(*,*) 'RCM: error in torcm ' - call BlackBoxRCM(RM) - endif - exchangeNum = exchangeNum + 1 - call cpu_time(t2) - - if (doRCMVerbose) write(6,'(a,g14.4,a)')'RCM: torcm cpu time= ',t2-t1,' seconds' - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Advance RCM - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call cpu_time(t1) - if (doRCMVerbose) then - write(6,'(a,f12.4,a,f12.4,a,f12.4,a)')'RCM: call rcm at itimei =',itimei,' to itimef =',itimef,' dt=',ircm_dt, ' sec' - call print_date_time(6_iprec) - endif - - ! now run the rcm - call Tic("xRCMx") - call rcm (itimei, itimef, nSubstep, icontrol=4_iprec,stropt=RM%rcm_runid,nslcopt=RM%RCM_nOut) - call Toc("xRCMx") -! rec = rec + 1 ! update record after rcm has run - - call cpu_time(t2) - if (doRCMVerbose) then - write(6,'(a,f12.4,a)')'RCM_MHD: rcm cpu time= ',t2-t1,' seconds' - call print_date_time(6_iprec) - endif - - ! Do not export data if this is both the first & last exchange. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Export data to MHD code - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (doRCMVerbose) write(6,'(a)')'RCM_MHD: calling tomhd ' - - call cpu_time(t1) - call Tic("TOMHD") - call Tomhd (RM, ierr) - call Toc("TOMHD") - - call cpu_time(t2) - if (doRCMVerbose) then - call print_date_time(6_iprec) - write(6,*)'RCM: tomhd cpu time= ',t2-t1,' seconds' - endif - - if (ierr < 0 ) then - write(6,*) 'RCM: error in tomhd ' - call BlackBoxRCM(RM) - endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - end if - - ! if (iflag==RCMRESTART)then ! stop - ! call rcm (itimei,itimef,nSubstep,icontrol=5_iprec) - ! call tearDownIon(RM) ! Matches setupIon() above - ! end if - - return - - end subroutine rcm_mhd - - !Write black box and die - subroutine BlackBoxRCM(RCMApp) - type(rcm_mhd_t), intent(inout) :: RCMApp - - !TODO: Can add some console output here - - !Output last words - RCMApp%rcm_runid = "CRASH" // trim(RCMApp%rcm_runid) - call initRCMIO(RCMApp,isResO=.false.) - call WriteRCM(RCMApp,0,0.0_rp,0.0_rp) - RCMApp%rcm_nOut = 0 - call rcm_mhd(0.0_rp,TINY,RCMApp,RCMWRITEOUTPUT) - - !Die with dignity - write(*,*) 'RCM Commiting suicide in 300s ...' - call sleep(300) !Sleep before blowing up - write(*,*) 'Goodbye cruel world' - stop !Self destruct - end subroutine BlackBoxRCM - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine print_date_time(LUN) - ! prints date and time, 6/08, frt (from rcm) - USE rcm_precision, ONLY : iprec - IMPLICIT NONE - CHARACTER(LEN=8) :: real_date - CHARACTER(LEN=10) ::real_time - INTEGER(iprec), INTENT(IN) :: LUN - - CALL Date_and_time (real_date, real_time) - WRITE (LUN,'(A11,A4,A1,A2,A1,A2, A8,A2,A1,A2,A1,A2)') & - ' Today is ', real_date(1:4), '/', & - real_date(5:6), '/', & - real_date(7:8), & - ' Time: ', real_time(1:2), ':', & - real_time(3:4), ':', & - real_time(5:6) - return - end subroutine print_date_time - -end module rcm_mhd_mod - diff --git a/src/rcm/rcm_mhd_interfaces.F90 b/src/rcm/rcm_mhd_interfaces.F90 deleted file mode 100644 index dc1b6815..00000000 --- a/src/rcm/rcm_mhd_interfaces.F90 +++ /dev/null @@ -1,124 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!> RCM Ionosphere grid definition, coupled model variables and helper -!! functions. -module rcm_mhd_interfaces - USE kdefs, ONLY : strLen - USE rcm_precision - USE Rcm_mod_subs, ONLY : isize, jsize, kcsize,jwrap, doRCMVerbose - USE rcmdefs, ONLY : RCMTOPCLOSED,RCMTOPNULL,RCMTOPOPEN - implicit none - integer(iprec), parameter :: RCMINIT=0,RCMADVANCE=1,RCMRESTART=2,RCMWRITERESTART=-2,RCMWRITEOUTPUT=-3,RCMWRITETIMING=-1 - integer(iprec), parameter :: RCMCOLDSTART=10 - logical :: doColdstart =.true. - - !Scaling parameters - real(rprec), parameter :: rcmPScl = 1.0e+9 !Convert Pa->nPa - real(rprec), parameter :: rcmNScl = 1.0e-6 !Convert #/m3 => #/cc - real(rprec), parameter :: rcmBScl = 1.0e+9 !Convert T to nT - - type rcm_mhd_T - real(rprec) :: llBC !MHD low-latitude boundary (radians) - real(rprec) :: dtCpl !Current coupling timescale (can change), [s] - integer(iprec) :: nLat_ion - integer(iprec) :: nLon_ion - real(rprec) :: planet_radius ! m - real(rprec) :: iono_radius ! m - real(rprec),allocatable :: gcolat(:) !> RCM Latitude grid points - real(rprec),allocatable :: glong(:) !> RCM Longitude grid points - real(rprec),allocatable :: pot(:,:) !> Potential; received from MHD [Volts] - real(rprec),allocatable :: eng_avg(:,:,:) !> Average Energy (sent to MIX Coupler/Solver) - real(rprec),allocatable :: flux(:,:,:) !> Energy Flux (sent to MIX Coupler/Solver) - real(rprec),allocatable :: nflx(:,:,:) !> Number Flux (sent to MIX Coupler/Solver) - real(rprec),allocatable :: fac(:,:) !> Total FAC density (sent to MIX Coupler/Solver)A - real(rprec),allocatable :: Pave(:,:) ! MHD supplied average pressure on Pa - real(rprec),allocatable :: Nave(:,:) ! MHD supplied average density in #/m^3 - real(rprec),allocatable :: N0 (:,:) ! MHD supplied average COLD density in #/m^3 - real(rprec),allocatable :: Vol(:,:) ! MHD supplied flux tube volume, -ve => open fieldline - [Re/T] - real(rprec),allocatable :: X_bmin(:,:,:)! MHD supplied location of Bmin surface, x,y,z in meters - real(rprec),allocatable :: Bmin(:,:) ! MHD supplied bmin strenght in T - real(rprec),allocatable :: beta_average(:,:) ! MHD field line averaged plasma beta (\int 2mu0P/B^3ds/B/\int ds/B) - integer(iprec),allocatable :: iopen(:,:) ! MHD supplied mask open/closed field line (-1: closed; 1: open; 0: else) - - real(rprec),allocatable :: Prcm(:,:) ! RCM supplied pressure in Pa - real(rprec),allocatable :: Nrcm(:,:) ! RCM supplied density in #/m^3 - real(rprec),allocatable :: Npsph(:,:) ! RCM supplied plasmasphere density in #/m^3 - real(rprec),allocatable :: sigmap(:,:) - real(rprec),allocatable :: sigmah(:,:) - real(rprec),allocatable :: oxyfrac(:,:) ! O+ fraction of MHD number density - real(rprec),allocatable :: Percm(:,:) ! RCM electron (only) pressure in Pa - !Conjugate mapping, lat/lon of conjugate point mapped - real(rprec),allocatable :: latc(:,:) - real(rprec),allocatable :: lonc(:,:) - !Empirical Ti/Te - real(rprec),allocatable :: TioTe0(:,:) - !Field line arc length [Re] - real(rprec),allocatable :: Lb(:,:) - !Alfven Bounce timescale [s] - real(rprec),allocatable :: Tb(:,:) - !Loss cone size [rad] - real(rprec),allocatable :: losscone(:,:) - !Curvature radius [Rp] - real(rprec),allocatable :: radcurv(:,:) - !Information about MHD ingestion - logical, allocatable :: toMHD(:,:) - !RCM confidence weight, [0,1] - real(rprec),allocatable :: wIMAG(:,:) - - integer(iprec),allocatable :: nTrc(:,:) !Number of steps on this flux-tube - - !Arrays to hold error in D,P => eta => D',P'. Storing X'/X - real(rprec), allocatable,dimension(:,:) :: errD,errP - - !Information to sync restarts w/ MHD - integer(iprec) :: rcm_nOut,rcm_nRes !Indices for output/restart - character(len=strLen) :: rcm_runid - - !Some simple quantities for keeping track of RCM energy channels - real(rprec) :: MaxAlam = 0.0 - - !Current pressure floor from MHD [nPa] - real(rprec) :: pFloor = 0.0 - - integer(iprec) :: NkT = kcsize !Current number of used channels - end type rcm_mhd_T - - contains - !Copy A (RCM/MHD-sized) into B (RCM-sized) and wrap (fill periodic) - subroutine EmbiggenWrap(rmA,rcmA) - REAL(rprec), intent(in) :: rmA (isize,jsize-jwrap+1) - REAL(rprec), intent(inout) :: rcmA(isize,jsize) - - INTEGER(iprec) :: j - - rcmA(:,jwrap:jsize) = rmA(:,:) - do j=1,jwrap-1 - rcmA(:,j) = rcmA(:,jsize-jwrap+j) - enddo - - end subroutine EmbiggenWrap - - !Same as above, but for int - subroutine EmbiggenWrapI(rmA,rcmA) - INTEGER(iprec), intent(in) :: rmA (isize,jsize-jwrap+1) - INTEGER(iprec), intent(inout) :: rcmA(isize,jsize) - - INTEGER(iprec) :: j - - rcmA(:,jwrap:jsize) = rmA(:,:) - do j=1,jwrap-1 - rcmA(:,j) = rcmA(:,jsize-jwrap+j) - enddo - - end subroutine EmbiggenWrapI - - !Copy rcmA (RCM-sized) into rmA (RCM/MHD-sized) - subroutine Unbiggen(rcmA,rmA) - REAL(rprec), intent(in) :: rcmA(isize,jsize) - REAL(rprec), intent(inout) :: rmA (isize,jsize-jwrap+1) - - rmA(:,:) = rcmA(:,jwrap:jsize) - - end subroutine Unbiggen - -end module rcm_mhd_interfaces diff --git a/src/rcm/rcm_mhd_io.F90 b/src/rcm/rcm_mhd_io.F90 deleted file mode 100644 index 7d165ee7..00000000 --- a/src/rcm/rcm_mhd_io.F90 +++ /dev/null @@ -1,496 +0,0 @@ -module rcm_mhd_io - use rcm_mhd_interfaces - use ioh5 - use xml_input - use rcm_mod_subs, ONLY : colat, aloct - use rice_housekeeping_module, ONLY : nSkipFL,doFLOut - use rcmdefs - - implicit none - - integer, parameter , private :: MAXRCMIOVAR = 80 - character(len=strLen), private :: h5File,RCMH5,FLH5 - real(rp), parameter , private :: IMGAMMA = 5.0/3.0 - - contains -!-------------- -!Kaiju RCM IO Routines - subroutine initRCMIO(RCMApp,isResO) - type(rcm_mhd_t), intent(inout) :: RCMApp - logical, intent(in), optional :: isResO - - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - real(rp), dimension(:,:), allocatable :: iLat,iLon - - integer :: i,j,NLat,NLon - real(rp) :: dLat,dLon,clMin,clMax - logical :: isRestart,fExist - - !Set isRestart - if (present(isResO)) then - isRestart = isResO - else - isRestart = .false. - endif - - !Create file names and nuke old stuff - h5File = trim(RCMApp%rcm_runid) // ".mhdrcm.h5" !MHD-RCM coupling data - FLH5 = trim(RCMApp%rcm_runid) // ".rcmfl.h5" !RCM field lines - RCMH5 = trim(RCMApp%rcm_runid) // ".rcm.h5" !RCM data - - fExist = CheckFile(h5File) - write(*,*) 'RCM outputting to ',trim(h5File) - - if (.not. isRestart) then - !Kill it all - call CheckAndKill(h5File) !For non-restart but file exists - call CheckAndKill(FLH5) - call CheckAndKill(RCMH5) - endif - - if (isRestart .and. fExist) then - !File already exists, don't need to init - return - endif - - !If we're still here then we need to do work - NLat = RCMApp%nLat_ion - NLon = RCMApp%nLon_ion - - clMin = RCMApp%gcolat(1) - clMax = RCMApp%gcolat(NLat) - dLat = (clMax-clMin)/NLat - dLon = (2*PI-0.0)/NLon - - allocate(iLat(NLat+1,NLon+1)) - allocate(iLon(NLat+1,NLon+1)) - - do j=1,NLon+1 - iLon(:,j) = 0.0 + (j-1)*dLon - enddo - dLat = (RCMApp%gcolat(2)-RCMApp%gcolat(1)) - iLat(1,:) = clMin-0.5*dLat - do i=2,NLat - dLat = (RCMApp%gcolat(i)-RCMApp%gcolat(i-1)) - iLat(i,:) = iLat(i-1,:) + dLat - enddo - !Replicate last dlat - iLat(NLat+1,:) = iLat(NLat,:) + dLat - - iLat = 90.0-iLat*180.0/PI !Turn colat into lat - iLon = iLon*180.0/PI - - !Reset IO chain - call ClearIO(IOVars) - - !Flipping lat/lon - call AddOutVar(IOVars,"X",iLon) - call AddOutVar(IOVars,"Y",iLat) - call AddOutVar(IOVars,"UnitsID","RCMMHD") - - call WriteVars(IOVars,.true.,h5File) - - end subroutine initRCMIO - - subroutine WriteRCM(RCMApp,nOut,MJD,time) - USE constants, ONLY: nt - USE rcm_mod_subs, ONLY:isize,jsize,jwrap - type(rcm_mhd_t), intent(inout) :: RCMApp - integer, intent(in) :: nOut - real(rp), intent(in) :: MJD,time - - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - character(len=strLen) :: gStr - - real(rp) :: rcm2Wolf - - integer :: NLat,NLon - - NLat = RCMApp%nLat_ion - NLon = RCMApp%nLon_ion - - rcm2Wolf = nt**(IMGAMMA-1.0) !Convert to Wolf units, RCM: Pa (Re/T)^gam => nPa (Re/nT)^gam - - - !Reset IO chain - call ClearIO(IOVars) - - call AddOutVar(IOVars,"N",RCMApp%Nrcm*rcmNScl,uStr="#/cc") - call AddOutVar(IOVars,"Npsph",RCMApp%Npsph*rcmNScl,uStr="#/cc") - call AddOutVar(IOVars,"P" ,RCMApp%Prcm *rcmPScl,uStr="nPa") - call AddOutVar(IOVars,"Pe",RCMApp%Percm*rcmPScl,uStr="nPa") - call AddOutVar(IOVars,"IOpen",RCMApp%iopen*1.0_rp) - call AddOutVar(IOVars,"bVol",RCMApp%Vol*nt,uStr="Re/nT") - call AddOutVar(IOVars,"pot",RCMApp%pot,uStr="V") - call AddOutVar(IOVars,"xMin",RCMApp%X_bmin(:,:,XDIR)/REarth,uStr="Re") - call AddOutVar(IOVars,"yMin",RCMApp%X_bmin(:,:,YDIR)/REarth,uStr="Re") - call AddOutVar(IOVars,"zMin",RCMApp%X_bmin(:,:,ZDIR)/REarth,uStr="Re") - call AddOutVar(IOVars,"bMin",RCMApp%Bmin,uStr="T") - call AddOutVar(IOVars,"S",rcm2Wolf*RCMApp%Prcm*(RCMApp%Vol**IMGAMMA),uStr="Wolf") - call AddOutVar(IOVars,"beta",RCMApp%beta_average) - - call AddOutVar(IOVars,"Pmhd",RCMApp%Pave*rcmPScl,uStr="nPa") - call AddOutVar(IOVars,"Nmhd",RCMApp%Nave*rcmNScl,uStr="#/cc") - call AddOutVar(IOVars,"Nmhd0",RCMApp%N0*rcmNScl,uStr="#/cc") - call AddOutVar(IOVars,"oxyfrac",RCMApp%oxyfrac,uStr="fraction") - - call AddOutVar(IOVars,"latc",RCMApp%latc*180.0/PI,uStr="deg") - call AddOutVar(IOVars,"lonc",RCMApp%lonc*180.0/PI,uStr="deg") - call AddOutVar(IOVars,"lossc",RCMApp%losscone*180.0/PI,uStr="deg") - call AddOutVar(IOVars,"Lb" ,RCMApp%Lb,uStr="Re") - call AddOutVar(IOVars,"Tb" ,RCMApp%Tb,uStr="s") - call AddOutVar(IOVars,"radcurv" ,RCMApp%radcurv,uStr="Re") - call AddOutVar(IOVars,"wIMAG" ,RCMApp%wIMAG,uStr="weight") - - call AddOutVar(IOVars,"eeavg" ,RCMApp%eng_avg(:,:,RCMELECTRON)*1.0e-3,uStr="keV") !ev->keV electrons - call AddOutVar(IOVars,"eeflux",RCMApp%flux (:,:,RCMELECTRON),uStr="ergs/cm2") - call AddOutVar(IOVars,"enflux",RCMApp%nflx (:,:,RCMELECTRON),uStr="#/cm2/s") - call AddOutVar(IOVars,"ieavg" ,RCMApp%eng_avg(:,:,RCMPROTON)*1.0e-3,uStr="keV") !ev->keV ions - call AddOutVar(IOVars,"ieflux",RCMApp%flux (:,:,RCMPROTON),uStr="ergs/cm2") - call AddOutVar(IOVars,"influx",RCMApp%nflx (:,:,RCMPROTON),uStr="#/cm2/s") - - call AddOutVar(IOVars,"birk",RCMApp%fac,uStr="uA/m2",dStr="RCM Vasyliunas FACs") - call AddOutVar(IOVars,"nTrc",RCMApp%nTrc*1.0_rp,uStr="steps") - - call AddOutVar(IOVars,"TioTe0",RCMApp%TioTe0,dStr="Empirical Ti/Te") - - call AddOutVar(IOVars,"toMHD",merge(1.0_rp,0.0_rp,RCMApp%toMHD)) - call AddOutVar(IOVars,"errD",RCMApp%errD,uStr="X'/X") - call AddOutVar(IOVars,"errP",RCMApp%errP,uStr="X'/X") - - call AddOutVar(IOVars,"colat",colat(:,jwrap:jsize)) - call AddOutVar(IOVars,"aloct",aloct(:,jwrap:jsize)) - !Add attributes - call AddOutVar(IOVars,"time",time) - call AddOutVar(IOVars,"MJD",MJD) - - write(gStr,'(A,I0)') "Step#", nOut - call WriteVars(IOVars,.true.,h5File,gStr) - - end subroutine WriteRCM - - subroutine RCMRestartInfo(RCMApp,xmlInp,t0,isRCMopt) - type(rcm_mhd_t) , intent(inout) :: RCMApp - type(XML_Input_T), intent(in) :: xmlInp - real(rp), intent(out) :: t0 - logical, intent(in), optional :: isRCMopt - - integer :: nRes - character(len=strLen) :: resID,nStr,inH5 - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - logical :: doSP,isRCM - - if (present(isRCMopt)) then - isRCM = isRCMopt - else - isRCM = .false. - endif - if (isRCM) then - call xmlInp%Set_Val(resID,"/Kaiju/rcm/restart/resID","msphere") - call xmlInp%Set_Val(nRes ,"/Kaiju/rcm/restart/nRes" ,-1) - else - call xmlInp%Set_Val(resID,"/Kaiju/gamera/restart/resID","msphere") - call xmlInp%Set_Val(nRes ,"/Kaiju/gamera/restart/nRes" ,-1) - endif - !Get number string - if (nRes == -1) then - nStr = "XXXXX" - else - write (nStr,'(I0.5)') nRes - endif - - inH5 = trim(resID) // ".RCM.Res." // trim(nStr) // ".h5" - - call CheckFileOrDie(inH5,"Restart file not found ...") - - !Get time data out of restart - doSP = .false. !Restarts are always double precision - - call ClearIO(IOVars) !Reset IO chain - call AddInVar(IOVars,"time",vTypeO=IOREAL ) - call ReadVars(IOVars,doSP,inH5) - t0 = GetIOReal(IOVars,"time") - - if (ioExist(inH5,"nRes")) then - call ClearIO(IOVars) !Reset IO chain - call AddInVar(IOVars,"nRes",vTypeO=IOINT ) - call ReadVars(IOVars,doSP,inH5) - nRes = GetIOInt(IOVars,"nRes") - RCMApp%rcm_nRes = nRes - endif - - RCMApp%rcm_nRes = nRes + 1 !Holds step for *NEXT* restart - end subroutine RCMRestartInfo - - !Write out field lines - subroutine WriteRCMFLs(RCMFLs,nOut,MJD,time,Ni,Nj) - USE ebtypes - integer, intent(in) :: nOut,Ni,Nj - real(rp), intent(in) :: MJD,time - type(magLine_T), intent(in), dimension(Ni,Nj) :: RCMFLs - - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - character(len=strLen) :: gStr,lnStr - integer :: i,j,n - - !Bail out if we're not doing this - if (.not. doFLOut) return - - !Create group and write base data - write(gStr,'(A,I0)') "Step#", nOut - call AddOutVar(IOVars,"time",time) - call AddOutVar(IOVars,"MJD",MJD) - - - call WriteVars(IOVars,.true.,FLH5,gStr) - call ClearIO(IOVars) - - !Now loop through and create subgroup for each line (w/ striding) - !TODO: Avoid the individual write for every line - n = 0 - do i=1,Ni,nSkipFL - do j=1,Nj-1,nSkipFL - write(lnStr,'(A,I0)') "Line#", n - if (RCMFLs(i,j)%isGood) then - call OutLine(RCMFLs(i,j),gStr,lnStr,IOVars) - n = n + 1 - endif - enddo - enddo - - end subroutine WriteRCMFLs - - !Write out individual line - subroutine OutLine(fL,gStr,lnStr,IOVars) - USE ebtypes - USE gdefs - type(magLine_T), intent(in) :: fL - character(len=strLen), intent(in) :: gStr,lnStr - type(IOVAR_T), intent(inout), dimension(MAXRCMIOVAR) :: IOVars - integer :: i,Np,Npp,n0 - - call ClearIO(IOVars) - Np = fL%Nm + fL%Np + 1 - if (Np<=nSkipFL) return - n0 = fL%Nm - - !Add scalar stuff - !Record seed point - call AddOutVar(IOVars,"x0",fL%x0(XDIR)) - call AddOutVar(IOVars,"y0",fL%x0(YDIR)) - call AddOutVar(IOVars,"z0",fL%x0(ZDIR)) - - !Do striding through field line points - Npp = size(fL%xyz(0:-n0:-nSkipFL,XDIR)) - - call AddOutVar(IOVars,"xyz",transpose(fL%xyz(0:-n0:-nSkipFL,XDIR:ZDIR))) - call AddOutVar(IOVars,"Np",Npp) - call AddOutVar(IOVars,"n0",1) !Seed point is now the first point - - !Only output some of the variables - call AddOutVar(IOVars,"B",fL%magB(0:-n0:-nSkipFL),uStr="nT") - call AddOutVar(IOVars,"D",fL%Gas (0:-n0:-nSkipFL,DEN ,BLK),uStr="#/cc") - call AddOutVar(IOVars,"P",fL%Gas (0:-n0:-nSkipFL,PRESSURE,BLK),uStr="nPa" ) - - !Write output chain - call WriteVars(IOVars,.true.,FLH5,gStr,lnStr) - call ClearIO(IOVars) - - end subroutine OutLine - - subroutine WriteMHD2IMagRestart(RCMApp,nRes,MJD,time) - type(rcm_mhd_t) , intent(inout) :: RCMApp - integer, intent(in) :: nRes - real(rp), intent(in) :: MJD, time - - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - character(len=strLen) :: ResF,lnResF - - write (ResF, '(A,A,I0.5,A)') trim(RCMApp%rcm_runid), ".mhd2imag.Res.", nRes, ".h5" - call CheckAndKill(ResF) - call ClearIO(IOVars) - - !Main attributes - call AddOutVar(IOVars,"nRes",nRes) - call AddOutVar(IOVars,"MJD" ,MJD) - call AddOutVar(IOVars,"time",time) - call AddOutVar(IOVars,"llBC",RCMApp%llBC) - call AddOutVar(IOVars,"dtCpl",RCMApp%dtCpl) - call AddOutVar(IOVars,"planet_radius",RCMApp%planet_radius) - call AddOutVar(IOVars,"iono_radius" ,RCMApp%iono_radius) - - !Variables - call AddOutVar(IOVars,"gcolat" ,RCMApp%gcolat ) - call AddOutVar(IOVars,"glong" ,RCMApp%glong ) - call AddOutVar(IOVars,"pot" ,RCMApp%pot ) - call AddOutVar(IOVars,"eng_avg" ,RCMApp%eng_avg ) - call AddOutVar(IOVars,"flux" ,RCMApp%flux ) - call AddOutVar(IOVars,"nflx" ,RCMApp%nflx ) - call AddOutVar(IOVars,"fac" ,RCMApp%fac ) - call AddOutVar(IOVars,"Pave" ,RCMApp%Pave ) - call AddOutVar(IOVars,"Nave" ,RCMApp%Nave ) - call AddOutVar(IOVars,"N0" ,RCMApp%N0 ) - call AddOutVar(IOVars,"Vol" ,RCMApp%Vol ) - call AddOutVar(IOVars,"X_bmin" ,RCMApp%X_bmin ) - call AddOutVar(IOVars,"Bmin" ,RCMApp%Bmin ) - call AddOutVar(IOVars,"beta_average",RCMApp%beta_average) - call AddOutVar(IOVars,"iopen" ,RCMApp%iopen*1.0_rp) - - call AddOutVar(IOVars,"Prcm" ,RCMApp%Prcm ) - call AddOutVar(IOVars,"Nrcm" ,RCMApp%Nrcm ) - call AddOutVar(IOVars,"Npsph" ,RCMApp%Npsph ) - call AddOutVar(IOVars,"sigmap" ,RCMApp%sigmap ) - call AddOutVar(IOVars,"sigmah" ,RCMApp%sigmah ) - call AddOutVar(IOVars,"oxyfrac" ,RCMApp%oxyfrac ) - call AddOutVar(IOVars,"Percm" ,RCMApp%Percm ) - call AddOutVar(IOVars,"latc" ,RCMApp%latc ) - call AddOutVar(IOVars,"lonc" ,RCMApp%lonc ) - call AddOutVar(IOVars,"TioTe0" ,RCMApp%TioTe0 ) - call AddOutVar(IOVars,"Lb" ,RCMApp%Lb ) - call AddOutVar(IOVars,"Tb" ,RCMApp%Tb ) - call AddOutVar(IOVars,"losscone",RCMApp%losscone) - call AddOutVar(IOVars,"radcurv" ,RCMApp%radcurv ) - call AddOutVar(IOVars,"wIMAG" ,RCMApp%wIMAG ) - - call AddOutVar(IOVars,"toMHD",merge(1.0_rp,0.0_rp,RCMApp%toMHD)) - - !Let er rip - call WriteVars(IOVars,.false.,ResF) - !Create link to latest restart - write (lnResF, '(A,A,A,A)') trim(RCMApp%rcm_runid), ".mhd2imag.Res.", "XXXXX", ".h5" - call MapSymLink(ResF,lnResF) - - end subroutine WriteMHD2IMagRestart - - subroutine ReadMHD2IMagRestart(RCMApp,nRes) - type(rcm_mhd_t) , intent(inout) :: RCMApp - integer, intent(in) :: nRes - - type(IOVAR_T), dimension(MAXRCMIOVAR) :: IOVars - character(len=strLen) :: ResF,nStr - logical :: fExist - real(rp), dimension(:,:), allocatable :: iopenX,toMHDX - integer :: NLat,NLon - - NLat = RCMApp%nLat_ion - NLon = RCMApp%nLon_ion - - !Get number string - if (nRes == -1) then - nStr = "XXXXX" - else - write (nStr,'(I0.5)') nRes - endif - - write (ResF, '(A,A,A,A)') trim(RCMApp%rcm_runid), ".mhd2imag.Res.", trim(nStr), ".h5" - write(*,*) 'Trying to read MHD2Imag restart from ', trim(ResF) - inquire(file=ResF,exist=fExist) - - if (.not. fExist) then - !Error out and leave - write(*,*) 'Unable to open MHD2Imag restart file, skipping ...' - return - else - write(*,*) 'Found MHD2Imag restart, reading ...' - endif - - !Read data if still here - call ClearIO(IOVars) - call AddInVar(IOVars,"gcolat" ) - call AddInVar(IOVars,"glong" ) - call AddInVar(IOVars,"pot" ) - call AddInVar(IOVars,"eng_avg" ) - call AddInVar(IOVars,"flux" ) - call AddInVar(IOVars,"nflx" ) - call AddInVar(IOVars,"fac" ) - call AddInVar(IOVars,"Pave" ) - call AddInVar(IOVars,"Nave" ) - call AddInVar(IOVars,"Vol" ) - call AddInVar(IOVars,"X_bmin" ) - call AddInVar(IOVars,"Bmin" ) - call AddInVar(IOVars,"beta_average") - call AddInVar(IOVars,"iopen" ) - call AddInVar(IOVars,"Prcm" ) - call AddInVar(IOVars,"Nrcm" ) - call AddInVar(IOVars,"Npsph" ) - call AddInVar(IOVars,"sigmap" ) - call AddInVar(IOVars,"sigmah" ) - call AddInVar(IOVars,"oxyfrac" ) - call AddInVar(IOVars,"Percm" ) - call AddInVar(IOVars,"latc" ) - call AddInVar(IOVars,"lonc" ) - call AddInVar(IOVars,"Lb" ) - call AddInVar(IOVars,"Tb" ) - call AddInVar(IOVars,"losscone" ) - call AddInVar(IOVars,"radcurv" ) - call AddInVar(IOVars,"wIMAG" ) - call AddInVar(IOVars,"toMHD" ) - !Get data - call ReadVars(IOVars,.false.,ResF) - - !Unpack data - !1D - !Disabling reading geometric stuff (use recalculated value) - !call IOArray1DFill(IOVars,"gcolat" ,RCMApp%gcolat ) - !call IOArray1DFill(IOVars,"glong" ,RCMApp%glong ) - - !2D - call IOArray2DFill(IOVars,"pot" ,RCMApp%pot ) - call IOArray2DFill(IOVars,"fac" ,RCMApp%fac ) - call IOArray2DFill(IOVars,"Pave" ,RCMApp%Pave ) - call IOArray2DFill(IOVars,"Nave" ,RCMApp%Nave ) - call IOArray2DFill(IOVars,"Vol" ,RCMApp%Vol ) - call IOArray2DFill(IOVars,"Bmin" ,RCMApp%Bmin ) - call IOArray2DFill(IOVars,"beta_average",RCMApp%beta_average) - call IOArray2DFill(IOVars,"Prcm" ,RCMApp%Prcm ) - call IOArray2DFill(IOVars,"Nrcm" ,RCMApp%Nrcm ) - call IOArray2DFill(IOVars,"Npsph" ,RCMApp%Npsph ) - call IOArray2DFill(IOVars,"sigmap" ,RCMApp%sigmap ) - call IOArray2DFill(IOVars,"sigmah" ,RCMApp%sigmah ) - call IOArray2DFill(IOVars,"oxyfrac" ,RCMApp%oxyfrac ) - call IOArray2DFill(IOVars,"Percm" ,RCMApp%Percm ) - call IOArray2DFill(IOVars,"latc" ,RCMApp%latc ) - call IOArray2DFill(IOVars,"lonc" ,RCMApp%lonc ) - call IOArray2DFill(IOVars,"Lb" ,RCMApp%Lb ) - call IOArray2DFill(IOVars,"Tb" ,RCMApp%Tb ) - call IOArray2DFill(IOVars,"losscone" ,RCMApp%losscone ) - call IOArray2DFill(IOVars,"radcurv" ,RCMApp%radcurv ) - call IOArray2DFill(IOVars,"wIMAG" ,RCMApp%wIMAG ) - - !3D - call IOArray3DFill(IOVars,"eng_avg" ,RCMApp%eng_avg ) - call IOArray3DFill(IOVars,"flux" ,RCMApp%flux ) - if(ioExist(ResF,"nflx")) then - call IOArray3DFill(IOVars,"nflx" ,RCMApp%nflx ) - endif - call IOArray3DFill(IOVars,"X_bmin" ,RCMApp%X_bmin ) - - !Weird data - allocate(iopenX(NLat,NLon)) - allocate(toMHDX(NLat,NLon)) - call IOArray2DFill(IOVars,"iopen",iopenX) - RCMApp%iopen = nint(iopenX) - call IOArray2DFill(IOVars,"toMHD",toMHDX) - RCMApp%toMHD = (toMHDX>0.5) - - !Handle some optional values - if (ioExist(ResF,"N0")) then - call ClearIO(IOVars) - call AddInVar(IOVars,"N0") - call ReadVars(IOVars,.false.,ResF) - call IOArray2DFill(IOVars,"N0",RCMApp%N0) - else - RCMApp%N0 = 0.0 - endif - - if (ioExist(ResF,"TioTe0")) then - call ClearIO(IOVars) - call AddInVar(IOVars,"TioTe0") - call ReadVars(IOVars,.false.,ResF) - call IOArray2DFill(IOVars,"TioTe0",RCMApp%TioTe0) - else - RCMApp%TioTe0 = tiote_RCM - endif - write(*,*) 'Finished reading MHD2Imag restart ...' - end subroutine ReadMHD2IMagRestart -end module rcm_mhd_io diff --git a/src/rcm/rcm_subs.F90 b/src/rcm/rcm_subs.F90 deleted file mode 100644 index 36269796..00000000 --- a/src/rcm/rcm_subs.F90 +++ /dev/null @@ -1,3537 +0,0 @@ -! - MODULE Rcm_mod_subs - use kdefs, ONLY : PI,Mp_cgs,Me_cgs,EarthM0g,eCharge,kev2erg - use conversion_module, ONLY : almdel - use rice_housekeeping_module, ONLY: use_plasmasphere, EWMTauInput - use constants, ONLY: nt, radius_earth_m - use rcmdefs - use rcm_precision - use clocks - use math - - IMPLICIT NONE - SAVE -! -! - INTEGER, PARAMETER :: LUN = 11 !, LUN_2 = 12, LUN_3 = 13 - -! Define a number of universal useful constants and parameters: -! Part 1 is machine-dependent parameters and they should not be changed -! under any circumstances. -! Part 2 is physical constants; these may require editing, in which case -! all the code must be recompiled. -! - REAL (RPREC), PARAMETER :: & -! Part 1: machine-specific and mathematical parameters - zero = 0.0_rprec, & - one = 1.0_rprec, & - two = 2.0_rprec, & - three = 3.0_rprec, & - four = 4.0_rprec, & - five = 5.0_rprec, & - six = 6.0_rprec, & - eight = 8.0_rprec, & - half = 0.5_rprec, & - qtr = 0.25_rprec,& - machine_eps1 = EPSILON (1.0_rprec), & - machine_eps2 = machine_eps1*10_rprec, & - ! machine_tiny = TINY (one),& - ! machine_huge = HUGE (one),& - pi_two = two * pi, & - pi_by_two = pi / two, & - rtd = 180.0_rprec/pi, & - dtr = pi/180.0_rprec, & - rth = 12.0_rprec / pi,& - htr = one / rth ,& -! -! Part 2: physical constants ! EDITING ALLOWED HERE - xmass(RCMNUMFLAV) = [Me_cgs*1.0e-3,Mp_cgs*1.0e-3], & - !xmass (2) = (/ 9.1E-31_rprec, & - ! 1.67E-27_rprec /), & - !besu = 3.0584E+4_rprec, & - besu = EarthM0g*1.0e+5, & !Use consistent moment, G => nT - signbe = one, & - romeca = zero, & - !charge_e = 1.6E-19_rprec, & - charge_e = eCharge, & !Take from kdefs - sgn (ksize) = one, & -! Part 3: conversion constants - ev2erg = kev2erg*1.0e-3, & ! conversion from eV to erg - m2cm = 100., & ! conversion from meter to centimeter - nT2T = nt, & ! conversion from nT to T - dfactor = nt/radius_earth_m ! conversion for density - INTEGER (iprec) :: ie_el = 1, ie_hd = 2 ! coding for e and proton -! -! -! Potential solver GMRESM tolerance: - REAL (rprec) :: tol_gmres - logical :: doRCMVerbose = .FALSE. - logical :: doRCMVerboseH5 = .FALSE. -! -! -! This is a definition of the label structure, for I/O: - TYPE :: label_def - INTEGER (iprec) :: intg (20) - REAL (rprec) :: real (20) - CHARACTER(LEN=80) :: char - END TYPE label_def - TYPE (label_def) :: label -! -! -! Define an ellipse: - TYPE :: ellipse_def - REAL(rprec) :: aa, bb, xx, yy - END TYPE ellipse_def -! - TYPE (ellipse_def) :: boundary (2) -! -! -! Grid info: - REAL (rprec) :: dlam, dpsi, Ri, Re, & - alpha (isize, jsize), & - beta (isize, jsize), & - colat (isize, jsize), & - aloct (isize, jsize), & - bir (isize, jsize), & - sini (isize, jsize), & - vcorot(isize, jsize), & - fac (isize, jsize) - INTEGER (iprec) :: i1, i2, iint, j1, j2, jint, imin, imin_j(jsize), ibnd_type -! -! - LOGICAL :: L_move_plasma_grid = .TRUE. - LOGICAL :: L_doOMPClaw = .TRUE. - LOGICAL :: L_doOMPprecip = .FALSE. - LOGICAL :: doVAvgInit = .TRUE. !Whether we need to initialize v_avg - - LOGICAL :: doNoBndFlow = .FALSE. - integer :: nNBFL = 2 -! -! -! Plasma on grid: - REAL (rprec) :: alamc (kcsize), etac (kcsize), fudgec (kcsize), & - eeta (isize,jsize,kcsize), eeta_cutoff, cmax, & - eeta_avg (isize,jsize,kcsize), deleeta(isize,jsize,kcsize), & - lossratep(isize,jsize,kcsize), lossmodel(isize,jsize,kcsize), Dpp(isize,jsize), & - last_veff(isize,jsize,ksize), & - last_ocbDist(isize,jsize) - - INTEGER (iprec) :: ikflavc (kcsize), i_advect, i_eta_bc, i_birk - LOGICAL :: L_dktime - INTEGER (iprec), PARAMETER :: irdk=18, inrgdk=13, isodk=2, iondk=2 - REAL (rprec) :: dktime (irdk, inrgdk, isodk, iondk), sunspot_number - REAL (rprec) :: dtAvg_v,dtMHD - LOGICAL :: advChannel(kcsize) = .true. !Which channels to advance - - logical :: kill_fudge -! -! -! Magnetic field: - REAL (rprec) :: xmin (isize,jsize), ymin (isize,jsize), zmin (isize,jsize), & - bmin (isize,jsize), vm (isize,jsize), & - rmin (isize,jsize), pmin(isize,jsize),& - x1 (isize,jsize), x2 (isize,jsize), & - y1 (isize,jsize), y2 (isize,jsize), & - b1 (isize,jsize), b2 (isize,jsize), & - vm1(isize,jsize), vm2(isize,jsize), & - bndloc (jsize),radcurv(isize,jsize),losscone(isize,jsize) - INTEGER (iprec), ALLOCATABLE :: ibtime (:) - REAL (rprec) :: fstoff, fclps, fdst, fmeb, ftilt - INTEGER (iprec) :: itype_bf - ! itype_bf = 1 -- read time sequence from input files and interpolate in time - ! itype_bf = 2 -- read single B-field configuration from input files - ! itype_bf = 3 -- expect that an external program will assign B-field arrays - ! including pmin and rmin, so do nothing. -! -! -! Ionospheric quantities: - REAL (rprec) :: qtped (isize,jsize), pedpsi (isize,jsize), & - qtplam(isize,jsize), pedlam (isize,jsize), & - qthall(isize,jsize), hall (isize,jsize), & - ss (jsize), & - pwe (isize,jsize), pwn (isize,jsize), & - hwe (isize,jsize), hwn (isize,jsize), & - sw (jsize), & - eflux (isize,jsize,iesize), eavg (isize,jsize,iesize), nflux (isize,jsize,iesize), & - efluxk (isize,jsize,kcsize,iesize), eavgk (isize,jsize,kcsize,iesize), nfluxk (isize,jsize,kcsize,iesize) - INTEGER (iprec) :: icond, nsmthi, nsmthj, iwind - LOGICAL :: ifloor, icorrect -! -! -! Magnetospheric quantities: - REAL (rprec) :: v (isize,jsize), vpar (isize,jsize), vbnd (jsize), & - birk (isize,jsize), pvgamma (isize,jsize,iesize), & - pressrcm (isize,jsize), & - v_avg (isize,jsize), birk_avg (isize,jsize), & - densrcm(isize,jsize),denspsph(isize,jsize) - INTEGER (iprec) :: ipcp_type, ipot -! -! Input PCP drop and its current value: - INTEGER (iprec), ALLOCATABLE :: ivtime (:) - REAL (rprec), ALLOCATABLE :: vinput (:), vinput_phase(:) - REAL (rprec) :: vdrop, vdrop_phase -! -! - - INCLUDE 'rcmdir.h' - -! Logical :: IsCoupledExternally = .false. ! flag to determine if RCM is standalone or not - - ! Variables for internal RCM timing: - INTEGER(iprec) :: timer_start(10) = 0, timer_stop(10) = 0, count_rate - REAL (rprec) :: timer_values (10)=0.0_rprec - -! - INTERFACE Gntrp - MODULE PROCEDURE Gntrp_2d_ang - END INTERFACE - - INTERFACE Interp - MODULE PROCEDURE Interp_1d, Interp_2d, Interp_2d_of3d - END INTERFACE - - INTERFACE Bjmod - MODULE PROCEDURE Bjmod_int, Bjmod_real - END INTERFACE - - INTERFACE Circle - MODULE PROCEDURE Circle_1d, Circle_2d - END INTERFACE -! -! -! - CONTAINS -! -! -! -! SUBROUTINE Comput (jtime, dt ) - SUBROUTINE Comput (dtCpl) - IMPLICIT NONE -! INTEGER (iprec), INTENT (IN) :: jtime -! REAL (rprec), INTENT (IN) :: dt -! - REAL (rprec), INTENT(IN) :: dtCpl - INTEGER (iprec) :: j - REAL (rprec) :: a(3), b(3), dx(3), dy(3), deqdt -! -! - - CALL Tic("GET_JBIRK") - CALL Get_jbirk - if (doRCMVerbose) then - write(6,*)'RCM: finish getting jbirk' - endif - CALL Toc("GET_JBIRK") - - CALL Tic("PRECIP") - CALL kdiffPrecip(dtCpl) - !CALL diffusePrecip (dtCpl) - !Call diffusePrecipMaxwellian () - if (doRCMVerbose) then - write(6,*)'RCM: finish getting diffuse precipitation' - endif - CALL Toc("PRECIP") - -! IF (ibnd_type == 4) THEN -! DO NOTHING, VBND IS ALREADY SET -! DO j = 1, jsize -! v (1:imin_j(j)-1,j) = vbnd (j) -! END DO -! ELSE -! STOP 'COMPUT: ibnd_type not implemented' -! END IF -! -! - RETURN - END SUBROUTINE Comput -! -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - SUBROUTINE Get_jbirk ( ) - IMPLICIT NONE -!__________________________________________________________________________ -! -! Program written by: r.w. spiro -! last update: -! 04-05-88 -! 01-29-96 frt - added ain,min_j arr -! Algorithm by: r.a. wolf -! -! This subroutine computes birk(i,j) given inner edge -! locations -! modified 04-05-88 to include effects of gradients in eta. -! see raw document re including eeta in computation of jbirk -! dated feb 6, 1988. -! birk is current density (2 hemispheres) in units of -! microamp/m**2 -! -! birk(i,j) here is the field-aligned current density per -! unit of ionospheric area, so that it already includes -! the factor sin(I); this is J_parallel*sin(I) in the RHS -! of the Vasyliunas equation. -! -! Issues with non-integer boundary (Stanislav's notes): -! for BIRK from inner edge segments, this is not an issue -! (except that if a segment is entirely outside the bndry, -! then we don't compute its contribution); of course, we -! have to care about this somewhere else where motion of -! test particles is computed. For BIRK from gradients of -! EETA, -! removed edges 3/19 frt -! -!______________________________________________________________________________ -! - REAL (rprec), PARAMETER :: cf1 = one / pi_two, & - cf2 = - (three/four)*( (two / pi) - half) -! - INTEGER (iprec) :: i, j, k, kc, klbeg, klend, kl, klnext, & - ibmin, ibmax, jbmin, jbmax, jb1, jb2, & - ig, jj, jindex, ib1, ib2 - REAL (rprec) :: detadi(isize,jsize), detadj(isize,jsize), & - dvmdi(isize,jsize), dvmdj(isize,jsize), dbirk, & - vmkl, vmnext, sum, b1, b2, x, y, el, umax, umin, ss, & - z, dg1, dg2, dg3, qmin, qmax, qn, qx, & - denom, a1, a2, bjm, range, bim, gkl (5000) - LOGICAL, dimension(1:isize,1:jsize) :: isOpen - -! -! - birk (:,:) = zero -! -! -! Compute J_parallel due to continuous channel: -! - !Replacing gradient w/ slope-limited gradient used in advection - isOpen = (vm < 0) - call Grad_IJ(vm,isOpen,dvmdi,dvmdj) - - do kc=1,kcsize - !Using new gradient, Grad_IJ is internally threaded so don't call it from OMP loop - call Grad_IJ(eeta(:,:,kc),isOpen,detadi,detadj) - - !NOTE: Not great to have OMP inside k loop but easier than writing an unthreaded Grad_IJ - !$OMP PARALLEL DO & - !$OMP schedule(dynamic) & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE(i,j,dbirk) & - !$OMP SHARED(kc,j1,j2,i2,alamc,dlam,dpsi,Ri) & - !$OMP SHARED(alpha,beta,detadi,detadj,dvmdj,dvmdi,eeta,birk,isOpen) - DO j = j1, j2 - !Calculate Vasyliunas FAC wherever possible, even using MHD buffer cells - DO i = 1,i2 - if (isOpen(i,j)) CYCLE - - dbirk = charge_e * signbe * ABS(alamc(kc)) * & - (detadj(i,j) * dvmdi(i,j) - detadi(i,j)*dvmdj(i,j)) / & - (alpha(i,j)*beta(i,j)*dlam*dpsi*Ri**2) - birk (i, j) = birk (i, j) + dbirk - ENDDO !i - ENDDO !j - - enddo - - CALL Circle (birk) - - END SUBROUTINE Get_jbirk -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - SUBROUTINE Get_jbirk2 ( ) - IMPLICIT NONE -!__________________________________________________________________________ -! -! Program written by: r.w. spiro -! last update: -! 04-05-88 -! 01-29-96 frt - added ain,min_j arr -! 11-14-02 frt uses a new version on the grid-based scheme -! Algorithm by: r.a. wolf -! -! This subroutine computes birk(i,j) given inner edge -! locations -! modified 04-05-88 to include effects of gradients in eta. -! see raw document re including eeta in computation of jbirk -! dated feb 6, 1988. -! birk is current density (2 hemispheres) in units of -! microamp/m**2 -! -! birk(i,j) here is the field-aligned current density per -! unit of ionospheric area, so that it already includes -! the factor sin(I); this is J_parallel*sin(I) in the RHS -! of the Vasyliunas equation. -! -! Issues with non-integer boundary (Stanislav's notes): -! for BIRK from inner edge segments, this is not an issue -! (except that if a segment is entirely outside the bndry, -! then we don't compute its contribution); of course, we -! have to care about this somewhere else where motion of -! test particles is computed. For BIRK from gradients of -! EETA, -! -! This version uses a new way to compute jbirk from the cts channel - frt -! -!______________________________________________________________________________ -! - REAL (rprec), PARAMETER :: cf1 = one / pi_two, & - cf2 = - (three/four)*( (two / pi) - half) -! - INTEGER (iprec) :: i, j, k, kc, klbeg, klend, kl, klnext, & - ibmin, ibmax, jbmin, jbmax, jb1, jb2, & - ig, jj, jindex, ib1, ib2 - REAL (rprec) :: detadi(isize,jsize), detadj(isize,jsize), & - dvmdi(isize,jsize), dvmdj(isize,jsize), dbirk, & - vmkl, vmnext, sum, b1, b2, x, y, el, umax, umin, ss, & - z, dg1, dg2, dg3, qmin, qmax, qn, qx, & - denom, a1, a2, bjm, range, bim, gkl (5000) - REAL (rprec) :: eeta2(isize,jsize,ksize),vm2(isize,jsize) -! -! - birk (:,:) = zero -! -! -! Compute J_parallel due to continuous channel: -! -! define new temporary work arrays eeta2 and vm2 - eeta2 = eeta - vm2 = vm - DO j=1,jsize - DO i=1,imin_j(j)-1 - DO k=1,kcsize - eeta2(i,j,k) = eeta(imin_j(j),j,k) - END DO - vm2(i,j) = vm(imin_j(j),j) - END DO - END DO - -! 1 2 3 -! i-1,j+1------i,j+1------i+1,j+1 -! | | | -! | | | -! | | | -! 4 | 5 -! i-1,j--------i,j--------i+1,j -! | | | -! | | | -! | | | -! 6 7 8 -! i-1,j-1------i,j-1------+1,j-1 -! the basic equation is -! dbirk is proportional to -! (eta_1*(vm_2-vm_1)+eta_2*(vm_3-vm_1)+eta_3*(vm_5-vm_2)+eta_4*(vm_1-vm_6) -! eta_5*(vm_8-vm_3)+eta_6*(vm_4-vm_7)+eta_7*(vm_6-vm_8)+eta_8*(vm_7-vm_5))/8 - DO kc = 1, kcsize -! - DO j = j1, j2 - DO i = imin_j(j)+1, i2 - - dbirk =(eeta2(i-1,j+1,kc)*(vm2(i ,j+1)-vm2(i-1,j )) + & - eeta2(i ,j+1,kc)*(vm2(i+1,j+1)-vm2(i-1,j+1)) + & - eeta2(i+1,j+1,kc)*(vm2(i+1,j )-vm2(i ,j+1)) + & - eeta2(i-1,j ,kc)*(vm2(i-1,j+1)-vm2(i-1,j-1)) + & - eeta2(i+1,j ,kc)*(vm2(i+1,j-1)-vm2(i+1,j+1)) + & - eeta2(i-1,j-1,kc)*(vm2(i-1,j )-vm2(i ,j-1)) + & - eeta2(i ,j-1,kc)*(vm2(i-1,j-1)-vm2(i+1,j-1)) + & - eeta2(i+1,j-1,kc)*(vm2(i ,j-1)-vm2(i+1,j ))) /8. - - dbirk = charge_e * signbe * ABS(alamc(kc)) * dbirk/ & - (alpha(i,j)*beta(i,j)*dlam*dpsi*Ri**2) - birk (i, j) = birk (i, j) + dbirk - END DO - END DO - END DO -! -!print*,'zeroing birk' - CALL Circle (birk) -! - RETURN - END SUBROUTINE Get_jbirk2 -! -! -!************************************************************************* -! -! - SUBROUTINE diffusePrecip (dtCpl) - IMPLICIT NONE - -!-------------------------------------------------------------------------- -! sbao 05/2021 -! This subroutine calculates diffuse electron precipitation using deleeta -! The equation of the differential flux is adapted from M. Gkioulidou et al (doi:10.1029/2012JA018032) - REAL (rprec), INTENT(IN) :: dtCpl - INTEGER (iprec) :: i, j, ie, iedim_local, kc, klow - REAL (rprec) :: en, delEn, Jk, sum1 (iesize), sum2 (iesize) - LOGICAL, dimension(1:isize,1:jsize) :: isOpen - REAL (rprec) :: JkConst - - - !Try to do calculation everywhere possible including MHD buffer region - isOpen = (vm < 0) - - !Set lowest RC channel - if (use_plasmasphere) then - klow = 2 - else - klow = 1 - endif - - iedim_local = 2 ! # of species, electron and proton -! - eavg (:,:,:) = zero - eflux (:,:,:) = zero - - loop_j: DO j = j1, j2 - !loop_i: DO i = imin_j(j), isize - loop_i: DO i = 1, isize - if (isOpen(i,j)) CYCLE -! Now for each grid point, consider all species -! present at that grid point, and compute sum1 and -! sum2 for positive and negative particles separately: - -! For each grid point, clear sum1 and sum2: -! - sum1 (1:iedim_local) = zero - sum2 (1:iedim_local) = zero -! - GRID_BASED: DO kc = klow, kcsize - IF (alamc (kc) < zero) THEN - ie = 1 ! electron - ELSE - ie = 2 ! proton - END IF - en = ABS(alamc(kc))*vm(i,j) ! channel energy in eV - delEn = ABS(almdel(kc))*vm(i,j) ! channel width in eV - JkConst = 1./(SQRT(8.*xmass(ie))*pi)*SQRT(charge_e)*nt/m2cm**2/radius_earth_m ! Constant for Jk - !Jk = JkConst*SQRT(ABS(alamc(kc)))* deleeta(i,j,kc)/dtCpl*vm(i,j)/almdel(kc) ! differential energy flux in 1/(eV cm^2 s sr) - Jk = JkConst*SQRT(ABS(alamc(kc)))* 1./3.*eeta(i,j,kc)/dtCpl*vm(i,j)/almdel(kc) - sum1(ie) = sum1(ie) + en*Jk*delEn ! in eV/(cm^2 s sr) - sum2(ie) = sum2(ie) + Jk*delEn ! in 1/(cm^2 s sr) - END DO GRID_BASED - - DO ie = 1, iedim_local -! - IF (sum2 (ie) > 10.*machine_tiny) THEN ! zero sbao 07/2019 -! -! compute thermal electron current, field-aligned -! potential drop, electron energy flux, -! and average electron energy at (i,j): -! - eflux(i,j,ie) = ev2erg*pi*sum1(ie) ! energy flux in erg/(cm^2 s), pi comes from the vel. space integral - eavg(i,j,ie) = sum1(ie)/sum2(ie) ! averge energy in eV - - ELSE -! we want eflux=0 and eavg=0 for no precipitation. - eflux (i, j, ie) = zero - eavg (i, j, ie) = zero -! - END IF - - END DO - - END DO loop_i - END DO loop_j - - CALL Circle (eflux (:, :, ie_el)) - CALL Circle (eavg (:, :, ie_el)) - CALL Circle (eflux (:, :, ie_hd)) - CALL Circle (eavg (:, :, ie_hd)) - - END SUBROUTINE diffusePrecip - - ! K: A brute force diffuse precipitation. - ! Particles lost through scattering should precipitate - subroutine kdiffPrecip(dtCpl) - IMPLICIT NONE - REAL (rprec), INTENT(IN) :: dtCpl - LOGICAL, dimension(1:isize,1:jsize) :: isOpen - real(rprec), dimension(RCMNUMFLAV) :: nflx,eflx - integer(iprec) :: klow,i,j,k,ie - real(rprec) :: dn - real(rprec) :: kin - !Try to do calculation everywhere possible including MHD buffer region - isOpen = (vm < 0) - !Set lowest RC channel - if (use_plasmasphere) then - klow = 2 - else - klow = 1 - endif - eavg (:,:,:) = 0.0 - eflux (:,:,:) = 0.0 - nflux (:,:,:) = 0.0 - do j=1,jsize - do i=1,isize - if (isOpen(i,j)) CYCLE - nflx = 0.0 - eflx = 0.0 - do k=klow,kcsize - ! only accumulate diff for keV below 30 keV. - kin = abs(alamc(k)*vm(i,j))*1.0e-3 !Energy [keV] - IF (alamc (k) < -TINY .and. kin<=30.0) THEN - ie = RCMELECTRON - else if (alamc (k) > +TINY) then - ie = RCMPROTON - else - cycle - endif - !Now accumulate, 0.5 for single hemisphere, see detailed deriviation of the diffuse precipitation on kaiju wiki - dn = 0.5*deleeta(i,j,k)*abs(bir(i,j)/sini(i,j))*nT2T/(m2cm**2)/dtCpl ! #/cm^2/s - nflx(ie) = nflx(ie) + dn !Num flux, #/cm2/s - eflx(ie) = eflx(ie) + dn*ABS(alamc(k))*vm(i,j) !Energy flux, eV/cm^2/s - enddo - eflux(i,j,:) = eflx*ev2erg ! energy flux in erg/(cm^2 s) - eavg (i,j,:) = eflx/nflx ! Average energy in eV - nflux(i,j,:) = nflx ! Num flux in #/cm^2/s - - DO ie = 1, RCMNUMFLAV - IF (nflx(ie) > TINY) THEN - ! The ratio of eavg is only meaningful when nflx is meaningful. - ! Note in REMIX, a higher floor will be applied toward the final precipitation. - eavg (i,j,ie) = eflx(ie)/nflx(ie) ! Average energy in eV - ELSE -! we want eflux=0 and eavg=0 for no precipitation. - eflux (i, j, ie) = zero - eavg (i, j, ie) = zero - nflux (i, j, ie) = zero -! - END IF - END DO - - enddo - enddo - - CALL Circle (nflux (:, :, ie_el)) - CALL Circle (eflux (:, :, ie_el)) - CALL Circle (eavg (:, :, ie_el)) - CALL Circle (nflux (:, :, ie_hd)) - CALL Circle (eflux (:, :, ie_hd)) - CALL Circle (eavg (:, :, ie_hd)) - - where(eflux<0.01 .or. eavg<0.01) - !Do both or neither - eavg = 0.0 - eflux = 0.0 - nflux = 0.0 - end where - end subroutine kdiffPrecip - - - SUBROUTINE diffusePrecipChannel () - IMPLICIT NONE - -!-------------------------------------------------------------------------- -! sbao 05/2021 -! This subroutine calculates diffuse electron precipitation using deleeta for each energy channel -! The equation of the differential flux is adapted M. Gkioulidou et al (doi:10.1029/2012JA018032) - - - END SUBROUTINE diffusePrecipChannel - - - SUBROUTINE diffusePrecipMaxwellian () - IMPLICIT NONE - -!-------------------------------------------------------------------------- -! sbao 01/2021 -! This subroutine calculates diffuse electron precipitation using Maxwellian distribuiton, adapted from Get_vparallel - - INTEGER (iprec) :: i, j, ie, iedim_local, kc - REAL (rprec) :: en, ekt, therm, sum1 (iesize), sum2 (iesize) - LOGICAL, dimension(1:isize,1:jsize) :: isOpen - - !Try to do calculation everywhere possible including MHD buffer region - isOpen = (vm < 0) - - iedim_local = 2 -! - vpar (:,:) = zero - eavg (:,:,:) = zero - eflux (:,:,:) = zero - - - !$OMP PARALLEL DO if (L_doOMPprecip) & - !$OMP schedule(dynamic) & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE(i,j,kc,ie,sum1,sum2) & - !$OMP PRIVATE(en,ekt,therm) & - !$OMP SHARED(j1,j2,iedim_local,imin_j,alamc,eeta) & - !$OMP SHARED(vpar,vm,fudgec,birk,eflux,eavg,isOpen) - - loop_j: DO j = j1, j2 - !loop_i: DO i = imin_j(j), isize - loop_i: DO i = 1, isize - if (isOpen(i,j)) CYCLE -! -! For each grid point, clear sum1 and sum2: -! - sum1 (1:iedim_local) = zero - sum2 (1:iedim_local) = zero -! -! -! Now for each grid point, consider all species -! present at that grid point, and compute sum1 and -! sum2 for positive and negative particles separately: -! - GRID_BASED: DO kc = 1, kcsize - ! IF ( ABS(alamc(kc))*vm(i,j) > 500.0_rprec) THEN - IF (alamc (kc) < zero) THEN - ie = 1 - ELSE - ie = 2 -! STOP 'BALGN4: ie is 2' - END IF - sum1(ie) = sum1(ie) + eeta(i,j,kc)*fudgec(kc) - sum2(ie) = sum2(ie) + eeta(i,j,kc)*fudgec(kc)*ABS(alamc(kc)) - !END IF - END DO GRID_BASED -! -! For positive and negative particles separately, -! compute precipitating number flux, average energy, -! and parallel potential drop: -! - DO ie = 1, iedim_local -! - IF (sum1 (ie) > 10.*machine_tiny) THEN ! zero sbao 07/2019 -! -! compute thermal electron current, field-aligned -! potential drop, electron energy flux, -! and average electron energy at (i,j): -! - en = sum1 (ie) * vm (i, j)**1.5 / 6.38E+21 - ekt = (two/three) * sum2 (ie) * vm (i,j) / sum1 (ie) - therm = 0.02675 * en * SQRT(ekt*xmass(1)/xmass(ie)) -! - IF (therm < 1.E-30) therm = zero - - eflux(i,j,ie) = 0.002 * therm * ekt - eavg(i,j,ie) = two*ekt - ! sbao 6/19 detect Nan - if (ISNAN(eflux(i,j,ie)))then - eflux(i,j,ie) = 0.0 - eavg(i,j,ie) = 0.0 - end if - - ELSE -! -! Case fudge=0: we want eflux=0 and eavg=0 for no precipitation. -! - eflux (i, j, ie) = zero - eavg (i, j, ie) = zero -! - END IF - ! corrections to eavg at eflux(i,j) == 0.0 sbao 07/2019 - ! == does not work well with real number, use lt threshold instead. ldong 04/2020 - if ( (eflux(i,j,ie) .lt. 0.01) .or. (eavg(i,j,ie) .lt. 0.01) ) then - !Do both or neither - eavg(i,j,ie) = 0.0 - eflux(i,j,ie) = 0.0 - endif - - ! IF (eflux(i,j,ie) .lt. 0.01) eavg(i,j,ie) = 0.0 - ! IF (eavg(i,j,ie) .lt. 0.01) eflux(i,j,ie) = 0.0 -! - END DO -! - END DO loop_i - END DO loop_j -! -! - CALL Circle (eflux (:, :, ie_el)) - CALL Circle (eavg (:, :, ie_el)) - CALL Circle (eflux (:, :, ie_hd)) - CALL Circle (eavg (:, :, ie_hd)) -! - RETURN - END SUBROUTINE diffusePrecipMaxwellian -! -! -!============================================================================== -! -! - SUBROUTINE Get_vparallel () - IMPLICIT NONE -!______________________________________________________________________________ -! last update: -! 05-05-87 by:rws -! 02-10-96 frt - added arrays ain,min_j -! -! Birk is sum of current densities into both hemispheres. -! (micro amp/m**2). Before activating parallel potential drop -! we need to check if birk is being used correctly in -! this routine. -! -! Stanislav: VPAR is computed inside IE loop (for both -! negative and positive particles), and will -! be the one for the largest IE value. Which -! is nonsense. -! Stanislav: this subroutine needs grid-based formulation -! of plasma (EETA). Before it was done by -! computing EETA for electrons from the inner -! edges of electrons, then it was changed to -! use directly grid-based population. In the -! latter case, array PVEC returned by this -! routine is the electron pressure (without -! the factor of 2/3) and is the same as what -! routine PV returns as array PVGAM. If the -! electrons are on the grid only, as in my case, -! then we call PV in rcm main program to compute -! the ion pressure, and we use PVEC from this -! routine for the electron pressure. (04/20/99) -! Stanislav, may 18,99: make all loops over electrons only, -! by using iedim_local and setting it to 1. -!______________________________________________________________________________ -! - INTEGER (iprec) :: i, j, ie, iedim_local, kc - REAL (rprec) :: en, ekt, therm, sum1 (iesize), sum2 (iesize) -! -! -! - iedim_local = 2 -! - vpar (:,:) = zero - eavg (:,:,:) = zero - eflux (:,:,:) = zero - - - loop_j: DO j = j1, j2 - loop_i: DO i = imin_j(j), isize -! -! For each grid point, clear sum1 and sum2: -! - sum1 (1:iedim_local) = zero - sum2 (1:iedim_local) = zero -! -! -! Now for each grid point, consider all species -! present at that grid point, and compute sum1 and -! sum2 for positive and negative particles separately: -! - GRID_BASED: DO kc = 1, kcsize - IF ( ABS(alamc(kc))*vm(i,j) > 500.0_rprec) THEN - IF (alamc (kc) < zero) THEN - ie = 1 - ELSE - ie = 2 -! STOP 'BALGN4: ie is 2' - END IF - sum1(ie) = sum1(ie) + eeta(i,j,kc)*fudgec(kc) - sum2(ie) = sum2(ie) + eeta(i,j,kc)*fudgec(kc)*ABS(alamc(kc)) - END IF - END DO GRID_BASED -! -! For positive and negative particles separately, -! compute precipitating number flux, average energy, -! and parallel potential drop: -! - DO ie = 1, iedim_local -! - IF (sum1 (ie) > 10.*machine_tiny) THEN ! zero sbao 07/2019 -! -! compute thermal electron current, field-aligned -! potential drop, electron energy flux, -! and average electron energy at (i,j): -! - en = sum1 (ie) * vm (i, j)**1.5 / 6.38E+21 - ekt = (two/three) * sum2 (ie) * vm (i,j) / sum1 (ie) - therm = 0.02675 * en * SQRT(ekt*xmass(1)/xmass(ie)) -! - IF (therm < 1.E-30) THEN - therm = zero - vpar (i,j) = zero - ELSE - IF (- birk (i, j) / therm > one) THEN - vpar (i,j) = ekt * (- birk (i,j) / therm - one) - ELSE - vpar (i,j) = one - END IF - vpar(i,j) = MIN (vpar (i, j), 10000.0_rprec) - END IF -! -! !!!!!!! ALERT: VPAR(I,J) IS SET TO 0 !!!!!!!!!!!!!!!!! -! - vpar (i, j) = zero -! -! - eflux(i,j,ie) = 0.002 * therm * & - ( ekt + vpar(i,j) + half*vpar(i,j)**2/ekt) - eavg(i,j,ie) = two*(ekt+vpar(i,j)+half*vpar(i,j)**2 /ekt) / & - (one + vpar (i, j) / ekt) - ! sbao 6/19 detect Nan - if (ISNAN(eflux(i,j,ie)))then - if (.not. doQuietRCM) write(*,*)'eflux,i,j,therm,ekt,vpar,sum1,sum2,vm',eflux(i,j,ie),i,j,therm,ekt,vpar(i,j),sum1(ie),sum2(ie),vm(i,j) - eflux(i,j,ie) = 0.0 - eavg(i,j,ie) = 0.0 - end if - - ELSE -! -! Case fudge=0: we want eflux=0 and eavg=0 for no precipitation. -! - eflux (i, j, ie) = zero - eavg (i, j, ie) = zero -! - END IF - ! corrections to eavg at eflux(i,j) == 0.0 sbao 07/2019 - ! == does not work well with real number, use lt threshold instead. ldong 04/2020 - IF (eflux(i,j,ie) .lt. 0.01) eavg(i,j,ie) = 0.0 - IF (eavg(i,j,ie) .lt. 0.01) eflux(i,j,ie) = 0.0 - -! - END DO -! - END DO loop_i - END DO loop_j -! -! -! - CALL Circle (vpar) - CALL Circle (eflux (:, :, ie_el)) - CALL Circle (eavg (:, :, ie_el)) - CALL Circle (eflux (:, :, ie_hd)) - CALL Circle (eavg (:, :, ie_hd)) -! - RETURN - END SUBROUTINE Get_vparallel -! -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - SUBROUTINE Floor_for_eflux () - IMPLICIT NONE - INTEGER (iprec) :: ivalue_max, i, j - REAL (rprec) :: eflux_max - DO j = 1, jsize - eflux_max = eflux (isize, j, ie_el) - ivalue_max = isize - DO i = isize-1, imin_j(j), -1 - IF (eflux(i,j,ie_el) > eflux(i+1,j,ie_el)) THEN - eflux_max = eflux(i,j,ie_el) - ivalue_max = i - END IF - END DO - DO i = imin_j(j), ivalue_max - 1 - eflux(i,j,ie_el) = MAX (half*eflux_max, eflux(i,j,ie_el)) - END DO - END DO - !ion precipitation - DO j = 1, jsize - eflux_max = eflux (isize, j, ie_hd) - ivalue_max = isize - DO i = isize-1, imin_j(j), -1 - IF (eflux(i,j,ie_hd) > eflux(i+1,j,ie_hd)) THEN - eflux_max = eflux(i,j,ie_hd) - ivalue_max = i - END IF - END DO - DO i = imin_j(j), ivalue_max - 1 - eflux(i,j,ie_hd) = MAX (half*eflux_max, eflux(i,j,ie_hd)) - END DO - END DO - RETURN - END SUBROUTINE Floor_for_eflux -! -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! -! - - SUBROUTINE Move_plasma_grid (dt, i_start, i_stop, j_start, j_stop,ie_ask) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: dt - INTEGER (iprec), INTENT (IN) :: ie_ask, i_start, i_stop, j_start, j_stop -!_____________________________________________________________________________ -! Subroutine to advance eta distribution for a time step -! by a lifetime-based algorithm (raw doc dated 5/12/87) -! -! Last update: 05-11-88 -! 01-29-96 ain ,min_j and calls to bndy added - frt -! rws 06-05-97 etamov changed to reflect new use of -! eeta array in rcm697 version -! -! CALLED FROM: TSTEP1 -!_____________________________________________________________________________ -! -! - REAL (rprec) :: eeta2 (isize,jsize), veff (isize,jsize), & - dvefdi(isize,jsize), dvefdj(isize,jsize), & - didt, djdt, biold, bjold, rate, mass_factor, a1, a2, fi, fj - INTEGER (iprec) :: i, j, kc, ie, i_1, i_2, j_1, j_2 - LOGICAL :: pt_1_1, pt_1_2, pt_2_1, pt_2_2 -! - real :: v_1_1, v_1_2, v_2_1, v_2_2 -! - DO kc = 1, kcsize -! - IF (alamc(kc) < zero) THEN - ie = 1 - ELSE - ie = 2 ! but must change if O+ is added - END IF - IF (ie /= ie_ask) CYCLE - mass_factor = SQRT (xmass(1) / xmass(ie)) - veff = v + vcorot - vpar + alamc(kc)*vm - - last_veff(:,:,kc) = veff ! Storing for output -! - dvefdi = Deriv_i (veff, imin_j) - dvefdj = Deriv_j (veff, imin_j, j1, j2, 1.0E+25_rprec) - WHERE (ABS(dvefdj) > 1.0E+24) - dvefdj = 0.0 - dvefdi = 0.0 - END WHERE -! -! - eeta2 (:,:) = eeta (:,:,kc) - DO j = j1, j2 -! DO i = imin_j(j), i2 - DO i = i_start, i_stop - IF (i <= imin_j(j)) CYCLE - didt = dvefdj (i,j) / fac (i,j) - djdt = - dvefdi (i,j) / fac (i,j) - biold = REAL(i,rprec) - didt * dt - bjold = Bjmod (REAL(j,rprec) - djdt * dt, jwrap, jsize ) - rate = RatefnFDG (fudgec(kc), alamc(kc), sini (i,j), bir (i,j), & - vm (i,j), mass_factor) -! IF (biold > Bndy(bndloc,bjold)) THEN - IF (biold > bndloc(j)) THEN -! Particle came from within the modeling region, find ETA_old by interp: - i_1 = INT (biold) - i_2 = i_1 + 1 - j_1 = INT (bjold) - j_2 = j_1 + 1 -! -! (i_1,j_1) x--------------x (i_1,j_2) -! | | -! | | -! | | -! | | -! (i_2,j_1) x--------------x (i_2,j_2) -! - pt_1_1 = i_1 >= imin_j(j_1) - pt_1_2 = i_1 >= imin_j(j_2) - pt_2_1 = i_2 >= imin_j(j_1) - pt_2_2 = i_2 >= imin_j(j_2) -! - v_1_1 = eeta2 (i_1,j_1) - v_1_2 = eeta2 (i_1,j_2) - v_2_1 = eeta2 (i_2,j_1) - v_2_2 = eeta2 (i_2,j_2) -! - IF ((.NOT.pt_2_1) .OR. (.NOT. pt_2_2)) THEN - STOP 'ONE OF I_2 POINTS OUT OF BNDY' - ELSE IF ((.NOT.pt_1_1) .AND. (.NOT.pt_1_2)) THEN - STOP 'BOTH I_1 POINTS OUT OF BNDY' - ELSE IF (pt_1_1) THEN ! get 1,2 by interp. - - ELSE ! get 1,1 by interp. - - END IF -! IF (i_1 < imin_j(j_1) .OR. i_2 < imin_j(j_1) .OR. & -! i_1 < imin_j(j_2) .OR. i_2 < imin_j(j_2)) THEN -! STOP 'PNT IS OUTSIDE MODELING REGION' -! END IF - fi = REAL(i_1) - fj = REAL(j_1) - a1 = (1.0-(biold-fi))*eeta2(i_1,j_1) + (biold-fi)*eeta2(i_2,j_1) - a2 = (1.0-(biold-fi))*eeta2(i_1,j_2) + (biold-fi)*eeta2(i_2,j_2) - eeta (i,j,kc) = ((1.0 - (bjold-fj)) * a1 + (bjold-fj) * a2)*EXP(-rate*dt) - ELSE -! Particle came from outside the modeling region, find ETA_old from b.c.: - STOP 'PARTICLE IS FLOWING IN, NOT IMPLEMENTED' - END IF - END DO - END DO -! - CALL Circle (eeta(:,:,kc)) -! - END DO -! - ! refill the plasmasphere 04012020 sbao - CALL Plasmasphere_Refilling_Model(eeta(:,:,1), rmin, aloct, vm, dt) - CALL Circle (eeta(:,:,1)) - - RETURN - - END SUBROUTINE Move_plasma_grid -! -! -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - SUBROUTINE Circle_2d (r) - IMPLICIT NONE - REAL (rprec), INTENT (IN OUT) :: r (:,:) -! - INTEGER (iprec) :: jlast, i, j, imax, jmax -! - imax = SIZE (r, DIM = 1) - jmax = SIZE (r, DIM = 2) - jlast = jmax - jwrap - - DO i = 1, imax - DO j = 1, jwrap - 1 - r (i, j) = r (i, jlast + j) - END DO - r (i, jmax) = r (i, jwrap) - END DO - RETURN - END SUBROUTINE Circle_2d -! -! -! -! -! - SUBROUTINE Circle_1d (r) - IMPLICIT NONE - REAL (rprec), INTENT (IN OUT) :: r (:) -! - INTEGER (iprec) :: jlast, j, jmax -! - jmax = SIZE (r, DIM = 1) - jlast = jmax - jwrap - - DO j = 1, jwrap - 1 - r (j) = r (jlast + j) - END DO - r (jmax) = r (jwrap) - RETURN - END SUBROUTINE Circle_1d -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - FUNCTION Eta_lambda_vgamma ( kbeg, kend, kcbeg, kcend, gamma) RESULT (out) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: kbeg, kend, kcbeg, kcend - REAL (rprec), INTENT (IN) :: gamma - REAL (rprec) :: out (isize,jsize,iesize) -!______________________________________________________________________________ -! -! Subroutine computes quantity ETA*ABS(ALAM)*V**GAMMA at each grid point -! for electrons and ions separately. KBEG, KEND, KCBEG, KCEND can be used -! to restrict species to be included in the sum (use 1, ksize, 1, kcsize for -! no restrictions). GAMMA is an input parameter: -! ** if GAMMA = 0, then the computed sum is the adiabatic parameter PVGAMMA -! ** if GAMMA = -5/3, compute energy density (or pressure without the 2/3 factor) -! ** if GAMMA = -2/3, compute total energy of particles -!______________________________________________________________________________ -! - INTEGER (iprec) :: nbi, k, m, mbeg, mend, ipmax, ncount, i,j,n, ie,kc - REAL (rprec) :: q, bimax, bicrss (100), charge -! -! - out = zero -! - DO ie = 1, iesize -! - IF (ie == 1) THEN - charge = - one - ELSE - charge = + one - END IF -! -! I. Compute sum for plasma on inner edges, electrons and ions separately : - -! -! II. Compute the sum for grid_based electrons or ions: -! - DO j = 1, jsize - DO i = 1, isize -! IF (REAL(i,rprec) < Bndy(bndloc, REAL(j,rprec)) ) CYCLE - IF (REAL(i,rprec) < bndloc(j) ) CYCLE - DO kc = kcbeg, kcend - q = alamc(kc) / charge - IF (q > zero) THEN - out (i,j,ie) = out (i,j,ie) + ABS (alamc(kc) * eeta(i,j,kc)) - END IF - END DO - END DO - END DO -! - END DO -! -! - DO ie = 1, iesize - CALL Circle (out (:,:,ie)) - END DO -! -! - DO ie = 1, iesize - out (:,:,ie) = out(:,:,ie) * (vm (:,:)**((-three/two)*gamma)) - END DO -! - RETURN - END FUNCTION Eta_lambda_vgamma -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - FUNCTION Get_imin_for_grid (j) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: j - INTEGER (iprec) :: Get_imin_for_grid -! - Get_imin_for_grid = MIN (imin_j(Bjmod(j,jwrap,jsize)), & - imin_j(Bjmod(j+1,jwrap,jsize)), & - imin_j(Bjmod(j-1,jwrap,jsize)) ) - RETURN - END FUNCTION Get_imin_for_grid -! -! -! -! - FUNCTION Lt_from_aloct (phi) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: phi - REAL (rprec) :: Lt_from_aloct -! -! Convert an RCM phi angle (aloct in ionosphere) to MLT -! Output (result) is: 0.0 <= result < 24.00 -! - IF (phi < zero .OR. phi > pi_two) THEN - WRITE (*,*) 'IN LT_FROM_ALOCT, PHI IS OUT OF BOUNDS' - STOP - ELSE - Lt_from_aloct = MODULO((phi-pi)*RTH, 24.0_rprec) - Lt_from_aloct = MODULO(Lt_from_aloct, 24.0_rprec) - END IF - RETURN - END FUNCTION Lt_from_aloct - -! -! - SUBROUTINE Read_plasma_H5 - use ioh5 - use files - implicit none - logical :: doSP - type(IOVAR_T), dimension(RCMIOVARS) :: IOVars !Lazy hard-coding max variables - integer :: nvari, tauDim, Nk, Nm,Nl,Ne - integer :: dims(4) ! update when add higher dimensions - - write(*,*) "Read rcmconfig.h5...." - - doSP = .false. - call ClearIO(IOVars) !Reset IO chain - call AddInVar(IOVars,"alamc") - call AddInVar(IOVars,"ikflavc") - call AddInVar(IOVars,"fudgec") - call ReadVars(IOVars,doSP,RCMGAMConfig) - - !Store data for energy channels - alamc(:) = IOVars(FindIO(IOVars, "alamc"))%data - ikflavc(:) = IOVars(FindIO(IOVars, "ikflavc"))%data - fudgec(:) = IOVars(FindIO(IOVars, "fudgec"))%data - - ! reset to make sure species if ikflav ==1 alamc is set to negative, for electrons - where(ikflavc==1)alamc = -abs(alamc) - - ! Check if rcmconfig.h5 is up-to-date - if (ioExist(RCMGAMConfig,"Tau1i")) then - write(*,*) "An old rcmconfig.h5 is used. Please make a new one using genRCM.py." - stop - endif - - !Store data for wave models - !Dimension check: only compatible with tau(MLT,L,Kp,Ek) - if (ioExist(RCMGAMConfig,"Taui")) then - EWMTauInput%useWM = .true. - !Chorus wave - call AddInVar(IOVars,"Kpi") - call AddInVar(IOVars,"MLTi") - call AddInVar(IOVars,"Li") - call AddInVar(IOVars,"Eki") - call AddInVar(IOVars,"Taui") - call ReadVars(IOVars,doSP,RCMGAMConfig) - tauDim = IOVars(FindIO(IOVars, "Taui"))%Nr - if (tauDim /= 4) then - write(*,*) "tauDim:",tauDim - write(*,*) 'Currently only support tau model files in the form tau(Kp,MLT,L,Ek)' - write(*,*)"tau:",IOVars(FindIO(IOVars, "Taui"))%dims - stop - endif - - dims = IOVars(FindIO(IOVars, "Taui"))%dims(1:tauDim) - Nk = IOVars(FindIO(IOVars, "Kpi"))%N - Nm = IOVars(FindIO(IOVars, "MLTi"))%N - Nl = IOVars(FindIO(IOVars, "Li"))%N - Ne = IOVars(FindIO(IOVars, "Eki"))%N - if (Nk /= dims(1) .or. Nm /= dims(2) .or. Nl /= dims(3) .or. Ne /= dims(4)) then - write(*,*) "dims:",dims,"Nk:",Nk,"Nm:",Nm,"Nl:",Nl,"Ne:",Ne - write(*,*) 'Dimensions of tau arrays are not compatible' - stop - endif - - !Store arrays - EWMTauInput%ChorusTauInput%Nk = Nk - EWMTauInput%ChorusTauInput%Nm = Nm - EWMTauInput%ChorusTauInput%Nl = Nl - EWMTauInput%ChorusTauInput%Ne = Ne - - - if(allocated(EWMTauInput%ChorusTauInput%Kpi)) deallocate(EWMTauInput%ChorusTauInput%Kpi) - if(allocated(EWMTauInput%ChorusTauInput%MLTi)) deallocate(EWMTauInput%ChorusTauInput%MLTi) - if(allocated(EWMTauInput%ChorusTauInput%Li)) deallocate(EWMTauInput%ChorusTauInput%Li) - if(allocated(EWMTauInput%ChorusTauInput%Eki)) deallocate(EWMTauInput%ChorusTauInput%Eki) - if(allocated(EWMTauInput%ChorusTauInput%taui)) deallocate(EWMTauInput%ChorusTauInput%taui) - - allocate(EWMTauInput%ChorusTauInput%Kpi(Nk)) - allocate(EWMTauInput%ChorusTauInput%MLTi(Nm)) - allocate(EWMTauInput%ChorusTauInput%Li(Nl)) - allocate(EWMTauInput%ChorusTauInput%Eki(Ne)) - allocate(EWMTauInput%ChorusTauInput%taui(Nk,Nm,Nl,Ne)) - - call IOArray1DFill(IOVars,"Kpi",EWMTauInput%ChorusTauInput%Kpi) - call IOArray1DFill(IOVars,"MLTi",EWMTauInput%ChorusTauInput%MLTi) - call IOArray1DFill(IOVars,"Li", EWMTauInput%ChorusTauInput%Li) - call IOArray1DFill(IOVars,"Eki",EWMTauInput%ChorusTauInput%Eki) - call IOArray4DFill(IOVars,"Taui",EWMTauInput%ChorusTauInput%taui) - - call ClearIO(IOVars) - - !Array order check: array is in acsending order - !Chorus - if(EWMTauInput%ChorusTauInput%Kpi(1) > EWMTauInput%ChorusTauInput%Kpi(Nk)) then - write(*,*) "Kp: ",EWMTauInput%ChorusTauInput%Kpi - write(*,*) "reorder wave model so Kp is in ascending order" - stop - end if - - if(EWMTauInput%ChorusTauInput%Li(1) > EWMTauInput%ChorusTauInput%Li(Nl)) then - write(*,*) "L: ",EWMTauInput%ChorusTauInput%Li - write(*,*) "reorder wave model so L shell is in ascending order" - stop - end if - - if(EWMTauInput%ChorusTauInput%MLTi(1) > EWMTauInput%ChorusTauInput%MLTi(Nm)) then - write(*,*) "MLT: ",EWMTauInput%ChorusTauInput%MLTi - write(*,*) "reorder wave model so MLT is in ascending order" - stop - end if - - if(EWMTauInput%ChorusTauInput%Eki(1) > EWMTauInput%ChorusTauInput%Eki(Ne)) then - write(*,*) "Ek: ",EWMTauInput%ChorusTauInput%Eki - write(*,*) "reorder wave model so Ek is in ascending order" - stop - end if - - endif - - - END SUBROUTINE Read_plasma_H5 -! -! -! - FUNCTION Dipole_Bfield (theta, phi, arg) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: theta, phi - INTEGER (iprec), INTENT (IN) :: arg - REAL (rprec) :: Dipole_Bfield -! -! THETA and PHI are in radians, THETA measured from n.pole down, -! PHI measured from noon to dusk to midnight etc. -! Distances RMIN, XMIN, and YMIN are in units of RE -! Since in the RCM, BESU is in [nT], and the factor of RE is ommited -! from the formula, VM has units of (RE/nT)**(-2/3) -! - REAL (rprec) :: rmin, xmin, ymin, bmin, vm -! - rmin = one / SIN(theta)**2 - xmin = rmin * COS (phi) - ymin = rmin * SIN (phi) - bmin = besu * (one/rmin**3) - vm = (32.0_rprec/35.0_rprec* rmin**4 / Besu * & - SQRT(one-one/rmin)* & - (one+half/rmin+three/eight/rmin**2+five/eight/two/rmin**3) & - ) ** (-two/three) -! - IF (arg == 1) THEN - Dipole_Bfield = xmin - ELSE IF (arg == 2) THEN - Dipole_Bfield = ymin - ELSE IF (arg == 3) THEN - Dipole_Bfield = bmin - ELSE IF (arg == 4) THEN - Dipole_Bfield = vm - ELSE - STOP 'ILLEGAL ARGUMENT FOR DIPOLE_BFIELD' - END IF -! - RETURN - END FUNCTION Dipole_Bfield -! -! -! -! -! - FUNCTION Deriv_i (a, imin_j) RESULT (d_di) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: imin_j(:) - REAL (rprec), INTENT (IN) :: a(:,:) - REAL (rprec) :: d_di (SIZE(a,DIM=1), SIZE(a,DIM=2)) -! -!_________________________________________________________________________ -! The idea is to use central differences for a second-order accuracy -! of the first-order derivative, if we can. If one of the neighboring -! points is outside the boundary, use forward or back difference -! (first-order accuracy) if we can. If both points are outside, set -! derivative to zero. -!_________________________________________________________________________ -! - INTEGER (iprec) :: i, j, j_size, i_size -! - i_size = SIZE (a, DIM=1) - j_size = SIZE (a, DIM=2) -! - DO j = 1, j_size -! - d_di (1:imin_j(j)-1,j) = 0.0_rprec -! - i = imin_j(j) - d_di (i,j) = -1.5_rprec*a(i,j) + 2.0_rprec*a(i+1,j) - 0.5_rprec*a(i+2,j) -! - DO i = imin_j(j)+1, i_size - 1 - d_di (i,j) = 0.5_rprec*(a(i+1,j) - a(i-1,j)) - END DO -! - i = i_size - d_di (i,j) = +1.5_rprec*a(i,j) - 2.0_rprec*a(i-1,j) + 0.5_rprec*a(i-2,j) -! - END DO -! - CALL Circle (d_di) -! - RETURN - END FUNCTION Deriv_i -! -! -! - FUNCTION Deriv_j (a, imin_j, j1, j2, error_value) RESULT (d_dj) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: a (:,:), error_value - INTEGER (iprec), INTENT (IN) :: imin_j(:), j1, j2 - REAL (rprec) :: d_dj (SIZE(a,DIM=1), SIZE(a,DIM=2)) -!___________________________________________________________________________ -! -! Take derivative of A with respect to J. The idea is to use -! grid points that are inside the modeling region. Stanislav 10/27/2000. -! 3/6/2001: modified to be the same as Frank's version in rcm296. -! Notice that pt_jpp is defined differently (>) than pt_jp(>=), and ditto -! for pt_jmm and pt_jm. Took this from Frank's version. -!___________________________________________________________________________ -! - INTEGER (iprec) :: i_bnd, i, j, jm, jmm, jp, jpp, j_size - LOGICAL :: pt_jp, pt_jpp, pt_jm, pt_jmm -! -! - i_bnd = MAXVAL (imin_j) - j_size = SIZE (imin_j) -! - DO j = j1, j2 -! - jp = j + 1 - jm = j - 1 -! - d_dj (1:imin_j(j)-1,j) = 0.0_rprec -! - DO i = imin_j(j), i_bnd-1 -! - pt_jp = (i >= imin_j(jp)) - pt_jm = (i >= imin_j(jm)) -! - IF (pt_jp .AND. pt_jm ) THEN - d_dj (i,j) = half*(a (i,jp) - a (i,jm)) - ELSE IF (pt_jp ) THEN !j-1 is outside - d_dj (i,j) = a(i,jp) - a(i,j) - ELSE IF (pt_jm ) THEN ! j+1 is outside - d_dj (i,j) = (a (i,j) - a (i,jm)) - ELSE - d_dj (i,j) = error_value - END IF -! - END DO -! - d_dj (i_bnd:,j) = 0.5_rprec*( a(i_bnd:,jp) - a(i_bnd:,jm)) - END DO -! - CALL Circle (d_dj) -! - RETURN - END FUNCTION Deriv_j -! -! -! - SUBROUTINE Rcm (itimei_in, itimef_in, nstep_in, icontrol, stropt, nslcopt, iXML) -!--------------------------------------------- -! notes -! icontrol controls behaviour of the RCM -! 0: initialize RCM size params and go back -! (RCMINIT) 1: initialize RCM grid, energy channels, quit: -! 2: read in inputs, quit: -! 3: Set initial conditions on plasma (edges and grid-based) -! 4: run RCM from itimei to itimef with time step idt, quit: -! ICONWRITERESTART = 31337: write a restart record to RCM -! ICONWRITEOUTPUT = ICONWRITERESTART + 1: write an HDF5 output -! ICONRESTART = ICONWRITERESTART - 1: Read HDF5 restart - - - USE xml_input - USE rcm_timing_module - IMPLICIT NONE -! - type(XML_Input_T), intent(in), optional :: iXML - REAL (rprec), INTENT (IN) :: itimei_in, itimef_in !, & - !idt_in, idt1_in,& - !idt2_in, - INTEGER (iprec), INTENT (IN) :: nstep_in - INTEGER (iprec), INTENT (IN) :: icontrol - character(len=*), intent(in), optional :: stropt - integer(iprec) , intent(in), optional :: nslcopt - CHARACTER(LEN=8) :: real_date - CHARACTER (LEN=8) :: time_char - CHARACTER(LEN=10) ::real_time - CHARACTER(LEN=80) :: ST='', PS='', HD='', string_null='' - LOGICAL :: FD, logical_flag -! -! - REAL (rprec), SAVE :: itimei, itimef !, idt, idt1, idt2 -! REAL (rprec), SAVE :: itout1, itout2, itcln, i_time - INTEGER (iprec), SAVE :: idebug, k, kc, n, nstep - INTEGER (iprec) :: i_avg, i_step - REAL (rprec) :: dt,wAvg - REAL (rprec), PARAMETER :: tinyT = 1e-6 !10.0*machine_tiny - - CALL SYSTEM_CLOCK (timer_start(1), count_rate) - - itimef = itimef_in - itimei = itimei_in - nstep = nstep_in - - if (doRCMVerbose) then - write(6,*)'RCM: itimei= ',itimei,' seconds',' itimef= ',itimef,' seconds ','nStep= ',nstep - endif - - IF (icontrol == ICONWRITERESTART) then ! write a restart record to RCM - call WriteRCMH5(stropt,nslcopt,isRestart=.true.) - return - ENDIF - IF (icontrol == ICONWRITEOUTPUT) then ! write an HDF5 output - call WriteRCMH5(stropt,nslcopt,isRestart=.false.) - return - ENDIF - IF (icontrol == ICONRESTART) then - !Read HDF5 restart - call ReadRCMRestart(stropt,nslcopt) - return - ENDIF - - IF (icontrol == 0) then ! initialize RCM size params and go back: - - - ! Grid limit parameters - i1 = 2 ! will reset anyway - i2 = isize - 1 - j1 = jwrap - j2 = jsize - 1 - iint = 1 - jint = 1 - - CALL SYSTEM_CLOCK (timer_stop(1), count_rate) - timer_values (1) = (timer_stop (1) - timer_start (1))/count_rate + timer_values(1) - - RETURN - - END IF - - IF (icontrol == 1) then ! initialize RCM grid, energy channels, quit: - ! CALL Read_grid () - CALL Read_plasma_H5() - - CALL SYSTEM_CLOCK (timer_stop(1), count_rate) - timer_values (1) = (timer_stop (1) - timer_start (1))/count_rate + timer_values(1) - - RETURN - END IF - - - IF (icontrol == 2) then ! read in inputs, quit: - - if(present(iXML)) then - call RCM_Params_XML(iXML) - else - call RCM_Params_XML() - endif - CALL Read_dktime_H5(L_dktime) - - CALL SYSTEM_CLOCK (timer_stop(1), count_rate) - timer_values (1) = (timer_stop (1) - timer_start (1))/count_rate + timer_values(1) - - RETURN - - END IF - - - IF (icontrol == 3) then !--> Set initial conditions on plasma (grid-based): -! - ! Open file for formatted output and do initial print out : - CALL Date_and_time (real_date, real_time) - - i1 = imin + 1 - - IF (itimei > tinyT) imin_j = CEILING (bndloc) - - - CALL SYSTEM_CLOCK (timer_stop(1), count_rate) - timer_values (1) = (timer_stop (1) - timer_start (1))/count_rate + timer_values(1) - - RETURN - - END IF - - - - IF (icontrol == 4) then ! run RCM from itimei to itimef with time step idt, quit: - call Tic("Main_Loop") - - !Do check - if (.not. any(advChannel)) then - write(*,*) "RCM has no good channels, dying" - stop - endif - - CALL SYSTEM_CLOCK (timer_start(2), count_rate) - - !NOTE: v_avg behaves differently than birk_avg - !v_avg is the running average over numerous rcm couplings, birk_avg is over just the current one - - if (doVAvgInit) then - v_avg = v !Initialize v_avg = v at first time - doVAvgInit = .FALSE. - else - !Figure out weighting for exponential moving average (EMA) - !Want weighting such that ~95% of the weight comes from the last dtAvg seconds - dt = (itimef-itimei) !Full RCM step - wAvg = 1.0 - exp(-3*dt/max(dtAvg_v,dt)) - v_avg = wAvg*v + (1-wAvg)*v_avg - endif - - birk_avg = zero - eeta_avg = zero - i_avg = 0 - - deleeta = 0.0 - lossratep = 0.0 - lossmodel= -1.0 - -!******************* main time loop ************************* -! - !Save most recent coupling dt - dtMHD = itimef-itimei - dt = (itimef - itimei)/REAL(nstep) - - if (doRCMVerbose) then - write(6,*)'RCM: substep length = ',dt,' seconds' - endif -! - !Q: Does this have any point since it gets recalculated in move-plasma? - !fac = 1.0E-3_rprec * bir * alpha * beta * dlam * dpsi * ri**2 * signbe -! - birk_avg = birk_avg + birk - - IF (nstep < 1) STOP 'Number of substep in RCM should be at least 1' - - !NOTE: Pushing averaging into move-plasma to avoid multiple recalculations of static arrays - call Move_plasma_grid_MHD(dt,nstep) - - CALL Comput (itimef-itimei) - if (doRCMVerbose) then - write(6,*)'RCM: : finishing Comput' - endif - birk_avg = (birk_avg + birk)/2. ! brik_avg takes two data points at itimei and itimef - - CALL SYSTEM_CLOCK (timer_stop(1), count_rate) - timer_values (1) = (timer_stop (1) - timer_start (1))/count_rate + timer_values(1) - - CALL SYSTEM_CLOCK (timer_stop(2), count_rate) - timer_values (2) = (timer_stop (2) - timer_start (2))/count_rate - - call Toc("Main_Loop") - - RETURN - - END IF - - - WRITE (*,*) ' RCM was called with an invalid value of Icontrol, aborting ...' - STOP - - CONTAINS -! - !HDF5 Restart reader - subroutine ReadRCMRestart(runid,nStp) - use ioh5 - use files - implicit none - character(len=*), intent(in) :: runid - integer(iprec), intent(in) :: nStp - logical :: doSP !Do single precision - character(len=strLen) :: H5File - type(IOVAR_T), dimension(RCMIOVARS) :: IOVars !Lazy hard-coding max variables - integer(iprec) :: nvar,nres,Ni,Nj,Nk - - !Prepare for reading - doSP = .false. !Restarts are always double precision - nres = nStp-1 !nStp holds number for *NEXT* restart output - if (nres == -1) then - !Use sym link - H5File = trim(runid) // ".RCM.Res.XXXXX.h5" - else - !Use actual # - write (H5File, '(A,A,I0.5,A)') trim(runid), ".RCM.Res.", nres, ".h5" - endif - write(*,*) 'Restarting RCM with file, ', trim(H5File) - call ClearIO(IOVars) !Reset IO chain - - !List variables to read - !Scalars (need to specify integers), order doesn't matter - - call AddInVar(IOVars,"itimei",vTypeO=IOINT ) - call AddInVar(IOVars,"isize" ,vTypeO=IOINT ) - call AddInVar(IOVars,"jsize" ,vTypeO=IOINT ) - call AddInVar(IOVars,"ksize" ,vTypeO=IOINT ) - call AddInVar(IOVars,"cmax" ,vTypeO=IOREAL) - call AddInVar(IOVars,"fmeb" ,vTypeO=IOREAL) - call AddInVar(IOVars,"fstoff",vTypeO=IOREAL) - call AddInVar(IOVars,"fdst" ,vTypeO=IOREAL) - call AddInVar(IOVars,"fclps" ,vTypeO=IOREAL) - call AddInVar(IOVars,"vdrop" ,vTypeO=IOREAL) - call AddInVar(IOVars,"kp" ,vTypeO=IOREAL) - call AddInVar(IOVars,"i_avg" ,vTypeO=IOREAL) - - !Arrays - call AddInVar(IOVars,"rcmxmin" ) - call AddInVar(IOVars,"rcmymin" ) - call AddInVar(IOVars,"rcmzmin" ) - call AddInVar(IOVars,"rcmvm" ) - call AddInVar(IOVars,"rcmbmin" ) - call AddInVar(IOVars,"rcmbndloc") - - call AddInVar(IOVars,"rcmetac" ) - call AddInVar(IOVars,"rcmeeta" ) - call AddInVar(IOVars,"rcmeetaavg") - call AddInVar(IOVars,"rcmlosspre") - call AddInVar(IOVars,"rcmlossmod") - !call AddInVar(IOVars,"rcmDpp") - - - call AddInVar(IOVars,"rcmpedlam" ) - call AddInVar(IOVars,"rcmpedpsi" ) - call AddInVar(IOVars,"rcmhall" ) - call AddInVar(IOVars,"rcmeavg" ) - call AddInVar(IOVars,"rcmeflux" ) - call AddInVar(IOVars,"rcmnflux" ) - call AddInVar(IOVars,"rcmbirk" ) - call AddInVar(IOVars,"rcmbirkavg") - - call AddInVar(IOVars,"rcmv") - call AddInVar(IOVars,"rcmvavg") - - call AddInVar(IOVars,"alpha") - call AddInVar(IOVars,"aloct") - call AddInVar(IOVars,"colat") - call AddInVar(IOVars,"beta") - call AddInVar(IOVars,"bir") - call AddInVar(IOVars,"sini") - - !Extra stuff (not in write arrays) - call AddInVar(IOVars,"alamc") - - !Now do actual reading - call ReadVars(IOVars,doSP,H5File) - !Do some testing to make sure sizes match - nvar = FindIO(IOVars,"rcmeeta",doFailO=.true.) - Ni = IOVars(nvar)%dims(1) - Nj = IOVars(nvar)%dims(2) - Nk = IOVars(nvar)%dims(3) - if ( (isize /= Ni) .or. (jsize /= Nj) .or. (ksize /= Nk) ) then - write(*,*) 'RCM Restart Mismatch!' - write(*,*) 'Input size: ',Ni,Nj,Nk - write(*,*) 'RCM size: ',isize,jsize,ksize - stop - endif - - !Parse data and put it where it goes, need to do each variable - !Scalars - itimei = GetIOInt(IOVars,"itimei") - - cmax = GetIOReal(IOVars,"cmax") - fmeb = GetIOReal(IOVars,"fmeb") - fstoff = GetIOReal(IOVars,"fstoff") - fdst = GetIOReal(IOVars,"fdst") - fclps = GetIOReal(IOVars,"fclps") - vdrop = GetIOReal(IOVars,"vdrop") - i_avg = GetIOReal(IOVars,"i_avg") - - !Pull 2D arrays - call IOArray2DFill(IOVars,"rcmxmin",xmin) - call IOArray2DFill(IOVars,"rcmymin",ymin) - call IOArray2DFill(IOVars,"rcmzmin",zmin) - call IOArray2DFill(IOVars,"rcmbmin",bmin) - - call IOArray2DFill(IOVars,"rcmv",v) - call IOArray2DFill(IOVars,"rcmvavg",v_avg) - doVAvgInit = .FALSE. !Don't need to start fresh v_avg - - call IOArray2DFill(IOVars,"rcmvm",vm) - - call IOArray2DFill(IOVars,"rcmbirk",birk) - call IOArray2DFill(IOVars,"rcmbirkavg",birk_avg) - - call IOArray2DFill(IOVars,"rcmhall",hall) - call IOArray2DFill(IOVars,"rcmpedlam",pedlam) - call IOArray2DFill(IOVars,"rcmpedpsi",pedpsi) - - !Disable replacing geometry (calculated fresh anyways) - !Better for when using upscaled restart - !call IOArray2DFill(IOVars,"alpha",alpha) - !call IOArray2DFill(IOVars,"aloct",aloct) - !call IOArray2DFill(IOVars,"colat",colat) - !call IOArray2DFill(IOVars,"beta",beta) - !call IOArray2DFill(IOVars,"bir",bir) - !call IOArray2DFill(IOVars,"sini",sini) - !call IOArray2DFill(IOVars,"rcmDpp",Dpp) - - - !Pull 1D arrays - call IOArray1DFill(IOVars,"rcmetac",etac) - call IOArray1DFill(IOVars,"rcmbndloc",bndloc) - call IOArray1DFill(IOVars,"alamc",alamc) - - !Pull 3D arrays - call IOArray3DFill(IOVars,"rcmeavg",eavg) - call IOArray3DFill(IOVars,"rcmeeta",eeta) - call IOArray3DFill(IOVars,"rcmeetaavg",eeta_avg) - call IOArray3DFill(IOVars,"rcmeflux",eflux) - if(ioExist(H5File,"rcmnflux")) then - call IOArray3DFill(IOVars,"rcmnflux",nflux) - endif - if(ioExist(H5File,"rcmlosspre")) then - call IOArray3DFill(IOVars,"rcmlosspre",lossratep) - endif - if(ioExist(H5File,"rcmlossmod")) then - call IOArray3DFill(IOVars,"rcmlossmod",lossmodel) - endif - - end subroutine ReadRCMRestart - - !HDF5 output routine - !isRestart = Whether we're writing restart dump or regular output slice - subroutine WriteRCMH5(runid,nStp,isRestart) - use ioh5 - use files - implicit none - character(len=*), intent(in) :: runid - integer(iprec), intent(in) :: nStp - logical, intent(in) :: isRestart - - type(IOVAR_T), dimension(RCMIOVARS) :: IOVars !Lazy hard-coding max variables - logical :: doSP !Do single precision output - character(len=strLen) :: H5File,gStr,lnResF - - !Prepare for output - !Reset IO chain - call ClearIO(IOVars) - !Distinguish output slices vs restarts - if (isRestart) then - doSP = .false. !Double precision restarts - write (H5File, '(A,A,I0.5,A)') trim(runid), ".RCM.Res.", nStp, ".h5" - else - !Regular output - doSP = .true. - H5File = trim(runid) // ".rcm.h5" - write (gStr, '(A,I0)') "Step#", nStp - endif - - !Attributes - call AddOutVar(IOVars,"time",1.0_rp*itimei) - call AddOutVar(IOVars,"itimei",itimei) - call AddOutVar(IOVars,"isize" ,isize ) - call AddOutVar(IOVars,"jsize" ,jsize ) - call AddOutVar(IOVars,"ksize" ,ksize ) - call AddOutVar(IOVars,"cmax" ,cmax ) - call AddOutVar(IOVars,"fmeb" ,fmeb ) - call AddOutVar(IOVars,"fstoff",fstoff) - call AddOutVar(IOVars,"fdst" ,fdst ) - call AddOutVar(IOVars,"fclps" ,fclps ) - call AddOutVar(IOVars,"vdrop" ,vdrop ) - call AddOutVar(IOVars,"i_avg" ,i_avg ) - call AddOutVar(IOVars,"dtCpl" ,dtMHD ) - - !Arrays - call AddOutVar(IOVars,"rcmxmin",xmin) - call AddOutVar(IOVars,"rcmymin",ymin) - call AddOutVar(IOVars,"rcmzmin",zmin) - call AddOutVar(IOVars,"rcmvm" ,vm ) - call AddOutVar(IOVars,"rcmbmin",bmin) - call AddOutVar(IOVars,"rcmbndloc",bndloc) - - call AddOutVar(IOVars,"rcmetac" ,etac) - call AddOutVar(IOVars,"rcmeeta" ,eeta) - call AddOutVar(IOVars,"rcmeetaavg",eeta_avg) - call AddOutVar(IOVars,"rcmdeleeta",deleeta) - call AddOutVar(IOVars,"rcmlosspre",lossratep) - call AddOutVar(IOVars,"rcmDpp",Dpp) - call AddOutVar(IOVars,"rcmlossmod",lossmodel) - - call AddOutVar(IOVars,"rcmpedlam" ,pedlam ) - call AddOutVar(IOVars,"rcmpedpsi" ,pedpsi ) - call AddOutVar(IOVars,"rcmhall" ,hall ) - call AddOutVar(IOVars,"rcmeavg" ,eavg ) - call AddOutVar(IOVars,"rcmeflux" ,eflux ) - call AddOutVar(IOVars,"rcmnflux" ,nflux ) - call AddOutVar(IOVars,"rcmbirk" ,birk ) - call AddOutVar(IOVars,"rcmbirkavg",birk_avg) - - call AddOutVar(IOVars,"rcmv",v) - call AddOutVar(IOVars,"rcmvavg",v_avg) - - !Extra stuff not in write_array - call AddOutVar(IOVars,"alamc",alamc) - call AddOutVar(IOVars,"aloct",aloct) - call AddOutVar(IOVars,"colat",colat) - call AddOutVar(IOVars,"alpha",alpha) - call AddOutVar(IOVars,"beta" ,beta ) - call AddOutVar(IOVars,"bir" ,bir ) - call AddOutVar(IOVars,"sini" ,sini ) - - if (doRCMVerboseH5) then - !Good place to store useful but large 3D outputs - call AddOutVar(IOVars,"rcmveff",last_veff,uStr="Volts") - call AddOutVar(IOVars,"rcmocbDist",last_ocbDist) - endif - - !Done staging output, now let er rip - if (isRestart) then - call AddOutVar(IOVars,"nRes",nStp) - call CheckAndKill(H5File) !Always overwrite restarts - call WriteVars(IOVars,doSP,H5File) - !Create link to latest restart - write (lnResF, '(A,A,A,A)') trim(runid), ".RCM.Res.", "XXXXX", ".h5" - call MapSymLink(H5File,lnResF) - else - call WriteVars(IOVars,doSP,H5File,gStr) - endif - end subroutine WriteRCMH5 - - subroutine RCM_Params_XML(iXML) - use xml_input - use strings - - type(XML_Input_T), intent(in), optional :: iXML - character(len=strLen) :: inpXML - type(XML_Input_T) :: xmlInp - - if(present(iXML)) then - call iXML%GetFileStr(inpXML) - else - !Find input deck filename - call getIDeckStr(inpXML) - endif - - !Create new XML reader w/ RCM as root - xmlInp = New_XML_Input(trim(inpXML),'Kaiju/RCM',.true.) - - call xmlInp%Set_Val(label%char,"sim/runid","MAGE sim") - - !Output - call xmlInp%Set_Val(idebug,"output/idebug",1) ! 6. 0 <=> do disk printout - call xmlInp%Set_Val(doRCMVerbose,"output/doDebug",doRCMVerbose) - call xmlInp%Set_Val(doRCMVerboseH5,"output/doDebugH5",doRCMVerboseH5) - !eflux - call xmlInp%Set_Val(ifloor,"eflux/ifloor",.true.) ! 18. if true, install a floor for EFLUX - call xmlInp%Set_Val(icorrect,"eflux/icorrect",.true.) ! 19. if true, make lat. correction to EFLUX - - !Grid - call xmlInp%Set_Val(imin,"grid/imin",1) - call xmlInp%Set_Val(ibnd_type,"grid/ibnd_type",4) ! 14. type of bndy (1-eq.p, 2-iono) - call xmlInp%Set_Val(ipcp_type,"grid/ipcp_type",13) ! 14. type of bndy (1-eq.p, 2-iono) - call xmlInp%Set_Val(nsmthi,"grid/nsmthi",0) ! 15. How much to smooth cond in I - call xmlInp%Set_Val(nsmthj,"grid/nsmthj",0) ! 16. How much to smooth cond in J - call xmlInp%Set_Val(L_move_plasma_grid,"grid/L_move_plasma_grid",.true.) - - !Catch-all params - call xmlInp%Set_Val(ipot,"params/ipot",-1) ! 6. which potential solver to use - call xmlInp%Set_Val(iwind,"params/iwind",0) ! 9. 0 is no neutral winds - call xmlInp%Set_Val(icond,"params/icond",3) ! 1 is active conductances, 2 is Hardy with kp, 3 is input - - call xmlInp%Set_Val(cmax,"params/cmax",3.0) ! in rcm_mod_balgn - call xmlInp%Set_Val(eeta_cutoff,"params/eeta_cutoff",0.05) ! as a fraction - - !Charge exchange - call xmlInp%Set_Val(kill_fudge,"chargex/kill_fudge",.false.) ! .true. means no loss - if (kill_fudge) then - fudgec = 0.0 - endif - call xmlInp%Set_Val(L_dktime,"chargex/L_dktime",.true.) - call xmlInp%Set_Val(sunspot_number,"chargex/sunspot_number",96.0) - - !Clawpack options - call xmlInp%Set_Val(L_doOMPClaw,"clawpack/doOMPClaw",L_doOMPClaw) - - !Averaging timescale for plasmasphere - call xmlInp%Set_Val(dtAvg_v,"plasmasphere/tAvg",60.0) - - call xmlInp%Set_Val(doNoBndFlow,"experimental/doNoBndFlow",.false.) - call xmlInp%Set_Val(nNBFL,"experimental/NBFLayers",nNBFL) - - !Some values just setting - tol_gmres = 1.0e-5 - itype_bf = 3 ! 1 is interpolate for HV, 2--MHD code, 3--receive through module - i_advect = 3 ! 1-interpolate, 2rCLAWPACK/inter, 3-CLAWPACK - i_eta_bc = 2! 1-time-dep. from file, 2-constant for run - i_birk = 1 ! birk calculation 1=default 3 = new - end subroutine RCM_Params_XML - - ! - END SUBROUTINE Rcm -! -! - - !K: HDF5 version of lifetime reader - SUBROUTINE Read_dktime_H5(L_dktime) - use ioh5 - use files - IMPLICIT NONE - LOGICAL, INTENT (IN) :: L_dktime - logical :: doSP - type(IOVAR_T), dimension(RCMIOVARS) :: IOVars !Lazy hard-coding max variables - - !real(rprec) :: dktime2(irdk,inrgdk,isodk, iondk) - Call CheckFileOrDie(RCMGAMConfig,"RCM-Config H5 file does not exist.") - - if (L_dktime) then - !Read from HDF5 - doSP = .false. - call ClearIO(IOVars) !Reset IO chain - call AddInVar(IOVars,"dktable") - call ReadVars(IOVars,doSP,RCMGAMConfig) - - dktime = reshape(IOVars(1)%data,[irdk,inrgdk,isodk, iondk]) - - endif - END SUBROUTINE Read_dktime_H5 - - - - FUNCTION Cexrat (isp,enrg,rloc,ssn,dktime,irdk,inrgdk,isoldk, & - iondk) - IMPLICIT NONE - INTEGER(iprec), INTENT (IN) :: isp, irdk, inrgdk, isoldk, iondk - REAL(rprec), INTENT (IN) :: enrg, rloc, ssn, dktime (irdk,inrgdk,isoldk,iondk) - REAL(rprec) :: Cexrat -! -!------------------------------------------------------------------------- -! copyright rice university, 1993 -! -! version 1.00 05.09.90 -! 2.00 02.04.90 -! msm delivery version -! 2.10 06.11.93 -! error output routed to unit 9 -! -! programmer: r. w. spiro -! -! purpose: function subprogram to return charge exchange loss rate -! (sec**(-1)) for ions of species isp, energy enrg (ev) at -! l=rloc (re) for sunspot number ssn. this routine is based -! on a table generated by james bishop of u. of michigan. -! -! calling parameters -! isp species identifier -! isp=2 for h+ ions -! isp=3 for o+ ions -! enrg energy in ev -! rloc radial location (re) -! ssn sunspot number -! dktime table of ion decay times -! irdk radial dimension of dktime array -! inrgdk energy dimension of dktime array -! isoldk sunspot number dimension of dktime array -! iondk number of ion species in dktime array -!-------------------------------------------------------------------------------- -! - INTEGER(iprec), PARAMETER ::irsiz=18,inrgsz=13,isolsz=2,ionsiz=2 - REAL(rprec) :: elgvec(inrgsz), rvec(irsiz),ssnvec(2), & - enrglg, br, bnrg, ssnuse, bssn, decayt - INTEGER(iprec) :: ispndx, ir, inrg -! - DATA elgvec /2.50,2.75,3.00,3.25,3.50,3.75,4.00, & - 4.25,4.50,4.75,5.00,5.25,5.50/ -! - DATA rvec /1.50,2.00,2.50,3.00, & - 3.50,4.00,4.50,5.00, & - 5.50,6.00,6.50,7.00, & - 7.50,8.00,8.50,9.00, & - 9.50,10.00/ -! - DATA ssnvec /0.0,100./ -! -! - IF (irsiz /= irdk .OR. inrgsz /= inrgdk .OR. & - ionsiz /= iondk .OR. isolsz /= isoldk) THEN - write(*,*) 'dimension error in function cexrat' - write(*,*) 'irdk,inrgdk,iondk,isoldk',irdk,inrgdk,iondk,isoldk - write(*,*) 'irsiz,inrgsz,ionsiz,isolsz',irsiz,inrgsz,ionsiz,isolsz - write(*,*) 'stopping program in cexrat' - STOP - END IF -! - enrglg = LOG10(enrg) ! work with log10 of particle energy - ispndx=isp-1 -! - if_1: IF (rloc <= rvec(1)) THEN ! find br for interpolation - br=1.0 - ELSE IF (rloc > rvec(irdk)) THEN - br=irdk - ELSE - do_1: DO ir=1,irdk-1 - IF (rloc <= rvec(ir+1)) THEN - br=ir+(rloc-rvec(ir))/(rvec(ir+1)-rvec(ir)) - EXIT do_1 - END IF - END DO do_1 - END IF if_1 -! - if_2: IF (enrglg.le.elgvec(1)) THEN ! find bnrg for interpolation - bnrg = 1.0 - ELSE IF (enrglg > elgvec(inrgdk)) THEN - bnrg = inrgdk - ELSE - do_2: DO inrg=1,inrgdk-1 - IF (enrglg <= elgvec(inrg+1)) THEN - bnrg=inrg+(enrglg-elgvec(inrg))/(elgvec(inrg+1)-elgvec(inrg)) - EXIT do_2 - END IF - END DO do_2 - END IF if_2 -! -!********** change 9/30/91 ***************************************** -! if ssn.gt.ssnvec(2), then use ssnvec(2) for ssn - ssnuse=ssn - IF (ssnuse > ssnvec(2)) ssnuse=ssnvec(2) -! -!********* end change 9/30/91 ************************************ -! -! find bssn for interpolation - bssn=1.0+(ssnuse-ssnvec(1))/(ssnvec(2)-ssnvec(1)) -! -! decayt is decay time in seconds - - decayt = G3ntrp (dktime(1_iprec,1_iprec,1_iprec,ispndx),irdk,inrgdk,isoldk,br,bnrg,bssn) -! - IF (ABS(decayt) < 1.0E-20) THEN - write(*,*) 'decayt is less than 1.e-20 sec in cexrat' - write(*,*) 'decayt=',decayt,' br=',br,' bnrg=',bnrg,'bssn=',bssn - write(*,*) 'isp=',isp,' enrg=',enrg,' rloc=',rloc,' ssn=',ssn - write(*,*) 'ssnuse=',ssnuse - END IF -! -! to get charge exchange rate (sec**9-1)) cexrat, invert decayt -! - cexrat=1.0/decayt - RETURN - END FUNCTION Cexrat -! -! - FUNCTION G3ntrp (a,imax,jmax,kmax,bi,bj,bk) - IMPLICIT NONE - INTEGER(iprec), INTENT (IN) :: imax, jmax, kmax - REAL(rprec), INTENT (IN) :: a(imax,jmax,kmax), bi, bj, bk - REAL(rprec) :: G3ntrp -! -!--------------------------------------------------------------------------- -! copyright Rice University, 1993 -! -! VERSION 1.00 DATE: 01.11.88 -! 1.01A 02.02.89 -! 2.00 MSM DELIVERY VERSION 01.28.93 -! -! PURPOSE: FUNCTION SUBPROGRAM TO PERFORM A GENERAL 3-D LINEAR -! INTERPOLATION OF ARRAY A(I,J,K) AT PT(BV(1),BV(2),BV(3)) -! -! INPUT: -! A 3-D ARRAY TO BE INTERPOLATED -! IMAX I DIMENSION OF ARRAY A -! JMAX J DIMENSION OF ARRAY A -! KMAX K DIMENSION OF ARRAY A -! BI FLOATING POINT VALUE TO INTERPOLATE IN I DIMENSION -! BJ FLOATING POINT VALUE TO INTERPOLATE IN J DIMENSION -! BK FLOATING POINT VALUE TO INTERPOLATE IN K DIMENSION -! -! -! OUTPUT: -! G3NTRP INTERPOLATED VALUES OF ARRAY A -!---------------------------------------------------------------------- -! -! - INTEGER(iprec) :: ndx(3),ndim(3), kstop, jstop, L, i, j, k - REAL(rprec) :: BV(3),COEF(3,2), fndx -! - NDIM(1)=IMAX - NDIM(2)=JMAX - NDIM(3)=KMAX - BV(1)=BI - BV(2)=BJ - BV(3)=BK - DO L=1,3 - NDX(L)=BV(L) - IF(NDX(L).LT.1) NDX(L)=1 - IF(NDX(L).GT.NDIM(L)-1) NDX(L)=NDIM(L)-1 - IF(NDX(L).LE.0) NDX(L)=1 - FNDX=REAL(NDX(L)) - COEF(L,1)=1.-BV(L)+FNDX - COEF(L,2)=BV(L)-FNDX - END DO -! - G3NTRP=0. - kstop = MIN(KMAX,2) - jstop = MIN(JMAX,2) - DO I=1,2 - DO J=1,jstop - DO K=1,kstop - G3ntrp=G3ntrp+ & - coef(1,i)*coef(2,j)*coef(3,k)*a(ndx(1)+i-1,ndx(2)+j-1,ndx(3)+k-1) - END DO - END DO - END DO -! - RETURN - END FUNCTION G3ntrp -! -!========================================================================= - - -!========================================================================= -! -!Advance eeta by dt nstep times, dtcpl=dt x nstep - -SUBROUTINE Move_plasma_grid_MHD (dt,nstep) - use rice_housekeeping_module, ONLY : LowLatMHD,doNewCX,ELOSSMETHOD,dozeroLoss,doFLCLoss,dp_on,doPPRefill,doSmoothDDV,staticR,NowKp - use math, ONLY : SmoothOpTSC,SmoothOperator33 - use lossutils, ONLY : CXKaiju,FLCRat - use planethelper, ONLY : DipFTV_colat,DerivDipFTV - use constants, ONLY : nt,radius_earth_m - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: dt - INTEGER (iprec), INTENT(IN) :: nstep - - !Clawpack-sized grids - REAL (rprec), dimension(-1:isize+2,-1:jsize-1) :: etaC - !Clawpack x Nk sized grids - REAL (rprec), dimension(-1:isize+2,-1:jsize-1,1:kcsize) :: didt,djdt,rateC - !RCM-sized grids - REAL (rprec), dimension( 1:isize , 1:jsize ) :: rate,dvedi,dvedj,vv,dvvdi,dvvdj,dvmdi,dvmdj - REAL (rprec), dimension( 1:isize , 1:jsize ) :: vv_avg,dvvdi_avg,dvvdj_avg - - REAL (rprec), dimension( 1:isize , 1:jsize ) :: ftv,dftvi,dftvj - - LOGICAL, dimension(1:isize,1:jsize) :: isOpen - INTEGER, dimension(1:isize,1:jsize) :: ocbDist - INTEGER (iprec) :: iOCB_j(1:jsize) - REAL (rprec) :: mass_factor,r_dist,lossCX,lossFLC - REAL (rprec), dimension(2) :: lossFT - REAL (rprec), save :: xlower,xupper,ylower,yupper, T1,T2 !Does this need save? - INTEGER (iprec) :: i, j, kc, ie, iL,jL,iR,jR,iMHD,n - INTEGER (iprec) :: CLAWiter, joff - - REAL (rprec) :: T1k,T2k !Local loop variables b/c clawpack alters input - LOGICAL, save :: FirstTime=.true. - - call Tic("Move_Plasma_Init") - if (jwrap /= 3) then - write(*,*) 'Somebody should rewrite this code to not assume that jwrap=3' - stop - endif - - !Doing silly thing to find i of MHD's lowlat BC - do i=1,isize - if (0.5*PI-colat(i,jwrap) <= LowLatMHD) exit - enddo - iMHD = i !low-lat boundary for MHD on RCM grid - - !--- - !Do prep work - where (eeta<0) - eeta = 0.0 - endwhere - - eeta_avg = 0.0 - joff=jwrap-1 - - if (FirstTime) then - T1=0. - FirstTime = .false. - else - T1=T2 - end if - - T2=T1+dt - - xlower = 1 - xupper = isize - ylower = 0.0 - yupper = jsize-3 - - !--- - !Get OCB - isOpen = (vm < 0) - do j=1,jsize - if (any(isOpen(:,j))) then - !Some open cells on this column - do i=isize,1,-1 - if (isOpen(i,j)) exit - enddo - iOCB_j(j) = i - else - !No open cells here - iOCB_j(j) = 0 - endif - enddo !j loop - - if (doNoBndFlow) then - ocbDist = OCBMap(isOpen,nNBFL) - endif - - !--- - !Calculate node-centered IJ gradients for use inside loop (instead of redoing for each channel) - !veff = v + vcorot - vpar + vm*alamc(k) = vv + vm*alamc(k) - - !Do array-sized prep work - !$OMP PARALLEL WORKSHARE if (L_doOMPClaw) - fac = 1.0E-3*signbe*bir*alpha*beta*dlam*dpsi*ri**2 - vv = v + vcorot - vpar !Current potential - vv_avg = v_avg + vcorot - vpar !Time-averaged potential for plasmasphere - - where (.not. isOpen) - !Using ftv directly w/ possible intermediate smoothing - ftv = vm**(-3.0/2) - elsewhere - ftv = 0.0 - endwhere - !$OMP END PARALLEL WORKSHARE - - !Get IJ gradients of potential - call Grad_IJ(vv ,isOpen,dvvdi ,dvvdj ) - call Grad_IJ(vv_avg,isOpen,dvvdi_avg,dvvdj_avg) - - !Zero out velocities below staticR if necessary - if (staticR > TINY) then - where ( rmin <= staticR ) - dvvdi_avg = 0.0 - dvvdj_avg = 0.0 - endwhere - endif - - !Now get energy-dep. portion, grad_ij vm - call FTVGrad(ftv,isOpen,dftvi,dftvj) - - !$OMP PARALLEL WORKSHARE if (L_doOMPClaw) - dvmdi = (-2.0/3.0)*(ftv**(-5.0/3.0))*dftvi - dvmdj = (-2.0/3.0)*(ftv**(-5.0/3.0))*dftvj - !Calculate plasmasphere density forall i,j once - Dpp = (1.0e-6)*eeta(:,:,1)*dfactor*vm**1.5 !Convert eta to #/cc - !$OMP END PARALLEL WORKSHARE - - call Toc("Move_Plasma_Init") - -!--- -!Now calculate things that won't change over the substepping - call Tic("Move_Plasma_preAdv") - !ie, di/dj-dt, lossratep/rate - rate = 0.0 - lossratep = 0.0 - lossmodel = -1.0 - didt = 0.0 - djdt = 0.0 - - !$OMP PARALLEL DO if (L_doOMPClaw) & - !$OMP schedule(dynamic) & - !$OMP DEFAULT(SHARED) & - !$OMP private(i,j,kc,ie,iL,jL,iR,jR,rate,dvedi,dvedj) & - !$OMP private(mass_factor,r_dist,lossCX,lossFLC,lossFT) - DO kc = kcsize,1,-1 - !Skip boring channels - IF (.not. advChannel(kc)) CYCLE - IF (MAXVAL(eeta(:,:,kc)) < machine_tiny) THEN - eeta(:,:,kc) = 0.0 - advChannel(kc) = .false. - CYCLE - ENDIF - - !If oxygen is to be added, must change this! - IF (alamc(kc) <= 0.0) THEN - ie = RCMELECTRON - ELSE - ie = RCMPROTON - END IF - - mass_factor = SQRT (xmass(1)/xmass(ie)) - - !--- - !Get "interface" velocities on clawpack grid, |-1:isize+2,-1:jsize-1| - !Start by calculating dvedi,dvedj = grad_ij (veff) = grad_ij (vv) + alamc(k)*grad_ij vm - if ( (abs(alamc(kc))TINY) ) then - !Do plasmasphere effective potential, uses averaged potential and no energy dep. portion - dvedi = dvvdi_avg - dvedj = dvvdj_avg - else - !Any other RC channel - dvedi = dvvdi + alamc(kc)*dvmdi - dvedj = dvvdj + alamc(kc)*dvmdj - endif - !Now loop over clawpack grid interfaces and calculate velocities - didt(:,:,kc) = 0.0 - djdt(:,:,kc) = 0.0 - - do j=1,jsize-1 !clawpack jdim - do i=isize,2,-1 - - !I interface - - !Clawpack i,j I-interface is betwen RCM nodes i-1,j+jwrap-1 and i,j+wrap-1 - ! i.e., i,j:I => i-1,j+joff / i,j+joff - iL = i-1; jL = WrapJ(j+joff) - iR = i ; jR = WrapJ(j+joff) - - didt(i,j,kc) = CalcInterface(isOpen(iL,jL),dvedj(iL,jL),fac(iL,jL), & - isOpen(iR,jR),dvedj(iR,jR),fac(iR,jR) ) - - !J interface - !Clawpack i,j J-interface is between RCM nodes i,j+joff-1 and i,j+joff - iL = i; jL = WrapJ(j+joff-1) - iR = i; jR = WrapJ(j+joff ) - - !Note extra - in dvedi part of call - djdt(i,j,kc) = CalcInterface(isOpen(iL,jL),-dvedi(iL,jL),fac(iL,jL), & - isOpen(iR,jR),-dvedi(iR,jR),fac(iR,jR) ) - - enddo - enddo !j loop - - !Freeze flow too close to MHD inner boundary - didt(iMHD-1:,:,kc) = 0.0 - djdt(iMHD+1:,:,kc) = 0.0 - - !Freeze flow into the domain, only move stuff around from MHD buffer - didt(1:2,:,kc) = 0.0 - djdt(1 ,:,kc) = 0.0 - - !Halt inflow from buffer cells right next to ocb - if (doNoBndFlow) then - call NoBoundaryFlow(ocbDist,didt(:,:,kc),djdt(:,:,kc),nNBFL) - endif - - call PadClaw(didt(:,:,kc)) - call PadClaw(djdt(:,:,kc)) - - !--- - !Calculate loss terms on clawpack grid - !Start w/ loss term on RCM grid - if (.not. doZeroLoss) then - do j=1,jsize - do i=1,isize - !Do some init - lossCX = 0.0 - lossFLC = 0.0 - lossFT = 0.0 - lossratep(i,j,kc) = 0.0 - lossmodel(i,j,kc) = -1.0 ! -1: undefined; 0: C05; 1: chorus; 2: hiss; 3: C+H; 4: strong diffusion; 5: fudge; 10: ion FLC. - rate(i,j) = 0.0 - - if (isOpen(i,j)) then - rate(i,j) = -TINY !Set negative value to signal clawpack source term - cycle - endif - - !Calculate losses and keep track of total losses/precip losses - if ( (ie == RCMELECTRON) .and. (kc /= 1) ) then - !Do electron losses - lossFT = Ratefn(xmin(i,j),ymin(i,j),alamc(kc),vm(i,j),bmin(i,j),losscone(i,j),Dpp(i,j),NowKp,fudgec(kc),sini(i,j),bir(i,j),mass_factor,ELOSSMETHOD) - lossratep(i,j,kc) = lossratep(i,j,kc) + lossFT(1) - lossmodel(i,j,kc) = lossFT(2) - rate(i,j) = rate(i,j) + lossFT(1) - endif - - if (ie == RCMPROTON) then - !Do ion losses - r_dist = sqrt(xmin(i,j)**2+ymin(i,j)**2) - if ( L_dktime ) then - lossCX = CXKaiju(ie,abs(alamc(kc))*vm(i,j),r_dist) - endif - if (doFLCLoss) then - lossFLC = FLCRat(ie,alamc(kc),vm(i,j),bmin(i,j),radcurv(i,j),losscone(i,j)) - endif - lossratep(i,j,kc) = lossratep(i,j,kc) + lossFLC - lossmodel(i,j,kc) = 10.0 - rate(i,j) = rate(i,j) + lossFLC + lossCX - endif - - enddo !i loop - enddo !j loop - else - rate = 0.0 - endif - !Have loss on RCM grid, now get claw grid - call rcm2claw(rate,rateC(:,:,kc)) - ENDDO !kc loop - call Toc("Move_Plasma_preAdv") - -!Done static (per coupling) things, now substep and advect - call Tic("Move_Plasma_Adv") - !--- - !Main channel loop - !NOTE: T1k/T2k need to be private b/c they're altered by claw2ez - - !$OMP PARALLEL DO if (L_doOMPClaw) & - !$OMP schedule(dynamic) & - !$OMP DEFAULT(SHARED) & - !$OMP private(i,j,kc,n,T1k,T2k,CLAWiter,etaC) - DO kc = kcsize,1,-1 - !Skip boring channels - IF (.not. advChannel(kc)) CYCLE - IF (MAXVAL(eeta(:,:,kc)) < machine_tiny) THEN - eeta(:,:,kc) = 0.0 - CYCLE - ENDIF - - eeta_avg(:,:,kc) = 0.0 - if ( (kc==1) .and. (.not. dp_on)) then ! We are plasmasphere and we don't want to evolve it - ! Just set eeta_avg to whatever eta is there, and leave - !! Note: Regions that have ever been outside of active domain will never have psph again, based on current implementation (2023-08-24) - eeta_avg(:,:,kc) = eeta(:,:,kc) - cycle - else ! We are hot channel or we are evolving plasmasphere channel - ! Add current weighted eeta as first contribution - eeta_avg(:,:,kc) = eeta(:,:,kc)/(nstep+1) - endif - - !Sub-step nstep times - do n=1,nstep - !--- - !Tally precipitation losses - deleeta(:,:,kc) = deleeta(:,:,kc) + eeta(:,:,kc)*(1.0-exp(-lossratep(:,:,kc)*dt)) - call circle(deleeta(:,:,kc)) - - !--- - !Do clawpack call - call rcm2claw(eeta(:,:,kc),etaC) - !Call clawpack, always as first time - !Need local copies b/c clawpack alters T1/T2 - T1k = T1 - T2k = T2 - call claw2ez(.true.,T1k,T2k,xlower,xupper,ylower,yupper, & - CLAWiter,2,isize-1+1,jsize-3,etaC,didt(:,:,kc),djdt(:,:,kc),rateC(:,:,kc)) - !--- - !Unpack and finish up - !Copy out - do j=j1,j2 !jwrap,jsize-1 - do i=1,isize-1 - if (isOpen(i,j)) then - eeta(i,j,kc) = 0.0 - else - eeta(i,j,kc) = max(etaC(i,j-joff),0.0) - endif - enddo - enddo - eeta(:,jsize,kc) = eeta(:,jwrap,kc) - call circle(eeta(:,:,kc)) - - if ( (kc==1) .and. dp_on .and. doPPRefill) then - !refill the plasmasphere 04012020 sbao - !K: Added kc==1 check 8/11/20 - call Kaiju_Plasmasphere_Refill(eeta(:,:,1), xmin,ymin, aloct, vm, imin_j,dt) - call circle(eeta(:,:,kc)) !Probably don't need to re-circle - endif - - eeta_avg(:,:,kc) = eeta_avg(:,:,kc) + eeta(:,:,kc)/(nstep+1) - enddo !substep loop - - enddo !Main kc loop - - call Toc("Move_Plasma_Adv") - - contains - - !Calculate RCM-node centered gradient of FTV - subroutine FTVGrad(ftv,isOpen,dftvdi,dftvdj) - REAL (rprec), dimension(1:isize,1:jsize), intent(IN) :: ftv - REAL (rprec), dimension(1:isize,1:jsize), intent(OUT) :: dftvdi,dftvdj - LOGICAL , dimension(1:isize,1:jsize), intent(IN) :: isOpen - - REAL (rprec), dimension(1:isize,1:jsize) :: V0,dV - REAL (rprec), dimension(1:isize,1:jsize) :: dV0i,dV0j,ddVi,ddVj - - INTEGER (iprec) :: i - REAL (rprec) :: cl,dcldi,dv0dcl - - !Calculate dipole FTV - do i=1,isize - cl = colat(i,jwrap) - V0(i,:) = DipFTV_colat(cl) - enddo - - !Now decompose the two contributions - dV = 0.0 - where (.not. isOpen) - dV = ftv - V0 - endwhere - - !Take gradients of each - !Grad of dipole, analytic - dV0i = 0.0 - dV0j = 0.0 - do i=2,isize-1 - dcldi = 0.5*(colat(i+1,jwrap)-colat(i-1,jwrap)) - cl = colat(i,jwrap) - dv0dcl = DerivDipFTV(cl) - dV0i(i,:) = dv0dcl*dcldi - enddo - - !Grad of perturbation - call Grad_IJ(dV,isOpen,ddVi,ddVj,doLimO=.true. ) - - !Possibly smooth grad of perturbation - if (doSmoothDDV) then - call Smooth_IJ(ddVi,isOpen) - call Smooth_IJ(ddVj,isOpen) - endif - - !Recombine pieces - dftvdi = dV0i + ddVi - dftvdj = dV0j + ddVj - - !Old calculation, just do raw gradient - !call Grad_IJ(ftv,isOpen,dftvdi,dftvdj) - - end subroutine FTVGrad - - - !Do smoothing window on RCM grid quantity - subroutine Smooth_IJ(Q,isOpen) - REAL (rprec), dimension(1:isize,1:jsize), intent(INOUT) :: Q - LOGICAL , dimension(1:isize,1:jsize), intent(IN) :: isOpen - REAL (rprec), dimension(1:isize,1:jsize) :: Qs - REAL (rprec), dimension(3,3) :: Q33 - LOGICAL , dimension(3,3) :: G33 - - INTEGER (iprec) :: i,j - - Qs = Q - - !$OMP PARALLEL DO if (L_doOMPClaw) & - !$OMP DEFAULT (SHARED) & - !$OMP PRIVATE(i,j,Q33,G33) - do j=j1,j2 !jwrap,jsize-1 - do i=2,isize-1 - Q33(:,:) = Q(i-1:i+1,j-1:j+1) - G33(:,:) = .not. isOpen(i-1:i+1,j-1:j+1) !Only smooth w/ good cells - Qs(i,j) = SmoothOperator33(Q33,G33) - enddo - enddo - - Qs(:,jsize) = Qs(:,jwrap) - call circle(Qs) - Q = Qs !Save back smoothed array - - end subroutine Smooth_IJ - - !Copy variable from rcm to clawpack grid - subroutine rcm2claw(qR,qC) - REAL (rprec), dimension( 1:isize , 1:jsize ), intent(IN) :: qR - REAL (rprec), dimension(-1:isize+2,-1:jsize-1), intent(OUT) :: qC - - !Center patch - qC(1:isize,1:jsize-jwrap) = qR(1:isize,jwrap:jsize-1) - call PadClaw(qC) - - end subroutine rcm2claw - - !Fill padding of a clawpack grid - subroutine PadClaw(qC) - REAL (rprec), dimension(-1:isize+2,-1:jsize-1), intent(INOUT) :: qC - INTEGER (iprec) :: i, j - !Pole - do i=-1,0 - qC(i,j1-joff:j2-joff) = qC(1,j1-joff:j2-joff) - enddo - - !Equator - do i=isize+1,isize+2 - qC(i,j1-joff:j2-joff) = qC(isize,j1-joff:j2-joff) - enddo - - !Periodic - qC(:,-1:0) = qC(:,jsize-4:jsize-3) - qC(:,jsize-joff:jsize-joff+1) = qC(:,1:2) - end subroutine PadClaw - - subroutine NoBoundaryFlow(ocbDist,didt,djdt,nL0) - !Zero flow coming from the direction of the open/closed boundary or cells nL distance from ocb - !Flow towards the ocb is left alone - integer, dimension(1:isize,1:jsize), intent(in) :: ocbDist - real (rp), dimension(-1:isize+2,-1:jsize-1), intent(inout) :: didt,djdt - integer, intent(in), optional :: nL0 ! Number of i layers inward of o/c boundary to act upon - - integer :: nL - integer :: i,j, jW, jWm1, jWp1 - - if(present(nL0)) then - nL = nL0 - else - nL = 2 - endif - - !Gonna ignore odd dvdti,j indicies and assume PadClaw is gonna work things out later - - !First, populate open/closed boundary dist map - ! !! Only strictly a distance for values <= nL, if greater then we don't care - - !Now kill some velocities - !$OMP PARALLEL DO if (L_doOMPClaw) & - !$OMP schedule(dynamic) & - !$OMP DEFAULT(SHARED) & - !$OMP private(i,j,jW,jWm1,jWp1) - do j=1,jsize-1 !clawpack jdim - do i=2,isize - jW = WrapJ(j + joff) - jWm1 = WrapJ(j + joff - 1) - jWp1 = WrapJ(j + joff + 1) - - if (ocbDist(i,jW) .eq. 0) then - cycle - else if (ocbDist(i,jW) .le. nL ) then - ! Zap - if ( (ocbDist(i-1,jW) .lt. ocbDist(i,jW)) .and. (didt(i-1,j) .gt. 0) ) then ! lower i - didt(i-1,j) = 0 - else if ( (ocbDist(i+1,jW) .lt. ocbDist(i,jW)) .and. (didt(i+1,j) .lt. 0) ) then ! upper i - didt(i+1,j) = 0 - else if ( (ocbDist(i,jWm1) .lt. ocbDist(i,jW)) .and. (djdt(i,j-1) .gt. 0) ) then ! lower j - djdt(i,j-1) = 0 - else if ( (ocbDist(i,jWp1) .lt. ocbDist(i,jW)) .and. (djdt(i,j+1) .lt. 0) ) then ! upper j - djdt(i,j+1) = 0 - endif - !else ! If we aren't next to any layers lower than the one we're currently on, we're done - ! exit - endif - enddo !i loop - enddo !j loop - - end subroutine NoBoundaryFlow - - function CalcInterface(isOpL,dvL,facL,isOpR,dvR,facR) result(dxdt) - LOGICAL, intent(IN) :: isOpL,isOpR - REAL (rprec), intent(IN) :: dvL,dvR,facL,facR - REAL (rprec) :: dxdt - - REAL (rprec) :: dvAvg,fAvg - if (isOpL .and. isOpR) then - !Both sides are bad, no flow - dxdt = 0.0 - - else if ( (.not. isOpL) .and. (.not. isOpR) ) then - !Both sides are good, do basic averaging - dvAvg = 0.5*( dvL + dvR) - fAvg = 0.5*(facL + facR) - dxdt = dvAvg/fAvg - else if (isOpL) then - !Left = Open / Right = Closed - !Use right velocity if it's leftward - dxdt = min(0.0,dvR/facR) - else if (isOpR) then - !Left = Closed / Right = Open - !Use left velocity if it's rightward - dxdt = max(0.0,dvL/facL) - endif - end function CalcInterface - - - !Wrap around large indices, jwrap<=>jsize seem to be repeated points on axis - !So jsize+1 => jwrap+1, i.e. j=>j-jsize+jwrap - function WrapJ(j) result(jp) - INTEGER (iprec), intent(IN) :: j - INTEGER (iprec) :: jp - - if (j>jsize) then - jp = j-jsize+jwrap - else - jp = j - endif - end function WrapJ - - function OCBMap(isOp, nL0) result (ocbDist) - !Calculate and label cells within nL cells (including diagonal direction) from the ocb - logical, dimension(1:isize,1:jsize), intent(in) :: isOp - integer, intent(in), optional :: nL0 ! Number of i layers inward of o/c boundary to act upon - - integer :: nL - integer, dimension(1:isize,1:jsize) :: ocbDist ! Cell's distance from closest open field cell - integer :: i,j,iL - - if(present(nL0)) then - nL = nL0 - else - nL = 2 - endif - - where (isOp) - ocbDist = 0 - elsewhere - ocbDist = nL + 1 - end where - - do iL=1,nL - !write(*,*) "il=",iL - do j=2,jsize-1 !clawpack jdim - do i=2,isize-1 - if (isOp(i,j)) then - cycle - else if (any(ocbDist(i-1:i+1,j-1:j+1) .eq. iL-1) .and. (ocbDist(i,j) .eq. nL+1)) then ! ignore value of current cell - !write(*,*) "i,j=",i,j - !write(*,*) ocbDist(i-1:i+1,j-1:j+1) - !write(*,*) any(ocbDist(i-1:i+1,j-1:j+1) .eq. iL-1) - !write(*,*) (ocbDist(i,j) .ne. iL-1) - ocbDist(i,j) = iL - !!Find a better way to determine when we can quit - !else ! If we aren't next to any layers lower than the one we're currently on, we're done - ! exit !This doesn't do anything except try to save time - !! Might not want to do this, in case you get some odd open-closed-open lobes - endif - enddo !i loop - enddo !j loop - enddo !layer loop - - if (doRCMVerboseH5) then - last_ocbDist = ocbDist - endif - - if (.false.) then - do j=1,jsize - write(*,*) "j=",j - write(*,*) ocbDist(:,j) - enddo - endif - end function OCBMap - -END SUBROUTINE Move_plasma_grid_MHD - -!Calculate RCM-node centered gradient of veff -subroutine Grad_IJ(veff,isOpen,dvedi,dvedj,doLimO) - REAL (rprec), dimension(1:isize,1:jsize), intent(IN) :: veff - REAL (rprec), dimension(1:isize,1:jsize), intent(OUT) :: dvedi,dvedj - LOGICAL , dimension(1:isize,1:jsize), intent(IN) :: isOpen - LOGICAL, intent(in), optional :: doLimO - - INTEGER (iprec) :: i,j - - LOGICAL :: isOp(3),doLim - REAL (rprec) :: Q(3) - - if (present(doLimO)) then - doLim = doLimO - else - doLim = .true. - endif - - dvedi = 0.0 - dvedj = 0.0 - - !$OMP PARALLEL DO if (L_doOMPClaw) & - !$OMP DEFAULT (NONE) & - !$OMP PRIVATE(i,j,isOp,Q) & - !$OMP SHARED(dvedi,dvedj,veff,isOpen,doLim) - do j=2,jsize-1 - do i=2,isize-1 - !Do I deriv - Q = veff (i-1:i+1,j) - isOp = isOpen(i-1:i+1,j) - dvedi(i,j) = Deriv_IJ(Q,isOp,doLim) - - !Do J deriv - Q = veff (i,j-1:j+1) - isOp = isOpen(i,j-1:j+1) - dvedj(i,j) = Deriv_IJ(Q,isOp,doLim) - enddo - enddo - -!Lower/Upper boundary - dvedi(1,:) = dvedi(2,:) - dvedj(1,:) = dvedj(2,:) - - dvedi(isize,:) = dvedi(isize-1,:) - dvedj(isize,:) = dvedj(isize-1,:) -!Periodic - dvedi(:,jsize) = dvedi(:,jwrap ) - dvedi(:,1 ) = dvedi(:,jsize-2) - - dvedj(:,jsize) = dvedj(:,jwrap ) - dvedj(:,1 ) = dvedj(:,jsize-2) -end subroutine Grad_IJ - -!Take derivative from 3-point stencil if possible -function Deriv_IJ(Q,isOp,doLim) result(dvdx) - LOGICAL , intent(IN) :: isOp(-1:+1) - REAL (rprec), intent(IN) :: Q(-1:+1) - LOGICAL , intent(IN) :: doLim - - LOGICAL, parameter :: doSuperBee = .false. !Use superbee (instead of minmod/MC) - REAL (rprec) :: dvdx - REAL (rprec) :: dvL,dvR,dvC - dvdx = 0.0 - - if (isOp(0)) return - - !If still here then central point is closed - if (isOp(-1) .and. isOp(+1)) then - !Nothing to work with - return - endif - !Have at least two points - if ((.not. isOp(-1)) .and. (.not. isOp(+1))) then - !Both sides closed - - !dvdx = 0.5*(Q(+1)-Q(-1)) !Straight up centered derivative - dvL = Q( 0) - Q(-1) - dvR = Q(+1) - Q( 0) - dvC = 0.5*( Q(+1) - Q(-1) ) - - if (doLim) then - !Do slope limiter, either minmod or superbee - if (doSuperBee) then - !Superbee slope-lim on gradient - dvdx = qkmaxmod( qkminmod(dvR,2*dvL),qkminmod(2*dvR,dvL) ) - else - dvdx = MCLim(dvL,dvR,dvC) - !dvdx = qkminmod(dvL,dvR) !Just minmod lim - endif - else - !Take straight centered difference - dvdx = dvC - endif - - else if (.not. isOp(-1)) then - !-1 is closed, do backward difference - dvdx = Q(0)-Q(-1) - else - !+1 is closed, do forward difference - dvdx = Q(+1)-Q(0) - endif - - contains - function MCLim(dqL,dqR,dqC) result(dqbar) - REAL (rprec), intent(in) :: dqL,dqR,dqC - REAL (rprec) :: dqbar - REAL (rprec) :: magdq - - if (dqL*dqR <= 0) then - !Sign flip, clamp - dqbar = 0.0 - else - !Consistent sense, use MC limiter - magdq = min(2*abs(dqL),2*abs(dqR),abs(dqC)) - !SIGN(A,B) returns the value of A with the sign of B - dqbar = sign(magdq,dqC) - endif - end function MCLim - - !Quick and lazy minmod limiter - function qkminmod(a,b) result(c) - REAL (rprec), intent(in) :: a,b - REAL (rprec) :: c - - if (a*b > 0) then - !Pick min modulus - if (abs(a) < abs(b)) then - c = a - else - c = b - endif !No sign flip - else - c = 0.0 - endif - end function qkminmod - - !Quick and laxy maxmod limiter - function qkmaxmod(a,b) result(c) - REAL (rprec), intent(in) :: a,b - REAL (rprec) :: c - - if (a*b > 0) then - !Pick max modulus - if (abs(a) < abs(b)) then - c = b - else - c = a - endif !No sign flip - else - c = 0.0 - endif - end function qkmaxmod - -end function Deriv_IJ - -!Adapted by K: from S. Bao's adaptation of Colby Lemon's code, 09/20 - -SUBROUTINE Kaiju_Plasmasphere_Refill(eeta0,xmin,ymin,aloct,vm,imin_j,idt) - use rice_housekeeping_module, ONLY : NowKp - use earthhelper, ONLY : GallagherXY - use rcmdefs, ONLY : DenPP0 - - implicit none - - REAL (rprec), intent(inout), dimension(isize,jsize) :: eeta0 - REAL (rprec), intent(in), dimension(isize,jsize) :: xmin,ymin, aloct, vm - REAL (rprec), intent(in) :: idt - INTEGER (iprec), intent(in), dimension(jsize) :: imin_j - - integer :: i,j - REAL (rprec) , parameter :: day2s = 24.0*60.0*60,s2day=1.0/day2s - REAL (rprec) :: dppT,dpsph,eta2cc,tau,etaT,deta,dndt - REAL (rprec) :: dpp0,rad,maxX - - dpp0 = 10*DenPP0 !Use 10x the plasmasphere cutoff density to decide on refilling - maxX = 2.0 !Max over-filling relative to target, i.e. don't go above maxX x den-target - - - do j=1,jsize - do i=1,isize - if (vm(i,j) <= 0) cycle - if (i < imin_j(j)+1) cycle !Don't refill outside active domain - - rad = sqrt( xmin(i,j)**2.0 + ymin(i,j)**2.0 ) - - !Closed field line, calculate Berbue+ 2005 density (#/cc) - !Or use Gallagher on nightside w/ NowKp (current Kp) - !dppT = 10.0**(-0.66*rad + 4.89) !Target refilled density [#/cc] - dppT = GallagherXY(xmin(i,j),ymin(i,j),NowKp) - - eta2cc = (1.0e-6)*dfactor*vm(i,j)**1.5 !Convert eta to #/cc - dpsph = eta2cc*eeta0(i,j) !Current plasmasphere density [#/cc] - - !Check for other outs before doing anything - if (dppT < dpp0) cycle !Target too low - !if (dpsph < dpp0) cycle !Current density too low to bother w/ - if (dpsph >= maxX*dppT) cycle !Too much already there - - etaT = dppT/eta2cc !Target eta for refilling - - !Now calculate refilling - dndt = 10.0**(3.48-0.331*rad) !cm^-3/day, Denton+ 2012 eqn 1 - !dndt = (cos(aloct(i,j))+1)*dndt !Bias refilling towards dayside - - deta = (idt*s2day)*dndt/eta2cc !Change in eta over idt - !deta = min(deta,etaT-eeta0(i,j)) !Don't overfill - - eeta0(i,j) = eeta0(i,j) + deta - - enddo - enddo - -END SUBROUTINE Kaiju_Plasmasphere_Refill - -!Adapted by S.Bao from Colby Lemon's original code. 04012020 sbao -SUBROUTINE Plasmasphere_Refilling_Model(eeta0, rmin, aloct, vm, idt) - - implicit none - REAL (rprec), intent(inout), dimension(isize,jsize) :: eeta0 - REAL (rprec), intent(in), dimension(isize,jsize) :: rmin, aloct, vm - REAL (rprec) :: den_increase(isize, jsize), ftv(isize,jsize) - REAL (rprec) :: idt - REAL (rprec) , parameter :: m_per_Re = 6380.e3 - REAL (rprec) , parameter :: nT_per_T = 1.e9 - REAL (rprec) , parameter :: cm_per_m = 1.e2 - where (vm > 0) - ftv = vm**(-3.0/2.0) - elsewhere - ftv = 0.0 ! open field lines, most likely. Set ftv to zero because we want eeta to be zero there - end where - - den_increase = (idt/1000.0/(24*60*60)) * 10**(3.01 - 0.322*rmin) * ftv * (m_per_Re * nT_per_T * cm_per_m**3) ! ple/cc - where (aloct < pi/2 .OR. aloct > 3*pi/2) ! If we are on the dayside - eeta0 = eeta0 + 1.8 * den_increase - elsewhere - eeta0 = eeta0 + 0.2 * den_increase - end where - - - ! Keep eeta0 between 0 and two times the Berube et al. 2005 density. - eeta0 = min(eeta0, 2*10**(4.56 - 0.51*rmin) * ftv * (m_per_Re*nT_per_T*cm_per_m**3)) - eeta0 = max(eeta0, 0.0) - -END SUBROUTINE - -FUNCTION RatefnFDG (fudgx, alamx, sinix, birx, vmx, xmfact) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: fudgx,alamx,sinix,birx,vmx,xmfact - REAL (rprec) :: RatefnFDG - ! - ! Function subprogram to compute precipitation rate - ! Last update: 04-04-88 - ! - RatefnFDG = 0.0466_rprec*fudgx*SQRT(ABS(alamx))*(sinix/birx)*vmx**2 - RatefnFDG = xmfact * RatefnFDG - RETURN -END FUNCTION RatefnFDG - -FUNCTION Ratefn (xx,yy,alamx,vmx,beqx,losscx,nex,kpx,fudgxO,sinixO,birxO,xmfactO,ELOSSMETHOD) - - use lossutils, ONLY : RatefnC_tau_s - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: ELOSSMETHOD - REAL (rprec), INTENT (IN) :: xx,yy,alamx,vmx,beqx,losscx,nex,kpx - REAL (rprec), INTENT (IN), OPTIONAL :: fudgxO,sinixO,birxO,xmfactO - REAL (rprec) :: fudgx,sinix,birx,xmfact - REAL (rprec), dimension(2) :: Ratefn - REAL (rprec) :: L, MLT, K, tau - if (present(fudgxO)) then - fudgx = fudgxO - else - fudgx = 0.0 - endif - if (present(sinixO)) then - sinix = sinixO - else - sinix = 0.0 - endif - if (present(birxO)) then - birx = birxO - else - birx = 0.0 - endif - if (present(xmfactO)) then - xmfact = xmfactO - else - xmfact = 0.0 - endif - - Ratefn = [1.D-10,-1.D0] ! default rate is 1e-10/s, type is -1. - select case (ELOSSMETHOD) - case (ELOSS_FDG) - Ratefn(1)= RatefnFDG(fudgx, alamx, sinix, birx, vmx, xmfact) !1/s - Ratefn(2)= -2.0 - case (ELOSS_SS) - tau = RatefnC_tau_s(alamx,vmx,beqx,losscx) - Ratefn(1) = 1.D0/tau !/s - Ratefn(2) = -1.0 - case (ELOSS_WM) - if (EWMTauInput%useWM) then - if (kpx > 10.0) then - write(*,*) "Kp = ", kpx, ", invalid Kp input for the wave models. Please use 'FDG' or 'SS' in the electron loss model instead." - stop - endif - Ratefn = RatefnWM(xx,yy,alamx,vmx,nex,kpx,beqx,losscx) - else - write(*,*) "Wave models are missing in rcmconfig.h5" - stop - endif - case default - write(*,*) "The electron loss rate model type entered is not supported." - stop - end select - -END FUNCTION Ratefn - -FUNCTION RatefnWM(xx,yy,alamx,vmx,nex,kpx,beqx,losscx) - use lossutils, ONLY : LossR8_PSHEET, LossR8_IMAG, Lo, Li, SSCATTER - IMPLICIT NONE - - REAL (rprec), INTENT (IN) :: xx,yy,alamx,vmx,nex,kpx,beqx,losscx - REAL (rprec), dimension(2) :: RatefnWM,rIMAG - REAL (rprec) :: L,rPS,wIMAG - - L = sqrt(xx**2+yy**2) - - !Wave type: Hiss: 1.0; Chorus: 2.0 (Inner Mag,L<7); strong scattering: 3.0 (Plasmasheet,L>8); Blending zone, 7 Lo) then - !Only plasma sheet - rPS = LossR8_PSHEET(alamx,vmx,beqx,losscx) - RatefnWM(1) = rPS - RatefnWM(2) = SSCATTER !wave type number for strong scattering - else if (L < Li) then - !IMAG only - rIMAG = LossR8_IMAG(xx,yy,alamx,vmx,nex,kpx) - RatefnWM(1) = rIMAG(1) - RatefnWM(2) = rIMAG(2) - - else - !Middle - rIMAG = LossR8_IMAG (xx,yy,alamx,vmx,nex,kpx) - rPS = LossR8_PSHEET(alamx,vmx,beqx,losscx) - wIMAG = RampDown(L,Li,Lo-Li) !Ramp from 1 to 0 - RatefnWM(1) = wIMAG*rIMAG(1) + (1-wIMAG)*rPS - RatefnWM(2) = SSCATTER-wIMAG - endif - -END FUNCTION RatefnWM - -!------------------------------------- - FUNCTION Gntrp_2d_ang (array, bi, bj, ikind) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: ikind - REAL (rprec), INTENT (IN) :: array (:,:), bi, bj - REAL (rprec) :: Gntrp_2d_ang -! - INTEGER (iprec) :: ii, jj, ni, nj - REAL (rprec) :: fi,fj,a1,a2,v_1, v_2 -! -! -! Prepare indices for interpolation: -! - ni = SIZE (array, 1) - nj = SIZE (array, 2) - IF (bj < 1.0 .OR. bj > nj) write(*,*) 'BJ out of range in gntrp_2d_ang' - IF (bi < 1.0 .OR. bi > ni) write(*,*) 'BI out of range in gntrp_2d_ang' -! - ii = INT (bi) - fi = REAL (ii,rprec) - jj = INT (bj) - fj = REAL (jj,rprec) - IF (ii == ni) ii = ii - 1 - IF (jj == nj) jj = jwrap ! periodicity in J -! - v_1 = array (ii,jj) - v_2 = array (ii+1,jj) -! IF (ii < imin_j(jj)) v_1 = array(imin_j(jj),jj) -! IF (ii+1 < imin_j(jj)) v_2 = array(imin_j(jj),jj) - a1 = (1.0-(bi-fi))*v_1 + (bi-fi)*v_2 -! - v_1 = array (ii , jj+1) - v_2 = array (ii+1, jj+1) -! IF (ii < imin_j(jj+1)) v_1 = array (imin_j(jj+1),jj+1) -! IF (ii+1 < imin_j(jj+1)) v_2 = array (imin_j(jj+1),jj+1) - a2 = (1.0-(bi-fi))*v_1 + (bi-fi)*v_2 -! - IF (ikind == 1) THEN - IF (jj+1 == nj) a2 = a2 + pi_two - IF (jj == jwrap) a1 = zero - IF (jj+1 == jwrap) a2 = a2 + pi_two ! sts, feb 22 - END IF -! - Gntrp_2d_ang = (1.0 - (bj-fj)) * a1 + (bj-fj) * a2 -! - RETURN - END FUNCTION Gntrp_2d_ang -! -! -! -! -! - FUNCTION Intrp_2d_grid (array, bi, bbj, jwrap, imin_j) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: jwrap, imin_j(:) - REAL (rprec), INTENT (IN) :: array (:,:), bi, bbj - REAL (rprec) :: Intrp_2d_grid -! - INTEGER (iprec) :: ii, jj, imax_array, jmax_array - REAL (rprec) :: bj, ca, cb, cc, cd, di, dj -! -! - imax_array = SIZE (array, 1) - jmax_array = SIZE (array, 2) - ii = MAX (1, MIN (INT (bi), imax_array-1)) - bj = Bjmod ( bbj,jwrap,jmax_array) - jj = INT (bj) -! -! (i,j)---------------------(i,j+1) -! | A | B | -! | | | -! | |di | -! | dj | 1-dj | -! |---------(bi,bj)---------------| -! | | | -! | | | -! | |1-di | -! | | | -! | C | D | -! (i+1,j)-----------------(i+1,j+1) -! - di = bi - ii - dj = bj - jj - IF (ii < imin_j(jj)) THEN - ca = 0.0 - ELSE - ca = (one-di)*(one-dj) - END IF - IF (ii+1 < imin_j(jj)) THEN - cc = 0.0 - ELSE - cc = di * (one-dj) - END IF - IF (ii < imin_j(jj+1)) THEN - cb = 0.0 - ELSE - cb = (one-di)*dj - END IF - IF (ii+1 < imin_j(jj+1)) THEN - cd = 0.0 - ELSE - cd = di*dj - END IF -! - Intrp_2d_grid = ca*array(ii,jj)+cb*array(ii,jj+1)+ & - cc*array(ii+1,jj)+cd*array(ii+1,jj+1) - Intrp_2d_grid = Intrp_2d_grid / (ca+cb+cc+cd) -! - RETURN - END FUNCTION Intrp_2d_grid - FUNCTION Interp_1d (array, bi ) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: array (:), bi - REAL (rprec) :: Interp_1d -! -! This function subprogram interpolates 1-dim. ARRAY to return -! the value of ARRAY at the non-integer point BI. -! -! Stanislav: if Bi < 1, then the array is extrapolated -! linearly based on the values A(1,:) and A(2,:). -! If Bi > imax, then array is linearly -! extrapolated on the values A(imax-1,:) and A(imax,:). -! - INTEGER (iprec) :: ii, imax_array - REAL (rprec) :: fi -! - imax_array = SIZE (array) -! - IF (bi < one .OR. bi > imax_array) STOP 'OUT OF BOUNDS IN INTERP_1D' -! - ii = MAX (1, MIN (INT (bi), imax_array-1)) - fi = REAL (ii,rprec) - Interp_1d = (one - (bi-fi) ) * array (ii) + (bi-fi) * array (ii+1) - RETURN - END FUNCTION Interp_1d - - - - FUNCTION Interp_2d (array, bi, bj) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: array (:,:), bi, bj - REAL (rprec) :: Interp_2d -! - INTEGER (iprec) :: ii, jn, jj, jp1, imax_array, jmax_array - REAL (rprec) :: fi,fj,a1,a2 -! -! -! Prepare indices for interpolation: -! - imax_array = SIZE (array, 1) - jmax_array = SIZE (array, 2) -! -! - IF (bi < one .OR. bi > imax_array .OR. bj < 1 .OR. bj > jmax_array) & - STOP 'OUT OF BOUNDS IN INTERP_2D' -! -! - ii = MAX (1, MIN (INT (bi), imax_array-1)) - fi = REAL (ii,rprec) -! -! -! Decide which interpolation to perform and proceed: -! - jn = NINT (bj) - IF (ABS (bj-REAL(jn,rprec)) < 1.0E-4_rprec) THEN ! 1-d interp. of 2-d array -! - Interp_2d = (one-(bi-fi)) * array(ii,jn) + (bi-fi)*array(ii+1,jn) -! - ELSE ! 2-d interpolation of 2-d array: -! -! If jwrap <= bj < jmax, then jwrap-1 <= INT(bj) <= jmax-1 -! and jwrap <= INT(bj)+1 <= jmax -! - jj = INT (bj) - fj = REAL (jj,rprec) - jp1 = jj + 1 -! - a1 = (one-(bi-fi))*array(ii,jj) + (bi-fi)*array(ii+1,jj) - a2 = (one-(bi-fi))*array(ii,jp1) + (bi-fi)*array(ii+1,jp1) -! - Interp_2d = (one - (bj-fj)) * a1 + (bj-fj) * a2 -! - END IF - RETURN - END FUNCTION Interp_2d - - - - - FUNCTION Interp_2d_of3d (array, bi, bj, index_3) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: index_3 - REAL (rprec), INTENT (IN) :: array (:,:,:), bi, bj - REAL (rprec) :: Interp_2d_of3d -! -! This is the same as Gntrp_2d but for a 3-dim array, see comments for -! Gntrp_2d. A separate function is needed since if Gntrp_2d were used, -! then we would need to pass array sections (the other option is Fortran -! 77 style of passing an offset array, but that should be avoided for -! compiler checking and parallelization reasons). -! - INTEGER (iprec) :: ii, jn, jj, jp1, imax_array, jmax_array, kmax_array - REAL (rprec) :: fi,fj,a1,a2 -! -! -! Prepare indices for interpolation: -! - imax_array = SIZE (array, 1) - jmax_array = SIZE (array, 2) - kmax_array = SIZE (array, DIM = 3) -! -! - IF (bi < one .OR. bi > imax_array .OR. bj < one .OR. bj > jmax_array) THEN - WRITE (*,*) 'OUT OF BOUNDS IN INTERP_2D_OF_3D' - STOP - END IF -! -! - IF (index_3 > kmax_array .OR. index_3 < 1) STOP 'INTRP_2D_OF3D: index_3 OUT OF RANGE' - ii = MAX (1, MIN (INT (bi), imax_array-1)) - fi = REAL (ii,rprec) -! -! -! Decide which interpolation to perform and proceed: -! - jn = NINT (bj) - IF (ABS (bj-REAL(jn,rprec)) < 1.0E-4_rprec) THEN ! 1-d interp. of 2-d array -! - Interp_2d_of3d = (one-(bi-fi)) * array(ii,jn,index_3) + & - (bi-fi)*array(ii+1,jn,index_3) -! - ELSE ! 2-d interpolation of 2-d array: -! -! If jwrap <= bj < jmax, then jwrap-1 <= INT(bj) <= jmax-1 -! and jwrap <= INT(bj)+1 <= jmax -! - jj = INT (bj) - fj = REAL (jj,rprec) - jp1 = jj + 1 -! - a1 = (one-(bi-fi))*array(ii,jj,index_3) + (bi-fi)*array(ii+1,jj,index_3) - a2 = (one-(bi-fi))*array(ii,jp1,index_3) + (bi-fi)*array(ii+1,jp1,index_3) -! - Interp_2d_of3d = (one - (bj-fj)) * a1 + (bj-fj) * a2 -! - END IF - RETURN - END FUNCTION Interp_2d_of3d -! -! 7. A few routines needed for circulariation and normalization in J: -! - FUNCTION Bjmod_real (bj, jwrap, jsize) - IMPLICIT NONE - REAL (rprec), INTENT (IN) :: bj - INTEGER(iprec), INTENT (IN) :: jwrap, jsize - REAL (rprec) :: Bjmod_real -!_____________________________________________________________________________ -! last update: 11-28-84 by:rws -! -! this function subporgram returns bjmod with a value -! between jwrap and jmax-1. In RCM, arrays in j (local time angle) -! are dimensioned from 1 to jsize, but the grid wraps around and -! overlaps such that array (jwrap) = array (jsize) -! array (jwrap-1) = array (jsize-1), etc. In other words, only -! elements from j=jwrap to j=jsize-1 are unique. This function takes -! a non-integer j index, BJ, and makes sure that it is larger or -! equal to jwrap but smaller than jsize-1. Then when array is interpolated -! on two elements, j is never larger than jsize or smaller than jwrap-1. -! For the case of jwrap = 3 and a 1-dim array, this looks like: -! -! j-value: 1 2 3 4 5 jsize-2 jsize-1 jsize -! x x x x x .................x x x -! | | | | | | -! | | --------->---------->---|--------|----- -! | --------------->------------|-->----- -! ---------->----------->------- -! -! Dependency: none -! - Bjmod_real = bj -! -! do_1: DO -! IF (Bjmod_real < REAL (jsize - 1,rprec)) EXIT -! Bjmod_real = Bjmod_real - REAL (jsize - jwrap,rprec) -! END DO do_1 -! -! do_2: DO -! IF (Bjmod_real >= REAL (jwrap,rprec)) EXIT -! Bjmod_real = Bjmod_real + REAL(jsize - jwrap,rprec) -! END DO do_2 -! -bjmod_real = MODULO(bj-REAL(jwrap),REAL(jsize-jwrap-1)) + REAL(jwrap) - RETURN - END FUNCTION Bjmod_real -! -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! - FUNCTION Bjmod_int (bj, jwrap, jsize) - IMPLICIT NONE - INTEGER (iprec), INTENT (IN) :: bj - INTEGER (iprec), INTENT (IN) :: jwrap, jsize - INTEGER (iprec) :: Bjmod_int -!_____________________________________________________________________________ -! last update: 11-28-84 by:rws -! -! this function subporgram returns bjmod with a value -! between jwrap and jmax-1. In RCM, arrays in j (local time angle) -! are dimensioned from 1 to jsize, but the grid wraps around and -! overlaps such that array (jwrap) = array (jsize) -! array (jwrap-1) = array (jsize-1), etc. In other words, only -! elements from j=jwrap to j=jsize-1 are unique. This function takes -! a non-integer j index, BJ, and makes sure that it is larger or -! equal to jwrap but smaller than jsize-1. Then when array is interpolated -! on two elements, j is never larger than jsize or smaller than jwrap-1. -! For the case of jwrap = 3 and a 1-dim array, this looks like: -! -! j-value: 1 2 3 4 5 jsize-2 jsize-1 jsize -! x x x x x .................x x x -! | | | | | | -! | | --------->---------->---|--------|----- -! | --------------->------------|-->----- -! ---------->----------->------- -! -! Dependency: none -! - Bjmod_int = bj -! - do_1: DO - IF (Bjmod_int > jsize - 1) THEN - Bjmod_int = Bjmod_int - (jsize - jwrap) - ELSE - EXIT do_1 - END IF - END DO do_1 -! - do_2: DO - IF (Bjmod_int < jwrap) THEN - Bjmod_int = Bjmod_int + (jsize - jwrap) - ELSE - EXIT do_2 - END IF - END DO do_2 -! - RETURN - END FUNCTION Bjmod_int -! -! - END MODULE Rcm_mod_subs diff --git a/src/rcm/rcm_timing.F90 b/src/rcm/rcm_timing.F90 deleted file mode 100644 index fa2c7cb8..00000000 --- a/src/rcm/rcm_timing.F90 +++ /dev/null @@ -1,125 +0,0 @@ - module rcm_timing_module - -! Use Rcm_mod_subs, only : iprec,rprec,rcmdir - use rcm_precision - - integer(iprec), allocatable,dimension(:),save :: rcm_timing - - contains - - subroutine AddToList(element,list) - IMPLICIT NONE - - integer(iprec) :: i, idim - integer(iprec), intent(in) :: element - integer(iprec), dimension(:), allocatable, intent(inout) :: list - integer(iprec), dimension(:), allocatable :: clist - - - if(allocated(list)) then - idim = size(list) - allocate(clist(idim+1)) - do i=1,idim - clist(i) = list(i) - end do - clist(idim+1) = element - - deallocate(list) - call move_alloc(clist, list) - - else - allocate(list(1)) - list(1) = element - end if - - !K: Commenting out output - !write(*,*)' addtolist adding t=',element - !write(*,*)' rcm_time=',list - return - - end subroutine AddToList - - subroutine read_rcm_timing(list) - IMPLICIT NONE - INCLUDE 'rcmdir.h' - integer(iprec) :: i, idim - integer(iprec), dimension(:), allocatable, intent(inout) :: list - integer(iprec) :: iin,tin - - open(unit=20,file='RCMfiles/rcm_timing.dat',status='old',err=21) - idim = 0 - do - read(20,*,end=20)tin,iin - idim = idim + 1 - end do - 20 close(20) - - allocate(list(idim)) - - open(unit=20,file='RCMfiles/rcm_timing.dat',status='old') - do i=1,idim - read(20,*,end=20)tin,iin - list(i) = tin - end do - close(20) - - return - - 21 STOP 'read error in read_rcm_timing' - - end subroutine read_rcm_timing - - subroutine write_rcm_timing(list) - IMPLICIT NONE - INCLUDE 'rcmdir.h' - integer(iprec) :: i, idim - integer(iprec), dimension(:),intent(in) :: list - - !write(*,*)' writing rcm timing ' - - open(unit=20,file=rcmdir//'rcm_timing.dat',status='replace',err=21) - idim = size(list) - - do i=1,idim - write(20,*)list(i),i - end do - close(20) - - return - - 21 STOP 'write error in write_rcm_timing' - - end subroutine write_rcm_timing - - - subroutine find_record(itime,list,record) - IMPLICIT NONE - integer(iprec), dimension(:), intent(in) :: list - integer(iprec), intent(in) :: itime - integer(iprec), intent(out) :: record - integer(iprec) :: idim,i - - idim = size(list) - - do i=1,idim - if(itime == list(i))then - record = i - write(*,'(2(a,i5))')' At t=',itime,' record =',record - return - end if - end do - !Didn't find exact match, now just use closest - record = minloc(abs(list-itime),dim=1) - write(*,*) 'find_record: error in find record, for itime=',itime - write(*,*) 'itimei/nearest = ',itime,list(record) - - !record = -1 - - return - - end subroutine find_record - - - end module rcm_timing_module - - diff --git a/src/rcm/rcmdir.h b/src/rcm/rcmdir.h deleted file mode 100644 index ad570eb7..00000000 --- a/src/rcm/rcmdir.h +++ /dev/null @@ -1,3 +0,0 @@ - character (len=9), parameter :: Rcmdir= 'RCMfiles/' - character (len=8), parameter :: rcm_tec_subdir = 'RCM_TEC/' - character (len=*), parameter :: RCMGAMConfig = "rcmconfig.h5" \ No newline at end of file diff --git a/src/rcm/rcmu2tecplot.F90 b/src/rcm/rcmu2tecplot.F90 deleted file mode 100644 index 58caecbf..00000000 --- a/src/rcm/rcmu2tecplot.F90 +++ /dev/null @@ -1,412 +0,0 @@ - program rcmu2tecplot -! USE Rcm_mod_subs, ONLY : iprec,rprec - USE rcm_precision - - IMPLICIT NONE - - integer(iprec) :: idim,jdim,kdim - integer(iprec) :: i,j,k,kk - integer(iprec) :: itime,itime0,itimef - integer(iprec), allocatable, dimension(:) :: ikflav - integer(iprec) :: ks,kf - - real(rprec) :: time,start_time_min,time_min,eps,r - integer(iprec), allocatable, dimension(:) :: imin_j - real(rprec) , allocatable, dimension(:) :: alam,etac - real(rprec) , allocatable, dimension(:,:) :: xi,yi,zi - real(rprec) , allocatable, dimension(:,:) :: xe,ye,ze - real(rprec) , allocatable, dimension(:,:) :: vm,v,birk,bmin,pressure,pvg,dsob3 - real(rprec) , allocatable, dimension(:,:) :: densi, dense, ti, te, pressurei,pressuree - real(rprec) , allocatable, dimension(:,:,:) :: eeta,veff,partial_pressures - real(rprec) , parameter :: mass_proton = 1.67e-27 - real(rprec) , parameter :: mass_electron = 9.1e-31 - real(rprec) , parameter :: coulomb = 1.67e-19 - - logical :: threed,tecplot360 - logical :: onefile,opened - logical :: firstpass =.true. - - character (len=9) :: chartime - character (len=45) :: tecoutfile - character (len=1) :: ans - CHARACTER (LEN=05) :: char_kvalue='xxxxx' - - write(6,*)' NOTE: this version writes out ze' - - write(*,'(a,$)')' enter the time to start, end reading: ' - read(5,*)itime0,itimef - write(*,'(a,$)')' enter start time on min: ' - read(5,*)start_time_min - - write(*,'(a,$)')' do you want 3d data information (y/n)?: ' - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')threed=.true. - - write(*,'(a,$)')' do you want it all in one file (y/n)?: ' - onefile=.false. - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')onefile=.true. - opened = .false. - - write(*,'(a,$)')' do you want it for tecplot360(y/n)?: ' - tecplot360=.false. - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')tecplot360=.true. - - open(unit=1,file='rcmu.dat',status='old',action='read',& - form='unformatted') - - itime = 0 - - do - if(itime < itimef)then - - read(1,end=10)itime,idim,jdim,kdim - - write(*,'(4(a,i6))')' reading in time =',itime,' idim =',idim,' jdim =',jdim,' kdim=',kdim -! only allocate once - if( .not.allocated(alam)) then - allocate (alam(kdim),etac(kdim),ikflav(kdim)) - allocate (xi(idim,jdim),yi(idim,jdim),zi(idim,jdim)) - allocate (xe(idim,jdim),ye(idim,jdim),ze(idim,jdim)) - allocate (vm(idim,jdim),v(idim,jdim)) - allocate (birk(idim,jdim),dsob3(idim,jdim)) - allocate (eeta(idim,jdim,kdim),bmin(idim,jdim)) - allocate (veff(idim,jdim,kdim)) - allocate (partial_pressures(idim,jdim,kdim)) - allocate (pressure(idim,jdim)) - allocate (pressuree(idim,jdim)) - allocate (pressurei(idim,jdim)) - allocate (densi(idim,jdim)) - allocate (dense(idim,jdim)) - allocate (ti(idim,jdim)) - allocate (te(idim,jdim)) - allocate (pvg(idim,jdim)) - allocate (imin_j(jdim)) - end if - - read(1)alam,etac,ikflav - read(1)xe,ye,ze,xi,yi,zi,vm,v,eeta,birk,bmin - if(firstpass)then - if(threed)then - do k=1,kdim - write(6,*)' alam(',k,')', alam(k) - end do - write(6,*)' enter the start and end k vals threed output' - write(6,*)'enter 0 0 for all the data' - read(6,*)ks,kf - if(ks == 0 .and. kf ==0)then - ks = 1 - kf = kdim - endif - endif - END IF - firstpass=.false. - -! write(*,*)'alam: ',alam -! output file - if(itime >= itime0)then - time_min = itime/60.+start_time_min - write(*,*)'time min=',time_min - call min2hr(time_min,chartime) - - if(.not.opened.and.onefile)then - - if(threed)then - tecoutfile = adjustr('tec3dn') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - else - tecoutfile = adjustr('tecn') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - endif - - endif - - if(.not.opened) open(unit=2,file=tecoutfile,status='unknown') -! add corotation - do j=1,jdim - do i=1,idim - if(vm(i,j) > 0)then - r = sqrt(xe(i,j)**2+ye(i,j)**2) - !v(i,j) = v(i,j) - 92400./r - - do k=1,kdim - veff(i,j,k) = v(i,j) + alam(k)*vm(i,j) -92400./r - end do - end if - end do - end do - -! now output the files - - if(threed)then - if(.not.opened)then - write(2,*)' VARIABLES =, "xe(Re)" "ye(Re)" "ze(Re)" "xi(Re)"'& - ,' "yi(Re)" "zi(Re)" ' & - ,' "v(V)" "vm" "birk(mA/m^2)" "bmin(nT)" "pressure(Pa)"'& - ,' "pVg"'& - ,' "ion density(cc)" "electron density(cc)"'& - ,' "ion pressure(Pa)" "electron pressurei(Pa)"'& - ,' "ion temperature(eV)" "electron temperature(eV)"'& - ,' "eeta" "veff" "partial_pressures"' - - end if -! 2d - else - if(.not.opened)then - write(2,*)' VARIABLES =, "xe(Re)" "ye(Re)" "ze(Re)" "xi(Re)" '& - ,' "yi(Re)" "zi(Re)" ' & - ,' "v(V)" "vm" "birk(mA/m^2)" "bmin(nT)" '& - ,' "pressure(Pa)"'& - ,' "pVg"'& - ,' "ion density(cc)" "electron density(cc)"'& - ,' "ion pressure(Pa)" "electron pressure(Pa)"'& - ,' "ion temperature(eV)" "electron temperature(eV)"'& - ,' "eeta0" "veff0" "partial_pressures(Pa)"' - end if - -! if(tecplot360)then -! write(2,*)' ZONE, T ="',itime,'" ,I=',idim,' ,J=',jdim ,& -! ' , DATAPACKING=BLOCK',' ,SOLUTIONTIME=',itime -! else -! write(2,*)' ZONE, T ="',itime,'" ,I=',idim,' ,J=',jdim , & -! &', DATAPACKING=BLOCK' -! endif - - end if - - pressure = 0.0 - pressuree = 0.0 - pressurei = 0.0 - partial_pressures = 0.0 - densi = 0.0 - dense = 0.0 - ti = 0.0 - te = 0.0 - opened = .true. - do j=1,jdim -! process the data -! imin_j is the last closed fieldline - imin_j(j) = 2 - do i=idim,2,-1 - if(vm(i,j) < 0)then - imin_j(j) = i + 1 - exit - end if - end do - - eps = 1.0e-3 - do i=imin_j(j)-1,1,-1 - xe(i,j) = xe(i+1,j)*(1 + eps) - ye(i,j) = ye(i+1,j)*(1 + eps) - end do -! now set the pressure - do i=imin_j(j),idim - do kk=1,kdim - pressure(i,j) = pressure(i,j) + 1.67e-35*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - veff(i,j,kk) = v(i,j) + vm(i,j)*alam(kk)-92400./r -! partial pressures - partial_pressures(i,j,kk) = 1.67e-35*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - if(vm(i,j) <0.0)partial_pressures(i,j,kk)=0.0 - if(alam(kk) > 0)then - densi(i,j) = densi(i,j) + 1.5694E-16*eeta(i,j,kk)*vm(i,j)**1.5 - pressurei(i,j) = pressurei(i,j) + 1.67e-35*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - else - dense(i,j) = dense(i,j) + 1.5694E-16*eeta(i,j,kk)*vm(i,j)**1.5 - pressuree(i,j) = pressuree(i,j) + 1.67e-35*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - end if - end do - end do - end do -! pv^gamma - where(vm > 0) - pvg = pressure*vm**(-2.5)*1.0e9 ! convert to rcm units - end where -! ion temperature - where(vm > 0) - where(densi > 0) - ti = pressurei/densi/coulomb - end where - where(dense > 0) - te = pressuree/dense/coulomb - end where - end where -! reset to avoid Inf and NaN - where (vm < 0.0) - pressure = 0.0 - pressurei = 0.0 - pressuree = 0.0 - densi = 0.0 - dense = 0.0 - ti = 0.0 - te = 0.0 - pvg = 0.0 - end where - -! output the data - if(threed)then - do k=ks,kf - WRITE (char_kvalue,'(A2,I3.3)') 'K=', k - if(tecplot360)then - if(k==ks)then - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ',DATAPACKING=BLOCK, SOLUTIONTIME=',itime - else - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ',DATAPACKING=BLOCK, VARSHARELIST=([1-17]), SOLUTIONTIME=',itime - end if - - else - if(k==ks)then - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ', DATAPACKING=BLOCK' - else - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ', DATAPACKING=BLOCK, VARSHARELIST=([1-17])' - end if - - end if - write(2,'(A,F9.3,A)') 'AUXDATA Alamc='//'"', alam(k),'"' - write(2,'(a,a,a)')' AUXDATA TIME ="',chartime,'"' - - if(k == ks)then - DO j=1,jdim; write(2,'(15es14.5)')(xe(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ye(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ze(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(xi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(yi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')( v(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(vm(i,j),i=1,idim);END DO -! divide by 2 since birk is total current (right?) - DO j=1,jdim; write(2,'(15es14.5)')(birk(i,j)/2,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(bmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pvg(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(densi(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dense(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressurei(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressuree(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ti(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(te(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,k),i=1,idim);END DO - else - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,k),i=1,idim);END DO - end if - - end do - - else -! 2d - WRITE (2,*) 'ZONE T="RCM-'//& - '" I=', idim, ', J=',jdim, ', & - DATAPACKING=BLOCK, SOLUTIONTIME=',itime - write(2,'(a,a,a)')' AUXDATA TIME ="',chartime,'"' - DO j=1,jdim; write(2,'(15es14.5)')(xe(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ye(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ze(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(xi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(yi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')( v(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(vm(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(birk(i,j)/2.,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(bmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pvg(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(densi(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dense(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressurei(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressuree(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ti(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(te(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,1),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,1),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,1),i=1,idim);END DO - end if - - if(.not.onefile)then - opened=.false. - close(2) - else - opened=.true. - endif - - if(.not.opened)then -! this call to preplot is system dependent and may not work -! if(tecplot360)then -! CALL System ('/Applications/Tec360/bin/preplot '//tecoutfile) -! else -! CALL System ('/Applications/Tec100/bin/preplot '//tecoutfile) -! endif -! CALL System ('rm '//tecoutfile) - - end if - end if - - else - exit - - end if - - end do - if(onefile)then - close(2) -! CALL System ('/Applications/Tec360/bin/preplot '//tecoutfile) -! CALL System ('rm '//tecoutfile) - end if - - 10 stop - - end program rcmu2tecplot - -!----------------------------------- - subroutine min2hr(time,hours) -! returns a string of hr:min:sec from an input in minutes -! 2/04 frt -! USE Rcm_mod_subs, ONLY : iprec,rprec - use rcm_precision - implicit none - real(rprec) :: time - real(rprec) :: time_hours - real(rprec) :: time_minutes - real(rprec) :: time_seconds - character (len=*) :: hours - character (len=3) :: char_time_hours - character (len=2) :: char_time_minutes,char_time_seconds -! time is in minutes - - time_hours = floor(time/60.) - time_minutes = floor(time - 60*time_hours) - time_seconds = 60*(time -floor(time)) - - write(*,*)int(time_hours,iprec),time - - write(char_time_hours,'(i3.3)')int(time_hours,iprec) -! write(*,*)' char_time_hours =',char_time_hours -! if(int(time_hours) < 10)then -! char_time_hours = '00'//adjustr(char_time_hours) -! endif -! write(*,*)' char_time_hours =',char_time_hours - write(char_time_minutes,'(i2.2)')int(time_minutes,iprec) - write(char_time_seconds,'(i2.2)')int(time_seconds,iprec) -! write(*,*)' char_time_seconds =',char_time_seconds - - hours = adjustr(char_time_hours) //'-'//char_time_minutes//'-' & - //adjustl(char_time_seconds) - write(*,'(a,g14.6,a,a)')' time (min) =',time,' h-m-s:',hours - - return - end subroutine min2hr - diff --git a/src/rcm/rcmutorcm-tec.F90 b/src/rcm/rcmutorcm-tec.F90 deleted file mode 100644 index 2d51f087..00000000 --- a/src/rcm/rcmutorcm-tec.F90 +++ /dev/null @@ -1,434 +0,0 @@ - program rcmutorcm -! attempt to add eeta channels -! use kdefs - USE Rcm_mod_subs, ONLY : iprec,rprec - - IMPLICIT NONE - - integer(iprec) :: idim,jdim,kdim - integer(iprec) :: i,j,k,kk - integer(iprec) :: itime,itime0,itimef - integer(iprec), allocatable, dimension(:) :: ikflav - integer(iprec) :: ks,kf - - real(rprec) :: time,start_time_min,time_min,eps,r - integer(iprec), allocatable, dimension(:) :: imin_j - real(rprec), allocatable, dimension(:) :: alam,etac - real(rprec), allocatable, dimension(:,:) :: xi,yi,zi - real(rprec), allocatable, dimension(:,:) :: xmin,ymin,zmin,rmin,pmin,beta_avg - real(rprec), allocatable, dimension(:,:) :: vm,v,birk,bmin,pressure,pvg,dsob3,pressure_mhd,pressure_rcm,t_mhd - real(rprec), allocatable, dimension(:,:) :: dens_mhd,densi, dense, ti, te, pressurei,pressuree,dens_corr - real(rprec), allocatable, dimension(:,:,:) :: eeta,veff,partial_pressures,partial_densities - integer(iprec), allocatable, dimension(:,:) :: iopen - real(rprec), parameter :: mass_proton = 1.67e-27 - real(rprec), parameter :: mass_electron = 9.1e-31 - real(rprec), parameter :: coulomb = 1.6022e-19 - real(rprec), parameter :: radius_earth = 6380.e3 - real(rprec), parameter :: nt = 1.0e-9 - real(rprec) :: pressure_factor, density_factor - - logical :: threed,tecplot360 - logical :: onefile,opened - logical :: firstpass =.true. - - character (len=9) :: chartime - character (len=45) :: tecoutfile - character (len=1) :: ans - CHARACTER (LEN=05) :: char_kvalue='xxxxx' - - pressure_factor = 2./3.*coulomb/(radius_earth)*nt - - density_factor = nt/radius_earth - - write(6,*)' NOTE: this version writes out ze' - - write(*,'(a,$)')' enter the time to start, end reading: ' - read(5,*)itime0,itimef - write(*,'(a,$)')' enter start time on min: ' - read(5,*)start_time_min - - write(*,'(a,$)')' do you want 3d data information (y/n)?: ' - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')threed=.true. - - write(*,'(a,$)')' do you want it all in one file (y/n)?: ' - onefile=.false. - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')onefile=.true. - opened = .false. - -! write(*,'(a,$)')' do you want it for tecplot360(y/n)?: ' -! tecplot360=.false. -! read(5,'(a1)')ans -! if(ans.eq.'y'.or.ans.eq.'Y')i - tecplot360=.true. - - open(unit=1,file='rcmu_torcm.dat',status='old',action='read',& - form='unformatted') - - itime = 0 - - do - if(itime <= itimef)then - - read(1,end=10)idim,jdim,kdim - - write(*,*)'idim =',idim,' jdim=',jdim,' kdim =',kdim - - write(*,'(a,i6)')' reading in time =',itime -! only allocate once - if( .not.allocated(alam)) then - allocate (alam(kdim),etac(kdim),ikflav(kdim)) - allocate (xi(idim,jdim),yi(idim,jdim),zi(idim,jdim)) - allocate (xmin(idim,jdim),ymin(idim,jdim),zmin(idim,jdim)) - allocate (vm(idim,jdim),v(idim,jdim)) - allocate (rmin(idim,jdim),pmin(idim,jdim)) - allocate (birk(idim,jdim),dsob3(idim,jdim)) - allocate (eeta(idim,jdim,kdim),bmin(idim,jdim)) - allocate (veff(idim,jdim,kdim)) - allocate (partial_pressures(idim,jdim,kdim)) - allocate (partial_densities(idim,jdim,kdim)) - allocate (pressure_mhd(idim,jdim)) - allocate (pressure_rcm(idim,jdim)) - allocate (pressure(idim,jdim)) - allocate (pressuree(idim,jdim)) - allocate (pressurei(idim,jdim)) - allocate (dens_mhd(idim,jdim)) - allocate (densi(idim,jdim)) - allocate (dense(idim,jdim)) - allocate (t_mhd(idim,jdim)) - allocate (ti(idim,jdim)) - allocate (te(idim,jdim)) - allocate (beta_avg(idim,jdim)) - allocate (pvg(idim,jdim)) - allocate (iopen(idim,jdim)) - allocate (imin_j(jdim)) - end if - - read(1) itime, alam, xi, yi, zi, rmin, pmin, & - iopen, vm, pressure_mhd, dens_mhd, bmin, ti, te, beta_avg,v,eeta - - if(firstpass)then - if(threed)then - do k=1,kdim - write(6,*)' alam(',k,')', alam(k) - end do - write(6,*)' enter the start and end k vals threed output' - write(6,*)'enter 0 0 for all the data' - read(5,*)ks,kf - if(ks == 0 .and. kf ==0)then - ks = 1 - kf = kdim - endif - endif - END IF - firstpass=.false. - -! output file - if(itime >= itime0)then - time_min = itime/60.+start_time_min - call min2hr(time_min,chartime) - - if(.not.opened.and.onefile)then - - if(threed)then - tecoutfile = adjustr('tec3dtorcm') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - else - tecoutfile = adjustr('tectorcm') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - endif - - endif - - ! compute xmin,ymin - do j=1,jdim - do i=1,idim - xmin(i,j) = rmin(i,j)*cos(pmin(i,j)) - ymin(i,j) = rmin(i,j)*sin(pmin(i,j)) - end do - end do - - if(.not.opened) open(unit=2,file=tecoutfile,status='unknown',recl=500) -! add corotation -! do j=1,jdim -! do i=1,idim -! if(vm(i,j) > 0)then -! r = sqrt(xmin(i,j)**2+ymin(i,j)**2) -! !v(i,j) = v(i,j) - 92400./r -! -! do k=1,kdim -! veff(i,j,k) = v(i,j) + alam(k)*vm(i,j) -92400./r -! end do -! end if -! end do -! end do - -! now output the files - - if(threed)then - if(.not.opened)then - write(2,*)' VARIABLES =, "xmin(Re)" "ymin(Re)" "zmin(Re)" "xi(Re)"'& - ,' "yi(Re)" "zi(Re)" ' & - ,' "v(V)" "vm" "bmin(nT)" "mhd pressure(Pa)" "mhd density(cc)"'& - ,' "pVg"'& - ,' "ion density(cc)" "electron density(cc)" '& - ,' "ion pressure(Pa)" "electron pressure(Pa)" "rcm pressure(Pa)" '& - ,' "mhd temperature(eV)" "ion temperature(eV)" "electron temperature(eV)"'& - ,' "eeta" "veff" "partial_pressures(Pa)" "partial_densities(cc)"' - - end if -! 2d - else - if(.not.opened)then - write(2,*)' VARIABLES =, "xmin(Re)" "ymin(Re)" "zmin(Re)" "xi(Re)" '& - ,' "yi(Re)" "zi(Re)" ' & - ,' "v(V)" "vm" "bmin(nT)" '& - ,' "mhd pressure(Pa)" "mhd density(cc)"'& - ,' "pVg"'& - ,' "ion density(cc)" "electron density(cc)" "rcm density(cc)"'& - ,' "ion pressure(Pa)" "electron pressure(Pa)" "mhd pressure(Pa)" '& - ,' "mhd temperature(eV)" "ion temperature(eV)" "electron temperature(eV)"'& - ,' "eeta0" "veff0" "partial_pressures(Pa)" "partial_densities(cc)"' - end if - - end if - - pressure = 0.0 - pressuree = 0.0 - pressurei = 0.0 - partial_pressures = 0.0 - partial_densities = 0.0 - densi = 0.0 - dense = 0.0 - ti = 0.0 - te = 0.0 - opened = .true. - do j=1,jdim -! process the data -! imin_j is the last closed fieldline - imin_j(j) = 2 - do i=idim,2,-1 - if(vm(i,j) < 0)then - imin_j(j) = i + 1 - exit - end if - end do - - eps = 1.0e-3 - do i=imin_j(j)-1,1,-1 - xmin(i,j) = xmin(i+1,j)*(1 + eps) - ymin(i,j) = ymin(i+1,j)*(1 + eps) - end do -! now set the pressure - do i=imin_j(j),idim - do kk=1,kdim - pressure(i,j) = pressure(i,j) + pressure_factor*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - veff(i,j,kk) = v(i,j) + vm(i,j)*alam(kk)-92400./rmin(i,j) -! partial pressures - partial_pressures(i,j,kk) = pressure_factor*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - partial_densities(i,j,kk) = density_factor*eeta(i,j,kk)*vm(i,j)**1.5 - if(alam(kk) > 0.0)then - densi(i,j) = densi(i,j) + density_factor*eeta(i,j,kk)*vm(i,j)**1.5 - pressurei(i,j) = pressurei(i,j) + pressure_factor*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - else - dense(i,j) = dense(i,j) + density_factor*eeta(i,j,kk)*vm(i,j)**1.5 - pressuree(i,j) = pressuree(i,j) + pressure_factor*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - end if - end do - - pressure_rcm = pressurei+pressuree - - end do - end do -! pv^gamma - where(vm > 0) - pvg = pressure*vm**(-2.5)*1.0e9 ! convert to wolf units - end where -! ion temperature - where(vm > 0) - where(densi > 0) - ti = pressurei/densi/coulomb - end where - where(dense > 0) - te = pressuree/dense/coulomb - end where - end where -! mhd temperature - t_mhd = pressure_mhd/dens_mhd/coulomb -! reset to avoid Inf and NaN - where (vm < 0.0) - pressure = 0.0 - pressurei = 0.0 - pressuree = 0.0 - densi = 0.0 - dense = 0.0 - ti = 0.0 - te = 0.0 - pvg = 0.0 - end where - -! output the data - if(threed)then - do k=ks,kf - WRITE (char_kvalue,'(A2,I3.3)') 'K=', k - if(tecplot360)then - if(k==ks)then - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ',DATAPACKING=BLOCK, SOLUTIONTIME=',itime - else - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ',DATAPACKING=BLOCK, VARSHARELIST=([1-20]), SOLUTIONTIME=',itime - end if - - else - if(k==ks)then - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ', DATAPACKING=BLOCK' - else - WRITE (2,*) 'ZONE T="RCM-'//char_kvalue//& - '" I=', idim, ', J=',jdim, ', DATAPACKING=BLOCK, VARSHARELIST=([1-20])' - end if - - end if - write(2,'(A,F9.3,A)') 'AUXDATA Alamc='//'"', alam(k),'"' - write(2,'(a,a,a)')' AUXDATA TIME ="',chartime,'"' - - if(k == ks)then - DO j=1,jdim; write(2,'(15es14.5)')(xmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ymin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(xi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(yi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')( v(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(vm(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(bmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure_mhd(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dens_mhd(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pvg(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(densi(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dense(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressurei(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressuree(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure_rcm(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(t_mhd(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ti(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(te(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_densities(i,j,k)/1.0e6,i=1,idim);END DO - else - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,k),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_densities(i,j,k)/1.0e6,i=1,idim);END DO - end if - - end do - - else -! 2d - WRITE (2,*) 'ZONE T="RCM-'//& - '" I=', idim, ', J=',jdim, ', & - DATAPACKING=BLOCK, SOLUTIONTIME=',itime - write(2,'(a,a,a)')' AUXDATA TIME ="',chartime,'"' - DO j=1,jdim; write(2,'(15es14.5)')(xmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ymin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(xi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(yi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(zi(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')( v(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(vm(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(bmin(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure_mhd(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dens_mhd(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pvg(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(densi(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(dense(i,j)/1.0e6,i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressurei(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressuree(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(pressure_rcm(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(t_mhd(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(ti(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(te(i,j),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(eeta(i,j,1),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')(veff(i,j,1),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_pressures(i,j,1),i=1,idim);END DO - DO j=1,jdim; write(2,'(15es14.5)')& - (partial_densities(i,j,1)/1.0e6,i=1,idim);END DO - end if - - if(.not.onefile)then - opened=.false. - close(2) - else - opened=.true. - endif - - if(.not.opened)then - - end if - end if - - else - exit - - end if - - end do - if(onefile)then - close(2) - end if - - 10 stop - - end program rcmutorcm - -!----------------------------------- - subroutine min2hr(time,hours) -! returns a string of hr:min:sec from an input in minutes -! 2/04 frt - USE Rcm_mod_subs, ONLY : rprec - implicit none - real(rprec) :: time - real(rprec) :: time_hours - real(rprec) :: time_minutes - real(rprec) :: time_seconds - character (len=*) :: hours - character (len=3) :: char_time_hours - character (len=2) :: char_time_minutes,char_time_seconds -! time is in minutes - - time_hours = floor(time/60.) - time_minutes = floor(time - 60*time_hours) - time_seconds = 60*(time -floor(time)) - - write(char_time_hours,'(i3.3)')int(time_hours) -! write(*,*)' char_time_hours =',char_time_hours -! if(int(time_hours) < 10)then -! char_time_hours = '00'//adjustr(char_time_hours) -! endif -! write(*,*)' char_time_hours =',char_time_hours - write(char_time_minutes,'(i2.2)')int(time_minutes) - write(char_time_seconds,'(i2.2)')int(time_seconds) -! write(*,*)' char_time_seconds =',char_time_seconds - - hours = adjustr(char_time_hours) //'-'//char_time_minutes//'-' & - //adjustl(char_time_seconds) - write(*,'(a,g14.6,a,a)')' time (min) =',time,' h-m-s:',hours - - return - end subroutine min2hr - diff --git a/src/rcm/rcmutorcm.F90 b/src/rcm/rcmutorcm.F90 deleted file mode 100644 index 6ec9e669..00000000 --- a/src/rcm/rcmutorcm.F90 +++ /dev/null @@ -1,268 +0,0 @@ -! program to convert rcmu2.dat file to tecplot (as written by torcm.f90) -! 5/05 frt - program rcmu22tecplot - implicit none - - integer :: idim,jdim,kdim - integer :: i,j,k,kk - integer :: itime,itime0,itimef - integer, allocatable, dimension(:) :: ikflav - integer :: ilast - - real :: time,start_time_min,time_min,eps,r,pi,dpi - real, allocatable, dimension(:) :: alam,etac - real, allocatable, dimension(:,:) :: xi,yi,zi,rmin,pmin - real, allocatable, dimension(:,:) :: xe,ye,ze - real, allocatable, dimension(:,:) :: vm,v,birk,bmin,pressure,pvg - real, allocatable, dimension(:,:) :: dens,ti,te - real, allocatable, dimension(:,:,:) :: eeta,veff - integer, allocatable, dimension(:,:) :: open - real,parameter :: boltz = 1.38e-23 ! boltzmann constant - real,parameter :: ev = 1.6e-19 ! electron volt - - logical :: threed - logical :: onefile,opened - - character (len=9) :: chartime - character (len=45) :: tecoutfile - character (len=1) :: ans - - pi = acos(-1.0) - dpi = pi/180. - - write(*,'(a,$)')' enter the time to start, end reading: ' - read(5,*)itime0,itimef - write(*,'(a,$)')' enter start time on min: ' - read(5,*)start_time_min - - write(*,'(a,$)')' do you want 3d data information (y/n)?: ' - threed=.false. - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')threed=.true. - write(*,'(a,$)')' do you want it all in one file (y/n)?: ' - onefile=.false. - read(5,'(a1)')ans - if(ans.eq.'y'.or.ans.eq.'Y')onefile=.true. - opened = .false. - - open(unit=1,file='rcmu2.dat',status='old',action='read',& - form='unformatted') - - itime = 0 - - do - if(itime <= itimef)then - - read(1,end=10)idim,jdim,kdim - - write(*,*)' idim =',idim,'jdim =',jdim,' kdim =',kdim - -! only allocate once - if( .not.allocated(alam)) then - allocate (alam(kdim),etac(kdim),ikflav(kdim)) - allocate (xi(idim,jdim),yi(idim,jdim),zi(idim,jdim)) - allocate (rmin(idim,jdim),pmin(idim,jdim)) - allocate (xe(idim,jdim),ye(idim,jdim),ze(idim,jdim)) - allocate (vm(idim,jdim),v(idim,jdim),birk(idim,jdim)) - allocate (dens(idim,jdim),ti(idim,jdim),te(idim,jdim)) - allocate (eeta(idim,jdim,kdim),bmin(idim,jdim)) - allocate (open(idim,jdim)) - allocate (veff(idim,jdim,kdim)) - allocate (pressure(idim,jdim)) - allocate (pvg(idim,jdim)) - end if - - read(1) itime, alam, xi, yi, zi, rmin, pmin, & - open, vm, pressure, dens, bmin, ti, te, eeta - write(*,*)' reading in time =',itime - if(itime > itimef)stop - -! write(*,*)'alam: ',alam -! output file - if(itime >= itime0)then - time_min = itime/60.+start_time_min - call min2hr(time_min,chartime) - - if(.not.opened.and.onefile)then - if(threed)then - - tecoutfile = adjustr('tec3d') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - - else - - tecoutfile = adjustr('tec') // chartime // '.dat' - write(*,*)' writing file =',tecoutfile - - endif - endif -! compute xe,ye - do j=1,jdim - do i=1,idim - xe(i,j) = rmin(i,j)*cos(pmin(i,j)) - ye(i,j) = rmin(i,j)*sin(pmin(i,j)) - end do - end do - - if(.not.opened) open(unit=2,file=tecoutfile,status='unknown',& - recl=200) -! add corotation - do j=1,jdim - do i=1,idim - if(vm(i,j) > 0)then - r = sqrt(xe(i,j)**2+ye(i,j)**2) - end if - end do - end do -! now set the pressure - do i=ilast,idim - do kk=1,kdim - pressure(i,j) = pressure(i,j) + 1.67e-35*abs(alam(kk))*& - eeta(i,j,kk)*vm(i,j)**2.5 - veff(i,j,k) = v(i,j) + vm(i,j)*alam(k) - end do - end do - where(vm > 0) - pvg = pressure*vm**(-2.5)*1.0e9 ! converts to nPa/(re/nt)^5/3 - elsewhere - pressure = 0.0 - pvg = 0.0 - end where -! process the data - do j=1,jdim - ilast = 1 - do i=idim,2,-1 - if(vm(i-1,j) < 0)then - ilast = i - exit - end if - end do -! write(*,*)' for j= ',j,' ilast =',ilast -! write(*,*)' vm ilast =',vm(ilast,j) - - eps = 1.0e-3 - do i=ilast-1,1,-1 - xe(i,j) = xe(i+1,j)*(1 + eps) - ye(i,j) = ye(i+1,j)*(1 + eps) - end do - end do -! now output the data - - if(threed)then - if(.not.opened)then - write(2,*)' VARIABLES =, "xe(Re)" "ye(Re)" "xi(Re)" '& - ,'"yi(Re)" "zi(Re)" "pressure(Pa)"'& - ,'"pVg(nPa(re/nt)^5/3)" '& - ,'"eeta" "alam"'& - ,'"dens(cc)" "bmin(nT)" "ti(eV)" "te(eV)" "vm"' - end if - write(2,*)' ZONE, T ="',itime,'" ,I=',idim,' ,J=',jdim ,' ,K=',kdim & - ,', DATAPACKING=POINT' - else - if(.not.opened)then - write(2,*)' VARIABLES =, "xe(Re)" "ye(Re)" "xi(Re)" "yi(Re)" '& - ,'"zi(Re)" "pressure(Pa)"'& - ,'"pVg(nPa(re/nt)^5/3)" '& - ,'"eeta" "alam" "dens(cc)" "bmin(nT)" "ti(eV)" "te(eV)"'& - ,'"vm"' - end if - write(2,*)' ZONE, T ="',itime,'" ,I=',idim,' ,J=',jdim ,& - ', DATAPACKING=POINT' - end if - - write(2,*)' AUXDATA TIME ="',chartime,'"' - - opened = .true. - - ! if(threed)then - ! do k=1,kdim - ! do j=1,jdim - - ! do i=1,idim - ! write(2,21)xe(i,j),ye(i,j),xi(i,j),yi(i,j),zi(i,j),& - ! pressure(i,j),& - ! pvg(i,j),eeta(i,j,k),alam(k),& - ! dens(i,j)/1.0e6,bmin(i,j),& - ! ti(i,j)*boltz/ev,te(i,j)*boltz/ev,vm(i,j) - ! 21 format(14(g12.6,1x)) - ! end do - ! end do - ! end do - ! else - - ! do j=1,jdim - ! k = 1 - ! do i=1,idim - ! write(2,11)xe(i,j),ye(i,j),xi(i,j),yi(i,j),zi(i,j),& - ! pressure(i,j),& - ! pvg(i,j),eeta(i,j,k),alam(k),& - ! dens(i,j)/1.0e6,bmin(i,j),& - ! ti(i,j)*boltz/ev,te(i,j)*boltz/ev,vm(i,j) - ! 11 format(13(g12.6,1x)) - ! end do - ! end do - ! end if - - if(.not.onefile)then - opened=.false. - close(2) - else - opened=.true. - endif - -! system dependent, comment out -! if(.not.opened)then -! CALL System ('/Applications/Tec100/bin/preplot '//tecoutfile) -! CALL System ('rm '//tecoutfile) -! end if - end if - - else - exit - end if - - end do - if(onefile)then - close(2) -! system dependent, comment out -! CALL System ('/Applications/Tec100/bin/preplot '//tecoutfile) -! CALL System ('rm '//tecoutfile) - end if - - 10 stop - - end program rcmu22tecplot -!----------------------------------- - subroutine min2hr(time,hours) -! returns a string of hr:min:sec from an input in minutes -! 2/04 frt - implicit none - real :: time - real :: time_hours - real :: time_minutes - real :: time_seconds - character (len=*) :: hours - character (len=3) :: char_time_hours - character (len=2) :: char_time_minutes,char_time_seconds -! time is in minutes - - time_hours = floor(time/60.) - time_minutes = floor(time - 60*time_hours) - time_seconds = 60*(time -floor(time)) - - write(char_time_hours,'(i3.3)')int(time_hours) - write(*,*)' char_time_hours =',char_time_hours -! if(int(time_hours) < 10)then -! char_time_hours = '00'//adjustr(char_time_hours) -! endif -! write(*,*)' char_time_hours =',char_time_hours - write(char_time_minutes,'(i2.2)')int(time_minutes) - write(char_time_seconds,'(i2.2)')int(time_seconds) - write(*,*)' char_time_seconds =',char_time_seconds - - hours = adjustr(char_time_hours) //':'//char_time_minutes//':' & - //adjustl(char_time_seconds) - - return - end subroutine min2hr - diff --git a/src/rcm/read_alam.F90 b/src/rcm/read_alam.F90 deleted file mode 100644 index cf8e9317..00000000 --- a/src/rcm/read_alam.F90 +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE Read_alam (kdim, alam, iflav,fudge, almdel, & - almmax, almmin, iedim, ierr) - use rcmdefs - USE rcm_precision - use ioh5 - use files - - IMPLICIT NONE - INTEGER(iprec), INTENT (IN) :: kdim, iedim - INTEGER(iprec), INTENT (OUT) :: ierr - REAL(rprec), INTENT (IN OUT) :: alam(kdim), almdel(kdim), & - almmax(kdim), almmin(kdim), fudge(kdim) - INTEGER(iprec), INTENT (IN OUT), DIMENSION (kdim) :: iflav -! -! This routine was re-designed so that it communicates with -! the outside world only through its list of arguments. -! Thus, can use it to get information for grid-based energy -! channels, or for edges. (Stanislav) -! - INTEGER(iprec) :: NIn,k, iflavin, ie, lun = 1 - INTEGER(iprec) :: num_chan (iedim), k_start, k_stop - REAL(rprec) :: alamin, amin, amax,fudgein - LOGICAL :: lflag_1, lflag_2 -! - type(IOVAR_T), dimension(RCMIOVARS) :: IOVars !Lazy hard-coding max variables - logical :: doSP - - INCLUDE 'rcmdir.h' -! - if (isGAMRCM) then - - !Use Gamera HDF5 stuff - doSP = .false. - call ClearIO(IOVars) !Reset IO chain - call AddInVar(IOVars,"ikflavc") - call AddInVar(IOVars,"alamc") - call AddInVar(IOVars,"fudgec") - call ReadVars(IOVars,doSP,RCMGAMConfig) - - !Test all read variables to have the right size - do k=1,3 - NIn = IOVars(k)%N - if (NIn /= kdim) then - write(*,*) 'RCM configuration error, mismatched k sizes ...' - stop - endif - enddo - - !Lazily replicating loop from below - DO k = 1, kdim - iflavin = IOVars(1)%data(k) - alamin = IOVars(2)%data(k) - fudgein = IOVars(3)%data(k) - - IF (iflavin == 1) THEN - alam (k) = alamin - IF (alam(k) > 0.0) alam(k) = - alam(k) -! fudge (k) = 0.3333 - fudge (k) = fudgein - iflav (k) = 1 - ELSE IF (iflavin == 2) THEN - alam (k) = alamin -! fudge (k) = 0.0000 - fudge (k) = fudgein - iflav (k) = 2 - ELSE - STOP 'ILLEGAL TYPE OF SPECIES' - END IF - - ENDDO !k - - else - write(*,*) "This ain't gonna work!" - stop - - endif !isGAMRCM -! -! -! check to see how many different types of speces there are -! - num_chan(:) = 0 - DO k = 1, kdim - ie = iflav (k) - num_chan (ie) = num_chan (ie) + 1 - IF (num_chan(ie) > 1) THEN - IF (ABS(alam(k)) < ABS(alam(k-1))) THEN - STOP ' ERROR: enchan channels not in increasing order' - END IF - IF (ie > iedim) STOP 'ILLEGAL SPECIES IN READ_ALAM' - END IF - END DO -! -! - DO k = 1, kdim - ie = iflav (k) - IF (num_chan(ie) == 1) THEN - almmax (k) = 2.0*alam(k) - almmin (k) = 0.0 - ELSE - IF (ie == 1) THEN - k_start = 1 - k_stop = num_chan (ie) - ELSE IF (ie == 2) THEN - k_start = num_chan(ie-1)+1 - k_stop = num_chan(ie-1)+num_chan(ie) - ELSE - STOP 'WRONG IE' - END IF - - IF (k == k_start) THEN - almmax(k) = 0.5*(ABS(alam(k))+ABS(alam(k+1))) - almmin(k) = 0.0 - ELSE IF (k == k_stop) THEN - almmax(k) = 1.5*ABS(alam(k)) - 0.5*ABS(alam(k-1)) - almmin(k) = 0.5*(ABS(alam(k-1))+ABS(alam(k))) - ELSE - almmax(k) = 0.5*(ABS(alam(k))+ABS(alam(k+1))) - almmin(k) = 0.5*(ABS(alam(k-1))+ABS(alam(k))) - END IF - END IF - almdel(k)= ABS(almmax(k))-ABS(almmin(k)) - END DO -! - ierr = 0 - RETURN - 100 WRITE (*,'(T2,A)') 'error on opening enchan.dat' - ierr = -1 - - RETURN - END SUBROUTINE Read_alam diff --git a/src/rcm/tomhd.F90 b/src/rcm/tomhd.F90 deleted file mode 100644 index 6fdfa7fb..00000000 --- a/src/rcm/tomhd.F90 +++ /dev/null @@ -1,281 +0,0 @@ -MODULE tomhd_mod - USE rcm_precision - USE rice_housekeeping_module - USE rcm_mhd_interfaces - USE kdefs, ONLY : TINY - USE constants, ONLY : mass_proton,mass_electron,nt,ev,tiote,boltz - USE Rcm_mod_subs, ONLY : isize, jsize, kcsize,jwrap,alamc,ikflavc - USE earthhelper, ONLY : GallagherXY,DP2kT - USE etautils - USE math - - implicit none - - contains - - SUBROUTINE tomhd (RM, ierr) -! -!============================================================== -! purpose: -! To convert RCM information (eta), to MHD information (p,n) -! It also writes to files (optional): -! 'rcmu.dat' = unformatted time-averaged rcm data for analysis -! -! inputs: -! -! 4/18/95 rws -! 9/18/95 frt -! 9/1/98 this version takes into account the the rcm record -! can differ to the record -! 7/09 -restructured to use modules and allow to transfer -! the LFM grid - frt -! 2/19 -modified version to connect to gamera - frt -! 5/20 -removed use of record numbers in rcm bookkeeping -! - also adds output from plasmasphere model by Shanshan Bao -! 5/20/20 - removed idim,jdim -frt -! -! -!============================================================== - - USE Rcm_mod_subs, ONLY : bmin,birk,xmin,ymin,zmin,vm,eeta,eeta_avg, & - bndloc,pressrcm,densrcm,denspsph,imin_j,eflux,eavg,nflux - - - IMPLICIT NONE - type(rcm_mhd_T),intent(inout) :: RM - INTEGER(iprec), INTENT (OUT) :: ierr - - REAL(rprec), dimension(isize,jsize) :: Pircm,Percm - integer :: n - - !Always set p/d_factors - call SetFactors(RM%planet_radius) - - !Do some checks on the RCM eta distribution - if (doRelax) call RelaxEta(eeta,eeta_avg,vm,RM) - - !Now pick which eta (instant vs. avg) and calculate moments - if (doAvg2MHD) then - call rcm2moments(eeta_avg,vm,densrcm,denspsph,pressrcm,Pircm,Percm) - else - call rcm2moments(eeta ,vm,densrcm,denspsph,pressrcm,Pircm,Percm) - endif - - RM%MaxAlam = maxval(alamc) - - !Update arrays in the MHD-RCM object - call Unbiggen(pressrcm,RM%Prcm ) - call Unbiggen(Percm ,RM%Percm) - - call Unbiggen(densrcm ,RM%Nrcm ) - call Unbiggen(denspsph,RM%Npsph) - call Unbiggen(birk ,RM%fac ) - do n=1,2 - call Unbiggen(nflux(:,:,n),RM%nflx (:,:,n)) - call Unbiggen(eflux(:,:,n),RM%flux (:,:,n)) - call Unbiggen(eavg (:,:,n),RM%eng_avg(:,:,n)) - enddo - - ierr = 0 - - END SUBROUTINE tomhd - - !Do some safety stuff to eta w/ temperature is high - SUBROUTINE RelaxEta(eta,eta_avg,vm,RCMApp) - USE Rcm_mod_subs, ONLY : rmin - IMPLICIT NONE - - REAL(rprec), intent(inout), dimension(isize,jsize,kcsize) :: eta,eta_avg - REAL(rprec), intent(in) :: vm(isize,jsize) - type(rcm_mhd_T),intent(in) :: RCMApp - - REAL(rprec), dimension(isize,jsize) :: Drc,Dpp,Prc,Lb,Tb,Pion,Pele - integer :: i,j,jp,klow,k - REAL(rprec), dimension(kcsize) :: etaMax,etaNew,etaOld - REAL(rprec) :: TauDP,wDP,wgt - - !Set lowest RC channel - if (use_plasmasphere) then - klow = 2 - else - klow = 1 - endif - - !Get moments from eta - call rcm2moments(eta,vm,Drc,Dpp,Prc,Pion,Pele) - - !Map Lb from RCM-MHD grid to RCM grid, Lb = Tube length [m] - call EmbiggenWrap(RCMApp%Lb,Lb) - !Convert to km - Lb = RCMApp%planet_radius*Lb*1.0e-3 - - call EmbiggenWrap(RCMApp%Tb,Tb) - - !Now loop over i,j and relax in energy space by blending w/ Maxwellian - !Get weights for Maxwellian part of blend - !eta_{R} = w * eta_{Maxwellian} + (1-w) * eta - !Thermal bounce: w = dtCpl/tau, tau = sound wave bounce period - !Grid bounce: w = kT_{RCM}/kT_{Top}, ratio of effective temperature to largest grid energy - - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,jp,TauDP,wDP,wgt,k) & - !$OMP private(etaMax,etaNew,etaOld) - DO j = 1, jsize - !i,j is index in RCM grid - !i,jp is index in RCM-MHD grid - if (j>=jwrap) then - jp = j-jwrap+1 - else - !j (RCM) => jsize-jwrap+j (RCM) => jsize-jwrap+j-jwrap+1 (RCM-MHD) - jp = jsize-jwrap+j-jwrap+1 - endif - - DO i = 1, isize - IF (vm (i,j) < 0.0) CYCLE - IF (Drc(i,j) < TINY) CYCLE - - !Get Maxwellian (or kappa) to blend with - !Enforce floors - Drc (i,j) = max(Drc (i,j),rcm_dFloor/rcmNScl) - Pion(i,j) = max(Pion(i,j),rcm_pFloor/rcmPScl) - Pele(i,j) = max(Pele(i,j),rcm_pFloor/rcmPScl) - - call DPP2eta(Drc(i,j),Pion(i,j),Pele(i,j),vm(i,j),etaMax) - !Get timescale to blend over - TauDP = DriftPeriod(Drc(i,j),Prc(i,j),rmin(i,j),RCMApp%Bmin(i,jp),RCMApp%radcurv(i,jp),RCMApp%planet_radius) - wDP = RCMApp%dtCpl/TauDP !Drift period - call ClampWeight(wDP) - !Choose which weight to use - wgt = wDP - - !Now do blending - etaOld = eta(i,j,:) - do k=1,kcsize - if (alamc(k)>TINY) then - !Ions - if (Pion(i,j)>TINY) then - etaNew(k) = (1-wgt)*etaOld(k) + wgt*etaMax(k) - else - etaNew(k) = etaOld(k) - endif !Pion>TINY - else if (alamc(k)<-TINY) then - !Electrons - if (Pele(i,j)>TINY) then - etaNew(k) = (1-wgt)*etaOld(k) + wgt*etaMax(k) - else - etaNew(k) = etaOld(k) - endif !Pele > TINY - else - !plasmasphere - etaNew(k) = etaOld(k) - endif !alamc - - enddo - eta(i,j,:) = etaNew - - ENDDO - ENDDO !j loop - - contains - - !L [Rp], Rc [Rp], Rp[m] - function DriftPeriod(n,P,L,Bmin,Rc,Rp) result(TauD) - REAL(rprec), intent(in) :: n,P,L,Bmin,Rc,Rp - REAL(rprec) :: TauD - REAL(rprec) :: keV,Bnt,Vd - - keV = DP2kT(n*rcmNScl,P*rcmPScl) !Temp in keV - Bnt = Bmin*1.0e+9 !B in nT - - !Using, Vd = 156*K/Rc/B, K[keV],Rc[Re],B[nT] - - Vd = (1.0e+3)*156.0*keV/Rc/Bnt !m/s - TauD = 2.0*PI*L*Rp/Vd - !write(*,*) 'Tau = ', TauD,DipoleDriftPeriod(n,P,L) - end function DriftPeriod - - function DipoleDriftPeriod(n,P,L) result(TauD) - REAL(rprec), intent(in) :: n,P,L - REAL(rprec) :: TauD - REAL(rprec) :: keV - - keV = DP2kT(n*rcmNScl,P*rcmPScl) !Temp in keV - !Using, Td = 700/K/L hrs - TauD = (60.0*60.0)*700/(keV*L) - end function DipoleDriftPeriod - - !Return sound wave bounce period [s], take n/P in RCM units and L [km] - function CsBounce(n,P,L) result(TauCS) - REAL(rprec), intent(in) :: n,P,L - REAL(rprec) :: TauCS - REAL(rprec) :: TiEV,CsMKS - - integer, parameter :: nBounce = 8 !Number of bounces to equilibrate - - TiEV = (1.0e+3)*DP2kT(n*rcmNScl,P*rcmPScl) !Temp in eV - !CsMKS = 9.79 x sqrt(5/3 * Ti) km/s, Ti eV - CsMKS = 9.79*sqrt((5.0/3)*TiEV) - TauCS = 2*nBounce*L/CsMKS - end function CsBounce - - function GridWeight(n,P,vm,alamax) result(wgt) - REAL(rprec), intent(in) :: n,P,vm,alamax - REAL(rprec) :: wgt - REAL(rprec) :: kevMHD,kevRCM - - kevMHD = DP2kT(n*rcmNScl,P*rcmPScl) !Get keV from RCM moments - kevRCM = abs(alamax)*vm*1.0e-3 !keV of max RCM energy channel - - wgt = kevMHD/kevRCM - call ClampWeight(wgt) - end function GridWeight - - !Clamps weight in [0,1] - subroutine ClampWeight(wgt) - REAL(rprec), intent(inout) :: wgt - if (wgt<0.0) wgt = 0.0 - if (wgt>1.0) wgt = 1.0 - end subroutine ClampWeight - - END SUBROUTINE RelaxEta - - - !Convert given eeta to density (RC/plasmasphere) and pressure - SUBROUTINE rcm2moments(eta,vm,Drc,Dpp,Prc,Pion,Pele) - USE Rcm_mod_subs, ONLY : xmin,ymin,zmin - IMPLICIT NONE - REAL(rprec), intent(in) :: eta(isize,jsize,kcsize) - REAL(rprec), intent(in) :: vm(isize,jsize) - REAL(rprec), intent(out), dimension(isize,jsize) :: Drc,Dpp,Prc - REAL(rprec), intent(out), dimension(isize,jsize), optional :: Pion,Pele - INTEGER (iprec) :: i,j - LOGICAL :: doIE - - Drc = 0.0 - Dpp = 0.0 - Prc = 0.0 - if (present(Pion) .and. present(Pele)) then - Pion = 0.0 - Pele = 0.0 - doIE = .true. - else - doIE = .false. - endif - - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j) - DO j = 1, jsize - DO i = 1, isize - !Get density and pressure, possibly w/ extra charge neutrality assumption - call eta2DP(eta(i,j,:),vm(i,j),Drc(i,j),Dpp(i,j),Prc(i,j),doQ0) - if (doIE) then - call IntegratePressureIE(eta(i,j,:),vm(i,j),Pion(i,j),Pele(i,j)) !Get separated pressures - endif - ENDDO - ENDDO !J loop - - END SUBROUTINE rcm2moments - -END MODULE tomhd_mod diff --git a/src/rcm/torcm.F90 b/src/rcm/torcm.F90 deleted file mode 100644 index e566651d..00000000 --- a/src/rcm/torcm.F90 +++ /dev/null @@ -1,1091 +0,0 @@ - -MODULE torcm_mod - USE rcm_precision - USE constants, only: big_vm,tiote,nt,ev,boltz - USE rice_housekeeping_module, ONLY: use_plasmasphere,LowLatMHD,L_write_vars_debug - USE rcm_mhd_interfaces - USE rcmdefs, ONLY : RCMTOPCLOSED,RCMTOPNULL,RCMTOPOPEN,DenPP0 - USE kdefs, ONLY : TINY - USE math, ONLY : RampDown - USE etautils - implicit none - - integer(iprec), private, parameter :: NumG = 4 !How many buffer cells to require - - contains -!================================================================== - SUBROUTINE Torcm (RM, itimei, ierr, icontrol) - - USE Rcm_mod_subs, ONLY : isize,jsize, jwrap, kcsize, iesize, & - vm, bmin, xmin, ymin, pmin, rmin,v, & - alamc, etac, ikflavc, fudgec, eeta, & - imin_j, bndloc, vbnd, & - colat, aloct, bir, sini, & - ibnd_type,rcmdir - USE conversion_module - USE earthhelper, ONLY : GallagherXY - -! NOTE: This version fixes the rcm boundary condition at rec=1 -!=================================================================== -! -! purpose: to setup rcm for a run, converts mhd information to -! rcm information -! -! inputs: -! rec_in = record to be updated with new values -! rec == 1: resets the rcm and initializes the files -! rec > 1: only boundary conditions are updated -! itimei = time to write to rcm records -! -! outputs: -! ierr = error flag if there is a problem -! -!=================================================================== -! -! last update: 05.18.90 -! 04.13.95 -! 96 -! 20.01.00 frt mc version -! 8.03 frt computes integral average pressure -! 06.01.04 frt cleaned up version -! 09.10.12 frt added code to handle tilt -! 19.05.20 frt removed use of records in rcm -! frt remove use of idim,jdim,kdim -! -!=================================================================== - - IMPLICIT NONE - type(rcm_mhd_T),intent(inout) :: RM - REAL(rprec), INTENT (IN) :: itimei - INTEGER(iprec), INTENT (IN) :: icontrol - INTEGER(iprec), INTENT (IN OUT) :: ierr - - INTEGER(iprec) :: kin,jmid,ibnd, inew, iold - INTEGER(iprec) :: jm,jp,ip,itmax - INTEGER(iprec) :: min0,i,j,k,n,ns,klow,n_smooth - LOGICAL,PARAMETER :: use_ellipse = .true. - LOGICAL, SAVE :: doReadALAM = .true. - REAL(rprec) :: dpp,wMHD,wRCM - - !K: 8/20, rewritten to try to better incorporate immersed boundary BCs - !iopen: -1 (RCMTOPCLOSED), CLOSED & inside RCM ellipse - ! +1 (RCMTOPOPEN) , OPEN & definitely outside RCM domain - ! 0 (RCMTOPNULL) , CLOSED & outside RCM domain - - ierr = 0 - - !Set density/pressure factors - call SetFactors(RM%planet_radius) - - !Start by reading alam channels if they're not yet set - !Rewriting this bit to not read_alam every call, K: 8/20 - if (doReadALAM) then - CALL Read_alam (kcsize, alamc, ikflavc, fudgec, almdel, almmax, almmin, iesize, ierr) - doReadALAM = .false. - IF (ierr < 0) RETURN - !Go ahead and do some other init stuff while you're here - LowLatMHD = RM%llBC - endif - - !Set lowest RC channel - if (use_plasmasphere) then - klow = 2 - else - klow = 1 - endif - - !If T>0, save certain arrays before modifying anything - IF (icontrol==RCMADVANCE.or.icontrol==RCMRESTART) then - bndloc_old = bndloc - imin_j_old = imin_j - if(minval(bndloc) <= 0)then - write(6,*) ' TORCM: boundary problem' - write(6,*)' bndloc:',bndloc - ierr = -1 - return - - end if - END IF - - ! get B-field lines starting from RCM ionospheric grid - ! points, compute flux-tube volume of field lines that are - ! closed, and mark open ones with a mask array OPEN - ! (1=open, -1=closed). For open field lines, FTV is set to big_vm: - - CALL Calc_ftv (RM,big_vm,ierr) - IF (ierr < 0) THEN - write(6,*) 'calc_ftv problem' - RETURN - ENDIF - - !----- - !Domain calculation - - ! Now, set RCM high-latitude grid boundary. Initially, - ! for each MLT, we find the grid point with highest - ! latitude and still on closed field lines; the point - ! next to it (down in latitude) is set to be boundary. - ! Result of this subsection is to populate arrays BNDLOC - ! and IMIN_J with values: - do j=1,jsize - bndloc(j) = 2 ! if everything else fails, can use this... - do i=isize,2,-1 - if (iopen(i,j) >= 0) then !null or open - bndloc(j) = i + 2 !Adding buffer cell/s here - exit - endif - end do - end do - ! reset imin_j - imin_j = ceiling(bndloc) - IF (L_write_vars_debug) then - write(6,*)' bndy ',bndloc(j),j,vm(imin_j(j),j) - END IF - - ! fits an ellipse to the boundary - !K: 8/20, changing ellipse so that it doesn't reset vm unless open - if (use_ellipse) then - CALL Set_ellipse(isize,jsize,rmin,pmin,vm,big_vm,bndloc,iopen) - end if - - call reset_rcm_vm(isize,jsize,bndloc,big_vm,imin_j,vm,iopen) - - !Smooth boundary location - !NOTE: This can only shrink RCM domain, not increase - !K: 8/20, changing reset_rcm_vm to only reset VM on open fields - !Calculate number of smoothing iterations based on longitudinal cell size - !Approx. 1hr MLT - !n_smooth = 5 - - if (doSmoothBNDLOC) then - n_smooth = nint( 15.0/(360.0/jsize) ) - else - n_smooth = NumG - endif - - do ns=1,n_smooth - call smooth_boundary_location(isize,jsize,jwrap,bndloc) - call reset_rcm_vm(isize,jsize,bndloc,big_vm,imin_j,vm,iopen) ! adjust Imin_j - enddo - - !----- - !MHD thermodynamics - IF (icontrol==RCMCOLDSTART .and. use_plasmasphere) THEN - eeta(:,:,1) = 0.0 !Make sure no plasmasphere for first cold start calculation - ENDIF - - !---->Set new EETA from MHD code pressure. - ! On open field lines, values of ETA will be zero: - call MHD2eta(RM,ierr) - IF (ierr < 0) RETURN - - if ( (maxval(eeta_new) <=0) .or. any(isnan(eeta_new)) ) then - write(6,*)' something is wrong in eeta_new' - write(6,*) 'maxval = ', maxval(eeta_new) - write(6,*) 'Num nans = ', count(isnan(eeta_new)) - ierr = -1 - return - end if - - !Handle cold start, must happen after eeta_new is calculated (temp/press2eta) - IF (icontrol==RCMCOLDSTART) THEN - !write(6,*)' TORCM: initializing the RCM arrays at t=',itimei - bndloc_old = bndloc - imin_j_old = imin_j - !Now set RCM domain values to MHD state values - do j=1,jsize - do i=1,isize - !Don't worry about plasmasphere, that channel will get reset anyways - if (iopen(i,j) == RCMTOPOPEN) then - eeta(i,j,:) = 0.0 - else - eeta(i,j,:) = eeta_new(i,j,:) - endif - enddo - enddo - ENDIF - - ! just in case: - imin_j = CEILING(bndloc) - imin_j_old = CEILING(bndloc_old) - - ! initialize the dynamic plasmasphere, reset static part if necessary - !sbao 03282020 - if (use_plasmasphere) then - call set_plasmasphere(icontrol,isize,jsize,kcsize,xmin,ymin,rmin,vm,eeta,imin_j) - - if (doPPSmooth) then - !Adding some smoothing to the plasmapause - call SmoothPPause(eeta(:,:,1),vm,iopen,imin_j,RM%dtCpl) - endif - endif - - - !Incorporate MHD-produced values into newly-acquired RCM cells - DO j=1,jsize - inew = imin_j(j) - iold = imin_j_old(j) - if (inew <= iold) then - eeta(inew:iold,j,klow:) = eeta_new(inew:iold,j,klow:) - endif - ENDDO - - - !----- - !Fill in grid ghosts - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,dpp) - do j=1,jsize - do i=1,isize - if (iopen(i,j) == RCMTOPOPEN) then - !Zap everything here - eeta(i,j,:) = 0.0 - vm (i,j) = big_vm - !Reset mapping on open lines - rmin(i,j) = 0.0 - pmin(i,j) = 0.0 - xmin(i,j) = 0.0 - ymin(i,j) = 0.0 - - else if (iopen(i,j) == RCMTOPNULL) then - !This is closed field region but outside RCM domain - !Use MHD information for RC channels - eeta(i,j,klow:) = eeta_new(i,j,klow:) - - endif !iopen - - if (use_plasmasphere .and. iopen(i,j) /= RCMTOPOPEN) then - !Check for below plasmasphere cutoff - dpp = GetDensityFactor()*1.0*eeta(i,j,1)*vm(i,j)**1.5 - if (dpp < DenPP0*1.0e+6) eeta(i,j,1) = 0.0 - endif !plasmasphere - - enddo !i - enddo !j - - !Finally decide which channels are worth advancing (ie contribute an interesting amount) - call SetKBounds(RM%NkT) - - !----- - !Finish up and get out of here - - ! import ionosphere - call Ionosphere_toRCM(RM) - - !Do sanity check - DO j = 1, jsize - DO i = imin_j(j),isize - IF (vm(i,j) <= 0.0) THEN - write(6,*) 'vm problem in TORCM' - ierr = -1 - return - ENDIF - END DO - END DO - - !Return updates to topology, CLOSED=>NULL in buffer region to RM object - RM%iopen = iopen (:,jwrap:jsize) - - if (any(isnan(eeta))) then - write(6,*) 'Bad eeta at end of torcm!' - ierr = -1 - return - endif - - RETURN - END SUBROUTINE Torcm - - !Smooth ragged edges at the plasmapause -!---------------------------------------------------------- - SUBROUTINE SmoothPPause(etapp,vm,iopen,imin_j,dtCpl) - USE rcmdefs,ONLY : isize,jsize - USE RCM_mod_subs,ONLY : dtAvg_v - - IMPLICIT NONE - REAL(rprec) , INTENT(INOUT) :: etapp(isize,jsize) - REAL(rprec) , INTENT(IN) :: vm(isize,jsize) - INTEGER(iprec), INTENT(IN) :: iopen(isize,jsize) - INTEGER(iprec), INTENT(IN) :: imin_j(jsize) - REAL(rprec) , INTENT(IN) :: dtCpl - - REAL(rprec) :: bndlocpp(jsize),bndlocpp_new(jsize) - INTEGER(iprec) :: imin_jpp(jsize) - INTEGER(iprec) :: i,j,n,n_smooth,di - REAL(rprec) :: dpp,Ac(3),ppscl - INTEGER(iprec), parameter :: NumI = NumG - - !Find plasmapause - do j=1,jsize - !For fixed j start from far and go near, find first value above DenPP0 - do i = 2,isize - dpp = GetDensityFactor()*1.0*etapp(i,j)*vm(i,j)**1.5 - if (dpp >= DenPP0*1.0e+6) then - bndlocpp(j) = i-1 - imin_jpp(j) = i-1 - exit - endif !Above plasmapause cutoff - enddo !i loop - enddo !j loop - - !Now do smoothing on real-valued boundary - n_smooth = nint( 5.0/(360.0/jsize) ) !Arbitrary 5deg window - - do n=1,n_smooth - call SmoothJBnd(bndlocpp,bndlocpp_new) - bndlocpp = bndlocpp_new - enddo - - !Convert to indices - imin_jpp = ceiling(bndlocpp) - - !Deplete below plasmapause - !Attenuate over dtAvg_v - ppscl = exp(-dtCpl/max(dtAvg_v,dtCpl)) - - do j=1,jsize - do i=1,imin_jpp(j) - etapp(i,j) = ppscl*etapp(i,j) - enddo - enddo - - END SUBROUTINE SmoothPPause - - !Smooth real-valued bndloc, store in bndloc_new - SUBROUTINE SmoothJBnd(bndloc,bndloc_new) - USE rcmdefs,ONLY : jsize - IMPLICIT NONE - REAL(rprec), INTENT(IN ) :: bndloc(jsize) - REAL(rprec), INTENT(OUT) :: bndloc_new(jsize) - - REAL(rprec), PARAMETER :: am = 1, a0 = 2, ap = 1 - INTEGER(iprec) :: j,jm,jp - - bndloc_new = 0.0 - - do j=1,jsize - ! 1 <=> jdim -jwrap +1 - ! jdim <=> jwrap - - jm = j - 1 - if(jm < 1) jm = jsize - jwrap - jp = j + 1 - if(jp > jsize) jp = jwrap + 1 - !Use 3-pt stencil - bndloc_new(j) = (am*bndloc(jm) + a0*bndloc(j) + ap*bndloc(jp))/(am+a0+ap) - - enddo - - END SUBROUTINE SmoothJBnd - - !Smooth eta k-slice over ibnd_j + di using coefficients Ac (--,-,0) - SUBROUTINE SmoothJEta(etak,iopen,ibnd_j,di,Ac) - USE rcmdefs,ONLY : isize,jsize,jwrap - IMPLICIT NONE - - REAL(rprec), INTENT(INOUT) :: etak(isize,jsize) - INTEGER(iprec), INTENT(IN) :: iopen(isize,jsize) - INTEGER(iprec), INTENT(IN) :: ibnd_j(jsize) - INTEGER(iprec), INTENT(IN) :: di - REAL(rprec), INTENT(IN) :: Ac(3) - - logical :: isOpen(5) - REAL(rprec) :: etaks(jsize) - REAL(rprec) :: a1,a2,a3,a4,a5 - INTEGER(iprec) :: jmm,jm,j,jp,jpp - a1 = Ac(1) ; a2 = Ac(2) ; a3 = Ac(3) ; a4 = a2 ; a5 = a1 - - do j=1,jsize - !Get indices - ! 1 <=> jdim -jwrap +1 - ! jdim <=> jwrap - jmm = j - 2 - if(jmm < 1)jmm = jsize - jwrap - 1 - jm = j - 1 - if(jm < 1) jm = jsize - jwrap - jpp = j + 2 - if(jpp > jsize)jpp = jwrap + 2 - jp = j + 1 - if(jp > jsize) jp = jwrap + 1 - - !Check topology - isOpen(1) = (iopen(ibnd_j(jmm)+di,jmm) == RCMTOPOPEN) - isOpen(2) = (iopen(ibnd_j(jm )+di,jm ) == RCMTOPOPEN) - isOpen(3) = (iopen(ibnd_j(j )+di,j ) == RCMTOPOPEN) - isOpen(4) = (iopen(ibnd_j(jp )+di,jp ) == RCMTOPOPEN) - isOpen(5) = (iopen(ibnd_j(jpp)+di,jpp) == RCMTOPOPEN) - - if ( any(isOpen) ) then - !Keep old values b/c too close to OCB - etaks(j) = etak(ibnd_j(j)+di,j) - else - !Only smooth if all closed/null cells - etaks(j) = ( a1*etak(ibnd_j(jmm)+di,jmm) + & - a2*etak(ibnd_j(jm )+di,jm ) + & - a3*etak(ibnd_j(j )+di,j ) + & - a4*etak(ibnd_j(jp )+di,jp ) + & - a5*etak(ibnd_j(jpp)+di,jpp) )/(a1+a2+a3+a4+a5) - endif !isOpen - enddo !j loop - - !Now go back and reset values - do j=1,jsize - etak(ibnd_j(j)+di,j) = etaks(j) - enddo - - END SUBROUTINE SmoothJEta -!---------------------------------------------------------- - SUBROUTINE Calc_ftv (RM,big_vm,ierr) - USE conversion_module - USE RCM_mod_subs,ONLY : isize,jsize,kcsize,bmin,vm,rmin,pmin,& - xmin,ymin,zmin,vbnd,jwrap,radcurv,losscone - - IMPLICIT NONE - type(rcm_mhd_T), intent(in) :: RM - REAL(rprec), INTENT (IN) :: big_vm - INTEGER(iprec), INTENT (OUT) :: ierr -! -!=================================================================== -! -! calc_ftv: gets flux tube volumes, mapping parameters (r,p) -! be, sini, open/closed flag, and pressure on each 2D -! -! inputs: -! isize = dimension in latitude -! jsize = dimension in local time -! kcsize = channel dimensions (not used here) -! x0_sm,y0_sm,z0_sm = location of grid points in ionosphere in sm coordinates -! big_vm = value to set open field lines -! -! outputs: -! be = magnitude of b field in the equatorial plane in nT -! vm = flux tube volume**(-2/3) -! note: vm for open fieldlines is flagged with a -! large value (big_vm) (input) -! sini = dip angle in the ionosphere from ground -! rmin = equatorial r location of mapping in Re -! pmin = equatorial lt location of mapping in radians -! iopen = 2d array flagging open/undefined (0/1) or closed (-1) pnts -! on rcm grid -! press = pressure on field line, data from the mhd code in Pa -! den = density on field line, data from the mhd code in ple/cc -! -!=================================================================== -! -! this routine maps either to the magnetopause -! or to the conjugate hemisphere and generates -! a potential distribution on a grid in the polar cap -! it does this by tracing field lines -! using the trac tracer. -! uses gehavo for the field line tracing -! created 03/90 last mod 08/95 -! 01/19 - frt -this version gets all the values from the MHD code -! - - integer(iprec) :: i,j - REAL(rprec) :: vm_rcmmhd(isize,jsize-jwrap+1) !Holder for vm calc - - !Pull RCM-MHD variables into RCM arrays and scale/wrap - !RCM-MHD => RCM (sizes) - call EmbiggenWrap(RM%Pave,press) - call EmbiggenWrap(RM%Nave,den ) - - call EmbiggenWrap(RM%x_bmin(:,:,1)/RM%planet_radius,xmin) - call EmbiggenWrap(RM%x_bmin(:,:,2)/RM%planet_radius,ymin) - call EmbiggenWrap(RM%x_bmin(:,:,3)/RM%planet_radius,zmin) - - call EmbiggenWrap(RM%bmin/nt,bmin) - call EmbiggenWrap(RM%beta_average,beta_average) - - call EmbiggenWrap(RM%radcurv,radcurv) - call EmbiggenWrap(RM%losscone,losscone) - - call EmbiggenWrapI(RM%iopen,iopen) - call EmbiggenWrap (RM%wImag,wImag) - - ! compute vm and find boundaries - !Calculate vm on RCM/MHD-sized grid - where (RM%vol > 0.0) - vm_rcmmhd = 1.0/(RM%vol*nt)**(2.0/3.0) ! (nt/re)^0.667 - elsewhere - vm_rcmmhd = big_vm - end where - - !Convert to RCM-sized grid - call EmbiggenWrap(vm_rcmmhd,vm) - - !Make sure topology is right - where (vm<0) - iopen = RCMTOPOPEN - endwhere - - !Find boundary - vbnd(:) = 2 - do j=jwrap,jsize - do i=isize,2,-1 - if ( iopen(i,j) /= RCMTOPCLOSED ) then - vbnd(j) = i - exit - endif - enddo - enddo - - ! wrap vbnd - do j=1,jwrap-1 - vbnd(j) = vbnd(jsize-jwrap+j) - end do - - ! compute rmin,pmin - rmin = sqrt(xmin**2 + ymin**2 + zmin**2) - pmin = atan2(ymin,xmin) - - if (any(isnan(vm))) then - write(6,*) 'RCM: NaN in Calc_FTV' - write(6,*) 'Num NaNs = ', count(isnan(vm)) - ierr = -1 - return - endif - - ierr = 0 - - END SUBROUTINE Calc_ftv - -!-------------------------------------------------- -! - - SUBROUTINE MHD2eta(RM,ierr) - USE conversion_module - USE RCM_mod_subs, ONLY : ikflavc,vm,alamc,isize,jsize,kcsize,eeta - USE rcm_precision - IMPLICIT NONE - type(rcm_mhd_T), intent(inout) :: RM - integer , intent(inout) :: ierr - - real(rprec), dimension(isize,jsize) :: errD,errP - real(rprec) :: drc,dpp,prc,drc_p,dpp_p,prc_p - integer(iprec) :: i,j - - !Note: RM%errX is different size than errX for some reason - errD = 0.0 - errP = 0.0 - RM%errD = 0.0 - RM%errP = 0.0 - - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,drc,dpp,prc,drc_p,dpp_p,prc_p) - do j=1,jsize - do i=1,isize - !Get corrected density from MHD - call PartFluid(i,j,drc,dpp) - prc = press(i,j) - if ( (iopen(i,j) /= RCMTOPOPEN) .and. (drc>TINY) .and. (prc>TINY) ) then - !Good stuff, let's go - !TODO: Remove the silly redundant calculation here to get the error - !Do D,P => eta => D',P' for error - call DP2eta(drc,prc,vm(i,j),eeta_new(i,j,:),doRescaleO=.false.) - call eta2DP(eeta_new(i,j,:),vm(i,j),drc_p,dpp_p,prc_p) - !Now save error - errD(i,j) = drc_p/drc - errP(i,j) = prc_p/prc - - !Now just redo it w/ scaling (independently scale ions and electrons) - call DP2eta(drc,prc,vm(i,j),eeta_new(i,j,:),doRescaleO=.true.) - !call MaxVsKap(drc,prc,vm(i,j)) - !Not good MHD - else - eeta_new(i,j,:) = 0.0 - endif - enddo - enddo !J loop - - !Copy to MHD-RCM object for output - call Unbiggen(errD,RM%errD) - call Unbiggen(errP,RM%errP) - - ierr = 0 - END SUBROUTINE MHD2eta - -! -!=================================================================== - !Attempt to separate hot/cold components of MHD fluid - !TODO: Rewrite this messy code - SUBROUTINE PartFluid(i,j,drc,dpp) - USE conversion_module - USE RCM_mod_subs, ONLY : ikflavc,vm,alamc,isize,jsize,kcsize,eeta - - IMPLICIT NONE - integer(iprec), intent(in) :: i,j - real(rprec), intent(out) :: drc,dpp - - real(rprec) :: dmhd,dpp_rcm,drc_rcm,dtot_rcm,prc_rcm - real(rprec) :: drc1,drc2 - logical :: doM1 - - drc = 0.0 - dpp = 0.0 - !Trap for boring cases - if (iopen(i,j) == RCMTOPOPEN) then - return - endif - - !Get MHD bulk density - dmhd = den(i,j) - call eta2DP(eeta(i,j,:),vm(i,j),drc_rcm,dpp_rcm,prc_rcm) - - if (.not. use_plasmasphere) then - dpp = 0.0 - drc = dmhd !All goes to RC fluid - return - endif - - if (dmhd <= TINY) then - drc = 0.0 - dpp = dpp_rcm - return - endif - - !Get RCM info - - if (dpp_rcm <= TINY) then - drc = dmhd - dpp = 0.0 - return - endif - - !If still here either null or closed and have some work to do - !Try two ways: - !1: drc = dmhd-dpp - !2: Use RCM RC/PP ratio to split dmhd - drc1 = 0.0 - drc2 = 0.0 - - !Method 1 - if (dpp_rcm <= dmhd) then - !Subtract plasmasphere from RCM from MHD density - drc1 = dmhd-dpp_rcm - else - drc1 = min(dmhd,abs(dpp_rcm-dmhd)) - endif - if (drc1 < TINY) drc1 = 0.0 - - !Method 2 - if ( (drc_rcm > TINY) .and. (dpp_rcm > TINY) ) then - dtot_rcm = drc_rcm + dpp_rcm - drc2 = dmhd*(drc_rcm/dtot_rcm) - else - drc2 = 0.0 - endif - - !Pick which split to use - if ( (drc1 <= TINY) .and. (drc2 <= TINY) ) then - !Both methods failed, just return unsplit density - drc = dmhd - dpp = 0.0 - return - endif - - !If still here at least one good method - doM1 = .false. - - if ( (drc1 > TINY) .and. (drc2 > TINY) ) then - !Both methods successful, choose min - if (drc1 < drc2) then - doM1 = .true. - else - !Second method - doM1 = .false. - endif - else if (drc1 > TINY) then - !Only method 1 worked - doM1 = .true. - else - !Only method 2 worked - doM1 = .false. - endif - - if (doM1) then - !Method 1 - drc = drc1 - dpp = dpp_rcm - else - !Second method - drc = drc2 - dpp = dmhd*(dpp_rcm/dtot_rcm) - endif - - !write(*,*) 'M: dmhd / drc / dpp = ', doM1,1.0e-6*dmhd,1.0e-6*drc,1.0e-6*dpp - END SUBROUTINE PartFluid - - -!=================================================================== - SUBROUTINE Set_ellipse(idim,jdim,rmin,pmin,vm,big_vm,bndloc,iopen) - -! routine that fits an ellipse and resets the modeling -! boundary to be inside the ellipse -! 6/03 frt -! inputs: -! idim,jdim - size of the 2d rcm arrays (lat, long) -! xe,ye - equatorial mapping point of field line from rcm grid -! vm - computed flux tube volume ^(-2/3) set to big_vm if open -! or outside the ellipse boundary (output) -! bndloc/imin_j - boundary location (output) -! a1 - dayside end of ellipse -! a2 - nightside location of the ellipse -! b - semi minor axis (y) of ellipse - USE rice_housekeeping_module, ONLY : ellBdry - - implicit none - integer(iprec) :: idim,jdim - real(rprec) :: rmin(idim,jdim), pmin(idim,jdim) - real(rprec) :: xe(idim,jdim), ye(idim,jdim) - real(rprec) :: vm(idim,jdim) - integer(iprec) :: iopen(idim,jdim) - real(rprec) :: bndloc(jdim) - real(rprec) :: big_vm,a1,a2,a,bP,bM,x0,ell - real(rprec) :: xP,xM,yMaxP,yMaxM - integer(iprec) :: i,j,jm,jp,newi,oldi - logical :: isGood(idim,jdim) - -! x0 = (a1 + a2)/2 -! a = (a1 - a2)/2 -! -! b -! | | -! | | -! x=0) then - ell = ((xe(i,j)-x0)/a)**2+(ye(i,j)/bP)**2 - else - !Dawn - ell = ((xe(i,j)-x0)/a)**2+(ye(i,j)/bM)**2 - endif !Dusk/dawn - - !Also check longitudinal neighbors - jm = j-1 - if (jm < 1) jm = jdim - jwrap - jp = j+1 - if(jp > jdim) jp = jwrap + 1 - - isGood(i,j) = (ell<=1.0) .and. (iopen(i,jm) /= RCMTOPOPEN) .and. (iopen(i,jp) /= RCMTOPOPEN) - endif - enddo - enddo !j loop - - !Now set boundary based on isGood and number of required buffer cells - !$OMP PARALLEL DO default(shared) & - !$OMP private(i,j,newi,oldi) - do j=1,jdim - do i=idim,1,-1 - !Loop from the top and find first bad cell - if (.not. isGood(i,j)) exit - enddo !i loop - !Cell i,j is bad or got to i=1 - newi = min(i+1+NumG,idim) - !newbndloc(j) = newi - oldi = bndloc(j) - !Throttle change in bndloc to NumG if possible - if (newi > oldi+NumG) then - !Boundary is moving inwards, limit inwards motion if the cells are good - if ( all(isGood(oldi:newi,j)) ) then - !All the cells are good, so limit retreat to NumG cells - newi = min(oldi+NumG,idim) - endif - else if (newi < oldi-NumG) then - !Trying to expand by too many cells - newi = max(oldi-NumG,1) - endif - bndloc(j) = newi - enddo !j loop - - end subroutine Set_ellipse - -!------------------------------------ - !Decide on which channels are worth advancing in clawpack - SUBROUTINE SetKBounds(NkT) - USE conversion_module - USE RCM_mod_subs, ONLY : ikflavc,vm,alamc,isize,jsize,kcsize,eeta,advChannel - USE rice_housekeeping_module, ONLY : epsPk - IMPLICIT NONE - INTEGER(iprec), INTENT(INOUT) :: NkT - - integer(iprec) :: i,j,k - real(rprec) :: P,cPk,ijPk(kcsize) - real(rprec) :: LamI,LamE - real(rprec), dimension(isize,jsize,kcsize) :: PkoP - !Pk = int_1,k dP(k) = pressure contribution up to channel k - - PkoP = 0.0 - - do j=1,jsize - do i=1,isize - if (iopen(i,j) == RCMTOPOPEN) CYCLE - call eta2Pk(eeta(i,j,:),vm(i,j),ijPk) - P = sum(ijPk) - do k=1,kcsize - PkoP(i,j,k) = sum(ijPk(1:k))/P !Cumulative fraction - enddo - - enddo !i - enddo !j - - !Now have cumulative fractions, for each k see how important it is - do k=1,kcsize - !1-PkoP = contribution from channels k+1,Nk - cPk = maxval(1-PkoP(:,:,k),mask = (iopen /= RCMTOPOPEN) ) !Max importance over ij - - if (cPk 0.0)then - dens_gal = GallagherXY(xmin(i,j),ymin(i,j),InitKp)*1.0e6 - eeta(i,j,1) = dens_gal/(GetDensityFactor()*vm(i,j)**1.5) - end if - end do - end do - else - ! reset the static part of the plasmasphere sbao 07292020 - !Tweak by K: 8/7/20 - if (staticR > TINY) then - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,dens_gal,xeq,yeq,L) - do j=1,jdim - do i=imin_j(j),idim - !Use dipole for staticR density evaluation - L = 1.0/sin(colat(i,j))**2.0 - if(L <= staticR .and. vm(i,j) > 0.0)then - xeq = L*cos(aloct(i,j)) - yeq = L*sin(aloct(i,j)) - dens_gal = GallagherXY(xeq,yeq,InitKp)*1.0e6 - !dens_gal = GallagherXY(xmin(i,j),ymin(i,j),InitKp)*1.0e6 - eeta(i,j,1) = dens_gal/(GetDensityFactor()*vm(i,j)**1.5) - end if - end do - end do - end if !staticR - endif !RCMCOLDSTART - - return - - end subroutine set_plasmasphere - -!------------------------------------------ - subroutine reset_rcm_vm(idim,jdim,bndloc,big_vm,imin_j,vm,iopen) -! this routine resets imin_j, vm, and open based on a newly set bndloc - implicit none - integer(iprec), intent(in) :: idim,jdim - integer(iprec),intent(inout) :: imin_j(jdim),iopen(idim,jdim) - real(rprec), intent(inout) :: bndloc(jdim) - real(rprec), intent(in) :: big_vm - real(rprec), intent(inout) :: vm(idim,jdim) - - integer(iprec) :: i,j,iC - - imin_j = CEILING(bndloc) - - !Loop through grid and reset closed cells below boundary to NULL and poison vm in open cells - - !$OMP PARALLEL DO default(shared) & - !$OMP private(i,j,iC) - do j=1,jdim - iC = imin_j(j) - do i=1,idim - if ( (iopen(i,j) == RCMTOPCLOSED) .and. (i= 0) then !null or open - bndloc(j) = i + 1 - exit - endif - end do - end do - ! reset imin_j - imin_j = ceiling(bndloc) - - end subroutine reset_rcm_vm - -!====================================== - subroutine allocate_conversion_arrays(isz,jsz,kcsz) -! used to allocate memory for the exchange arrays -! 7/09 frt - use conversion_module - implicit none - integer(iprec),intent(in) :: isz,jsz,kcsz - integer(iprec) :: idim,jdim,kdim -! if the arrays are allocated, then return - if(allocated(x0))return - - idim = isz - jdim = jsz - kdim = kcsz - - write(*,*)' Allocating conversion arrays' - - ! 1d arrays - allocate(imin_j_old(jdim)) - allocate(bndloc_old(jdim)) - allocate(almmin(kdim)) - allocate(almmax(kdim)) - allocate(almdel(kdim)) - ! 2d arrays - allocate(x0_sm(idim,jdim)) - allocate(y0_sm(idim,jdim)) - allocate(z0_sm(idim,jdim)) - allocate(x0(idim,jdim)) - allocate(y0(idim,jdim)) - allocate(z0(idim,jdim)) - - allocate(den(idim,jdim)) - allocate(press(idim,jdim)) - allocate(deno(idim,jdim)) - allocate(presso(idim,jdim)) - allocate(to(idim,jdim)) - allocate(beta_average(idim,jdim)) - allocate(iopen(idim,jdim)) - allocate(wImag(idim,jdim)) - - ! 3d arrays - allocate(eeta_new(idim,jdim,kdim)) - - return - - end subroutine allocate_conversion_arrays - -END MODULE torcm_mod diff --git a/src/remix/mixconductance.F90 b/src/remix/mixconductance.F90 index 45d1ea1c..d26a10fb 100644 --- a/src/remix/mixconductance.F90 +++ b/src/remix/mixconductance.F90 @@ -9,22 +9,9 @@ module mixconductance use euvhelper use auroralhelper use kai2geo - use rcmdefs, ONLY : tiote_RCM implicit none -! real(rp), dimension(:,:), allocatable, private :: beta_RCM,alpha_RCM,gtype_RCM ! two-dimensional beta based on RCM fluxes. - - !Replacing some hard-coded inline values (bad) w/ module private values (slightly less bad) -! real(rp), parameter, private :: maxDrop = 20.0 !Hard-coded max potential drop [kV] -! real(rp), parameter, private :: eTINY = mixeTINY ! Floor of average energy [keV] -! real(rp), parameter, private :: Ne_floor = 0.03e6 ! minimum Ne in [/m^3] when evaluating the linearized FL relation. -! real(rp), parameter, private :: Ne_psp = 10.0e6 ! Ne threshold for the plasmasphere in [/m^3]. -! real(rp), parameter, private :: GuABNF = 1.e7 ! Gussenhoven+[1983] Auroral Boundary Number Flux in [#/cm^s/s]. -! real(rp), private :: RinMHD = 0.0 !Rin of MHD grid (0 if not running w/ MHD) -! real(rp), private :: MIXgamma -! real(rp), private :: beta_inp - contains subroutine conductance_init(conductance,Params,G) @@ -63,39 +50,6 @@ module mixconductance if (.not. allocated(conductance%deltaSigmaP)) allocate(conductance%deltaSigmaP(G%Np,G%Nt)) if (.not. allocated(conductance%deltaSigmaH)) allocate(conductance%deltaSigmaH(G%Np,G%Nt)) -! if (.not. allocated(conductance%rampFactor)) allocate(conductance%rampFactor(G%Np,G%Nt)) -! if (.not. allocated(conductance%ares)) allocate(conductance%ares(G%Np,G%Nt)) -! if (.not. allocated(conductance%deltaE)) allocate(conductance%deltaE(G%Np,G%Nt)) -! if (.not. allocated(conductance%E0)) allocate(conductance%E0(G%Np,G%Nt)) -! if (.not. allocated(conductance%phi0)) allocate(conductance%phi0(G%Np,G%Nt)) -! if (.not. allocated(conductance%engFlux)) allocate(conductance%engFlux(G%Np,G%Nt)) - -! if (.not. allocated(conductance%avgEng)) allocate(conductance%avgEng(G%Np,G%Nt)) -! if (.not. allocated(conductance%drift)) allocate(conductance%drift(G%Np,G%Nt)) -! if (.not. allocated(conductance%AuroraMask)) allocate(conductance%AuroraMask(G%Np,G%Nt)) -! if (.not. allocated(conductance%PrecipMask)) allocate(conductance%PrecipMask(G%Np,G%Nt)) - - ! these arrays are global and should not be! reallocate them -! if(allocated(beta_RCM)) deallocate(beta_RCM) -! if(allocated(alpha_RCM)) deallocate(alpha_RCM) -! if(allocated(gtype_RCM)) deallocate(gtype_RCM) - -! allocate(beta_RCM(G%Np,G%Nt)) -! allocate(alpha_RCM(G%Np,G%Nt)) -! allocate(gtype_RCM(G%Np,G%Nt)) - -! call SetMIXgamma(Params%gamma) - ! MHD inner boundary, used to calc mirror ratio. -! RinMHD = Params%RinMHD - ! Te/Tmhd -! alpha_RCM = 1.0/(tiote_RCM+1.0) - ! Loss cone rate -! beta_RCM = conductance%beta -! beta_inp = conductance%beta - ! RCM grid weight: 1. Totally on closed RCM; 0. Totally outside RCM. - ! if conductance_IM_GTYPE is not called, gtype_RCM has all zero, MHD values have a weight of 1. -! gtype_RCM = 0.0 - end subroutine conductance_init subroutine conductance_total(conductance,G,St,gcm,h) diff --git a/src/voltron/CMakeLists.txt b/src/voltron/CMakeLists.txt index f1eddd4a..8051cb4d 100644 --- a/src/voltron/CMakeLists.txt +++ b/src/voltron/CMakeLists.txt @@ -1,3 +1,3 @@ file(GLOB volt_srcs *.F90 modelInterfaces/*.F90 raijuInterfaces/*.F90) add_library(voltlib ${volt_srcs} ${VOLTIC}) -target_link_libraries(voltlib remixlib chimplib gamlib rcmlib raijulib baselib dragonkinglib) +target_link_libraries(voltlib remixlib chimplib gamlib raijulib baselib dragonkinglib) diff --git a/src/voltron/imagtubes.F90 b/src/voltron/imagtubes.F90 index 1bf92553..d55028e5 100644 --- a/src/voltron/imagtubes.F90 +++ b/src/voltron/imagtubes.F90 @@ -101,7 +101,7 @@ module imagtubes ijTube%rCurv = L/3.0 ijTube%wIMAG = 1.0 !Much imag - ijTube%TioTe0 = tiote_RCM + ijTube%TioTe0 = def_tiote end subroutine DipoleTube diff --git a/src/voltron/innermagsphere.F90 b/src/voltron/innermagsphere.F90 index 00d0b4a7..fdb509d1 100644 --- a/src/voltron/innermagsphere.F90 +++ b/src/voltron/innermagsphere.F90 @@ -6,11 +6,7 @@ module innermagsphere use ebtypes use volttypes use gamapp -! use sstimag - use sstLLimag - !use rcmimag use msphutils, only : RadIonosphere - use rcmXimag use cmiutils, only : SquishCorners implicit none diff --git a/src/voltron/modelInterfaces/rcm_mix_interface.F90 b/src/voltron/modelInterfaces/rcm_mix_interface.F90 deleted file mode 100644 index 2685a688..00000000 --- a/src/voltron/modelInterfaces/rcm_mix_interface.F90 +++ /dev/null @@ -1,424 +0,0 @@ -module rcm_mix_interface - use mixdefs - use mixgeom - use volttypes - use rcm_mhd_interfaces - use rcmdefs - - implicit none - - type(mixGrid_T), private :: rcmG, rcmG_mixstyle, rcmGS - -contains - - subroutine init_rcm_mix(rcmApp,imag2mix) - type(rcm_mhd_T),intent(in) :: rcmApp - type(imag2Mix_T), intent(inout) :: imag2mix - real(rp), dimension(:,:), allocatable :: rcmp, rcmt ! remix-style 2-D arrays to hold the RCM grid - integer :: i, j, Np, Nt - - Np = size(rcmApp%glong) - Nt = size(rcmApp%gcolat) - - !Create imag2mix object - !Note, imag2mix objects are in RCM order (gcolat,lon) - allocate(imag2mix%gcolat(Nt)) - allocate(imag2mix%glong (Np)) - allocate(imag2mix%eflux (Nt,Np)) - allocate(imag2mix%iflux (Nt,Np)) - allocate(imag2mix%eavg (Nt,Np)) - allocate(imag2mix%iavg (Nt,Np)) - allocate(imag2mix%latc (Nt,Np)) - allocate(imag2mix%lonc (Nt,Np)) - allocate(imag2mix%fac (Nt,Np)) - allocate(imag2mix%inIMag(Nt,Np)) - allocate(imag2mix%eden (Nt,Np)) - allocate(imag2mix%epre (Nt,Np)) - allocate(imag2mix%Npsp (Nt,Np)) - allocate(imag2mix%enflx (Nt,Np)) - allocate(imag2mix%inflx (Nt,Np)) - allocate(imag2mix%gtype (Nt,Np)) - imag2mix%gcolat = rcmApp%gcolat - imag2mix%glong = rcmApp%glong - imag2mix%inIMag = .false. - imag2mix%isInit = .true. - - !Now do remix mapping - if (.not.allocated(rcmp)) allocate(rcmp(Np,Nt)) - if (.not.allocated(rcmt)) allocate(rcmt(Np,Nt)) - - ! construct the 2-D grid - do j=1,Np - rcmt(j,:) = rcmApp%gcolat - enddo - - do i=1,Nt - rcmp(:,i) = rcmApp%glong - enddo - - ! call remix grid constructor - call init_grid_fromTP(rcmG,rcmt,rcmp,isSolverGrid=.false.) - call init_grid_fromTP(rcmG_mixstyle,rcmt(1:Np-1,:),rcmp(1:Np-1,:),isSolverGrid=.false.) - - end subroutine init_rcm_mix - - subroutine map_rcm_mix(voltApp,rcmPot) - type(voltApp_T), intent(in) :: voltApp - real(rp), dimension(:,:), allocatable, intent(inout) :: rcmPot - type(Map_T) :: rcmMap - - ! do mapping here since in geo the RCM grid will be moving - call mix_set_map(voltApp%remixApp%ion(NORTH)%G,rcmG,rcmMap) - call mix_map_grids(rcmMap,voltApp%remixApp%ion(NORTH)%St%Vars(:,:,POT),rcmPot) - !Convert from kV to V - rcmPot = (1.0e+3)*rcmPot - - end subroutine map_rcm_mix - - !Take fluxes from RCM and use for conductance - subroutine mapIMagToRemix(imag2mix,remixApp) - type(imag2Mix_T), intent(inout) :: imag2mix - type(mixApp_T), intent(inout) :: remixApp - type(Map_T) :: rcmMap, rcmMapS - real(rp),dimension(:,:),allocatable :: rcmGtype ! to convert integer imag2mix%gtype into real numbers for interpolation. - real(rp),dimension(:,:),allocatable :: rcmEflux_mix,rcmEavg_mix,rcmEden_mix,rcmEpre_mix,rcmEnflx_mix,rcmGtype_mix,rcmNpsp_mix - real(rp), dimension(:,:), allocatable :: efluxS, eavgS, edenS, epreS, enflxS, gtypeS, npspS ! for SH mapping. will add ifluxS and iavgS later. - integer :: SHmaptype - ! # of steps for mapping RCM SH precipitation (may make it an option in XML later): - ! 0. direct mirror mapping using NH results; - ! 1. map from irregular RCM SH to remix; - ! 2. map from irregular RCM SH to a regular equivalent then map to remix as the NH does. - SHmaptype=1 - - if ( (.not. imag2mix%isInit) .or. (.not. imag2mix%isFresh) ) return - - !Pull info and do cool stuff here - ! do mapping here since in geo the RCM grid will be moving - ! FIXME: if we do RCM in SM, though, this is not necessary (can set map in the init routine above) - - call mapIMagToRemix_gtype(imag2mix,rcmGtype) - call mix_set_map(rcmG_mixstyle,remixApp%ion(NORTH)%G,rcmMap) - associate(rcmNt=>rcmG_mixstyle%Nt,rcmNp=>rcmG_mixstyle%Np) - call mix_map_grids(rcmMap,transpose(imag2mix%eavg (:,1:rcmNp)), rcmEavg_mix ) - call mix_map_grids(rcmMap,transpose(imag2mix%enflx(:,1:rcmNp)), rcmEnflx_mix) - call mix_map_grids(rcmMap,transpose(imag2mix%eflux(:,1:rcmNp)), rcmEflux_mix) - call mix_map_grids(rcmMap,transpose(imag2mix%eden (:,1:rcmNp)), rcmEden_mix ) - call mix_map_grids(rcmMap,transpose(imag2mix%epre (:,1:rcmNp)), rcmEpre_mix ) - call mix_map_grids(rcmMap,transpose(imag2mix%npsp (:,1:rcmNp)), rcmNpsp_mix ) - call mix_map_grids(rcmMap,transpose(rcmGtype (:,1:rcmNp)), rcmGtype_mix) - end associate - - remixApp%ion(NORTH)%St%Vars(:,:,IM_EAVG ) = rcmEavg_mix*1e-3 ! [eV -> keV] - remixApp%ion(NORTH)%St%Vars(:,:,IM_ENFLX) = rcmEnflx_mix ! [#/cm^2/s] - remixApp%ion(NORTH)%St%Vars(:,:,IM_EFLUX) = rcmEflux_mix ! [ergs/cm^2/s] - remixApp%ion(NORTH)%St%Vars(:,:,IM_GTYPE) = rcmGtype_mix ! normalize since gtype is from 0 to 2. - remixApp%ion(NORTH)%St%Vars(:,:,IM_EDEN ) = rcmEden_mix ! [#/m^3] - remixApp%ion(NORTH)%St%Vars(:,:,IM_EPRE ) = rcmEpre_mix ! [Pa] - remixApp%ion(NORTH)%St%Vars(:,:,IM_NPSP ) = rcmNpsp_mix ! [#/m^3] - - ! Southern Hemisphere Mapping - if(SHmaptype==1) then - call mapIMagSToRemix(imag2mix,remixApp,rcmGtype,efluxS,eavgS,gtypeS,edenS,epreS,enflxS,npspS) - rcmEavg_mix = transpose(eavgS) - rcmEnflx_mix = transpose(enflxS) - rcmEflux_mix = transpose(efluxS) - rcmGtype_mix = transpose(gtypeS) - rcmEden_mix = transpose(edenS) - rcmEpre_mix = transpose(epreS) - rcmNpsp_mix = transpose(npspS) - elseif(SHmaptype==2) then - call mapIMagSToIMag(imag2mix,efluxS,eavgS) ! need updates to deal with inIMagActive and inIMagBuffer. But SHmaptype=2 is never used. - call mix_set_map(rcmGS,remixApp%ion(NORTH)%G,rcmMapS) - associate(rcmNt=>rcmGS%Nt,rcmNp=>rcmGS%Np) - call mix_map_grids(rcmMapS,transpose(efluxS(:,1:rcmNp-1)),rcmEflux_mix) - call mix_map_grids(rcmMapS,transpose(eavgS(:,1:rcmNp-1)), rcmEavg_mix) - end associate - endif - - associate(Nt=>remixApp%ion(SOUTH)%G%Nt,Np=>remixApp%ion(SOUTH)%G%Np) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_EAVG ) = rcmEavg_mix (Np:1:-1,:)*1e-3 ! [eV -> keV] - remixApp%ion(SOUTH)%St%Vars(:,:,IM_ENFLX) = rcmEnflx_mix(Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_EFLUX) = rcmEflux_mix(Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_GTYPE) = rcmGtype_mix(Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_EDEN ) = rcmEden_mix (Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_EPRE ) = rcmEpre_mix (Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_NPSP ) = rcmNpsp_mix (Np:1:-1,:) - end associate - -! For proton precipitation (all zero for now) - rcmEflux_mix=0.0 - rcmEavg_mix=0.0 - associate(rcmNt=>rcmG_mixstyle%Nt,rcmNp=>rcmG_mixstyle%Np) - call mix_map_grids(rcmMap,transpose(imag2mix%iflux(:,1:rcmNp)),rcmEflux_mix) - call mix_map_grids(rcmMap,transpose(imag2mix%iavg (:,1:rcmNp)),rcmEavg_mix ) - call mix_map_grids(rcmMap,transpose(imag2mix%inflx(:,1:rcmNp)),rcmEnflx_mix) - end associate - remixApp%ion(NORTH)%St%Vars(:,:,IM_IAVG ) = rcmEavg_mix*1e-3 ! [eV -> keV] - remixApp%ion(NORTH)%St%Vars(:,:,IM_IFLUX) = rcmEflux_mix - remixApp%ion(NORTH)%St%Vars(:,:,IM_INFLX) = rcmEnflx_mix - associate(Nt=>remixApp%ion(SOUTH)%G%Nt,Np=>remixApp%ion(SOUTH)%G%Np) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_IAVG ) = rcmEavg_mix (Np:1:-1,:)*1e-3 ! [eV -> keV] - remixApp%ion(SOUTH)%St%Vars(:,:,IM_IFLUX) = rcmEflux_mix(Np:1:-1,:) - remixApp%ion(SOUTH)%St%Vars(:,:,IM_INFLX) = rcmEnflx_mix(Np:1:-1,:) - end associate - - !Set toggle and ignore it until isFresh toggled back - imag2mix%isFresh = .false. - end subroutine mapIMagToRemix - - subroutine mapIMagToRemix_gtype(imag2mix,rcmGtype) - ! Convert imag2mix%gtype integer numbers to real numbers for interpolation. - ! Allow more enumerators of gtype in the future. - type(imag2Mix_T), intent(in) :: imag2mix - real(rp),dimension(:,:), allocatable, intent(inout) :: rcmGtype - - if (.not.allocated(rcmGtype)) then - associate(Nt=>size(imag2mix%gtype,1),Np=>size(imag2mix%gtype,2)) - allocate(rcmGtype(Nt,Np)) - end associate - endif - rcmGtype = 0.0D0 - - where(imag2mix%gtype == IMactive) - rcmGtype = 1.0D0 - elsewhere(imag2mix%gtype == IMbuffer) - rcmGtype = 0.5D0 - elsewhere(imag2mix%gtype == IMoutside) - rcmGtype = 0.0D0 - endwhere - - end subroutine mapIMagToRemix_gtype - - subroutine mapIMagSToRemix(imag2mix,remixApp,rcmGtype,efluxS,eavgS,gtypeS,edenS,epreS,enflxS,npspS) - ! Directly map from irregular RCM SH grid to ReMIX. - type(imag2Mix_T), intent(in) :: imag2mix - type(mixApp_T), intent(in) :: remixApp - real(rp), intent(in) :: rcmGtype(size(imag2mix%gtype,1),size(imag2mix%gtype,2)) - real(rp), dimension(:,:), allocatable, intent(inout) :: efluxS, eavgS, gtypeS, edenS, epreS, enflxS, npspS - real(rp), dimension(:,:), allocatable :: colatc, glongc, mixt, mixp, Ainvdwgt2 - real(rp) :: dlat, delt, delp, invdwgt - integer :: Np_rcm, Nt_rcm, Np_mix, Nt_mix, i, j, i0, j0, jl, ju, il, iu, jp, dj - - Nt_rcm = size(imag2mix%latc,1) - Np_rcm = size(imag2mix%latc,2) ! imag2mix%latc (Nt_rcm,Np_rcm) - - if (.not.allocated(colatc)) allocate(colatc(Nt_rcm,Np_rcm)) - if (.not.allocated(glongc)) allocate(glongc(Nt_rcm,Np_rcm)) - ! Source grid: latc is negative. colatc is positive from ~15 to 75 deg. Note latc=0 for open field lines. - colatc = PI/2 + imag2mix%latc - glongc = imag2mix%lonc - - ! Destination grid: remix Grid. - mixt = remixApp%ion(NORTH)%G%t - mixp = remixApp%ion(NORTH)%G%p - Np_mix = size(mixt,1) - Nt_mix = size(mixt,2) - dlat = mixt(1,2)-mixt(1,1) - dj = nint(dble(Np_mix)/dble(Np_rcm)) ! ratio of rcm dlon to remix dlon. - - ! Mapping: remix dlat is ~10x of rcm, dlon is ~1/3.6 of rcm. Remix lat is from 0-45 deg. RCM is from 15-75 deg. - ! For each rcm SH point, find the nearest remix lat. If it's not too far away (within dlat) then - ! find the nearest remix lon. Assign rcm contribution to the nearest lat shell within 2 rcm dlon. - ! The difference is due to remix dlat is larger while dlon is smaller. Need to make sure all remix grids have some contribution from rcm. - ! Lastly, normalize the contribution by total IDW. - if (.not.allocated(efluxS)) allocate(efluxS(Nt_mix,Np_mix)) - if (.not.allocated(eavgS)) allocate(eavgS (Nt_mix,Np_mix)) - if (.not.allocated(gtypeS)) allocate(gtypeS(Nt_mix,Np_mix)) - if (.not.allocated(edenS)) allocate(edenS (Nt_mix,Np_mix)) - if (.not.allocated(epreS)) allocate(epreS (Nt_mix,Np_mix)) - if (.not.allocated(enflxS)) allocate(enflxS(Nt_mix,Np_mix)) - if (.not.allocated(npspS)) allocate(npspS (Nt_mix,Np_mix)) - if (.not.allocated(Ainvdwgt2)) allocate(Ainvdwgt2(Nt_mix,Np_mix)) - efluxS = 0.0 - eavgS = 0.0 - gtypeS = 0.0 - edenS = 0.0 - epreS = 0.0 - enflxS = 0.0 - npspS = 0.0 - Ainvdwgt2 = 0.0 - !$OMP PARALLEL DO default(shared) collapse(2) & - !$OMP private(i,j,i0,il,iu,j0,jl,ju,jp,delt,delp,invdwgt) & - !$OMP reduction(+:efluxS,eavgS,Ainvdwgt2,gtypeS,edenS,epreS,enflxS,npspS) - do j=1,Np_rcm - do i=1,Nt_rcm -! if(imag2mix%eflux(i,j)>0.0) then - i0 = minloc(abs(mixt(1,:)-colatc(i,j)),1) ! Find the nearest remix colat index for rcm colatc(i,j) - if(mixt(1,i0)<=colatc(i,j)) then ! If the nearest remix colat is < rcm colatc, only collect rcm to this colat and its next grid. - il=i0 - iu=min(i0+1,Nt_mix) - else ! Otherwise, collect from this point and its neighbor lat. - il=max(i0-1,1) - iu=i0 - endif - do i0=il,iu - ! For any remix grid, interpolate if rcm lat is within dlat away - if(abs(mixt(1,i0)-colatc(i,j))Np_mix-dj) then - do j0=1,dj-(Np_mix-jp) - delt = abs(mixt(j0,i0)-colatc(i,j)) - delp = abs((mixp(j0,i0)-glongc(i,j)))*sin(mixt(j0,i0)) - invdwgt = 1./sqrt(delt**2+delp**2) - efluxS(i0,j0) = efluxS(i0,j0) + imag2mix%eflux(i,j)*invdwgt - eavgS(i0,j0) = eavgS(i0,j0) + imag2mix%eavg(i,j) *invdwgt - gtypeS(i0,j0) = gtypeS(i0,j0) + rcmGtype(i,j)*invdwgt - edenS(i0,j0) = edenS(i0,j0) + imag2mix%eden(i,j) *invdwgt - epreS(i0,j0) = epreS(i0,j0) + imag2mix%epre(i,j) *invdwgt - npspS(i0,j0) = npspS(i0,j0) + imag2mix%npsp(i,j) *invdwgt - enflxS(i0,j0) = enflxS(i0,j0) + imag2mix%enflx(i,j)*invdwgt - Ainvdwgt2(i0,j0) = Ainvdwgt2(i0,j0) + invdwgt - enddo - endif - do j0=jl,ju - delt = abs(mixt(j0,i0)-colatc(i,j)) - delp = abs((mixp(j0,i0)-glongc(i,j)))*sin(mixt(j0,i0)) - invdwgt = 1./sqrt(delt**2+delp**2) - efluxS(i0,j0) = efluxS(i0,j0) + imag2mix%eflux(i,j)*invdwgt - eavgS(i0,j0) = eavgS(i0,j0) + imag2mix%eavg(i,j) *invdwgt - gtypeS(i0,j0) = gtypeS(i0,j0) + rcmGtype(i,j)*invdwgt - edenS(i0,j0) = edenS(i0,j0) + imag2mix%eden(i,j) *invdwgt - epreS(i0,j0) = epreS(i0,j0) + imag2mix%epre(i,j) *invdwgt - npspS(i0,j0) = npspS(i0,j0) + imag2mix%npsp(i,j) *invdwgt - enflxS(i0,j0) = enflxS(i0,j0) + imag2mix%enflx(i,j)*invdwgt - Ainvdwgt2(i0,j0) = Ainvdwgt2(i0,j0) + invdwgt - enddo - endif - enddo -! endif - enddo - enddo - !$OMP PARALLEL DO default(shared) collapse(2) & - !$OMP private(i0,j0) - do j0=1,Np_mix - do i0=1,Nt_mix - if(Ainvdwgt2(i0,j0)>0.0) then - efluxS(i0,j0) = efluxS(i0,j0)/Ainvdwgt2(i0,j0) - eavgS(i0,j0) = eavgS(i0,j0) /Ainvdwgt2(i0,j0) - gtypeS(i0,j0) = gtypeS(i0,j0)/Ainvdwgt2(i0,j0) - edenS(i0,j0) = edenS(i0,j0) /Ainvdwgt2(i0,j0) - epreS(i0,j0) = epreS(i0,j0) /Ainvdwgt2(i0,j0) - enflxS(i0,j0) = enflxS(i0,j0)/Ainvdwgt2(i0,j0) - npspS(i0,j0) = npspS(i0,j0) /Ainvdwgt2(i0,j0) - endif - enddo - enddo - end subroutine mapIMagSToRemix - - subroutine mapIMagSToIMag(imag2mix,efluxS,eavgS) - type(imag2Mix_T), intent(in) :: imag2mix - real(rp), dimension(:,:), allocatable, intent(inout) :: efluxS, eavgS - real(rp), dimension(:,:), allocatable :: colatc, glongc, rcmt, rcmp, Ainvdwgt2 - real(rp) :: colatmin, dlat, dlon, delt, delp, invdwgt, Ainvdwgt - integer :: i, j, Np, Nt, i0, j0, NpS, NtS, il, iu, jl, ju - -! RCM NH grid is regular but not uniform. The lat spacing increases toward low latitude (high colat) -! from 0.015 deg to 0.6 deg, on average (75-15)/200 = 0.3 deg. The lon spacing is uniform, 360/100 = 3.6 deg. -! When constructing a regular grid for SH, may keep the highest lat resolution in the high lat end. The low -! lat end would be no different. - - Nt = size(imag2mix%latc,1) - Np = size(imag2mix%latc,2) ! imag2mix%latc (Nt,Np) - if (.not.allocated(colatc)) allocate(colatc(Nt,Np)) - if (.not.allocated(glongc)) allocate(glongc(Nt,Np)) - ! latc is negative. colatc is positive from ~15 to 75 deg. Note latc=0 for open field lines. - colatc = PI/2 + imag2mix%latc - glongc = imag2mix%lonc - - ! Step 1. Determine the highest lat/lowest colat in SH conjugate grid. - colatmin = PI/2 - do j=1,Np - do i=1,Nt - if(colatc(i,j)0.0) then - i0 = minloc(abs(rcmt(1,:)-colatc(i,j)),1) - il = max(i0-2,1) - iu = min(i0+2,NtS) - j0 = minloc(abs(rcmp(:,1)-glongc(i,j)),1) - jl = max(j0-2,1) - ju = min(j0+2,NpS) - do i0=il,iu ! Warning: this range in lat is too broad and would result in latitudinal expansion. - do j0=jl,ju - delt = abs(rcmt(j0,i0)-colatc(i,j)) - delp = abs((rcmp(j0,i0)-glongc(i,j)))*sin(rcmt(j0,i0)) - invdwgt = 1./sqrt(delt**2+delp**2) - efluxS(i0,j0) = efluxS(i0,j0) + imag2mix%eflux(i,j)*invdwgt - eavgS(i0,j0) = eavgS(i0,j0) + imag2mix%eavg(i,j)*invdwgt - Ainvdwgt2(i0,j0) = Ainvdwgt2(i0,j0) + invdwgt - enddo - end do - endif - end do - end do - !$OMP PARALLEL DO default(shared) collapse(2) & - !$OMP private(i0,j0) - do j0=1,NpS - do i0=1,NtS - if(Ainvdwgt2(i0,j0)>0.0) then - efluxS(i0,j0) = efluxS(i0,j0)/Ainvdwgt2(i0,j0) - eavgS(i0,j0) = eavgS(i0,j0)/Ainvdwgt2(i0,j0) - endif - end do - end do - end subroutine mapIMagSToIMag - -end module rcm_mix_interface diff --git a/src/voltron/mpi/CMakeLists.txt b/src/voltron/mpi/CMakeLists.txt index 83d74f10..51d8def1 100644 --- a/src/voltron/mpi/CMakeLists.txt +++ b/src/voltron/mpi/CMakeLists.txt @@ -1,3 +1,3 @@ file(GLOB volt_mpi_srcs *.F90 modelInterfaces/*.F90) add_library(voltmpilib ${volt_mpi_srcs}) -target_link_libraries(voltmpilib voltlib rcmlib remixlib chimplib gammpilib gamlib basempilib baselib) +target_link_libraries(voltmpilib voltlib remixlib chimplib gammpilib gamlib basempilib baselib) diff --git a/src/voltron/rcmXimag.F90 b/src/voltron/rcmXimag.F90 deleted file mode 100644 index 67f5b83f..00000000 --- a/src/voltron/rcmXimag.F90 +++ /dev/null @@ -1,251 +0,0 @@ -! A version of rcmimag which also calls sstimagLL and replaces RCM pressures with SST. -! Eventually, we want to merge the two pressures in some assimilative way. -! X stands for eXtended. -module rcmXimag - use rcmimag - use sstLLimag - use mixdefs - use mixgeom - USE Rcm_mod_subs, ONLY : isize, jsize - use rcmdefs, only : RCMTOPOPEN,RCMTOPCLOSED - - implicit none - - type, extends(innerMagBase_T) :: rcmXIMAG_T - - class(rcmIMAG_T), allocatable :: rcmApp - class(empData_T), allocatable :: empApp - type(mixGrid_T) :: rcmG - type(Map_T) :: rcmMap - - contains - - ! over-ride the base functions with RCM versions - ! procedure :: doInit => initRCMX - ! procedure :: doAdvance => advanceRCMX - ! procedure :: doEval => evalRCMX - ! procedure :: doIO => doRCMXIO - ! procedure :: doRestart => doRCMXRestart - - end type - -! contains - -! subroutine initRCMX(imag,iXML,isRestart,vApp) -! class(rcmXIMAG_T), intent(inout) :: imag -! type(XML_Input_T), intent(in) :: iXML -! logical, intent(in) :: isRestart -! type(voltApp_T), intent(inout) :: vApp - -! allocate(rcmIMAG_T :: imag%rcmApp) -! allocate(empData_T :: imag%empApp) - -! call imag%rcmApp%doInit(iXML,isRestart,vApp) -! call imag%empApp%doInit(iXML,isRestart,vApp) - -! ! define rcm grid, store inside the rcmXIMAG class -! call rcmGrid(imag) -! ! set map (note, sstG is defined in empApp%doInit) -! call mix_set_map(imag%empApp%sstG,imag%rcmG,imag%rcmMap) - -! contains - -! ! note this is ugly, as it simply reuses the code from rcm_mix_interface -! ! FIXME: consider defining RCM mix-style grid in, e.g., initRCM and reusing here and in rcm_mix_interface -! subroutine rcmGrid(imagX) -! class(rcmXIMAG_T), intent(inout) :: imagX -! integer :: i, j, Np, Nt -! real(rp), dimension(:,:), allocatable :: rcmp, rcmt ! remix-style 2-D arrays to hold the RCM grid - -! Np = size(imagX%rcmApp%rcmCpl%glong) -! Nt = size(imagX%rcmApp%rcmCpl%gcolat) - -! !Now do remix mapping -! if (.not.allocated(rcmp)) allocate(rcmp(Np,Nt)) -! if (.not.allocated(rcmt)) allocate(rcmt(Np,Nt)) - -! ! construct the 2-D grid -! do j=1,Np -! rcmt(j,:) = imagX%rcmApp%rcmCpl%gcolat -! enddo - -! do i=1,Nt -! rcmp(:,i) = imagX%rcmApp%rcmCpl%glong -! enddo - -! ! call remix grid constructor -! call init_grid_fromTP(imagX%rcmG,rcmt,rcmp,isSolverGrid=.false.) - -! end subroutine rcmGrid - -! end subroutine initRCMX - -! subroutine advanceRCMX(imag,vApp,tAdv) -! class(rcmXIMAG_T), intent(inout) :: imag -! type(voltApp_T), intent(inout) :: vApp -! real(rp), intent(in) :: tAdv -! real(rp), dimension(:,:), allocatable :: empPressureOnRCMGrid -! real(rp), dimension(:,:), allocatable :: empBvolOnRCMGrid - -! call imag%rcmApp%doAdvance(vApp,tAdv) -! call imag%empApp%doAdvance(vApp,tAdv) - -! ! interpolate from emp to rcm here -! !call mix_map_grids(imag%rcmMap,imag%empApp%sstP,empPressureOnRCMGrid) -! !call mix_map_grids(imag%rcmMap,imag%empApp%sstBvol,empBvolOnRCMGrid) - - -! ! replace RCM pressure for now but think about merging like this later -! !rcmX%Pressure = w1(x,y)*rcm%Pressure + w2(x,y)*sst%Pressure - -! ! note, converting sst pressure (nPa) to rcm (Pa) -! ! doEval below converts back to nPa -! !imag%rcmApp%rcmCpl%Prcm = 1.0e-9*transpose(empPressureOnRCMGrid) - -! ! Set RCM pressure via rcm(pV^gamma)=sst(pV^gamma) - -! call setPressViaEntropy(imag) - - -! ! Manipulate "RCM's" density to be some combination of Nmhd and Npsph -! call setRCMXDensity(imag%rcmApp%rcmCpl, 2) - - -! end subroutine advanceRCMX - -! subroutine evalRCMX(imag,x1,x2,t,imW,isEdible) -! class(rcmXIMAG_T), intent(inout) :: imag -! real(rp), intent(in) :: x1,x2,t -! real(rp), intent(out) :: imW(NVARIMAG) -! logical, intent(out) :: isEdible - -! call imag%rcmApp%doEval(x1,x2,t,imW,isEdible) - -! end subroutine evalRCMX - -! !IO wrappers -- just do RCM things -! subroutine doRCMXIO(imag,nOut,MJD,time) -! class(rcmXIMAG_T), intent(inout) :: imag -! integer, intent(in) :: nOut -! real(rp), intent(in) :: MJD,time - -! call imag%rcmApp%doIO(nOut,MJD,time) -! !Hijack mhdrcm file and include SST information -! !call doSSTIO(imag,nOut) -! end subroutine doRCMXIO - -! subroutine doRCMXRestart(imag,nRes,MJD,time) -! class(rcmXIMAG_T), intent(inout) :: imag -! integer, intent(in) :: nRes -! real(rp), intent(in) :: MJD, time - -! call imag%rcmApp%doRestart(nRes,MJD,time) -! end subroutine doRCMXRestart - - - -! subroutine setRCMXDensity(rcmCpl,option) -! class(rcm_mhd_T), intent(inout) :: rcmCpl -! integer, intent(in) :: option - -! integer :: i,j - -! select case (option) -! case(1) -! ! Use only whatever's in MHD -! rcmCpl%Nrcm = rcmCpl%Nave -! case(2) -! ! Wherever Npsph>Nave, use Npsph -! ! Else, use Nave - -! !$OMP PARALLEL DO default(shared) collapse(2) & -! !$OMP schedule(dynamic) & -! !$OMP private(i,j) -! do j=1,rcmCpl%nLon_ion -! do i=1,rcmCpl%nLat_ion - -! if (rcmCpl%Npsph(i,j) > rcmCpl%Nave(i,j)) then -! rcmCpl%Nrcm(i,j) = rcmCpl%Npsph(i,j) -! else -! rcmCpl%Nrcm(i,j) = rcmCpl%Nave(i,j) -! endif -! enddo -! enddo -! case DEFAULT -! !Don't do anything, will use RCM's density -! end select - -! end subroutine setRCMXDensity - -! subroutine setPressViaEntropy(imag) -! class(rcmXIMAG_T), intent(inout) :: imag - -! real(rp), dimension(:,:), allocatable :: empIOpenOnRCMGrid, empTpIo -! real(rp), dimension(:,:), allocatable :: empPressureOnRCMGrid, empTpP -! real(rp), dimension(:,:), allocatable :: empBvolOnRCMGrid, empTpBvol -! real(rp) :: gamma = 5./3. -! integer :: i,j - -! call mix_map_grids(imag%rcmMap,imag%empApp%Iopen,empIOpenOnRCMGrid) -! call mix_map_grids(imag%rcmMap,imag%empApp%sstP,empPressureOnRCMGrid) -! call mix_map_grids(imag%rcmMap,imag%empApp%sstBvol,empBvolOnRCMGrid) -! empTpIo = transpose(empIOpenOnRCMGrid) -! empTpP = transpose(empPressureOnRCMGrid) -! empTpBvol = transpose(empBvolOnRCMGrid) - -! DO i = 1,isize -! DO j = 1,jsize - - -! if (empTpIo(i,j) > (-0.5) .or. empTpBvol(i,j) < 0) then ! If interpolated point is fairly influenced by an open line, kill it -! ! Make sure mhd won't ingest this point -! ! Probably only need to set one of these but idk where we are in RCMEval pipeline so set both to be safe -! imag%rcmApp%rcmCpl%iopen(i,j) = 1 -! imag%rcmApp%rcmCpl%toMHD(i,j) = .false. -! else ! Only other option here is that its a closed line (-1) according to SST -! !if (imag%rcmApp%rcmCpl%iopen(i,j) /= RCMTOPOPEN) then ! Only overwrite closed and buffer region -! if (imag%rcmApp%rcmCpl%Vol(i,j) > 0) then -! imag%rcmApp%rcmCpl%Prcm(i,j) = 1.0e-9*empTpP(i,j) & -! *(empTpBvol(i,j)*1.0e9)**gamma & -! *imag%rcmApp%rcmCpl%Vol(i,j)**(-gamma) -! else -! imag%rcmApp%rcmCpl%Prcm(i,j) = 0 -! end if -! end if -! END DO -! END DO - -! end subroutine setPressViaEntropy - -! subroutine doSSTIO(imag,nOut) -! class(rcmXIMAG_T), intent(in) :: imag -! integer, intent(in) :: nOut -! type(IOVAR_T), dimension(4) :: IOVars -! character(len=strLen) :: h5File -! character(len=strLen) :: gStr -! real(rp), dimension(:,:), allocatable :: empIOpenOnRCMGrid, empTpIo -! real(rp), dimension(:,:), allocatable :: empPressureOnRCMGrid, empTpP -! real(rp), dimension(:,:), allocatable :: empBvolOnRCMGrid, empTpBvol - -! call mix_map_grids(imag%rcmMap,imag%empApp%Iopen,empIOpenOnRCMGrid) -! call mix_map_grids(imag%rcmMap,imag%empApp%sstP,empPressureOnRCMGrid) -! call mix_map_grids(imag%rcmMap,imag%empApp%sstBvol,empBvolOnRCMGrid) -! empTpIo = transpose(empIOpenOnRCMGrid) -! empTpP = transpose(empPressureOnRCMGrid) -! empTpBvol = transpose(empBvolOnRCMGrid) - - -! h5File = trim(imag%rcmApp%rcmCpl%rcm_runid) // ".mhdrcm.h5" !MHD-RCM coupling data - -! call ClearIO(IOVars) - -! call AddOutVar(IOVars,"SSTP",empTpP,uStr="nPa") -! call AddOutVar(IOVars,"SSTBvol",empTpBvol,uStr="Re/nT") -! call AddOutVar(IOVars,"SSTIopen",empTpIo) - -! write(gStr,'(A,I0)') "Step#", nOut -! call WriteVars(IOVars,.true.,h5File,gStr,"SST") - -! end subroutine doSSTIO - -end module rcmXimag diff --git a/src/voltron/rcmeval.F90 b/src/voltron/rcmeval.F90 deleted file mode 100644 index 476cf1d0..00000000 --- a/src/voltron/rcmeval.F90 +++ /dev/null @@ -1,360 +0,0 @@ -!Routines for interpolating (TSC) on RCM grid -module rcmeval - use volttypes - use rcm_mhd_interfaces - use rcmdefs, only : DenPP0 - use planethelper - use gdefs, only : dFloor,pFloor - - implicit none - logical :: doWolfLim = .true. !Whether to do wolf-limiting - logical :: doWolfNLim = .false. !If wolf-limiting whether to do wolf-limiting on density as well - real(rp) :: nBounce = 1.0 !Scaling factor for Alfven transit - real(rp) :: maxBetaLim = 6.0/5.0 !Largest beta to use in weighting formula - logical :: doBounceDT = .true. !Whether to use Alfven bounce in dt-ingest - - !Points for interpolation - integer, parameter, private :: Np = 9 - - contains - - !Enforce Wolf-limiting on an MHD/RCM thermodynamic state - !Density [#/cc], pressure [nPa] - subroutine WolfLimit(nrc,prc,npsph,nmhd,pmhd,beta,nlim,plim) - real(rp), intent(in) :: nrc,prc,npsph,nmhd,pmhd,beta - real(rp), intent(out) :: nlim,plim - - real(rp) :: nrcm,prcm,ppsph,psphKev - real(rp) :: alpha,blim,dVoV,wRCM,wMHD - logical :: doRC,doPP - - nlim = 0.0 - plim = 0.0 - nrcm = 0.0 - prcm = 0.0 - - !Get a low but non-zero pressure for plasmasphere - !Use Genestreti+ 2016 linear fit - !T [eV] = B* n^A, n [#/cc], A = -0.15, B = 1.4 - psphKev = ColdTempKev(npsph) - ppsph = DkT2P(npsph,psphKev) - - !Incorporate RC/PP contributions - !Test RC/PP contribution - doRC = (prc >= TINY ) - doPP = (npsph >= DenPP0) - - if (doRC) then - !Incorporate RC contribution - nrcm = nrcm + nrc - prcm = prcm + prc - endif - if (doPP) then - !Incorporate plasmasphere contribution - nrcm = nrcm + npsph - prcm = prcm + ppsph - endif - !Now have total density/pressure contributions from RC+PP - !Think about bailing - !Return raw values if not limiting, and don't limit if there's no RC - if ( (.not. doWolfLim) .or. (.not. doRC) ) then - nlim = nrcm - plim = prcm - return - endif - - !If still here we've gotta wolf limit - !Experiment w/ limiting max value of beta allowed - blim = min(beta,maxBetaLim) - !Get scaling term - alpha = 1.0 + blim*5.0/6.0 - - wRCM = 1.0/alpha - wMHD = (alpha-1.0)/alpha ! = 1 - wRCM - plim = wRCM*prcm + wMHD*pmhd - - !Check whether to limit density - if (doWolfNLim .and. (nrcm>TINY)) then - !n_R V = (n_M + dn)(V + dV) - !nlim = n_M + dn, Drop dn*dV => - dVoV = 0.5*(blim/alpha)*(prcm-pmhd)/pmhd - nlim = nrcm - nmhd*dVoV - if (nlim <= dFloor) then - !Something went bad, nuke everything - nlim = 0.0 - plim = 0.0 - endif !nlim - else - nlim = nrcm !Raw density - endif !doWolfNLim - - end subroutine WolfLimit - - !Plasmasphere temperature, use Genestreti+ 2016 linear fit - !Density [#/cc] => Temperature [keV] - function ColdTempKeV(npsph) result(Tkev) - real(rp), intent(in) :: npsph - real(rp) :: Tkev - - real(rp), parameter :: A = -0.15,B=1.4 - !T [eV] = B* n^A, n [#/cc], A = -0.15, B = 1.4 - !Floor at 0.01/cc - Tkev = (1.0e-3)*B*(max(npsph,0.01)**A) - - end function ColdTempKev - - !Interpolate state at lat/lon - subroutine InterpRCM(RCMApp,lat,lon,t,imW,isEdible) - type(rcm_mhd_T), intent(in) :: RCMApp - real(rp) , intent(in) :: lat,lon,t - real(rp) , intent(out) :: imW(NVARIMAG0) - logical , intent(out) :: isEdible - - integer :: n,Ni,Nj,ip,jp - integer, dimension(2) :: ij0 - integer , dimension(Np,2) :: IJs - real(rp), dimension(Np) :: Ws,nLims,pLims,Tbs - logical , dimension(Np) :: isGs - real(rp) :: colat,npp,nrcm,nmhd,prcm,pmhd,beta - - imW = 0.0 - isEdible = .false. - - !Nuke all of this b/c it shouldn't get called - -! Ni = RCMApp%nLat_ion -! Nj = RCMApp%nLon_ion - -! !Set defaults -! imW(:) = 0.0 -! imW(IMDEN ) = 0.0 -! imW(IMPR ) = 0.0 -! imW(IMTSCL) = 0.0 -! isEdible = .false. - -! colat = PI/2 - lat - -! !Do 1st short cut tests -! isEdible = (colat >= RCMApp%gcolat(1)) .and. (colat <= RCMApp%gcolat(RCMApp%nLat_ion)) & -! .and. (lat > TINY) - -! if (.not. isEdible) return - -! !If still here, find mapping (i,j) on RCM grid of point -! call GetRCMLoc(lat,lon,ij0) - -! !Do second short cut tests -! isEdible = RCMApp%toMHD(ij0(1),ij0(2)) -! if (.not. isEdible) return - -! call GetInterpTSC(lat,lon,ij0,IJs,Ws,isGs) -! isEdible = all(isGs) !Require all points in stencil are edible - -! !Do last short cut -! if (.not. isEdible) return - -! !Get limited N/P at each stencil point -! nLims = 0.0 -! pLims = 0.0 - -! do n=1,Np -! ip = IJs(n,1) -! jp = IJs(n,2) -! !Densities [#/cc] -! npp = rcmNScl*RCMApp%Npsph(ip,jp) -! nrcm = rcmNScl*RCMApp%Nrcm (ip,jp) -! nmhd = rcmNScl*RCMApp%Nave (ip,jp) -! !Pressure [nPa] -! prcm = rcmPScl*RCMApp%Prcm (ip,jp) -! pmhd = rcmPScl*RCMApp%Pave (ip,jp) - -! beta = RCMApp%beta_average(ip,jp) - -! !Have input quantities, calculate local wolf-limited values -! if (doWolfLim) then -! call WolfLimit(nrcm,prcm,npp,nmhd,pmhd,beta,nLims(n),pLims(n)) -! else -! !Just lazyily use same function w/ beta=0 -! call WolfLimit(nrcm,prcm,npp,nmhd,pmhd,0.0_rp,nLims(n),pLims(n)) -! endif - -! Tbs(n) = RcMApp%Tb(ip,jp) -! enddo -! !Get final ingestion values -! imW(IMDEN) = dot_product(nLims,Ws) -! imW(IMPR ) = dot_product(pLims,Ws) - -! !Coordinates -! imW(IMX1) = rad2deg*lat -! imW(IMX2) = rad2deg*lon - -! if (doBounceDT) then -! !Use Alfven bounce timescale -! imW(IMTSCL) = nBounce*dot_product(Tbs,Ws) -! endif - -! !-------- -! !Internal routines -! contains - -! !Get ij's of stencil points and weights -! subroutine GetInterpTSC(lat,lon,ij0,IJs,Ws,isGs) -! real(rp), intent(in) :: lat,lon -! integer , intent(in) :: ij0(2) -! integer , intent(out) :: IJs(Np,2) -! real(rp), intent(out) :: Ws(Np) -! logical , intent(out) :: isGs(Np) - -! integer :: i0,j0,n,di,dj,ip,jp -! real(rp) :: colat,dcolat,dlon,eta,zeta -! real(rp), dimension(-1:+1) :: wE,wZ - -! !Single point -! isGs = .true. -! IJs(:,:) = 1 -! Ws = 0.0 -! IJs(1,:) = [ij0] -! Ws (1 ) = 1.0 -! associate(gcolat=>RCMApp%gcolat,glong=>RCMApp%glong, & -! nLat=>RCMApp%nLat_ion,nLon=>RCMApp%nLon_ion, & -! toMHD=>RCMApp%toMHD) - -! i0 = ij0(1) -! j0 = ij0(2) - -! if ( (i0==1) .or. (i0==nLat) ) return !Don't bother if you're next to lat boundary - -! !Get index space mapping: eta,zeta in [-0.5,0.5] -! colat = PI/2 - lat -! dcolat = ( gcolat(i0+1)-gcolat(i0-1) )/2 -! dlon = glong(2)-glong(1) !Assuming constant spacing - -! eta = ( colat - gcolat(i0) )/ dcolat -! zeta = ( lon - glong(j0) )/dlon - -! !Clamp mappings -! call ClampMap(eta) -! call ClampMap(zeta) -! !Calculate weights -! call weight1D(eta ,wE) -! call weight1D(zeta,wZ) - -! n = 1 -! do dj=-1,+1 -! do di=-1,+1 -! ip = i0+di -! jp = j0+dj -! !Wrap around boundary, repeated point at 1/isize -! if (jp<1) jp = nLon-1 -! if (jp>nLon) jp = 2 -! IJs(n,:) = [ip,jp] -! Ws(n) = wE(di)*wZ(dj) -! isGs(n) = toMHD(ip,jp) -! if (.not. isGs(n)) Ws(n) = 0.0 - -! n = n + 1 -! enddo -! enddo !dj - -! !Renormalize -! Ws = Ws/sum(Ws) - -! end associate -! end subroutine GetInterpTSC - -! !1D triangular shaped cloud weights -! !1D weights for triangular shaped cloud interpolation -! !Assuming on -1,1 reference element, dx=1 -! !Check for degenerate cases ( |eta| > 0.5 ) -! subroutine weight1D(eta,wE) -! real(rp), intent(in) :: eta -! real(rp), intent(out) :: wE(-1:1) - -! wE(-1) = 0.5*(0.5-eta)**2.0 -! wE( 1) = 0.5*(0.5+eta)**2.0 -! wE( 0) = 0.75 - eta**2.0 - -! end subroutine weight1D - -! !Clamps mapping in [-0.5,0.5] -! subroutine ClampMap(ez) -! REAL(rprec), intent(inout) :: ez -! if (ez<-0.5) ez = -0.5 -! if (ez>+0.5) ez = +0.5 -! end subroutine ClampMap - -! function AvgQ(Q,IJs,Ws,Ni,Nj) -! integer , intent(in) :: Ni,Nj -! integer , intent(in) :: IJs(Np,2) -! real(rp), intent(in) :: Ws(Np) -! real(rp), intent(in) :: Q(Ni,Nj) - -! real(rp) :: AvgQ -! integer :: n,i0,j0 -! real(rp) :: Qs(Np) -! AvgQ = 0.0 - -! do n=1,Np -! i0 = IJs(n,1) -! j0 = IJs(n,2) -! Qs(n) = Q(i0,j0) -! enddo -! AvgQ = dot_product(Qs,Ws) - -! end function AvgQ - -! subroutine GetRCMLoc(lat,lon,ij0) -! real(rp), intent(in) :: lat,lon -! integer, intent(out) :: ij0(2) - -! integer :: iX,jX,iC,n -! real(rp) :: colat,dp,dcol,dI,dJ - -! associate(gcolat=>RCMApp%gcolat,glong=>RCMApp%glong, & -! nLat=>RCMApp%nLat_ion,nLon=>RCMApp%nLon_ion) - -! !Assuming constant lon spacing -! dp = glong(2) - glong(1) - -! !Get colat point -! colat = PI/2 - lat -! !Use findloc w/ intel for speed -! #if defined __INTEL_COMPILER && __INTEL_COMPILER >= 1800 -! iC = findloc(gcolat >= colat,.true.,dim=1) - 1 -! #else -! !Bypass as findloc does not work for gfortran<9 -! !Work-around code -! do n=1,nLat -! if (gcolat(n) >= colat) exit -! enddo -! iC = n-1 -! #endif -! dcol = gcolat(iC+1)-gcolat(iC) -! dI = (colat-gcolat(iC))/dcol -! if (dI <= 0.5) then -! iX = iC -! else -! iX = iC+1 -! endif - -! !Get lon point -! dJ = lon/dp -! if ( (dJ-floor(dJ)) <= 0.5 ) then -! jX = floor(dJ)+1 -! else -! jX = floor(dJ)+2 -! endif - -! !Impose bounds just in case -! iX = max(iX,1) -! iX = min(iX,nLat) -! jX = max(jX,1) -! jX = min(jX,nLon) - -! ij0 = [iX,jX] - -! end associate -! end subroutine GetRCMLoc - - end subroutine InterpRCM -end module rcmeval \ No newline at end of file diff --git a/src/voltron/rcmimag.F90 b/src/voltron/rcmimag.F90 deleted file mode 100644 index 89cf8170..00000000 --- a/src/voltron/rcmimag.F90 +++ /dev/null @@ -1,596 +0,0 @@ -!Routines to handle RCM inner magnetosphere model -!NOTES: -!-Figure out flux-tube volume units -!-Work on upating legacy Fortran -!-Work on OMP bindings -!-Streamline console noise - -module rcmimag - use volttypes - use files - use earthhelper - use imaghelper - use planethelper - use rcm_mhd_interfaces - use rcm_mix_interface - use rcmtubes - use clocks - use kronos - use rcm_mhd_mod, ONLY : rcm_mhd - use rcm_mhd_io - use gdefs, only : dFloor,pFloor - use rcmdefs, only : DenPP0 - use rcmeval - - implicit none - - integer, parameter, private :: MHDPad = 0 !Number of padding cells between RCM domain and MHD ingestion - logical , private :: doTrickyTubes = .true. !Whether to poison bad flux tubes - real(rp), private :: imagScl = 1.5 !Safety factor for RCM=>ebsquish - - !Whether to call smooth tubes routine at all, see imagtubes for specific options - logical , private :: doSmoothTubes = .false. - - !Whether to send MHD buffer information to remix - logical , private :: doBigIMag2Ion = .false. - - !Whether to use MHD Alfven bounce or RCM hot population bounce - logical, private :: doHotBounce = .true. - real(rp), dimension(:,:), allocatable, private :: mixPot - - type, extends(innerMagBase_T) :: rcmIMAG_T - - ! rcm coupling variable - type(rcm_mhd_T) :: rcmCpl - - ! Holder for field line data - type(magLine_T), dimension(:,:), allocatable :: rcmFLs - - logical :: doFakeTube=.false. !Only for testing - - contains - - ! over-ride the base functions with RCM versions - procedure :: doInit => initRCM - procedure :: doAdvance => advanceRCM - procedure :: doEval => EvalRCM - procedure :: doIO => doRCMIO - procedure :: doConIO => doRCMConIO - procedure :: doRestart => doRCMRestart - - end type - - contains - - !Initialize RCM inner magnetosphere model - subroutine initRCM(imag,iXML,isRestart,vApp) - class(rcmIMAG_T), intent(inout) :: imag - type(XML_Input_T), intent(in) :: iXML - logical, intent(in) :: isRestart - type(voltApp_T), intent(inout) :: vApp - - character(len=strLen) :: RunID - real(rp) :: t0 - - associate(RCMApp => imag%rcmCpl, & !type rcm_mhd_T - imag2mix => vApp%imag2mix, & - t0 => vApp%time, & - dtCpl => vApp%DeepDT) - - !Set radii in RCMApp - RCMApp%planet_radius = vApp%planet%rp_m - RCMApp%iono_radius = vApp%planet%ri_m - Rp_m = vApp%planet%rp_m ! For local use - RIonRCM = vApp%planet%ri_m/vApp%planet%rp_m - - planetM0g = vApp%planet%magMoment - - if (vApp%isLoud) then - write(*,*) '---------------' - write(*,*) 'RCM planet params' - write(*,*) 'Rp [m] = ', Rp_m - write(*,*) 'RIon [Rp] = ', RIonRCM - write(*,*) 'RIon [m] = ', RIonRCM*Rp_m - write(*,*) 'MagMoment [G] = ', planetM0g - write(*,*) '---------------' - endif - - call iXML%Set_Val(RunID,"/Kaiju/gamera/sim/runid","sim") - RCMApp%rcm_runid = trim(RunID) - - call iXML%Set_Val(doWolfLim ,"/Kaiju/gamera/source/doWolfLim" ,doWolfLim ) - if (doWolfLim) then - call iXML%Set_Val(doWolfNLim ,"/Kaiju/gamera/source/doWolfNLim" ,doWolfNLim ) - else - doWolfNLim = .false. - endif - - call iXML%Set_Val(doBounceDT,"/Kaiju/gamera/source/doBounceDT",doBounceDT) - call iXML%Set_Val(doHotBounce,"/Kaiju/gamera/source/doHotBounce",doHotBounce) - call iXML%Set_Val(nBounce ,"/Kaiju/gamera/source/nBounce" ,nBounce ) - call iXML%Set_Val(maxBetaLim,"/Kaiju/gamera/source/betamax" ,maxBetaLim) - call iXML%Set_Val(doBigIMag2Ion ,"imag2ion/doBigIMag2Ion",doBigIMag2Ion) - - call iXML%Set_Val(imagScl ,"imag/safeScl",imagScl) - call iXML%Set_Val(bMin_C ,"imag/bMin_C" ,bMin_C ) - call iXML%Set_Val(wImag_C ,"imag/wImag_C",wImag_C) - - call iXML%Set_Val(imag%doFakeTube, "imag/doFakeTube",.false.) - - if (isRestart) then - - !Get t0 and nRes necessary for RCM restart - call RCMRestartInfo(RCMApp,iXML,t0) - - write(*,*) 'Restarting RCM @ t = ', t0 - vApp%time = t0 !Set vApp's time to correct value from restart - call rcm_mhd(t0,dtCpl,RCMApp,RCMRESTART,iXML=iXML) - !Check if we need to do coldstart, assuming coldstart happens at T=0 - if (t0 <= 0) then - !Still haven't got to T=0 even w/ restart so still need to cold start - doColdStart = .true. - call InitRCMICs(imag,vApp,iXML) - else - doColdstart = .false. ! set to false if it is a restart - endif - call ReadMHD2IMagRestart(imag%rcmCpl,imag%rcmCpl%rcm_nRes-1) !Subtract 1 for the one to read - else - t0 = vApp%time - write(*,*) 'Initializing RCM ...' - call InitRCMICs(imag,vApp,iXML) - call rcm_mhd(t0,dtCpl,RCMApp,RCMINIT,iXML=iXML) - doColdStart = .true. - endif - - call init_rcm_mix(RCMApp,imag2mix) - - !Allocate any memory needed - allocate(imag%rcmFLs(RCMApp%nLat_ion,RCMApp%nLon_ion)) - - !Start up IO - if(vApp%writeFiles) call initRCMIO(RCMApp,isRestart) - - end associate - - end subroutine initRCM - - !Setup ICs to pass to RCM if asked to - subroutine InitRCMICs(imag,vApp,iXML) - class(rcmIMAG_T), intent(inout) :: imag - type(XML_Input_T), intent(in) :: iXML - type(voltApp_T), intent(in) :: vApp - - real(rp) :: t0 - - call iXML%Set_Val(RCMICs%doIC,"imag/doInit",.false.) - t0 = TINY - if (RCMICs%doIC) then - !Want initial dst0 - RCMICs%dst0 = GetSWVal("symh",vApp%tilt%wID,t0) - RCMICs%vSW = abs(GetSWVal("Vx",vApp%tilt%wID,t0)) - RCMICs%dSW = GetSWVal("D",vApp%tilt%wID,t0) - - !Set PS values (see Borovsky paper) - RCMICs%dPS = 0.292*(RCMICs%dSW**0.49) - RCMICs%kTPS = -3.65 + 0.0190*RCMICs%vSW*1.0e-3 !m/s=>km/s - RCMICs%kTPS = max(RCMICs%kTPS,TINY) - - !Tune RC pressure profile, using just dst(T=0) (will try to do better later) - call SetQTRC(RCMICs%dst0) - else - !Zero out any additional ring current - call SetQTRC(0.0_rp) - endif - - !Also initialize TM03 - call InitTM03(vApp%tilt%wID,t0) - - contains - - function GetSWVal(vID,fID,t0) result(qSW) - character(len=*), intent(in) :: vID,fID - real(rp), intent(in) :: t0 - real(rp) :: qSW - - type(TimeSeries_T) :: tsQ - tsQ%wID = trim(fID) - call tsQ%initTS(trim(vID),doLoudO=.false.) - qSW = tsQ%evalAt(t0) - end function GetSWVal - - end subroutine InitRCMICs - - !Advance RCM from Voltron data - subroutine AdvanceRCM(imag,vApp,tAdv) - class(rcmIMAG_T), intent(inout) :: imag - type(voltApp_T), intent(inout) :: vApp - real(rp), intent(in) :: tAdv - - integer :: i,j,n,nStp,maxNum - real(rp) :: colat,lat,lon - real(rp) :: dtAdv - type(RCMTube_T) :: ijTube - - real(rp) :: maxRad - logical :: isLL,doHackIC - - if (vApp%isEarth) then - call UpdateTM03(vApp%time) !Update plasma sheet model for MP finding and such - call MJDRecalc(vApp%MJD) - else - write(*,*) "You need to do something about RCM for not Earth!" - stop - endif - - associate(RCMApp => imag%rcmCpl) - - RCMApp%llBC = vApp%mhd2chmp%lowlatBC - RCMApp%dtCpl = vApp%DeepDT - RCMApp%pFloor = pFloor - - call Tic("MAP_RCMMIX") - !Get potential from mix - call map_rcm_mix(vApp,mixPot) - call Toc("MAP_RCMMIX") - - call Tic("RCM_TUBES") - if (imag%doFakeTube) write(*,*) "Using fake flux tubes for testing!" - - !Load RCM tubes - !$OMP PARALLEL DO default(shared) collapse(2) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,colat,lat,lon,isLL,ijTube) - do j=1,RCMApp%nLon_ion - do i=1,RCMApp%nLat_ion - call CleanLine(imag%rcmFLs(i,j)) !Wipe old field line info - - colat = RCMApp%gcolat(i) - lat = PI/2 - colat - lon = RCMApp%glong(j) - - !Decide if we're below low-lat BC or not - isLL = (lat <= RCMApp%llBC) - if (isLL) then - !Use mocked up values - call DipoleTube(vApp,lat,lon,ijTube,imag%rcmFLs(i,j)) - else - if (imag%doFakeTube) then - call FakeTube (vApp,lat,lon,ijTube,imag%rcmFLs(i,j)) - else - !Trace through MHD - call MHDTube (vApp,lat,lon,ijTube,imag%rcmFLs(i,j),vApp%nTrc) - endif - endif - - !Stuff data into RCM - RCMApp%Vol(i,j) = ijTube%Vol - RCMApp%bmin(i,j) = ijTube%bmin - RCMApp%iopen(i,j) = ijTube%iopen - RCMApp%beta_average(i,j) = ijTube%beta_average - RCMApp%Pave(i,j) = ijTube%Pave - RCMApp%Nave(i,j) = ijTube%Nave - RCMApp%X_bmin(i,j,:) = ijTube%X_bmin - - RCMApp%latc(i,j) = ijTube%latc - RCMApp%lonc(i,j) = ijTube%lonc - RCMApp%losscone(i,j) = ijTube%losscone - RCMApp%Lb(i,j) = ijTube%Lb - RCMApp%radcurv(i,j) = ijTube%rCurv - RCMApp%Tb(i,j) = ijTube%Tb - RCMApp%wIMAG(i,j) = ijTube%wIMAG - RCMApp%nTrc(i,j) = imag%rcmFLs(i,j)%Nm+imag%rcmFLs(i,j)%Np - !mix variables are stored in this order (longitude,colatitude), hence the index flip - RCMApp%pot(i,j) = mixPot(j,i) - - !Set composition - RCMApp%oxyfrac(i,j) = 0.0 - - enddo - enddo - - doHackIC = (vApp%time <= vApp%DeepDT) .and. RCMICs%doIC !Whether to hack MHD/RCM coupling for ICs - - call Toc("RCM_TUBES") - !Do any tube hacking needed before sending tubes to RCM - if (doHackIC) then - !Tune values to send to RCM for its cold start - !Setup quiet time ring current to hit target using both current BSDst and target dst - !Replacing first RC estimate w/ Dst at end of blow-in period - call SetQTRC(RCMICs%dst0-vApp%BSDst) - call HackTubes(RCMApp,vApp) - endif - - if (doTrickyTubes) then - !Coverup some bad tubes - call TrickyTubes(RCMApp) - endif - - if (doSmoothTubes) then - !Smooth out FTV/potential on tubes b/c RCM will take gradient - call SmoothTubes(RCMApp,vApp) - - endif - - !Advance from vApp%time to tAdv - call Tic("AdvRCM") - dtAdv = tAdv-vApp%time !RCM-DT - if (doColdstart) then - write(*,*) 'Cold-starting RCM @ t = ', vApp%time - call rcm_mhd(vApp%time,dtAdv,RCMApp,RCMCOLDSTART) - doColdstart = .false. - else - call rcm_mhd(vApp%time,dtAdv,RCMApp,RCMADVANCE) - end if - - call Toc("AdvRCM") - - !Set ingestion region - if (doHackIC) then - !For ICs ingest from entire closed field region just this once - RCMApp%toMHD = .not. (RCMApp%iopen == RCMTOPOPEN) - else - call SetIngestion(RCMApp) - !Try to tailor region to do projections over - ! !Find maximum extent of RCM domain (RCMTOPCLOSED but not RCMTOPNULL) - !maxRad = maxval(norm2(RCMApp%X_bmin,dim=3),mask=(RCMApp%iopen == RCMTOPCLOSED)) - maxRad = maxval(norm2(RCMApp%X_bmin,dim=3),mask=.not. (RCMApp%iopen == RCMTOPOPEN)) - maxNum = maxval( RCMApp%nTrc ,mask=.not. (RCMApp%iopen == RCMTOPOPEN)) - maxRad = maxRad/Rp_m - vApp%rTrc = imagScl*maxRad - vApp%nTrc = min( nint(imagScl*maxNum),MaxFL ) - endif - - !Pull data from RCM state for conductance calculations - !NOTE: this is not the closed field region, this is actually the RCM domain - !How much RCM info to use - if (doBigIMag2Ion) then - !Pass buffer region to remix - vApp%imag2mix%inIMag = .not. (RCMApp%iopen == RCMTOPOPEN) - else - vApp%imag2mix%inIMag = (RCMApp%iopen == RCMTOPCLOSED) - endif - - ! Pass RCM grid type info for remix conductance merge. - ! Gtype is integer and will be converted to numbers for interpolation in rcm_mix_interface. - where(RCMApp%iopen == RCMTOPCLOSED) - vApp%imag2mix%gtype = IMactive - elsewhere((.not. RCMApp%iopen == RCMTOPCLOSED) .and. (.not. RCMApp%iopen == RCMTOPOPEN)) - vApp%imag2mix%gtype = IMbuffer - elsewhere - vApp%imag2mix%gtype = IMoutside - endwhere - - vApp%imag2mix%latc = RCMApp%latc - vApp%imag2mix%lonc = RCMApp%lonc - - ! electrons precipitation - vApp%imag2mix%enflx = RCMApp%nflx (:,:,RCMELECTRON) - vApp%imag2mix%eflux = RCMApp%flux (:,:,RCMELECTRON) - vApp%imag2mix%eavg = RCMApp%eng_avg(:,:,RCMELECTRON) - ! ion precipitation - vApp%imag2mix%inflx = RCMApp%nflx (:,:,RCMPROTON) - vApp%imag2mix%iflux = RCMApp%flux (:,:,RCMPROTON) - vApp%imag2mix%iavg = RCMApp%eng_avg(:,:,RCMPROTON) - - ! Pass RCM hot electron density and pressure to REMIX. - vApp%imag2mix%eden = RCMApp%Nrcm - vApp%imag2mix%epre = RCMApp%Percm - vApp%imag2mix%npsp = RCMApp%Npsph - - vApp%imag2mix%isFresh = .true. - - end associate - - end subroutine AdvanceRCM - - !Set region of RCM grid that's "good" for MHD ingestion - subroutine SetIngestion(RCMApp) - type(rcm_mhd_T), intent(inout) :: RCMApp - - integer , dimension(:), allocatable :: jBnd - integer :: i,j - logical :: inMHD,isClosed - real(rp) :: Drc,bEq,Lb,Prc - - RCMApp%toMHD(:,:) = .false. - !Testing lazy quick boundary - allocate(jBnd ( RCMApp%nLon_ion )) - !Now find nominal current boundary - jBnd(:) = RCMApp%nLat_ion-1 - - !$OMP PARALLEL DO default(shared) & - !$OMP private(i,j,inMHD,isClosed,Drc,bEq,Lb,Prc) - do j=1,RCMApp%nLon_ion - do i = RCMApp%nLat_ion,1,-1 - inMHD = RCMApp%toMHD(i,j) - isClosed = (RCMApp%iopen(i,j) == RCMTOPCLOSED) - if ( .not. isClosed ) then - jBnd(j) = min(i+1+MHDPad,RCMApp%nLat_ion) - exit - endif - - enddo !i loop - RCMApp%toMHD(:,j) = .false. - RCMApp%toMHD(jBnd(j):,j) = .true. - - !Replace bounce timescale w/ one using RCM hot population and equatorial B - if (doHotBounce) then - !Calculate ingestion timescale in this longitude - do i = jBnd(j),RCMApp%nLat_ion - Drc = rcmNScl*RCMApp%Nrcm (i,j) !#/cc - Prc = rcmPScl*RCMApp%Prcm (i,j) !nPa - Drc = max(Drc,TINY) - bEq = rcmBScl*RCMApp%Bmin (i,j) !Mag field [nT] - Lb = (RCMApp%planet_radius)*(1.0e-3)*RCMApp%Lb(i,j) !Lengthscale [km] - !RCMApp%Tb(i,j) = AlfBounce(Drc,bEq,Lb) - RCMApp%Tb(i,j) = FastBounce(Drc,Prc,bEq,Lb) - enddo - endif - - enddo - - contains - !Calculate Alfven bounce timescale - !D = #/cc, B = nT, L = km - function AlfBounce(Dcc,BnT,Lkm) result(dTb) - real(rp), intent(in) :: Dcc,BnT,Lkm - real(rp) :: dTb - - real(rp) :: Va - if ( (Dcc imag%rcmCpl) - !Start by getting some data - !Pressure peak info - maxIJ = maxloc(RCMApp%Prcm,mask=RCMApp%toMHD) - i0 = maxIJ(1); j0 = maxIJ(2) - - maxPRCM = RCMApp%Prcm (i0,j0)*rcmPScl - maxPMHD = RCMApp%Pave (i0,j0)*rcmPScl - maxBeta = RCMApp%beta_average(i0,j0) - maxD = RCMApp%Nrcm (i0,j0)*rcmNScl - maxDMHD = RCMApp%Nave (i0,j0)*rcmNScl - maxDP = RCMApp%Npsph(i0,j0)*rcmNScl - - maxL = norm2(RCMApp%X_bmin(i0,j0,XDIR:YDIR))/Rp_m - maxMLT = atan2(RCMApp%X_bmin(i0,j0,YDIR),RCMApp%X_bmin(i0,j0,XDIR))*180.0/PI - if (maxMLT<0) maxMLT = maxMLT+360.0 - maxWT = 100*RCMApp%wImag(i0,j0) - - maxLam = (1.0e-3)*RCMApp%MaxAlam/( (RCMApp%vol(i0,j0)*1.0e-9)**(2.0/3.0) ) !Max RCM energy channel [keV] - - !Get pressure weighted confidence - wTrust = sum(RCMApp%Prcm*RCMApp%wIMAG,mask=RCMApp%toMHD)/sum(RCMApp%Prcm,mask=RCMApp%toMHD) - wTrust = 100.0*wTrust - !Get min confidence in MHD domain - wTMin = 100.0*minval(RCMApp%wIMAG,mask=RCMApp%toMHD) - !Get some info about size of closed field domain - maxNum = maxval(RCMApp%nTrc,mask=.not. (RCMApp%iopen == RCMTOPOPEN)) - maxLen = maxval(RCMApp%Lb ,mask=.not. (RCMApp%iopen == RCMTOPOPEN)) - - !Do some output - if ((maxPRCMRCM routines - !Fake flux-tube to mock up MHD side of coupling - subroutine FakeTube(vApp,lat,lon,ijTube,bTrc) - type(voltApp_T), intent(in) :: vApp - real(rp), intent(in) :: lat,lon - type(RCMTube_T), intent(out) :: ijTube - type(magLine_T), intent(inout) :: bTrc - - real(rp), dimension(NDIM) :: xyzIon,x0,xyzEq - real(rp) :: bIon,L,N0_ps,P0_ps,TiEV,CsMKS,VaMKS - logical :: isInTM03 - - !Need equatorial xyz - !Assume lat/lon @ Earth, dipole push to first cell + epsilon - xyzIon(XDIR) = RIonRCM*cos(lat)*cos(lon) - xyzIon(YDIR) = RIonRCM*cos(lat)*sin(lon) - xyzIon(ZDIR) = RIonRCM*sin(lat) - x0 = DipoleShift(xyzIon,vApp%mhd2chmp%Rin+TINY) - bIon = norm2(DipoleB0(xyzIon))*oBScl*1.0e-9 !EB=>T, ionospheric field strength - - L = DipoleL(xyzIon) - xyzEq = DipoleShift(xyzIon,L) - - !Start by filling dipole values - call DipoleTube(vApp,lat,lon,ijTube,bTrc) - !Get TM03 values - call EvalTM03_SM(xyzEq,N0_ps,P0_ps,isInTM03) - if (.not. isInTM03) return !Nothing else to do - - !Need to set beta,N,p - ijTube%Nave = N0_ps*1.0e+6 !#/cc => #/m3 - ijTube%Pave = P0_ps*1.0e-9 !nPa=>Pa - - TiEV = (1.0e+3)*DP2kT(N0_ps,P0_ps) !Temp in eV - CsMKS = 9.79*sqrt((5.0/3)*TiEV) !km/s - VaMKS = 22.0*(ijTube%bmin*1.0e+9)/sqrt(N0_ps) !km/s - ijTube%beta_average = 2.0*(CsMKS/VaMKS)**2.0 - ijTube%TioTe0 = tiote_RCM - end subroutine FakeTube - - !MHD flux-tube - subroutine MHDTube(vApp,lat,lon,ijTube,bTrc,nTrcO) - type(voltApp_T), intent(in) :: vApp - real(rp), intent(in) :: lat,lon - type(RCMTube_T), intent(out) :: ijTube - type(magLine_T), intent(inout) :: bTrc - integer, intent(in), optional :: nTrcO - - real(rp) :: t, bMin,bIon - real(rp), dimension(NDIM) :: x0, bEq, xyzIon - real(rp), dimension(NDIM) :: xyzC,xyzIonC - integer :: OCb - real(rp) :: bD,bP,dvB,bBeta,rCurv - real(rp) :: bD0,bP0,kT0 - - real(rp) :: VaMKS,CsMKS,VebMKS !Speeds in km/s - real(rp) :: TiEV !Temperature in ev - !First get seed for trace - !Assume lat/lon @ Earth, dipole push to first cell + epsilon - xyzIon(XDIR) = RIonRCM*cos(lat)*cos(lon) - xyzIon(YDIR) = RIonRCM*cos(lat)*sin(lon) - xyzIon(ZDIR) = RIonRCM*sin(lat) - - associate(ebModel=>vApp%ebTrcApp%ebModel,ebGr=>vApp%ebTrcApp%ebState%ebGr,ebState=>vApp%ebTrcApp%ebState) - if (ebModel%isMAGE .and. inDomain(xyzIon,ebModel,ebState%ebGr)) then - x0 = DipoleShift(xyzIon,norm2(xyzIon)+TINY) - else - x0 = DipoleShift(xyzIon,vApp%mhd2chmp%Rin+TINY) - endif - bIon = norm2(DipoleB0(xyzIon))*oBScl*1.0e-9 !EB=>T, ionospheric field strength - - !Now do field line trace - - - t = ebState%eb1%time !Time in CHIMP units - - if (present(nTrcO)) then - call genLine(ebModel,ebState,x0,t,bTrc,nTrcO,doShueO=.true.,doNHO=.true.) - else - call genLine(ebModel,ebState,x0,t,bTrc, doShueO=.true.,doNHO=.true.) - endif - - !Topology - !OCB = 0 (solar wind), 1 (half-closed), 2 (both ends closed) - OCb = FLTop(ebModel,ebGr,bTrc) - - if ((OCb /= 2) .or. (.not. bTrc%isGood)) then - !Not closed line, set some values and get out - ijTube%X_bmin = 0.0 - ijTube%bmin = 0.0 - ijTube%iopen = RCMTOPOPEN - ijTube%Vol = 0.0 - ijTube%Pave = 0.0 - ijTube%Nave = 0.0 - ijTube%beta_average = 0.0 - ijTube%latc = 0.0 - ijTube%lonc = 0.0 - ijTube%Lb = 0.0 - ijTube%Tb = 0.0 - ijTube%losscone = 0.0 - ijTube%rCurv = 0.0 - ijTube%wIMAG = 0.0 - ijTube%TioTe0 = tiote_RCM - return - endif - - !Get diagnostics from closed field line - !Minimal surface (bEq in Rp, bMin in EB) - call FLEq(ebModel,bTrc,bEq,bMin) - bMin = bMin*oBScl*1.0e-9 !EB=>Tesla - bEq = bEq*Rp_m !Re=>meters - - !Plasma quantities - !dvB = Flux-tube volume (Re/EB) - if (ebModel%nSpc > 0) then - !Get from both COLD/RC - call FLThermo(ebModel,ebGr,bTrc,bD0,bP0,dvB,bBeta,COLDFLUID) - call FLThermo(ebModel,ebGr,bTrc,bD ,bP ,dvB,bBeta,RCFLUID) - - !Only get thermodynamics from non-plasmasphere fluid - !RCFLUID goes to xAve - !COLD can be either N0,Nave, or neither. eg if plasmasphere got hot - if (bP0 > pFloor) then - kT0 = DP2kT(bD0,bP0) !Temp in keV - - if (kT0 > kTCutH) then - !This is actually hot, add it to RC seed - bD = bD + bD0 - bP = bP + bP0 - bD0 = 0.0 - else if (kT0 > kTCutC) then - !Not cold - bD0 = 0.0 - endif - else - bD0 = 0.0 - endif - else - !Use standard bulk - call FLThermo(ebModel,ebGr,bTrc,bD,bP,dvB,bBeta) - bD0 = 0.0 - endif - !Use empirical tiote or not - - !ijTube%TioTe0 = TioTe_Empirical(bEq/Rp_m) !Rescaling to Re - ijTube%TioTe0 = tiote_RCM - - !Converts Re/EB => Re/T - dvB = dvB/(oBScl*1.0e-9) - bP = bP *1.0e-9 !nPa=>Pa - bD = bD *1.0e+6 !#/cc => #/m3 - bD0 = bD0*1.0e+6 !#/cc => #/m3 - - ijTube%X_bmin = bEq - ijTube%bmin = bMin - ijTube%iopen = RCMTOPCLOSED - ijTube%Vol = dvB - ijTube%Pave = bP - ijTube%Nave = bD - ijTube%N0 = bD0 - ijTube%beta_average = bBeta - - !Find conjugate lat/lon @ RIonRCM - call FLConj(ebModel,ebGr,bTrc,xyzC) - xyzIonC = DipoleShift(xyzC,RIonRCM) - ijTube%latc = asin(xyzIonC(ZDIR)/norm2(xyzIonC)) - ijTube%lonc = modulo( atan2(xyzIonC(YDIR),xyzIonC(XDIR)),2*PI ) - ijTube%Lb = FLArc(ebModel,ebGr,bTrc) - !NOTE: Bounce timescale may be altered to use RCM hot density - ijTube%Tb = FLAlfvenX(ebModel,ebGr,bTrc) - - ijTube%losscone = asin(sqrt(bMin/bIon)) - - !Get curvature radius and ExB velocity [km/s] - call FLCurvRadius(ebModel,ebGr,ebState,bTrc,rCurv,VebMKS) - ijTube%rCurv = rCurv - - !Get confidence interval - !VaMKS = flux tube arc length [km] / Alfven crossing time [s] - VaMKS = (ijTube%Lb*Rp_m*1.0e-3)/max(ijTube%Tb,TINY) - !CsMKS = 9.79 x sqrt(5/3 * Ti) km/s, Ti eV - TiEV = (1.0e+3)*DP2kT(bD*1.0e-6,bP*1.0e+9) !Temp in eV - CsMKS = 9.79*sqrt((5.0/3)*TiEV) - - ijTube%wIMAG = VaMKS/( sqrt(VaMKS**2.0 + CsMKS**2.0) + VebMKS) - - end associate - - end subroutine MHDTube - - !Dipole flux tube info - subroutine DipoleTube(vApp,lat,lon,ijTube,bTrc) - type(voltApp_T), intent(in) :: vApp - real(rp), intent(in) :: lat,lon - type(RCMTube_T), intent(out) :: ijTube - type(magLine_T), intent(inout) :: bTrc - - real(rp) :: L,colat - real(rp) :: mdipole - - mdipole = ABS(planetM0g)*G2T ! dipole moment in T - colat = PI/2 - lat - L = 1.0/(sin(colat)**2.0) - !ijTube%Vol = 32./35.*L**4.0/mdipole - !Use full dipole FTV formula, convert Rx/nT => Rx/T - ijTube%Vol = DipFTV_L(L,planetM0g)*1.0e+9 - - ijTube%X_bmin(XDIR) = L*cos(lon)*Rp_m !Rp=>meters - ijTube%X_bmin(YDIR) = L*sin(lon)*Rp_m !Rp=>meters - ijTube%X_bmin(ZDIR) = 0.0 - ijTube%bmin = mdipole/L**3.0 - - ijTube%iopen = RCMTOPCLOSED - - ijTube%pot = 0.0 - - ijTube%beta_average = 0.0 - ijTube%Pave = 0.0 - ijTube%Nave = 0.0 - - ijTube%latc = -lat - ijTube%lonc = lon - ijTube%Lb = L !Just lazily using L shell - ijTube%Tb = 0.0 - ijTube%losscone = 0.0 - ijTube%rCurv = L/3.0 - - ijTube%wIMAG = 1.0 !Much imag - ijTube%TioTe0 = tiote_RCM - end subroutine DipoleTube - - !Do some trickkery on the tubes if they seem too weird for RCM - subroutine TrickyTubes(RCMApp) - type(rcm_mhd_T), intent(inout) :: RCMApp - - integer :: Ni,Nj,i,j - logical :: isBadTube - - Ni = RCMApp%nLat_ion - Nj = RCMApp%nLon_ion - - !Loop over grid and poison cells we wouldn't trust RCM with - do j=1,Nj - do i=1,Ni - if (RCMApp%iopen(i,j) /= RCMTOPOPEN) then - !Check this cell - isBadTube = (RCMApp%wImag(i,j)<=wImag_C) .or. (RCMApp%Bmin(i,j)*1.0e+9 <= bMin_C) - - if (isBadTube) then - !Poison this cell - RCMApp%iopen(i,j) = RCMTOPOPEN - RCMApp%Vol(i,j) = 0.0 - endif - endif - enddo !i loop - enddo !j loop - - end subroutine TrickyTubes - - !Smooth RCM tube data as needed - subroutine SmoothTubes(RCMApp,vApp) - type(rcm_mhd_T), intent(inout) :: RCMApp - type(voltApp_T), intent(in) :: vApp - - integer :: n,Ni,Nj,Ns - logical, dimension(:,:), allocatable :: isG - real(rp), dimension(:,:), allocatable :: V0,dV - - real(rp) :: dphi_mix,dphi_rcm - real(rp) :: colat - - !Setup domain - Ni = RCMApp%nLat_ion - Nj = RCMApp%nLon_ion - - !Prep for smoothing - allocate(isG(Ni,Nj)) - isG = .not. (RCMApp%iopen == RCMTOPOPEN) - - !Smooth some tubes - !Currently only smoothing ingestion timescale - call Smooth2D(RCMApp%Tb) !Bounce timescale for ingestion - - - contains - subroutine Smooth2D(Q) - real(rp), dimension(Ni,Nj), intent(inout) :: Q - - real(rp), dimension(Ni,Nj) :: Qs - integer :: i,j,di,dj,ip,jp - real(rp), dimension(-2:+2,-2:+2) :: Q55 - logical , dimension(-2:+2,-2:+2) :: G55 - - Qs(:,:) = Q - - !$OMP PARALLEL DO default(shared) & - !$OMP schedule(dynamic) & - !$OMP private(i,j,di,dj,ip,jp,Q55,G55) - do j=1,Nj - do i=3,Ni-3 - if (isG(i,j)) then - !Pack local 5x5 stencil - do dj=-2,+2 - do di=-2,+2 - ip = i+di - jp = WrapJ(j+dj) - Q55(di,dj) = Q (ip,jp) - G55(di,dj) = isG(ip,jp) - enddo !di - enddo !dj - !Calc smoothed value and store - Qs(i,j) = SmoothOperator55(Q55,G55) - endif !isG(i,j) - enddo !i - enddo !j - !Store values - Q = Qs - end subroutine Smooth2D - - !Wrap j index around periodic boundary - function WrapJ(j) result(jp) - integer, intent(in) :: j - integer :: jp - jp = j - if (jp>Nj) jp = jp-Nj+1 - if (jp<1 ) jp = jp+Nj-1 - end function WrapJ - end subroutine SmoothTubes - - !Rewire MHD=>RCM info to set RCM's cold start ICs - subroutine HackTubes(RCMApp,vApp) - type(rcm_mhd_T), intent(inout) :: RCMApp - type(voltApp_T), intent(in) :: vApp - - integer :: i,j, ij_TM(2) - real(rp) :: llBC,lat,colat,lon,LPk - - real(rp) :: Pmhd,Dmhd,P0_rc,N0_rc,N0_ps,P0_ps,N,P,L - real(rp) :: xyzSM(NDIM) - real(rp) :: x0_TM,y0_TM,Bvol0_TM,T0_TM,ktRC,ijBvol0,ktMax,ktCap - - logical :: isInTM03,isLL,isOut - - ktCap = 4.0 !Limit temperature increase from plasma sheet temp. - - !Loop through active region and reset things - llBC = vApp%mhd2chmp%lowlatBC - - LPk = LPk_QTRC() - - !To setup RC temperature, adiabatically push TM03 temperature at X=-10 (+eps) - !Find bmin at x0_TM - x0_TM = (-10.0 - TINY)*Rp_m - y0_TM = ( 0.0 )*Rp_m - - ij_TM = minloc( sqrt( (RCMApp%X_bmin(:,:,XDIR) - x0_TM)**2.0 + (RCMApp%X_bmin(:,:,YDIR) - y0_TM)**2.0 ), & - mask=.not. (RCMApp%iopen == RCMTOPOPEN) ) - - !Now get temperature and FTV at location - !B0_TM = RCMApp%Bmin(ij_TM(IDIR),ij_TM(JDIR)) - Bvol0_TM = RCMApp%Vol(ij_TM(IDIR),ij_TM(JDIR)) - call EvalTM03([x0_TM,y0_TM,0.0_rp]/Rp_m,N0_ps,P0_ps,isInTM03) - T0_TM = DP2kT(N0_ps,P0_ps) - - if (.not. isInTM03) then - write(*,*) "This should not happen w/ TM03, you should figure this out ..." - endif - - do j=1,RCMApp%nLon_ion - do i=1,RCMApp%nLat_ion - !Grab coordinates - colat = RCMApp%gcolat(i) - lat = PI/2 - colat - lon = RCMApp%glong(j) - - !Decide if we're below low-lat BC or not - isLL = (lat <= llBC) - isOut = (RCMApp%iopen(i,j) == RCMTOPOPEN) - - if (isLL .or. isOut) cycle - - !Get L,Pmhd,Dmhd (convert back to our units; nPa,#/cc,Re) - Pmhd = rcmPScl*RCMApp%Pave(i,j) - Dmhd = rcmNScl*RCMApp%Nave(i,j) - L = norm2( RCMApp%X_bmin(i,j,:) )/Rp_m - xyzSM(:) = RCMApp%X_bmin(i,j,:) /Rp_m - - !Quiet-time ring current - P0_rc = P_QTRC(L) - ! Get target temperature from adiabatic scaling of TM plasma sheet - ! From RCM approximation, KE = lambda*bVol^(-2/3) - ! KE_ij = KE_10*(bVol_10/bVol_ij)^(2/3) - ijBvol0 = RCMApp%Vol(i,j) - ktRC = (T0_TM)*(Bvol0_TM/ijBvol0)**(2./3.) - ktRC = min(ktRC,ktCap*T0_TM) - - N0_rc = PkT2Den(P0_rc,ktRC) - - !Get plasma sheet values - !Prefer TM03 but use Borovsky statistical values otherwise - call EvalTM03_SM(xyzSM,N0_ps,P0_ps,isInTM03) - if (.not. isInTM03) then - N0_ps = RCMICs%dPS - P0_ps = DkT2P(N0_ps,RCMICs%kTPS) - endif - - if ( P0_ps>P0_rc ) then - !Use PS values - P = P0_ps - N = N0_ps - else - !Use RC values - P = P0_rc - N = N0_rc - endif - - !Now store them - RCMApp%Pave(i,j) = P/rcmPScl - RCMApp%Nave(i,j) = N/rcmNScl - - enddo - enddo - end subroutine HackTubes - -end module rcmtubes