From e6d78d7957729a714e5e2ac7f0ec24ed5ecfa9d5 Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 1 May 2024 10:22:58 -0700 Subject: [PATCH 001/118] powspace stabscan gridding --- slayer/makefile | 21 +++++++++++++++------ slayer/slayer.f | 38 +++++++++++++++++++++++++------------- 2 files changed, 40 insertions(+), 19 deletions(-) diff --git a/slayer/makefile b/slayer/makefile index 65f531be3..50e86ba91 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -1,7 +1,7 @@ include ../install/DEFAULTS.inc -IFLAGS = -I$(MATHINC) -I$(NETCDFINC) +IFLAGS = -I../equil -I../pentrc -I$(MATHINC) -I$(NETCDFINC) F90 = $(FC) $(FFLAGS) $(OMPFLAG) $(IFLAGS) export FFLAGS @@ -11,7 +11,9 @@ export FFLAGS LIBDIR = ../lib LIBS = \ - -llsode + -llsode \ + -lpentrc \ + -lequil OBJS = \ sglobal.o \ @@ -20,11 +22,17 @@ OBJS = \ gslayer.o \ slayer.o -all: lsode slayer +all: lsode equil pentrc slayer -lsode: +equil: + cd ../equil; make + +lsode: cd ../lsode; make +pentrc: + cd ../pentrc; make pentrc + slayer: $(OBJS) $(F90) -o slayer $(OBJS) -L$(LIBDIR) $(LIBS) -L$(MATHDIR) $(MATHLIBS) -L$(NETCDFDIR) $(NETCDFLIBS) $(NETCDF_EXTRA_LIBS) mkdir -p ../lib/ @@ -37,7 +45,8 @@ slayer: $(OBJS) params.o : sglobal.o delta.o : sglobal.o gslayer.o : sglobal.o delta.o -slayer.o : sglobal.o params.o delta.o +slayer.o : sglobal.o params.o delta.o ../pentrc/grid.mod ../equil/spline_mod.mod clean: - rm -f *.o *.mod *.out *.bin slayer + rm -f *.o *.mod *.out *.bin slayers + diff --git a/slayer/slayer.f b/slayer/slayer.f index 81281dc04..2ef561600 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -17,6 +17,8 @@ PROGRAM slayer USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag + USE grid, ONLY : powspace,linspace + IMPLICIT NONE CHARACTER(128) :: infile @@ -43,9 +45,11 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl + $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl, + $ inQs_log REAL(r8), DIMENSION(:,:), ALLOCATABLE :: - $ js,ks,psis,jxbs,Q_sols,br_ths + $ js,ks,psis,jxbs,Q_sols,br_ths, + $ inQs_left,inQs_right REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas @@ -307,20 +311,28 @@ PROGRAM slayer c----------------------------------------------------------------------- IF (stability_flag) THEN ALLOCATE(inQs(0:inum),iinQs(0:200)) - ALLOCATE(deltas(0:inum,0:200)) - - inQ_max=10.0 - inQ_min=-10.0 - - DO i=0,inum + ALLOCATE(inQs_left(0:2+inum/2,0:2+inum/2)) + ALLOCATE(inQs_right(0:2+inum/2,0:2+inum/2)) + ALLOCATE(inQs_log(0:3+inum)) + ALLOCATE(deltas(0:3+inum,0:200)) + + inQ_max=5.0 + inQ_min=-5.0 + + inQs_left = powspace(REAL(Q)-1.0,REAL(Q),1,2+inum/2,"upper") + inQs_right = powspace(REAL(Q),REAL(Q)+1.0,1,2+inum/2,"lower") + inQs_log = (/inQs_left(1,1:2+inum/2),inQs_right(1,2:1+inum/2)/) + !WRITE(*,*)"inQs_log=",inQs_log + DO i=0,inum+3 DO j=0,200 inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) + iinQs(j)=inQ_min+(REAL(j)/200)*(inQ_max-inQ_min) - deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr,inc_beta, - $ inds,intau,inpe,iinQ=iinQs(j)) + deltas(i,j)=riccati(inQs_log(i),inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ENDDO ENDDO - + IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_stability_n"// $ TRIM(sn)//".out", STATUS="UNKNOWN") @@ -329,13 +341,13 @@ PROGRAM slayer DO i=0,inum DO j=0,200 WRITE(out_unit,'(1x,4(es17.8e3))') - $ inQs(i),iinQs(j), + $ inQs_log(i),iinQs(j), $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) ENDDO ENDDO CLOSE(out_unit) ENDIF - DEALLOCATE(inQs,iinQs,deltas) + DEALLOCATE(inQs,iinQs,inQs_left,inQs_right,inQs_log,deltas) ENDIF c----------------------------------------------------------------------- c riccati scan. From 37e04e708b1cbe6da5cc23e98b9c73fa8ba6c82b Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 3 May 2024 10:59:41 -0700 Subject: [PATCH 002/118] broken, but setting up stabscan loop --- slayer/gslayer.f | 145 ++++++++++++++++++++++++++++++++++++++++++++++- slayer/sglobal.f | 2 +- slayer/slayer.f | 34 +++++------ 3 files changed, 158 insertions(+), 23 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index f5cfe4eb5..289ad129c 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -8,6 +8,8 @@ MODULE gslayer_mod USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag + USE grid, ONLY : powspace,linspace + IMPLICIT NONE CONTAINS @@ -29,7 +31,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, LOGICAL, INTENT(IN) :: ascii_flag COMPLEX(r8),INTENT(OUT) :: delta,psi0 REAL(r8),INTENT(OUT) :: jxb,omega_sol,br_th - + INTEGER :: i,inum INTEGER, DIMENSION(1) :: index @@ -169,4 +171,145 @@ END SUBROUTINE gpec_slayer END MODULE gslayer_mod +c----------------------------------------------------------------------- +c subprogram 2. slayer_growthrates. +c run slayer to provide gamma(ising). +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c declarations. +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- + SUBROUTINE slayer_growthrates(infile,ascii_flag, + $ ReQ_num,ImQ_num) + + INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns + INTEGER :: ReQ_num,ImQ_num ! TEMPORARY HARDCODING + + LOGICAL, INTENT(IN) :: ascii_flag + + INTEGER :: i,inum + INTEGER, DIMENSION(1) :: index + + REAL(r8) :: inQ,inQ_e,inQ_i,inpe,inc_beta,inds,intau,inlu + REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, + $ lbeta,tau_i,tau_h,tau_r,tau_v + REAL(r8) :: inQ_min,inQ_max,Q_sol + + CHARACTER(3) :: sn,sm + + CHARACTER(len=8) :: fmt ! format descriptor for stab file naming + CHARACTER(len=8) :: x1 ! string for stab file naming + INTEGER :: i1 ! integer for stab file naming + + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, + $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, + $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl, + $ inQs_log + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: + $ js,ks,psis,Q_sols, + $ inQs_left,inQs_right + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss + COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + + OPEN(UNIT=input_unit,FILE=infile,STATUS="old") + READ(input_unit,*)inn + ALLOCATE(mms(inn),nns(inn),prs(inn), + $ n_es(inn),t_es(inn),t_is(inn),omegas(inn), + $ l_ns(inn),l_ts(inn),qvals(inn),svals(inn), + $ bts(inn),rss(inn),R0s(inn),mu_is(inn),zeffs(inn), + $ Q_soll(inn),br_thl(inn)) + DO k=0,inn-1 + READ(input_unit,'(2(1x,I2),14(1x,e12.4))') + $ mms(k),nns(k),prs(k), + $ n_es(k),t_es(k),t_is(k),omegas(k), + $ l_ns(k),l_ts(k),qvals(k),svals(k), + $ bts(k),rss(k),R0s(k),mu_is(k),zeffs(k) + ENDDO + CLOSE(input_unit) + + DO k=0,inn-1 + WRITE(*,*)k + mr=REAL(mms(k)) + nr=REAL(nns(k)) + inpr=prs(k) + CALL params(n_es(k),t_es(k),t_is(k),omegas(k), + $ l_ns(k),l_ts(k),qvals(k),svals(k),bts(k),rss(k), + $ R0s(k),mu_is(k),zeffs(k),params_check) + inQ=Q + inQ_e=Q_e + inQ_i=Q_i + inc_beta=c_beta + inds=ds + intau=tau + Q0=Q + + IF (Q0>inQ_e) THEN + inQ_max=2.0*Q0 + inQ_min=1.05*inQ_e + ELSE + inQ_max=0.95*inQ_e + IF (Q0>0) THEN + inQ_min=0.8*inQ_i + ELSE + inQ_min=1.5*MINVAL((/Q0,inQ_i/)) + ENDIF + ENDIF + ENDDO + + riccati_out=.FALSE. + + ReQ_num = 400 + ImQ_num = 200 + + ALLOCATE(inQs(0:ReQ_num),iinQs(0:ImQ_num)) + ALLOCATE(inQs_left(0:2+ReQ_num/2,0:2+ReQ_num/2)) + ALLOCATE(inQs_right(0:2+ReQ_num/2,0:2+ReQ_num/2)) + ALLOCATE(inQs_log(0:3+ReQ_num)) + ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) + + inQ_max=5.0 + inQ_min=-5.0 + + inQs_left = powspace(REAL(Q)-1.0,REAL(Q),1, + $ 2+ReQ_num/2,"upper") + inQs_right = powspace(REAL(Q),REAL(Q)+1.0,1, + $ 2+ReQ_num/2,"lower") + inQs_log = (/inQs_left(1,1:2+ReQ_num/2), + $ inQs_right(1,2:1+ReQ_num/2)/) + !WRITE(*,*)"inQs_log=",inQs_log + DO i=0,ReQ_num+3 + DO j=0,ImQ_num + inQs(i)=inQ_min+(REAL(i)/ReQ_num)*(inQ_max-inQ_min) + + iinQs(j)=inQ_min+(REAL(j)/ImQ_num)*(inQ_max-inQ_min) + deltas(i,j)=riccati(inQs_log(i),inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) + ENDDO + ENDDO + +c----------------------------------------------------------------------- +c block to allow file sequential fil naming based on q + fmt = '(I5.5)' ! an integer of width 5 with zeros at the left + i1 = qvals(k) + write (x1,fmt) i1 ! integer to string using a 'internal file' +c----------------------------------------------------------------------- + + OPEN(UNIT=out_unit,FILE="slayer_stability_q"// + $ TRIM(x1)//".out", STATUS="UNKNOWN") + WRITE(out_unit,'(1x,4(a17))'),"RE(Q)", + $ "IM(Q)","RE(delta)","IM(delta)" + DO i=0,ReQ_num + DO j=0,ImQ_num + WRITE(out_unit,'(1x,4(es17.8e3))') + $ inQs_log(i),iinQs(j), + $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) + ENDDO + ENDDO + CLOSE(out_unit) + + DEALLOCATE(inQs,iinQs,inQs_left,inQs_right,inQs_log,deltas) + DEALLOCATE(prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, + $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,mms,nns) + + diff --git a/slayer/sglobal.f b/slayer/sglobal.f index dab710805..43343bf6d 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -9,7 +9,7 @@ MODULE sglobal_mod REAL(r8) :: mr,nr REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, - $ delta_n,layfac + $ delta_n,layfac,Qconv COMPLEX(r8) :: Q REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, diff --git a/slayer/slayer.f b/slayer/slayer.f index 2ef561600..f21441bf5 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -17,12 +17,10 @@ PROGRAM slayer USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag - USE grid, ONLY : powspace,linspace - IMPLICIT NONE CHARACTER(128) :: infile - INTEGER :: i,j,k,inum,jnum,knum,inn + INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -100,6 +98,8 @@ PROGRAM slayer inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. + ReQ_num=400 ! resolution for stab. scan along Re(Q) axis + ImQ_num=200 ! resolution for stab. scan along Im(Q) axis in_unit=1 out_unit=2 out2_unit=3 @@ -311,25 +311,17 @@ PROGRAM slayer c----------------------------------------------------------------------- IF (stability_flag) THEN ALLOCATE(inQs(0:inum),iinQs(0:200)) - ALLOCATE(inQs_left(0:2+inum/2,0:2+inum/2)) - ALLOCATE(inQs_right(0:2+inum/2,0:2+inum/2)) - ALLOCATE(inQs_log(0:3+inum)) - ALLOCATE(deltas(0:3+inum,0:200)) - - inQ_max=5.0 - inQ_min=-5.0 - - inQs_left = powspace(REAL(Q)-1.0,REAL(Q),1,2+inum/2,"upper") - inQs_right = powspace(REAL(Q),REAL(Q)+1.0,1,2+inum/2,"lower") - inQs_log = (/inQs_left(1,1:2+inum/2),inQs_right(1,2:1+inum/2)/) - !WRITE(*,*)"inQs_log=",inQs_log - DO i=0,inum+3 + ALLOCATE(deltas(0:inum,0:200)) + + inQ_max=10.0 + inQ_min=-10.0 + + DO i=0,inum DO j=0,200 inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) - iinQs(j)=inQ_min+(REAL(j)/200)*(inQ_max-inQ_min) - deltas(i,j)=riccati(inQs_log(i),inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) + deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr,inc_beta, + $ inds,intau,inpe,iinQ=iinQs(j)) ENDDO ENDDO @@ -341,13 +333,13 @@ PROGRAM slayer DO i=0,inum DO j=0,200 WRITE(out_unit,'(1x,4(es17.8e3))') - $ inQs_log(i),iinQs(j), + $ inQs(i),iinQs(j), $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) ENDDO ENDDO CLOSE(out_unit) ENDIF - DEALLOCATE(inQs,iinQs,inQs_left,inQs_right,inQs_log,deltas) + DEALLOCATE(inQs,iinQs,deltas) ENDIF c----------------------------------------------------------------------- c riccati scan. From 5632eb339ea812c6b3cbe35fa22746935387d287 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 23 May 2024 11:33:38 -0700 Subject: [PATCH 003/118] 1st draft gamma calculation --- slayer/gslayer.f | 420 +++++++++++++++++++++++++++++++++++++---------- slayer/slayer.f | 62 ++++++- 2 files changed, 383 insertions(+), 99 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 289ad129c..a81c8ecd4 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -8,6 +8,8 @@ MODULE gslayer_mod USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag + USE params_mod + USE grid, ONLY : powspace,linspace IMPLICIT NONE @@ -168,74 +170,220 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer - - END MODULE gslayer_mod - -c----------------------------------------------------------------------- -c subprogram 2. slayer_growthrates. -c run slayer to provide gamma(ising). c----------------------------------------------------------------------- +c Subprogram 2. interpolate_slice_at_Q +c Either extract or interpolate a 1D deltas slice at given Q c----------------------------------------------------------------------- -c declarations. -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- - SUBROUTINE slayer_growthrates(infile,ascii_flag, - $ ReQ_num,ImQ_num) - - INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns - INTEGER :: ReQ_num,ImQ_num ! TEMPORARY HARDCODING + SUBROUTINE interpolate_slice_at_Q(deltas, Q, inQs_log, + $ slice) + ! Input + REAL(r8), DIMENSION(:, :), INTENT(IN) :: deltas ! 2D delta array + REAL(r8), DIMENSION(:), INTENT(IN) :: inQs_log ! Re(Q) axis + REAL(r8), INTENT(IN) :: Q ! slice value (Q) + ! Output + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: slice + ! Local variables + INTEGER :: NROWS, NCOLS, i_lower, i_upper, j + REAL(r8) :: Q_lower,Q_upper,lower_slice,upper_slice + + ! Extract array dimensions + NROWS = SIZE(deltas, 1) + NCOLS = SIZE(deltas, 2) + ! Allocate slice array (same size as second dimension of deltas) + ALLOCATE(slice(NCOLS)) + ! Find bracketing rows based on Q (assuming sorted x-axis) + i_lower = 1 + DO WHILE (i_lower < NROWS .AND. inQs_log(i_lower+1) < Q) + i_lower = i_lower + 1 + END DO + + ! Check if Q is included in inQs_log (it should be) + IF (inQs_log(i_lower) - Q < 1.0E-6_r8) THEN !!! this threshold could be an issue? + WRITE(*,*)"Indexing slice at Q!" + DO j = 1, NCOLS + slice(j) = deltas(i_lower, j) + END DO + ELSE - LOGICAL, INTENT(IN) :: ascii_flag + !! Handle cases where Q is outside the range + ! IF (i_lower == 1 .AND. Q < deltas(1, 1)) THEN + ! i_lower = 1 + ! i_upper = 2 + ! ELSE IF (i_lower == NROWS) THEN + ! i_lower = NROWS - 1 + ! i_upper = NROWS + ! ELSE + ! i_upper = i_lower + 1 + ! END IF + + ! Interpolate each element of the slice (along the columns) + DO j = 1, NCOLS + i_upper = i_lower+1 + + lower_slice = deltas(i_lower, j) + upper_slice = deltas(i_upper, j) + Q_lower = deltas(i_lower, 1) + Q_upper = deltas(i_upper, 1) + + slice(j) = (lower_slice + upper_slice )/2.0 + + ! This linear interpolation isn't correct ??? + !slice(j) = lower_slice + + !$ (Q - Q_lower) * (upper_slice - + !$ lower_slice) / (Q_upper - Q_lower) + END DO + END IF - INTEGER :: i,inum - INTEGER, DIMENSION(1) :: index + RETURN + END SUBROUTINE interpolate_slice_at_Q +c----------------------------------------------------------------------- +c Subprogram 3. gamma_from_delta_match +c Interpolate gamma corresponding to delta-deltaprime match +c----------------------------------------------------------------------- + SUBROUTINE gamma_from_delta_match(slice, iinQs, deltap, + $ ImQ_gamma) + ! Inputs + REAL(r8), DIMENSION(:), INTENT(IN) :: slice ! 1D gammas array, i.e. deltas(Q,:) + REAL(r8), DIMENSION(:), INTENT(IN) :: iinQs ! 1D array of gammas, i.e. Im(Q) + REAL(r8), INTENT(IN) :: deltap ! Target outer layer delta prime + ! Output + REAL(r8), INTENT(OUT) :: ImQ_gamma ! Matched gamma(delta = deltaprime), giving growth rate + ! Local variables + INTEGER :: n, i_lower, i_upper, i, j, i_mid + REAL(r8) :: deltap_lower, deltap_upper, slope + REAL(r8), DIMENSION(:), ALLOCATABLE :: temp_slice, temp_iinQs ! Temporary arrays + + ! Array size check + n = SIZE(slice) + IF (SIZE(iinQs) /= n) THEN + WRITE(*, *) 'ERROR: slice and iinQs arrays + $ must have the same size.' + RETURN + END IF + + ! Allocate temporary arrays + ALLOCATE(temp_slice(n), temp_iinQs(n)) + ImQ_gamma = 0.0 + + ! Copy input arrays to temporary arrays + temp_slice = slice + temp_iinQs = iinQs + + ! Sort temporary arrays in ascending order if not already sorted + IF (ANY(temp_slice(2:) < temp_slice(:n-1))) THEN + ! Simple bubble sort + DO i = 1, n - 1 + DO j = 1, n - i + IF (temp_slice(j) > temp_slice(j + 1)) THEN + ! Swap elements in temp_slice + temp_slice([j, j+1]) = temp_slice([j+1, j]) + ! Swap corresponding elements in temp_iinQs + temp_iinQs([j, j+1]) = temp_iinQs([j+1, j]) + END IF + END DO + END DO + END IF + + ! Handle cases where deltap is outside the temp_slice range + IF (deltap < temp_slice(1)) THEN + i_lower = 1 + i_upper = 2 + ELSE IF (deltap > temp_slice(n)) THEN + i_lower = n - 1 + i_upper = n + ELSE + ! Find the bracketing indices for deltap (binary search) + i_lower = 1 + i_upper = n + DO WHILE (i_upper - i_lower > 1) + i_mid = (i_lower + i_upper) / 2 + IF (temp_slice(i_mid) < deltap) THEN + i_lower = i_mid + ELSE + i_upper = i_mid + END IF + END DO + END IF + + deltap_lower = temp_slice(i_lower) + deltap_upper = temp_slice(i_upper) + + !WRITE(*,*)"my ImQ_gamma=",(temp_iinQs(i_lower) + FOR TESTING + !$ temp_iinQs(i_upper)) / 2 + + ! Linear interpolation (revised for robustness) + IF (deltap_upper - deltap_lower < 1.0E-10_r8) THEN ! Handle nearly equal values + ImQ_gamma = (temp_iinQs(i_lower) + + $ temp_iinQs(i_upper)) / 2 + ELSE + slope = (temp_iinQs(i_upper) - + $ temp_iinQs(i_lower)) / (deltap_upper - deltap_lower) + ImQ_gamma = temp_iinQs(i_lower) + + $ slope * (deltap - deltap_lower) + END IF - REAL(r8) :: inQ,inQ_e,inQ_i,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, - $ lbeta,tau_i,tau_h,tau_r,tau_v - REAL(r8) :: inQ_min,inQ_max,Q_sol + !WRITE(*,*)"temp_iinQs(i_lower)=",temp_iinQs(i_lower) + !WRITE(*,*)"temp_iinQs(i_upper)=",temp_iinQs(i_upper) + !WRITE(*,*)"slice=",slice - CHARACTER(3) :: sn,sm + ! Deallocate temporary arrays + DEALLOCATE(temp_slice, temp_iinQs) + RETURN + END SUBROUTINE gamma_from_delta_match +c----------------------------------------------------------------------- +c Subprogram 4. gamma_stability_scan +c Run grid packed slayer stab. scan around omega_ExB and gamma axes +c----------------------------------------------------------------------- + SUBROUTINE gamma_stability_scan(n_e,t_e,t_i,omega,inpr,inpe, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff, + $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs,inQ) +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + ! Inputs + REAL(r8),INTENT(IN) :: n_e,t_e,t_i,omega,inpr,inpe,l_n,l_t, + $ qval,sval,bt,rs,R0,mu_i,zeff + INTEGER, INTENT(IN) :: ReQ_num,ImQ_num + + ! Outputs + COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, + $ INTENT(OUT) :: deltas + REAL(r8), DIMENSION(:), ALLOCATABLE, + $ INTENT(OUT) :: inQs_log,iinQs + REAL(r8), INTENT(OUT) :: inQ + + ! Local variables + INTEGER :: i,j,k + REAL(r8) :: inQ_e,inQ_i,inc_beta,inds,intau,Q0 + !REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, + !$ lbeta,tau_i,tau_h,tau_r,tau_v + REAL(r8) :: inQ_min,inQ_max + LOGICAL :: params_check + CHARACTER(3) :: q_str CHARACTER(len=8) :: fmt ! format descriptor for stab file naming CHARACTER(len=8) :: x1 ! string for stab file naming INTEGER :: i1 ! integer for stab file naming - - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl, - $ inQs_log - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: - $ js,ks,psis,Q_sols, - $ inQs_left,inQs_right - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss - COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas - - OPEN(UNIT=input_unit,FILE=infile,STATUS="old") - READ(input_unit,*)inn - ALLOCATE(mms(inn),nns(inn),prs(inn), - $ n_es(inn),t_es(inn),t_is(inn),omegas(inn), - $ l_ns(inn),l_ts(inn),qvals(inn),svals(inn), - $ bts(inn),rss(inn),R0s(inn),mu_is(inn),zeffs(inn), - $ Q_soll(inn),br_thl(inn)) - DO k=0,inn-1 - READ(input_unit,'(2(1x,I2),14(1x,e12.4))') - $ mms(k),nns(k),prs(k), - $ n_es(k),t_es(k),t_is(k),omegas(k), - $ l_ns(k),l_ts(k),qvals(k),svals(k), - $ bts(k),rss(k),R0s(k),mu_is(k),zeffs(k) - ENDDO - CLOSE(input_unit) - - DO k=0,inn-1 - WRITE(*,*)k - mr=REAL(mms(k)) - nr=REAL(nns(k)) - inpr=prs(k) - CALL params(n_es(k),t_es(k),t_is(k),omegas(k), - $ l_ns(k),l_ts(k),qvals(k),svals(k),bts(k),rss(k), - $ R0s(k),mu_is(k),zeffs(k),params_check) - inQ=Q + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: inQs_left,inQs_right + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs +c----------------------------------------------------------------------- +c Set initial values +c----------------------------------------------------------------------- + inQ=0.0 ! Q=23.0 for DIII-D example. + inQ_e=0.0 ! Q_e=2.0 for DIII-D example. + inQ_i=0.0 ! Q_i=-2.6 for DIII-D example. + inc_beta=0.0 ! c_beta=0.7 for DIII-D example. + inds=0.0 ! 6.0 for DIII-D example. + intau=0.0 ! 1.0 for DIII-D example. + !inlu=1e8 + Q0=0.0 +c----------------------------------------------------------------------- +c Calculate parameters as needed +c----------------------------------------------------------------------- + params_check=.TRUE. + CALL params(n_e,t_e,t_i,omega, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + inQ=REAL(Q) inQ_e=Q_e inQ_i=Q_i inc_beta=c_beta @@ -243,57 +391,60 @@ SUBROUTINE slayer_growthrates(infile,ascii_flag, intau=tau Q0=Q - IF (Q0>inQ_e) THEN - inQ_max=2.0*Q0 - inQ_min=1.05*inQ_e - ELSE - inQ_max=0.95*inQ_e - IF (Q0>0) THEN - inQ_min=0.8*inQ_i - ELSE - inQ_min=1.5*MINVAL((/Q0,inQ_i/)) - ENDIF - ENDIF - ENDDO - - riccati_out=.FALSE. - - ReQ_num = 400 - ImQ_num = 200 - + ! JKP used this for multiple surface loop but not for single surface? + ! IF (Q0>inQ_e) THEN + ! inQ_max=2.0*Q0 + ! inQ_min=1.05*inQ_e + ! ELSE + ! inQ_max=0.95*inQ_e + ! IF (Q0>0) THEN + ! inQ_min=0.8*inQ_i + ! ELSE + ! inQ_min=1.5*MINVAL((/Q0,inQ_i/)) + ! ENDIF + ! ENDIF + !ENDDO + + !riccati_out=.FALSE. ? +c----------------------------------------------------------------------- +c Build exponential grid packing for stability scan, then run +c----------------------------------------------------------------------- + ! Allocate grid packing arrays and 2D complex deltas array ALLOCATE(inQs(0:ReQ_num),iinQs(0:ImQ_num)) ALLOCATE(inQs_left(0:2+ReQ_num/2,0:2+ReQ_num/2)) ALLOCATE(inQs_right(0:2+ReQ_num/2,0:2+ReQ_num/2)) ALLOCATE(inQs_log(0:3+ReQ_num)) ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) - inQ_max=5.0 - inQ_min=-5.0 + inQ_max=3.0 ! max growth rate in scan, OPEN TO USER? + inQ_min=-3.0 ! min growth rate in scan, OPEN TO USER? - inQs_left = powspace(REAL(Q)-1.0,REAL(Q),1, + ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? + inQs_left = powspace(inQ-0.2,inQ,1, ! omega-0.2 $ 2+ReQ_num/2,"upper") - inQs_right = powspace(REAL(Q),REAL(Q)+1.0,1, + inQs_right = powspace(inQ,inQ+0.2,1, ! omega+0.2 $ 2+ReQ_num/2,"lower") inQs_log = (/inQs_left(1,1:2+ReQ_num/2), $ inQs_right(1,2:1+ReQ_num/2)/) !WRITE(*,*)"inQs_log=",inQs_log + DO i=0,ReQ_num+3 DO j=0,ImQ_num + ! Getting rid of "inQs" weirdly broke things?? inQs(i)=inQ_min+(REAL(i)/ReQ_num)*(inQ_max-inQ_min) - iinQs(j)=inQ_min+(REAL(j)/ImQ_num)*(inQ_max-inQ_min) + ! Run riccati() at each Q index to give delta deltas(i,j)=riccati(inQs_log(i),inQ_e,inQ_i,inpr, $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ENDDO ENDDO - c----------------------------------------------------------------------- -c block to allow file sequential fil naming based on q - fmt = '(I5.5)' ! an integer of width 5 with zeros at the left - i1 = qvals(k) - write (x1,fmt) i1 ! integer to string using a 'internal file' +c Alter qval to string to add to output filename c----------------------------------------------------------------------- - + fmt = '(I5.5)' ! an integer of width 2 for q surface + i1 = qval + write (x1,fmt) i1 ! integer to string using a 'internal file' + ! Write stability scan output file OPEN(UNIT=out_unit,FILE="slayer_stability_q"// $ TRIM(x1)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))'),"RE(Q)", @@ -305,11 +456,98 @@ SUBROUTINE slayer_growthrates(infile,ascii_flag, $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) ENDDO ENDDO - CLOSE(out_unit) + CLOSE(out_unit) - DEALLOCATE(inQs,iinQs,inQs_left,inQs_right,inQs_log,deltas) - DEALLOCATE(prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,mms,nns) + DEALLOCATE(inQs_left,inQs_right) + RETURN + END SUBROUTINE gamma_stability_scan +c----------------------------------------------------------------------- +c Subprogram 5. gamma_match +c Loop stability scans and gamma matches across k rational surfaces +c----------------------------------------------------------------------- + SUBROUTINE gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, + $ l_ns,l_ts,qvals,svals,bts,rss,R0s,mu_is, + $ zeffs,outer_deltas,ReQ_num,ImQ_num, + $ growthrates,growthrate_err) +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + ! Inputs + INTEGER, INTENT(IN) :: n_k ! Number of rational surfaces + INTEGER, DIMENSION(:), INTENT(IN) :: mms,nns + REAL(r8), DIMENSION(:), INTENT(IN) :: n_es,t_es, + $ t_is,omegas,prs,pes,l_ns,l_ts,qvals, + $ svals,bts,rss,R0s,mu_is,zeffs + COMPLEX(r8), DIMENSION(:), INTENT(IN) :: outer_deltas + INTEGER, INTENT(IN) :: ReQ_num,ImQ_num + ! Outputs + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: + $ growthrates, growthrate_err + ! Local variables + INTEGER :: k,w + ! Local variables received from internal subroutines + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log,iinQs + COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + REAL(r8), DIMENSION(:), ALLOCATABLE :: slice + REAL(r8), DIMENSION(3) :: Q_range ! (-Q_err, Q, +Q_err ) + REAL(r8), DIMENSION(3) :: growthrate_range ! (-gamma, +gamma ) + REAL(r8) :: layer_Q, inQ, ImQ_gamma + + ! Allocate growthrates arrays + ALLOCATE(growthrates(n_k)) + ALLOCATE(growthrate_err(n_k)) +c----------------------------------------------------------------------- +c Loop across rational surfaces +c----------------------------------------------------------------------- + ! Summary: for each rational surface, run narrow stability scan + ! for analysis, then slice out 1D array of growth rates at + ! given omega_ExB (Q), then find growth rate corresponding + ! to delta-deltaprime match + DO k=1,n_k + WRITE(*,*)"layer #: ",k + ! Run stability scan + CALL gamma_stability_scan(n_es(k),t_es(k),t_is(k),omegas(k), + $ prs(k),pes(k),l_ns(k),l_ts(k),qvals(k),svals(k), + $ bts(k),rss(k),R0s(k),mu_is(k),zeffs(k), + $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs,inQ) + + layer_Q = inQ + + ! Hardcoding rudimentary +/- 10% omega_ExB errorbars + Q_range = (/0.9*layer_Q, 1.1*layer_Q, layer_Q/) + + ! Calculate growth rate +/- omega_ExB = Q errorbars + DO w=1,3 + + ! Slice out growth rates at layer_Q (Re(Q)) + CALL interpolate_slice_at_Q(REAL(deltas), + $ Q_range(w), inQs_log, slice) + + ! Match delta to delta prime to obtain growth rate + CALL gamma_from_delta_match(slice, iinQs, + $ REAL(outer_deltas(k)), + $ ImQ_gamma) + + IF (w==3) THEN + ! Qconv = Q / omega_ExB + ! gamma = Im(Q) / Qconv + growthrates(k) = ImQ_gamma / (layer_Q / omegas(k)) + ELSE + growthrate_range(w) = ImQ_gamma / (layer_Q / omegas(k)) + ENDIF + ENDDO + growthrate_err(k) = ABS(growthrate_range(2) - + $ growthrate_range(1)) + + DEALLOCATE(slice) ! Free memory after use for each layer + + ENDDO + DEALLOCATE(deltas,inQs_log,iinQs) + + RETURN + END SUBROUTINE gamma_match + + END MODULE gslayer_mod diff --git a/slayer/slayer.f b/slayer/slayer.f index f21441bf5..315b963de 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -17,10 +17,13 @@ PROGRAM slayer USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag + ! FOR TESTING: + USE gslayer_mod + IMPLICIT NONE CHARACTER(128) :: infile - INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num + INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num,n_k INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -28,7 +31,7 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check + $ params_check,gamma_match_flag !FOR TESTING REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff @@ -42,16 +45,19 @@ PROGRAM slayer INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl, + $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, + $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes, $ inQs_log REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, $ inQs_left,inQs_right REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates, + $ growthrate_err + NAMELIST/slayer_input/params_flag,input_flag,infile, $ mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, @@ -63,7 +69,7 @@ PROGRAM slayer NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ stability_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, - $ params_check,bal_flag + $ params_check,bal_flag,gamma_match_flag c----------------------------------------------------------------------- c set initial values. c----------------------------------------------------------------------- @@ -98,8 +104,8 @@ PROGRAM slayer inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=400 ! resolution for stab. scan along Re(Q) axis - ImQ_num=200 ! resolution for stab. scan along Im(Q) axis + ReQ_num=200 ! resolution for stab. scan along Re(Q) axis + ImQ_num=100 ! resolution for stab. scan along Im(Q) axis in_unit=1 out_unit=2 out2_unit=3 @@ -255,6 +261,46 @@ PROGRAM slayer $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,mms,nns) ENDIF c----------------------------------------------------------------------- +c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY +c----------------------------------------------------------------------- + IF (gamma_match_flag) THEN + n_k=2 + ALLOCATE(mms(n_k),nns(n_k),prs(n_k),pes(n_k), + $ n_es(n_k),t_es(n_k),t_is(n_k),omegas(n_k), + $ l_ns(n_k),l_ts(n_k),qvals(n_k),svals(n_k), + $ bts(n_k),rss(n_k),R0s(n_k),mu_is(n_k),zeffs(n_k), + $ outer_deltas(n_k)) + ! Approximate data for q=2 and q=3, for testing only + ! These are of the form needed to output from + ! upcoming build_inputs.f script, interfacing with equil.f + mms = (/2, 2 /) + nns = (/1, 1 /) + prs = (/0.1, 0.005 /) + pes = (/0.0, 0.0 /) + n_es = (/7.765e+17, 9.999e+16 /) + t_es = (/26.0, 2.0 /) + t_is = (/26.0, 2.0 /) + omegas = (/54530.0, 54530.0 /) + l_ns = (/0.2, 0.2 /) + l_ts = (/0.1, 0.1 /) + qvals = (/2.0, 3.0 /) + svals = (/729.5, 500.5 /) + bts = (/1.0, 1.0 /) + rss = (/0.16, 0.2 /) + R0s = (/2.0, 2.0 /) + mu_is = (/2.0, 2.0 /) + zeffs = (/2.0, 2.0 /) + outer_deltas = (/(27.15,0.1), (20.15,0.1) /) + + CALL gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, + $ l_ns,l_ts,qvals,svals,bts,rss,R0s,mu_is, + $ zeffs,outer_deltas, + $ ReQ_num,ImQ_num,growthrates,growthrate_err) + WRITE(*,*)"growthrates=",growthrates + WRITE(*,*)"growthrate error=",growthrate_err + + ENDIF +c----------------------------------------------------------------------- c find solutions based on simple torque balance. c----------------------------------------------------------------------- IF (bal_flag)THEN From e04745f6392d5cd3d1844c83983d665685d47e77 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 6 Jun 2024 15:21:06 -0700 Subject: [PATCH 004/118] WIP: layer inputs routine --- slayer/gslayer.f | 245 ++++++++++++++++++++----------------------- slayer/layerinputs.f | 236 +++++++++++++++++++++++++++++++++++++++++ slayer/makefile | 3 +- slayer/slayer.f | 68 +++++++----- 4 files changed, 396 insertions(+), 156 deletions(-) create mode 100644 slayer/layerinputs.f diff --git a/slayer/gslayer.f b/slayer/gslayer.f index a81c8ecd4..2182c57c6 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -250,8 +250,10 @@ SUBROUTINE gamma_from_delta_match(slice, iinQs, deltap, REAL(r8), INTENT(OUT) :: ImQ_gamma ! Matched gamma(delta = deltaprime), giving growth rate ! Local variables INTEGER :: n, i_lower, i_upper, i, j, i_mid - REAL(r8) :: deltap_lower, deltap_upper, slope - REAL(r8), DIMENSION(:), ALLOCATABLE :: temp_slice, temp_iinQs ! Temporary arrays + REAL(r8) :: deltap_lower, deltap_upper, slope, + $ lower_val, upper_val,n_poles,dx + REAL(r8), DIMENSION(:), ALLOCATABLE :: temp_slice, temp_iinQs, ! Temporary arrays + $ grad_slice, pospole_gamma, negpole_gamma ! Array size check n = SIZE(slice) @@ -263,67 +265,93 @@ SUBROUTINE gamma_from_delta_match(slice, iinQs, deltap, ! Allocate temporary arrays ALLOCATE(temp_slice(n), temp_iinQs(n)) + ALLOCATE(grad_slice(n-1)) ! gradient + ImQ_gamma = 0.0 ! Copy input arrays to temporary arrays temp_slice = slice temp_iinQs = iinQs - ! Sort temporary arrays in ascending order if not already sorted - IF (ANY(temp_slice(2:) < temp_slice(:n-1))) THEN - ! Simple bubble sort - DO i = 1, n - 1 - DO j = 1, n - i - IF (temp_slice(j) > temp_slice(j + 1)) THEN - ! Swap elements in temp_slice - temp_slice([j, j+1]) = temp_slice([j+1, j]) - ! Swap corresponding elements in temp_iinQs - temp_iinQs([j, j+1]) = temp_iinQs([j+1, j]) + ! GRADIENT THRESHOLD IS 50??? + n_poles = 1.0 + ALLOCATE(pospole_gamma(2),negpole_gamma(2)) + pospole_gamma = 1e+20 + negpole_gamma = 1e+20 + + ! Calculate the gradient + DO i = 1, n - 1 + dx = iinQs(i + 1) - iinQs(i) ! Change in x + grad_slice(i) = (slice(i + 1) - slice(i)) / dx ! Slope (gradient) + END DO + + ! Find first match + DO i = 1, n-1 + ! is this a pole point? + IF (((SIGN(1.0,slice(i)) /= SIGN(1.0,slice(i+1))) .AND. + $ ABS(grad_slice(i) > 50))) THEN!.AND. + !$ (SIGN(1.0,grad_slice(i)) /= + !$ SIGN(1.0,grad_slice(i+1)))) THEN + ! it is a pole + IF (slice(i) > 0) THEN + WRITE(*,*)"FOUND A POS POLE ",0.0 + pospole_gamma(n_poles) = iinQs(i) + negpole_gamma(n_poles) = iinQs(i+1) + n_poles = n_poles + 1 + ELSE + WRITE(*,*)"FOUND A NEG POLE ",i + negpole_gamma(n_poles) = iinQs(i) + pospole_gamma(n_poles) = iinQs(i+1) + n_poles = n_poles+1 END IF - END DO - END DO - END IF - ! Handle cases where deltap is outside the temp_slice range - IF (deltap < temp_slice(1)) THEN - i_lower = 1 - i_upper = 2 - ELSE IF (deltap > temp_slice(n)) THEN - i_lower = n - 1 - i_upper = n - ELSE - ! Find the bracketing indices for deltap (binary search) - i_lower = 1 - i_upper = n - DO WHILE (i_upper - i_lower > 1) - i_mid = (i_lower + i_upper) / 2 - IF (temp_slice(i_mid) < deltap) THEN - i_lower = i_mid - ELSE - i_upper = i_mid - END IF - END DO - END IF + WRITE(*,*)"n_poles=",n_poles - deltap_lower = temp_slice(i_lower) - deltap_upper = temp_slice(i_upper) + IF ((SIGN(1.0,slice(i))<0.0 .AND. deltap0.0 .AND. deltap>slice(i))) THEN + ImQ_gamma = iinQs(i) ! stride value is huge and not captured by our grid, but will be close to the pole + END IF + ELSE + ! Determine which element of the slice is lower and which is upper + IF (slice(i) <= slice(i + 1)) THEN + lower_val = slice(i) + upper_val = slice(i + 1) + ELSE + lower_val = slice(i + 1) + upper_val = slice(i) + END IF - !WRITE(*,*)"my ImQ_gamma=",(temp_iinQs(i_lower) + FOR TESTING - !$ temp_iinQs(i_upper)) / 2 + ! Check if deltap is within the interval + IF ((lower_val <= deltap) .AND. + $ (deltap <= upper_val)) THEN + !ImQ_gamma = (iinQs(i) + iinQs(i+1)) / 2 ! do a better linear interpolation here + + ! Linear interpolation (revised for robustness) + IF (upper_val - lower_val < 1.0E-10_r8) THEN ! Handle nearly equal values + ImQ_gamma = (iinQs(i) + + $ iinQs(i+1)) / 2 + ELSE + slope = (iinQs(i+1) - + $ iinQs(i)) / (upper_val - lower_val) + ImQ_gamma = iinQs(i) + + $ slope * (deltap - lower_val) + END IF + END IF + END IF + END DO - ! Linear interpolation (revised for robustness) - IF (deltap_upper - deltap_lower < 1.0E-10_r8) THEN ! Handle nearly equal values - ImQ_gamma = (temp_iinQs(i_lower) + - $ temp_iinQs(i_upper)) / 2 - ELSE - slope = (temp_iinQs(i_upper) - - $ temp_iinQs(i_lower)) / (deltap_upper - deltap_lower) - ImQ_gamma = temp_iinQs(i_lower) + - $ slope * (deltap - deltap_lower) + IF (n_poles > 2) THEN + WRITE(*,*)"Alert: more than two poles detected" END IF + !WRITE(*,*)"temp_iinQs(i_lower)=",temp_iinQs(i_lower) !WRITE(*,*)"temp_iinQs(i_upper)=",temp_iinQs(i_upper) + !WRITE(*,*)"NEWImQ_gamma=",ImQ_gamma + !WRITE(*,*)"pospole_gamma=",pospole_gamma + !WRITE(*,*)"negpole_gamma=",negpole_gamma + !WRITE(*,*)"slice=",slice ! Deallocate temporary arrays @@ -335,15 +363,16 @@ END SUBROUTINE gamma_from_delta_match c Subprogram 4. gamma_stability_scan c Run grid packed slayer stab. scan around omega_ExB and gamma axes c----------------------------------------------------------------------- - SUBROUTINE gamma_stability_scan(n_e,t_e,t_i,omega,inpr,inpe, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff, - $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs,inQ) + SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,inQ0,inpr,inpe,ReQ_num,ImQ_num,deltas, + $ inQs_log,iinQs) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - REAL(r8),INTENT(IN) :: n_e,t_e,t_i,omega,inpr,inpe,l_n,l_t, - $ qval,sval,bt,rs,R0,mu_i,zeff + REAL(r8),INTENT(IN) :: qval,inQ_e,inQ_i,inc_beta,inds, + $ intau,inQ0,inpr,inpe + COMPLEX(r8), INTENT(IN) :: inQ INTEGER, INTENT(IN) :: ReQ_num,ImQ_num ! Outputs @@ -351,15 +380,10 @@ SUBROUTINE gamma_stability_scan(n_e,t_e,t_i,omega,inpr,inpe, $ INTENT(OUT) :: deltas REAL(r8), DIMENSION(:), ALLOCATABLE, $ INTENT(OUT) :: inQs_log,iinQs - REAL(r8), INTENT(OUT) :: inQ ! Local variables INTEGER :: i,j,k - REAL(r8) :: inQ_e,inQ_i,inc_beta,inds,intau,Q0 - !REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, - !$ lbeta,tau_i,tau_h,tau_r,tau_v REAL(r8) :: inQ_min,inQ_max - LOGICAL :: params_check CHARACTER(3) :: q_str CHARACTER(len=8) :: fmt ! format descriptor for stab file naming CHARACTER(len=8) :: x1 ! string for stab file naming @@ -367,46 +391,6 @@ SUBROUTINE gamma_stability_scan(n_e,t_e,t_i,omega,inpr,inpe, REAL(r8), DIMENSION(:,:), ALLOCATABLE :: inQs_left,inQs_right REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs c----------------------------------------------------------------------- -c Set initial values -c----------------------------------------------------------------------- - inQ=0.0 ! Q=23.0 for DIII-D example. - inQ_e=0.0 ! Q_e=2.0 for DIII-D example. - inQ_i=0.0 ! Q_i=-2.6 for DIII-D example. - inc_beta=0.0 ! c_beta=0.7 for DIII-D example. - inds=0.0 ! 6.0 for DIII-D example. - intau=0.0 ! 1.0 for DIII-D example. - !inlu=1e8 - Q0=0.0 -c----------------------------------------------------------------------- -c Calculate parameters as needed -c----------------------------------------------------------------------- - params_check=.TRUE. - CALL params(n_e,t_e,t_i,omega, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - inQ=REAL(Q) - inQ_e=Q_e - inQ_i=Q_i - inc_beta=c_beta - inds=ds - intau=tau - Q0=Q - - ! JKP used this for multiple surface loop but not for single surface? - ! IF (Q0>inQ_e) THEN - ! inQ_max=2.0*Q0 - ! inQ_min=1.05*inQ_e - ! ELSE - ! inQ_max=0.95*inQ_e - ! IF (Q0>0) THEN - ! inQ_min=0.8*inQ_i - ! ELSE - ! inQ_min=1.5*MINVAL((/Q0,inQ_i/)) - ! ENDIF - ! ENDIF - !ENDDO - - !riccati_out=.FALSE. ? -c----------------------------------------------------------------------- c Build exponential grid packing for stability scan, then run c----------------------------------------------------------------------- ! Allocate grid packing arrays and 2D complex deltas array @@ -420,9 +404,9 @@ SUBROUTINE gamma_stability_scan(n_e,t_e,t_i,omega,inpr,inpe, inQ_min=-3.0 ! min growth rate in scan, OPEN TO USER? ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? - inQs_left = powspace(inQ-0.2,inQ,1, ! omega-0.2 + inQs_left = powspace(REAL(inQ)-0.2,REAL(inQ),1, ! omega-0.2 $ 2+ReQ_num/2,"upper") - inQs_right = powspace(inQ,inQ+0.2,1, ! omega+0.2 + inQs_right = powspace(REAL(inQ),REAL(inQ)+0.2,1, ! omega+0.2 $ 2+ReQ_num/2,"lower") inQs_log = (/inQs_left(1,1:2+ReQ_num/2), $ inQs_right(1,2:1+ReQ_num/2)/) @@ -466,25 +450,24 @@ END SUBROUTINE gamma_stability_scan c Subprogram 5. gamma_match c Loop stability scans and gamma matches across k rational surfaces c----------------------------------------------------------------------- - SUBROUTINE gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, - $ l_ns,l_ts,qvals,svals,bts,rss,R0s,mu_is, - $ zeffs,outer_deltas,ReQ_num,ImQ_num, - $ growthrates,growthrate_err) + SUBROUTINE gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, + $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, + $ inpr_arr,inpe_arr,outer_delta_arr,omegas_arr, + $ ReQ_num,ImQ_num,growthrates,growthrate_err) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - INTEGER, INTENT(IN) :: n_k ! Number of rational surfaces - INTEGER, DIMENSION(:), INTENT(IN) :: mms,nns - REAL(r8), DIMENSION(:), INTENT(IN) :: n_es,t_es, - $ t_is,omegas,prs,pes,l_ns,l_ts,qvals, - $ svals,bts,rss,R0s,mu_is,zeffs - COMPLEX(r8), DIMENSION(:), INTENT(IN) :: outer_deltas + REAL(r8), DIMENSION(:), INTENT(IN) :: qvals,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, + $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr + COMPLEX(r8), DIMENSION(:), INTENT(IN) :: inQ_arr,outer_delta_arr INTEGER, INTENT(IN) :: ReQ_num,ImQ_num ! Outputs REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ growthrates, growthrate_err ! Local variables + INTEGER :: n_k ! Number of rational surfaces INTEGER :: k,w ! Local variables received from internal subroutines REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log,iinQs @@ -492,8 +475,9 @@ SUBROUTINE gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, REAL(r8), DIMENSION(:), ALLOCATABLE :: slice REAL(r8), DIMENSION(3) :: Q_range ! (-Q_err, Q, +Q_err ) REAL(r8), DIMENSION(3) :: growthrate_range ! (-gamma, +gamma ) - REAL(r8) :: layer_Q, inQ, ImQ_gamma + REAL(r8) :: layer_Q, ImQ_gamma + n_k = SIZE(qvals) ! Allocate growthrates arrays ALLOCATE(growthrates(n_k)) ALLOCATE(growthrate_err(n_k)) @@ -504,37 +488,38 @@ SUBROUTINE gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, ! for analysis, then slice out 1D array of growth rates at ! given omega_ExB (Q), then find growth rate corresponding ! to delta-deltaprime match - DO k=1,n_k + DO k=1,n_k-1 WRITE(*,*)"layer #: ",k ! Run stability scan - CALL gamma_stability_scan(n_es(k),t_es(k),t_is(k),omegas(k), - $ prs(k),pes(k),l_ns(k),l_ts(k),qvals(k),svals(k), - $ bts(k),rss(k),R0s(k),mu_is(k),zeffs(k), - $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs,inQ) + CALL gamma_stability_scan(qvals(k),inQ_arr(k),inQ_e_arr(k), + $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), + $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), + $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs) - layer_Q = inQ + layer_Q = REAL(inQ_arr(k)) ! Hardcoding rudimentary +/- 10% omega_ExB errorbars Q_range = (/0.9*layer_Q, 1.1*layer_Q, layer_Q/) ! Calculate growth rate +/- omega_ExB = Q errorbars DO w=1,3 - - ! Slice out growth rates at layer_Q (Re(Q)) - CALL interpolate_slice_at_Q(REAL(deltas), - $ Q_range(w), inQs_log, slice) - - ! Match delta to delta prime to obtain growth rate - CALL gamma_from_delta_match(slice, iinQs, - $ REAL(outer_deltas(k)), - $ ImQ_gamma) - IF (w==3) THEN + + ! Slice out growth rates at layer_Q (Re(Q)) + CALL interpolate_slice_at_Q(REAL(deltas), + $ Q_range(w), inQs_log, slice) + ! Match delta to delta prime to obtain growth rate + CALL gamma_from_delta_match(slice, iinQs, + $ REAL(outer_delta_arr(k)), + $ ImQ_gamma) + CALL gamma_from_delta_match(slice, iinQs, + $ REAL(outer_delta_arr(k)), + $ ImQ_gamma) ! Qconv = Q / omega_ExB ! gamma = Im(Q) / Qconv - growthrates(k) = ImQ_gamma / (layer_Q / omegas(k)) - ELSE - growthrate_range(w) = ImQ_gamma / (layer_Q / omegas(k)) + growthrates(k) = ImQ_gamma / (layer_Q / omegas_arr(k)) + !ELSE + ! growthrate_range(w) = ImQ_gamma / (layer_Q / omegas(k)) ENDIF ENDDO diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f new file mode 100644 index 000000000..1642104ea --- /dev/null +++ b/slayer/layerinputs.f @@ -0,0 +1,236 @@ + MODULE layerinputs_mod + + USE inputs, ONLY : kin + USE pentrc_interface, ONLY : zi,mi,wefac,wpfac,initialize_pentrc + USE read_eq_mode, ONLY : read_eq_efit + USE direct_mod, ONLY : direct_run + !resm = mfac(resnum(ising)) + !CALL spline_eval(kin,respsi,1) + + ! STILL NEED ro AND bt0, GLOBAL GPEC VARIABLES + + IMPLICIT NONE + + CONTAINS +c----------------------------------------------------------------------- +c subprogram 1. build_inputs. +c compute +c----------------------------------------------------------------------- + SUBROUTINE build_inputs(egnum,xspmn,spot,nspot, + $ growthrate_flag, + $ slayer_inpr) +c----------------------------------------------------------------------- +c declarations. +c----------------------------------------------------------------------- + LOGICAL, INTENT(IN) :: growthrate_flag + INTEGER, INTENT(IN) :: egnum,nspot + REAL(r8), INTENT(IN) :: spot, slayer_inpr + + !INTEGER :: i_id,q_id,m_id,p_id,c_id,w_id,k_id,n_id,d_id,a_id, + !$ pp_id,cp_id,wp_id,np_id,dp_id,wc_id,bc_id, + !$ astat + + REAL(r8) :: respsi,lpsi,rpsi,shear,hdist,sbnosurf + + INTEGER, DIMENSION(msing) :: resnum + + TYPE(spline_type) :: spl + + INTEGER :: resm + TYPE(spline_type) :: sr + + REAL(r8), DIMENSION(msing) :: inQ_arr,inQ_e_arr,inQ_i_arr, + $ inc_beta_arr,inds_arr,intau_arr,Q0_arr, + $ outer_delta_arr + +c----------------------------------------------------------------------- +c Find # of rational surfaces msing. +c----------------------------------------------------------------------- + CHARACTER(*) :: vmat_filename + INTEGER :: ising + + OPEN(UNIT=debug_unit,FILE=TRIM(vmat_filename),STATUS="OLD", + $ FORM="UNFORMATTED") + READ(debug_unit)mpert,msing + +c----------------------------------------------------------------------- +c Read and build equilibrium inputs +c----------------------------------------------------------------------- + CALL fourfit_action_matrix + ! call the automatic reading and distributing of inputs + CALL initialize_pentrc(op_kin=.FALSE.,op_deq=.FALSE., + $ op_peq=.FALSE.) + ! manually set the pentrc equilibrium description + CALL set_eq(eqfun,sq,rzphi,smats,tmats,xmats,ymats,zmats, + $ twopi*psio,ro,nn,jac_type,mlow,mhigh,mpert,mthvac) + ! manually set the kinetic profiles + CALL read_kin(kinetic_file,zi,zimp,mi,mimp,nfac, + $ tfac,wefac,wpfac,indebug) + ! manually set the perturbed equilibrium displacements + ! use false flat xi and xi' for equal weighting + ALLOCATE(psitmp(sq%mx+1),mtmp(mpert),xtmp(sq%mx+1,mpert)) + psitmp(:) = sq%xs(0:) + mtmp = (/(m,m=mlow,mhigh)/) + xtmp = 1e-4 + CALL set_peq(psitmp,mtmp,xtmp,xtmp,xtmp,.false.,tdebug) + DEALLOCATE(xtmp,mtmp,psitmp) + IF(verbose) WRITE(*,*)"Computing Kinetic Matrices" + CALL fourfit_kinetic_matrix(kingridtype,out_fund) + + CALL sing_scan + DO ising=1,msing + CALL resist_eval(sing(ising)) + ENDDO + + CALL ksing_find + + + CALL gpeq_alloc + CALL idcon_build(egnum,xspmn) + + CALL gpeq_interp_singsurf(fsp_sol,spot,nspot) + + IF (vsbrzphi_flag) ALLOCATE(singbno_mn(mpert,msing)) + + ! minor radius defined using toroidal flux. Used for threshold + CALL spline_int(sq) + qintb = sq%fsi(mpsi, 4) + psitor(:) = sq%fsi(:, 4) / qintb ! normalized toroidal flux + rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen + CALL spline_alloc(sr,mpsi,1) + sr%xs = sq%xs + sr%fs(:, 1) = rhotor(:) + CALL spline_fit(sr,"extrap") + +c----------------------------------------------------------------------- +c HERE I NEED TO READ IN STRIDE NETCDF ?? +c----------------------------------------------------------------------- + IF growthrate_flag THEN + outer_delta_arr = 0.0 + ! TBD + END IF +c----------------------------------------------------------------------- +c loop across singular surfaces, evaluate spline quantities. +c----------------------------------------------------------------------- + ! j_c is j_c/(chi1*sq%f(4)) + DO ising=1,msing + resnum(ising)=NINT(singtype(ising)%q*nn)-mlow+1 + respsi=singtype(ising)%psifac + CALL spline_eval(sq,respsi,1) + +c----------------------------------------------------------------------- +c prepare layer analysis. +c----------------------------------------------------------------------- + resm = mfac(resnum(ising)) + CALL spline_eval(sr,respsi,1) + CALL spline_eval(kin,respsi,1) +c----------------------------------------------------------------------- +c SLAYER inputs for sing surface +c----------------------------------------------------------------------- + omega_i=-twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) + $ -twopi*kin%f1(3)/(e*zi*chi1) + omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) + $ +twopi*kin%f1(4)/(e*chi1) + + ! Here's where I'm getting these from + !CALL gpec_slayer(kin%f(2),kin%f(4)/e,kin%f(1),kin%f(3)/e, + !$ kin%f(5),kin%f(9),omega_e,omega_i,sq%f(4),sq%f1(4), + !$ bt0,sr%f1(1),ro,mi,slayer_inpr,resm,nn,ascii_flag, + !$ delta_s,psi0,jxb,omega_sol,br_th) + + n_e = kin%f(2) + t_e = kin%f(4)/e + n_i = kin%f(1) + t_i = kin%f(3)/e + zeff = kin%f(5) + omega = kin%f(9) + qval = sq%f(4) + sval = sq%f1(4) + bt = bt0 + rs = sr%f1(1) + R0 = ro + mu_i = mi + inpr = slayer_inpr + mms = resm + nns = nn + + mrs = real(mms,4) + nrs = real(nns,4) + + ! String representations of the m and n mode numbers + !IF (nns<10) THEN + ! WRITE(UNIT=sn,FMT='(I1)') nns + ! sn=ADJUSTL(sn) + !ELSE + ! WRITE(UNIT=sn,FMT='(I2)') nns + !ENDIF + !IF (mms<10) THEN + ! WRITE(UNIT=sm,FMT='(I1)') mms + ! sm=ADJUSTL(sm) + !ELSEIF (mms<100) THEN + ! WRITE(UNIT=sm,FMT='(I2)') mms + ! sm=ADJUSTL(sm) + !ELSE + ! WRITE(UNIT=sm,FMT='(I3)') mms + !ENDIF + + inpe=0.0 ! Waybright added this + + tau= t_i/t_e ! ratio of ion to electron temperature + tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. + eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + rho=(mu_i*m_p)*n_e ! mass density + + b_l=(nrs/mrs)*nrs*sval*bt/R0 ! characteristic magnetic field + v_a=b_l/(mu0*rho)**0.5 ! alfven velocity + rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. + + tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! alfven time across surface + tau_r=mu0*rs**2.0/eta ! resistive time scale + tau_v=tau_r/inpr ! rho*rs**2.0/visc ! viscous time scale + + ! this one must be anomalous. calculated back from pr. + visc= rho*rs**2.0/tau_v + + lu=tau_r/tau_h ! Lundquist number + + Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole + + ! note Q depends on Qconv even if omega is fixed. + Q=Qconv*omega + Q_e=-Qconv*omega_e + Q_i=-Qconv*omega_i + + ! This is the most critical parameter + ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. + + lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 + c_beta=(lbeta/(1.0+lbeta))**0.5 + + delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes + + qvals(ising) = qval + inQ_arr(ising)=Q + inQ_e_arr(ising)=Q_e + inQ_i_arr(ising)=Q_i + inc_beta_arr(ising)=c_beta + inds_arr(ising)=ds + intau_arr(ising)=tau + Q0_arr(ising)=Q + inpr_arr(ising) = inpr + inpe_arr(ising) = 0.0 !!! TEMPORARY? + omegas_arr(ising) = omega + outer_delta_arr(ising) = outer_layer_delta + + ENDDO + CALL spline_dealloc(sr) + CALL cspline_dealloc(fsp_sol) + CALL gpeq_dealloc +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- + IF(timeit) CALL gpec_timer(2) + RETURN + END SUBROUTINE build_inputs + + END MODULE layerinputs_mod \ No newline at end of file diff --git a/slayer/makefile b/slayer/makefile index 50e86ba91..aace6bf9f 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -18,6 +18,7 @@ LIBS = \ OBJS = \ sglobal.o \ params.o \ + layerinputs.o \ delta.o \ gslayer.o \ slayer.o @@ -44,7 +45,7 @@ slayer: $(OBJS) params.o : sglobal.o delta.o : sglobal.o -gslayer.o : sglobal.o delta.o +gslayer.o : sglobal.o layerinputs.o delta.o slayer.o : sglobal.o params.o delta.o ../pentrc/grid.mod ../equil/spline_mod.mod clean: diff --git a/slayer/slayer.f b/slayer/slayer.f index 315b963de..1f5e7d42b 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -45,9 +45,13 @@ PROGRAM slayer INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,qvals,svals, + $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes, $ inQs_log + REAL(r8), DIMENSION(:), ALLOCATABLE:: qvals,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, + $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: inQ_arr,outer_delta_arr REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, $ inQs_left,inQs_right @@ -104,8 +108,8 @@ PROGRAM slayer inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=200 ! resolution for stab. scan along Re(Q) axis - ImQ_num=100 ! resolution for stab. scan along Im(Q) axis + ReQ_num=100 ! resolution for stab. scan along Re(Q) axis + ImQ_num=200 ! resolution for stab. scan along Im(Q) axis in_unit=1 out_unit=2 out2_unit=3 @@ -273,29 +277,43 @@ PROGRAM slayer ! Approximate data for q=2 and q=3, for testing only ! These are of the form needed to output from ! upcoming build_inputs.f script, interfacing with equil.f - mms = (/2, 2 /) - nns = (/1, 1 /) - prs = (/0.1, 0.005 /) - pes = (/0.0, 0.0 /) - n_es = (/7.765e+17, 9.999e+16 /) - t_es = (/26.0, 2.0 /) - t_is = (/26.0, 2.0 /) - omegas = (/54530.0, 54530.0 /) - l_ns = (/0.2, 0.2 /) - l_ts = (/0.1, 0.1 /) + ! Kinetic inputs (old) + !mms = (/2, 2 /) + !nns = (/1, 1 /) + !prs = (/0.1, 0.005 /) + !pes = (/0.0, 0.0 /) + !n_es = (/7.765e+17, 9.999e+16 /) + !t_es = (/26.0, 2.0 /) + !t_is = (/26.0, 2.0 /) + !l_ns = (/0.2, 0.2 /) + !l_ts = (/0.1, 0.1 /) + !svals = (/729.5, 500.5 /) + !bts = (/1.0, 1.0 /) + !rss = (/0.16, 0.2 /) + !R0s = (/2.0, 2.0 /) + !mu_is = (/2.0, 2.0 /) + !zeffs = (/2.0, 2.0 /) qvals = (/2.0, 3.0 /) - svals = (/729.5, 500.5 /) - bts = (/1.0, 1.0 /) - rss = (/0.16, 0.2 /) - R0s = (/2.0, 2.0 /) - mu_is = (/2.0, 2.0 /) - zeffs = (/2.0, 2.0 /) - outer_deltas = (/(27.15,0.1), (20.15,0.1) /) - - CALL gamma_match(n_k,mms,nns,n_es,t_es,t_is,omegas,prs,pes, - $ l_ns,l_ts,qvals,svals,bts,rss,R0s,mu_is, - $ zeffs,outer_deltas, - $ ReQ_num,ImQ_num,growthrates,growthrate_err) + inQ_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) + inQ_e_arr = (/ 1.9127E-005, 4.6109E-007 /) + inQ_i_arr = (/ -1.9127E-005, -4.6109E-007 /) + inc_beta_arr= (/ 3.6809E-003, 3.6635E-004 /) + inds_arr = (/ 1.4394, 0.1276 /) + intau_arr = (/ 1.0, 1.0 /) + inQ0_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) + !eta_s = (/ 6.6907E-006, 3.1361E-004 /) + !S_s = (/ 30696266.0, 1956419.0 /) + inpr_arr = (/0.1, 0.005 /) + inpe_arr = (/0.0, 0.0 /) + omegas_arr = (/54530.0, 54530.0 /) + outer_delta_arr = (/(27.15,0.1), (20.15,0.1) /) + + CALL gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, + $ inc_beta_arr,inds_arr,intau_arr, + $ inQ0_arr,inpr_arr,inpe_arr, + $ outer_delta_arr,omegas_arr, + $ ReQ_num,ImQ_num,growthrates,growthrate_err) + WRITE(*,*)"growthrates=",growthrates WRITE(*,*)"growthrate error=",growthrate_err From 1d808011725a18b2bcc3d5dcc13198b960c9519c Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 27 Jun 2024 11:50:55 -0700 Subject: [PATCH 005/118] WIP: runs, but netcdf errors --- slayer/gslayer.f | 27 ++-- slayer/layerinputs.f | 327 +++++++++++++++++++++++++++++------------ slayer/makefile | 13 +- slayer/slayer.f | 96 +++++++----- stride/stride_netcdf.f | 13 +- 5 files changed, 329 insertions(+), 147 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 2182c57c6..d488a333d 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -372,7 +372,7 @@ SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, ! Inputs REAL(r8),INTENT(IN) :: qval,inQ_e,inQ_i,inc_beta,inds, $ intau,inQ0,inpr,inpe - COMPLEX(r8), INTENT(IN) :: inQ + REAL(r8), INTENT(IN) :: inQ ! REAL??? INTEGER, INTENT(IN) :: ReQ_num,ImQ_num ! Outputs @@ -404,9 +404,9 @@ SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, inQ_min=-3.0 ! min growth rate in scan, OPEN TO USER? ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? - inQs_left = powspace(REAL(inQ)-0.2,REAL(inQ),1, ! omega-0.2 + inQs_left = powspace(inQ-0.2,inQ,1, ! omega-0.2 $ 2+ReQ_num/2,"upper") - inQs_right = powspace(REAL(inQ),REAL(inQ)+0.2,1, ! omega+0.2 + inQs_right = powspace(inQ,inQ+0.2,1, ! omega+0.2 $ 2+ReQ_num/2,"lower") inQs_log = (/inQs_left(1,1:2+ReQ_num/2), $ inQs_right(1,2:1+ReQ_num/2)/) @@ -450,18 +450,19 @@ END SUBROUTINE gamma_stability_scan c Subprogram 5. gamma_match c Loop stability scans and gamma matches across k rational surfaces c----------------------------------------------------------------------- - SUBROUTINE gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, + SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, - $ inpr_arr,inpe_arr,outer_delta_arr,omegas_arr, + $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr, $ ReQ_num,ImQ_num,growthrates,growthrate_err) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - REAL(r8), DIMENSION(:), INTENT(IN) :: qvals,inQ_e_arr, + REAL(r8), DIMENSION(:), INTENT(IN) :: qval_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, - $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr - COMPLEX(r8), DIMENSION(:), INTENT(IN) :: inQ_arr,outer_delta_arr + $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, + $ inQ_arr + REAL(r8), DIMENSION(:), INTENT(IN) :: outer_delta_arr INTEGER, INTENT(IN) :: ReQ_num,ImQ_num ! Outputs REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: @@ -477,7 +478,7 @@ SUBROUTINE gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, REAL(r8), DIMENSION(3) :: growthrate_range ! (-gamma, +gamma ) REAL(r8) :: layer_Q, ImQ_gamma - n_k = SIZE(qvals) + n_k = SIZE(qval_arr) ! Allocate growthrates arrays ALLOCATE(growthrates(n_k)) ALLOCATE(growthrate_err(n_k)) @@ -491,12 +492,12 @@ SUBROUTINE gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, DO k=1,n_k-1 WRITE(*,*)"layer #: ",k ! Run stability scan - CALL gamma_stability_scan(qvals(k),inQ_arr(k),inQ_e_arr(k), + CALL gamma_stability_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs) - layer_Q = REAL(inQ_arr(k)) + layer_Q = inQ_arr(k) ! REAL??? ! Hardcoding rudimentary +/- 10% omega_ExB errorbars Q_range = (/0.9*layer_Q, 1.1*layer_Q, layer_Q/) @@ -510,10 +511,10 @@ SUBROUTINE gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, $ Q_range(w), inQs_log, slice) ! Match delta to delta prime to obtain growth rate CALL gamma_from_delta_match(slice, iinQs, - $ REAL(outer_delta_arr(k)), + $ outer_delta_arr(k), $ ImQ_gamma) CALL gamma_from_delta_match(slice, iinQs, - $ REAL(outer_delta_arr(k)), + $ outer_delta_arr(k), $ ImQ_gamma) ! Qconv = Q / omega_ExB ! gamma = Im(Q) / Qconv diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 1642104ea..6a9fac93f 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -1,11 +1,16 @@ MODULE layerinputs_mod - USE inputs, ONLY : kin - USE pentrc_interface, ONLY : zi,mi,wefac,wpfac,initialize_pentrc - USE read_eq_mode, ONLY : read_eq_efit - USE direct_mod, ONLY : direct_run - !resm = mfac(resnum(ising)) - !CALL spline_eval(kin,respsi,1) + USE inputs, ONLY : read_kin,kin,chi1 + !USE params + !USE dcon_interface_mod, ONLY : respsi + !USE direct_mod, ONLY : direct_run + USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, + $ spline_dealloc + USE sglobal_mod, ONLY: m_p, chag, lnLamb, + $ Q_e,Q_i,pr,pe,c_beta,ds,tau,mu0,r8, ! NOT out_unit + $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q + USE netcdf + ! STILL NEED ro AND bt0, GLOBAL GPEC VARIABLES @@ -13,115 +18,244 @@ MODULE layerinputs_mod CONTAINS c----------------------------------------------------------------------- +c subprogram 1. check. +c Check status of netcdf file. +c----------------------------------------------------------------------- + SUBROUTINE check(stat) +c----------------------------------------------------------------------- +c declaration. +c----------------------------------------------------------------------- + INTEGER, INTENT (IN) :: stat +c----------------------------------------------------------------------- +c stop if it is an error. +c----------------------------------------------------------------------- + IF(stat /= nf90_noerr) THEN + PRINT *, TRIM(nf90_strerror(stat)) + !STOP "ERROR: failed to write/read netcdf file" + ENDIF +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- + RETURN + END SUBROUTINE check +c----------------------------------------------------------------------- +c Read and build equilibrium inputs +c----------------------------------------------------------------------- + SUBROUTINE read_stride_netcdf_diagonal(ncfile, r_dim, + $ dp_diagonal, q_rational, psi_n_rational, shear, + $ r0, bt0) + + !USE netcdf ! NetCDF module for Fortran + !USE stride_netcdf_mod ! For the 'check' subroutine (error handling) + + ! Input/Output Arguments + CHARACTER(128), INTENT(IN) :: ncfile + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal + REAL(r8), DIMENSION(:), INTENT(OUT) :: q_rational, + $ psi_n_rational, shear + REAL(r8), INTENT(OUT) :: r0, bt0 + + ! Internal Variables + INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, + $ dp_id, qr_id, pr_id, shear_id, r0_id, bt0_id ! Explicit kind for NetCDF variables + INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime + INTEGER :: i + + ! Open the NetCDF file + stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) + WRITE(*,*)"ncfile=",ncfile + CALL check(stat) ! Error handling + + ! Get Dimension Information + stat = nf90_inq_varid(ncid, "r", r_dim_id) + CALL check(stat) + stat = nf90_get_var(ncid, r_dim_id, r_dim) ! Use len= for dimension + CALL check(stat) + + ! Allocate Arrays (based on dimension) + ALLOCATE(dp_diagonal(r_dim)) + !ALLOCATE(delta_prime(r_dim, r_dim)) + + ! Get Variable IDs + stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "q_rational", qr_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "shear", shear_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "bt0", bt0_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "r0", r0_id) + CALL check(stat) + + ! Read Data from NetCDF File + ! Set up start and count for reading only the diagonal + start(1) = 1 + count(1) = 1 + + ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. + stat = nf90_get_var(ncid, dp_id, delta_prime) + CALL check(stat) + ! Read 1D variables + stat = nf90_get_var(ncid, qr_id, q_rational) + CALL check(stat) + stat = nf90_get_var(ncid, pr_id, psi_n_rational) + CALL check(stat) + stat = nf90_get_var(ncid, shear_id, shear) + CALL check(stat) + stat = nf90_get_var(ncid, bt0_id, bt0) + CALL check(stat) + stat = nf90_get_var(ncid, r0_id, r0) + CALL check(stat) + + ! Extract Diagonal, with 3rd index signifying REAL part + DO i = 1, r_dim + dp_diagonal(i) = REAL(delta_prime(i, i, 1)) + END DO + + ! Clean Up + DEALLOCATE(delta_prime) + stat = nf90_close(ncid) + CALL check(stat) + + END SUBROUTINE read_stride_netcdf_diagonal +c----------------------------------------------------------------------- c subprogram 1. build_inputs. c compute c----------------------------------------------------------------------- - SUBROUTINE build_inputs(egnum,xspmn,spot,nspot, - $ growthrate_flag, - $ slayer_inpr) + SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, + $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, + $ inds_arr,intau_arr,Q0_arr,inpr_arr,inpe_arr, + $ omegas_arr,outer_delta_arr) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- + CHARACTER(128), INTENT(IN) :: ncfile LOGICAL, INTENT(IN) :: growthrate_flag - INTEGER, INTENT(IN) :: egnum,nspot - REAL(r8), INTENT(IN) :: spot, slayer_inpr + REAL(r8), INTENT(IN) ::slayer_inpr - !INTEGER :: i_id,q_id,m_id,p_id,c_id,w_id,k_id,n_id,d_id,a_id, - !$ pp_id,cp_id,wp_id,np_id,dp_id,wc_id,bc_id, - !$ astat + REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf, + $ ising - REAL(r8) :: respsi,lpsi,rpsi,shear,hdist,sbnosurf - - INTEGER, DIMENSION(msing) :: resnum + INTEGER :: zi, zimp, mi, mimp, msing + REAL(r8) :: nfac,tfac,wefac,wpfac,e,twopi TYPE(spline_type) :: spl - INTEGER :: resm TYPE(spline_type) :: sr - REAL(r8), DIMENSION(msing) :: inQ_arr,inQ_e_arr,inQ_i_arr, - $ inc_beta_arr,inds_arr,intau_arr,Q0_arr, - $ outer_delta_arr + INTEGER :: mms,nns,mrs,nrs -c----------------------------------------------------------------------- -c Find # of rational surfaces msing. -c----------------------------------------------------------------------- - CHARACTER(*) :: vmat_filename - INTEGER :: ising + REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, + $ qval,sval,bt,rs,zeff,inpe,r0,bt0 + REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, + $ rho,tau_v,inpr,Qconv,lbeta + + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr, + $ inQ_arr,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, + $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr - OPEN(UNIT=debug_unit,FILE=TRIM(vmat_filename),STATUS="OLD", - $ FORM="UNFORMATTED") - READ(debug_unit)mpert,msing + REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, + $ psi_n_rational, shear + INTEGER :: r_dim c----------------------------------------------------------------------- +c Read in STRIDE netcdf +c----------------------------------------------------------------------- + character(512) :: + $ kinetic_file = '/fusion/projects/codes/gpec/GPEC-1.5/ + $ docs/examples/a10_ideal_example/a10_prof1.txt' + !REAL(r8), DIMENSION(:), ALLOCATABLE :: q_rational, q_rational_coords + !REAL(r8), DIMENSION(:), ALLOCATABLE :: Delta_prime, Delta_prime_coords + WRITE(*,*)"ncfile=",ncfile + CALL read_stride_netcdf_diagonal(ncfile, + $ r_dim, dp_diagonal, q_rational, psi_n_rational, + $ shear, r0, bt0) + + !CALL READ_Q_RATIONAL_AND_DELTA_PRIME_FROM_NETCDF( + !& filename, q_rational, q_rational_coords, + !& Delta_prime, Delta_prime_coords) + + msing = r_dim + + ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), + $ inQ_i_arr(msing), + $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), + $ Q0_arr(msing),outer_delta_arr(msing)) + !DEALLOCATE(q_rational, q_rational_coords, Delta_prime, Delta_prime_coords) +c----------------------------------------------------------------------- c Read and build equilibrium inputs c----------------------------------------------------------------------- - CALL fourfit_action_matrix - ! call the automatic reading and distributing of inputs - CALL initialize_pentrc(op_kin=.FALSE.,op_deq=.FALSE., - $ op_peq=.FALSE.) - ! manually set the pentrc equilibrium description - CALL set_eq(eqfun,sq,rzphi,smats,tmats,xmats,ymats,zmats, - $ twopi*psio,ro,nn,jac_type,mlow,mhigh,mpert,mthvac) - ! manually set the kinetic profiles - CALL read_kin(kinetic_file,zi,zimp,mi,mimp,nfac, - $ tfac,wefac,wpfac,indebug) - ! manually set the perturbed equilibrium displacements - ! use false flat xi and xi' for equal weighting - ALLOCATE(psitmp(sq%mx+1),mtmp(mpert),xtmp(sq%mx+1,mpert)) - psitmp(:) = sq%xs(0:) - mtmp = (/(m,m=mlow,mhigh)/) - xtmp = 1e-4 - CALL set_peq(psitmp,mtmp,xtmp,xtmp,xtmp,.false.,tdebug) - DEALLOCATE(xtmp,mtmp,psitmp) - IF(verbose) WRITE(*,*)"Computing Kinetic Matrices" - CALL fourfit_kinetic_matrix(kingridtype,out_fund) - - CALL sing_scan - DO ising=1,msing - CALL resist_eval(sing(ising)) - ENDDO - - CALL ksing_find - - - CALL gpeq_alloc - CALL idcon_build(egnum,xspmn) - - CALL gpeq_interp_singsurf(fsp_sol,spot,nspot) - - IF (vsbrzphi_flag) ALLOCATE(singbno_mn(mpert,msing)) - - ! minor radius defined using toroidal flux. Used for threshold - CALL spline_int(sq) - qintb = sq%fsi(mpsi, 4) - psitor(:) = sq%fsi(:, 4) / qintb ! normalized toroidal flux - rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen - CALL spline_alloc(sr,mpsi,1) - sr%xs = sq%xs - sr%fs(:, 1) = rhotor(:) - CALL spline_fit(sr,"extrap") + !======================================================================= + !subroutine read_kin(file,zi,zimp,mi,mimp,nfac,tfac,wefac,wpfac,write_log) + !----------------------------------------------------------------------- + !*DESCRIPTION: + ! Read ascii file containing table of kinetic profiles ni, ne, ti, + ! te, and omegaE, then form kin spline containing some additional + ! information (krook nui,nue). + ! + ! Assumes table consists of 6 columns: psi_n, n_i(m^-3), n_e(m^-3), + ! T_i(eV), T_e(eV), omega_E(rad/s). File can (nearly) arbitrary + ! header and/or footer, with the exception that no lines start with + ! a number. + ! + !*ARGUMENTS: + ! file : character(256) (in) + ! File path. + ! zi : integer + ! Ion charge in fundamental units + ! zimp : integer + ! Impurity ion charge in fundamental units + ! mi : integer + ! Ion mass in fundamental units (mass proton) + ! mimp : integer + ! Impurity ion mass in fundamental units + ! wefac : real + ! Direct multiplier for omegaE profiles + ! wpfac : real + ! Scaling of rotation profile, done via manipulation of omegaE + ! write_log : bool + ! Writes kinetic spline to log file + ! + !----------------------------------------------------------------------- c----------------------------------------------------------------------- -c HERE I NEED TO READ IN STRIDE NETCDF ?? +c set up kin c----------------------------------------------------------------------- - IF growthrate_flag THEN - outer_delta_arr = 0.0 - ! TBD - END IF + ! manually set the kinetic profiles + zi = 1 + zimp = 1 + mi = 1 + mimp = 1 + nfac = 1.0 + tfac = 1.0 + wefac = 1.0 + wpfac = 1.0 + e=1.6021917e-19 + twopi = 6.28318530718 + + CALL read_kin(kinetic_file,zi,zimp,mi,mimp,nfac, + $ tfac,wefac,wpfac,.false.) + ! manually set the perturbed equilibrium displacements + ! use false flat xi and xi' for equal weighting + c----------------------------------------------------------------------- c loop across singular surfaces, evaluate spline quantities. c----------------------------------------------------------------------- ! j_c is j_c/(chi1*sq%f(4)) DO ising=1,msing - resnum(ising)=NINT(singtype(ising)%q*nn)-mlow+1 - respsi=singtype(ising)%psifac - CALL spline_eval(sq,respsi,1) - + !resnum(ising)=NINT(singtype(ising)%q*nn)-mlow+1 + !respsi=singtype(ising)%psifac + !CALL spline_eval(sq,respsi,1) + respsi = psi_n_rational(ising) c----------------------------------------------------------------------- c prepare layer analysis. c----------------------------------------------------------------------- - resm = mfac(resnum(ising)) + !resm = mfac(resnum(ising)) CALL spline_eval(sr,respsi,1) CALL spline_eval(kin,respsi,1) c----------------------------------------------------------------------- @@ -144,18 +278,17 @@ SUBROUTINE build_inputs(egnum,xspmn,spot,nspot, t_i = kin%f(3)/e zeff = kin%f(5) omega = kin%f(9) - qval = sq%f(4) - sval = sq%f1(4) + qval = q_rational(ising)!sq%f(4) + sval = shear(ising) bt = bt0 rs = sr%f1(1) - R0 = ro + R0 = r0 mu_i = mi inpr = slayer_inpr - mms = resm - nns = nn - - mrs = real(mms,4) - nrs = real(nns,4) + !mms = resm + !nns = nn + mrs = 2.0 ! FROM NAMELIST ???? real(mms,4) + nrs = 1.0 ! FROM NAMELIST ???? real(nns,4) ! String representations of the m and n mode numbers !IF (nns<10) THEN @@ -209,7 +342,7 @@ SUBROUTINE build_inputs(egnum,xspmn,spot,nspot, delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes - qvals(ising) = qval + qval_arr(ising) = qval inQ_arr(ising)=Q inQ_e_arr(ising)=Q_e inQ_i_arr(ising)=Q_i @@ -220,16 +353,16 @@ SUBROUTINE build_inputs(egnum,xspmn,spot,nspot, inpr_arr(ising) = inpr inpe_arr(ising) = 0.0 !!! TEMPORARY? omegas_arr(ising) = omega - outer_delta_arr(ising) = outer_layer_delta + outer_delta_arr(ising) = dp_diagonal(ising) ENDDO CALL spline_dealloc(sr) - CALL cspline_dealloc(fsp_sol) - CALL gpeq_dealloc + !CALL cspline_dealloc(fsp_sol) + !CALL gpeq_dealloc c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- - IF(timeit) CALL gpec_timer(2) + RETURN END SUBROUTINE build_inputs diff --git a/slayer/makefile b/slayer/makefile index aace6bf9f..b4c676d97 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -1,7 +1,7 @@ include ../install/DEFAULTS.inc -IFLAGS = -I../equil -I../pentrc -I$(MATHINC) -I$(NETCDFINC) +IFLAGS = -I../equil -I../harvest -I../pentrc -I$(MATHINC) -I$(NETCDFINC) F90 = $(FC) $(FFLAGS) $(OMPFLAG) $(IFLAGS) export FFLAGS @@ -13,7 +13,8 @@ LIBDIR = ../lib LIBS = \ -llsode \ -lpentrc \ - -lequil + -lequil \ + -lharvest OBJS = \ sglobal.o \ @@ -23,7 +24,13 @@ OBJS = \ gslayer.o \ slayer.o -all: lsode equil pentrc slayer +all: equil harvest lsode pentrc slayer + +harvest: + cd ../; git submodule init; git submodule update + cd ../harvest; make FC=$(FC) CC=$(CC) GACODE_ROOT= -f Makefile libharvest.a + mkdir -p ../lib + cp -f ../harvest/libharvest.a ../lib/ equil: cd ../equil; make diff --git a/slayer/slayer.f b/slayer/slayer.f index 1f5e7d42b..5dccc3afe 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -19,10 +19,11 @@ PROGRAM slayer ! FOR TESTING: USE gslayer_mod + USE layerinputs_mod IMPLICIT NONE - CHARACTER(128) :: infile + CHARACTER(128) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num,n_k INTEGER, DIMENSION(1) :: index @@ -31,7 +32,7 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,gamma_match_flag !FOR TESTING + $ params_check,growthrates_flag !FOR TESTING REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff @@ -39,22 +40,27 @@ PROGRAM slayer REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th COMPLEX(r8) :: delta,delta_n_p - REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max,kpower, + REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, + $ kpower, $ Qratio INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals, + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl, + $ bal, + $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes, $ inQs_log - REAL(r8), DIMENSION(:), ALLOCATABLE:: qvals,inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, - $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: inQ_arr,outer_delta_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: qval_arr,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr, + $ intau_arr,inQ0_arr,inpr_arr, + $ inpe_arr,omegas_arr,inQ_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: + $ outer_delta_arr REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, $ inQs_left,inQs_right + REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas @@ -63,7 +69,7 @@ PROGRAM slayer $ growthrate_err NAMELIST/slayer_input/params_flag,input_flag,infile, - $ mm,nn,n_e,t_e,t_i,omega,l_n,l_t, + $ ncfile,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, $ inQ_i,inpr,inpe,inc_beta,inds,intau,inlu,Q0,delta_n_p NAMELIST/slayer_control/inum,jnum,knum,QPscan_flag,QPscan2_flag, @@ -71,9 +77,9 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag + $ stability_flag,growthrates_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, - $ params_check,bal_flag,gamma_match_flag + $ params_check,bal_flag c----------------------------------------------------------------------- c set initial values. c----------------------------------------------------------------------- @@ -131,6 +137,8 @@ PROGRAM slayer params_flag=.TRUE. input_flag=.FALSE. infile="input_params.dat" + ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ + $stride_output_n1.nc" verbose=.TRUE. ascii_flag=.TRUE. bin_flag=.TRUE. @@ -140,6 +148,7 @@ PROGRAM slayer params_check=.FALSE. bal_flag=.FALSE. stability_flag=.FALSE. + growthrates_flag=.FALSE. c----------------------------------------------------------------------- c read slayer.in. c----------------------------------------------------------------------- @@ -267,13 +276,13 @@ PROGRAM slayer c----------------------------------------------------------------------- c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- - IF (gamma_match_flag) THEN - n_k=2 - ALLOCATE(mms(n_k),nns(n_k),prs(n_k),pes(n_k), - $ n_es(n_k),t_es(n_k),t_is(n_k),omegas(n_k), - $ l_ns(n_k),l_ts(n_k),qvals(n_k),svals(n_k), - $ bts(n_k),rss(n_k),R0s(n_k),mu_is(n_k),zeffs(n_k), - $ outer_deltas(n_k)) + IF (growthrates_flag) THEN + !n_k=2 + ! ALLOCATE(mms(n_k),nns(n_k),prs(n_k),pes(n_k), + !$ n_es(n_k),t_es(n_k),t_is(n_k),omegas(n_k), + !$ l_ns(n_k),l_ts(n_k),qvals(n_k),svals(n_k), + !$ bts(n_k),rss(n_k),R0s(n_k),mu_is(n_k),zeffs(n_k), + !$ outer_deltas(n_k)) ! Approximate data for q=2 and q=3, for testing only ! These are of the form needed to output from ! upcoming build_inputs.f script, interfacing with equil.f @@ -293,25 +302,46 @@ PROGRAM slayer !R0s = (/2.0, 2.0 /) !mu_is = (/2.0, 2.0 /) !zeffs = (/2.0, 2.0 /) - qvals = (/2.0, 3.0 /) - inQ_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) - inQ_e_arr = (/ 1.9127E-005, 4.6109E-007 /) - inQ_i_arr = (/ -1.9127E-005, -4.6109E-007 /) - inc_beta_arr= (/ 3.6809E-003, 3.6635E-004 /) - inds_arr = (/ 1.4394, 0.1276 /) - intau_arr = (/ 1.0, 1.0 /) - inQ0_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) + + + !q_arr = (/2.0, 3.0 /) + !inQ_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) + !inQ_e_arr = (/ 1.9127E-005, 4.6109E-007 /) + !inQ_i_arr = (/ -1.9127E-005, -4.6109E-007 /) + !inc_beta_arr= (/ 3.6809E-003, 3.6635E-004 /) + !inds_arr = (/ 1.4394, 0.1276 /) + !intau_arr = (/ 1.0, 1.0 /) + !inQ0_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) !eta_s = (/ 6.6907E-006, 3.1361E-004 /) !S_s = (/ 30696266.0, 1956419.0 /) - inpr_arr = (/0.1, 0.005 /) - inpe_arr = (/0.0, 0.0 /) - omegas_arr = (/54530.0, 54530.0 /) - outer_delta_arr = (/(27.15,0.1), (20.15,0.1) /) + !inpr_arr = (/0.1, 0.005 /) + !inpe_arr = (/0.0, 0.0 /) + !omegas_arr = (/54530.0, 54530.0 /) + !outer_delta_arr = (/(27.15,0.1), (20.15,0.1) /) + + !CHARACTER(len=256) :: filename = "stride_output_n1.nc" + !REAL(r8), DIMENSION(:), ALLOCATABLE :: q_rational, q_rational_coords + !REAL(r8), DIMENSION(:), ALLOCATABLE :: Delta_prime, Delta_prime_coords + + + + ! WRITE(*,*)"growthrates=",q_rational + + !CALL read_stride_netcdf(filename, q_rational, q_rational_coords, + !$ Delta_prime, Delta_prime_coords) + CALL build_inputs(ncfile,inpr, + $ growthrates_flag,qval_arr, + $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, + $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, + $ omegas_arr,outer_delta_arr) + + WRITE(*,*)"outer_delta_arr=",outer_delta_arr + WRITE(*,*)"omegas_arr=",omegas_arr - CALL gamma_match(qvals,inQ_arr,inQ_e_arr,inQ_i_arr, + CALL gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr, $ inQ0_arr,inpr_arr,inpe_arr, - $ outer_delta_arr,omegas_arr, + $ omegas_arr,outer_delta_arr, $ ReQ_num,ImQ_num,growthrates,growthrate_err) WRITE(*,*)"growthrates=",growthrates diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 08199da29..4d3c26e9c 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -59,7 +59,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ f_id, q_id, dv_id, mu_id, di_id, dr_id, ca_id, $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, - $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id + $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, + $ bt0_id, r0_id, shear_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile @@ -162,8 +163,14 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid,"r_prime",nf90_int,rp_dim,rp_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ r_dim,pr_id) ) + CALL check( nf90_def_var(ncid,"bt0",nf90_double, + $ r_dim/r_dim,bt0_id) ) + CALL check( nf90_def_var(ncid,"r0",nf90_double, + $ r_dim/r_dim,r0_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) + CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, + $ shear_id) ) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" @@ -217,8 +224,12 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,pr_id, (/(sing(i)%psifac, $ i=1,msing)/)) ) + CALL check( nf90_put_var(ncid,bt0_id, (/ bt0 /)) ) + CALL check( nf90_put_var(ncid,r0_id, (/ ro /)) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) + CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, + $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? ENDIF IF(debug_flag) PRINT *," - Putting profile variables in netcdf" From c873bd6b35535e99fcf3db7f40f356a26bb924ba Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 4 Jul 2024 11:29:57 -0700 Subject: [PATCH 006/118] WIP: building growthrate outputs --- slayer/gslayer.f | 38 +++-- slayer/layerinputs.f | 312 +++++++++++++++++++++++++++++++++-------- slayer/makefile | 3 +- slayer/slayer.f | 27 +++- slayer/slayer_netcdf.f | 188 +++++++++++++++++++++++++ stride/stride_netcdf.f | 9 +- 6 files changed, 498 insertions(+), 79 deletions(-) create mode 100644 slayer/slayer_netcdf.f diff --git a/slayer/gslayer.f b/slayer/gslayer.f index d488a333d..1ed32a727 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -10,6 +10,10 @@ MODULE gslayer_mod USE params_mod + USE layerinputs_mod + + USE slayer_netcdf_mod + USE grid, ONLY : powspace,linspace IMPLICIT NONE @@ -186,6 +190,7 @@ SUBROUTINE interpolate_slice_at_Q(deltas, Q, inQs_log, INTEGER :: NROWS, NCOLS, i_lower, i_upper, j REAL(r8) :: Q_lower,Q_upper,lower_slice,upper_slice + slice = 0.0 ! Extract array dimensions NROWS = SIZE(deltas, 1) NCOLS = SIZE(deltas, 2) @@ -404,15 +409,15 @@ SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, inQ_min=-3.0 ! min growth rate in scan, OPEN TO USER? ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? - inQs_left = powspace(inQ-0.2,inQ,1, ! omega-0.2 + inQs_left = powspace(inQ-0.5,inQ,1, ! omega-0.5 $ 2+ReQ_num/2,"upper") - inQs_right = powspace(inQ,inQ+0.2,1, ! omega+0.2 + inQs_right = powspace(inQ,inQ+0.5,1, ! omega+0.5 $ 2+ReQ_num/2,"lower") inQs_log = (/inQs_left(1,1:2+ReQ_num/2), $ inQs_right(1,2:1+ReQ_num/2)/) !WRITE(*,*)"inQs_log=",inQs_log - DO i=0,ReQ_num+3 + DO i=0,ReQ_num+1 DO j=0,ImQ_num ! Getting rid of "inQs" weirdly broke things?? inQs(i)=inQ_min+(REAL(i)/ReQ_num)*(inQ_max-inQ_min) @@ -433,7 +438,7 @@ SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, $ TRIM(x1)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))'),"RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" - DO i=0,ReQ_num + DO i=0,ReQ_num+1 DO j=0,ImQ_num WRITE(out_unit,'(1x,4(es17.8e3))') $ inQs_log(i),iinQs(j), @@ -450,7 +455,8 @@ END SUBROUTINE gamma_stability_scan c Subprogram 5. gamma_match c Loop stability scans and gamma matches across k rational surfaces c----------------------------------------------------------------------- - SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + $ inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr, $ ReQ_num,ImQ_num,growthrates,growthrate_err) @@ -461,7 +467,7 @@ SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, REAL(r8), DIMENSION(:), INTENT(IN) :: qval_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, - $ inQ_arr + $ inQ_arr,psi_n_rational REAL(r8), DIMENSION(:), INTENT(IN) :: outer_delta_arr INTEGER, INTENT(IN) :: ReQ_num,ImQ_num ! Outputs @@ -473,6 +479,8 @@ SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, ! Local variables received from internal subroutines REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log,iinQs COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_slices REAL(r8), DIMENSION(:), ALLOCATABLE :: slice REAL(r8), DIMENSION(3) :: Q_range ! (-Q_err, Q, +Q_err ) REAL(r8), DIMENSION(3) :: growthrate_range ! (-gamma, +gamma ) @@ -482,6 +490,7 @@ SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, ! Allocate growthrates arrays ALLOCATE(growthrates(n_k)) ALLOCATE(growthrate_err(n_k)) + c----------------------------------------------------------------------- c Loop across rational surfaces c----------------------------------------------------------------------- @@ -489,7 +498,7 @@ SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, ! for analysis, then slice out 1D array of growth rates at ! given omega_ExB (Q), then find growth rate corresponding ! to delta-deltaprime match - DO k=1,n_k-1 + DO k=1,n_k WRITE(*,*)"layer #: ",k ! Run stability scan CALL gamma_stability_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), @@ -527,11 +536,24 @@ SUBROUTINE gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, growthrate_err(k) = ABS(growthrate_range(2) - $ growthrate_range(1)) + ALLOCATE(all_RE_deltas(SIZE(inQs_log),SIZE(iinQs),n_k)) + ALLOCATE(all_slices(SIZE(iinQs),n_k)) + + all_RE_deltas(:,:,k) = REAL(deltas) + all_slices(:,k) = slice + DEALLOCATE(slice) ! Free memory after use for each layer ENDDO - DEALLOCATE(deltas,inQs_log,iinQs) + CALL slayer_netcdf_out(n_k,SIZE(inQs_log),SIZE(iinQs),qval_arr, + $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr,psi_n_rational, + $ all_Re_deltas,all_slices) + + DEALLOCATE(deltas) + + WRITE(*,*)"inQs_log len ",SIZE(inQs_log) + WRITE(*,*)"iinQs len ",SIZE(iinQs) RETURN END SUBROUTINE gamma_match diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 6a9fac93f..b8b8825bb 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -1,16 +1,18 @@ MODULE layerinputs_mod - USE inputs, ONLY : read_kin,kin,chi1 + USE inputs, ONLY : read_kin,read_equil,kin,chi1 !USE params - !USE dcon_interface_mod, ONLY : respsi + USE dcon_interface, ONLY : set_geom,geom !USE direct_mod, ONLY : direct_run USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, - $ spline_dealloc + $ spline_dealloc,spline_int,spline_fit USE sglobal_mod, ONLY: m_p, chag, lnLamb, $ Q_e,Q_i,pr,pe,c_beta,ds,tau,mu0,r8, ! NOT out_unit $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q USE netcdf - + USE pentrc_interface, ONLY : pentrc_timer=>timer + !USE equil_mod + !USE equil_out_mod ! STILL NEED ro AND bt0, GLOBAL GPEC VARIABLES @@ -41,9 +43,9 @@ END SUBROUTINE check c----------------------------------------------------------------------- c Read and build equilibrium inputs c----------------------------------------------------------------------- - SUBROUTINE read_stride_netcdf_diagonal(ncfile, r_dim, + SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ dp_diagonal, q_rational, psi_n_rational, shear, - $ r0, bt0) + $ ro,bt0,psio,mpsi) !USE netcdf ! NetCDF module for Fortran !USE stride_netcdf_mod ! For the 'check' subroutine (error handling) @@ -51,53 +53,79 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, r_dim, ! Input/Output Arguments CHARACTER(128), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal - REAL(r8), DIMENSION(:), INTENT(OUT) :: q_rational, + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, $ psi_n_rational, shear - REAL(r8), INTENT(OUT) :: r0, bt0 + REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: ro,bt0,psio, + $ mpsi + INTEGER, INTENT(OUT) :: msing + + REAL(r8), DIMENSION(:), ALLOCATABLE :: msing_arr ! Internal Variables INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, - $ dp_id, qr_id, pr_id, shear_id, r0_id, bt0_id ! Explicit kind for NetCDF variables + $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, + $ msing_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i + INTEGER :: bt0_len,ro_len,psio_len,mpsi_len,msing_len ! Attribute lengths + ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) WRITE(*,*)"ncfile=",ncfile CALL check(stat) ! Error handling - ! Get Dimension Information - stat = nf90_inq_varid(ncid, "r", r_dim_id) + stat = nf90_inquire_attribute(ncid, msing_id, "msing", + $ len = msing_len) + ALLOCATE(msing_arr(msing_len)) + CALL check(stat) - stat = nf90_get_var(ncid, r_dim_id, r_dim) ! Use len= for dimension + stat = nf90_get_att(ncid, msing_id, "msing", msing_arr) CALL check(stat) + msing=INT(msing_arr(1)) + ! Allocate Arrays (based on dimension) - ALLOCATE(dp_diagonal(r_dim)) - !ALLOCATE(delta_prime(r_dim, r_dim)) + ALLOCATE(dp_diagonal(msing),q_rational(msing), + $ psi_n_rational(msing),shear(msing)) + ALLOCATE(delta_prime(msing, msing,2)) ! Get Variable IDs stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) CALL check(stat) + WRITE(*,*)"stat=",stat stat = nf90_inq_varid(ncid, "q_rational", qr_id) CALL check(stat) + WRITE(*,*)"stat=",stat stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) CALL check(stat) + WRITE(*,*)"stat=",stat + stat = nf90_inq_varid(ncid, "shear", shear_id) CALL check(stat) - stat = nf90_inq_varid(ncid, "bt0", bt0_id) + stat = nf90_inquire_attribute(ncid, bt0_id, "bt0", + $ len = bt0_len) + CALL check(stat) + stat = nf90_inquire_attribute(ncid, ro_id, "ro", + $ len = ro_len) CALL check(stat) - stat = nf90_inq_varid(ncid, "r0", r0_id) + stat = nf90_inquire_attribute(ncid, psio_id, "psio", + $ len = psio_len) CALL check(stat) + stat = nf90_inquire_attribute(ncid, mpsi_id, "mpsi", + $ len = mpsi_len) + CALL check(stat) + ALLOCATE(bt0(bt0_len),ro(ro_len),psio(psio_len), + $ mpsi(mpsi_len)) ! Read Data from NetCDF File ! Set up start and count for reading only the diagonal - start(1) = 1 - count(1) = 1 + !start(1) = 1 + !count(1) = 1 ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. - stat = nf90_get_var(ncid, dp_id, delta_prime) + stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) CALL check(stat) ! Read 1D variables stat = nf90_get_var(ncid, qr_id, q_rational) @@ -106,13 +134,17 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, r_dim, CALL check(stat) stat = nf90_get_var(ncid, shear_id, shear) CALL check(stat) - stat = nf90_get_var(ncid, bt0_id, bt0) + stat = nf90_get_att(ncid, bt0_id, "bt0", bt0) + CALL check(stat) + stat = nf90_get_att(ncid, ro_id, "ro", ro) + CALL check(stat) + stat = nf90_get_att(ncid, psio_id, "psio", psio) CALL check(stat) - stat = nf90_get_var(ncid, r0_id, r0) + stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) CALL check(stat) ! Extract Diagonal, with 3rd index signifying REAL part - DO i = 1, r_dim + DO i = 1, msing dp_diagonal(i) = REAL(delta_prime(i, i, 1)) END DO @@ -127,7 +159,8 @@ END SUBROUTINE read_stride_netcdf_diagonal c compute c----------------------------------------------------------------------- SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, - $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, + $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,Q0_arr,inpr_arr,inpe_arr, $ omegas_arr,outer_delta_arr) c----------------------------------------------------------------------- @@ -140,52 +173,67 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf, $ ising - INTEGER :: zi, zimp, mi, mimp, msing - REAL(r8) :: nfac,tfac,wefac,wpfac,e,twopi + INTEGER :: zi, zimp, mi, mimp + REAL(r8) :: nfac,tfac,wefac,wpfac,e,pi,twopi TYPE(spline_type) :: spl - TYPE(spline_type) :: sr - INTEGER :: mms,nns,mrs,nrs + INTEGER :: mms,nns,mrs,nrs,mpsi REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ qval,sval,bt,rs,zeff,inpe,r0,bt0 + $ qval,sval,bt,rs,zeff,inpe,R0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, - $ rho,tau_v,inpr,Qconv,lbeta + $ rho,tau_v,inpr,Qconv,lbeta,qintb REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr, - $ inQ_arr,inQ_e_arr, + $ inQ_arr,inQ_e_arr,psi_n_rational, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr + REAL(r8), DIMENSION(0:128) :: psitor, rhotor + REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, - $ psi_n_rational, shear - INTEGER :: r_dim + $ shear,ro,bt0,psio,mpsi_arr + INTEGER :: msing,i + c----------------------------------------------------------------------- c Read in STRIDE netcdf c----------------------------------------------------------------------- character(512) :: - $ kinetic_file = '/fusion/projects/codes/gpec/GPEC-1.5/ - $ docs/examples/a10_ideal_example/a10_prof1.txt' + $ kinetic_file = '/fusion/projects/codes/gpec/GPEC-1.5/ + $docs/examples/a10_ideal_example/a10_prof1.txt' + !character(512) :: + !$ kinetic_file = '/fusion/projects/codes/gpec/users/burgessd/GPEC/ + !$bin/g147131.02300.txt' !REAL(r8), DIMENSION(:), ALLOCATABLE :: q_rational, q_rational_coords !REAL(r8), DIMENSION(:), ALLOCATABLE :: Delta_prime, Delta_prime_coords - WRITE(*,*)"ncfile=",ncfile + CALL read_stride_netcdf_diagonal(ncfile, - $ r_dim, dp_diagonal, q_rational, psi_n_rational, - $ shear, r0, bt0) + $ msing, dp_diagonal, q_rational, psi_n_rational, + $ shear, ro, bt0, psio, mpsi_arr) + WRITE(*,*)"msing_out=",msing + WRITE(*,*)"dp_diagonal=",dp_diagonal + WRITE(*,*)"q_rational=",q_rational + WRITE(*,*)"psi_n_rational=",psi_n_rational + WRITE(*,*)"shear=",shear + WRITE(*,*)"ro=",ro + WRITE(*,*)"bt0=",bt0 + WRITE(*,*)"psio=",psio + + mpsi = INT(mpsi_arr(1)) + WRITE(*,*)"mpsi=",mpsi !CALL READ_Q_RATIONAL_AND_DELTA_PRIME_FROM_NETCDF( !& filename, q_rational, q_rational_coords, !& Delta_prime, Delta_prime_coords) - - msing = r_dim - ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), $ inQ_i_arr(msing), $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), - $ Q0_arr(msing),outer_delta_arr(msing)) + $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), + $ omegas_arr(msing),outer_delta_arr(msing)) + !ALLOCATE(my_rhotor(mpsi),my_psitor(1)) !DEALLOCATE(q_rational, q_rational_coords, Delta_prime, Delta_prime_coords) c----------------------------------------------------------------------- c Read and build equilibrium inputs @@ -228,21 +276,74 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, c----------------------------------------------------------------------- ! manually set the kinetic profiles zi = 1 - zimp = 1 - mi = 1 - mimp = 1 + zimp = 6 + mi = 2 + mimp = 12 nfac = 1.0 tfac = 1.0 wefac = 1.0 wpfac = 1.0 e=1.6021917e-19 - twopi = 6.28318530718 + pi = 3.1415926535897932 + twopi = 2*pi + chi1 = twopi*psio(1) CALL read_kin(kinetic_file,zi,zimp,mi,mimp,nfac, $ tfac,wefac,wpfac,.false.) ! manually set the perturbed equilibrium displacements ! use false flat xi and xi' for equal weighting + !CALL spline_int(sq) + !WRITE(*,*)"sq=",sq + WRITE(*,*)"mpsi=",mpsi + !CALL spline_alloc(sq,mpsi,4) + + !CALL spline_int(sq) + + !CALL timer(0,out_unit) + !CALL equil_read(out_unit) + !CALL equil_out_global + !CALL equil_out_qfind + + !if(.not. sq%allocated) + !$ stop 'ERROR: Cannot define geometric splines without sq' + + + !CALL set_geom + !WRITE(*,*)"geom%f(2)=",geom%fs(:,2) + + + + + ! minor radius defined using toroidal flux. Used for threshold + !CALL spline_int(sq) + !qintb = sq%fsi(mpsi, 4) + !psitor(:) = sq%fsi(:, 4) / qintb ! normalized toroidal flux + !rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen + !CALL spline_alloc(sr,mpsi,1) + !sr%xs = sq%xs + !sr%fs(:, 1) = rhotor(:) + !CALL spline_fit(sr,"extrap") + + + !WRITE(*,*)"twopi*psio / (pi * bt0)=",twopi*psio / (pi * bt0) + !WRITE(*,*)"sq%fsi(:, 4)=",sq%fsi(:, 4) + !WRITE(*,*)"sq%fsi(:, 4)*twopi*psio / (pi * bt0)=" + !$(twopi*psio / (pi * bt0))* + !DO i=1,mpsi + ! WRITE(*,*)"spline(i)=",sq%fsi(i, 4) + ! WRITE(*,*)"(i)=",SIZE(SQRT(sq%fsi(i, 4)*(twopi*psio / + !$(pi * bt0)))) + ! my_psitor = REAL(sq%fsi(i, 4)) + !WRITE(*,*)"my_psitor(1)=",my_psitor(1) + !WRITE(*,*)"(my_psitor(1))=",my_psitor(1) + !WRITE(*,*)"(my_rhotor(i))=",my_rhotor(i) + !my_rhotor(i)=SQRT(my_psitor(1)*(twopi*psio / + !$(pi * bt0))) + + !ENDDO + !WRITE(*,*)"rhotor=",rhotor + c----------------------------------------------------------------------- c loop across singular surfaces, evaluate spline quantities. c----------------------------------------------------------------------- @@ -252,19 +353,28 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, !respsi=singtype(ising)%psifac !CALL spline_eval(sq,respsi,1) respsi = psi_n_rational(ising) + WRITE(*,*)"respsi=",respsi + WRITE(*,*)"chi1=",chi1 + c----------------------------------------------------------------------- c prepare layer analysis. c----------------------------------------------------------------------- !resm = mfac(resnum(ising)) - CALL spline_eval(sr,respsi,1) + !CALL spline_eval(sr,respsi,1) CALL spline_eval(kin,respsi,1) + !CALL spline_eval(geom,respsi,1) c----------------------------------------------------------------------- c SLAYER inputs for sing surface c----------------------------------------------------------------------- + + + omega_i=-twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) $ -twopi*kin%f1(3)/(e*zi*chi1) omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) + WRITE(*,*)"omega_i=",omega_i + WRITE(*,*)"omega_e=",omega_e ! Here's where I'm getting these from !CALL gpec_slayer(kin%f(2),kin%f(4)/e,kin%f(1),kin%f(3)/e, @@ -276,20 +386,40 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, t_e = kin%f(4)/e n_i = kin%f(1) t_i = kin%f(3)/e - zeff = kin%f(5) - omega = kin%f(9) + zeff = kin%f(9) + omega = kin%f(5) qval = q_rational(ising)!sq%f(4) sval = shear(ising) - bt = bt0 - rs = sr%f1(1) - R0 = r0 + bt = bt0(1) + rs = 0.167 + R0 = ro(1) mu_i = mi inpr = slayer_inpr - !mms = resm - !nns = nn - mrs = 2.0 ! FROM NAMELIST ???? real(mms,4) - nrs = 1.0 ! FROM NAMELIST ???? real(nns,4) + !!! TEMPORARY + !mm=2 + !nn=1 + !mr = real(mm,4) + !nr = real(nn,4) + mms = 2.0 + nns = 1.0 + mrs = real(mms,4) + nrs = real(nns,4) + + WRITE(*,*)"n_e=",n_e + WRITE(*,*)"t_e=",t_e + WRITE(*,*)"n_i=",n_i + WRITE(*,*)"t_i=",t_i + WRITE(*,*)"zeff=",zeff + WRITE(*,*)"omega=",omega + WRITE(*,*)"qval=",qval + WRITE(*,*)"sval=",sval + WRITE(*,*)"bt=",bt + WRITE(*,*)"rs=",rs + WRITE(*,*)"R0=",R0 + WRITE(*,*)"mu_i=",mu_i + WRITE(*,*)"inpr=",inpr + WRITE(*,*)"dp_diagonal(ising)=",dp_diagonal ! String representations of the m and n mode numbers !IF (nns<10) THEN ! WRITE(UNIT=sn,FMT='(I1)') nns @@ -309,23 +439,34 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, inpe=0.0 ! Waybright added this + WRITE(*,*)"lnLamb=",lnLamb + WRITE(*,*)"mu_i=",mu_i + WRITE(*,*)"m_p=",m_p + tau= t_i/t_e ! ratio of ion to electron temperature tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) rho=(mu_i*m_p)*n_e ! mass density + + + b_l=(nrs/mrs)*nrs*sval*bt/R0 ! characteristic magnetic field - v_a=b_l/(mu0*rho)**0.5 ! alfven velocity + WRITE(*,*)"b_l=",b_l + + v_a=b_l/(mu0*rho)**0.5 ! alfven velocity, B_L IS BROKEN rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! alfven time across surface tau_r=mu0*rs**2.0/eta ! resistive time scale tau_v=tau_r/inpr ! rho*rs**2.0/visc ! viscous time scale + WRITE(*,*)"tau_v=",tau_v ! this one must be anomalous. calculated back from pr. visc= rho*rs**2.0/tau_v lu=tau_r/tau_h ! Lundquist number + WRITE(*,*)"lu=",lu Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole @@ -333,30 +474,85 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i + WRITE(*,*)"Q=",Q ! This is the most critical parameter ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 + WRITE(*,*)"c_beta=",c_beta delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes + WRITE(*,*)"delta_n=",delta_n + + WRITE(*,*)"qval_arr(ising)=",qval_arr(ising) + WRITE(*,*)"qval=",qval qval_arr(ising) = qval + WRITE(*,*)"qval_arr(ising)=",qval_arr(ising) inQ_arr(ising)=Q + WRITE(*,*)"inQ_arr(ising)=",inQ_arr(ising) + inQ_e_arr(ising)=Q_e + WRITE(*,*)"inQ_e_arr(ising)=",inQ_e_arr(ising) + inQ_i_arr(ising)=Q_i + WRITE(*,*)"inQ_i_arr(ising)=",inQ_i_arr(ising) + inc_beta_arr(ising)=c_beta + WRITE(*,*)"inds_arr(ising)=",inc_beta_arr(ising) + inds_arr(ising)=ds + WRITE(*,*)"inds_arr(ising)=",inds_arr(ising) + intau_arr(ising)=tau + WRITE(*,*)"intau_arr(ising)=",intau_arr(ising) + Q0_arr(ising)=Q + WRITE(*,*)"Q0_arr(ising)=",Q0_arr(ising) + inpr_arr(ising) = inpr + WRITE(*,*)"inpr_arr(ising)=",inpr_arr(ising) + inpe_arr(ising) = 0.0 !!! TEMPORARY? + WRITE(*,*)"inpe_arr(ising)=",inpe_arr(ising) + omegas_arr(ising) = omega - outer_delta_arr(ising) = dp_diagonal(ising) + WRITE(*,*)"omegas_arr(ising)=",omegas_arr(ising) + outer_delta_arr(ising) = dp_diagonal(ising) + WRITE(*,*)"outer_delta_arr(ising)=", + $outer_delta_arr(ising) + + WRITE(*,*)"qval_arr=",qval_arr + WRITE(*,*)"inQ_arr=",inQ_arr + WRITE(*,*)"inQ_e_arr=",inQ_e_arr + WRITE(*,*)"inQ_i_arr=",inQ_i_arr + WRITE(*,*)"inc_beta_arr=",inc_beta_arr + WRITE(*,*)"inds_arr=",inds_arr + WRITE(*,*)"intau_arr=",intau_arr + WRITE(*,*)"Q0_arr=",Q0_arr + WRITE(*,*)"inpr_arr=",inpr_arr + WRITE(*,*)"inpe_arr=",inpe_arr + WRITE(*,*)"omegas_arr=",omegas_arr + WRITE(*,*)"outer_delta_arr=",outer_delta_arr ENDDO - CALL spline_dealloc(sr) + + !WRITE(*,*)"qval_arr=",qval_arr + !WRITE(*,*)"inQ_arr=",inQ_arr + !WRITE(*,*)"inQ_e_arr=",inQ_e_arr + !WRITE(*,*)"inQ_i_arr=",inQ_i_arr + !WRITE(*,*)"inc_beta_arr=",inc_beta_arr + !WRITE(*,*)"inds_arr=",inds_arr + !WRITE(*,*)"intau_arr=",intau_arr + !WRITE(*,*)"Q0_arr=",Q0_arr + !!WRITE(*,*)"inpr_arr=",inpr_arr + !WRITE(*,*)"inpe_arr=",inpe_arr + !WRITE(*,*)"omegas_arr=",omegas_arr + !WRITE(*,*)"outer_delta_arr=",outer_delta_arr + + !CALL spline_dealloc(sr) !CALL cspline_dealloc(fsp_sol) !CALL gpeq_dealloc c----------------------------------------------------------------------- diff --git a/slayer/makefile b/slayer/makefile index b4c676d97..29a36dfd3 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -20,6 +20,7 @@ OBJS = \ sglobal.o \ params.o \ layerinputs.o \ + slayer_netcdf.o \ delta.o \ gslayer.o \ slayer.o @@ -52,7 +53,7 @@ slayer: $(OBJS) params.o : sglobal.o delta.o : sglobal.o -gslayer.o : sglobal.o layerinputs.o delta.o +gslayer.o : sglobal.o delta.o slayer.o : sglobal.o params.o delta.o ../pentrc/grid.mod ../equil/spline_mod.mod clean: diff --git a/slayer/slayer.f b/slayer/slayer.f index 5dccc3afe..126f7f300 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -54,7 +54,8 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: qval_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr + $ inpe_arr,omegas_arr,inQ_arr, + $ psi_n_rational REAL(r8), DIMENSION(:), ALLOCATABLE :: $ outer_delta_arr REAL(r8), DIMENSION(:,:), ALLOCATABLE :: @@ -138,7 +139,9 @@ PROGRAM slayer input_flag=.FALSE. infile="input_params.dat" ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ - $stride_output_n1.nc" + $stride_output_a1.nc" + !ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ + !$stride_output_147131.nc" verbose=.TRUE. ascii_flag=.TRUE. bin_flag=.TRUE. @@ -330,15 +333,29 @@ PROGRAM slayer !CALL read_stride_netcdf(filename, q_rational, q_rational_coords, !$ Delta_prime, Delta_prime_coords) CALL build_inputs(ncfile,inpr, - $ growthrates_flag,qval_arr, + $ growthrates_flag,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, $ omegas_arr,outer_delta_arr) - WRITE(*,*)"outer_delta_arr=",outer_delta_arr + WRITE(*,*)"qval_arr=",qval_arr + WRITE(*,*)"inQ_arr=",inQ_arr + WRITE(*,*)"inQ_e_arr=",inQ_e_arr + WRITE(*,*)"inQ_i_arr=",inQ_i_arr + WRITE(*,*)"inc_beta_arr=",inc_beta_arr + WRITE(*,*)"inds_arr=",inds_arr + WRITE(*,*)"intau_arr=",intau_arr + WRITE(*,*)"inQ0_arr=",inQ0_arr + WRITE(*,*)"inpr_arr=",inpr_arr + WRITE(*,*)"inpe_arr=",inpe_arr WRITE(*,*)"omegas_arr=",omegas_arr + WRITE(*,*)"outer_delta_arr=",outer_delta_arr + WRITE(*,*)"made it to gammamatch=",qval_arr + + !stop - CALL gamma_match(qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + $ inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr, $ inQ0_arr,inpr_arr,inpe_arr, $ omegas_arr,outer_delta_arr, diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f new file mode 100644 index 000000000..33d92c593 --- /dev/null +++ b/slayer/slayer_netcdf.f @@ -0,0 +1,188 @@ +c----------------------------------------------------------------------- +c file slayer_netcdf.f +c writes slayer information to a netcdf file +c----------------------------------------------------------------------- +c code organization. +c----------------------------------------------------------------------- +c 0. slayer_netcdf_mod +c 1. check +c 2. stride_netcdf_out +c----------------------------------------------------------------------- +c subprogram 0. slayer_netcdf_mod +c module declarations. +c----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c declarations. +c----------------------------------------------------------------------- + MODULE slayer_netcdf_mod + !USE dcon_mod + USE sglobal_mod + !USE layerinputs_mod + !USE gslayer_mod + USE netcdf + IMPLICIT NONE + CONTAINS +c ----------------------------------------------------------------------- +c ----------------------------------------------------------------------- +c subprogram 2. stride_netcdf_out. +c Replicate stride.out information in netcdf format. +c ----------------------------------------------------------------------- +c----------------------------------------------------------------------- +c subprogram 1. check. +c Check status of netcdf file. +c----------------------------------------------------------------------- + SUBROUTINE check(stat) +c----------------------------------------------------------------------- +c declaration. +c----------------------------------------------------------------------- + INTEGER, INTENT (IN) :: stat +c----------------------------------------------------------------------- +c stop if it is an error. +c----------------------------------------------------------------------- + IF(stat /= nf90_noerr) THEN + PRINT *, TRIM(nf90_strerror(stat)) + !STOP "ERROR: failed to write/read netcdf file" + ENDIF +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- + RETURN + END SUBROUTINE check +c ----------------------------------------------------------------------- +c declarations. +c ----------------------------------------------------------------------- + SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, + $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr,psi_n_rational, + $ all_Re_deltas,all_slices) + INTEGER, INTENT(IN) :: msing,ReQ_n,ImQ_n + REAL(r8), DIMENSION(:), INTENT(IN) :: qval_arr, + $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr, + $ psi_n_rational!,shear + REAL(r8), DIMENSION(:,:), INTENT(IN) :: all_slices + REAL(r8), DIMENSION(:,:,:), INTENT(IN) :: all_Re_deltas + INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, + $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, + $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id, + $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id + !COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et + !CHARACTER(2) :: sn + CHARACTER(64) :: ncfile + ! INTEGER :: ising,jsing + !COMPLEX(r8), DIMENSION(msing,msing) :: ap,bp,gammap,deltap + LOGICAL, PARAMETER :: debug_flag = .FALSE. +c ----------------------------------------------------------------------- +c set variables +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *,"Called slayer_netcdf_out" + IF (nn<10) THEN + WRITE(UNIT=sn,FMT='(I1)')nn + sn=ADJUSTL(sn) + ELSE + WRITE(UNIT=sn,FMT='(I2)')nn + ENDIF + ncfile = "slayer_output_n"//TRIM(sn)//".nc" + IF(debug_flag) PRINT *, ncfile +c ----------------------------------------------------------------------- +c open files +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Creating netcdf files" + CALL check( nf90_create(ncfile, + $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) +c ----------------------------------------------------------------------- +c define global file attributes +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Defining netcdf globals" + CALL check( nf90_put_att(ncid,nf90_global,"title", + $ "SLAYER outputs")) + ! define global attributes + !CALL check( nf90_put_att(ncid,nf90_global,'ro', ro)) + !CALL check( nf90_put_att(ncid,nf90_global,'psio', psio)) + !CALL check( nf90_put_att(ncid,nf90_global,'bt0', bt0)) + !CALL check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) + !CALL check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) + !CALL check( nf90_put_att(ncid,nf90_global,"n", nn)) + !CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + ! define dimensions + IF(debug_flag) PRINT *," - Defining dimensions in netcdf" + !CALL check( nf90_def_dim(ncid, "i", 2, i_dim) ) + !CALL check( nf90_def_var(ncid, "i", nf90_int, i_dim, i_id) ) + !CALL check( nf90_def_dim(ncid, "m", mpert, m_dim) ) + !CALL check( nf90_def_var(ncid, "m", nf90_int, m_dim, m_id) ) + !CALL check( nf90_def_dim(ncid, "mode", mpert, mo_dim) ) + !CALL check( nf90_def_var(ncid, "mode", nf90_int, mo_dim, mo_id)) + !CALL check( nf90_def_dim(ncid, "psi_n", sq%mx+1, p_dim) ) + !CALL check( nf90_def_var(ncid, "psi_n", nf90_double, p_dim, p_id)) + IF(msing>0)THEN + CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, + $ qsing_id)) + CALL check( nf90_def_dim(ncid,"ReQ_arr",ReQ_n, + $ ReQ_dim) ) !r_dim = q_rational + CALL check( nf90_def_var(ncid,"ReQ_arr",nf90_double,ReQ_dim, + $ ReQ_id)) + CALL check( nf90_def_dim(ncid,"ImQ_arr",ImQ_n,ImQ_dim) ) !r_dim = q_rational + CALL check( nf90_def_var(ncid,"ImQ_arr",nf90_double,ImQ_dim, + $ ImQ_id)) + CALL check( nf90_def_var(ncid,"growthrates",nf90_double, + $ qsing_dim,gamma_id)) + CALL check( nf90_def_var(ncid,"omegas",nf90_double, + $ qsing_dim,omegas_id)) + CALL check( nf90_def_var(ncid,"Q",nf90_double, + $ qsing_dim,Q_id)) + CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, + $ qsing_dim,pr_id) ) + CALL check( nf90_def_var(ncid,"q_rational",nf90_double, + $ qsing_dim,qr_id) ) + ! CALL check( nf90_def_var(ncid,"shear",nf90_double,q_rational, + !$ shear_id) ) + ENDIF + ! define variables + IF(debug_flag) PRINT *," - Defining variables in netcdf" + !CALL check( nf90_def_var(ncid, "f", nf90_double, p_dim, f_id) ) + !CALL check( nf90_def_var(ncid, "mu0p", nf90_double, p_dim, mu_id)) + !CALL check( nf90_def_var(ncid, "dvdpsi", nf90_double,p_dim,dv_id)) + !CALL check( nf90_def_var(ncid, "q", nf90_double, p_dim, q_id) ) + !CALL check( nf90_def_var(ncid, "di", nf90_double, p_dim, di_id) ) + !CALL check( nf90_def_var(ncid, "dr", nf90_double, p_dim, dr_id) ) + !CALL check( nf90_def_var(ncid, "ca1", nf90_double, p_dim, ca_id)) + !CALL check( nf90_def_var(ncid, "W_p_eigenvector", nf90_double, + !$ (/m_dim, mo_dim, i_dim/), wp_id) ) + !CALL check( nf90_def_var(ncid, "W_p_eigenvalue", nf90_double, + !$ (/mo_dim, i_dim/), wpv_id) ) + IF(msing>0)THEN + CALL check( nf90_def_var(ncid, "Re_Delta", nf90_double, + $ (/ReQ_dim, ImQ_dim, qsing_dim/), dp_id) ) + CALL check( nf90_def_var(ncid, "slices", nf90_double, + $ (/ImQ_dim, qsing_dim/), slice_id) ) + ENDIF + ! end definitions + CALL check( nf90_enddef(ncid) ) +c ----------------------------------------------------------------------- +c set variables +c ----------------------------------------------------------------------- + ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" + CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) + CALL check( nf90_put_var(ncid,ReQ_id, inQs_log)) + CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) + CALL check( nf90_put_var(ncid,gamma_id, growthrates)) + CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) + CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) + CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) + CALL check( nf90_put_var(ncid,qr_id, qval_arr)) + !CALL check( nf90_put_var(ncid,shear_id, shear)) + ! IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" + CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas))!, + !$(/ReQ_n,ImQ_n,msing/))) + CALL check( nf90_put_var(ncid,slice_id,all_slices))!, + !$(/ImQ_n,msing/))) +c ----------------------------------------------------------------------- +c close file +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Closing netcdf file" + CALL check( nf90_close(ncid) ) +c ----------------------------------------------------------------------- +c terminate. +c ----------------------------------------------------------------------- + RETURN + END SUBROUTINE slayer_netcdf_out + END MODULE slayer_netcdf_mod \ No newline at end of file diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 4d3c26e9c..9eb8ec587 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -60,7 +60,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ bt0_id, r0_id, shear_id + $ shear_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile @@ -109,6 +109,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_put_att(ncid,nf90_global,'mhigh', mhigh)) CALL check( nf90_put_att(ncid,nf90_global,'mpert', mpert)) CALL check( nf90_put_att(ncid,nf90_global,'mband', mband)) + CALL check( nf90_put_att(ncid,nf90_global,'msing', msing)) CALL check( nf90_put_att(ncid,nf90_global,'psilow', psilow)) CALL check( nf90_put_att(ncid,nf90_global,'amean', amean)) CALL check( nf90_put_att(ncid,nf90_global,'rmean', rmean)) @@ -163,10 +164,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid,"r_prime",nf90_int,rp_dim,rp_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ r_dim,pr_id) ) - CALL check( nf90_def_var(ncid,"bt0",nf90_double, - $ r_dim/r_dim,bt0_id) ) - CALL check( nf90_def_var(ncid,"r0",nf90_double, - $ r_dim/r_dim,r0_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, @@ -224,8 +221,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,pr_id, (/(sing(i)%psifac, $ i=1,msing)/)) ) - CALL check( nf90_put_var(ncid,bt0_id, (/ bt0 /)) ) - CALL check( nf90_put_var(ncid,r0_id, (/ ro /)) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, From 7384150d68b1428a1855b702689daa449028b196 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 5 Jul 2024 13:56:19 -0700 Subject: [PATCH 007/118] WIP: adding GUI compatibility --- docs/examples/a10_ideal_example/slayer.in | 13 +- input/slayer.in | 13 +- pentrc/inputs.f90 | 1 + slayer/layerinputs.f | 241 ++++++++++------------ slayer/slayer.f | 16 +- stride/stride_netcdf.f | 29 ++- 6 files changed, 162 insertions(+), 151 deletions(-) diff --git a/docs/examples/a10_ideal_example/slayer.in b/docs/examples/a10_ideal_example/slayer.in index 8d2d5ba03..380c8dea4 100644 --- a/docs/examples/a10_ideal_example/slayer.in +++ b/docs/examples/a10_ideal_example/slayer.in @@ -2,16 +2,16 @@ !!! FOR READING IN ASCII TABLE, SET INPUT_FLAG input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table - infile='/fusion/projects/codes/gpec/GPEC-1.5/docs/examples/a10_ideal_example/a10_prof1.txt' ! Path to ascii table of profile quantities read when using input_flag - + infile='' ! Path to ascii table of profile quantities read when using input_flag + ncfile='' ! Path to netCDF file of STRIDE outputs !!! FOR MANUALLY ENTERING KINETIC QUANTITIES @ RATIONAL SURFACE, SET PARAMS_FLAG - params_flag=t ! calculates normalized parameters from profile quantities + params_flag=f ! calculates normalized parameters from profile quantities mm=2 ! poloidal mode number nn=1 ! toroidal mode number n_e=7.77E+17 ! electron density [m^-3] t_e=25.8 ! electron temperature [eV] t_i=25.8 ! ion temperature [eV] - sval=729.0 ! magnetic shear at the layer + sval=2.0 ! magnetic shear at the layer bt=1.0 ! toroidal field [T] rs=0.17 ! minor radius of resonant surface [m] R0=2.0 ! major radius of magnetic axis [m] @@ -21,7 +21,7 @@ qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective - inpr=0.0001 ! Prantdl number + inpr=0.1 ! Prantdl number inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -56,7 +56,8 @@ bin_flag=t ! writes results to binary files netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q - bal_flag=t ! calculate the resonant field penetration threshold from torque balance + growthrates_flag=t ! Calculate growthrates on each rational surface + !bal_flag=f ! calculate the resonant field penetration threshold from torque balance / &SLAYER_DIAGNOSE riccati_out=f ! writes LSDOE Riccati integration to an ascii file diff --git a/input/slayer.in b/input/slayer.in index 8d2d5ba03..380c8dea4 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -2,16 +2,16 @@ !!! FOR READING IN ASCII TABLE, SET INPUT_FLAG input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table - infile='/fusion/projects/codes/gpec/GPEC-1.5/docs/examples/a10_ideal_example/a10_prof1.txt' ! Path to ascii table of profile quantities read when using input_flag - + infile='' ! Path to ascii table of profile quantities read when using input_flag + ncfile='' ! Path to netCDF file of STRIDE outputs !!! FOR MANUALLY ENTERING KINETIC QUANTITIES @ RATIONAL SURFACE, SET PARAMS_FLAG - params_flag=t ! calculates normalized parameters from profile quantities + params_flag=f ! calculates normalized parameters from profile quantities mm=2 ! poloidal mode number nn=1 ! toroidal mode number n_e=7.77E+17 ! electron density [m^-3] t_e=25.8 ! electron temperature [eV] t_i=25.8 ! ion temperature [eV] - sval=729.0 ! magnetic shear at the layer + sval=2.0 ! magnetic shear at the layer bt=1.0 ! toroidal field [T] rs=0.17 ! minor radius of resonant surface [m] R0=2.0 ! major radius of magnetic axis [m] @@ -21,7 +21,7 @@ qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective - inpr=0.0001 ! Prantdl number + inpr=0.1 ! Prantdl number inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -56,7 +56,8 @@ bin_flag=t ! writes results to binary files netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q - bal_flag=t ! calculate the resonant field penetration threshold from torque balance + growthrates_flag=t ! Calculate growthrates on each rational surface + !bal_flag=f ! calculate the resonant field penetration threshold from torque balance / &SLAYER_DIAGNOSE riccati_out=f ! writes LSDOE Riccati integration to an ascii file diff --git a/pentrc/inputs.f90 b/pentrc/inputs.f90 index 7ed7527e7..99e342bc0 100644 --- a/pentrc/inputs.f90 +++ b/pentrc/inputs.f90 @@ -216,6 +216,7 @@ subroutine read_kin(file,zi,zimp,mi,mimp,nfac,tfac,wefac,wpfac,write_log) do i=1,5 tmp%fs(0:,i) = table(1:,i+1) enddo + call spline_fit(tmp,"extrap") if(write_log) print *,"Formed temporary spline" diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index b8b8825bb..8a68f23c2 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -43,122 +43,133 @@ END SUBROUTINE check c----------------------------------------------------------------------- c Read and build equilibrium inputs c----------------------------------------------------------------------- - SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, + SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ dp_diagonal, q_rational, psi_n_rational, shear, - $ ro,bt0,psio,mpsi) + $ ro,bt0,psio,mpsi,nn,resm) !USE netcdf ! NetCDF module for Fortran !USE stride_netcdf_mod ! For the 'check' subroutine (error handling) ! Input/Output Arguments - CHARACTER(128), INTENT(IN) :: ncfile - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, + CHARACTER(512), INTENT(IN) :: ncfile + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, $ psi_n_rational, shear - REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: ro,bt0,psio, + REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: ro,bt0,psio, $ mpsi - INTEGER, INTENT(OUT) :: msing + INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm + INTEGER, INTENT(OUT) :: msing - REAL(r8), DIMENSION(:), ALLOCATABLE :: msing_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: msing_arr ! Internal Variables - INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, + INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, - $ msing_id ! Explicit kind for NetCDF variables - INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime - INTEGER :: i - INTEGER :: bt0_len,ro_len,psio_len,mpsi_len,msing_len ! Attribute lengths + $ msing_id,nn_id,resm_id ! Explicit kind for NetCDF variables + INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime + INTEGER :: i + INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, + $ msing_len,nn_len ! Attribute lengths ! Open the NetCDF file - stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) - WRITE(*,*)"ncfile=",ncfile - CALL check(stat) ! Error handling + stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) + WRITE(*,*)"ncfile=",ncfile + CALL check(stat) ! Error handling - stat = nf90_inquire_attribute(ncid, msing_id, "msing", + stat = nf90_inquire_attribute(ncid,msing_id,"msing", $ len = msing_len) - ALLOCATE(msing_arr(msing_len)) + CALL check(stat) + ALLOCATE(msing_arr(msing_len)) + stat = nf90_get_att(ncid,msing_id,"msing",msing_arr) + CALL check(stat) - CALL check(stat) - stat = nf90_get_att(ncid, msing_id, "msing", msing_arr) - CALL check(stat) - - msing=INT(msing_arr(1)) + msing=INT(msing_arr(1)) ! Allocate Arrays (based on dimension) - ALLOCATE(dp_diagonal(msing),q_rational(msing), - $ psi_n_rational(msing),shear(msing)) - ALLOCATE(delta_prime(msing, msing,2)) + ALLOCATE(dp_diagonal(msing),q_rational(msing), + $ psi_n_rational(msing),shear(msing), + $ resm(msing)) + ALLOCATE(delta_prime(msing, msing,2)) + + stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) + CALL check(stat) + stat = nf90_inquire_attribute(ncid,bt0_id,"bt0",len=bt0_len) + CALL check(stat) + + bt0_id=0 !!!!! THIS COULD BE A PROBLEM + + stat = nf90_inquire_attribute(ncid,psio_id,"psio",len = psio_len) + CALL check(stat) + + stat = nf90_inquire_attribute(ncid,mpsi_id,"mpsi",len = mpsi_len) + CALL check(stat) + stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) + CALL check(stat) + + ALLOCATE(bt0(INT(bt0_len)),ro(INT(ro_len)),psio(INT(psio_len)), + $mpsi(INT(mpsi_len)),nn(INT(nn_len))) ! Get Variable IDs - stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) - CALL check(stat) - WRITE(*,*)"stat=",stat - stat = nf90_inq_varid(ncid, "q_rational", qr_id) - CALL check(stat) - WRITE(*,*)"stat=",stat - stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) - CALL check(stat) - WRITE(*,*)"stat=",stat - - stat = nf90_inq_varid(ncid, "shear", shear_id) - CALL check(stat) - stat = nf90_inquire_attribute(ncid, bt0_id, "bt0", - $ len = bt0_len) - CALL check(stat) - stat = nf90_inquire_attribute(ncid, ro_id, "ro", - $ len = ro_len) - CALL check(stat) - stat = nf90_inquire_attribute(ncid, psio_id, "psio", - $ len = psio_len) - CALL check(stat) - stat = nf90_inquire_attribute(ncid, mpsi_id, "mpsi", - $ len = mpsi_len) - CALL check(stat) - ALLOCATE(bt0(bt0_len),ro(ro_len),psio(psio_len), - $ mpsi(mpsi_len)) + stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "q_rational", qr_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "shear", shear_id) + CALL check(stat) + stat = nf90_inq_varid(ncid, "resm", resm_id) + CALL check(stat) ! Read Data from NetCDF File ! Set up start and count for reading only the diagonal !start(1) = 1 !count(1) = 1 - ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. - stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) - CALL check(stat) - ! Read 1D variables - stat = nf90_get_var(ncid, qr_id, q_rational) - CALL check(stat) - stat = nf90_get_var(ncid, pr_id, psi_n_rational) - CALL check(stat) - stat = nf90_get_var(ncid, shear_id, shear) - CALL check(stat) - stat = nf90_get_att(ncid, bt0_id, "bt0", bt0) - CALL check(stat) - stat = nf90_get_att(ncid, ro_id, "ro", ro) - CALL check(stat) - stat = nf90_get_att(ncid, psio_id, "psio", psio) - CALL check(stat) - stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) - CALL check(stat) - - ! Extract Diagonal, with 3rd index signifying REAL part - DO i = 1, msing - dp_diagonal(i) = REAL(delta_prime(i, i, 1)) - END DO + ! Get attributes + stat = nf90_get_att(ncid, ro_id, "ro", ro) + CALL check(stat) + stat = nf90_get_att(ncid, bt0_id, "bt0", bt0) + CALL check(stat) + stat = nf90_get_att(ncid, psio_id, "psio", psio) + CALL check(stat) + stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) + CALL check(stat) + stat = nf90_get_att(ncid, nn_id, "n", nn) + CALL check(stat) + + ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. + stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) + CALL check(stat) + ! Read 1D variables + stat = nf90_get_var(ncid, qr_id, q_rational) + CALL check(stat) + stat = nf90_get_var(ncid, pr_id, psi_n_rational) + CALL check(stat) + stat = nf90_get_var(ncid, shear_id, shear) + CALL check(stat) + stat = nf90_get_var(ncid, resm_id, resm) + CALL check(stat) + + ! Extract Diagonal, with 3rd index signifying REAL part + DO i = 1, msing + dp_diagonal(i) = REAL(delta_prime(i, i, 1)) + END DO ! Clean Up - DEALLOCATE(delta_prime) - stat = nf90_close(ncid) - CALL check(stat) + DEALLOCATE(delta_prime) + stat = nf90_close(ncid) + CALL check(stat) - END SUBROUTINE read_stride_netcdf_diagonal + END SUBROUTINE read_stride_netcdf_diagonal c----------------------------------------------------------------------- c subprogram 1. build_inputs. c compute c----------------------------------------------------------------------- - SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, + SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, + $ growthrate_flag, $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,Q0_arr,inpr_arr,inpe_arr, @@ -166,7 +177,6 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- - CHARACTER(128), INTENT(IN) :: ncfile LOGICAL, INTENT(IN) :: growthrate_flag REAL(r8), INTENT(IN) ::slayer_inpr @@ -195,15 +205,15 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, $ shear,ro,bt0,psio,mpsi_arr + INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm INTEGER :: msing,i c----------------------------------------------------------------------- c Read in STRIDE netcdf c----------------------------------------------------------------------- - character(512) :: - $ kinetic_file = '/fusion/projects/codes/gpec/GPEC-1.5/ - $docs/examples/a10_ideal_example/a10_prof1.txt' + CHARACTER(512), INTENT(IN) :: infile,ncfile + !character(512) :: !$ kinetic_file = '/fusion/projects/codes/gpec/users/burgessd/GPEC/ !$bin/g147131.02300.txt' @@ -212,7 +222,7 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, CALL read_stride_netcdf_diagonal(ncfile, $ msing, dp_diagonal, q_rational, psi_n_rational, - $ shear, ro, bt0, psio, mpsi_arr) + $ shear, ro, bt0, psio, mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing WRITE(*,*)"dp_diagonal=",dp_diagonal WRITE(*,*)"q_rational=",q_rational @@ -221,6 +231,8 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, WRITE(*,*)"ro=",ro WRITE(*,*)"bt0=",bt0 WRITE(*,*)"psio=",psio + WRITE(*,*)"nn=",nn + WRITE(*,*)"resm=",resm mpsi = INT(mpsi_arr(1)) WRITE(*,*)"mpsi=",mpsi @@ -288,14 +300,14 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, twopi = 2*pi chi1 = twopi*psio(1) - CALL read_kin(kinetic_file,zi,zimp,mi,mimp,nfac, + CALL read_kin(infile,zi,zimp,mi,mimp,nfac, $ tfac,wefac,wpfac,.false.) ! manually set the perturbed equilibrium displacements ! use false flat xi and xi' for equal weighting !CALL spline_int(sq) !WRITE(*,*)"sq=",sq - WRITE(*,*)"mpsi=",mpsi + !WRITE(*,*)"mpsi=",mpsi !CALL spline_alloc(sq,mpsi,4) !CALL spline_int(sq) @@ -382,6 +394,10 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, !$ bt0,sr%f1(1),ro,mi,slayer_inpr,resm,nn,ascii_flag, !$ delta_s,psi0,jxb,omega_sol,br_th) + !singtype(ising)%q = q(ising)? + !resnum=NINT(singtype(ising)%q*nn)-mlow+1 + !shear(ising)=mfac(resnum)*sq%f1(4)/sq%f(4)**2 + n_e = kin%f(2) t_e = kin%f(4)/e n_i = kin%f(1) @@ -389,7 +405,7 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, zeff = kin%f(9) omega = kin%f(5) qval = q_rational(ising)!sq%f(4) - sval = shear(ising) + sval = shear(ising) ! SHEAR SO MUCH SMALLER THAN BEFORE???? 500 puts it on the root bt = bt0(1) rs = 0.167 R0 = ro(1) @@ -401,11 +417,14 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, !nn=1 !mr = real(mm,4) !nr = real(nn,4) - mms = 2.0 - nns = 1.0 + mms = resm(ising) + nns = nn(1) mrs = real(mms,4) nrs = real(nns,4) + WRITE(*,*)"nns=",nns + WRITE(*,*)"mms=",mms + WRITE(*,*)"n_e=",n_e WRITE(*,*)"t_e=",t_e WRITE(*,*)"n_i=",n_i @@ -486,57 +505,19 @@ SUBROUTINE build_inputs(ncfile,slayer_inpr,growthrate_flag, delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes WRITE(*,*)"delta_n=",delta_n - WRITE(*,*)"qval_arr(ising)=",qval_arr(ising) - WRITE(*,*)"qval=",qval - qval_arr(ising) = qval - WRITE(*,*)"qval_arr(ising)=",qval_arr(ising) inQ_arr(ising)=Q - WRITE(*,*)"inQ_arr(ising)=",inQ_arr(ising) - inQ_e_arr(ising)=Q_e - WRITE(*,*)"inQ_e_arr(ising)=",inQ_e_arr(ising) - inQ_i_arr(ising)=Q_i - WRITE(*,*)"inQ_i_arr(ising)=",inQ_i_arr(ising) - inc_beta_arr(ising)=c_beta - WRITE(*,*)"inds_arr(ising)=",inc_beta_arr(ising) - inds_arr(ising)=ds - WRITE(*,*)"inds_arr(ising)=",inds_arr(ising) - intau_arr(ising)=tau - WRITE(*,*)"intau_arr(ising)=",intau_arr(ising) - Q0_arr(ising)=Q - WRITE(*,*)"Q0_arr(ising)=",Q0_arr(ising) - inpr_arr(ising) = inpr - WRITE(*,*)"inpr_arr(ising)=",inpr_arr(ising) - inpe_arr(ising) = 0.0 !!! TEMPORARY? - WRITE(*,*)"inpe_arr(ising)=",inpe_arr(ising) - omegas_arr(ising) = omega - WRITE(*,*)"omegas_arr(ising)=",omegas_arr(ising) - outer_delta_arr(ising) = dp_diagonal(ising) - WRITE(*,*)"outer_delta_arr(ising)=", - $outer_delta_arr(ising) - - WRITE(*,*)"qval_arr=",qval_arr - WRITE(*,*)"inQ_arr=",inQ_arr - WRITE(*,*)"inQ_e_arr=",inQ_e_arr - WRITE(*,*)"inQ_i_arr=",inQ_i_arr - WRITE(*,*)"inc_beta_arr=",inc_beta_arr - WRITE(*,*)"inds_arr=",inds_arr - WRITE(*,*)"intau_arr=",intau_arr - WRITE(*,*)"Q0_arr=",Q0_arr - WRITE(*,*)"inpr_arr=",inpr_arr - WRITE(*,*)"inpe_arr=",inpe_arr - WRITE(*,*)"omegas_arr=",omegas_arr - WRITE(*,*)"outer_delta_arr=",outer_delta_arr + ENDDO !WRITE(*,*)"qval_arr=",qval_arr diff --git a/slayer/slayer.f b/slayer/slayer.f index 126f7f300..0ad1047be 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -23,7 +23,7 @@ PROGRAM slayer IMPLICIT NONE - CHARACTER(128) :: infile,ncfile + CHARACTER(512) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num,n_k INTEGER, DIMENSION(1) :: index @@ -78,9 +78,9 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag,growthrates_flag + $ stability_flag,growthrates_flag,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, - $ params_check,bal_flag + $ params_check c----------------------------------------------------------------------- c set initial values. c----------------------------------------------------------------------- @@ -137,9 +137,8 @@ PROGRAM slayer PeOhmOnly_flag=.TRUE. params_flag=.TRUE. input_flag=.FALSE. - infile="input_params.dat" - ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ - $stride_output_a1.nc" + infile="" + ncfile="" !ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ !$stride_output_147131.nc" verbose=.TRUE. @@ -332,7 +331,10 @@ PROGRAM slayer !CALL read_stride_netcdf(filename, q_rational, q_rational_coords, !$ Delta_prime, Delta_prime_coords) - CALL build_inputs(ncfile,inpr, + WRITE(*,*)"infile=",infile + WRITE(*,*)"ncfile=",ncfile + + CALL build_inputs(infile,ncfile,inpr, $ growthrates_flag,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 9eb8ec587..2b5c4936f 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -53,6 +53,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) REAL(r8), DIMENSION(mpert), INTENT(IN) :: epi,evi,eti COMPLEX(r8), DIMENSION(mpert,mpert), INTENT(IN) :: wp,wv,wt COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: dp + INTEGER, DIMENSION(mpert) :: mvec INTEGER :: i, ncid, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, @@ -60,12 +61,15 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id + $ shear_id,resm_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile - INTEGER :: ising,jsing + REAL(r8) :: resnum,shear,respsi,resm_sing + INTEGER, DIMENSION(msing) :: resm + + INTEGER :: ising,jsing,m COMPLEX(r8), DIMENSION(msing,msing) :: ap,bp,gammap,deltap LOGICAL, PARAMETER :: debug_flag = .FALSE. @@ -153,6 +157,13 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_dim(ncid, "psi_n", sq%mx+1, p_dim) ) CALL check( nf90_def_var(ncid, "psi_n", nf90_double, p_dim, p_id)) IF(msing>0)THEN + mvec=(/(m,m=mlow,mhigh)/) + DO i=1,msing + respsi=sing(i)%psifac + resnum=NINT(sing(i)%q*nn)-mlow+1 + resm_sing=mvec(resnum) + resm(i)=resm_sing + ENDDO CALL check( nf90_def_dim(ncid,"lr_index",2*msing,l_dim) ) CALL check( nf90_def_var(ncid,"lr_index",nf90_int,l_dim,l_id)) CALL check( nf90_def_dim(ncid,"lr_prime",2*msing,lp_dim) ) @@ -168,6 +179,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) + CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, + $ resm_id) ) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" @@ -223,8 +236,20 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) + + !mvec=(/(m,m=mlow,mhigh)/) + !DO i=1,msing + ! respsi=sing(i)%psifac + ! CALL spline_eval(sq,respsi,1) + ! resnum=NINT(sing(i)%q*2.0)-mlow+1 + ! shear=mvec(resnum)*sq%f1(4)/sq%f(4)**2 + ! WRITE(*,*)"SHEAR=",shear + !ENDDO + CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? + CALL check( nf90_put_var(ncid,resm_id, resm) ) + ! CALL check( nf90_put_var(ncid,shear_id,shear) ) ! GPEC HAS DIFFERENT SHEAR CALC? ENDIF IF(debug_flag) PRINT *," - Putting profile variables in netcdf" From f6368033a2949ddee51cef7d0e57f03be0f6a58b Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 26 Jul 2024 12:57:43 -0700 Subject: [PATCH 008/118] WIP: cleaned SLAYER, stability plots --- input/slayer.in | 5 +- slayer/gslayer.f | 329 +++++----------------------- slayer/layerinputs.f | 477 ++++++++++++++++++----------------------- slayer/makefile | 1 - slayer/sglobal.f | 2 +- slayer/slayer.f | 108 ++-------- slayer/slayer_netcdf.f | 262 ++++++++++++++++++---- 7 files changed, 503 insertions(+), 681 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 380c8dea4..ec5858477 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -21,7 +21,7 @@ qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective - inpr=0.1 ! Prantdl number + inpr=1.0 ! Prantdl number inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -38,6 +38,9 @@ inum=400 ! resolution to find error field thresholds. jnum=100 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. + ReQ_num=350 ! resolution for stability scan along Re(Q) axis + ImQ_num=350 ! resolution for stability scan along Im(Q) axis + scan_radius=3 ! stability scan width in Q QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space QPescan_flag=f ! scan (Q,Pe) space for delta and torque. diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 1ed32a727..8238a7316 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -1,6 +1,6 @@ MODULE gslayer_mod - USE sglobal_mod, ONLY: out_unit, r8, mu0, m_p, chag, lnLamb, + USE sglobal_mod, ONLY: out_unit,r8, mu0, m_p, chag, lnLamb, $ Q_e,Q_i,pr,pe,c_beta,ds,tau, $ eta,visc,rho_s,lu,omega_e,omega_i, $ delta_n, @@ -175,256 +175,68 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- -c Subprogram 2. interpolate_slice_at_Q -c Either extract or interpolate a 1D deltas slice at given Q -c----------------------------------------------------------------------- - SUBROUTINE interpolate_slice_at_Q(deltas, Q, inQs_log, - $ slice) - ! Input - REAL(r8), DIMENSION(:, :), INTENT(IN) :: deltas ! 2D delta array - REAL(r8), DIMENSION(:), INTENT(IN) :: inQs_log ! Re(Q) axis - REAL(r8), INTENT(IN) :: Q ! slice value (Q) - ! Output - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: slice - ! Local variables - INTEGER :: NROWS, NCOLS, i_lower, i_upper, j - REAL(r8) :: Q_lower,Q_upper,lower_slice,upper_slice - - slice = 0.0 - ! Extract array dimensions - NROWS = SIZE(deltas, 1) - NCOLS = SIZE(deltas, 2) - ! Allocate slice array (same size as second dimension of deltas) - ALLOCATE(slice(NCOLS)) - ! Find bracketing rows based on Q (assuming sorted x-axis) - i_lower = 1 - DO WHILE (i_lower < NROWS .AND. inQs_log(i_lower+1) < Q) - i_lower = i_lower + 1 - END DO - - ! Check if Q is included in inQs_log (it should be) - IF (inQs_log(i_lower) - Q < 1.0E-6_r8) THEN !!! this threshold could be an issue? - WRITE(*,*)"Indexing slice at Q!" - DO j = 1, NCOLS - slice(j) = deltas(i_lower, j) - END DO - ELSE - - !! Handle cases where Q is outside the range - ! IF (i_lower == 1 .AND. Q < deltas(1, 1)) THEN - ! i_lower = 1 - ! i_upper = 2 - ! ELSE IF (i_lower == NROWS) THEN - ! i_lower = NROWS - 1 - ! i_upper = NROWS - ! ELSE - ! i_upper = i_lower + 1 - ! END IF - - ! Interpolate each element of the slice (along the columns) - DO j = 1, NCOLS - i_upper = i_lower+1 - - lower_slice = deltas(i_lower, j) - upper_slice = deltas(i_upper, j) - Q_lower = deltas(i_lower, 1) - Q_upper = deltas(i_upper, 1) - - slice(j) = (lower_slice + upper_slice )/2.0 - - ! This linear interpolation isn't correct ??? - !slice(j) = lower_slice + - !$ (Q - Q_lower) * (upper_slice - - !$ lower_slice) / (Q_upper - Q_lower) - END DO - END IF - - RETURN - END SUBROUTINE interpolate_slice_at_Q -c----------------------------------------------------------------------- -c Subprogram 3. gamma_from_delta_match -c Interpolate gamma corresponding to delta-deltaprime match -c----------------------------------------------------------------------- - SUBROUTINE gamma_from_delta_match(slice, iinQs, deltap, - $ ImQ_gamma) - ! Inputs - REAL(r8), DIMENSION(:), INTENT(IN) :: slice ! 1D gammas array, i.e. deltas(Q,:) - REAL(r8), DIMENSION(:), INTENT(IN) :: iinQs ! 1D array of gammas, i.e. Im(Q) - REAL(r8), INTENT(IN) :: deltap ! Target outer layer delta prime - ! Output - REAL(r8), INTENT(OUT) :: ImQ_gamma ! Matched gamma(delta = deltaprime), giving growth rate - ! Local variables - INTEGER :: n, i_lower, i_upper, i, j, i_mid - REAL(r8) :: deltap_lower, deltap_upper, slope, - $ lower_val, upper_val,n_poles,dx - REAL(r8), DIMENSION(:), ALLOCATABLE :: temp_slice, temp_iinQs, ! Temporary arrays - $ grad_slice, pospole_gamma, negpole_gamma - - ! Array size check - n = SIZE(slice) - IF (SIZE(iinQs) /= n) THEN - WRITE(*, *) 'ERROR: slice and iinQs arrays - $ must have the same size.' - RETURN - END IF - - ! Allocate temporary arrays - ALLOCATE(temp_slice(n), temp_iinQs(n)) - ALLOCATE(grad_slice(n-1)) ! gradient - - ImQ_gamma = 0.0 - - ! Copy input arrays to temporary arrays - temp_slice = slice - temp_iinQs = iinQs - - ! GRADIENT THRESHOLD IS 50??? - n_poles = 1.0 - ALLOCATE(pospole_gamma(2),negpole_gamma(2)) - pospole_gamma = 1e+20 - negpole_gamma = 1e+20 - - ! Calculate the gradient - DO i = 1, n - 1 - dx = iinQs(i + 1) - iinQs(i) ! Change in x - grad_slice(i) = (slice(i + 1) - slice(i)) / dx ! Slope (gradient) - END DO - - ! Find first match - DO i = 1, n-1 - ! is this a pole point? - IF (((SIGN(1.0,slice(i)) /= SIGN(1.0,slice(i+1))) .AND. - $ ABS(grad_slice(i) > 50))) THEN!.AND. - !$ (SIGN(1.0,grad_slice(i)) /= - !$ SIGN(1.0,grad_slice(i+1)))) THEN - ! it is a pole - IF (slice(i) > 0) THEN - WRITE(*,*)"FOUND A POS POLE ",0.0 - pospole_gamma(n_poles) = iinQs(i) - negpole_gamma(n_poles) = iinQs(i+1) - n_poles = n_poles + 1 - ELSE - WRITE(*,*)"FOUND A NEG POLE ",i - negpole_gamma(n_poles) = iinQs(i) - pospole_gamma(n_poles) = iinQs(i+1) - n_poles = n_poles+1 - END IF - - WRITE(*,*)"n_poles=",n_poles - - IF ((SIGN(1.0,slice(i))<0.0 .AND. deltap0.0 .AND. deltap>slice(i))) THEN - ImQ_gamma = iinQs(i) ! stride value is huge and not captured by our grid, but will be close to the pole - END IF - ELSE - ! Determine which element of the slice is lower and which is upper - IF (slice(i) <= slice(i + 1)) THEN - lower_val = slice(i) - upper_val = slice(i + 1) - ELSE - lower_val = slice(i + 1) - upper_val = slice(i) - END IF - - ! Check if deltap is within the interval - IF ((lower_val <= deltap) .AND. - $ (deltap <= upper_val)) THEN - !ImQ_gamma = (iinQs(i) + iinQs(i+1)) / 2 ! do a better linear interpolation here - - ! Linear interpolation (revised for robustness) - IF (upper_val - lower_val < 1.0E-10_r8) THEN ! Handle nearly equal values - ImQ_gamma = (iinQs(i) + - $ iinQs(i+1)) / 2 - ELSE - slope = (iinQs(i+1) - - $ iinQs(i)) / (upper_val - lower_val) - ImQ_gamma = iinQs(i) + - $ slope * (deltap - lower_val) - END IF - END IF - END IF - END DO - - IF (n_poles > 2) THEN - WRITE(*,*)"Alert: more than two poles detected" - END IF - - - !WRITE(*,*)"temp_iinQs(i_lower)=",temp_iinQs(i_lower) - !WRITE(*,*)"temp_iinQs(i_upper)=",temp_iinQs(i_upper) - !WRITE(*,*)"NEWImQ_gamma=",ImQ_gamma - !WRITE(*,*)"pospole_gamma=",pospole_gamma - !WRITE(*,*)"negpole_gamma=",negpole_gamma - - !WRITE(*,*)"slice=",slice - - ! Deallocate temporary arrays - DEALLOCATE(temp_slice, temp_iinQs) - - RETURN - END SUBROUTINE gamma_from_delta_match -c----------------------------------------------------------------------- -c Subprogram 4. gamma_stability_scan +c Subprogram 2. gamma_stability_scan c Run grid packed slayer stab. scan around omega_ExB and gamma axes c----------------------------------------------------------------------- SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,ReQ_num,ImQ_num,deltas, - $ inQs_log,iinQs) + $ inds,intau,inQ0,inpr,inpe,ReQ_num,ImQ_num,scan_radius, + $ deltas,inQs,iinQs) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - REAL(r8),INTENT(IN) :: qval,inQ_e,inQ_i,inc_beta,inds, + REAL(r8),INTENT(IN) :: inQ_e,inQ_i,inc_beta,inds, $ intau,inQ0,inpr,inpe REAL(r8), INTENT(IN) :: inQ ! REAL??? - INTEGER, INTENT(IN) :: ReQ_num,ImQ_num + INTEGER, INTENT(IN) :: qval,ReQ_num,ImQ_num,scan_radius ! Outputs COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, $ INTENT(OUT) :: deltas REAL(r8), DIMENSION(:), ALLOCATABLE, - $ INTENT(OUT) :: inQs_log,iinQs + $ INTENT(OUT) :: inQs,iinQs ! Local variables INTEGER :: i,j,k - REAL(r8) :: inQ_min,inQ_max + REAL(r8) :: Re_inQ_min,Re_inQ_max,Im_inQ_min,Im_inQ_max CHARACTER(3) :: q_str CHARACTER(len=8) :: fmt ! format descriptor for stab file naming CHARACTER(len=8) :: x1 ! string for stab file naming INTEGER :: i1 ! integer for stab file naming - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: inQs_left,inQs_right - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs + !REAL(r8), DIMENSION(:,:), ALLOCATABLE :: inQs_left,inQs_right + !REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log c----------------------------------------------------------------------- c Build exponential grid packing for stability scan, then run c----------------------------------------------------------------------- ! Allocate grid packing arrays and 2D complex deltas array - ALLOCATE(inQs(0:ReQ_num),iinQs(0:ImQ_num)) - ALLOCATE(inQs_left(0:2+ReQ_num/2,0:2+ReQ_num/2)) - ALLOCATE(inQs_right(0:2+ReQ_num/2,0:2+ReQ_num/2)) - ALLOCATE(inQs_log(0:3+ReQ_num)) + ALLOCATE(inQs(0:ReQ_num+1),iinQs(0:ImQ_num)) + !ALLOCATE(inQs_left(0:2+ReQ_num/2,0:2+ReQ_num/2)) + !ALLOCATE(inQs_right(0:2+ReQ_num/2,0:2+ReQ_num/2)) + !ALLOCATE(inQs_log(0:3+ReQ_num)) ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) - inQ_max=3.0 ! max growth rate in scan, OPEN TO USER? - inQ_min=-3.0 ! min growth rate in scan, OPEN TO USER? + Im_inQ_max=scan_radius ! max growth rate in scan, OPEN TO USER? + Im_inQ_min=-scan_radius ! min growth rate in scan, OPEN TO USER? + Re_inQ_max=scan_radius ! max growth rate in scan, OPEN TO USER? + Re_inQ_min=-scan_radius ! min growth rate in scan, OPEN TO USER? ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? - inQs_left = powspace(inQ-0.5,inQ,1, ! omega-0.5 - $ 2+ReQ_num/2,"upper") - inQs_right = powspace(inQ,inQ+0.5,1, ! omega+0.5 - $ 2+ReQ_num/2,"lower") - inQs_log = (/inQs_left(1,1:2+ReQ_num/2), - $ inQs_right(1,2:1+ReQ_num/2)/) - !WRITE(*,*)"inQs_log=",inQs_log + !inQs_left = powspace(inQ-Re_inQ_max,inQ,1, ! omega-3.0 + !$ 2+ReQ_num/2,"upper") + !inQs_right = powspace(inQ,inQ+Re_inQ_max,1, ! omega+3.0 + !$ 2+ReQ_num/2,"lower") + !inQs_log = (/inQs_left(1,1:2+ReQ_num/2), + !$ inQs_right(1,2:1+ReQ_num/2)/) + + inQs = linspace((Re_inQ_min+inQ),(Re_inQ_max+inQ),ReQ_num+1) DO i=0,ReQ_num+1 DO j=0,ImQ_num - ! Getting rid of "inQs" weirdly broke things?? - inQs(i)=inQ_min+(REAL(i)/ReQ_num)*(inQ_max-inQ_min) - iinQs(j)=inQ_min+(REAL(j)/ImQ_num)*(inQ_max-inQ_min) + iinQs(j)=Im_inQ_min+(REAL(j)/ImQ_num)*(Im_inQ_max- + $ Im_inQ_min) ! Run riccati() at each Q index to give delta - deltas(i,j)=riccati(inQs_log(i),inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) + deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ! NOT USING GRID PACKING ENDDO ENDDO c----------------------------------------------------------------------- @@ -441,55 +253,50 @@ SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, DO i=0,ReQ_num+1 DO j=0,ImQ_num WRITE(out_unit,'(1x,4(es17.8e3))') - $ inQs_log(i),iinQs(j), + $ inQs(i),iinQs(j), $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) ENDDO ENDDO CLOSE(out_unit) - DEALLOCATE(inQs_left,inQs_right) - RETURN END SUBROUTINE gamma_stability_scan c----------------------------------------------------------------------- -c Subprogram 5. gamma_match -c Loop stability scans and gamma matches across k rational surfaces +c Subprogram 3. gamma_match +c Loop stability across k rational surfaces c----------------------------------------------------------------------- SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr, + $ inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr, - $ ReQ_num,ImQ_num,growthrates,growthrate_err) + $ ReQ_num,ImQ_num,scan_radius) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - REAL(r8), DIMENSION(:), INTENT(IN) :: qval_arr,inQ_e_arr, + REAL(r8), DIMENSION(:), INTENT(IN) :: inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, $ inQ_arr,psi_n_rational + INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr REAL(r8), DIMENSION(:), INTENT(IN) :: outer_delta_arr - INTEGER, INTENT(IN) :: ReQ_num,ImQ_num + INTEGER, INTENT(IN) :: ReQ_num,ImQ_num,scan_radius ! Outputs - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: - $ growthrates, growthrate_err + REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates ! Local variables INTEGER :: n_k ! Number of rational surfaces INTEGER :: k,w ! Local variables received from internal subroutines - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log,iinQs + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_slices + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_slices,all_inQs REAL(r8), DIMENSION(:), ALLOCATABLE :: slice - REAL(r8), DIMENSION(3) :: Q_range ! (-Q_err, Q, +Q_err ) - REAL(r8), DIMENSION(3) :: growthrate_range ! (-gamma, +gamma ) REAL(r8) :: layer_Q, ImQ_gamma n_k = SIZE(qval_arr) ! Allocate growthrates arrays ALLOCATE(growthrates(n_k)) - ALLOCATE(growthrate_err(n_k)) c----------------------------------------------------------------------- c Loop across rational surfaces @@ -499,62 +306,32 @@ SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, ! given omega_ExB (Q), then find growth rate corresponding ! to delta-deltaprime match DO k=1,n_k - WRITE(*,*)"layer #: ",k + WRITE(*,*) "Scanning q=", qval_arr(k), " rational surface" ! Run stability scan CALL gamma_stability_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ ReQ_num,ImQ_num,deltas,inQs_log,iinQs) + $ ReQ_num,ImQ_num,scan_radius,deltas,inQs,iinQs) layer_Q = inQ_arr(k) ! REAL??? - ! Hardcoding rudimentary +/- 10% omega_ExB errorbars - Q_range = (/0.9*layer_Q, 1.1*layer_Q, layer_Q/) - - ! Calculate growth rate +/- omega_ExB = Q errorbars - DO w=1,3 - IF (w==3) THEN - - ! Slice out growth rates at layer_Q (Re(Q)) - CALL interpolate_slice_at_Q(REAL(deltas), - $ Q_range(w), inQs_log, slice) - ! Match delta to delta prime to obtain growth rate - CALL gamma_from_delta_match(slice, iinQs, - $ outer_delta_arr(k), - $ ImQ_gamma) - CALL gamma_from_delta_match(slice, iinQs, - $ outer_delta_arr(k), - $ ImQ_gamma) - ! Qconv = Q / omega_ExB - ! gamma = Im(Q) / Qconv - growthrates(k) = ImQ_gamma / (layer_Q / omegas_arr(k)) - !ELSE - ! growthrate_range(w) = ImQ_gamma / (layer_Q / omegas(k)) - ENDIF - - ENDDO - growthrate_err(k) = ABS(growthrate_range(2) - - $ growthrate_range(1)) - - ALLOCATE(all_RE_deltas(SIZE(inQs_log),SIZE(iinQs),n_k)) - ALLOCATE(all_slices(SIZE(iinQs),n_k)) + IF (k==1) THEN + ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) + ALLOCATE(all_slices(SIZE(iinQs),n_k), + $ all_inQs(SIZE(inQs),n_k)) + ENDIF all_RE_deltas(:,:,k) = REAL(deltas) - all_slices(:,k) = slice - - DEALLOCATE(slice) ! Free memory after use for each layer - + all_inQs(:,k) = inQs ENDDO - CALL slayer_netcdf_out(n_k,SIZE(inQs_log),SIZE(iinQs),qval_arr, - $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr,psi_n_rational, - $ all_Re_deltas,all_slices) + CALL slayer_netcdf_out(n_k,SIZE(inQs),SIZE(iinQs),qval_arr, + $ inQs,iinQs,growthrates,omegas_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,psi_n_rational, + $ all_Re_deltas,all_inQs) DEALLOCATE(deltas) - WRITE(*,*)"inQs_log len ",SIZE(inQs_log) - WRITE(*,*)"iinQs len ",SIZE(iinQs) - RETURN END SUBROUTINE gamma_match diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 8a68f23c2..cf3b0d675 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -1,20 +1,15 @@ MODULE layerinputs_mod USE inputs, ONLY : read_kin,read_equil,kin,chi1 - !USE params - USE dcon_interface, ONLY : set_geom,geom - !USE direct_mod, ONLY : direct_run USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, $ spline_dealloc,spline_int,spline_fit USE sglobal_mod, ONLY: m_p, chag, lnLamb, - $ Q_e,Q_i,pr,pe,c_beta,ds,tau,mu0,r8, ! NOT out_unit + $ Q_e,Q_i,pr,pe,c_beta,ds,tau,r8,mu0,pi,out_unit, ! NOT out_unit $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q USE netcdf - USE pentrc_interface, ONLY : pentrc_timer=>timer - !USE equil_mod - !USE equil_out_mod - - ! STILL NEED ro AND bt0, GLOBAL GPEC VARIABLES + USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq + USE bicube_mod, ONLY: bicube_eval_external,bicube_type + USE slayer_netcdf_mod, ONLY: slayer_netcdf_inputs IMPLICIT NONE @@ -41,22 +36,20 @@ SUBROUTINE check(stat) RETURN END SUBROUTINE check c----------------------------------------------------------------------- -c Read and build equilibrium inputs +c subprogram 2. read_stride_netcdf_diagonal. +c Read STRIDE netcdf file for SLAYER inputs only. c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ dp_diagonal, q_rational, psi_n_rational, shear, - $ ro,bt0,psio,mpsi,nn,resm) - - !USE netcdf ! NetCDF module for Fortran - !USE stride_netcdf_mod ! For the 'check' subroutine (error handling) + $ r_o,my_bt0,my_psio,mpsi,nn,resm) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, $ psi_n_rational, shear - REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: ro,bt0,psio, - $ mpsi + REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, + $ my_psio,mpsi INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm INTEGER, INTENT(OUT) :: msing @@ -72,7 +65,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, $ msing_len,nn_len ! Attribute lengths - ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) WRITE(*,*)"ncfile=",ncfile @@ -100,15 +92,16 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, bt0_id=0 !!!!! THIS COULD BE A PROBLEM - stat = nf90_inquire_attribute(ncid,psio_id,"psio",len = psio_len) + stat = nf90_inquire_attribute(ncid,psio_id,"psio",len=psio_len) CALL check(stat) - stat = nf90_inquire_attribute(ncid,mpsi_id,"mpsi",len = mpsi_len) + stat = nf90_inquire_attribute(ncid,mpsi_id,"mpsi",len=mpsi_len) CALL check(stat) stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) CALL check(stat) - ALLOCATE(bt0(INT(bt0_len)),ro(INT(ro_len)),psio(INT(psio_len)), + ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), + $ my_psio(INT(psio_len)), $mpsi(INT(mpsi_len)),nn(INT(nn_len))) ! Get Variable IDs @@ -123,18 +116,13 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, stat = nf90_inq_varid(ncid, "resm", resm_id) CALL check(stat) - ! Read Data from NetCDF File - ! Set up start and count for reading only the diagonal - !start(1) = 1 - !count(1) = 1 - ! Get attributes - stat = nf90_get_att(ncid, ro_id, "ro", ro) + stat = nf90_get_att(ncid, ro_id, "ro", r_o) CALL check(stat) - stat = nf90_get_att(ncid, bt0_id, "bt0", bt0) + stat = nf90_get_att(ncid, bt0_id, "bt0", my_bt0) CALL check(stat) - stat = nf90_get_att(ncid, psio_id, "psio", psio) + stat = nf90_get_att(ncid, psio_id, "psio", my_psio) CALL check(stat) stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) CALL check(stat) @@ -165,8 +153,95 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, END SUBROUTINE read_stride_netcdf_diagonal c----------------------------------------------------------------------- -c subprogram 1. build_inputs. -c compute +c subprogram 2. issurfint. +c surface integration by simple method. +c----------------------------------------------------------------------- + FUNCTION issurfint(func,fs,inpsi,wegt,ave, + $ fsave,psave,jacs,delpsi,inr,ina,first) +c----------------------------------------------------------------------- +c declaration. +c----------------------------------------------------------------------- + !IMPLICIT NONE + INTEGER, INTENT(IN) :: fs,wegt,ave + REAL(r8), INTENT(IN) :: inpsi + REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func + + LOGICAL, INTENT(INOUT) :: first + INTEGER, INTENT(INOUT) :: fsave + REAL(r8), INTENT(INOUT) :: psave + REAL(r8),DIMENSION(0:),INTENT(INOUT) :: jacs,delpsi,inr,ina + INTEGER :: itheta, ix, iy + REAL(r8) :: issurfint + REAL(r8) :: rfac,ineta,injac,inarea + REAL(r8), DIMENSION(1,2) :: w + REAL(r8), DIMENSION(0:fs) :: z,thetas + REAL(r8), dimension(4) :: rzphi_f, rzphi_fx, rzphi_fy + + issurfint=0 + inarea=0 + ix = 0 + iy = 0 + IF(first .OR. inpsi/=psave .OR. fs/=fsave)THEN + psave = inpsi + fsave = fs + !first = .FALSE. + DO itheta=0,fs + thetas(itheta) = REAL(itheta,r8)/REAL(fs,r8) + ENDDO + DO itheta=0,fs-1 + CALL bicube_eval_external(rzphi, inpsi, thetas(itheta), 1, + $ ix, iy, rzphi_f, rzphi_fx, rzphi_fy) + rfac=SQRT(rzphi_f(1)) + ineta=twopi*(thetas(itheta)+rzphi_f(2)) + ina(itheta)=rfac + inr(itheta)=ro+rfac*COS(ineta) + z(itheta)=zo+rfac*SIN(ineta) + injac=rzphi_f(4) + jacs(itheta)=injac + w(1,1)=(1+rzphi_fy(2))*twopi**2*rfac*inr(itheta)/injac + w(1,2)=-rzphi_fy(1)*pi*inr(itheta)/(rfac*injac) + delpsi(itheta)=SQRT(w(1,1)**2+w(1,2)**2) + ENDDO + ENDIF + + IF (wegt==0) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE IF (wegt==1) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE IF (wegt==2) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs + ENDDO + ELSE IF (wegt==3) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE + STOP "ERROR: issurfint wegt must be in [0,1,2,3]" + ENDIF + + IF (ave==1) THEN + DO itheta=0,fs-1 + inarea=inarea+jacs(itheta)*delpsi(itheta)/fs + ENDDO + issurfint=issurfint/inarea + ENDIF +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- + RETURN + END FUNCTION issurfint +c----------------------------------------------------------------------- +c subprogram 3. build_inputs. +c build input arrays for SLAYER c----------------------------------------------------------------------- SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, $ growthrate_flag, @@ -179,12 +254,11 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, c----------------------------------------------------------------------- LOGICAL, INTENT(IN) :: growthrate_flag REAL(r8), INTENT(IN) ::slayer_inpr - + LOGICAL :: firstsurf REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf, $ ising - INTEGER :: zi, zimp, mi, mimp - REAL(r8) :: nfac,tfac,wefac,wpfac,e,pi,twopi + REAL(r8) :: nfac,tfac,wefac,wpfac,e!,pi,twopi TYPE(spline_type) :: spl TYPE(spline_type) :: sr @@ -192,97 +266,67 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, INTEGER :: mms,nns,mrs,nrs,mpsi REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ qval,sval,bt,rs,zeff,inpe,R0 + $ my_qval,my_sval,my_bt,my_rs,zeff,inpe,R_0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr, + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ inQ_arr,inQ_e_arr,psi_n_rational, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, - $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr + $ inpr_arr,inpe_arr,omegas_arr, + $ outer_delta_arr + INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, - $ shear,ro,bt0,psio,mpsi_arr - INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm - INTEGER :: msing,i + $ shear,r_o,my_bt0,my_psio,mpsi_arr, + $ omegas_e_arr,omegas_i_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, + $ ti_arr,zeff_arr,bt_arr,rs_arr, + $ R0_arr,mu_i_arr + INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm,nns_arr + INTEGER :: msing,i,mthsurf + REAL(r8), DIMENSION(0:512) :: unitfun + INTEGER :: fsave + REAL(r8) :: psave + REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs,delpsi,rsurf,asurf + REAL(r8) :: rfac,jac,a_surf + CHARACTER(512), INTENT(IN) :: infile,ncfile c----------------------------------------------------------------------- c Read in STRIDE netcdf c----------------------------------------------------------------------- - CHARACTER(512), INTENT(IN) :: infile,ncfile - - !character(512) :: - !$ kinetic_file = '/fusion/projects/codes/gpec/users/burgessd/GPEC/ - !$bin/g147131.02300.txt' - !REAL(r8), DIMENSION(:), ALLOCATABLE :: q_rational, q_rational_coords - !REAL(r8), DIMENSION(:), ALLOCATABLE :: Delta_prime, Delta_prime_coords - CALL read_stride_netcdf_diagonal(ncfile, - $ msing, dp_diagonal, q_rational, psi_n_rational, - $ shear, ro, bt0, psio, mpsi_arr,nn,resm) - WRITE(*,*)"msing_out=",msing - WRITE(*,*)"dp_diagonal=",dp_diagonal - WRITE(*,*)"q_rational=",q_rational - WRITE(*,*)"psi_n_rational=",psi_n_rational - WRITE(*,*)"shear=",shear - WRITE(*,*)"ro=",ro - WRITE(*,*)"bt0=",bt0 - WRITE(*,*)"psio=",psio - WRITE(*,*)"nn=",nn - WRITE(*,*)"resm=",resm + $ msing,dp_diagonal,q_rational,psi_n_rational, + $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm) + !WRITE(*,*)"msing_out=",msing + !WRITE(*,*)"dp_diagonal=",dp_diagonal + !!!WRITE(*,*)"q_rational=",q_rational + !WRITE(*,*)"psi_n_rational=",psi_n_rational + !WRITE(*,*)"shear=",shear + !WRITE(*,*)"r_o=",r_o + !WRITE(*,*)"my_bt0=",my_bt0 + !WRITE(*,*)"my_psio=",my_psio + !WRITE(*,*)"nn=",nn + !WRITE(*,*)"resm=",resm mpsi = INT(mpsi_arr(1)) - WRITE(*,*)"mpsi=",mpsi + mthsurf = 512 - !CALL READ_Q_RATIONAL_AND_DELTA_PRIME_FROM_NETCDF( - !& filename, q_rational, q_rational_coords, - !& Delta_prime, Delta_prime_coords) ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), - $ inQ_i_arr(msing), - $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), - $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), - $ omegas_arr(msing),outer_delta_arr(msing)) - !ALLOCATE(my_rhotor(mpsi),my_psitor(1)) - !DEALLOCATE(q_rational, q_rational_coords, Delta_prime, Delta_prime_coords) -c----------------------------------------------------------------------- -c Read and build equilibrium inputs -c----------------------------------------------------------------------- - - !======================================================================= - !subroutine read_kin(file,zi,zimp,mi,mimp,nfac,tfac,wefac,wpfac,write_log) - !----------------------------------------------------------------------- - !*DESCRIPTION: - ! Read ascii file containing table of kinetic profiles ni, ne, ti, - ! te, and omegaE, then form kin spline containing some additional - ! information (krook nui,nue). - ! - ! Assumes table consists of 6 columns: psi_n, n_i(m^-3), n_e(m^-3), - ! T_i(eV), T_e(eV), omega_E(rad/s). File can (nearly) arbitrary - ! header and/or footer, with the exception that no lines start with - ! a number. - ! - !*ARGUMENTS: - ! file : character(256) (in) - ! File path. - ! zi : integer - ! Ion charge in fundamental units - ! zimp : integer - ! Impurity ion charge in fundamental units - ! mi : integer - ! Ion mass in fundamental units (mass proton) - ! mimp : integer - ! Impurity ion mass in fundamental units - ! wefac : real - ! Direct multiplier for omegaE profiles - ! wpfac : real - ! Scaling of rotation profile, done via manipulation of omegaE - ! write_log : bool - ! Writes kinetic spline to log file - ! - !----------------------------------------------------------------------- + $ inQ_i_arr(msing), + $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), + $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), + $ omegas_arr(msing),omegas_e_arr(msing),omegas_i_arr(msing), + $ outer_delta_arr(msing)) + ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), + $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), + $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) + + ALLOCATE(jacs(0:mthsurf),delpsi(0:mthsurf), + $ rsurf(0:mthsurf),asurf(0:mthsurf)) c----------------------------------------------------------------------- c set up kin c----------------------------------------------------------------------- @@ -296,196 +340,94 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, wefac = 1.0 wpfac = 1.0 e=1.6021917e-19 - pi = 3.1415926535897932 - twopi = 2*pi - chi1 = twopi*psio(1) + chi1 = twopi*my_psio(1) CALL read_kin(infile,zi,zimp,mi,mimp,nfac, $ tfac,wefac,wpfac,.false.) - ! manually set the perturbed equilibrium displacements - ! use false flat xi and xi' for equal weighting - - !CALL spline_int(sq) - !WRITE(*,*)"sq=",sq - !WRITE(*,*)"mpsi=",mpsi - !CALL spline_alloc(sq,mpsi,4) - - !CALL spline_int(sq) - - !CALL timer(0,out_unit) - !CALL equil_read(out_unit) - !CALL equil_out_global - !CALL equil_out_qfind - - !if(.not. sq%allocated) - !$ stop 'ERROR: Cannot define geometric splines without sq' - - !CALL set_geom - !WRITE(*,*)"geom%f(2)=",geom%fs(:,2) - - - - - ! minor radius defined using toroidal flux. Used for threshold - !CALL spline_int(sq) - !qintb = sq%fsi(mpsi, 4) - !psitor(:) = sq%fsi(:, 4) / qintb ! normalized toroidal flux - !rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen - !CALL spline_alloc(sr,mpsi,1) - !sr%xs = sq%xs - !sr%fs(:, 1) = rhotor(:) - !CALL spline_fit(sr,"extrap") - - - !WRITE(*,*)"twopi*psio / (pi * bt0)=",twopi*psio / (pi * bt0) - !WRITE(*,*)"sq%fsi(:, 4)=",sq%fsi(:, 4) - !WRITE(*,*)"sq%fsi(:, 4)*twopi*psio / (pi * bt0)=" - !$(twopi*psio / (pi * bt0))* - !DO i=1,mpsi - ! WRITE(*,*)"spline(i)=",sq%fsi(i, 4) - ! WRITE(*,*)"(i)=",SIZE(SQRT(sq%fsi(i, 4)*(twopi*psio / - !$(pi * bt0)))) - ! my_psitor = REAL(sq%fsi(i, 4)) - !WRITE(*,*)"my_psitor(1)=",my_psitor(1) - !WRITE(*,*)"(my_psitor(1))=",my_psitor(1) - !WRITE(*,*)"(my_rhotor(i))=",my_rhotor(i) - !my_rhotor(i)=SQRT(my_psitor(1)*(twopi*psio / - !$(pi * bt0))) - - !ENDDO - !WRITE(*,*)"rhotor=",rhotor + CALL equil_read(out_unit) c----------------------------------------------------------------------- c loop across singular surfaces, evaluate spline quantities. c----------------------------------------------------------------------- - ! j_c is j_c/(chi1*sq%f(4)) + DO ising=1,msing - !resnum(ising)=NINT(singtype(ising)%q*nn)-mlow+1 - !respsi=singtype(ising)%psifac - !CALL spline_eval(sq,respsi,1) + respsi = psi_n_rational(ising) WRITE(*,*)"respsi=",respsi - WRITE(*,*)"chi1=",chi1 + WRITE(*,*)"ising=",ising + + firstsurf = .TRUE. + unitfun = 1 + + ! Minor radius! + a_surf = issurfint(unitfun,mthsurf,respsi,3,1, + $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) -c----------------------------------------------------------------------- -c prepare layer analysis. -c----------------------------------------------------------------------- - !resm = mfac(resnum(ising)) - !CALL spline_eval(sr,respsi,1) - CALL spline_eval(kin,respsi,1) - !CALL spline_eval(geom,respsi,1) c----------------------------------------------------------------------- c SLAYER inputs for sing surface c----------------------------------------------------------------------- - - + CALL spline_eval(kin,respsi,1) omega_i=-twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) $ -twopi*kin%f1(3)/(e*zi*chi1) omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) - WRITE(*,*)"omega_i=",omega_i WRITE(*,*)"omega_e=",omega_e - ! Here's where I'm getting these from - !CALL gpec_slayer(kin%f(2),kin%f(4)/e,kin%f(1),kin%f(3)/e, - !$ kin%f(5),kin%f(9),omega_e,omega_i,sq%f(4),sq%f1(4), - !$ bt0,sr%f1(1),ro,mi,slayer_inpr,resm,nn,ascii_flag, - !$ delta_s,psi0,jxb,omega_sol,br_th) - - !singtype(ising)%q = q(ising)? - !resnum=NINT(singtype(ising)%q*nn)-mlow+1 - !shear(ising)=mfac(resnum)*sq%f1(4)/sq%f(4)**2 - n_e = kin%f(2) t_e = kin%f(4)/e n_i = kin%f(1) t_i = kin%f(3)/e zeff = kin%f(9) omega = kin%f(5) - qval = q_rational(ising)!sq%f(4) - sval = shear(ising) ! SHEAR SO MUCH SMALLER THAN BEFORE???? 500 puts it on the root - bt = bt0(1) - rs = 0.167 - R0 = ro(1) - mu_i = mi + my_qval = q_rational(ising)!sq%f(4) + my_sval = shear(ising) ! SHEAR SO MUCH SMALLER THAN BEFORE???? 500 puts it on the root + my_bt = my_bt0(1) + my_rs = a_surf + R_0 = r_o(1) + mu_i = 2.0 + + eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + inpr = slayer_inpr - !!! TEMPORARY - !mm=2 - !nn=1 - !mr = real(mm,4) - !nr = real(nn,4) + ne_arr(ising) = n_e + te_arr(ising) = t_e + ni_arr(ising) = n_i + ti_arr(ising) = t_i + zeff_arr(ising) = zeff + bt_arr(ising) = my_bt + rs_arr(ising) = my_rs + R0_arr(ising) = R_0 + mu_i_arr(ising) = mu_i + mms = resm(ising) nns = nn(1) mrs = real(mms,4) nrs = real(nns,4) - WRITE(*,*)"nns=",nns - WRITE(*,*)"mms=",mms - - WRITE(*,*)"n_e=",n_e - WRITE(*,*)"t_e=",t_e - WRITE(*,*)"n_i=",n_i - WRITE(*,*)"t_i=",t_i - WRITE(*,*)"zeff=",zeff - WRITE(*,*)"omega=",omega - WRITE(*,*)"qval=",qval - WRITE(*,*)"sval=",sval - WRITE(*,*)"bt=",bt - WRITE(*,*)"rs=",rs - WRITE(*,*)"R0=",R0 - WRITE(*,*)"mu_i=",mu_i - WRITE(*,*)"inpr=",inpr - WRITE(*,*)"dp_diagonal(ising)=",dp_diagonal - ! String representations of the m and n mode numbers - !IF (nns<10) THEN - ! WRITE(UNIT=sn,FMT='(I1)') nns - ! sn=ADJUSTL(sn) - !ELSE - ! WRITE(UNIT=sn,FMT='(I2)') nns - !ENDIF - !IF (mms<10) THEN - ! WRITE(UNIT=sm,FMT='(I1)') mms - ! sm=ADJUSTL(sm) - !ELSEIF (mms<100) THEN - ! WRITE(UNIT=sm,FMT='(I2)') mms - ! sm=ADJUSTL(sm) - !ELSE - ! WRITE(UNIT=sm,FMT='(I3)') mms - !ENDIF - - inpe=0.0 ! Waybright added this - - WRITE(*,*)"lnLamb=",lnLamb - WRITE(*,*)"mu_i=",mu_i - WRITE(*,*)"m_p=",m_p + nns_arr = nn(1) + + inpe=0.0!0.0165*inpr ! Waybright added this tau= t_i/t_e ! ratio of ion to electron temperature tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) rho=(mu_i*m_p)*n_e ! mass density - - - - b_l=(nrs/mrs)*nrs*sval*bt/R0 ! characteristic magnetic field - WRITE(*,*)"b_l=",b_l + b_l=(nrs/mrs)*nrs*my_sval*my_bt/R_0 ! characteristic magnetic field v_a=b_l/(mu0*rho)**0.5 ! alfven velocity, B_L IS BROKEN - rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. + rho_s=1.02e-4*(mu_i*t_e)**0.5/my_bt ! ion Lamour by elec. Temp. - tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! alfven time across surface - tau_r=mu0*rs**2.0/eta ! resistive time scale + tau_h=R_0*(mu0*rho)**0.5/(nns*my_sval*my_bt) ! alfven time across surface + tau_r=mu0*my_rs**2.0/eta ! resistive time scale tau_v=tau_r/inpr ! rho*rs**2.0/visc ! viscous time scale - WRITE(*,*)"tau_v=",tau_v ! this one must be anomalous. calculated back from pr. - visc= rho*rs**2.0/tau_v + visc= rho*my_rs**2.0/tau_v lu=tau_r/tau_h ! Lundquist number - WRITE(*,*)"lu=",lu Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole @@ -493,19 +435,16 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i - WRITE(*,*)"Q=",Q ! This is the most critical parameter - ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. + ds=lu**(1.0/3.0)*rho_s/my_rs ! conversion based on Cole. - lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 + lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/my_bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 - WRITE(*,*)"c_beta=",c_beta - delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes - WRITE(*,*)"delta_n=",delta_n + delta_n=lu**(1.0/3.0)/my_rs ! norm factor for delta primes - qval_arr(ising) = qval + qval_arr(ising) = INT(my_qval) inQ_arr(ising)=Q inQ_e_arr(ising)=Q_e inQ_i_arr(ising)=Q_i @@ -514,33 +453,29 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr - inpe_arr(ising) = 0.0 !!! TEMPORARY? + inpe_arr(ising) = inpe!0.0!0.0165*inpr !!! TEMPORARY? omegas_arr(ising) = omega + omegas_e_arr(ising) = omega_e + omegas_i_arr(ising) = omega_i outer_delta_arr(ising) = dp_diagonal(ising) ENDDO - !WRITE(*,*)"qval_arr=",qval_arr - !WRITE(*,*)"inQ_arr=",inQ_arr - !WRITE(*,*)"inQ_e_arr=",inQ_e_arr - !WRITE(*,*)"inQ_i_arr=",inQ_i_arr - !WRITE(*,*)"inc_beta_arr=",inc_beta_arr - !WRITE(*,*)"inds_arr=",inds_arr - !WRITE(*,*)"intau_arr=",intau_arr - !WRITE(*,*)"Q0_arr=",Q0_arr - !!WRITE(*,*)"inpr_arr=",inpr_arr - !WRITE(*,*)"inpe_arr=",inpe_arr - !WRITE(*,*)"omegas_arr=",omegas_arr - !WRITE(*,*)"outer_delta_arr=",outer_delta_arr - - !CALL spline_dealloc(sr) - !CALL cspline_dealloc(fsp_sol) - !CALL gpeq_dealloc + WRITE(*,*)"zeff_arr=",zeff_arr + + CALL slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, + $ zeff_arr,shear,bt_arr,rs_arr,R0_arr,mu_i_arr,resm,nns_arr, + $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr, + $ intau_arr,inpr_arr,inpe_arr,omegas_arr, + $ outer_delta_arr) + c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- RETURN + + END SUBROUTINE build_inputs END MODULE layerinputs_mod \ No newline at end of file diff --git a/slayer/makefile b/slayer/makefile index 29a36dfd3..f6dcca4ad 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -50,7 +50,6 @@ slayer: $(OBJS) cp -f slayer ../bin # dependencies - params.o : sglobal.o delta.o : sglobal.o gslayer.o : sglobal.o delta.o diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 43343bf6d..403b3b6fb 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -12,7 +12,7 @@ MODULE sglobal_mod $ delta_n,layfac,Qconv COMPLEX(r8) :: Q - REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, + REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6022e-19, $ kval=1.3807e-23,lnLamb=17.0 diff --git a/slayer/slayer.f b/slayer/slayer.f index 0ad1047be..092cf5492 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -13,7 +13,7 @@ PROGRAM slayer USE sglobal_mod - USE params_mod + !USE params_mod USE delta_mod, ONLY: riccati,riccati_out, $ parflow_flag,PeOhmOnly_flag @@ -24,7 +24,8 @@ PROGRAM slayer IMPLICIT NONE CHARACTER(512) :: infile,ncfile - INTEGER :: i,j,k,inum,jnum,knum,inn,ReQ_num,ImQ_num,n_k + INTEGER :: i,j,k,inum,jnum,knum,inn, + $ ReQ_num,ImQ_num,n_k,scan_radius INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -49,16 +50,16 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl, $ bal, $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes, - $ inQs_log - REAL(r8), DIMENSION(:), ALLOCATABLE :: qval_arr,inQ_e_arr, + $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, $ inpe_arr,omegas_arr,inQ_arr, $ psi_n_rational + INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: $ outer_delta_arr - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, $ inQs_left,inQs_right REAL(r8) :: spot, slayer_inpr @@ -73,7 +74,8 @@ PROGRAM slayer $ ncfile,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, $ inQ_i,inpr,inpe,inc_beta,inds,intau,inlu,Q0,delta_n_p - NAMELIST/slayer_control/inum,jnum,knum,QPscan_flag,QPscan2_flag, + NAMELIST/slayer_control/inum,jnum,knum,ReQ_num,ImQ_num, + $ scan_radius,QPscan_flag,QPscan2_flag, $ QPescan_flag,QDscan2_flag,Qbscan_flag,Qscan_flag, $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag @@ -115,8 +117,9 @@ PROGRAM slayer inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=100 ! resolution for stab. scan along Re(Q) axis - ImQ_num=200 ! resolution for stab. scan along Im(Q) axis + ReQ_num=350 ! resolution for stab. scan along Re(Q) axis + ImQ_num=350 ! resolution for stab. scan along Im(Q) axis + scan_radius = 3 in_unit=1 out_unit=2 out2_unit=3 @@ -139,8 +142,6 @@ PROGRAM slayer input_flag=.FALSE. infile="" ncfile="" - !ncfile="/fusion/projects/codes/gpec/users/burgessd/GPEC/bin/ - !$stride_output_147131.nc" verbose=.TRUE. ascii_flag=.TRUE. bin_flag=.TRUE. @@ -279,58 +280,6 @@ PROGRAM slayer c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- IF (growthrates_flag) THEN - !n_k=2 - ! ALLOCATE(mms(n_k),nns(n_k),prs(n_k),pes(n_k), - !$ n_es(n_k),t_es(n_k),t_is(n_k),omegas(n_k), - !$ l_ns(n_k),l_ts(n_k),qvals(n_k),svals(n_k), - !$ bts(n_k),rss(n_k),R0s(n_k),mu_is(n_k),zeffs(n_k), - !$ outer_deltas(n_k)) - ! Approximate data for q=2 and q=3, for testing only - ! These are of the form needed to output from - ! upcoming build_inputs.f script, interfacing with equil.f - ! Kinetic inputs (old) - !mms = (/2, 2 /) - !nns = (/1, 1 /) - !prs = (/0.1, 0.005 /) - !pes = (/0.0, 0.0 /) - !n_es = (/7.765e+17, 9.999e+16 /) - !t_es = (/26.0, 2.0 /) - !t_is = (/26.0, 2.0 /) - !l_ns = (/0.2, 0.2 /) - !l_ts = (/0.1, 0.1 /) - !svals = (/729.5, 500.5 /) - !bts = (/1.0, 1.0 /) - !rss = (/0.16, 0.2 /) - !R0s = (/2.0, 2.0 /) - !mu_is = (/2.0, 2.0 /) - !zeffs = (/2.0, 2.0 /) - - - !q_arr = (/2.0, 3.0 /) - !inQ_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) - !inQ_e_arr = (/ 1.9127E-005, 4.6109E-007 /) - !inQ_i_arr = (/ -1.9127E-005, -4.6109E-007 /) - !inc_beta_arr= (/ 3.6809E-003, 3.6635E-004 /) - !inds_arr = (/ 1.4394, 0.1276 /) - !intau_arr = (/ 1.0, 1.0 /) - !inQ0_arr = (/ (2.6744E-003,0.0), (5.5874E-004,0.0) /) - !eta_s = (/ 6.6907E-006, 3.1361E-004 /) - !S_s = (/ 30696266.0, 1956419.0 /) - !inpr_arr = (/0.1, 0.005 /) - !inpe_arr = (/0.0, 0.0 /) - !omegas_arr = (/54530.0, 54530.0 /) - !outer_delta_arr = (/(27.15,0.1), (20.15,0.1) /) - - !CHARACTER(len=256) :: filename = "stride_output_n1.nc" - !REAL(r8), DIMENSION(:), ALLOCATABLE :: q_rational, q_rational_coords - !REAL(r8), DIMENSION(:), ALLOCATABLE :: Delta_prime, Delta_prime_coords - - - - ! WRITE(*,*)"growthrates=",q_rational - - !CALL read_stride_netcdf(filename, q_rational, q_rational_coords, - !$ Delta_prime, Delta_prime_coords) WRITE(*,*)"infile=",infile WRITE(*,*)"ncfile=",ncfile @@ -340,32 +289,17 @@ PROGRAM slayer $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, $ omegas_arr,outer_delta_arr) - WRITE(*,*)"qval_arr=",qval_arr - WRITE(*,*)"inQ_arr=",inQ_arr - WRITE(*,*)"inQ_e_arr=",inQ_e_arr - WRITE(*,*)"inQ_i_arr=",inQ_i_arr - WRITE(*,*)"inc_beta_arr=",inc_beta_arr - WRITE(*,*)"inds_arr=",inds_arr - WRITE(*,*)"intau_arr=",intau_arr - WRITE(*,*)"inQ0_arr=",inQ0_arr - WRITE(*,*)"inpr_arr=",inpr_arr - WRITE(*,*)"inpe_arr=",inpe_arr - WRITE(*,*)"omegas_arr=",omegas_arr - WRITE(*,*)"outer_delta_arr=",outer_delta_arr - WRITE(*,*)"made it to gammamatch=",qval_arr - - !stop + WRITE(*,*)"Safety factor values=",qval_arr + WRITE(*,*)"inQ values=",inQ_arr + WRITE(*,*)"Prantdl numbers=",inpr_arr + WRITE(*,*)"Electron viscosities=",inpe_arr + WRITE(*,*)"Omega ExB values=",omegas_arr + WRITE(*,*)"outer region deltaprimes=",outer_delta_arr CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr, - $ inc_beta_arr,inds_arr,intau_arr, - $ inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,outer_delta_arr, - $ ReQ_num,ImQ_num,growthrates,growthrate_err) - - WRITE(*,*)"growthrates=",growthrates - WRITE(*,*)"growthrate error=",growthrate_err - + $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, + $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, + $ outer_delta_arr,ReQ_num,ImQ_num,scan_radius) ENDIF c----------------------------------------------------------------------- c find solutions based on simple torque balance. diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 33d92c593..b2125d765 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -52,24 +52,23 @@ END SUBROUTINE check c declarations. c ----------------------------------------------------------------------- SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, - $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr,psi_n_rational, - $ all_Re_deltas,all_slices) + $ inQs,iinQs,growthrates,omegas_arr,inQ_arr,inQ_e_arr, + $ inQ_i_arr,psi_n_rational, + $ all_Re_deltas,all_inQs) INTEGER, INTENT(IN) :: msing,ReQ_n,ImQ_n - REAL(r8), DIMENSION(:), INTENT(IN) :: qval_arr, - $ inQs_log,iinQs,growthrates,omegas_arr,inQ_arr, - $ psi_n_rational!,shear - REAL(r8), DIMENSION(:,:), INTENT(IN) :: all_slices + REAL(r8), DIMENSION(:), INTENT(IN) :: + $ inQs,iinQs,growthrates,omegas_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,psi_n_rational!,shear + INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr + REAL(r8), DIMENSION(:,:), INTENT(IN) :: all_inQs REAL(r8), DIMENSION(:,:,:), INTENT(IN) :: all_Re_deltas INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, - $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id, - $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id - !COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et - !CHARACTER(2) :: sn + $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, + $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id,inQs_id CHARACTER(64) :: ncfile - ! INTEGER :: ising,jsing - !COMPLEX(r8), DIMENSION(msing,msing) :: ap,bp,gammap,deltap LOGICAL, PARAMETER :: debug_flag = .FALSE. + CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- @@ -94,24 +93,13 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, IF(debug_flag) PRINT *," - Defining netcdf globals" CALL check( nf90_put_att(ncid,nf90_global,"title", $ "SLAYER outputs")) - ! define global attributes - !CALL check( nf90_put_att(ncid,nf90_global,'ro', ro)) - !CALL check( nf90_put_att(ncid,nf90_global,'psio', psio)) - !CALL check( nf90_put_att(ncid,nf90_global,'bt0', bt0)) !CALL check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) !CALL check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) !CALL check( nf90_put_att(ncid,nf90_global,"n", nn)) - !CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + ! define global attributes ! define dimensions IF(debug_flag) PRINT *," - Defining dimensions in netcdf" - !CALL check( nf90_def_dim(ncid, "i", 2, i_dim) ) - !CALL check( nf90_def_var(ncid, "i", nf90_int, i_dim, i_id) ) - !CALL check( nf90_def_dim(ncid, "m", mpert, m_dim) ) - !CALL check( nf90_def_var(ncid, "m", nf90_int, m_dim, m_id) ) - !CALL check( nf90_def_dim(ncid, "mode", mpert, mo_dim) ) - !CALL check( nf90_def_var(ncid, "mode", nf90_int, mo_dim, mo_id)) - !CALL check( nf90_def_dim(ncid, "psi_n", sq%mx+1, p_dim) ) - !CALL check( nf90_def_var(ncid, "psi_n", nf90_double, p_dim, p_id)) IF(msing>0)THEN CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, @@ -129,6 +117,10 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, $ qsing_dim,omegas_id)) CALL check( nf90_def_var(ncid,"Q",nf90_double, $ qsing_dim,Q_id)) + CALL check( nf90_def_var(ncid,"Q_e",nf90_double, + $ qsing_dim,Q_e_id)) + CALL check( nf90_def_var(ncid,"Q_i",nf90_double, + $ qsing_dim,Q_i_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ qsing_dim,pr_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, @@ -138,22 +130,12 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" - !CALL check( nf90_def_var(ncid, "f", nf90_double, p_dim, f_id) ) - !CALL check( nf90_def_var(ncid, "mu0p", nf90_double, p_dim, mu_id)) - !CALL check( nf90_def_var(ncid, "dvdpsi", nf90_double,p_dim,dv_id)) - !CALL check( nf90_def_var(ncid, "q", nf90_double, p_dim, q_id) ) - !CALL check( nf90_def_var(ncid, "di", nf90_double, p_dim, di_id) ) - !CALL check( nf90_def_var(ncid, "dr", nf90_double, p_dim, dr_id) ) - !CALL check( nf90_def_var(ncid, "ca1", nf90_double, p_dim, ca_id)) - !CALL check( nf90_def_var(ncid, "W_p_eigenvector", nf90_double, - !$ (/m_dim, mo_dim, i_dim/), wp_id) ) - !CALL check( nf90_def_var(ncid, "W_p_eigenvalue", nf90_double, - !$ (/mo_dim, i_dim/), wpv_id) ) + IF(msing>0)THEN CALL check( nf90_def_var(ncid, "Re_Delta", nf90_double, $ (/ReQ_dim, ImQ_dim, qsing_dim/), dp_id) ) - CALL check( nf90_def_var(ncid, "slices", nf90_double, - $ (/ImQ_dim, qsing_dim/), slice_id) ) + CALL check( nf90_def_var(ncid, "inQs", nf90_double, + $ (/ReQ_dim, qsing_dim/), inQs_id) ) ENDIF ! end definitions CALL check( nf90_enddef(ncid) ) @@ -162,19 +144,18 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, c ----------------------------------------------------------------------- ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL check( nf90_put_var(ncid,ReQ_id, inQs_log)) + CALL check( nf90_put_var(ncid,ReQ_id, inQs)) CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) CALL check( nf90_put_var(ncid,gamma_id, growthrates)) CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) + CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) + CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL check( nf90_put_var(ncid,qr_id, qval_arr)) - !CALL check( nf90_put_var(ncid,shear_id, shear)) ! IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" - CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas))!, - !$(/ReQ_n,ImQ_n,msing/))) - CALL check( nf90_put_var(ncid,slice_id,all_slices))!, - !$(/ImQ_n,msing/))) + CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas)) + CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- @@ -185,4 +166,197 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, c ----------------------------------------------------------------------- RETURN END SUBROUTINE slayer_netcdf_out +c ----------------------------------------------------------------------- +c declarations. +c ----------------------------------------------------------------------- + SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, + $ zeff_arr,shear,bt_arr,rs_arr,R0_arr,mu_i_arr,resm,nns_arr, + $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr, + $ intau_arr,inpr_arr,inpe_arr,omegas_arr, + $ outer_delta_arr) + + INTEGER, INTENT(IN) :: msing + REAL(r8), DIMENSION(:), INTENT(IN) :: + $ ne_arr,te_arr,ni_arr,ti_arr,zeff_arr,shear,bt_arr,rs_arr, + $ R0_arr,mu_i_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr, + $ inpe_arr,omegas_arr,outer_delta_arr + INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr,resm,nns_arr + + INTEGER :: i, ncid,r_id,qsing_dim,qsing_id,msing_id, + $ i_dim,ne_id,te_id,ni_id,ti_id,zeff_id,shear_id,bt_id,rs_id, + $ R0_id,mu_i_id,resm_id,nns_id,inQ_id,inQ_e_id,inc_beta_id, + $ inds_id,qval_id,inQ_i_id,qr_id, + $ intau_id,inpr_id,inpe_id,omegas_id,outer_delta_id, + $ omegas_e_id,omegas_i_id + + CHARACTER(64) :: ncfile + + LOGICAL, PARAMETER :: debug_flag = .FALSE. + CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' +c ----------------------------------------------------------------------- +c set variables +c ----------------------------------------------------------------------- + ne_id=0 + te_id=0 + ni_id=0 + ti_id=0 + zeff_id=0 + shear_id=0 + bt_id=0 + rs_id=0 + R0_id=0 + mu_i_id=0 + resm_id=0 + nns_id=0 + inQ_id=0 + inQ_e_id=0 + inc_beta_id=0 + inds_id=0 + qval_id=0 + inQ_i_id=0 + qr_id=0 + intau_id=0 + inpr_id=0 + inpe_id=0 + omegas_id=0 + outer_delta_id=0 + omegas_e_id=0 + omegas_i_id=0 + + IF(debug_flag) PRINT *,"Called slayer_netcdf_inputs" + IF (nn<10) THEN + WRITE(UNIT=sn,FMT='(I1)')nn + sn=ADJUSTL(sn) + ELSE + WRITE(UNIT=sn,FMT='(I2)')nn + ENDIF + ncfile = "slayer_inputs_n"//TRIM(sn)//".nc" + IF(debug_flag) PRINT *, ncfile +c ----------------------------------------------------------------------- +c open files +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Creating netcdf files" + CALL check( nf90_create(ncfile, + $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) +c ----------------------------------------------------------------------- +c define global file attributes +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Defining netcdf globals" + CALL check( nf90_put_att(ncid,nf90_global,"title", + $ "SLAYER outputs")) + ! define global attributes + !CALL check( nf90_put_att(ncid,nf90_global,'ro', ro)) + !CALL check( nf90_put_att(ncid,nf90_global,'psio', psio)) + !CALL check( nf90_put_att(ncid,nf90_global,'bt0', bt0)) + !CALL check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) + !CALL check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) + !CALL check( nf90_put_att(ncid,nf90_global,"n", nn)) + CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + ! define dimensions + IF(debug_flag) PRINT *," - Defining dimensions in netcdf" + + IF(msing>0)THEN + CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, + $ qsing_id)) + + CALL check( nf90_def_var(ncid,"ne",nf90_double, + $ qsing_dim,ne_id)) + CALL check( nf90_def_var(ncid,"te",nf90_double, + $ qsing_dim,te_id)) + CALL check( nf90_def_var(ncid,"ni",nf90_double, + $ qsing_dim,ni_id)) + CALL check( nf90_def_var(ncid,"ti",nf90_double, + $ qsing_dim,ti_id)) + CALL check( nf90_def_var(ncid,"zeff",nf90_double, + $ qsing_dim,zeff_id)) + CALL check( nf90_def_var(ncid,"shear",nf90_double, + $ qsing_dim,shear_id)) + CALL check( nf90_def_var(ncid,"bt",nf90_double, + $ qsing_dim,bt_id)) + CALL check( nf90_def_var(ncid,"rs",nf90_double, + $ qsing_dim,rs_id)) + CALL check( nf90_def_var(ncid,"R0",nf90_double, + $ qsing_dim,R0_id)) + CALL check( nf90_def_var(ncid,"mu_i",nf90_double, + $ qsing_dim,mu_i_id)) + CALL check( nf90_def_var(ncid,"resm",nf90_int, + $ qsing_dim,resm_id)) + CALL check( nf90_def_var(ncid,"nns_arr",nf90_int, + $ qsing_dim,nns_id)) + CALL check( nf90_def_var(ncid,"qval",nf90_int, + $ qsing_dim,qval_id)) + CALL check( nf90_def_var(ncid,"q_rational",nf90_double, + $ qsing_dim,qr_id) ) + CALL check( nf90_def_var(ncid,"Q",nf90_double, + $ qsing_dim,inQ_id)) + CALL check( nf90_def_var(ncid,"Q_e",nf90_double, + $ qsing_dim,inQ_e_id)) + CALL check( nf90_def_var(ncid,"Q_i",nf90_double, + $ qsing_dim,inQ_i_id)) + CALL check( nf90_def_var(ncid,"c_beta",nf90_double, + $ qsing_dim,inc_beta_id)) + CALL check( nf90_def_var(ncid,"ds",nf90_double, + $ qsing_dim,inds_id)) + CALL check( nf90_def_var(ncid,"tau",nf90_double, + $ qsing_dim,intau_id)) + CALL check( nf90_def_var(ncid,"pr",nf90_double, + $ qsing_dim,inpr_id)) + CALL check( nf90_def_var(ncid,"pe",nf90_double, + $ qsing_dim,inpe_id)) + CALL check( nf90_def_var(ncid,"omegas",nf90_double, + $ qsing_dim,omegas_id)) + ! CALL check( nf90_def_var(ncid,"omegas_e",nf90_double, + !$ qsing_dim,omegas_e_id)) + ! CALL check( nf90_def_var(ncid,"omegas_i",nf90_double, + !$ qsing_dim,omegas_i_id)) + CALL check( nf90_def_var(ncid,"outer_delta",nf90_double, + $ qsing_dim,outer_delta_id)) + ENDIF + ! define variables + IF(debug_flag) PRINT *," - Defining variables in netcdf" + ! end definitions + CALL check( nf90_enddef(ncid) ) +c ----------------------------------------------------------------------- +c set variables +c ----------------------------------------------------------------------- + ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" + CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) + CALL check( nf90_put_var(ncid,ne_id, ne_arr)) + CALL check( nf90_put_var(ncid,ni_id, ni_id)) + CALL check( nf90_put_var(ncid,te_id, te_id)) + CALL check( nf90_put_var(ncid,ti_id, ti_id)) + CALL check( nf90_put_var(ncid,zeff_id, zeff_arr)) + CALL check( nf90_put_var(ncid,shear_id, shear)) + CALL check( nf90_put_var(ncid,bt_id, bt_arr)) + CALL check( nf90_put_var(ncid,rs_id, rs_arr)) + CALL check( nf90_put_var(ncid,R0_id, R0_arr)) + CALL check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) + CALL check( nf90_put_var(ncid,resm_id, resm)) + CALL check( nf90_put_var(ncid,nns_id, nns_arr)) + !CALL check( nf90_put_var(ncid,qval_id, qval_arr)) + CALL check( nf90_put_var(ncid,inQ_id, inQ_arr)) + CALL check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) + CALL check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) + CALL check( nf90_put_var(ncid,inc_beta_id, inc_beta_arr)) + CALL check( nf90_put_var(ncid,inds_id, inds_arr)) + CALL check( nf90_put_var(ncid,intau_id, intau_arr)) + CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) + CALL check( nf90_put_var(ncid,inpe_id, inpe_arr)) + CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) + !CALL check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) + !CALL check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) + CALL check( nf90_put_var(ncid,outer_delta_id,outer_delta_arr)) + +c ----------------------------------------------------------------------- +c close file +c ----------------------------------------------------------------------- + IF(debug_flag) PRINT *," - Closing netcdf file" + CALL check( nf90_close(ncid) ) +c ----------------------------------------------------------------------- +c terminate. +c ----------------------------------------------------------------------- + RETURN + END SUBROUTINE slayer_netcdf_inputs END MODULE slayer_netcdf_mod \ No newline at end of file From ca094bb4d34ce3ae33aaae2c93d2bd36be8e8084 Mon Sep 17 00:00:00 2001 From: d-burg Date: Sat, 27 Jul 2024 19:55:23 -0700 Subject: [PATCH 009/118] WIP: new arraylike inPr handling --- slayer/layerinputs.f | 59 +++++++++++++++++++++++------------------- slayer/slayer.f | 2 +- stride/stride_netcdf.f | 6 ++++- 3 files changed, 38 insertions(+), 29 deletions(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index cf3b0d675..3628358f9 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -41,13 +41,13 @@ END SUBROUTINE check c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ dp_diagonal, q_rational, psi_n_rational, shear, - $ r_o,my_bt0,my_psio,mpsi,nn,resm) + $ r_o,my_bt0,my_psio,mpsi,nn,resm,prandtl) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, - $ psi_n_rational, shear + $ psi_n_rational, shear, prandtl REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, $ my_psio,mpsi INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm @@ -58,7 +58,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Internal Variables INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, - $ msing_id,nn_id,resm_id ! Explicit kind for NetCDF variables + $ msing_id,nn_id,resm_id,prandtl_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i @@ -67,7 +67,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) - WRITE(*,*)"ncfile=",ncfile CALL check(stat) ! Error handling stat = nf90_inquire_attribute(ncid,msing_id,"msing", @@ -82,7 +81,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Allocate Arrays (based on dimension) ALLOCATE(dp_diagonal(msing),q_rational(msing), $ psi_n_rational(msing),shear(msing), - $ resm(msing)) + $ resm(msing),prandtl(msing)) ALLOCATE(delta_prime(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) @@ -90,7 +89,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, stat = nf90_inquire_attribute(ncid,bt0_id,"bt0",len=bt0_len) CALL check(stat) - bt0_id=0 !!!!! THIS COULD BE A PROBLEM stat = nf90_inquire_attribute(ncid,psio_id,"psio",len=psio_len) CALL check(stat) @@ -100,6 +98,12 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) CALL check(stat) + bt0_id=0 !!!!! THIS COULD BE A PROBLEM + nn_id=0 + mpsi_id=0 + psio_id=0 + ro_id=0 + ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), $ my_psio(INT(psio_len)), $mpsi(INT(mpsi_len)),nn(INT(nn_len))) @@ -113,9 +117,10 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, CALL check(stat) stat = nf90_inq_varid(ncid, "shear", shear_id) CALL check(stat) + stat = nf90_inq_varid(ncid, "prandtl", prandtl_id) + CALL check(stat) stat = nf90_inq_varid(ncid, "resm", resm_id) CALL check(stat) - ! Get attributes stat = nf90_get_att(ncid, ro_id, "ro", r_o) CALL check(stat) @@ -139,6 +144,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, CALL check(stat) stat = nf90_get_var(ncid, shear_id, shear) CALL check(stat) + stat = nf90_get_var(ncid, prandtl_id, prandtl) + CALL check(stat) stat = nf90_get_var(ncid, resm_id, resm) CALL check(stat) @@ -281,7 +288,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, $ shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr + $ omegas_e_arr,omegas_i_arr,prandtl REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, $ ti_arr,zeff_arr,bt_arr,rs_arr, $ R0_arr,mu_i_arr @@ -299,18 +306,19 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, c Read in STRIDE netcdf c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile, - $ msing,dp_diagonal,q_rational,psi_n_rational, - $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm) - !WRITE(*,*)"msing_out=",msing - !WRITE(*,*)"dp_diagonal=",dp_diagonal - !!!WRITE(*,*)"q_rational=",q_rational - !WRITE(*,*)"psi_n_rational=",psi_n_rational - !WRITE(*,*)"shear=",shear - !WRITE(*,*)"r_o=",r_o - !WRITE(*,*)"my_bt0=",my_bt0 - !WRITE(*,*)"my_psio=",my_psio - !WRITE(*,*)"nn=",nn - !WRITE(*,*)"resm=",resm + $ msing,dp_diagonal,q_rational,psi_n_rational, + $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm,prandtl) + WRITE(*,*)"msing_out=",msing + WRITE(*,*)"dp_diagonal=",dp_diagonal + WRITE(*,*)"q_rational=",q_rational + WRITE(*,*)"psi_n_rational=",psi_n_rational + WRITE(*,*)"shear=",shear + WRITE(*,*)"r_o=",r_o + WRITE(*,*)"my_bt0=",my_bt0 + WRITE(*,*)"my_psio=",my_psio + WRITE(*,*)"nn=",nn + WRITE(*,*)"resm=",resm + WRITE(*,*)"resm=",prandtl mpsi = INT(mpsi_arr(1)) mthsurf = 512 @@ -354,8 +362,6 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, DO ising=1,msing respsi = psi_n_rational(ising) - WRITE(*,*)"respsi=",respsi - WRITE(*,*)"ising=",ising firstsurf = .TRUE. unitfun = 1 @@ -373,7 +379,6 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, $ -twopi*kin%f1(3)/(e*zi*chi1) omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) - WRITE(*,*)"omega_e=",omega_e n_e = kin%f(2) t_e = kin%f(4)/e @@ -390,7 +395,9 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - inpr = slayer_inpr + inpr = prandtl(ising) + + inpe=0.0!0.0165*inpr ! Waybright added this ne_arr(ising) = n_e te_arr(ising) = t_e @@ -409,8 +416,6 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, nns_arr = nn(1) - inpe=0.0!0.0165*inpr ! Waybright added this - tau= t_i/t_e ! ratio of ion to electron temperature tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. rho=(mu_i*m_p)*n_e ! mass density @@ -461,7 +466,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, ENDDO - WRITE(*,*)"zeff_arr=",zeff_arr + !WRITE(*,*)"zeff_arr=",zeff_arr CALL slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, $ zeff_arr,shear,bt_arr,rs_arr,R0_arr,mu_i_arr,resm,nns_arr, diff --git a/slayer/slayer.f b/slayer/slayer.f index 092cf5492..153579355 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -295,7 +295,7 @@ PROGRAM slayer WRITE(*,*)"Electron viscosities=",inpe_arr WRITE(*,*)"Omega ExB values=",omegas_arr WRITE(*,*)"outer region deltaprimes=",outer_delta_arr - + !stop CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 2b5c4936f..6345c8abd 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -61,7 +61,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id + $ shear_id,resm_id,prandtl_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile @@ -179,6 +179,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) + CALL check( nf90_def_var(ncid, "prandtl", nf90_double, r_dim, + $ prandtl_id) ) CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, $ resm_id) ) ENDIF @@ -247,6 +249,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) !ENDDO CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, + $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? + CALL check( nf90_put_var(ncid,prandtl_id, (/(0.0, $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? CALL check( nf90_put_var(ncid,resm_id, resm) ) ! CALL check( nf90_put_var(ncid,shear_id,shear) ) ! GPEC HAS DIFFERENT SHEAR CALC? From a06471b6f545733509f05f11d1306ea1871034fa Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 30 Jul 2024 14:49:51 -0700 Subject: [PATCH 010/118] WIP: dynamic gridding root find backup --- input/slayer.in | 8 +- slayer/gslayer.f | 237 +++++++++++++++++++++++++++++++++++++++-- slayer/layerinputs.f | 24 ++--- slayer/slayer.f | 92 +++++++++++++--- slayer/slayer_netcdf.f | 35 ++++-- 5 files changed, 348 insertions(+), 48 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index ec5858477..3490aab22 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -22,6 +22,7 @@ mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective inpr=1.0 ! Prantdl number + inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -55,14 +56,15 @@ / &SLAYER_OUTPUT verbose=t ! prints progress to terminal - ascii_flag=t ! writes results to ascii files - bin_flag=t ! writes results to binary files + ascii_flag=f ! writes results to ascii files + bin_flag=f ! writes results to binary files netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q growthrates_flag=t ! Calculate growthrates on each rational surface + layer_stabilityscan_flag=t ! Generate Re(Q),Im(Q) scans for each rational surface !bal_flag=f ! calculate the resonant field penetration threshold from torque balance / &SLAYER_DIAGNOSE riccati_out=f ! writes LSDOE Riccati integration to an ascii file - params_check=t ! prints the primary parameters to the terminal when they are calculated + params_check=f ! prints the primary parameters to the terminal when they are calculated / \ No newline at end of file diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 8238a7316..5178eccf7 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -174,6 +174,233 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer + + FUNCTION log_prob(params,inQ,inQ_e,inQ_i,inc_beta,inds, + $ intau,inQ0,inpr,inpe,deltaprime,sigma) RESULT(lp) + real(r8), dimension(2), intent(in) :: params + real(r8), intent(in) :: deltaprime, sigma + real(r8) :: lp, distance + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, + $ intau,inQ0,inpr,inpe + ! Calculate distance from the target value + distance = abs((riccati(params(1), + $ inQ_e, + $ inQ_i, + $ inpr, + $ inc_beta, + $ inds, + $ intau, + $ inpe, + $ iinQ=params(2)) - + $ deltaprime)) + + ! Calculate the log probability (negative log-likelihood of a Gaussian) + lp = -0.5 * (distance / sigma)**2 + RETURN + END FUNCTION log_prob +c----------------------------------------------------------------------- +c Subprogram 2. gamma_stability_scan +c Run grid packed slayer stab. scan around omega_ExB and gamma axes +c----------------------------------------------------------------------- + SUBROUTINE growthrate_search(qval,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,inQ0,inpr,inpe,deltaprime,scan_radius, + $ deltas,inQs,iinQs,roots,growthrate,growthrate_loc) +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + ! Inputs + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, + $ intau,inQ0,inpr,inpe,deltaprime + INTEGER, INTENT(IN) :: qval,scan_radius +c----------------------------------------------------------------------- +c +c----------------------------------------------------------------------- + real(r8), intent(out), dimension(:,:), ALLOCATABLE :: roots ! Array to store (x, y) pairs of zeros + integer :: num_zeros ! Number of zeros found + real(r8), dimension(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs + integer :: n_fine + real(r8), dimension(:), ALLOCATABLE :: x_s,y_s + real(r8) :: x, y, dx, dy, ric_val, grad_x, grad_y + real(r8), dimension(2) :: start, end, step + real(r8) :: zero_tol, grad_tol, wr, delta + integer :: i, j, k, w, n_steps + logical :: found_zero + real(r8), intent(out) :: growthrate_loc, growthrate ! Output (x, y) pair + + integer :: n_points, idx_1, idx_2 + real(r8) :: x_1, y_1, x_2, y_2, dist, min_dist1, min_dist2 + + REAL(r8), DIMENSION(:,:), ALLOCATABLE, + $ INTENT(OUT) :: deltas + wr = inQ+inQ_e + ! Parameters + zero_tol = abs(0.1*deltaprime) ! Tolerance for zero value + grad_tol = 1.0!abs(0.1*deltaprime) ! Tolerance for steep gradient + n_steps = 100 ! Initial number of steps + n_fine = 10 + if (abs(deltaprime)>50) then + n_fine = n_fine * 2 + end if + ALLOCATE(x_s(n_fine),y_s(n_fine)) + ALLOCATE(inQs(n_steps)) + ALLOCATE(roots(10,2)) + ALLOCATE(deltas(n_steps,n_steps)) + + ! Initial coarse grid search + + dx = 2 * dble(scan_radius) / dble(n_steps) + dy = 2 * dble(scan_radius) / dble(n_steps) + num_zeros = 0 + + inQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) + ALLOCATE(iinQs(n_steps)) + + do i = 1, n_steps + x = inQs(i)!wr - scan_radius + (i - 0.5) * dx + do j = 1, n_steps + !y = -scan_radius + (j - 0.5) * dy + y=-scan_radius+(REAL(j)/n_steps)*(scan_radius+ + $ scan_radius) + iinQs(j) = y + delta = REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, + $ intau,inpe,iinQ=y)) + ric_val = abs(delta - deltaprime) + deltas(i,j) = delta + grad_x = 10!(REAL(riccati(x + dx,inQ_e,inQ_i,inpr,inc_beta, + !$ inds,intau,inpe,iinQ=y)) - + !$ REAL(riccati(x - dx,inQ_e,inQ_i,inpr,inc_beta, + !$ inds,intau,inpe,iinQ=y))) / (2 * dx) + grad_y = 10!(REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, + !$ intau,inpe,iinQ=y + dy)) - + !$ REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, + !$ intau,inpe,iinQ=y - dy))) / (2 * dy) + + !WRITE(*,*) "Point", [x,y] + !WRITE(*,*) "ric_val", ric_val + !WRITE(*,*) "grad_x", grad_x + !WRITE(*,*) "grad_y", grad_y + !WRITE(*,*) "[dx,dy]", [dx,dy] + + + if ((abs(ric_val) < zero_tol) .and. ((abs(grad_x) > + $ grad_tol) .or. (abs(grad_y) > grad_tol))) then + ! Potential zero found, refine with a finer grid + !start = [x - 0.1, y - 0.1] + !end = [x + 0.1, y + 0.1] + !step = (end - start) / 20 + !WRITE(*,*) "Potential zero found", [x,y] + ! WRITE(*,*) "dx", dx + ! WRITE(*,*) "dy", dy + ! WRITE(*,*) "step", step + ! WRITE(*,*) "scan_radius", scan_radius + + x_s = linspace((x-0.1),(x+0.1),n_fine) + y_s = linspace((y-0.1),(y+0.1),n_fine) + found_zero = .false. + do k=1,n_fine + do w=1,n_fine + !x_s = start(1) + (k - 0.5) * step(1) + !y_s = start(2) + (k - 0.5) * step(2) + + !WRITE(*,*) "fine point", [x_s(k),y_s(w)] + !WRITE(*,*) "y_s", y_s + !stop + !WRITE(*,*) "fine scan", k + + ric_val = REAL(riccati(x_s(k),inQ_e,inQ_i, + $ inpr,inc_beta,inds,intau,inpe, + $ iinQ=y_s(w))) - deltaprime + !WRITE(*,*) "ric_val", ric_val + + if (abs(ric_val) < abs(0.01*deltaprime)) then + ! Found a zero within tolerance, store it + num_zeros = num_zeros + 1 + roots(num_zeros, 1) = x + roots(num_zeros, 2) = y + WRITE(*,*) "FOUND ROOT #", num_zeros + found_zero=.true. + !exit ! Exit the inner loop since zero is found + end if + if (found_zero==.true.) then + exit + endif + end do + if (found_zero==.true.) then + exit + endif + end do + end if + end do + end do + + ! 1. Find the index of the (x, y) pair with x closest to wr + n_points = size(roots, 1) + min_dist1 = abs(roots(1, 1) - wr) + idx_1 = 1 + + do i = 2, n_points + dist = abs(roots(i, 1) - wr) + if (dist < min_dist1) then + min_dist1 = dist + idx_1 = i + end if + end do + + x_1 = roots(idx_1, 1) + y_1 = roots(idx_1, 2) + + ! 2. Find the index of the next closest (x, y) pair with y more than 0.5 away from y_1 + min_dist2 = huge(min_dist2) ! Initialize to a very large value + idx_2 = 0 ! Initialize to an invalid index + + do i = 1, n_points + if (i /= idx_1 .and. abs(roots(i, 2) - y_1) > 0.5) then ! Check if it's a different point and far enough in y + dist = abs(roots(i, 1) - wr) + if (dist < min_dist2) then + min_dist2 = dist + idx_2 = i + end if + end if + end do + + if (idx_2 > 0) then ! Check if a valid second point was found + x_2 = roots(idx_2, 1) + y_2 = roots(idx_2, 2) + end if + + ! 3. Apply your specific conditions to select the final (x, y) pair + if (idx_2 > 0 .and. abs(x_1 - x_2) < 0.1) then + if (y_1 < 0 .or. y_2 < 0) then ! Choose the pair with negative y + if (y_1 < 0) then + growthrate_loc = x_1 + growthrate = y_1 + else + growthrate_loc = x_2 + growthrate = y_2 + end if + end if + else ! If the x values are far apart, choose the first pair + growthrate_loc = x_1 + growthrate = y_1 + end if +c----------------------------------------------------------------------- +c +c----------------------------------------------------------------------- + ! Allocate grid packing arrays and 2D complex deltas array + !ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) + + !DO i=0,ReQ_num+1 + ! DO j=0,ImQ_num + ! iinQs(j)=Im_inQ_min+(REAL(j)/ImQ_num)*(Im_inQ_max- + !$ Im_inQ_min) + ! ! Run riccati() at each Q index to give delta + ! deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr, + !$ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ! NOT USING GRID PACKING + ! ENDDO + !ENDDO + + RETURN + END SUBROUTINE growthrate_search c----------------------------------------------------------------------- c Subprogram 2. gamma_stability_scan c Run grid packed slayer stab. scan around omega_ExB and gamma axes @@ -269,7 +496,8 @@ SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr, $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr, - $ ReQ_num,ImQ_num,scan_radius) + $ ReQ_num,ImQ_num,scan_radius,inQs,iinQs, + $ all_Re_deltas,all_inQs) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- @@ -287,7 +515,7 @@ SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, INTEGER :: n_k ! Number of rational surfaces INTEGER :: k,w ! Local variables received from internal subroutines - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs + REAL(r8), DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: inQs,iinQs COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_slices,all_inQs @@ -325,11 +553,6 @@ SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, all_inQs(:,k) = inQs ENDDO - CALL slayer_netcdf_out(n_k,SIZE(inQs),SIZE(iinQs),qval_arr, - $ inQs,iinQs,growthrates,omegas_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,psi_n_rational, - $ all_Re_deltas,all_inQs) - DEALLOCATE(deltas) RETURN diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 3628358f9..92333c392 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -41,13 +41,13 @@ END SUBROUTINE check c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ dp_diagonal, q_rational, psi_n_rational, shear, - $ r_o,my_bt0,my_psio,mpsi,nn,resm,prandtl) + $ r_o,my_bt0,my_psio,mpsi,nn,resm) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, - $ psi_n_rational, shear, prandtl + $ psi_n_rational, shear REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, $ my_psio,mpsi INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm @@ -58,7 +58,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Internal Variables INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, - $ msing_id,nn_id,resm_id,prandtl_id ! Explicit kind for NetCDF variables + $ msing_id,nn_id,resm_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i @@ -81,7 +81,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Allocate Arrays (based on dimension) ALLOCATE(dp_diagonal(msing),q_rational(msing), $ psi_n_rational(msing),shear(msing), - $ resm(msing),prandtl(msing)) + $ resm(msing)) ALLOCATE(delta_prime(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) @@ -117,8 +117,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, CALL check(stat) stat = nf90_inq_varid(ncid, "shear", shear_id) CALL check(stat) - stat = nf90_inq_varid(ncid, "prandtl", prandtl_id) - CALL check(stat) stat = nf90_inq_varid(ncid, "resm", resm_id) CALL check(stat) ! Get attributes @@ -144,8 +142,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, CALL check(stat) stat = nf90_get_var(ncid, shear_id, shear) CALL check(stat) - stat = nf90_get_var(ncid, prandtl_id, prandtl) - CALL check(stat) stat = nf90_get_var(ncid, resm_id, resm) CALL check(stat) @@ -250,7 +246,7 @@ END FUNCTION issurfint c subprogram 3. build_inputs. c build input arrays for SLAYER c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, + SUBROUTINE build_inputs(infile,ncfile,inpr_prof, $ growthrate_flag, $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr, @@ -260,7 +256,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, c declarations. c----------------------------------------------------------------------- LOGICAL, INTENT(IN) :: growthrate_flag - REAL(r8), INTENT(IN) ::slayer_inpr + REAL(r8), DIMENSION(8), INTENT(IN) :: inpr_prof LOGICAL :: firstsurf REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf, $ ising @@ -276,7 +272,6 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, $ my_qval,my_sval,my_bt,my_rs,zeff,inpe,R_0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ inQ_arr,inQ_e_arr,psi_n_rational, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, @@ -288,7 +283,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, $ shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr,prandtl + $ omegas_e_arr,omegas_i_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, $ ti_arr,zeff_arr,bt_arr,rs_arr, $ R0_arr,mu_i_arr @@ -307,7 +302,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile, $ msing,dp_diagonal,q_rational,psi_n_rational, - $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm,prandtl) + $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing WRITE(*,*)"dp_diagonal=",dp_diagonal WRITE(*,*)"q_rational=",q_rational @@ -318,7 +313,6 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, WRITE(*,*)"my_psio=",my_psio WRITE(*,*)"nn=",nn WRITE(*,*)"resm=",resm - WRITE(*,*)"resm=",prandtl mpsi = INT(mpsi_arr(1)) mthsurf = 512 @@ -395,7 +389,7 @@ SUBROUTINE build_inputs(infile,ncfile,slayer_inpr, eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - inpr = prandtl(ising) + inpr = inpr_prof(ising) inpe=0.0!0.0165*inpr ! Waybright added this diff --git a/slayer/slayer.f b/slayer/slayer.f index 153579355..671466cf2 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -33,7 +33,7 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,growthrates_flag !FOR TESTING + $ params_check,growthrates_flag,layer_stabilityscan_flag !FOR TESTING REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff @@ -55,14 +55,21 @@ PROGRAM slayer $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, $ inpe_arr,omegas_arr,inQ_arr, - $ psi_n_rational + $ psi_n_rational + REAL(r8), DIMENSION(8) :: inpr_prof + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas, + $ all_roots + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_inQs + REAL(r8),dimension(:, :),ALLOCATABLE :: roots + INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: - $ outer_delta_arr + $ outer_delta_arr, + $ all_growthrates,all_growthrate_locs REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, - $ inQs_left,inQs_right - REAL(r8) :: spot, slayer_inpr + $ inQs_left,inQs_right,coarse_deltas + REAL(r8) :: spot, slayer_inpr, growthrate, growthrate_loc REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas @@ -73,7 +80,8 @@ PROGRAM slayer NAMELIST/slayer_input/params_flag,input_flag,infile, $ ncfile,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, - $ inQ_i,inpr,inpe,inc_beta,inds,intau,inlu,Q0,delta_n_p + $ inQ_i,inpr,inpr_prof,inpe,inc_beta,inds, + $ intau,inlu,Q0,delta_n_p NAMELIST/slayer_control/inum,jnum,knum,ReQ_num,ImQ_num, $ scan_radius,QPscan_flag,QPscan2_flag, $ QPescan_flag,QDscan2_flag,Qbscan_flag,Qscan_flag, @@ -107,6 +115,7 @@ PROGRAM slayer inQ_e=2.0 ! Q_e=2.0 for DIII-D example. inQ_i=-2.6 ! Q_i=-2.6 for DIII-D example. inpr=0.5 ! 0.5 for DIII-D example. + inpr_prof=1.0 inpe=0.1 !I added this inc_beta=0.7 ! c_beta=0.7 for DIII-D example. inds=6.0 ! 6.0 for DIII-D example. @@ -152,6 +161,7 @@ PROGRAM slayer bal_flag=.FALSE. stability_flag=.FALSE. growthrates_flag=.FALSE. + layer_stabilityscan_flag=.FALSE. c----------------------------------------------------------------------- c read slayer.in. c----------------------------------------------------------------------- @@ -280,10 +290,9 @@ PROGRAM slayer c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- IF (growthrates_flag) THEN - WRITE(*,*)"infile=",infile - WRITE(*,*)"ncfile=",ncfile - - CALL build_inputs(infile,ncfile,inpr, + !WRITE(*,*)"infile=",infile + !WRITE(*,*)"ncfile=",ncfile + CALL build_inputs(infile,ncfile,inpr_prof, $ growthrates_flag,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, @@ -295,11 +304,66 @@ PROGRAM slayer WRITE(*,*)"Electron viscosities=",inpe_arr WRITE(*,*)"Omega ExB values=",omegas_arr WRITE(*,*)"outer region deltaprimes=",outer_delta_arr + + n_k = SIZE(qval_arr) + !ALLOCATE(all_growthrates(100,3,n_k)) + + all_RE_deltas(:,:,k) = REAL(deltas) + all_inQs(:,k) = inQs + DO k=1,n_k + WRITE(*,*) "Finding roots on q=", qval_arr(k), + $ " rational surface" + ! Run MCMC + + CALL growthrate_search(qval_arr(k),inQ_arr(k),inQ_e_arr(k), + $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), + $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), + $ outer_delta_arr(k),scan_radius, + $ coarse_deltas,inQs,iinQs,roots, + $ growthrate,growthrate_loc) !stop - CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, - $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, - $ outer_delta_arr,ReQ_num,ImQ_num,scan_radius) + + IF (k==1) THEN + ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) + ALLOCATE(all_inQs(SIZE(inQs),n_k)) + ALLOCATE(all_growthrates(n_k)) + ALLOCATE(all_growthrate_locs(n_k)) + ENDIF + all_RE_deltas(:,:,k) = coarse_deltas + all_inQs(:,k) = inQs + all_roots(:,:,k) = roots + all_growthrates(k) = growthrate + all_growthrate_locs(k) = growthrate_loc + ENDDO + + + !IF (layer_stabilityscan_flag) THEN + ! CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + !$ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, + !$ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, + !$ outer_delta_arr,ReQ_num,ImQ_num,scan_radius, + !$ inQs,iinQs,all_Re_deltas,all_inQs) + !ELSE + ! ALLOCATE(inQs(0:ReQ_num+1),iinQs(0:ImQ_num)) + ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) + ! ALLOCATE(all_inQs(SIZE(inQs),n_k)) + + ! all_RE_deltas = 0.0 + ! all_inQs = 0.0 + ! inQs = 0.0 + ! iinQs = 0.0 + !ENDIF + + CALL slayer_netcdf_out(n_k, + $ SIZE(inQs),SIZE(iinQs),qval_arr, + $ inQs,iinQs,all_roots,all_growthrates, + $ all_growthrate_locs,omegas_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,psi_n_rational, + $ all_Re_deltas,all_inQs) + + !WRITE(*,*)"xroots=",roots(:,1) + !WRITE(*,*)"yroots=",roots(:,2) + !stop ENDIF c----------------------------------------------------------------------- c find solutions based on simple torque balance. diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index b2125d765..217504ae0 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -51,21 +51,28 @@ END SUBROUTINE check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, - $ inQs,iinQs,growthrates,omegas_arr,inQ_arr,inQ_e_arr, + SUBROUTINE slayer_netcdf_out(msing,ReQ_n, + $ ImQ_n,qval_arr, + $ inQs,iinQs,all_roots,all_growthrates,all_growthrate_locs, + $ omegas_arr,inQ_arr,inQ_e_arr, $ inQ_i_arr,psi_n_rational, $ all_Re_deltas,all_inQs) + LOGICAL, PARAMETER :: layer_stabilityscan_flag = .true. INTEGER, INTENT(IN) :: msing,ReQ_n,ImQ_n REAL(r8), DIMENSION(:), INTENT(IN) :: - $ inQs,iinQs,growthrates,omegas_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,psi_n_rational!,shear + $ inQs,iinQs,omegas_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,psi_n_rational, + $ all_growthrates,all_growthrate_locs INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr REAL(r8), DIMENSION(:,:), INTENT(IN) :: all_inQs REAL(r8), DIMENSION(:,:,:), INTENT(IN) :: all_Re_deltas + REAL(r8),DIMENSION(:,:,:),ALLOCATABLE,INTENT(IN) :: + $ all_roots INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, - $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id,inQs_id + $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id,inQs_id, + $ gamma_err_id,gamma_loc_id,roots_dim CHARACTER(64) :: ncfile LOGICAL, PARAMETER :: debug_flag = .FALSE. CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' @@ -109,10 +116,15 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, CALL check( nf90_def_var(ncid,"ReQ_arr",nf90_double,ReQ_dim, $ ReQ_id)) CALL check( nf90_def_dim(ncid,"ImQ_arr",ImQ_n,ImQ_dim) ) !r_dim = q_rational + CALL check( nf90_def_dim(ncid,"nroots",100,roots_dim) ) !r_dim = q_rational CALL check( nf90_def_var(ncid,"ImQ_arr",nf90_double,ImQ_dim, $ ImQ_id)) CALL check( nf90_def_var(ncid,"growthrates",nf90_double, $ qsing_dim,gamma_id)) + CALL check( nf90_def_var(ncid,"growthrate_locs",nf90_double, + $ qsing_dim,gamma_loc_id)) + ! CALL check( nf90_def_var(ncid,"growthrates_inQ",nf90_double, + !$ (/roots_dim, qsing_dim/),gamma_loc_id)) CALL check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) CALL check( nf90_def_var(ncid,"Q",nf90_double, @@ -131,7 +143,7 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" - IF(msing>0)THEN + IF (layer_stabilityscan_flag) THEN CALL check( nf90_def_var(ncid, "Re_Delta", nf90_double, $ (/ReQ_dim, ImQ_dim, qsing_dim/), dp_id) ) CALL check( nf90_def_var(ncid, "inQs", nf90_double, @@ -146,7 +158,6 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) CALL check( nf90_put_var(ncid,ReQ_id, inQs)) CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) - CALL check( nf90_put_var(ncid,gamma_id, growthrates)) CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) @@ -154,8 +165,14 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n,ImQ_n,qval_arr, CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL check( nf90_put_var(ncid,qr_id, qval_arr)) ! IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" - CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas)) - CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) + IF (layer_stabilityscan_flag) THEN + CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas)) + CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) + ENDIF + CALL check( nf90_put_var(ncid,gamma_id,all_growthrates)) + !CALL check( nf90_put_var(ncid,gamma_err_id, + !$ (/(all_growthrates(:,3,i),i=1,msing)/))) + CALL check( nf90_put_var(ncid,gamma_loc_id,all_growthrate_locs)) c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- From 91b3ab099db983821ca5ca105c230997f2b80a3f Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Sun, 15 Sep 2024 20:08:11 -0700 Subject: [PATCH 011/118] WIP: backing up SLAYER AMR --- slayer/gslayer.f | 557 +++++++++++++++-------------------------- slayer/layerinputs.f | 164 ++++++------ slayer/sglobal.f | 6 + slayer/slayer.f | 266 +++++++++++++++----- slayer/slayer_netcdf.f | 225 ++++++++++------- 5 files changed, 623 insertions(+), 595 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 5178eccf7..9c89d6c80 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -1,5 +1,7 @@ MODULE gslayer_mod - + + USE omp_lib + USE sglobal_mod, ONLY: out_unit,r8, mu0, m_p, chag, lnLamb, $ Q_e,Q_i,pr,pe,c_beta,ds,tau, $ eta,visc,rho_s,lu,omega_e,omega_i, @@ -17,7 +19,7 @@ MODULE gslayer_mod USE grid, ONLY : powspace,linspace IMPLICIT NONE - + CONTAINS c----------------------------------------------------------------------- @@ -45,7 +47,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, $ lbeta,tau_i,tau_h,tau_r,tau_v REAL(r8) :: inQ_min,inQ_max,Q_sol - + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal CHARACTER(3) :: sn,sm @@ -95,8 +97,8 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, lu=tau_r/tau_h ! Lundquist number Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - - ! note Q depends on Qconv even if omega is fixed. + + ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i @@ -142,7 +144,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, inQ_max=10.0 inQ_min=-10.0 inum=200 - ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum),bal(0:inum)) + ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum),bal(0:inum)) DO i=0,inum inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) deltal(i)=riccati(inQs(i),inQ_e,inQ_i, @@ -174,388 +176,219 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer - - FUNCTION log_prob(params,inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe,deltaprime,sigma) RESULT(lp) - real(r8), dimension(2), intent(in) :: params - real(r8), intent(in) :: deltaprime, sigma - real(r8) :: lp, distance - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe - ! Calculate distance from the target value - distance = abs((riccati(params(1), - $ inQ_e, - $ inQ_i, - $ inpr, - $ inc_beta, - $ inds, - $ intau, - $ inpe, - $ iinQ=params(2)) - - $ deltaprime)) - - ! Calculate the log probability (negative log-likelihood of a Gaussian) - lp = -0.5 * (distance / sigma)**2 - RETURN - END FUNCTION log_prob c----------------------------------------------------------------------- -c Subprogram 2. gamma_stability_scan -c Run grid packed slayer stab. scan around omega_ExB and gamma axes +c Subprogram 2. growthrate_scan +c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE growthrate_search(qval,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,deltaprime,scan_radius, - $ deltas,inQs,iinQs,roots,growthrate,growthrate_loc) + SUBROUTINE old_growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,inQ0,inpr,inpe,scan_radius,reQ_num, + $ Re_deltas,Im_deltas,inQs,iinQs) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe,deltaprime - INTEGER, INTENT(IN) :: qval,scan_radius -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - real(r8), intent(out), dimension(:,:), ALLOCATABLE :: roots ! Array to store (x, y) pairs of zeros - integer :: num_zeros ! Number of zeros found - real(r8), dimension(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs - integer :: n_fine - real(r8), dimension(:), ALLOCATABLE :: x_s,y_s - real(r8) :: x, y, dx, dy, ric_val, grad_x, grad_y - real(r8), dimension(2) :: start, end, step - real(r8) :: zero_tol, grad_tol, wr, delta - integer :: i, j, k, w, n_steps + $ intau,inQ0,inpr,inpe + INTEGER, INTENT(IN) :: qval,scan_radius,reQ_num + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs + INTEGER :: n_fine + REAL(r8), DIMENSION(:), ALLOCATABLE :: x_s,y_s + REAL(r8) :: x, y, dx, dy, ric_val,start_time,end_time + REAL(r8), DIMENSION(2) :: start, end, step + REAL(r8) :: coarse_threshold,fine_threshold,grad_tol,wr + COMPLEX(r8) :: delta + INTEGER :: k, w, n_steps, i2, i,j logical :: found_zero - real(r8), intent(out) :: growthrate_loc, growthrate ! Output (x, y) pair - integer :: n_points, idx_1, idx_2 - real(r8) :: x_1, y_1, x_2, y_2, dist, min_dist1, min_dist2 + INTEGER :: n_points, idx_1, idx_2 + REAL(r8) :: x_1, y_1, x_2, y_2, dist, min_dist1, min_dist2 REAL(r8), DIMENSION(:,:), ALLOCATABLE, - $ INTENT(OUT) :: deltas - wr = inQ+inQ_e + $ INTENT(OUT) :: Re_deltas,Im_deltas + wr=0.0 ! Parameters - zero_tol = abs(0.1*deltaprime) ! Tolerance for zero value grad_tol = 1.0!abs(0.1*deltaprime) ! Tolerance for steep gradient - n_steps = 100 ! Initial number of steps - n_fine = 10 - if (abs(deltaprime)>50) then - n_fine = n_fine * 2 - end if - ALLOCATE(x_s(n_fine),y_s(n_fine)) + n_steps = reQ_num ! Initial number of steps +! n_fine = 10 +! if (abs(deltaprime)>100) then +! coarse_threshold = abs(0.95*deltaprime) ! Tolerance for zero value +! fine_threshold = abs(0.1*deltaprime) +! n_fine = n_fine * 2 +! else if (abs(deltaprime)>50) then +! coarse_threshold = abs(0.8*deltaprime) ! Tolerance for zero value +! fine_threshold = abs(0.1*deltaprime) +! n_fine = n_fine * 2 +! else if (abs(deltaprime)>20) then +! coarse_threshold = abs(0.66*deltaprime) ! Tolerance for zero value +! fine_threshold = abs(0.05*deltaprime) +! n_fine = n_fine * 2 +! else if (abs(deltaprime)>10) then +! coarse_threshold = abs(0.3*deltaprime) ! Tolerance for zero value +! fine_threshold = abs(0.03*deltaprime) +! else +! coarse_threshold = abs(0.1*deltaprime) ! Tolerance for zero value +! fine_threshold = abs(0.01*deltaprime) +! end if ALLOCATE(inQs(n_steps)) - ALLOCATE(roots(10,2)) - ALLOCATE(deltas(n_steps,n_steps)) - - ! Initial coarse grid search - - dx = 2 * dble(scan_radius) / dble(n_steps) - dy = 2 * dble(scan_radius) / dble(n_steps) - num_zeros = 0 - - inQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) ALLOCATE(iinQs(n_steps)) - - do i = 1, n_steps - x = inQs(i)!wr - scan_radius + (i - 0.5) * dx - do j = 1, n_steps - !y = -scan_radius + (j - 0.5) * dy - y=-scan_radius+(REAL(j)/n_steps)*(scan_radius+ - $ scan_radius) - iinQs(j) = y - delta = REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, - $ intau,inpe,iinQ=y)) - ric_val = abs(delta - deltaprime) - deltas(i,j) = delta - grad_x = 10!(REAL(riccati(x + dx,inQ_e,inQ_i,inpr,inc_beta, - !$ inds,intau,inpe,iinQ=y)) - - !$ REAL(riccati(x - dx,inQ_e,inQ_i,inpr,inc_beta, - !$ inds,intau,inpe,iinQ=y))) / (2 * dx) - grad_y = 10!(REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, - !$ intau,inpe,iinQ=y + dy)) - - !$ REAL(riccati(x,inQ_e,inQ_i,inpr,inc_beta,inds, - !$ intau,inpe,iinQ=y - dy))) / (2 * dy) - - !WRITE(*,*) "Point", [x,y] - !WRITE(*,*) "ric_val", ric_val - !WRITE(*,*) "grad_x", grad_x - !WRITE(*,*) "grad_y", grad_y - !WRITE(*,*) "[dx,dy]", [dx,dy] - - - if ((abs(ric_val) < zero_tol) .and. ((abs(grad_x) > - $ grad_tol) .or. (abs(grad_y) > grad_tol))) then - ! Potential zero found, refine with a finer grid - !start = [x - 0.1, y - 0.1] - !end = [x + 0.1, y + 0.1] - !step = (end - start) / 20 - !WRITE(*,*) "Potential zero found", [x,y] - ! WRITE(*,*) "dx", dx - ! WRITE(*,*) "dy", dy - ! WRITE(*,*) "step", step - ! WRITE(*,*) "scan_radius", scan_radius - - x_s = linspace((x-0.1),(x+0.1),n_fine) - y_s = linspace((y-0.1),(y+0.1),n_fine) - found_zero = .false. - do k=1,n_fine - do w=1,n_fine - !x_s = start(1) + (k - 0.5) * step(1) - !y_s = start(2) + (k - 0.5) * step(2) - - !WRITE(*,*) "fine point", [x_s(k),y_s(w)] - !WRITE(*,*) "y_s", y_s - !stop - !WRITE(*,*) "fine scan", k - - ric_val = REAL(riccati(x_s(k),inQ_e,inQ_i, - $ inpr,inc_beta,inds,intau,inpe, - $ iinQ=y_s(w))) - deltaprime - !WRITE(*,*) "ric_val", ric_val - - if (abs(ric_val) < abs(0.01*deltaprime)) then - ! Found a zero within tolerance, store it - num_zeros = num_zeros + 1 - roots(num_zeros, 1) = x - roots(num_zeros, 2) = y - WRITE(*,*) "FOUND ROOT #", num_zeros - found_zero=.true. - !exit ! Exit the inner loop since zero is found - end if - if (found_zero==.true.) then - exit - endif - end do - if (found_zero==.true.) then - exit - endif - end do - end if - end do - end do - - ! 1. Find the index of the (x, y) pair with x closest to wr - n_points = size(roots, 1) - min_dist1 = abs(roots(1, 1) - wr) - idx_1 = 1 - - do i = 2, n_points - dist = abs(roots(i, 1) - wr) - if (dist < min_dist1) then - min_dist1 = dist - idx_1 = i - end if - end do - - x_1 = roots(idx_1, 1) - y_1 = roots(idx_1, 2) - - ! 2. Find the index of the next closest (x, y) pair with y more than 0.5 away from y_1 - min_dist2 = huge(min_dist2) ! Initialize to a very large value - idx_2 = 0 ! Initialize to an invalid index - - do i = 1, n_points - if (i /= idx_1 .and. abs(roots(i, 2) - y_1) > 0.5) then ! Check if it's a different point and far enough in y - dist = abs(roots(i, 1) - wr) - if (dist < min_dist2) then - min_dist2 = dist - idx_2 = i - end if - end if - end do - - if (idx_2 > 0) then ! Check if a valid second point was found - x_2 = roots(idx_2, 1) - y_2 = roots(idx_2, 2) - end if - - ! 3. Apply your specific conditions to select the final (x, y) pair - if (idx_2 > 0 .and. abs(x_1 - x_2) < 0.1) then - if (y_1 < 0 .or. y_2 < 0) then ! Choose the pair with negative y - if (y_1 < 0) then - growthrate_loc = x_1 - growthrate = y_1 - else - growthrate_loc = x_2 - growthrate = y_2 - end if - end if - else ! If the x values are far apart, choose the first pair - growthrate_loc = x_1 - growthrate = y_1 - end if -c----------------------------------------------------------------------- -c -c----------------------------------------------------------------------- - ! Allocate grid packing arrays and 2D complex deltas array - !ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) - - !DO i=0,ReQ_num+1 - ! DO j=0,ImQ_num - ! iinQs(j)=Im_inQ_min+(REAL(j)/ImQ_num)*(Im_inQ_max- - !$ Im_inQ_min) - ! ! Run riccati() at each Q index to give delta - ! deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr, - !$ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ! NOT USING GRID PACKING - ! ENDDO - !ENDDO - + ALLOCATE(Re_deltas(n_steps,n_steps)) + ALLOCATE(Im_deltas(n_steps,n_steps)) + inQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) + iinQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) + i=1 + j=1 + !CALL OMP_SET_NUM_THREADS(4) + !PRINT *, "Max threads: ",OMP_GET_MAX_THREADS() + !CALL cpu_time(start_time) + !!$OMP PARALLEL DO PRIVATE(j,y,delta) !BIG REWRITE NEEDED + DO i = 1, n_steps + DO j = 1, n_steps + !PRINT *, "Hello from process: ", OMP_GET_THREAD_NUM() + y=iinQs(j) + delta = riccati(inQs(i),inQ_e,inQ_i,inpr,inc_beta, + $ inds,intau,inpe,iinQ=y) + Re_deltas(i,j) = REAL(delta) + Im_deltas(i,j) = AIMAG(delta) + !PRINT *,'inQs(i):',inQs(i) + !PRINT *,'y:',y + !PRINT *,'delta:',delta + END DO + !stop + END DO + !!$OMP END PARALLEL DO + !CALL cpu_time(end_time) + !PRINT *,'Layer scan time:',end_time-start_time,'seconds' + !test comment RETURN - END SUBROUTINE growthrate_search + END SUBROUTINE old_growthrate_scan c----------------------------------------------------------------------- -c Subprogram 2. gamma_stability_scan -c Run grid packed slayer stab. scan around omega_ExB and gamma axes +c Subprogram 2. growthrate_scan +c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE gamma_stability_scan(qval,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,ReQ_num,ImQ_num,scan_radius, - $ deltas,inQs,iinQs) + SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,inQ0,inpr,inpe,scan_radius,coarse_grid_size, + $ deltaprime,results) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs - REAL(r8),INTENT(IN) :: inQ_e,inQ_i,inc_beta,inds, + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, $ intau,inQ0,inpr,inpe - REAL(r8), INTENT(IN) :: inQ ! REAL??? - INTEGER, INTENT(IN) :: qval,ReQ_num,ImQ_num,scan_radius - - ! Outputs - COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, - $ INTENT(OUT) :: deltas - REAL(r8), DIMENSION(:), ALLOCATABLE, - $ INTENT(OUT) :: inQs,iinQs - - ! Local variables - INTEGER :: i,j,k - REAL(r8) :: Re_inQ_min,Re_inQ_max,Im_inQ_min,Im_inQ_max - CHARACTER(3) :: q_str - CHARACTER(len=8) :: fmt ! format descriptor for stab file naming - CHARACTER(len=8) :: x1 ! string for stab file naming - INTEGER :: i1 ! integer for stab file naming - !REAL(r8), DIMENSION(:,:), ALLOCATABLE :: inQs_left,inQs_right - !REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs_log -c----------------------------------------------------------------------- -c Build exponential grid packing for stability scan, then run -c----------------------------------------------------------------------- - ! Allocate grid packing arrays and 2D complex deltas array - ALLOCATE(inQs(0:ReQ_num+1),iinQs(0:ImQ_num)) - !ALLOCATE(inQs_left(0:2+ReQ_num/2,0:2+ReQ_num/2)) - !ALLOCATE(inQs_right(0:2+ReQ_num/2,0:2+ReQ_num/2)) - !ALLOCATE(inQs_log(0:3+ReQ_num)) - ALLOCATE(deltas(0:3+ReQ_num,0:ImQ_num)) - - Im_inQ_max=scan_radius ! max growth rate in scan, OPEN TO USER? - Im_inQ_min=-scan_radius ! min growth rate in scan, OPEN TO USER? - Re_inQ_max=scan_radius ! max growth rate in scan, OPEN TO USER? - Re_inQ_min=-scan_radius ! min growth rate in scan, OPEN TO USER? - - ! Grid packing - right now going to Q +/- 0.2 -- OPEN TO USER? - !inQs_left = powspace(inQ-Re_inQ_max,inQ,1, ! omega-3.0 - !$ 2+ReQ_num/2,"upper") - !inQs_right = powspace(inQ,inQ+Re_inQ_max,1, ! omega+3.0 - !$ 2+ReQ_num/2,"lower") - !inQs_log = (/inQs_left(1,1:2+ReQ_num/2), - !$ inQs_right(1,2:1+ReQ_num/2)/) - - inQs = linspace((Re_inQ_min+inQ),(Re_inQ_max+inQ),ReQ_num+1) - - DO i=0,ReQ_num+1 - DO j=0,ImQ_num - iinQs(j)=Im_inQ_min+(REAL(j)/ImQ_num)*(Im_inQ_max- - $ Im_inQ_min) - ! Run riccati() at each Q index to give delta - deltas(i,j)=riccati(inQs(i),inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQs(j)) ! NOT USING GRID PACKING - ENDDO - ENDDO -c----------------------------------------------------------------------- -c Alter qval to string to add to output filename -c----------------------------------------------------------------------- - fmt = '(I5.5)' ! an integer of width 2 for q surface - i1 = qval - write (x1,fmt) i1 ! integer to string using a 'internal file' - ! Write stability scan output file - OPEN(UNIT=out_unit,FILE="slayer_stability_q"// - $ TRIM(x1)//".out", STATUS="UNKNOWN") - WRITE(out_unit,'(1x,4(a17))'),"RE(Q)", - $ "IM(Q)","RE(delta)","IM(delta)" - DO i=0,ReQ_num+1 - DO j=0,ImQ_num - WRITE(out_unit,'(1x,4(es17.8e3))') - $ inQs(i),iinQs(j), - $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) - ENDDO - ENDDO - CLOSE(out_unit) + INTEGER, INTENT(IN) :: qval,scan_radius,coarse_grid_size + !REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs + COMPLEX(r8) :: delta + REAL(r8), INTENT(IN) :: deltaprime + INTEGER, PARAMETER :: fine_grid_size = 5 + REAL(r8), PARAMETER :: tolerance = 1.0E-6 + REAL(r8) :: delta_real, delta_imag, threshold + INTEGER :: i, j, k, l, count + REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, + $ inQ_coarse, iinQ_coarse + TYPE(result_type), INTENT(INOUT) :: results + + ! Arrays to store results + !REAL(r8), ALLOCATABLE :: inQ_array(:), iinQ_array(:), + !$ delta_real_array(:), delta_imag_array(:) + INTEGER :: max_points + + ! Calculate maximum possible number of points + max_points = coarse_grid_size**2 * (1 + (fine_grid_size-1)**2) + + ! Allocate arrays + !ALLOCATE(inQ_array(max_points), iinQ_array(max_points)) + !ALLOCATE(delta_real_array(max_points), + !$ delta_imag_array(max_points)) + + ! Allocate arrays with maximum possible size + ALLOCATE(results%inQs(max_points), results%iinQs(max_points)) + ALLOCATE(results%Re_deltas(max_points), + $ results%Im_deltas(max_points)) + + + ! Initialize counter + count = 0 + + ! Calculate step sizes + inQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) + iinQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) + + ! Coarse grid loop + DO i = 1, coarse_grid_size + DO j = 1, coarse_grid_size + inQ_coarse = -scan_radius + (i - 1) * inQ_step + iinQ_coarse = -scan_radius + (j - 1) * iinQ_step + + ! Evaluate riccati function + delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, + $ inds,intau,inpe,iinQ=iinQ_coarse) + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + ! Store coarse grid point + count = count + 1 + results%inQs(count) = inQ_coarse + results%iinQs(count) = iinQ_coarse + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + + IF (ABS(deltaprime) > 8) THEN + threshold = ABS(deltaprime)**(1./3.) + ELSE + threshold = 0.25 * ABS(deltaprime) + END IF + + ! Check if refinement is needed + IF (ABS(delta_real) > threshold) THEN + ! Fine grid loop + DO k = 2, fine_grid_size + DO l = 2, fine_grid_size + inQ_fine = inQ_coarse + (k-1) * inQ_step / + $ (fine_grid_size - 1) + iinQ_fine = iinQ_coarse + (l-1) * iinQ_step / + $ (fine_grid_size - 1) + + IF ((ABS(inQ_coarse - inQ_fine) < + $ tolerance) .AND. (ABS(iinQ_coarse - + $ iinQ_fine) < tolerance)) CYCLE + + ! Evaluate riccati function + delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + ! Store fine grid point + count = count + 1 + results%inQs(count) = inQ_fine + results%iinQs(count) = iinQ_fine + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END DO + END DO + END IF + END DO + END DO + + ! Set the actual count of points + results%count = count + + ! Resize arrays to actual number of points + CALL resize_array(results%inQs, count) + CALL resize_array(results%iinQs, count) + CALL resize_array(results%Re_deltas, count) + CALL resize_array(results%Im_deltas, count) RETURN - END SUBROUTINE gamma_stability_scan -c----------------------------------------------------------------------- -c Subprogram 3. gamma_match -c Loop stability across k rational surfaces -c----------------------------------------------------------------------- - SUBROUTINE gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr, - $ inc_beta_arr,inds_arr,intau_arr,inQ0_arr, - $ inpr_arr,inpe_arr,omegas_arr,outer_delta_arr, - $ ReQ_num,ImQ_num,scan_radius,inQs,iinQs, - $ all_Re_deltas,all_inQs) -c----------------------------------------------------------------------- -c Declarations -c----------------------------------------------------------------------- - ! Inputs - REAL(r8), DIMENSION(:), INTENT(IN) :: inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, - $ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, - $ inQ_arr,psi_n_rational - INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr - REAL(r8), DIMENSION(:), INTENT(IN) :: outer_delta_arr - INTEGER, INTENT(IN) :: ReQ_num,ImQ_num,scan_radius - ! Outputs - REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates - ! Local variables - INTEGER :: n_k ! Number of rational surfaces - INTEGER :: k,w - ! Local variables received from internal subroutines - REAL(r8), DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: inQs,iinQs - COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_slices,all_inQs - REAL(r8), DIMENSION(:), ALLOCATABLE :: slice - REAL(r8) :: layer_Q, ImQ_gamma - - n_k = SIZE(qval_arr) - ! Allocate growthrates arrays - ALLOCATE(growthrates(n_k)) - -c----------------------------------------------------------------------- -c Loop across rational surfaces -c----------------------------------------------------------------------- - ! Summary: for each rational surface, run narrow stability scan - ! for analysis, then slice out 1D array of growth rates at - ! given omega_ExB (Q), then find growth rate corresponding - ! to delta-deltaprime match - DO k=1,n_k - WRITE(*,*) "Scanning q=", qval_arr(k), " rational surface" - ! Run stability scan - CALL gamma_stability_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), - $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), - $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ ReQ_num,ImQ_num,scan_radius,deltas,inQs,iinQs) - - layer_Q = inQ_arr(k) ! REAL??? - - IF (k==1) THEN - ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) - ALLOCATE(all_slices(SIZE(iinQs),n_k), - $ all_inQs(SIZE(inQs),n_k)) - ENDIF + END SUBROUTINE growthrate_scan - all_RE_deltas(:,:,k) = REAL(deltas) - all_inQs(:,k) = inQs - ENDDO + SUBROUTINE resize_array(arr, new_size) + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) + INTEGER, INTENT(IN) :: new_size + REAL(r8), ALLOCATABLE :: temp(:) - DEALLOCATE(deltas) - - RETURN - END SUBROUTINE gamma_match + ALLOCATE(temp(new_size)) + temp(1:new_size) = arr(1:new_size) + CALL move_alloc(temp, arr) + END SUBROUTINE resize_array END MODULE gslayer_mod diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 92333c392..9b1bf2cc3 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -9,43 +9,23 @@ MODULE layerinputs_mod USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq USE bicube_mod, ONLY: bicube_eval_external,bicube_type - USE slayer_netcdf_mod, ONLY: slayer_netcdf_inputs + USE slayer_netcdf_mod!, ONLY: slayer_netcdf_inputs IMPLICIT NONE CONTAINS c----------------------------------------------------------------------- -c subprogram 1. check. -c Check status of netcdf file. -c----------------------------------------------------------------------- - SUBROUTINE check(stat) -c----------------------------------------------------------------------- -c declaration. -c----------------------------------------------------------------------- - INTEGER, INTENT (IN) :: stat -c----------------------------------------------------------------------- -c stop if it is an error. -c----------------------------------------------------------------------- - IF(stat /= nf90_noerr) THEN - PRINT *, TRIM(nf90_strerror(stat)) - !STOP "ERROR: failed to write/read netcdf file" - ENDIF -c----------------------------------------------------------------------- -c terminate. -c----------------------------------------------------------------------- - RETURN - END SUBROUTINE check -c----------------------------------------------------------------------- -c subprogram 2. read_stride_netcdf_diagonal. +c subprogram 1. read_stride_netcdf_diagonal. c Read STRIDE netcdf file for SLAYER inputs only. c----------------------------------------------------------------------- - SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, - $ dp_diagonal, q_rational, psi_n_rational, shear, + SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, + $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,shear, $ r_o,my_bt0,my_psio,mpsi,nn,resm) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: dp_diagonal + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: + $ Re_dp_diagonal,Im_dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, $ psi_n_rational, shear REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, @@ -78,18 +58,16 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, msing=INT(msing_arr(1)) - ! Allocate Arrays (based on dimension) - ALLOCATE(dp_diagonal(msing),q_rational(msing), + ! Allocate Arrays (based on dimension) + ALLOCATE(Re_dp_diagonal(msing),q_rational(msing), $ psi_n_rational(msing),shear(msing), - $ resm(msing)) + $ resm(msing),Im_dp_diagonal(msing)) ALLOCATE(delta_prime(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) CALL check(stat) stat = nf90_inquire_attribute(ncid,bt0_id,"bt0",len=bt0_len) CALL check(stat) - - stat = nf90_inquire_attribute(ncid,psio_id,"psio",len=psio_len) CALL check(stat) @@ -108,7 +86,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, $ my_psio(INT(psio_len)), $mpsi(INT(mpsi_len)),nn(INT(nn_len))) - ! Get Variable IDs + ! Get Variable IDs stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) CALL check(stat) stat = nf90_inq_varid(ncid, "q_rational", qr_id) @@ -122,7 +100,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Get attributes stat = nf90_get_att(ncid, ro_id, "ro", r_o) CALL check(stat) - stat = nf90_get_att(ncid, bt0_id, "bt0", my_bt0) CALL check(stat) stat = nf90_get_att(ncid, psio_id, "psio", my_psio) @@ -132,7 +109,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, stat = nf90_get_att(ncid, nn_id, "n", nn) CALL check(stat) - ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. + ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) CALL check(stat) ! Read 1D variables @@ -147,9 +124,10 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, ! Extract Diagonal, with 3rd index signifying REAL part DO i = 1, msing - dp_diagonal(i) = REAL(delta_prime(i, i, 1)) + Re_dp_diagonal(i) = delta_prime(i, i, 1) + Im_dp_diagonal(i) = delta_prime(i, i, 2) END DO - ! Clean Up + ! Clean Up DEALLOCATE(delta_prime) stat = nf90_close(ncid) CALL check(stat) @@ -157,7 +135,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile, msing, END SUBROUTINE read_stride_netcdf_diagonal c----------------------------------------------------------------------- c subprogram 2. issurfint. -c surface integration by simple method. +c surface integration by simple method. copied from EQUIL c----------------------------------------------------------------------- FUNCTION issurfint(func,fs,inpsi,wegt,ave, $ fsave,psave,jacs,delpsi,inr,ina,first) @@ -246,22 +224,23 @@ END FUNCTION issurfint c subprogram 3. build_inputs. c build input arrays for SLAYER c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,inpr_prof, - $ growthrate_flag, - $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr,inc_beta_arr, - $ inds_arr,intau_arr,Q0_arr,inpr_arr,inpe_arr, - $ omegas_arr,outer_delta_arr) + SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, + $ pe_flag,qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, + $ inpr_arr,inpe_arr,omegas_arr,Re_deltaprime_arr, + $ Im_deltaprime_arr) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- - LOGICAL, INTENT(IN) :: growthrate_flag + ! Inputs + LOGICAL, INTENT(IN) :: growthrate_flag,pe_flag + CHARACTER(512), INTENT(IN) :: infile,ncfile + ! Internals REAL(r8), DIMENSION(8), INTENT(IN) :: inpr_prof LOGICAL :: firstsurf - REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf, - $ ising + REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf,ising INTEGER :: zi, zimp, mi, mimp - REAL(r8) :: nfac,tfac,wefac,wpfac,e!,pi,twopi + REAL(r8) :: nfac,tfac,wefac,wpfac,e TYPE(spline_type) :: spl TYPE(spline_type) :: sr @@ -272,21 +251,20 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, $ my_qval,my_sval,my_bt,my_rs,zeff,inpe,R_0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: - $ inQ_arr,inQ_e_arr,psi_n_rational, + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, + $ inQ_e_arr,psi_n_rational, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, $ inpr_arr,inpe_arr,omegas_arr, - $ outer_delta_arr + $ Re_deltaprime_arr,Im_deltaprime_arr INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor - REAL(r8), DIMENSION(:), ALLOCATABLE :: dp_diagonal, q_rational, - $ shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, + $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, + $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, - $ ti_arr,zeff_arr,bt_arr,rs_arr, - $ R0_arr,mu_i_arr + $ ti_arr,zeff_arr,bt_arr,rs_arr,R0_arr,mu_i_arr INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm,nns_arr INTEGER :: msing,i,mthsurf REAL(r8), DIMENSION(0:512) :: unitfun @@ -294,17 +272,15 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, REAL(r8) :: psave REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs,delpsi,rsurf,asurf REAL(r8) :: rfac,jac,a_surf - - CHARACTER(512), INTENT(IN) :: infile,ncfile - c----------------------------------------------------------------------- c Read in STRIDE netcdf c----------------------------------------------------------------------- - CALL read_stride_netcdf_diagonal(ncfile, - $ msing,dp_diagonal,q_rational,psi_n_rational, + CALL read_stride_netcdf_diagonal(ncfile,msing,Re_dp_diagonal, + $ Im_dp_diagonal,q_rational,psi_n_rational, $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing - WRITE(*,*)"dp_diagonal=",dp_diagonal + WRITE(*,*)"Re_dp_diagonal=",Re_dp_diagonal + WRITE(*,*)"Im_dp_diagonal=",Im_dp_diagonal WRITE(*,*)"q_rational=",q_rational WRITE(*,*)"psi_n_rational=",psi_n_rational WRITE(*,*)"shear=",shear @@ -315,14 +291,14 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, WRITE(*,*)"resm=",resm mpsi = INT(mpsi_arr(1)) - mthsurf = 512 + mthsurf = 512 ! Hardcoded, but this is a default value ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), - $ inQ_i_arr(msing), - $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), - $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), - $ omegas_arr(msing),omegas_e_arr(msing),omegas_i_arr(msing), - $ outer_delta_arr(msing)) + $ inQ_i_arr(msing), + $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), + $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), + $ omegas_arr(msing),omegas_e_arr(msing),omegas_i_arr(msing), + $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) @@ -352,7 +328,6 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, c----------------------------------------------------------------------- c loop across singular surfaces, evaluate spline quantities. c----------------------------------------------------------------------- - DO ising=1,msing respsi = psi_n_rational(ising) @@ -391,7 +366,12 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, inpr = inpr_prof(ising) - inpe=0.0!0.0165*inpr ! Waybright added this + ! Check whether to include electron viscosity + IF (pe_flag) THEN + inpe=0.0165*inpr + ELSE + inpe=0.0 + ENDIF ne_arr(ising) = n_e te_arr(ising) = t_e @@ -444,7 +424,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, delta_n=lu**(1.0/3.0)/my_rs ! norm factor for delta primes qval_arr(ising) = INT(my_qval) - inQ_arr(ising)=Q + inQ_arr(ising)=REAL(Q) inQ_e_arr(ising)=Q_e inQ_i_arr(ising)=Q_i inc_beta_arr(ising)=c_beta @@ -452,29 +432,49 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof, intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr - inpe_arr(ising) = inpe!0.0!0.0165*inpr !!! TEMPORARY? + inpe_arr(ising) = inpe omegas_arr(ising) = omega omegas_e_arr(ising) = omega_e omegas_i_arr(ising) = omega_i - outer_delta_arr(ising) = dp_diagonal(ising) - + Re_deltaprime_arr(ising) = Re_dp_diagonal(ising) + Im_deltaprime_arr(ising) = Im_dp_diagonal(ising) ENDDO + !WRITE(*,*)"msing=",msing + !WRITE(*,*)"qval_arr=",qval_arr + !WRITE(*,*)"ne_arr=",ne_arr + !WRITE(*,*)"te_arr=",te_arr + !WRITE(*,*)"ni_arr=",ni_arr + !WRITE(*,*)"ti_arr=",ti_arr !WRITE(*,*)"zeff_arr=",zeff_arr - - CALL slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, - $ zeff_arr,shear,bt_arr,rs_arr,R0_arr,mu_i_arr,resm,nns_arr, - $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr, - $ intau_arr,inpr_arr,inpe_arr,omegas_arr, - $ outer_delta_arr) - + !WRITE(*,*)"shear=",shear + !WRITE(*,*)"bt_arr=",bt_arr + !WRITE(*,*)"rs_arr=",rs_arr + !WRITE(*,*)"R0_arr=",R0_arr + !WRITE(*,*)"resm=",resm + !WRITE(*,*)"nns_arr=",nns_arr + !WRITE(*,*)"inc_beta_arr=",inc_beta_arr + !WRITE(*,*)"inds_arr=",inds_arr + !WRITE(*,*)"intau_arr=",intau_arr + !WRITE(*,*)"inpr_arr=",inpr_arr + !WRITE(*,*)"inpe_arr=",inpe_arr + !WRITE(*,*)"omegas_arr=",omegas_arr + !WRITE(*,*)"omegas_e_arr=",omegas_e_arr + !WRITE(*,*)"omegas_i_arr=",omegas_i_arr + !WRITE(*,*)"Re_deltaprime_arr=",Re_deltaprime_arr + !WRITE(*,*)"Im_deltaprime_arr=",Im_deltaprime_arr + !stop + CALL slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr,ni_arr, + $ ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, + $ resm,nns_arr,inc_beta_arr,inds_arr, + $ intau_arr,inpr_arr,inpe_arr,inQ_arr,omegas_arr, + $ omegas_e_arr,omegas_i_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr) c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- - RETURN - END SUBROUTINE build_inputs END MODULE layerinputs_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 403b3b6fb..ae6356f2d 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -16,6 +16,12 @@ MODULE sglobal_mod $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6022e-19, $ kval=1.3807e-23,lnLamb=17.0 + TYPE result_type + REAL(r8), ALLOCATABLE :: inQs(:), iinQs(:), + $ Re_deltas(:), Im_deltas(:) + INTEGER :: count + END TYPE result_type + ! lnLamb will be updated. COMPLEX(r8), PARAMETER :: ifac=(0,1) diff --git a/slayer/slayer.f b/slayer/slayer.f index 671466cf2..dca43a3a8 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -33,7 +33,8 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,growthrates_flag,layer_stabilityscan_flag !FOR TESTING + $ params_check,growthrates_flag,analytic_growthrates_flag, + $ pe_flag,br_th_flag !FOR TESTING REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff @@ -57,23 +58,25 @@ PROGRAM slayer $ inpe_arr,omegas_arr,inQ_arr, $ psi_n_rational REAL(r8), DIMENSION(8) :: inpr_prof - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_RE_deltas, - $ all_roots + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, + $ all_Im_deltas,all_roots REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_inQs - REAL(r8),dimension(:, :),ALLOCATABLE :: roots + REAL(r8), DIMENSION(:,:),ALLOCATABLE :: Re_deltas,Im_deltas INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: - $ outer_delta_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr, $ all_growthrates,all_growthrate_locs REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths, $ inQs_left,inQs_right,coarse_deltas - REAL(r8) :: spot, slayer_inpr, growthrate, growthrate_loc + REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + TYPE(result_type) :: results(8) ! Assuming max 8 rational surfaces + REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates, $ growthrate_err @@ -88,7 +91,8 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag,growthrates_flag,bal_flag + $ stability_flag,growthrates_flag,analytic_growthrates_flag, + $ pe_flag,br_th_flag,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -161,7 +165,9 @@ PROGRAM slayer bal_flag=.FALSE. stability_flag=.FALSE. growthrates_flag=.FALSE. - layer_stabilityscan_flag=.FALSE. + analytic_growthrates_flag=.FALSE. + pe_flag=.FALSE. + br_th_flag=.FALSE. c----------------------------------------------------------------------- c read slayer.in. c----------------------------------------------------------------------- @@ -293,77 +299,221 @@ PROGRAM slayer !WRITE(*,*)"infile=",infile !WRITE(*,*)"ncfile=",ncfile CALL build_inputs(infile,ncfile,inpr_prof, - $ growthrates_flag,qval_arr,psi_n_rational, + $ growthrates_flag,pe_flag,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,outer_delta_arr) + $ omegas_arr,Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr WRITE(*,*)"inQ values=",inQ_arr WRITE(*,*)"Prantdl numbers=",inpr_arr WRITE(*,*)"Electron viscosities=",inpe_arr WRITE(*,*)"Omega ExB values=",omegas_arr - WRITE(*,*)"outer region deltaprimes=",outer_delta_arr - + WRITE(*,*)"outer region real deltaprimes=",Re_deltaprime_arr + WRITE(*,*)"outer region imag deltaprimes=",Im_deltaprime_arr + WRITE(*,*)"inQ_e_arr=",inQ_e_arr + WRITE(*,*)"inds_arr=",inds_arr + WRITE(*,*)"intau_arr=",intau_arr n_k = SIZE(qval_arr) - !ALLOCATE(all_growthrates(100,3,n_k)) - all_RE_deltas(:,:,k) = REAL(deltas) - all_inQs(:,k) = inQs DO k=1,n_k WRITE(*,*) "Finding roots on q=", qval_arr(k), $ " rational surface" - ! Run MCMC - CALL growthrate_search(qval_arr(k),inQ_arr(k),inQ_e_arr(k), + CALL growthrate_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ outer_delta_arr(k),scan_radius, - $ coarse_deltas,inQs,iinQs,roots, - $ growthrate,growthrate_loc) - !stop - - IF (k==1) THEN - ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) - ALLOCATE(all_inQs(SIZE(inQs),n_k)) + $ scan_radius,reQ_num,Re_deltaprime_arr(k), + $ results(n_k)) + + ! IF (k==1) THEN + ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) + ! ALLOCATE(all_Im_deltas(SIZE(inQs),SIZE(iinQs),n_k)) + ! ALLOCATE(all_inQs(SIZE(inQs),n_k)) ALLOCATE(all_growthrates(n_k)) ALLOCATE(all_growthrate_locs(n_k)) - ENDIF - all_RE_deltas(:,:,k) = coarse_deltas - all_inQs(:,k) = inQs - all_roots(:,:,k) = roots - all_growthrates(k) = growthrate - all_growthrate_locs(k) = growthrate_loc + ! ENDIF + ! all_Re_deltas(:,:,k) = Re_deltas + ! all_Im_deltas(:,:,k) = Im_deltas + ! all_inQs(:,k) = inQs + + ! DEALLOCATE(Re_deltas,Im_deltas) + all_growthrates(k) = 0.0 + all_growthrate_locs(k) = 0.0 ENDDO + WRITE(*,*) "all_growthrates", all_growthrates + + CALL slayer_netcdf_out(growthrates_flag,n_k,qval_arr, + $ all_growthrates,all_growthrate_locs, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr, + $ results) + stop + ENDIF +c----------------------------------------------------------------------- +c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY +c----------------------------------------------------------------------- + IF (analytic_growthrates_flag) THEN + WRITE(*,*)"intau=",intau + WRITE(*,*)"inQ=",inQ + WRITE(*,*)"Prantdl numbers=",inpr + WRITE(*,*)"Electron viscosities=",inpe + WRITE(*,*)"inQ_e=",inQ_e + WRITE(*,*)"inds=",inds + WRITE(*,*)"inc_beta=",inc_beta + + WRITE(*,*)"running analytic scan" + + qval_arr = (/ 2 /) + omegas_arr = (/ 0.0 /) + inQ_arr = (/ inQ /) + inQ_e_arr = (/ inQ_e /) + inQ_i_arr = (/ inQ_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ 5.0 /) + Im_deltaprime_arr = (/ 0.00001 /) + inpr_arr = (/ inpr /) + + CALL growthrate_scan(2,inQ,inQ_e, + $ inQ_i,inc_beta,inds, + $ intau,inQ,inpr,inpe, + $ scan_radius,reQ_num,Re_deltaprime_arr(k), + $ results(1)) + + ! WRITE(*,*)"SIZE(inQs)",SIZE(inQs) + ! WRITE(*,*)"SIZE(iinQs)",SIZE(iinQs) + + !IF (k==1) THEN + ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),1)) + ! ALLOCATE(all_Im_deltas(SIZE(inQs),SIZE(iinQs),1)) + ! ALLOCATE(all_inQs(SIZE(inQs),1)) + ALLOCATE(all_growthrates(1)) + ALLOCATE(all_growthrate_locs(1)) + !ENDIF + ! all_Re_deltas(:,:,1) = Re_deltas + ! all_Im_deltas(:,:,1) = Im_deltas + ! all_inQs(:,1) = inQs + !all_roots(:,:,k) = roots + + all_growthrates(1) = 0.0 + all_growthrate_locs(1) = 0.0 + + WRITE(*,*)"allocations successful" + + CALL slayer_netcdf_out(growthrates_flag,1,qval_arr, + $ all_growthrates,all_growthrate_locs, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr, + $ results) + stop + ENDIF +c----------------------------------------------------------------------- +c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY +c----------------------------------------------------------------------- + IF (br_th_flag) THEN + WRITE(*,*)"running br_th scan" - !IF (layer_stabilityscan_flag) THEN - ! CALL gamma_match(qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - !$ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr, - !$ inQ0_arr,inpr_arr,inpe_arr,omegas_arr, - !$ outer_delta_arr,ReQ_num,ImQ_num,scan_radius, - !$ inQs,iinQs,all_Re_deltas,all_inQs) - !ELSE - ! ALLOCATE(inQs(0:ReQ_num+1),iinQs(0:ImQ_num)) - ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) - ! ALLOCATE(all_inQs(SIZE(inQs),n_k)) - - ! all_RE_deltas = 0.0 - ! all_inQs = 0.0 - ! inQs = 0.0 - ! iinQs = 0.0 - !ENDIF - - CALL slayer_netcdf_out(n_k, - $ SIZE(inQs),SIZE(iinQs),qval_arr, - $ inQs,iinQs,all_roots,all_growthrates, - $ all_growthrate_locs,omegas_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,psi_n_rational, - $ all_Re_deltas,all_inQs) - - !WRITE(*,*)"xroots=",roots(:,1) - !WRITE(*,*)"yroots=",roots(:,2) - !stop + CALL params(n_e,t_e,t_i,omega, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + inQ=Q + inQ_e=Q_e + inQ_i=Q_i + inc_beta=c_beta + inds=ds + intau=tau + Q0=Q +c----------------------------------------------------------------------- +c calculate basic delta, torque, balance, error fields. +c----------------------------------------------------------------------- + WRITE(*,*)"basic delta successful" + delta_n_p=1e-2 + delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, + $ inpe) + psi0=1.0/ABS(delta+delta_n_p) ! a.u. + jxb=-AIMAG(1.0/(delta+delta_n_p)) ! a.u. +c----------------------------------------------------------------------- +c find solutions based on simple torque balance. +c----------------------------------------------------------------------- + IF (Q0>inQ_e) THEN + inQ_max=2.0*Q0 + inQ_min=1.05*inQ_e + ELSE + inQ_max=0.95*inQ_e + IF (Q0>0) THEN + inQ_min=0.8*inQ_i + ELSE + inQ_min=1.5*MINVAL((/Q0,inQ_i/)) + ENDIF + ENDIF + WRITE(*,*)"rotation scan" + ! Scan of rotation + inQ_max=10.0 + inQ_min=-10.0 + inum=200 + ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum), + $ bal(0:inum)) + DO i=0,inum + inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) + deltal(i)=riccati(inQs(i),inQ_e,inQ_i, + $ inpr,inc_beta,inds,intau,inpe) + jxbl(i)=-AIMAG(1.0/(deltal(i)+delta_n_p)) + bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) + ENDDO + + ! Identify the threshold from the maximum of the balance parameter + index=MAXLOC(bal) + Q_sol=inQs(index(1)) + !omega_sol=inQs(index(1))/Qconv + br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0)) + DEALLOCATE(inQs,deltal,jxbl,bal) + + WRITE(*,*)"allocating" + qval_arr = (/ 3 /) + inQs = (/ 1.0 /) + inQs = (/ 1.0 /) + + n_k = SIZE(qval_arr) + k=1 + IF (k==1) THEN + ALLOCATE(all_RE_deltas(1,1,n_k)) + ALLOCATE(all_Im_deltas(1,1,n_k)) + ALLOCATE(all_inQs(1,n_k)) + ALLOCATE(all_growthrates(n_k)) + ALLOCATE(all_growthrate_locs(n_k)) + ENDIF + all_Re_deltas(:,:,k) = 0.0 + all_Im_deltas(:,:,k) = 0.0 + all_inQs(:,k) = 0.0 + + all_growthrates(k) = br_th !!!!!!!!!!!!!!!!!!!!!!!!! + all_growthrate_locs(k) = 0.0 + + + qval_arr = (/ 3 /) + inQs = (/ 1.0 /) + inQs = (/ 1.0 /) + + omegas_arr = (/ 0.0 /) + inQ_arr = (/ inQ /) + inQ_e_arr = (/ inQ_e /) + inQ_i_arr = (/ inQ_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ 0.0 /) + Im_deltaprime_arr = (/ 0.0 /) + inpr_arr = (/ inpr /) + + WRITE(*,*)"allocations successful" + + CALL slayer_netcdf_out(growthrates_flag,1,qval_arr, + $ all_growthrates,all_growthrate_locs, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr, + $ results) + stop ENDIF c----------------------------------------------------------------------- c find solutions based on simple torque balance. diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 217504ae0..31b6f17f2 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -51,28 +51,30 @@ END SUBROUTINE check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(msing,ReQ_n, - $ ImQ_n,qval_arr, - $ inQs,iinQs,all_roots,all_growthrates,all_growthrate_locs, - $ omegas_arr,inQ_arr,inQ_e_arr, - $ inQ_i_arr,psi_n_rational, - $ all_Re_deltas,all_inQs) - LOGICAL, PARAMETER :: layer_stabilityscan_flag = .true. - INTEGER, INTENT(IN) :: msing,ReQ_n,ImQ_n + SUBROUTINE slayer_netcdf_out( + $ growthrates_flag,msing,qval_arr, + $ all_growthrates,all_growthrate_locs, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ inpr_arr,Re_deltaprime_arr,Im_deltaprime_arr, + $ results) + LOGICAL, INTENT(IN) :: growthrates_flag + INTEGER, INTENT(IN) :: msing REAL(r8), DIMENSION(:), INTENT(IN) :: - $ inQs,iinQs,omegas_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,psi_n_rational, - $ all_growthrates,all_growthrate_locs + $ omegas_arr,inQ_arr, + $ inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr, + $ all_growthrates,all_growthrate_locs,Re_deltaprime_arr, + $ Im_deltaprime_arr INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr - REAL(r8), DIMENSION(:,:), INTENT(IN) :: all_inQs - REAL(r8), DIMENSION(:,:,:), INTENT(IN) :: all_Re_deltas - REAL(r8),DIMENSION(:,:,:),ALLOCATABLE,INTENT(IN) :: - $ all_roots + TYPE(result_type), INTENT(IN) :: results(8) INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, - $ r_dim,pr_id, qr_id, dp_id,shear_id,slice_id,inQs_id, - $ gamma_err_id,gamma_loc_id,roots_dim + $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id, + $ gamma_err_id,gamma_loc_id,roots_dim,Re_dp_id,Im_dp_id, + $ rdpp_id,idpp_id,inpr_id + INTEGER :: run, run_dimid, point_dimid, varids(4), + $ max_points + CHARACTER(64) :: ncfile LOGICAL, PARAMETER :: debug_flag = .FALSE. CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' @@ -94,6 +96,8 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n, IF(debug_flag) PRINT *," - Creating netcdf files" CALL check( nf90_create(ncfile, $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) + + max_points = maxval([(results(run)%count, run=1,msing)]) c ----------------------------------------------------------------------- c define global file attributes c ----------------------------------------------------------------------- @@ -107,18 +111,18 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n, ! define global attributes ! define dimensions IF(debug_flag) PRINT *," - Defining dimensions in netcdf" + IF(msing>0)THEN CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) - CALL check( nf90_def_dim(ncid,"ReQ_arr",ReQ_n, - $ ReQ_dim) ) !r_dim = q_rational - CALL check( nf90_def_var(ncid,"ReQ_arr",nf90_double,ReQ_dim, - $ ReQ_id)) - CALL check( nf90_def_dim(ncid,"ImQ_arr",ImQ_n,ImQ_dim) ) !r_dim = q_rational - CALL check( nf90_def_dim(ncid,"nroots",100,roots_dim) ) !r_dim = q_rational - CALL check( nf90_def_var(ncid,"ImQ_arr",nf90_double,ImQ_dim, - $ ImQ_id)) + ! CALL check( nf90_def_dim(ncid,"ReQ_arr",ReQ_n, + !$ ReQ_dim) ) !r_dim = q_rational + ! CALL check( nf90_def_var(ncid,"ReQ_arr",nf90_double,ReQ_dim, + !$ ReQ_id)) + ! CALL check( nf90_def_dim(ncid,"ImQ_arr",ImQ_n,ImQ_dim) ) !r_dim = q_rational + ! CALL check( nf90_def_var(ncid,"ImQ_arr",nf90_double,ImQ_dim, + !$ ImQ_id)) CALL check( nf90_def_var(ncid,"growthrates",nf90_double, $ qsing_dim,gamma_id)) CALL check( nf90_def_var(ncid,"growthrate_locs",nf90_double, @@ -135,20 +139,44 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n, $ qsing_dim,Q_i_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ qsing_dim,pr_id) ) + CALL check( nf90_def_var(ncid,"P",nf90_double, + $ qsing_dim,inpr_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ qsing_dim,qr_id) ) - ! CALL check( nf90_def_var(ncid,"shear",nf90_double,q_rational, - !$ shear_id) ) - ENDIF - ! define variables - IF(debug_flag) PRINT *," - Defining variables in netcdf" - IF (layer_stabilityscan_flag) THEN - CALL check( nf90_def_var(ncid, "Re_Delta", nf90_double, - $ (/ReQ_dim, ImQ_dim, qsing_dim/), dp_id) ) - CALL check( nf90_def_var(ncid, "inQs", nf90_double, - $ (/ReQ_dim, qsing_dim/), inQs_id) ) + !!! For results + ! Define dimensions + ! CALL check( nf90_def_dim(ncid, "msing", msing, dimids(1)) ) + ! CALL check( nf90_def_dim(ncid, "max_points", + !$ maxval(results%count), dimids(2)) ) + !CALL check( nf90_def_dim(ncid, "run", msing, run_dimid) ) + CALL check( nf90_def_dim(ncid, "points", max_points, + $ point_dimid) ) + + ! Define variables + CALL check( nf90_def_var(ncid, "Re_Qs", nf90_double, + $ [point_dimid, qsing_dim], varids(1)) ) + CALL check( nf90_def_var(ncid, "Im_Qs", nf90_double, + $ [point_dimid, qsing_dim], varids(2)) ) + CALL check( nf90_def_var(ncid, "Re_deltas", nf90_double, + $ [point_dimid, qsing_dim], varids(3)) ) + CALL check( nf90_def_var(ncid, "Im_deltas", nf90_double, + $ [point_dimid, qsing_dim], varids(4)) ) + ENDIF + + !IF (growthrates_flag) .OR. (analytic_) THEN + !CALL check( nf90_def_var(ncid, "Re_Deltas", nf90_double, + !$ (/ReQ_dim, ImQ_dim, qsing_dim/), Re_dp_id) ) + !CALL check( nf90_def_var(ncid, "Im_Deltas", nf90_double, + !$ (/ReQ_dim, ImQ_dim, qsing_dim/), Im_dp_id) ) + CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, + $ qsing_dim,rdpp_id) ) + CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, + $ qsing_dim,idpp_id) ) + ! CALL check( nf90_def_var(ncid, "inQs", nf90_double, + !$ (/ReQ_dim, qsing_dim/), inQs_id) ) + !ENDIF ! end definitions CALL check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- @@ -156,23 +184,41 @@ SUBROUTINE slayer_netcdf_out(msing,ReQ_n, c ----------------------------------------------------------------------- ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL check( nf90_put_var(ncid,ReQ_id, inQs)) - CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) + !CALL check( nf90_put_var(ncid,ReQ_id, inQs)) + !CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) + CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) CALL check( nf90_put_var(ncid,qr_id, qval_arr)) + ! IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" - IF (layer_stabilityscan_flag) THEN - CALL check( nf90_put_var(ncid,dp_id,all_Re_deltas)) - CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) - ENDIF - CALL check( nf90_put_var(ncid,gamma_id,all_growthrates)) - !CALL check( nf90_put_var(ncid,gamma_err_id, - !$ (/(all_growthrates(:,3,i),i=1,msing)/))) - CALL check( nf90_put_var(ncid,gamma_loc_id,all_growthrate_locs)) + !IF (growthrates_flag) THEN + CALL check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) + CALL check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) + !CALL check( nf90_put_var(ncid,Re_dp_id,all_Re_deltas)) + !CALL check( nf90_put_var(ncid,Im_dp_id,all_Im_deltas)) + !CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) + !ENDIF + !CALL check( nf90_put_var(ncid,gamma_id,all_growthrates)) + !CALL check( nf90_put_var(ncid,gamma_loc_id,all_growthrate_locs)) + ! Write data + DO run = 1, msing + CALL check( nf90_put_var(ncid, varids(1), results(run)%inQs, + $ start=[1, run], count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid, varids(2), results(run)%iinQs, + $ start=[1, run], count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid, varids(3), + $ results(run)%Re_deltas, start=[1, run], + $ count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid, varids(4), + $ results(run)%Im_deltas, start=[1, run], + $ count=[results(run)%count, 1]) ) + END DO + !CALL check(nf90_put_var(ncid,varids(5),[results(run)%count,run=1,msing]) ) + c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- @@ -186,29 +232,28 @@ END SUBROUTINE slayer_netcdf_out c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, - $ zeff_arr,shear,bt_arr,rs_arr,R0_arr,mu_i_arr,resm,nns_arr, - $ qval_arr,inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr, - $ intau_arr,inpr_arr,inpe_arr,omegas_arr, - $ outer_delta_arr) + SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, + $ ni_arr,ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, + $ resm,nns_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr,inpe_arr, + $ inQ_arr,omegas_arr,omegas_e_arr,omegas_i_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr) INTEGER, INTENT(IN) :: msing - REAL(r8), DIMENSION(:), INTENT(IN) :: - $ ne_arr,te_arr,ni_arr,ti_arr,zeff_arr,shear,bt_arr,rs_arr, - $ R0_arr,mu_i_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr, - $ inpe_arr,omegas_arr,outer_delta_arr + REAL(r8), DIMENSION(:), INTENT(IN) :: ne_arr,te_arr,ni_arr, + $ ti_arr,zeff_arr,shear,bt_arr,rs_arr, + $ R0_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr, + $ inpe_arr,omegas_arr,omegas_e_arr,omegas_i_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr,inQ_arr INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr,resm,nns_arr INTEGER :: i, ncid,r_id,qsing_dim,qsing_id,msing_id, $ i_dim,ne_id,te_id,ni_id,ti_id,zeff_id,shear_id,bt_id,rs_id, - $ R0_id,mu_i_id,resm_id,nns_id,inQ_id,inQ_e_id,inc_beta_id, + $ R0_id,resm_id,nns_id,inQ_id,inQ_e_id,inc_beta_id, $ inds_id,qval_id,inQ_i_id,qr_id, - $ intau_id,inpr_id,inpe_id,omegas_id,outer_delta_id, + $ intau_id,inpr_id,inpe_id,omegas_id,Re_delta_id,Im_delta_id, $ omegas_e_id,omegas_i_id CHARACTER(64) :: ncfile - LOGICAL, PARAMETER :: debug_flag = .FALSE. CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' c ----------------------------------------------------------------------- @@ -223,7 +268,6 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, bt_id=0 rs_id=0 R0_id=0 - mu_i_id=0 resm_id=0 nns_id=0 inQ_id=0 @@ -237,7 +281,8 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, inpr_id=0 inpe_id=0 omegas_id=0 - outer_delta_id=0 + Re_delta_id=0 + Im_delta_id=0 omegas_e_id=0 omegas_i_id=0 @@ -262,15 +307,8 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, IF(debug_flag) PRINT *," - Defining netcdf globals" CALL check( nf90_put_att(ncid,nf90_global,"title", $ "SLAYER outputs")) - ! define global attributes - !CALL check( nf90_put_att(ncid,nf90_global,'ro', ro)) - !CALL check( nf90_put_att(ncid,nf90_global,'psio', psio)) - !CALL check( nf90_put_att(ncid,nf90_global,'bt0', bt0)) - !CALL check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) - !CALL check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) - !CALL check( nf90_put_att(ncid,nf90_global,"n", nn)) CALL check( nf90_put_att(ncid,nf90_global,"version", version)) - ! define dimensions + IF(debug_flag) PRINT *," - Defining dimensions in netcdf" IF(msing>0)THEN @@ -296,22 +334,20 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, $ qsing_dim,rs_id)) CALL check( nf90_def_var(ncid,"R0",nf90_double, $ qsing_dim,R0_id)) - CALL check( nf90_def_var(ncid,"mu_i",nf90_double, - $ qsing_dim,mu_i_id)) + !CALL check( nf90_def_var(ncid,"mu_i",nf90_double, + !$ qsing_dim,mu_i_id)) CALL check( nf90_def_var(ncid,"resm",nf90_int, $ qsing_dim,resm_id)) CALL check( nf90_def_var(ncid,"nns_arr",nf90_int, $ qsing_dim,nns_id)) - CALL check( nf90_def_var(ncid,"qval",nf90_int, - $ qsing_dim,qval_id)) - CALL check( nf90_def_var(ncid,"q_rational",nf90_double, - $ qsing_dim,qr_id) ) + !CALL check( nf90_def_var(ncid,"qval",nf90_int, + !$ qsing_dim,qval_id)) CALL check( nf90_def_var(ncid,"Q",nf90_double, $ qsing_dim,inQ_id)) - CALL check( nf90_def_var(ncid,"Q_e",nf90_double, - $ qsing_dim,inQ_e_id)) - CALL check( nf90_def_var(ncid,"Q_i",nf90_double, - $ qsing_dim,inQ_i_id)) + ! CALL check( nf90_def_var(ncid,"Q_e",nf90_double, + !$ qsing_dim,inQ_e_id)) + ! CALL check( nf90_def_var(ncid,"Q_i",nf90_double, + !$ qsing_dim,inQ_i_id)) CALL check( nf90_def_var(ncid,"c_beta",nf90_double, $ qsing_dim,inc_beta_id)) CALL check( nf90_def_var(ncid,"ds",nf90_double, @@ -324,12 +360,14 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, $ qsing_dim,inpe_id)) CALL check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) - ! CALL check( nf90_def_var(ncid,"omegas_e",nf90_double, - !$ qsing_dim,omegas_e_id)) - ! CALL check( nf90_def_var(ncid,"omegas_i",nf90_double, - !$ qsing_dim,omegas_i_id)) - CALL check( nf90_def_var(ncid,"outer_delta",nf90_double, - $ qsing_dim,outer_delta_id)) + CALL check( nf90_def_var(ncid,"omegas_e",nf90_double, + $ qsing_dim,omegas_e_id)) + CALL check( nf90_def_var(ncid,"omegas_i",nf90_double, + $ qsing_dim,omegas_i_id)) + CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, + $ qsing_dim,Re_delta_id)) + CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, + $ qsing_dim,Im_delta_id)) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" @@ -341,30 +379,31 @@ SUBROUTINE slayer_netcdf_inputs(msing,ne_arr,te_arr,ni_arr,ti_arr, ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) CALL check( nf90_put_var(ncid,ne_id, ne_arr)) - CALL check( nf90_put_var(ncid,ni_id, ni_id)) - CALL check( nf90_put_var(ncid,te_id, te_id)) - CALL check( nf90_put_var(ncid,ti_id, ti_id)) + CALL check( nf90_put_var(ncid,ni_id, ni_arr)) + CALL check( nf90_put_var(ncid,te_id, te_arr)) + CALL check( nf90_put_var(ncid,ti_id, ti_arr)) CALL check( nf90_put_var(ncid,zeff_id, zeff_arr)) CALL check( nf90_put_var(ncid,shear_id, shear)) CALL check( nf90_put_var(ncid,bt_id, bt_arr)) CALL check( nf90_put_var(ncid,rs_id, rs_arr)) CALL check( nf90_put_var(ncid,R0_id, R0_arr)) - CALL check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) + !CALL check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) CALL check( nf90_put_var(ncid,resm_id, resm)) CALL check( nf90_put_var(ncid,nns_id, nns_arr)) !CALL check( nf90_put_var(ncid,qval_id, qval_arr)) CALL check( nf90_put_var(ncid,inQ_id, inQ_arr)) - CALL check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) - CALL check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) + !CALL check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) + !CALL check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) CALL check( nf90_put_var(ncid,inc_beta_id, inc_beta_arr)) CALL check( nf90_put_var(ncid,inds_id, inds_arr)) CALL check( nf90_put_var(ncid,intau_id, intau_arr)) CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) CALL check( nf90_put_var(ncid,inpe_id, inpe_arr)) CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) - !CALL check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) - !CALL check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) - CALL check( nf90_put_var(ncid,outer_delta_id,outer_delta_arr)) + CALL check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) + CALL check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) + CALL check( nf90_put_var(ncid,Re_delta_id,Re_deltaprime_arr)) + CALL check( nf90_put_var(ncid,Im_delta_id,Im_deltaprime_arr)) c ----------------------------------------------------------------------- c close file From 5c48a44fde712ada41828690266ea4d6420f8cc2 Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Thu, 3 Oct 2024 14:53:04 -0700 Subject: [PATCH 012/118] WIP: SLAYER gamma refinement algo --- slayer/gslayer.f | 208 +++++++++++++++++++++++++++++++++++++++-------- slayer/slayer.f | 13 +-- 2 files changed, 180 insertions(+), 41 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 9c89d6c80..a731041fe 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -275,36 +275,36 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, $ intau,inQ0,inpr,inpe INTEGER, INTENT(IN) :: qval,scan_radius,coarse_grid_size + INTEGER :: new_scan_radius,new_coarse_grid_size !REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs COMPLEX(r8) :: delta REAL(r8), INTENT(IN) :: deltaprime - INTEGER, PARAMETER :: fine_grid_size = 5 + INTEGER :: fine_grid_size, new_fine_grid_size REAL(r8), PARAMETER :: tolerance = 1.0E-6 REAL(r8) :: delta_real, delta_imag, threshold - INTEGER :: i, j, k, l, count + INTEGER :: i, j, k, l, m, count, match_count + LOGICAL :: repeat REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, - $ inQ_coarse, iinQ_coarse + $ inQ_coarse, iinQ_coarse, inQ_coarse_shifted + REAL(r8), DIMENSION(2) :: both_coarse_inQs TYPE(result_type), INTENT(INOUT) :: results + INTEGER :: max_points, new_max_points - ! Arrays to store results - !REAL(r8), ALLOCATABLE :: inQ_array(:), iinQ_array(:), - !$ delta_real_array(:), delta_imag_array(:) - INTEGER :: max_points + !!!!!!!!!!!!!!!! + repeat = .FALSE. - ! Calculate maximum possible number of points + fine_grid_size = 6 max_points = coarse_grid_size**2 * (1 + (fine_grid_size-1)**2) - ! Allocate arrays - !ALLOCATE(inQ_array(max_points), iinQ_array(max_points)) - !ALLOCATE(delta_real_array(max_points), - !$ delta_imag_array(max_points)) - ! Allocate arrays with maximum possible size ALLOCATE(results%inQs(max_points), results%iinQs(max_points)) ALLOCATE(results%Re_deltas(max_points), $ results%Im_deltas(max_points)) - + results%inQs=0.0 + results%iinQs=0.0 + results%Re_deltas=0.0 + results%Im_deltas=0.0 ! Initialize counter count = 0 @@ -312,10 +312,14 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, inQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) iinQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) + match_count = 0 ! Coarse grid loop DO i = 1, coarse_grid_size DO j = 1, coarse_grid_size inQ_coarse = -scan_radius + (i - 1) * inQ_step + inQ_coarse_shifted = -scan_radius + (i - 2) * inQ_step + both_coarse_inQs(1) = inQ_coarse + both_coarse_inQs(2) = inQ_coarse_shifted iinQ_coarse = -scan_radius + (j - 1) * iinQ_step ! Evaluate riccati function @@ -338,50 +342,175 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END IF ! Check if refinement is needed - IF (ABS(delta_real) > threshold) THEN + IF ((ABS(delta_real) > threshold)) THEN + ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, + !$ delta_real) == SIGN(1.0, deltaprime))) THEN + ! Fine grid loop - DO k = 2, fine_grid_size + DO m = 1, 2 + DO k = 2, fine_grid_size DO l = 2, fine_grid_size - inQ_fine = inQ_coarse + (k-1) * inQ_step / - $ (fine_grid_size - 1) - iinQ_fine = iinQ_coarse + (l-1) * iinQ_step / - $ (fine_grid_size - 1) + inQ_fine = both_coarse_inQs(m)+(k-1)*inQ_step/ + $ (fine_grid_size - 1) + iinQ_fine = iinQ_coarse + (l-1) * iinQ_step / + $ (fine_grid_size - 1) + + IF ((ABS(both_coarse_inQs(m) - inQ_fine) < + $ tolerance) .AND. (ABS(iinQ_coarse - + $ iinQ_fine) < tolerance)) CYCLE + + ! Evaluate riccati function + delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + IF (ABS(delta_real) > ABS(deltaprime)) THEN + match_count = match_count + 1 + END IF + + ! Store fine grid point + count = count + 1 + results%inQs(count) = inQ_fine + results%iinQs(count) = iinQ_fine + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END DO + END DO + END DO + END IF + END DO + END DO - IF ((ABS(inQ_coarse - inQ_fine) < - $ tolerance) .AND. (ABS(iinQ_coarse - - $ iinQ_fine) < tolerance)) CYCLE + !!!!! + + IF (match_count == 0) THEN + WRITE(*,*)"No match found, increasing scan radius" + repeat = .TRUE. + new_scan_radius = scan_radius + 2 + new_coarse_grid_size = coarse_grid_size + 100 + new_fine_grid_size = 8 + ELSE IF (match_count > 0 .AND. match_count < 3) THEN + WRITE(*,*)"Match not definitive, increasing scan resolution" + repeat = .TRUE. + new_scan_radius = scan_radius + new_coarse_grid_size = coarse_grid_size + new_fine_grid_size = 10 + ELSE + repeat = .FALSE. + WRITE(*,*)"Match found" + + END IF + + IF (repeat) THEN + WRITE(*,*)"Rerunning growth rate scan" + + !DEALLOCATE(results%inQs(max_points), results%iinQs(max_points)) + !DEALLOCATE(results%Re_deltas(max_points), + !$ results%Im_deltas(max_points)) + + new_max_points = new_coarse_grid_size**2 * (1 + + $ (new_fine_grid_size-1)**2) + + ! Resize arrays to new max number of points + CALL grow_array(results%inQs, max_points, new_max_points) + CALL grow_array(results%iinQs, max_points, new_max_points) + CALL grow_array(results%Re_deltas, max_points, new_max_points) + CALL grow_array(results%Im_deltas, max_points, new_max_points) + + results%inQs=0.0 + results%iinQs=0.0 + results%Re_deltas=0.0 + results%Im_deltas=0.0 + ! Initialize counter + count = 0 + + ! Calculate step sizes + inQ_step = (2.0 * new_scan_radius)/(new_coarse_grid_size - 1) + iinQ_step = (2.0 * new_scan_radius)/(new_coarse_grid_size - 1) + + match_count = 0 + ! Coarse grid loop + DO i = 1, new_coarse_grid_size + DO j = 1, new_coarse_grid_size + inQ_coarse = -new_scan_radius + (i - 1) * inQ_step + inQ_coarse_shifted = -scan_radius + (i - 2) * inQ_step + both_coarse_inQs(1) = inQ_coarse + both_coarse_inQs(2) = inQ_coarse_shifted + iinQ_coarse = -new_scan_radius + (j - 1) * iinQ_step - ! Evaluate riccati function + ! Evaluate riccati function + delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, + $ inds,intau,inpe,iinQ=iinQ_coarse) + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + ! Store coarse grid point + count = count + 1 + results%inQs(count) = inQ_coarse + results%iinQs(count) = iinQ_coarse + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + + IF (ABS(deltaprime) > 8) THEN + threshold = ABS(deltaprime)**(1./3.) + ELSE + threshold = 0.25 * ABS(deltaprime) + END IF + + ! Check if refinement is needed + IF ((ABS(delta_real) > threshold)) THEN + ! Fine grid loop + DO m = 1,2 + DO k = 2, new_fine_grid_size + DO l = 2, new_fine_grid_size + inQ_fine=both_coarse_inQs(m)+(k-1)*inQ_step/ + $ (new_fine_grid_size - 1) + iinQ_fine = iinQ_coarse + (l-1) * iinQ_step/ + $ (new_fine_grid_size - 1) + + IF ((ABS(both_coarse_inQs(m) - inQ_fine) < + $ tolerance) .AND. (ABS(iinQ_coarse - + $ iinQ_fine) < tolerance)) CYCLE + + ! Evaluate riccati function delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) delta_real = REAL(delta) delta_imag = AIMAG(delta) - ! Store fine grid point + IF (ABS(delta_real)>ABS(deltaprime)) THEN + match_count = match_count + 1 + END IF + + ! Store fine grid point count = count + 1 results%inQs(count) = inQ_fine results%iinQs(count) = iinQ_fine results%Re_deltas(count) = delta_real results%Im_deltas(count) = delta_imag + END DO END DO - END DO - END IF - END DO - END DO + END DO + END IF + END DO + END DO + + END IF ! Set the actual count of points results%count = count ! Resize arrays to actual number of points - CALL resize_array(results%inQs, count) - CALL resize_array(results%iinQs, count) - CALL resize_array(results%Re_deltas, count) - CALL resize_array(results%Im_deltas, count) + CALL shrink_array(results%inQs, count) + CALL shrink_array(results%iinQs, count) + CALL shrink_array(results%Re_deltas, count) + CALL shrink_array(results%Im_deltas, count) RETURN END SUBROUTINE growthrate_scan - SUBROUTINE resize_array(arr, new_size) + SUBROUTINE shrink_array(arr, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) INTEGER, INTENT(IN) :: new_size REAL(r8), ALLOCATABLE :: temp(:) @@ -389,6 +518,15 @@ SUBROUTINE resize_array(arr, new_size) ALLOCATE(temp(new_size)) temp(1:new_size) = arr(1:new_size) CALL move_alloc(temp, arr) - END SUBROUTINE resize_array + END SUBROUTINE shrink_array + SUBROUTINE grow_array(arr, old_size, new_size) + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) + INTEGER, INTENT(IN) :: old_size,new_size + REAL(r8), ALLOCATABLE :: temp(:) + + ALLOCATE(temp(new_size)) + temp(1:old_size) = arr(1:old_size) + CALL move_alloc(temp, arr) + END SUBROUTINE grow_array END MODULE gslayer_mod diff --git a/slayer/slayer.f b/slayer/slayer.f index dca43a3a8..b40460b45 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -316,6 +316,8 @@ PROGRAM slayer WRITE(*,*)"intau_arr=",intau_arr n_k = SIZE(qval_arr) + ALLOCATE(all_growthrates(n_k)) + ALLOCATE(all_growthrate_locs(n_k)) DO k=1,n_k WRITE(*,*) "Finding roots on q=", qval_arr(k), $ " rational surface" @@ -324,14 +326,13 @@ PROGRAM slayer $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), $ scan_radius,reQ_num,Re_deltaprime_arr(k), - $ results(n_k)) + $ results(k)) ! IF (k==1) THEN ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) ! ALLOCATE(all_Im_deltas(SIZE(inQs),SIZE(iinQs),n_k)) ! ALLOCATE(all_inQs(SIZE(inQs),n_k)) - ALLOCATE(all_growthrates(n_k)) - ALLOCATE(all_growthrate_locs(n_k)) + ! ENDIF ! all_Re_deltas(:,:,k) = Re_deltas ! all_Im_deltas(:,:,k) = Im_deltas @@ -366,19 +367,19 @@ PROGRAM slayer WRITE(*,*)"running analytic scan" qval_arr = (/ 2 /) - omegas_arr = (/ 0.0 /) + omegas_arr = (/ 1000.0 /) inQ_arr = (/ inQ /) inQ_e_arr = (/ inQ_e /) inQ_i_arr = (/ inQ_i /) psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ 5.0 /) + Re_deltaprime_arr = (/ 10.0 /) Im_deltaprime_arr = (/ 0.00001 /) inpr_arr = (/ inpr /) CALL growthrate_scan(2,inQ,inQ_e, $ inQ_i,inc_beta,inds, $ intau,inQ,inpr,inpe, - $ scan_radius,reQ_num,Re_deltaprime_arr(k), + $ scan_radius,reQ_num,Re_deltaprime_arr(1), $ results(1)) ! WRITE(*,*)"SIZE(inQs)",SIZE(inQs) From 27168785ff87629bac068f1b367d09baf581884c Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Thu, 17 Oct 2024 13:33:37 -0700 Subject: [PATCH 013/118] WIP: new centered AMR algo --- input/slayer.in | 6 +- slayer/gslayer.f | 348 ++++++++++++++++++++++------------------- slayer/slayer_netcdf.f | 133 +++++++--------- 3 files changed, 240 insertions(+), 247 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 3490aab22..35a904aeb 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -61,8 +61,10 @@ netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q growthrates_flag=t ! Calculate growthrates on each rational surface - layer_stabilityscan_flag=t ! Generate Re(Q),Im(Q) scans for each rational surface - !bal_flag=f ! calculate the resonant field penetration threshold from torque balance + analytic_growthrates_flag=f ! Generate Re(Q),Im(Q) scans for each rational surface + br_th_flag=t ! Calculate br_th + compress_deltas=f ! Only output essential growth rate grid points + bal_flag=f ! calculate the resonant field penetration threshold from torque balance / &SLAYER_DIAGNOSE riccati_out=f ! writes LSDOE Riccati integration to an ascii file diff --git a/slayer/gslayer.f b/slayer/gslayer.f index a731041fe..3bd9b47b9 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -266,35 +266,41 @@ END SUBROUTINE old_growthrate_scan c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,scan_radius,coarse_grid_size, - $ deltaprime,results) + $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, + $ compress_deltas,deltaprime,results) c----------------------------------------------------------------------- c Declarations c----------------------------------------------------------------------- ! Inputs REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, $ intau,inQ0,inpr,inpe - INTEGER, INTENT(IN) :: qval,scan_radius,coarse_grid_size - INTEGER :: new_scan_radius,new_coarse_grid_size + INTEGER, INTENT(IN) :: qval,scan_radius,ncoarse + INTEGER :: new_scan_radius,new_ncoarse !REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs COMPLEX(r8) :: delta REAL(r8), INTENT(IN) :: deltaprime - INTEGER :: fine_grid_size, new_fine_grid_size + INTEGER :: nfine, new_nfine REAL(r8), PARAMETER :: tolerance = 1.0E-6 REAL(r8) :: delta_real, delta_imag, threshold INTEGER :: i, j, k, l, m, count, match_count LOGICAL :: repeat + LOGICAL, INTENT(IN) :: compress_deltas REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, - $ inQ_coarse, iinQ_coarse, inQ_coarse_shifted - REAL(r8), DIMENSION(2) :: both_coarse_inQs + $ inQ_coarse, iinQ_coarse TYPE(result_type), INTENT(INOUT) :: results INTEGER :: max_points, new_max_points - + INTEGER :: ci, cj, nx, ny + REAL(r8) :: dx, dy, overlap_factor + INTEGER :: fi, fj + REAL(r8) :: fine_dx, fine_dy, overlap_x, overlap_y + REAL(r8) :: x_start, x_end, y_start, y_end, x, y !!!!!!!!!!!!!!!! repeat = .FALSE. - - fine_grid_size = 6 - max_points = coarse_grid_size**2 * (1 + (fine_grid_size-1)**2) + dx = 1.0 + dy = 1.0 + nfine = 6 + overlap_factor = 0.5 + max_points = ncoarse**2 * (1 + (nfine-1)**2) ! Allocate arrays with maximum possible size ALLOCATE(results%inQs(max_points), results%iinQs(max_points)) @@ -309,77 +315,84 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, count = 0 ! Calculate step sizes - inQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) - iinQ_step = (2.0 * scan_radius) / (coarse_grid_size - 1) + inQ_step = (2.0 * scan_radius) / (ncoarse - 1) + iinQ_step = (2.0 * scan_radius) / (ncoarse - 1) + dx = inQ_step + dy = iinQ_step match_count = 0 ! Coarse grid loop - DO i = 1, coarse_grid_size - DO j = 1, coarse_grid_size - inQ_coarse = -scan_radius + (i - 1) * inQ_step - inQ_coarse_shifted = -scan_radius + (i - 2) * inQ_step - both_coarse_inQs(1) = inQ_coarse - both_coarse_inQs(2) = inQ_coarse_shifted - iinQ_coarse = -scan_radius + (j - 1) * iinQ_step - - ! Evaluate riccati function - delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, + DO i = 1, ncoarse + DO j = 1, ncoarse + inQ_coarse = -scan_radius + (i - 1) * inQ_step + iinQ_coarse = -scan_radius + (j - 1) * iinQ_step + + ! Evaluate riccati function + delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, $ inds,intau,inpe,iinQ=iinQ_coarse) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) - - ! Store coarse grid point - count = count + 1 - results%inQs(count) = inQ_coarse - results%iinQs(count) = iinQ_coarse - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - - IF (ABS(deltaprime) > 8) THEN - threshold = ABS(deltaprime)**(1./3.) - ELSE - threshold = 0.25 * ABS(deltaprime) - END IF - - ! Check if refinement is needed - IF ((ABS(delta_real) > threshold)) THEN - ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, - !$ delta_real) == SIGN(1.0, deltaprime))) THEN - - ! Fine grid loop - DO m = 1, 2 - DO k = 2, fine_grid_size - DO l = 2, fine_grid_size - inQ_fine = both_coarse_inQs(m)+(k-1)*inQ_step/ - $ (fine_grid_size - 1) - iinQ_fine = iinQ_coarse + (l-1) * iinQ_step / - $ (fine_grid_size - 1) - - IF ((ABS(both_coarse_inQs(m) - inQ_fine) < - $ tolerance) .AND. (ABS(iinQ_coarse - - $ iinQ_fine) < tolerance)) CYCLE - - ! Evaluate riccati function - delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + IF (.NOT. compress_deltas) THEN + ! Store coarse grid point + count = count + 1 + results%inQs(count) = inQ_coarse + results%iinQs(count) = iinQ_coarse + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END IF + + IF (ABS(deltaprime) > 8) THEN + threshold = ABS(deltaprime)**(1./3.) + ELSE + threshold = 0.25 * ABS(deltaprime) + END IF + + ! Check if refinement is needed + IF ((ABS(delta_real) > threshold)) THEN + ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, + !$ delta_real) == SIGN(1.0, deltaprime))) THEN + + ! Fine grid loop + fine_dx = dx / nfine + fine_dy = dy / nfine + + overlap_x = overlap_factor * fine_dx + overlap_y = overlap_factor * fine_dy + + x_start = inQ_coarse - dx/2 + overlap_x + x_end = inQ_coarse + dx/2 - overlap_x + y_start = iinQ_coarse - dy/2 + overlap_y + y_end = iinQ_coarse + dy/2 - overlap_y + + DO fj = 0, nfine-1 + iinQ_fine = y_start + fj * (y_end-y_start) / (nfine-1) + DO fi = 0, nfine-1 + inQ_fine = x_start + fi * (x_end-x_start) / (nfine-1) + IF ((ABS(inQ_coarse - inQ_fine) < + $ tolerance) .AND. (ABS(iinQ_coarse - + $ iinQ_fine) < tolerance)) CYCLE + + ! Evaluate riccati function + delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) - - IF (ABS(delta_real) > ABS(deltaprime)) THEN - match_count = match_count + 1 - END IF - - ! Store fine grid point - count = count + 1 - results%inQs(count) = inQ_fine - results%iinQs(count) = iinQ_fine - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END DO - END DO - END DO - END IF - END DO + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + IF (ABS(delta_real)>ABS(deltaprime)) THEN + match_count = match_count + 1 + END IF + + ! Store fine grid point + count = count + 1 + results%inQs(count) = inQ_fine + results%iinQs(count) = iinQ_fine + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END DO + END DO + END IF + END DO END DO !!!!! @@ -388,14 +401,14 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, WRITE(*,*)"No match found, increasing scan radius" repeat = .TRUE. new_scan_radius = scan_radius + 2 - new_coarse_grid_size = coarse_grid_size + 100 - new_fine_grid_size = 8 + new_ncoarse = ncoarse + 100 + new_nfine = nfine ELSE IF (match_count > 0 .AND. match_count < 3) THEN WRITE(*,*)"Match not definitive, increasing scan resolution" repeat = .TRUE. new_scan_radius = scan_radius - new_coarse_grid_size = coarse_grid_size - new_fine_grid_size = 10 + new_ncoarse = ncoarse + new_nfine = 8 ELSE repeat = .FALSE. WRITE(*,*)"Match found" @@ -403,98 +416,103 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END IF IF (repeat) THEN - WRITE(*,*)"Rerunning growth rate scan" - - !DEALLOCATE(results%inQs(max_points), results%iinQs(max_points)) - !DEALLOCATE(results%Re_deltas(max_points), - !$ results%Im_deltas(max_points)) - - new_max_points = new_coarse_grid_size**2 * (1 + - $ (new_fine_grid_size-1)**2) - - ! Resize arrays to new max number of points - CALL grow_array(results%inQs, max_points, new_max_points) - CALL grow_array(results%iinQs, max_points, new_max_points) - CALL grow_array(results%Re_deltas, max_points, new_max_points) - CALL grow_array(results%Im_deltas, max_points, new_max_points) - - results%inQs=0.0 - results%iinQs=0.0 - results%Re_deltas=0.0 - results%Im_deltas=0.0 - ! Initialize counter - count = 0 - - ! Calculate step sizes - inQ_step = (2.0 * new_scan_radius)/(new_coarse_grid_size - 1) - iinQ_step = (2.0 * new_scan_radius)/(new_coarse_grid_size - 1) - - match_count = 0 - ! Coarse grid loop - DO i = 1, new_coarse_grid_size - DO j = 1, new_coarse_grid_size - inQ_coarse = -new_scan_radius + (i - 1) * inQ_step - inQ_coarse_shifted = -scan_radius + (i - 2) * inQ_step - both_coarse_inQs(1) = inQ_coarse - both_coarse_inQs(2) = inQ_coarse_shifted - iinQ_coarse = -new_scan_radius + (j - 1) * iinQ_step - - ! Evaluate riccati function - delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, - $ inds,intau,inpe,iinQ=iinQ_coarse) + WRITE(*,*)"Rerunning growth rate scan" + + new_max_points = new_ncoarse**2 * (1 + + $ (new_nfine-1)**2) + + ! Resize arrays to new max number of points + CALL grow_array(results%inQs, max_points, new_max_points) + CALL grow_array(results%iinQs, max_points, new_max_points) + CALL grow_array(results%Re_deltas, max_points, new_max_points) + CALL grow_array(results%Im_deltas, max_points, new_max_points) + + results%inQs=0.0 + results%iinQs=0.0 + results%Re_deltas=0.0 + results%Im_deltas=0.0 + ! Initialize counter + count = 0 + + ! Calculate step sizes + inQ_step = (2.0 * new_scan_radius)/(new_ncoarse - 1) + iinQ_step = (2.0 * new_scan_radius)/(new_ncoarse - 1) + + match_count = 0 + + ! Coarse grid loop + DO i = 1, new_ncoarse + DO j = 1, new_ncoarse + inQ_coarse = -new_scan_radius + (i - 1) * inQ_step + iinQ_coarse = -new_scan_radius + (j - 1) * iinQ_step + + ! Evaluate riccati function + delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, + $ inds,intau,inpe,iinQ=iinQ_coarse) + delta_real = REAL(delta) + delta_imag = AIMAG(delta) + + IF (.NOT. compress_deltas) THEN + ! Store coarse grid point + count = count + 1 + results%inQs(count) = inQ_coarse + results%iinQs(count) = iinQ_coarse + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END IF + + IF (ABS(deltaprime) > 8) THEN + threshold = ABS(deltaprime)**(1./3.) + ELSE + threshold = 0.25 * ABS(deltaprime) + END IF + + ! Check if refinement is needed + IF ((ABS(delta_real) > threshold)) THEN + ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, + !$ delta_real) == SIGN(1.0, deltaprime))) THEN + + ! Fine grid loop + fine_dx = dx / new_nfine + fine_dy = dy / new_nfine + + overlap_x = overlap_factor * fine_dx + overlap_y = overlap_factor * fine_dy + + x_start = inQ_coarse - dx/2 - overlap_x + x_end = inQ_coarse + dx/2 + overlap_x + y_start = iinQ_coarse - dy/2 - overlap_y + y_end = iinQ_coarse + dy/2 + overlap_y + + DO fj = 0, nfine-1 + iinQ_fine = y_start+fj * (y_end-y_start) / (new_nfine-1) + DO fi = 0, nfine-1 + inQ_fine = x_start+fi * (x_end-x_start) /(new_nfine-1) + IF ((ABS(inQ_coarse - inQ_fine) < + $ tolerance) .AND. (ABS(iinQ_coarse - + $ iinQ_fine) < tolerance)) CYCLE + + ! Evaluate riccati function + delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, + $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) delta_real = REAL(delta) delta_imag = AIMAG(delta) - ! Store coarse grid point + IF (ABS(delta_real)>ABS(deltaprime)) THEN + match_count = match_count + 1 + END IF + + ! Store fine grid point count = count + 1 - results%inQs(count) = inQ_coarse - results%iinQs(count) = iinQ_coarse + results%inQs(count) = inQ_fine + results%iinQs(count) = iinQ_fine results%Re_deltas(count) = delta_real results%Im_deltas(count) = delta_imag - - IF (ABS(deltaprime) > 8) THEN - threshold = ABS(deltaprime)**(1./3.) - ELSE - threshold = 0.25 * ABS(deltaprime) - END IF - - ! Check if refinement is needed - IF ((ABS(delta_real) > threshold)) THEN - ! Fine grid loop - DO m = 1,2 - DO k = 2, new_fine_grid_size - DO l = 2, new_fine_grid_size - inQ_fine=both_coarse_inQs(m)+(k-1)*inQ_step/ - $ (new_fine_grid_size - 1) - iinQ_fine = iinQ_coarse + (l-1) * iinQ_step/ - $ (new_fine_grid_size - 1) - - IF ((ABS(both_coarse_inQs(m) - inQ_fine) < - $ tolerance) .AND. (ABS(iinQ_coarse - - $ iinQ_fine) < tolerance)) CYCLE - - ! Evaluate riccati function - delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) - - IF (ABS(delta_real)>ABS(deltaprime)) THEN - match_count = match_count + 1 - END IF - - ! Store fine grid point - count = count + 1 - results%inQs(count) = inQ_fine - results%iinQs(count) = iinQ_fine - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END DO - END DO - END DO - END IF + END DO END DO + END IF END DO + END DO END IF diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 31b6f17f2..f4fbdbb45 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -51,19 +51,18 @@ END SUBROUTINE check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out( - $ growthrates_flag,msing,qval_arr, - $ all_growthrates,all_growthrate_locs, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ inpr_arr,Re_deltaprime_arr,Im_deltaprime_arr, - $ results) - LOGICAL, INTENT(IN) :: growthrates_flag + SUBROUTINE slayer_netcdf_out(growthrates_flag, + $ analytic_growthrates_flag,br_th_flag,msing,qval_arr, + $ br_th,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ inpr_arr,Re_deltaprime_arr,Im_deltaprime_arr,results) + LOGICAL, INTENT(IN) :: growthrates_flag,analytic_growthrates_flag, + $ br_th_flag INTEGER, INTENT(IN) :: msing REAL(r8), DIMENSION(:), INTENT(IN) :: $ omegas_arr,inQ_arr, $ inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr, - $ all_growthrates,all_growthrate_locs,Re_deltaprime_arr, - $ Im_deltaprime_arr + $ Re_deltaprime_arr,Im_deltaprime_arr + REAL(r8), INTENT(IN) :: br_th INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr TYPE(result_type), INTENT(IN) :: results(8) INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, @@ -71,7 +70,7 @@ SUBROUTINE slayer_netcdf_out( $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id, $ gamma_err_id,gamma_loc_id,roots_dim,Re_dp_id,Im_dp_id, - $ rdpp_id,idpp_id,inpr_id + $ rdpp_id,idpp_id,inpr_id,br_th_id INTEGER :: run, run_dimid, point_dimid, varids(4), $ max_points @@ -116,19 +115,6 @@ SUBROUTINE slayer_netcdf_out( CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) - ! CALL check( nf90_def_dim(ncid,"ReQ_arr",ReQ_n, - !$ ReQ_dim) ) !r_dim = q_rational - ! CALL check( nf90_def_var(ncid,"ReQ_arr",nf90_double,ReQ_dim, - !$ ReQ_id)) - ! CALL check( nf90_def_dim(ncid,"ImQ_arr",ImQ_n,ImQ_dim) ) !r_dim = q_rational - ! CALL check( nf90_def_var(ncid,"ImQ_arr",nf90_double,ImQ_dim, - !$ ImQ_id)) - CALL check( nf90_def_var(ncid,"growthrates",nf90_double, - $ qsing_dim,gamma_id)) - CALL check( nf90_def_var(ncid,"growthrate_locs",nf90_double, - $ qsing_dim,gamma_loc_id)) - ! CALL check( nf90_def_var(ncid,"growthrates_inQ",nf90_double, - !$ (/roots_dim, qsing_dim/),gamma_loc_id)) CALL check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) CALL check( nf90_def_var(ncid,"Q",nf90_double, @@ -143,49 +129,42 @@ SUBROUTINE slayer_netcdf_out( $ qsing_dim,inpr_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ qsing_dim,qr_id) ) - - !!! For results - ! Define dimensions - ! CALL check( nf90_def_dim(ncid, "msing", msing, dimids(1)) ) - ! CALL check( nf90_def_dim(ncid, "max_points", - !$ maxval(results%count), dimids(2)) ) - !CALL check( nf90_def_dim(ncid, "run", msing, run_dimid) ) CALL check( nf90_def_dim(ncid, "points", max_points, $ point_dimid) ) - ! Define variables - CALL check( nf90_def_var(ncid, "Re_Qs", nf90_double, - $ [point_dimid, qsing_dim], varids(1)) ) - CALL check( nf90_def_var(ncid, "Im_Qs", nf90_double, - $ [point_dimid, qsing_dim], varids(2)) ) - CALL check( nf90_def_var(ncid, "Re_deltas", nf90_double, - $ [point_dimid, qsing_dim], varids(3)) ) - CALL check( nf90_def_var(ncid, "Im_deltas", nf90_double, - $ [point_dimid, qsing_dim], varids(4)) ) + IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + CALL check( nf90_def_var(ncid,"growthrates",nf90_double, + $ qsing_dim,gamma_id)) + CALL check(nf90_def_var(ncid,"growthrate_locs",nf90_double, + $ qsing_dim,gamma_loc_id)) + CALL check( nf90_def_var(ncid, "Re_Qs", nf90_double, + $ [point_dimid, qsing_dim], varids(1)) ) + CALL check( nf90_def_var(ncid, "Im_Qs", nf90_double, + $ [point_dimid, qsing_dim], varids(2)) ) + CALL check( nf90_def_var(ncid, "Re_deltas", nf90_double, + $ [point_dimid, qsing_dim], varids(3)) ) + CALL check( nf90_def_var(ncid, "Im_deltas", nf90_double, + $ [point_dimid, qsing_dim], varids(4)) ) + END IF - ENDIF + IF (br_th_flag) THEN + CALL check( nf90_def_var(ncid,"br_th",nf90_double, + $ qsing_dim,br_th_id) ) + END IF + END IF - !IF (growthrates_flag) .OR. (analytic_) THEN - !CALL check( nf90_def_var(ncid, "Re_Deltas", nf90_double, - !$ (/ReQ_dim, ImQ_dim, qsing_dim/), Re_dp_id) ) - !CALL check( nf90_def_var(ncid, "Im_Deltas", nf90_double, - !$ (/ReQ_dim, ImQ_dim, qsing_dim/), Im_dp_id) ) - CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, - $ qsing_dim,rdpp_id) ) - CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, - $ qsing_dim,idpp_id) ) - ! CALL check( nf90_def_var(ncid, "inQs", nf90_double, - !$ (/ReQ_dim, qsing_dim/), inQs_id) ) - !ENDIF + IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, + $ qsing_dim,rdpp_id) ) + CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, + $ qsing_dim,idpp_id) ) + END IF ! end definitions CALL check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- - ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) - !CALL check( nf90_put_var(ncid,ReQ_id, inQs)) - !CALL check( nf90_put_var(ncid,ImQ_id, iinQs)) CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) @@ -194,31 +173,25 @@ SUBROUTINE slayer_netcdf_out( CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) CALL check( nf90_put_var(ncid,qr_id, qval_arr)) - ! IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" - !IF (growthrates_flag) THEN - CALL check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) - CALL check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) - !CALL check( nf90_put_var(ncid,Re_dp_id,all_Re_deltas)) - !CALL check( nf90_put_var(ncid,Im_dp_id,all_Im_deltas)) - !CALL check( nf90_put_var(ncid,inQs_id,all_inQs)) - !ENDIF - !CALL check( nf90_put_var(ncid,gamma_id,all_growthrates)) - !CALL check( nf90_put_var(ncid,gamma_loc_id,all_growthrate_locs)) - ! Write data - DO run = 1, msing - CALL check( nf90_put_var(ncid, varids(1), results(run)%inQs, - $ start=[1, run], count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid, varids(2), results(run)%iinQs, - $ start=[1, run], count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid, varids(3), - $ results(run)%Re_deltas, start=[1, run], - $ count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid, varids(4), - $ results(run)%Im_deltas, start=[1, run], - $ count=[results(run)%count, 1]) ) - END DO - !CALL check(nf90_put_var(ncid,varids(5),[results(run)%count,run=1,msing]) ) - + IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + CALL check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) + CALL check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) + DO run = 1, msing + CALL check( nf90_put_var(ncid,varids(1),results(run)%inQs, + $ start=[1, run], count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid,varids(2),results(run)%iinQs, + $ start=[1, run], count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid, varids(3), + $ results(run)%Re_deltas, start=[1, run], + $ count=[results(run)%count, 1]) ) + CALL check( nf90_put_var(ncid, varids(4), + $ results(run)%Im_deltas, start=[1, run], + $ count=[results(run)%count, 1]) ) + END DO + END IF + IF (br_th_flag) THEN + CALL check( nf90_put_var(ncid,br_th_id, (/ br_th /))) + END IF c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- From 0ae4888488142238b758b22ebc53571dbe22b4c0 Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Sun, 27 Oct 2024 13:20:01 -0700 Subject: [PATCH 014/118] no AMR if small deltaprime --- slayer/gslayer.f | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 3bd9b47b9..9c8a37ac8 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -300,7 +300,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, dy = 1.0 nfine = 6 overlap_factor = 0.5 - max_points = ncoarse**2 * (1 + (nfine-1)**2) + max_points = ncoarse**2 * ((nfine)**2 - 1) ! Allocate arrays with maximum possible size ALLOCATE(results%inQs(max_points), results%iinQs(max_points)) @@ -333,7 +333,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, delta_real = REAL(delta) delta_imag = AIMAG(delta) - IF (.NOT. compress_deltas) THEN + IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 2)) THEN ! Store coarse grid point count = count + 1 results%inQs(count) = inQ_coarse @@ -349,7 +349,8 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END IF ! Check if refinement is needed - IF ((ABS(delta_real) > threshold)) THEN + IF ((ABS(delta_real) > threshold) .AND. + $ (ABS(deltaprime) > 2)) THEN ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN @@ -452,7 +453,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, delta_real = REAL(delta) delta_imag = AIMAG(delta) - IF (.NOT. compress_deltas) THEN + IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 2)) THEN ! Store coarse grid point count = count + 1 results%inQs(count) = inQ_coarse @@ -468,7 +469,8 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END IF ! Check if refinement is needed - IF ((ABS(delta_real) > threshold)) THEN + IF ((ABS(delta_real) > threshold) .AND. + $ (ABS(deltaprime) > 2)) THEN ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN @@ -515,15 +517,24 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END DO END IF - + WRITE(*,*)"Passed IF return" + WRITE(*,*)"count: ",count + WRITE(*,*)"max_points: ",max_points ! Set the actual count of points results%count = count - ! Resize arrays to actual number of points - CALL shrink_array(results%inQs, count) - CALL shrink_array(results%iinQs, count) - CALL shrink_array(results%Re_deltas, count) - CALL shrink_array(results%Im_deltas, count) + + WRITE(*,*)"Passed Set the actual count of points" + IF (count < max_points) THEN + ! Resize arrays to actual number of points + CALL shrink_array(results%inQs, count) + CALL shrink_array(results%iinQs, count) + CALL shrink_array(results%Re_deltas, count) + CALL shrink_array(results%Im_deltas, count) + END IF + + WRITE(*,*)"Arrays successfully shrunk" + RETURN END SUBROUTINE growthrate_scan From 27dcf0a3e9941bac64508c8da7c446e96b18a758 Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Mon, 28 Oct 2024 13:38:18 -0700 Subject: [PATCH 015/118] function call bug fixes --- slayer/delta.f | 354 +++++++++++++++++++++---------------------- slayer/layerinputs.f | 16 +- slayer/slayer.f | 74 +++------ 3 files changed, 206 insertions(+), 238 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 767a80dae..99463b589 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -26,7 +26,7 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - + Q=inQ IF(present(iinQ)) Q=inQ+ifac*iinQ Q_e=inQ_e @@ -36,7 +36,7 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, c_beta=inc_beta ds=inds tau=intau - + IF ((layfac>0).AND.(ABS(Q-Q_e)xout) istep=istep+1 CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) - WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) + WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) WRITE(out2_unit,'(1x,3(es17.8e3))')x,REAL(y),AIMAG(y) - ENDDO + ENDDO CLOSE(bin_unit) CLOSE(out2_unit) ELSE @@ -98,10 +98,10 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, ENDIF ! w=0 when Q=Q_e. Why? - + CALL w_der(neq,x,y,dy) riccati=pi/dy(1) - DEALLOCATE(atol,y,dy,iwork,rwork) + DEALLOCATE(atol,y,dy,iwork,rwork) END FUNCTION riccati c----------------------------------------------------------------------- @@ -127,37 +127,37 @@ SUBROUTINE w_der(neq,x,y,dy) IF (parflow_flag) THEN C1=((1 + tau)*x**2*pe* $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i)))) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))) $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -165,106 +165,106 @@ SUBROUTINE w_der(neq,x,y,dy) $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) - + C1p=((1 + tau)*x**2*pe* $ ((2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ **2)/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** $ 3 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (12*ds**2*pr*(1 + tau)*x**2 + + $ (12*ds**2*pr*(1 + tau)*x**2 + $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** $ 2 - (2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** $ 2 - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((12*ds**2*pr*(1 + tau)*x**2 + + $ (-((12*ds**2*pr*(1 + tau)*x**2 + $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) $ + (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2 $ - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)**2* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**3 $ + ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -273,14 +273,14 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) $ - ((1 + tau)*x**2*pe* - $ (2*pr*x + 2*x*pe + + $ (2*pr*x + 2*x*pe + $ (ds**2*(1 + tau)*x**6*pe**2* $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ $ c_beta**2))/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2) - + $ c_beta**2 + + $ ifac*(Q - Q_e))**2) - $ (6*ds**2*(1 + tau)*x**5*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -295,41 +295,41 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) $ *(-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -340,41 +340,41 @@ SUBROUTINE w_der(neq,x,y,dy) $ c_beta**2 + ifac*(Q - Q_e))) $ **2 + (2*(1 + tau)*x*pe* $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -382,7 +382,7 @@ SUBROUTINE w_der(neq,x,y,dy) $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) - + C2=((1 + tau)*x**2*pe* $ ((ds**2*x**4*pe)/ $ (c_beta**2* @@ -392,13 +392,13 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e)) $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -406,15 +406,15 @@ SUBROUTINE w_der(neq,x,y,dy) $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) - + C2p=((1 + tau)*x**2*pe* $ (-((ds**2*x**4*pe* $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ $ c_beta**2))/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2)) + + $ c_beta**2 + + $ ifac*(Q - Q_e))**2)) + $ (4*ds**2*x**3*pe)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -425,40 +425,40 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e)) $ **2 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + + $ (4*ds**2*pr*(1 + tau)*x**3 + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ (-((4*ds**2*pr*(1 + tau)*x**3 + $ 2*x* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2* $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -467,14 +467,14 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e))) $ - ((1 + tau)*x**2*pe* - $ (2*pr*x + 2*x*pe + + $ (2*pr*x + 2*x*pe + $ (ds**2*(1 + tau)*x**6*pe**2* $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ $ c_beta**2))/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2) - + $ c_beta**2 + + $ ifac*(Q - Q_e))**2) - $ (6*ds**2*(1 + tau)*x**5*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -496,15 +496,15 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e)) $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -522,15 +522,15 @@ SUBROUTINE w_der(neq,x,y,dy) $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e)) $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + $ ifac*ds**2*(Q - Q_i)))/ $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ifac*Q + pr*x**2 + x**2*pe - $ (ds**2*(1 + tau)*x**6*pe**2)/ $ (c_beta**2* $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -543,24 +543,24 @@ SUBROUTINE w_der(neq,x,y,dy) C1p=0 C2=0 C2p=0 - ENDIF - + ENDIF + IF (PeOhmOnly_flag) THEN - G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + + G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) ELSE - G=(x**2*pe + - $ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + + G=(x**2*pe + + $ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) ENDIF - + C3=x**2/(x**2 + (ds**2*(1 + tau)*x**4*pe)/ $ c_beta**2 + ifac*(Q - Q_e)) - + C3p=-((x**2*(2*x + (4*ds**2*(1 + tau)*x**3*pe)/ $ c_beta**2))/ $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ @@ -570,11 +570,11 @@ SUBROUTINE w_der(neq,x,y,dy) $ c_beta**2 + (0,1)*(Q - Q_e)) A1=(C1 + (C3p/C3)*(C2 + 1) + C2p)/(C2 + 1) - + A2=(C1p + C1*(C3p/C3) - G/C3)/(C2 + 1) - + dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x - + RETURN END SUBROUTINE w_der c----------------------------------------------------------------------- @@ -619,7 +619,7 @@ FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - + Q=inQ Q_e=inQ_e Q_i=inQ_i @@ -638,10 +638,10 @@ FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) istate = 1 iopt = 0 mf = 10 - liw = 20 + liw = 20 lrw = 22+16*neq ALLOCATE(iwork(liw),rwork(lrw)) - + xintv = 0.1 x=0.1 istep=1 @@ -668,12 +668,12 @@ END FUNCTION directred c direct integration (obsolete). c----------------------------------------------------------------------- SUBROUTINE phi_der(neq,x,y,dy) - + INTEGER, INTENT(IN) :: neq REAL(r8), INTENT(IN) :: x COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy - COMPLEX(r8), PARAMETER :: ifac=(0,1) + COMPLEX(r8), PARAMETER :: ifac=(0,1) dy(1)=(1+ifac*(Q-Q_e)*x**2.0)/x**2.0*y(2) dy(2)=(-Q*(Q-Q_i)*x**4.0+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 @@ -681,6 +681,6 @@ SUBROUTINE phi_der(neq,x,y,dy) $ +(c_beta**2.0+ifac*(Q-Q_i)*ds**2.0)*x**6.0 $ +(1+tau)*pr*ds**2.0*x**4.0)*y(1) RETURN - END SUBROUTINE phi_der - - END MODULE delta_mod + END SUBROUTINE phi_der + + END MODULE delta_mod \ No newline at end of file diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 9b1bf2cc3..7b4fdcd78 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -224,8 +224,8 @@ END FUNCTION issurfint c subprogram 3. build_inputs. c build input arrays for SLAYER c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, - $ pe_flag,qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe, + $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, $ inpr_arr,inpe_arr,omegas_arr,Re_deltaprime_arr, $ Im_deltaprime_arr) @@ -233,10 +233,10 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, c declarations. c----------------------------------------------------------------------- ! Inputs - LOGICAL, INTENT(IN) :: growthrate_flag,pe_flag CHARACTER(512), INTENT(IN) :: infile,ncfile ! Internals REAL(r8), DIMENSION(8), INTENT(IN) :: inpr_prof + REAL(r8), INTENT(IN) :: inpe LOGICAL :: firstsurf REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf,ising INTEGER :: zi, zimp, mi, mimp @@ -248,7 +248,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, INTEGER :: mms,nns,mrs,nrs,mpsi REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ my_qval,my_sval,my_bt,my_rs,zeff,inpe,R_0 + $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, @@ -367,10 +367,10 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, inpr = inpr_prof(ising) ! Check whether to include electron viscosity - IF (pe_flag) THEN - inpe=0.0165*inpr + IF (inpe < 0) THEN + my_inpe=0.0 ELSE - inpe=0.0 + my_inpe=0.0165*inpr ENDIF ne_arr(ising) = n_e @@ -432,7 +432,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,growthrate_flag, intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr - inpe_arr(ising) = inpe + inpe_arr(ising) = my_inpe omegas_arr(ising) = omega omegas_e_arr(ising) = omega_e omegas_i_arr(ising) = omega_i diff --git a/slayer/slayer.f b/slayer/slayer.f index b40460b45..57f6f7557 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -34,7 +34,7 @@ PROGRAM slayer $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,growthrates_flag,analytic_growthrates_flag, - $ pe_flag,br_th_flag !FOR TESTING + $ br_th_flag,compress_deltas REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff @@ -92,7 +92,7 @@ PROGRAM slayer $ layfac,Qratio,parflow_flag,peohmonly_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ stability_flag,growthrates_flag,analytic_growthrates_flag, - $ pe_flag,br_th_flag,bal_flag + $ br_th_flag,compress_deltas,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -166,8 +166,8 @@ PROGRAM slayer stability_flag=.FALSE. growthrates_flag=.FALSE. analytic_growthrates_flag=.FALSE. - pe_flag=.FALSE. br_th_flag=.FALSE. + compress_deltas=.FALSE. c----------------------------------------------------------------------- c read slayer.in. c----------------------------------------------------------------------- @@ -299,7 +299,7 @@ PROGRAM slayer !WRITE(*,*)"infile=",infile !WRITE(*,*)"ncfile=",ncfile CALL build_inputs(infile,ncfile,inpr_prof, - $ growthrates_flag,pe_flag,qval_arr,psi_n_rational, + $ inpe,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, $ omegas_arr,Re_deltaprime_arr,Im_deltaprime_arr) @@ -316,8 +316,6 @@ PROGRAM slayer WRITE(*,*)"intau_arr=",intau_arr n_k = SIZE(qval_arr) - ALLOCATE(all_growthrates(n_k)) - ALLOCATE(all_growthrate_locs(n_k)) DO k=1,n_k WRITE(*,*) "Finding roots on q=", qval_arr(k), $ " rational surface" @@ -325,27 +323,17 @@ PROGRAM slayer CALL growthrate_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ scan_radius,reQ_num,Re_deltaprime_arr(k), - $ results(k)) - - ! IF (k==1) THEN - ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),n_k)) - ! ALLOCATE(all_Im_deltas(SIZE(inQs),SIZE(iinQs),n_k)) - ! ALLOCATE(all_inQs(SIZE(inQs),n_k)) - - ! ENDIF - ! all_Re_deltas(:,:,k) = Re_deltas - ! all_Im_deltas(:,:,k) = Im_deltas - ! all_inQs(:,k) = inQs - - ! DEALLOCATE(Re_deltas,Im_deltas) - all_growthrates(k) = 0.0 - all_growthrate_locs(k) = 0.0 + $ scan_radius,reQ_num,compress_deltas, + $ Re_deltaprime_arr(k),results(k)) + WRITE(*,*)"Exited growthrate_scan" + ENDDO - WRITE(*,*) "all_growthrates", all_growthrates + WRITE(*,*)"Calling slayer_netcdf_out" - CALL slayer_netcdf_out(growthrates_flag,n_k,qval_arr, - $ all_growthrates,all_growthrate_locs, + br_th = 0.0 + CALL slayer_netcdf_out(growthrates_flag, + $ analytic_growthrates_flag, + $ br_th_flag,n_k,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, $ Re_deltaprime_arr,Im_deltaprime_arr, @@ -379,31 +367,14 @@ PROGRAM slayer CALL growthrate_scan(2,inQ,inQ_e, $ inQ_i,inc_beta,inds, $ intau,inQ,inpr,inpe, - $ scan_radius,reQ_num,Re_deltaprime_arr(1), - $ results(1)) - - ! WRITE(*,*)"SIZE(inQs)",SIZE(inQs) - ! WRITE(*,*)"SIZE(iinQs)",SIZE(iinQs) - - !IF (k==1) THEN - ! ALLOCATE(all_RE_deltas(SIZE(inQs),SIZE(iinQs),1)) - ! ALLOCATE(all_Im_deltas(SIZE(inQs),SIZE(iinQs),1)) - ! ALLOCATE(all_inQs(SIZE(inQs),1)) - ALLOCATE(all_growthrates(1)) - ALLOCATE(all_growthrate_locs(1)) - !ENDIF - ! all_Re_deltas(:,:,1) = Re_deltas - ! all_Im_deltas(:,:,1) = Im_deltas - ! all_inQs(:,1) = inQs - !all_roots(:,:,k) = roots - - all_growthrates(1) = 0.0 - all_growthrate_locs(1) = 0.0 + $ scan_radius,reQ_num,compress_deltas, + $ Re_deltaprime_arr(1),results(1)) WRITE(*,*)"allocations successful" - CALL slayer_netcdf_out(growthrates_flag,1,qval_arr, - $ all_growthrates,all_growthrate_locs, + br_th = 0.0 + CALL slayer_netcdf_out(growthrates_flag, + $ analytic_growthrates_flag,br_th_flag,1,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, $ Re_deltaprime_arr,Im_deltaprime_arr, @@ -489,10 +460,6 @@ PROGRAM slayer all_Im_deltas(:,:,k) = 0.0 all_inQs(:,k) = 0.0 - all_growthrates(k) = br_th !!!!!!!!!!!!!!!!!!!!!!!!! - all_growthrate_locs(k) = 0.0 - - qval_arr = (/ 3 /) inQs = (/ 1.0 /) inQs = (/ 1.0 /) @@ -508,8 +475,9 @@ PROGRAM slayer WRITE(*,*)"allocations successful" - CALL slayer_netcdf_out(growthrates_flag,1,qval_arr, - $ all_growthrates,all_growthrate_locs, + CALL slayer_netcdf_out(growthrates_flag, + $ analytic_growthrates_flag, + $ br_th_flag,1,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, $ Re_deltaprime_arr,Im_deltaprime_arr, From b29bf496176dbf04a6459b41dafbe8418fb7e3a9 Mon Sep 17 00:00:00 2001 From: +Daniel Burgess Date: Fri, 8 Nov 2024 08:26:15 -0800 Subject: [PATCH 016/118] change gamma scan tolerances --- slayer/gslayer.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 9c8a37ac8..3dce4f863 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -333,7 +333,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, delta_real = REAL(delta) delta_imag = AIMAG(delta) - IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 2)) THEN + IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 4)) THEN ! Store coarse grid point count = count + 1 results%inQs(count) = inQ_coarse @@ -350,7 +350,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, ! Check if refinement is needed IF ((ABS(delta_real) > threshold) .AND. - $ (ABS(deltaprime) > 2)) THEN + $ (ABS(deltaprime) > 4)) THEN ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN @@ -453,7 +453,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, delta_real = REAL(delta) delta_imag = AIMAG(delta) - IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 2)) THEN + IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 4)) THEN ! Store coarse grid point count = count + 1 results%inQs(count) = inQ_coarse @@ -470,7 +470,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, ! Check if refinement is needed IF ((ABS(delta_real) > threshold) .AND. - $ (ABS(deltaprime) > 2)) THEN + $ (ABS(deltaprime) > 4)) THEN ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN From a5e4789620a5f3cd8571c0b781178339803e7dc4 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 14 Nov 2024 12:40:10 -0500 Subject: [PATCH 017/118] clean up slayer growthrate scans --- slayer/gslayer.f | 289 ++++++++++++++--------------------------------- 1 file changed, 84 insertions(+), 205 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 3dce4f863..e0c41aa46 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -178,92 +178,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- c Subprogram 2. growthrate_scan -c Run stability scan on real and imaginary rotation axes -c----------------------------------------------------------------------- - SUBROUTINE old_growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,scan_radius,reQ_num, - $ Re_deltas,Im_deltas,inQs,iinQs) -c----------------------------------------------------------------------- -c Declarations -c----------------------------------------------------------------------- - ! Inputs - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe - INTEGER, INTENT(IN) :: qval,scan_radius,reQ_num - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs - INTEGER :: n_fine - REAL(r8), DIMENSION(:), ALLOCATABLE :: x_s,y_s - REAL(r8) :: x, y, dx, dy, ric_val,start_time,end_time - REAL(r8), DIMENSION(2) :: start, end, step - REAL(r8) :: coarse_threshold,fine_threshold,grad_tol,wr - COMPLEX(r8) :: delta - INTEGER :: k, w, n_steps, i2, i,j - logical :: found_zero - - INTEGER :: n_points, idx_1, idx_2 - REAL(r8) :: x_1, y_1, x_2, y_2, dist, min_dist1, min_dist2 - - REAL(r8), DIMENSION(:,:), ALLOCATABLE, - $ INTENT(OUT) :: Re_deltas,Im_deltas - wr=0.0 - ! Parameters - grad_tol = 1.0!abs(0.1*deltaprime) ! Tolerance for steep gradient - n_steps = reQ_num ! Initial number of steps -! n_fine = 10 -! if (abs(deltaprime)>100) then -! coarse_threshold = abs(0.95*deltaprime) ! Tolerance for zero value -! fine_threshold = abs(0.1*deltaprime) -! n_fine = n_fine * 2 -! else if (abs(deltaprime)>50) then -! coarse_threshold = abs(0.8*deltaprime) ! Tolerance for zero value -! fine_threshold = abs(0.1*deltaprime) -! n_fine = n_fine * 2 -! else if (abs(deltaprime)>20) then -! coarse_threshold = abs(0.66*deltaprime) ! Tolerance for zero value -! fine_threshold = abs(0.05*deltaprime) -! n_fine = n_fine * 2 -! else if (abs(deltaprime)>10) then -! coarse_threshold = abs(0.3*deltaprime) ! Tolerance for zero value -! fine_threshold = abs(0.03*deltaprime) -! else -! coarse_threshold = abs(0.1*deltaprime) ! Tolerance for zero value -! fine_threshold = abs(0.01*deltaprime) -! end if - ALLOCATE(inQs(n_steps)) - ALLOCATE(iinQs(n_steps)) - ALLOCATE(Re_deltas(n_steps,n_steps)) - ALLOCATE(Im_deltas(n_steps,n_steps)) - inQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) - iinQs = linspace((-scan_radius+wr),(scan_radius+wr),n_steps) - i=1 - j=1 - !CALL OMP_SET_NUM_THREADS(4) - !PRINT *, "Max threads: ",OMP_GET_MAX_THREADS() - !CALL cpu_time(start_time) - !!$OMP PARALLEL DO PRIVATE(j,y,delta) !BIG REWRITE NEEDED - DO i = 1, n_steps - DO j = 1, n_steps - !PRINT *, "Hello from process: ", OMP_GET_THREAD_NUM() - y=iinQs(j) - delta = riccati(inQs(i),inQ_e,inQ_i,inpr,inc_beta, - $ inds,intau,inpe,iinQ=y) - Re_deltas(i,j) = REAL(delta) - Im_deltas(i,j) = AIMAG(delta) - !PRINT *,'inQs(i):',inQs(i) - !PRINT *,'y:',y - !PRINT *,'delta:',delta - END DO - !stop - END DO - !!$OMP END PARALLEL DO - !CALL cpu_time(end_time) - !PRINT *,'Layer scan time:',end_time-start_time,'seconds' - !test comment - RETURN - END SUBROUTINE old_growthrate_scan -c----------------------------------------------------------------------- -c Subprogram 2. growthrate_scan -c Run stability scan on real and imaginary rotation axes +c Set up and iterate stability scans if no match is found c----------------------------------------------------------------------- SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, @@ -321,91 +236,19 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, dy = iinQ_step match_count = 0 - ! Coarse grid loop - DO i = 1, ncoarse - DO j = 1, ncoarse - inQ_coarse = -scan_radius + (i - 1) * inQ_step - iinQ_coarse = -scan_radius + (j - 1) * iinQ_step - - ! Evaluate riccati function - delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, - $ inds,intau,inpe,iinQ=iinQ_coarse) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) - - IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 4)) THEN - ! Store coarse grid point - count = count + 1 - results%inQs(count) = inQ_coarse - results%iinQs(count) = iinQ_coarse - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END IF - - IF (ABS(deltaprime) > 8) THEN - threshold = ABS(deltaprime)**(1./3.) - ELSE - threshold = 0.25 * ABS(deltaprime) - END IF - - ! Check if refinement is needed - IF ((ABS(delta_real) > threshold) .AND. - $ (ABS(deltaprime) > 4)) THEN - ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, - !$ delta_real) == SIGN(1.0, deltaprime))) THEN - - ! Fine grid loop - fine_dx = dx / nfine - fine_dy = dy / nfine - - overlap_x = overlap_factor * fine_dx - overlap_y = overlap_factor * fine_dy - - x_start = inQ_coarse - dx/2 + overlap_x - x_end = inQ_coarse + dx/2 - overlap_x - y_start = iinQ_coarse - dy/2 + overlap_y - y_end = iinQ_coarse + dy/2 - overlap_y - - DO fj = 0, nfine-1 - iinQ_fine = y_start + fj * (y_end-y_start) / (nfine-1) - DO fi = 0, nfine-1 - inQ_fine = x_start + fi * (x_end-x_start) / (nfine-1) - IF ((ABS(inQ_coarse - inQ_fine) < - $ tolerance) .AND. (ABS(iinQ_coarse - - $ iinQ_fine) < tolerance)) CYCLE - - ! Evaluate riccati function - delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) - - IF (ABS(delta_real)>ABS(deltaprime)) THEN - match_count = match_count + 1 - END IF - - ! Store fine grid point - count = count + 1 - results%inQs(count) = inQ_fine - results%iinQs(count) = iinQ_fine - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END DO - END DO - END IF - END DO - END DO - - !!!!! + ! Run scan + CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, + $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, + $ results,count,match_count,dx,dy) IF (match_count == 0) THEN - WRITE(*,*)"No match found, increasing scan radius" + WRITE(*,*)"No match found, rescanning" repeat = .TRUE. - new_scan_radius = scan_radius + 2 + !new_scan_radius = scan_radius + 2 new_ncoarse = ncoarse + 100 new_nfine = nfine ELSE IF (match_count > 0 .AND. match_count < 3) THEN - WRITE(*,*)"Match not definitive, increasing scan resolution" + WRITE(*,*)"Match not definitive, rescanning" repeat = .TRUE. new_scan_radius = scan_radius new_ncoarse = ncoarse @@ -441,12 +284,64 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, match_count = 0 - ! Coarse grid loop - DO i = 1, new_ncoarse - DO j = 1, new_ncoarse - inQ_coarse = -new_scan_radius + (i - 1) * inQ_step - iinQ_coarse = -new_scan_radius + (j - 1) * iinQ_step + ! COARSE AND FINE LOOPS + CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, + $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, + $ results,count,match_count,dx,dy) + + END IF ! End repeat "if" + + ! Set the actual count of points + results%count = count + + IF (count < max_points) THEN + ! Resize arrays to actual number of points + CALL shrink_array(results%inQs, count) + CALL shrink_array(results%iinQs, count) + CALL shrink_array(results%Re_deltas, count) + CALL shrink_array(results%Im_deltas, count) + END IF + + RETURN + END SUBROUTINE growthrate_scan +c----------------------------------------------------------------------- +c Subprogram 3. scan_grid +c Run stability scan on real and imaginary rotation axes +c----------------------------------------------------------------------- + SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, + $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, + $ results,count,match_count,dx,dy) + + ! Declarations (include necessary type declarations from original code) + REAL(r8), INTENT(IN) :: inQ_e, inQ_i, inpr, inc_beta, inds, + $ intau, inpe, deltaprime + INTEGER, INTENT(IN) :: scan_radius, ncoarse, nfine + LOGICAL, INTENT(IN) :: compress_deltas + TYPE(result_type), INTENT(INOUT) :: results + INTEGER, INTENT(INOUT) :: count, match_count + REAL(r8), INTENT(INOUT) :: dx, dy + + ! Local variables + REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, + $ inQ_coarse, iinQ_coarse + REAL(r8) :: delta_real, delta_imag, threshold + COMPLEX(r8) :: delta + REAL(r8) :: fine_dx, fine_dy, overlap_x, overlap_y + REAL(r8) :: x_start, x_end, y_start, y_end + INTEGER :: i, j, fi, fj + REAL(r8), PARAMETER :: tolerance = 1.0E-6 + REAL(r8) :: overlap_factor = 0.5 + + ! Calculate step sizes + inQ_step = (2.0 * scan_radius) / (ncoarse - 1) + iinQ_step = (2.0 * scan_radius) / (ncoarse - 1) + dx = inQ_step + dy = iinQ_step + DO i = 1, ncoarse + DO j = 1, ncoarse + inQ_coarse = -scan_radius + (i - 1) * inQ_step + iinQ_coarse = -scan_radius + (j - 1) * iinQ_step ! Evaluate riccati function delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, $ inds,intau,inpe,iinQ=iinQ_coarse) @@ -471,25 +366,25 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, ! Check if refinement is needed IF ((ABS(delta_real) > threshold) .AND. $ (ABS(deltaprime) > 4)) THEN - ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, + ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN ! Fine grid loop - fine_dx = dx / new_nfine - fine_dy = dy / new_nfine + fine_dx = dx / nfine + fine_dy = dy / nfine overlap_x = overlap_factor * fine_dx overlap_y = overlap_factor * fine_dy - x_start = inQ_coarse - dx/2 - overlap_x - x_end = inQ_coarse + dx/2 + overlap_x - y_start = iinQ_coarse - dy/2 - overlap_y - y_end = iinQ_coarse + dy/2 + overlap_y + x_start = inQ_coarse - dx/2 + overlap_x + x_end = inQ_coarse + dx/2 - overlap_x + y_start = iinQ_coarse - dy/2 + overlap_y + y_end = iinQ_coarse + dy/2 - overlap_y DO fj = 0, nfine-1 - iinQ_fine = y_start+fj * (y_end-y_start) / (new_nfine-1) + iinQ_fine = y_start + fj * (y_end-y_start) / (nfine-1) DO fi = 0, nfine-1 - inQ_fine = x_start+fi * (x_end-x_start) /(new_nfine-1) + inQ_fine = x_start + fi * (x_end-x_start) / (nfine-1) IF ((ABS(inQ_coarse - inQ_fine) < $ tolerance) .AND. (ABS(iinQ_coarse - $ iinQ_fine) < tolerance)) CYCLE @@ -501,7 +396,7 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, delta_imag = AIMAG(delta) IF (ABS(delta_real)>ABS(deltaprime)) THEN - match_count = match_count + 1 + match_count = match_count + 1 END IF ! Store fine grid point @@ -515,30 +410,11 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, END IF END DO END DO - - END IF - WRITE(*,*)"Passed IF return" - WRITE(*,*)"count: ",count - WRITE(*,*)"max_points: ",max_points - ! Set the actual count of points - results%count = count - - - WRITE(*,*)"Passed Set the actual count of points" - IF (count < max_points) THEN - ! Resize arrays to actual number of points - CALL shrink_array(results%inQs, count) - CALL shrink_array(results%iinQs, count) - CALL shrink_array(results%Re_deltas, count) - CALL shrink_array(results%Im_deltas, count) - END IF - - WRITE(*,*)"Arrays successfully shrunk" - - - RETURN - END SUBROUTINE growthrate_scan - + END SUBROUTINE scan_grid +c----------------------------------------------------------------------- +c Subprogram 4. shrink_array +c Remove excess scan array size from memory +c----------------------------------------------------------------------- SUBROUTINE shrink_array(arr, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) INTEGER, INTENT(IN) :: new_size @@ -548,7 +424,10 @@ SUBROUTINE shrink_array(arr, new_size) temp(1:new_size) = arr(1:new_size) CALL move_alloc(temp, arr) END SUBROUTINE shrink_array - +c----------------------------------------------------------------------- +c Subprogram 5. grow_array +c Increase scan array size if necessary +c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) INTEGER, INTENT(IN) :: old_size,new_size From 09bdb8cc04ca49b6d78698d59027a02dca78790e Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 14 Nov 2024 14:05:08 -0500 Subject: [PATCH 018/118] add Pe_flag --- input/slayer.in | 5 +++-- slayer/layerinputs.f | 11 ++++++----- slayer/slayer.f | 23 +++++++++++++++-------- 3 files changed, 24 insertions(+), 15 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 35a904aeb..83ac2f91d 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -15,14 +15,14 @@ bt=1.0 ! toroidal field [T] rs=0.17 ! minor radius of resonant surface [m] R0=2.0 ! major radius of magnetic axis [m] - omega=5.45E+04 ! ExB frequency [1/s] + omega=5.45E+04 ! ExB frequency [rad/s] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective inpr=1.0 ! Prantdl number - inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile + inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile, set < 0 to only use inpr instead inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -52,6 +52,7 @@ nbtscan_flag=f ! scan (n,bt) space for error fields. parflow_flag=f ! set parallel flow on PeOhmOnly_flag=t ! only include Pe from Ohm's law + Pe_flag=f ! if true, calculate classical inpe value from inpr and include in SLAYER run layfac=0.02 ! layfac*EXP(ifac*ATAN2(AIMAG(Q-Q_e),REAL(Q-Q_e)) is added to Q_e if ABS(Q-Q_e) Date: Fri, 22 Nov 2024 10:48:22 -0800 Subject: [PATCH 019/118] reverting Pe_flag commit --- input/slayer.in | 5 ++--- slayer/layerinputs.f | 11 +++++------ slayer/slayer.f | 23 ++++++++--------------- 3 files changed, 15 insertions(+), 24 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 83ac2f91d..35a904aeb 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -15,14 +15,14 @@ bt=1.0 ! toroidal field [T] rs=0.17 ! minor radius of resonant surface [m] R0=2.0 ! major radius of magnetic axis [m] - omega=5.45E+04 ! ExB frequency [rad/s] + omega=5.45E+04 ! ExB frequency [1/s] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective inpr=1.0 ! Prantdl number - inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile, set < 0 to only use inpr instead + inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -52,7 +52,6 @@ nbtscan_flag=f ! scan (n,bt) space for error fields. parflow_flag=f ! set parallel flow on PeOhmOnly_flag=t ! only include Pe from Ohm's law - Pe_flag=f ! if true, calculate classical inpe value from inpr and include in SLAYER run layfac=0.02 ! layfac*EXP(ifac*ATAN2(AIMAG(Q-Q_e),REAL(Q-Q_e)) is added to Q_e if ABS(Q-Q_e) Date: Mon, 25 Nov 2024 07:35:15 -0800 Subject: [PATCH 020/118] restoring Pe_flag commit --- input/slayer.in | 5 +++-- slayer/layerinputs.f | 11 ++++++----- slayer/slayer.f | 23 +++++++++++++++-------- 3 files changed, 24 insertions(+), 15 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 35a904aeb..83ac2f91d 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -15,14 +15,14 @@ bt=1.0 ! toroidal field [T] rs=0.17 ! minor radius of resonant surface [m] R0=2.0 ! major radius of magnetic axis [m] - omega=5.45E+04 ! ExB frequency [1/s] + omega=5.45E+04 ! ExB frequency [rad/s] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective inpr=1.0 ! Prantdl number - inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile + inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile, set < 0 to only use inpr instead inpe=0.0 ! Electron viscosity !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE @@ -52,6 +52,7 @@ nbtscan_flag=f ! scan (n,bt) space for error fields. parflow_flag=f ! set parallel flow on PeOhmOnly_flag=t ! only include Pe from Ohm's law + Pe_flag=f ! if true, calculate classical inpe value from inpr and include in SLAYER run layfac=0.02 ! layfac*EXP(ifac*ATAN2(AIMAG(Q-Q_e),REAL(Q-Q_e)) is added to Q_e if ABS(Q-Q_e) Date: Mon, 3 Feb 2025 15:04:24 -0500 Subject: [PATCH 021/118] WIP: add riccati_del_s function --- slayer/delta.f | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 97 insertions(+) diff --git a/slayer/delta.f b/slayer/delta.f index 99463b589..dc40a6792 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -105,6 +105,103 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, END FUNCTION riccati c----------------------------------------------------------------------- +c calculate delta based on riccati w_der formulation. +c----------------------------------------------------------------------- + FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, + $ inpe,iinQ,inx,iny) + + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds + REAL(r8),INTENT(IN) :: intau + REAL(r8),INTENT(IN),OPTIONAL :: iinQ,inx + COMPLEX(r8), INTENT(IN), OPTIONAL :: iny + COMPLEX(r8) :: riccati_del_s + + INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf + + REAL(r8) :: xintv,x,xout,rtol,jac,xmin + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy + + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork + REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork + + Q=inQ + IF(present(iinQ)) Q=inQ+ifac*iinQ + Q_e=inQ_e + Q_i=inQ_i + pr=inpr + pe=inpe + c_beta=inc_beta + ds=inds + tau=intau + + IF ((layfac>0).AND.(ABS(Q-Q_e)xout) + istep=istep+1 + CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')x,REAL(y),AIMAG(y) + ENDDO + CLOSE(bin_unit) + CLOSE(out2_unit) + ELSE + istep = 1 + itask = 1 + CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + + ENDIF + + ! w=0 when Q=Q_e. Why? + + CALL w_der(neq,x,y,dy) + riccati_del_s=pi/dy(1) + DEALLOCATE(atol,y,dy,iwork,rwork) + + END FUNCTION riccati_del_s +c----------------------------------------------------------------------- c riccati integration. c----------------------------------------------------------------------- SUBROUTINE w_der(neq,x,y,dy) From ce180dcb16dbff8e4c593bf1fb825c4073325113 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 6 Feb 2025 13:31:34 -0500 Subject: [PATCH 022/118] WIP: layer thickness delta.f functions --- input/slayer.in | 5 ++- slayer/delta.f | 105 +++++++++++++++++++++++++++++++++++++++--------- slayer/slayer.f | 105 ++++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 176 insertions(+), 39 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 83ac2f91d..3f2713c45 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -61,8 +61,9 @@ bin_flag=f ! writes results to binary files netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q - growthrates_flag=t ! Calculate growthrates on each rational surface - analytic_growthrates_flag=f ! Generate Re(Q),Im(Q) scans for each rational surface + del_gamma_flag=t ! Calculate growthrates on each rational surface using Delta' method + analytic_del_gamma_flag=f ! Generate Re(Q),Im(Q) scans for each rational surface + lar_gamma_flag=t ! Calculate growthrates on each rational surface using cylindrical method br_th_flag=t ! Calculate br_th compress_deltas=f ! Only output essential growth rate grid points bal_flag=f ! calculate the resonant field penetration threshold from torque balance diff --git a/slayer/delta.f b/slayer/delta.f index dc40a6792..02c43cc3f 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -108,28 +108,28 @@ END FUNCTION riccati c calculate delta based on riccati w_der formulation. c----------------------------------------------------------------------- FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, - $ inpe,iinQ,inx,iny) + $ inx,iny) - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inc_beta,inds REAL(r8),INTENT(IN) :: intau - REAL(r8),INTENT(IN),OPTIONAL :: iinQ,inx + REAL(r8),INTENT(IN),OPTIONAL :: inx COMPLEX(r8), INTENT(IN), OPTIONAL :: iny COMPLEX(r8) :: riccati_del_s INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - REAL(r8) :: xintv,x,xout,rtol,jac,xmin - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy + REAL(r8) :: xintv,x,xout,rtol,jac,xmin,pd,P_hat,alpha + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq,y,dy INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork Q=inQ - IF(present(iinQ)) Q=inQ+ifac*iinQ + !IF(present(iinQ)) Q=inQ+ifac*iinQ Q_e=inQ_e Q_i=inQ_i pr=inpr - pe=inpe + !pe=inpe c_beta=inc_beta ds=inds tau=intau @@ -141,7 +141,7 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, neq = 2 itol = 2 rtol = 1e-7 !1e-7*pr**0.4 ! !1e-7 at front 1e-6 !e-4 - ALLOCATE(atol(neq),y(1),dy(1)) + ALLOCATE(atol(neq),W(1),dW_dq(1)) atol(:) = 1e-7*pr**0.4 ! 1e-8 !e-4 itask = 2 istate = 1 @@ -157,12 +157,22 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, iwork(6)=10000 !5000 ! maximum step size, e.g. 50000 rwork=0 ! x=10.0*(1.0+log10(Q/pr)) - x=20.0 - xmin=1e-3 + + !!!!!!!! + pd=20.0 ! "starting backwards integration at large q" + !!!!!!!! + + xmin=1e-5 IF(present(inx)) x=inx xout=xmin - y(1)=-c_beta/sqrt((1+tau))/ds*x**2.0 ! it was (1+tau*ds). To be updated. - IF(present(iny)) y(1)=iny + + !y(1)=-c_beta/sqrt((1+tau))/ds*x**2.0 ! it was (1+tau*ds). To be updated. + + P_hat = inpr / ds**6 + alpha = (P_hat/(1+1/tau))**0.5 + W(1) = 0.0!-alpha*pd**2 - 0.5 + + IF(present(iny)) W(1)=iny ! y(1)=0.5-ifac*10.0 ! WRITE(*,*)y(1) @@ -177,33 +187,88 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// $ TRIM(sn)//'.out',STATUS='UNKNOWN') WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" - DO WHILE (x>xout) + DO WHILE (pd>xout) istep=istep+1 - CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + CALL lsode(w_der_del_s,neq,W,pd,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) - WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) - WRITE(out2_unit,'(1x,3(es17.8e3))')x,REAL(y),AIMAG(y) + WRITE(bin_unit)REAL(pd,4),REAL(REAL(W),4),REAL(AIMAG(W),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')pd,REAL(W),AIMAG(W) ENDDO CLOSE(bin_unit) CLOSE(out2_unit) ELSE istep = 1 itask = 1 - CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + CALL lsode(w_der_del_s,neq,W,pd,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) ENDIF ! w=0 when Q=Q_e. Why? - CALL w_der(neq,x,y,dy) - riccati_del_s=pi/dy(1) - DEALLOCATE(atol,y,dy,iwork,rwork) + CALL w_der_del_s(neq,pd,W,dW_dq) + + riccati_del_s=-( pi/((1+1/tau)**0.5) )*dW_dq(1) + DEALLOCATE(atol,W,dW_dq,iwork,rwork) END FUNCTION riccati_del_s c----------------------------------------------------------------------- c riccati integration. c----------------------------------------------------------------------- + SUBROUTINE w_der_del_s(neq,pd,W,dW_dq) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: pd + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dW_dq + REAL(r8) :: Q_hat, P_hat + COMPLEX(r8) :: E,F + + COMPLEX(r8), PARAMETER :: ifac=(0,1) + + !IF (PeOhmOnly_flag) THEN + ! G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + + !$ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ + !$ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + !$ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) + !ELSE + ! G=(x**2*pe + + !$ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + + !$ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ + !$ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + !$ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) + !ENDIF + + !C3=x**2/(x**2 + (ds**2*(1 + tau)*x**4*pe)/ + !$ c_beta**2 + ifac*(Q - Q_e)) + + !C3p=-((x**2*(2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + !$ c_beta**2))/ + !$ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + !$ c_beta**2 + (0,1)*(Q - Q_e))**2 + !$ ) + (2*x)/ + !$ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + !$ c_beta**2 + (0,1)*(Q - Q_e)) + + !A1=(C1 + (C3p/C3)*(C2 + 1) + C2p)/(C2 + 1) + + !A2=(C1p + C1*(C3p/C3) - G/C3)/(C2 + 1) + + Q_hat = Q / ds**4 + P_hat = pr / ds**6 + + E = (-Q_hat**2/(1+1/tau)) - 2*ifac*Q_hat*P_hat*pd**2 + + $ 2*P_hat*pd**4 ! P_tor = P_perp + F = P_hat - ifac*Q_hat + (1+1/tau)*P_hat*pd**2 + + !dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x + dW_dq(1)=W(1)/pd - W(1)*W(1)/pd - (pd*E)/F !pD = q + + RETURN + END SUBROUTINE w_der_del_s +c +c +c SUBROUTINE w_der(neq,x,y,dy) INTEGER, INTENT(IN) :: neq diff --git a/slayer/slayer.f b/slayer/slayer.f index 069cc99eb..eafff752a 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -14,7 +14,7 @@ PROGRAM slayer USE sglobal_mod !USE params_mod - USE delta_mod, ONLY: riccati,riccati_out, + USE delta_mod, ONLY: riccati,riccati_del_s,riccati_out, $ parflow_flag,PeOhmOnly_flag ! FOR TESTING: @@ -33,14 +33,14 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,growthrates_flag,analytic_growthrates_flag, - $ Pe_flag,br_th_flag,compress_deltas + $ params_check,del_gamma_flag,analytic_del_gamma_flag, + $ lar_gamma_flag,Pe_flag,br_th_flag,compress_deltas REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th - COMPLEX(r8) :: delta,delta_n_p + REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_i,d_b,E_ss,tau_r + COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,gamma REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower, @@ -91,8 +91,8 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag,growthrates_flag,analytic_growthrates_flag, - $ br_th_flag,compress_deltas,bal_flag + $ stability_flag,del_gamma_flag,analytic_del_gamma_flag, + $ lar_gamma_flag,br_th_flag,compress_deltas,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -165,8 +165,9 @@ PROGRAM slayer params_check=.FALSE. bal_flag=.FALSE. stability_flag=.FALSE. - growthrates_flag=.FALSE. - analytic_growthrates_flag=.FALSE. + del_gamma_flag=.FALSE. + analytic_del_gamma_flag=.FALSE. + lar_gamma_flag=.FALSE. br_th_flag=.FALSE. compress_deltas=.FALSE. c----------------------------------------------------------------------- @@ -294,9 +295,79 @@ PROGRAM slayer $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,mms,nns) ENDIF c----------------------------------------------------------------------- +c LAR (cylindrical) growthrates via restive layer thickness +c----------------------------------------------------------------------- + IF (lar_gamma_flag) THEN + WRITE(*,*)"intau=",intau + WRITE(*,*)"inQ=",inQ + WRITE(*,*)"Prantdl numbers=",inpr + WRITE(*,*)"Electron viscosities=",inpe + WRITE(*,*)"inQ_e=",inQ_e + WRITE(*,*)"inds=",inds + WRITE(*,*)"inc_beta=",inc_beta + + WRITE(*,*)"running analytic scan" + + qval_arr = (/ qval /) + omegas_arr = (/ omega /) + inQ_arr = (/ inQ /) + inQ_e_arr = (/ inQ_e /) + inQ_i_arr = (/ inQ_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ REAL(delta_n_p) /) + Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) + inpr_arr = (/ inpr /) + + WRITE(*,*)"Calculating LAR growth rate" + + CALL params(n_e,t_e,t_i,omega, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + + inQ=Q + inQ_e=Q_e + inQ_i=Q_i + inc_beta=c_beta + inds=ds + intau=tau + Q0=Q + + WRITE(*,*)"params() call successful" + + dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds, + $ intau) + + WRITE(*,*)"dels_db() call successful" + + eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + tau_r=mu0*rs**2.0/eta ! resistive time scale + + d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth + d_b = c_beta*d_i + del_s = dels_db * d_b + E_ss = 5.0 + gamma=(REAL(E_ss)/tau_r) * (rs/del_s) + + WRITE(*,*)"inds=",inds + WRITE(*,*)"Q_hat=",inQ/(inds**4) + WRITE(*,*)"P_hat=",inpr/(inds**6) + WRITE(*,*)"thickness/db=",dels_db + WRITE(*,*)"db=",d_b + WRITE(*,*)"thickness=",del_s + WRITE(*,*)"gamma=",gamma + + !br_th = 0.0 + ! CALL slayer_netcdf_out(growthrates_flag, + !$ analytic_growthrates_flag,br_th_flag,1,qval_arr,br_th, + !$ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + !$ psi_n_rational,inpr_arr, + !$ Re_deltaprime_arr,Im_deltaprime_arr, + !$ results) + stop + ENDIF +c----------------------------------------------------------------------- c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- - IF (growthrates_flag) THEN + IF (del_gamma_flag) THEN !WRITE(*,*)"infile=",infile !WRITE(*,*)"ncfile=",ncfile @@ -338,8 +409,8 @@ PROGRAM slayer WRITE(*,*)"Calling slayer_netcdf_out" br_th = 0.0 - CALL slayer_netcdf_out(growthrates_flag, - $ analytic_growthrates_flag, + CALL slayer_netcdf_out(del_gamma_flag, + $ analytic_del_gamma_flag, $ br_th_flag,n_k,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, @@ -350,7 +421,7 @@ PROGRAM slayer c----------------------------------------------------------------------- c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- - IF (analytic_growthrates_flag) THEN + IF (analytic_del_gamma_flag) THEN WRITE(*,*)"intau=",intau WRITE(*,*)"inQ=",inQ WRITE(*,*)"Prantdl numbers=",inpr @@ -380,8 +451,8 @@ PROGRAM slayer WRITE(*,*)"allocations successful" br_th = 0.0 - CALL slayer_netcdf_out(growthrates_flag, - $ analytic_growthrates_flag,br_th_flag,1,qval_arr,br_th, + CALL slayer_netcdf_out(del_gamma_flag, + $ analytic_del_gamma_flag,br_th_flag,1,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, $ Re_deltaprime_arr,Im_deltaprime_arr, @@ -482,8 +553,8 @@ PROGRAM slayer WRITE(*,*)"allocations successful" - CALL slayer_netcdf_out(growthrates_flag, - $ analytic_growthrates_flag, + CALL slayer_netcdf_out(del_gamma_flag, + $ analytic_del_gamma_flag, $ br_th_flag,1,qval_arr,br_th, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr, From b912356fa05590389ed3fad963fddd3bd253caeb Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 12 Feb 2025 16:19:04 -0500 Subject: [PATCH 023/118] WIP: slayer LAR gamma netcdf upgrades --- input/slayer.in | 51 ++++++++--------- slayer/delta.f | 114 +++++++++++++++++--------------------- slayer/gslayer.f | 45 ++++++++++++++- slayer/makefile | 1 + slayer/params.f | 5 ++ slayer/sglobal.f | 3 +- slayer/slayer.f | 123 ++++++++++++++++++----------------------- slayer/slayer_netcdf.f | 95 +++++++++++++++++++++++-------- 8 files changed, 254 insertions(+), 183 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 3f2713c45..50748255e 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -1,46 +1,43 @@ &SLAYER_INPUT - - !!! FOR READING IN ASCII TABLE, SET INPUT_FLAG + ! Default values taken from R. Fitzpatrick 'High Field' case in "Tearing Mode Dynamics in Tokamak Plasmas", 2023 input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table infile='' ! Path to ascii table of profile quantities read when using input_flag ncfile='' ! Path to netCDF file of STRIDE outputs - !!! FOR MANUALLY ENTERING KINETIC QUANTITIES @ RATIONAL SURFACE, SET PARAMS_FLAG params_flag=f ! calculates normalized parameters from profile quantities mm=2 ! poloidal mode number nn=1 ! toroidal mode number - n_e=7.77E+17 ! electron density [m^-3] - t_e=25.8 ! electron temperature [eV] - t_i=25.8 ! ion temperature [eV] - sval=2.0 ! magnetic shear at the layer - bt=1.0 ! toroidal field [T] - rs=0.17 ! minor radius of resonant surface [m] - R0=2.0 ! major radius of magnetic axis [m] - omega=5.45E+04 ! ExB frequency [rad/s] + n_e=5.10E+020 ! electron density [m^-3] + t_e=7000.0 ! electron temperature [eV] + t_i=7000.0 ! ion temperature [eV] + sval=1.34 ! magnetic shear at the layer + bt=12.0 ! toroidal field [T] + rs=0.53 ! minor radius of resonant surface [m] + R0=3.2 ! major radius of magnetic axis [m] + omega=5.45E+03 ! ExB frequency [rad/s] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface mu_i=2.0 ! ion mass ratio to proton ?? zeff=2.0 ! plasma Z_effective - inpr=1.0 ! Prantdl number + inpr=500.0 ! Prantdl number inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile, set < 0 to only use inpr instead inpe=0.0 ! Electron viscosity - - !!! IF INPUT_FLAG & PARAMS_FLAG ARE FALSE, MANUALLY ENTER DIMENSIONLESS QUANTITIES @ RATIONAL SURFACE - inQ=23.0 ! normalized ExB frequency + inQ=1.5 ! normalized ExB frequency inQ_e=2.0 ! normalized electron diamagnetic frequency inQ_i=-2.0 ! normalized ion diamagnetic frequency - inc_beta=0.7 ! dimensionless measure of the plasma pressure - inds=6.0 ! normalized ion sound radius + inc_beta=0.128 ! dimensionless measure of the plasma pressure + inds=2.26 ! normalized ion sound radius intau=1.0 ! ion temperature divided by electron temperature - Q0=4.0 ! unnecessary placeholder variable for inQ? - delta_n_p=0 ! delta offset used for jxb calculations. Default is (1e-2,1e-2). + Q0=1.5 ! unnecessary placeholder variable for inQ? + delta_n_p=(5.0,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). / + &SLAYER_CONTROL inum=400 ! resolution to find error field thresholds. jnum=100 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=350 ! resolution for stability scan along Re(Q) axis - ImQ_num=350 ! resolution for stability scan along Im(Q) axis + ReQ_num=300 ! resolution for stability scan along Re(Q) axis + ImQ_num=300 ! resolution for stability scan along Im(Q) axis scan_radius=3 ! stability scan width in Q QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space @@ -55,20 +52,24 @@ Pe_flag=f ! if true, calculate classical inpe value from inpr and include in SLAYER run layfac=0.02 ! layfac*EXP(ifac*ATAN2(AIMAG(Q-Q_e),REAL(Q-Q_e)) is added to Q_e if ABS(Q-Q_e)0).AND.(ABS(Q-Q_e)xout) + DO WHILE (my_q>xout) istep=istep+1 - CALL lsode(w_der_del_s,neq,W,pd,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) - WRITE(bin_unit)REAL(pd,4),REAL(REAL(W),4),REAL(AIMAG(W),4) - WRITE(out2_unit,'(1x,3(es17.8e3))')pd,REAL(W),AIMAG(W) + CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,my_jac,mf) + WRITE(bin_unit)REAL(my_q,4),REAL(REAL(W),4),REAL(AIMAG(W),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')my_q,REAL(W),AIMAG(W) ENDDO CLOSE(bin_unit) CLOSE(out2_unit) ELSE istep = 1 itask = 1 - CALL lsode(w_der_del_s,neq,W,pd,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,my_jac,mf) ENDIF ! w=0 when Q=Q_e. Why? - CALL w_der_del_s(neq,pd,W,dW_dq) + CALL w_der_del_s(neq,my_q,W,dW_dq) riccati_del_s=-( pi/((1+1/tau)**0.5) )*dW_dq(1) DEALLOCATE(atol,W,dW_dq,iwork,rwork) END FUNCTION riccati_del_s c----------------------------------------------------------------------- +c jacobian for riccati_del_s() +c------------------------------------------- ---------------------------- + SUBROUTINE my_jac(neq, my_q, W, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: my_q + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + pd(1,1) = 1.0/my_q - 2.0d0*W(1)/my_q + END SUBROUTINE my_jac +c----------------------------------------------------------------------- c riccati integration. c----------------------------------------------------------------------- - SUBROUTINE w_der_del_s(neq,pd,W,dW_dq) + SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) INTEGER, INTENT(IN) :: neq - REAL(r8), INTENT(IN) :: pd + REAL(r8), INTENT(IN) :: my_q COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dW_dq - REAL(r8) :: Q_hat, P_hat + REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat COMPLEX(r8) :: E,F COMPLEX(r8), PARAMETER :: ifac=(0,1) - !IF (PeOhmOnly_flag) THEN - ! G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + - !$ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - !$ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - !$ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) - !ELSE - ! G=(x**2*pe + - !$ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + - !$ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - !$ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - !$ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) - !ENDIF - - !C3=x**2/(x**2 + (ds**2*(1 + tau)*x**4*pe)/ - !$ c_beta**2 + ifac*(Q - Q_e)) - - !C3p=-((x**2*(2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - !$ c_beta**2))/ - !$ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - !$ c_beta**2 + (0,1)*(Q - Q_e))**2 - !$ ) + (2*x)/ - !$ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - !$ c_beta**2 + (0,1)*(Q - Q_e)) - - !A1=(C1 + (C3p/C3)*(C2 + 1) + C2p)/(C2 + 1) - - !A2=(C1p + C1*(C3p/C3) - G/C3)/(C2 + 1) - - Q_hat = Q / ds**4 - P_hat = pr / ds**6 - - E = (-Q_hat**2/(1+1/tau)) - 2*ifac*Q_hat*P_hat*pd**2 + - $ 2*P_hat*pd**4 ! P_tor = P_perp - F = P_hat - ifac*Q_hat + (1+1/tau)*P_hat*pd**2 + !Q_hat = Q / ds**4 + Q_hat = (Q_e*(1+tau)/tau) / D_beta_norm**4 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark + P_perp_hat = pr / D_beta_norm**6 ! 0.377 for benchmark + P_tor_hat = pr / D_beta_norm**6 ! 1.15 for benchmark - !dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x - dW_dq(1)=W(1)/pd - W(1)*W(1)/pd - (pd*E)/F !pD = q + E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ + $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) ! P_tor = P_perp + F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 + !dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x + dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F !p*D = my_q RETURN END SUBROUTINE w_der_del_s c diff --git a/slayer/gslayer.f b/slayer/gslayer.f index e0c41aa46..d5c2e69cc 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -7,8 +7,9 @@ MODULE gslayer_mod $ eta,visc,rho_s,lu,omega_e,omega_i, $ delta_n, $ Q - USE delta_mod, ONLY: riccati,riccati_out, - $ parflow_flag,PeOhmOnly_flag + USE delta_mod + !, ONLY: riccati,riccati_out, + !$ parflow_flag,PeOhmOnly_flag USE params_mod @@ -177,6 +178,46 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- +c Subprogram 3. scan_grid +c Run stability scan on real and imaginary rotation axes +c----------------------------------------------------------------------- + SUBROUTINE get_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr, + $ dels_db,d_beta,lar_gamma) + + ! Declarations (include necessary type declarations from original code) + REAL(r8), INTENT(IN) :: d_beta + COMPLEX(r8), INTENT(IN) :: dels_db,lar_gamma + + LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag + + INTEGER, INTENT(IN), DIMENSION(:), ALLOCATABLE :: qval_arr + REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, + $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr + + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs + TYPE(result_type) :: results(8) + + REAL(r8) :: br_th = 0 + + WRITE(*,*)"Successfully entered get_lar_gamma()" + + inQs = (/0.0/) + iinQs = (/0.0/) + + CALL slayer_netcdf_out(1,lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag, + $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, + $ Im_deltaprime_arr,dels_db,d_beta,D_beta_norm, + $ lar_gamma,inQs,iinQs,results) + + END SUBROUTINE get_lar_gamma +c----------------------------------------------------------------------- c Subprogram 2. growthrate_scan c Set up and iterate stability scans if no match is found c----------------------------------------------------------------------- diff --git a/slayer/makefile b/slayer/makefile index f6dcca4ad..2e3212cbb 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -54,6 +54,7 @@ params.o : sglobal.o delta.o : sglobal.o gslayer.o : sglobal.o delta.o slayer.o : sglobal.o params.o delta.o ../pentrc/grid.mod ../equil/spline_mod.mod +slayer_netcdf.o : sglobal.o clean: rm -f *.o *.mod *.out *.bin slayers diff --git a/slayer/params.f b/slayer/params.f index fcf988717..c8651932e 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -28,6 +28,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega, b_l=(nr/mr)*rs*sval*bt/R0 ! characteristic magnetic field v_a=b_l/(mu0*rho)**0.5 ! alfven velocity rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. + d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth tau_h=R0*(mu0*rho)**0.5/(nn*sval*bt) ! alfven time across surface tau_r=mu0*rs**2.0/eta ! resistive time scale @@ -57,6 +58,10 @@ SUBROUTINE params(n_e,t_e,t_i,omega, lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 + ! this is using Fitzpatrick's tau', we need tau eventually + d_beta = c_beta*d_i + D_beta_norm = (d_beta/rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) + delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes ! quick diagnostics. diff --git a/slayer/sglobal.f b/slayer/sglobal.f index ae6356f2d..6a68621ec 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -7,7 +7,8 @@ MODULE sglobal_mod INTEGER, PARAMETER :: r8=SELECTED_REAL_KIND(13,307) REAL(r8) :: mr,nr - REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau + REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, + $ d_beta,D_beta_norm REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, $ delta_n,layfac,Qconv COMPLEX(r8) :: Q diff --git a/slayer/slayer.f b/slayer/slayer.f index eafff752a..b5ee3cd31 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -33,14 +33,15 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,del_gamma_flag,analytic_del_gamma_flag, - $ lar_gamma_flag,Pe_flag,br_th_flag,compress_deltas + $ params_check,stabscan_eq_flag,stabscan_flag, + $ lar_gamma_eq_flag,lar_gamma_flag,Pe_flag, + $ br_th_flag,compress_deltas REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_i,d_b,E_ss,tau_r - COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,gamma + REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,tau_r,d_b + COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower, @@ -80,8 +81,8 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates, $ growthrate_err - NAMELIST/slayer_input/params_flag,input_flag,infile, - $ ncfile,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, + NAMELIST/slayer_input/input_flag,infile, + $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, $ inQ_i,inpr,inpr_prof,inpe,inc_beta,inds, $ intau,inlu,Q0,delta_n_p @@ -91,8 +92,9 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag,del_gamma_flag,analytic_del_gamma_flag, - $ lar_gamma_flag,br_th_flag,compress_deltas,bal_flag + $ stability_flag,lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,compress_deltas, + $ bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -165,9 +167,10 @@ PROGRAM slayer params_check=.FALSE. bal_flag=.FALSE. stability_flag=.FALSE. - del_gamma_flag=.FALSE. - analytic_del_gamma_flag=.FALSE. + stabscan_flag=.FALSE. + stabscan_eq_flag=.FALSE. lar_gamma_flag=.FALSE. + lar_gamma_eq_flag=.FALSE. br_th_flag=.FALSE. compress_deltas=.FALSE. c----------------------------------------------------------------------- @@ -306,7 +309,18 @@ PROGRAM slayer WRITE(*,*)"inds=",inds WRITE(*,*)"inc_beta=",inc_beta - WRITE(*,*)"running analytic scan" + WRITE(*,*)"Calculating LAR growth rate" + + CALL params(n_e,t_e,t_i,omega, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + + !inQ=Q ! TAKEN FROM NAMELIST + !inQ_e=Q_e ! TAKEN FROM NAMELIST + !inQ_i=Q_i ! TAKEN FROM NAMELIST + !inc_beta=c_beta + !inds=ds + !intau=tau + !Q0=Q qval_arr = (/ qval /) omegas_arr = (/ omega /) @@ -318,56 +332,41 @@ PROGRAM slayer Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) inpr_arr = (/ inpr /) - WRITE(*,*)"Calculating LAR growth rate" + D_beta_norm = inds ! NAMELIST - CALL params(n_e,t_e,t_i,omega, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - - inQ=Q - inQ_e=Q_e - inQ_i=Q_i - inc_beta=c_beta - inds=ds - intau=tau - Q0=Q + WRITE(*,*)"D_beta_norm = ",D_beta_norm + WRITE(*,*)"inds = ",inds - WRITE(*,*)"params() call successful" + WRITE(*,*)"lar_gamma inQ = ",inQ - dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,inds, - $ intau) + dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,d_beta, + $ intau) WRITE(*,*)"dels_db() call successful" - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - tau_r=mu0*rs**2.0/eta ! resistive time scale + eta = 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + tau_r = mu0*rs**2.0/eta ! resistive time scale - d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth - d_b = c_beta*d_i - del_s = dels_db * d_b - E_ss = 5.0 - gamma=(REAL(E_ss)/tau_r) * (rs/del_s) + del_s = dels_db * d_beta + lar_gamma = (REAL(delta_n_p)/tau_r) * (rs/del_s) + + WRITE(*,*)"dels_db=",dels_db + WRITE(*,*)"lar_gamma=",lar_gamma + + WRITE(*,*)"slayer.f lar_gamma=",lar_gamma + + CALL get_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr, + $ dels_db,d_beta,lar_gamma) - WRITE(*,*)"inds=",inds - WRITE(*,*)"Q_hat=",inQ/(inds**4) - WRITE(*,*)"P_hat=",inpr/(inds**6) - WRITE(*,*)"thickness/db=",dels_db - WRITE(*,*)"db=",d_b - WRITE(*,*)"thickness=",del_s - WRITE(*,*)"gamma=",gamma - - !br_th = 0.0 - ! CALL slayer_netcdf_out(growthrates_flag, - !$ analytic_growthrates_flag,br_th_flag,1,qval_arr,br_th, - !$ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - !$ psi_n_rational,inpr_arr, - !$ Re_deltaprime_arr,Im_deltaprime_arr, - !$ results) stop ENDIF c----------------------------------------------------------------------- c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- - IF (del_gamma_flag) THEN + IF (stabscan_eq_flag) THEN !WRITE(*,*)"infile=",infile !WRITE(*,*)"ncfile=",ncfile @@ -409,19 +408,14 @@ PROGRAM slayer WRITE(*,*)"Calling slayer_netcdf_out" br_th = 0.0 - CALL slayer_netcdf_out(del_gamma_flag, - $ analytic_del_gamma_flag, - $ br_th_flag,n_k,qval_arr,br_th, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr, - $ results) +c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, +c $ stabscan_eq_flag,stabscan_flag,br_th_flag) stop ENDIF c----------------------------------------------------------------------- c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY c----------------------------------------------------------------------- - IF (analytic_del_gamma_flag) THEN + IF (stabscan_flag) THEN WRITE(*,*)"intau=",intau WRITE(*,*)"inQ=",inQ WRITE(*,*)"Prantdl numbers=",inpr @@ -451,12 +445,8 @@ PROGRAM slayer WRITE(*,*)"allocations successful" br_th = 0.0 - CALL slayer_netcdf_out(del_gamma_flag, - $ analytic_del_gamma_flag,br_th_flag,1,qval_arr,br_th, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr, - $ results) +c CALL slayer_netcdf_out(1,lar_gamma_eq_flag,lar_gamma_flag, +c $ stabscan_eq_flag,stabscan_flag,br_th_flag) stop ENDIF c----------------------------------------------------------------------- @@ -553,13 +543,8 @@ PROGRAM slayer WRITE(*,*)"allocations successful" - CALL slayer_netcdf_out(del_gamma_flag, - $ analytic_del_gamma_flag, - $ br_th_flag,1,qval_arr,br_th, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr, - $ results) +c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, +c $ stabscan_eq_flag,stabscan_flag,br_th_flag) stop ENDIF c----------------------------------------------------------------------- diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index f4fbdbb45..267c0ba08 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -15,10 +15,7 @@ c declarations. c----------------------------------------------------------------------- MODULE slayer_netcdf_mod - !USE dcon_mod USE sglobal_mod - !USE layerinputs_mod - !USE gslayer_mod USE netcdf IMPLICIT NONE CONTAINS @@ -51,26 +48,42 @@ END SUBROUTINE check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(growthrates_flag, - $ analytic_growthrates_flag,br_th_flag,msing,qval_arr, - $ br_th,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ inpr_arr,Re_deltaprime_arr,Im_deltaprime_arr,results) - LOGICAL, INTENT(IN) :: growthrates_flag,analytic_growthrates_flag, - $ br_th_flag + SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, + $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, + $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db, + $ d_beta,D_beta_norm,lar_gamma,inQs,iinQs,results) + + ! ds = D_beta_norm for lar growth rate routines + +c OPTIONAL +c br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db,d_b,ds,lar_gamma, +c inQs,iinQs,results, + INTEGER, INTENT(IN) :: msing - REAL(r8), DIMENSION(:), INTENT(IN) :: - $ omegas_arr,inQ_arr, - $ inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr - REAL(r8), INTENT(IN) :: br_th - INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr + LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag + + INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, + $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr + + REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, + $ Im_deltaprime_arr,inQs,iinQs + + REAL(r8) :: br_th, d_beta, D_beta_norm + COMPLEX(r8) :: dels_db, lar_gamma + TYPE(result_type), INTENT(IN) :: results(8) - INTEGER :: i, ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim,qsing_id, + + INTEGER :: i,ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, - $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id, + $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id,S_id, $ gamma_err_id,gamma_loc_id,roots_dim,Re_dp_id,Im_dp_id, - $ rdpp_id,idpp_id,inpr_id,br_th_id + $ rdpp_id,idpp_id,inpr_id,br_th_id,dels_db_id,d_b_id, + $ inds_id,lar_gamma_id,qsing_id + INTEGER :: run, run_dimid, point_dimid, varids(4), $ max_points @@ -80,6 +93,13 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- +c i=0; ncid=0;r_id=0;ReQ_dim=0;ImQ_dim=0;qsing_dim=0;qsing_id=0; +c $ i_dim=0;m_dim=0;mo_dim=0;p_dim=0;i_id=0;m_id=0;mo_id=0;p_id=0; +c $ ReQ_id=0;ImQ_id=0;gamma_id=0;omegas_id=0;Q_id=0;Q_e_id=0; +c $ Q_i_id=0;r_dim=0;pr_id=0;qr_id=0;shear_id=0;slice_id=0; +c $ inQs_id=0;S_id=0;gamma_err_id=0;gamma_loc_id=0;roots_dim=0; +c $ Re_dp_id=0;Im_dp_id=0;rdpp_id=0;idpp_id=0;inpr_id=0; +c $ br_th_id=0;dels_db_id=0;d_b_id=0;inds_id=0;lar_gamma_id=0 IF(debug_flag) PRINT *,"Called slayer_netcdf_out" IF (nn<10) THEN WRITE(UNIT=sn,FMT='(I1)')nn @@ -111,8 +131,13 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, ! define dimensions IF(debug_flag) PRINT *," - Defining dimensions in netcdf" + WRITE(*,*)"netcdf msing=",msing + !WRITE(*,*)"netcdf qval=",qval + WRITE(*,*)"netcdf qval_arr=",qval_arr + IF(msing>0)THEN CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL check( nf90_def_dim(ncid, "i", 2, i_dim) ) CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) CALL check( nf90_def_var(ncid,"omegas",nf90_double, @@ -123,6 +148,8 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, $ qsing_dim,Q_e_id)) CALL check( nf90_def_var(ncid,"Q_i",nf90_double, $ qsing_dim,Q_i_id)) + CALL check( nf90_def_var(ncid,"S",nf90_double, + $ qsing_dim,S_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ qsing_dim,pr_id) ) CALL check( nf90_def_var(ncid,"P",nf90_double, @@ -132,7 +159,7 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, CALL check( nf90_def_dim(ncid, "points", max_points, $ point_dimid) ) - IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN CALL check( nf90_def_var(ncid,"growthrates",nf90_double, $ qsing_dim,gamma_id)) CALL check(nf90_def_var(ncid,"growthrate_locs",nf90_double, @@ -153,11 +180,21 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, END IF END IF - IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, $ qsing_dim,rdpp_id) ) CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, $ qsing_dim,idpp_id) ) + END IF + IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN + CALL check( nf90_def_var(ncid,"delta_s_d_b",nf90_double, + $ (/qsing_dim,i_dim/),dels_db_id) ) + CALL check( nf90_def_var(ncid,"d_beta",nf90_double, + $ qsing_dim,d_b_id) ) + CALL check( nf90_def_var(ncid,"D_beta_norm",nf90_double, + $ qsing_dim,inds_id) ) + CALL check( nf90_def_var(ncid,"growthrate",nf90_double, + $ (/qsing_dim,i_dim/),lar_gamma_id) ) END IF ! end definitions CALL check( nf90_enddef(ncid) ) @@ -169,11 +206,12 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) + CALL check( nf90_put_var(ncid,S_id, (/lu/))) CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) - CALL check( nf90_put_var(ncid,qr_id, qval_arr)) + !CALL check( nf90_put_var(ncid,qr_id, qval_arr)) - IF ((growthrates_flag) .OR. (analytic_growthrates_flag)) THEN + IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN CALL check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) CALL check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) DO run = 1, msing @@ -189,9 +227,20 @@ SUBROUTINE slayer_netcdf_out(growthrates_flag, $ count=[results(run)%count, 1]) ) END DO END IF + IF (br_th_flag) THEN CALL check( nf90_put_var(ncid,br_th_id, (/ br_th /))) END IF + + IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN + CALL check( nf90_put_var(ncid,dels_db_id, + $ RESHAPE((/REAL(dels_db),AIMAG(dels_db)/),(/qsing_dim,2/)))) + CALL check( nf90_put_var(ncid,d_b_id, (/ d_beta /))) + CALL check( nf90_put_var(ncid,inds_id, (/ D_beta_norm /))) + CALL check( nf90_put_var(ncid,lar_gamma_id, + $ RESHAPE((/REAL(lar_gamma),AIMAG(lar_gamma)/),(/qsing_dim,2/)))) + END IF + c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- @@ -285,7 +334,7 @@ SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, IF(debug_flag) PRINT *," - Defining dimensions in netcdf" IF(msing>0)THEN - CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + !CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) From 00c18d7ef3f8294eaae4a2fe853c755c97ed6707 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 17 Feb 2025 13:32:45 -0500 Subject: [PATCH 024/118] WIP: adjust error tolerances --- slayer/delta.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 6d02e2c17..9a0b2aea5 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -141,9 +141,9 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, neq = 2 itol = 2 - rtol = 1e-08 !changed to 1e-08 !1e-7*pr**0.4 ! !1e-7 at front 1e-6 !e-4 + rtol = 1e-10 !changed to 1e-08 !1e-7*pr**0.4 ! !1e-7 at front 1e-6 !e-4 ALLOCATE(atol(neq),W(1),dW_dq(1)) - atol(:) = 1e-08!*pr**0.4 ! changed to 1e-08 1e-8 !e-4 + atol(:) = 1e-10!*pr**0.4 ! changed to 1e-08 1e-8 !e-4 itask = 2 istate = 1 iopt = 0 From 35514d1276d2c6446916c829901dfcd48b17d842 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 27 Feb 2025 19:52:15 -0500 Subject: [PATCH 025/118] generalized growth rates to full eq!! --- slayer/gslayer.f | 33 +++++++------- slayer/layerinputs.f | 42 ++++++++++++------ slayer/sglobal.f | 2 +- slayer/slayer.f | 97 ++++++++++++++++++++++++++++++++++++------ slayer/slayer_netcdf.f | 31 ++++++++------ 5 files changed, 149 insertions(+), 56 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index d5c2e69cc..74a85245f 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -181,42 +181,43 @@ END SUBROUTINE gpec_slayer c Subprogram 3. scan_grid c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE get_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr, - $ dels_db,d_beta,lar_gamma) + SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, + $ Im_deltaprime_arr,dels_db_arr,lar_gamma_arr) ! Declarations (include necessary type declarations from original code) - REAL(r8), INTENT(IN) :: d_beta - COMPLEX(r8), INTENT(IN) :: dels_db,lar_gamma - LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag INTEGER, INTENT(IN), DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr - + $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr,ind_beta_arr, + $ D_beta_norm_arr + + COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, + $ lar_gamma_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs TYPE(result_type) :: results(8) REAL(r8) :: br_th = 0 - WRITE(*,*)"Successfully entered get_lar_gamma()" + WRITE(*,*)"Successfully entered output_lar_gamma()" inQs = (/0.0/) iinQs = (/0.0/) - CALL slayer_netcdf_out(1,lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag, + CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, + $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db,d_beta,D_beta_norm, - $ lar_gamma,inQs,iinQs,results) + $ Im_deltaprime_arr,dels_db_arr,ind_beta_arr, + $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) - END SUBROUTINE get_lar_gamma + END SUBROUTINE output_lar_gamma c----------------------------------------------------------------------- c Subprogram 2. growthrate_scan c Set up and iterate stability scans if no match is found diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index cdada7ea4..6a8b57897 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -4,7 +4,7 @@ MODULE layerinputs_mod USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, $ spline_dealloc,spline_int,spline_fit USE sglobal_mod, ONLY: m_p, chag, lnLamb, - $ Q_e,Q_i,pr,pe,c_beta,ds,tau,r8,mu0,pi,out_unit, ! NOT out_unit + $ Q_e,Q_i,pr,pe,c_beta,ds,d_beta,d_i,tau,r8,mu0,pi,out_unit, ! NOT out_unit $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq @@ -225,10 +225,11 @@ END FUNCTION issurfint c build input arrays for SLAYER c----------------------------------------------------------------------- SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, - $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, - $ inpr_arr,inpe_arr,omegas_arr,Re_deltaprime_arr, - $ Im_deltaprime_arr) + $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, + $ D_beta_norm_arr,intau_arr,Q0_arr,inpr_arr, + $ inpe_arr,omegas_arr,gammafac_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- @@ -251,12 +252,12 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0 REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, - $ rho,tau_v,inpr,Qconv,lbeta,qintb + $ rho,tau_v,inpr,Qconv,lbeta,qintb,gammafac REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, - $ inQ_e_arr,psi_n_rational, - $ inQ_i_arr,inc_beta_arr,inds_arr,intau_arr,Q0_arr, - $ inpr_arr,inpe_arr,omegas_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr + $ inQ_e_arr,psi_n_rational,D_beta_norm_arr, + $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, + $ intau_arr,Q0_arr,inpr_arr,inpe_arr,omegas_arr, + $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor @@ -296,10 +297,12 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), $ inQ_i_arr(msing), - $ inc_beta_arr(msing),inds_arr(msing),intau_arr(msing), - $ Q0_arr(msing),inpr_arr(msing),inpe_arr(msing), - $ omegas_arr(msing),omegas_e_arr(msing),omegas_i_arr(msing), - $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing)) + $ inc_beta_arr(msing),inds_arr(msing),ind_beta_arr(msing), + $ intau_arr(msing),Q0_arr(msing),inpr_arr(msing), + $ inpe_arr(msing),omegas_arr(msing),omegas_e_arr(msing), + $ omegas_i_arr(msing),gammafac_arr(msing), + $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), + $ D_beta_norm_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) @@ -399,6 +402,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, v_a=b_l/(mu0*rho)**0.5 ! alfven velocity, B_L IS BROKEN rho_s=1.02e-4*(mu_i*t_e)**0.5/my_bt ! ion Lamour by elec. Temp. + d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth tau_h=R_0*(mu0*rho)**0.5/(nns*my_sval*my_bt) ! alfven time across surface tau_r=mu0*my_rs**2.0/eta ! resistive time scale @@ -422,14 +426,23 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/my_bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 + ! this is using Fitzpatrick's tau', we need tau eventually + d_beta = c_beta*d_i + D_beta_norm = (d_beta/my_rs)*(lu**(1.0/3.0))*(tau/(1+ + $ tau))**(0.5) + delta_n=lu**(1.0/3.0)/my_rs ! norm factor for delta primes + gammafac = (my_rs*Re_dp_diagonal(ising))/tau_r ! scalar to convert thickness into growth rate + qval_arr(ising) = INT(my_qval) inQ_arr(ising)=REAL(Q) inQ_e_arr(ising)=Q_e inQ_i_arr(ising)=Q_i inc_beta_arr(ising)=c_beta inds_arr(ising)=ds + ind_beta_arr(ising)=d_beta + D_beta_norm_arr(ising)=D_beta_norm intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr @@ -437,6 +450,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, omegas_arr(ising) = omega omegas_e_arr(ising) = omega_e omegas_i_arr(ising) = omega_i + gammafac_arr(ising) = gammafac Re_deltaprime_arr(ising) = Re_dp_diagonal(ising) Im_deltaprime_arr(ising) = Im_dp_diagonal(ising) ENDDO diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 6a68621ec..00b751f3f 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -8,7 +8,7 @@ MODULE sglobal_mod REAL(r8) :: mr,nr REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, - $ d_beta,D_beta_norm + $ d_beta,D_beta_norm,gamma_fac REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, $ delta_n,layfac,Qconv COMPLEX(r8) :: Q diff --git a/slayer/slayer.f b/slayer/slayer.f index b5ee3cd31..4193aa9d4 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -54,10 +54,10 @@ PROGRAM slayer $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr, - $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr, - $ psi_n_rational + $ inQ_i_arr,inc_beta_arr,inds_arr, + $ intau_arr,inQ0_arr,inpr_arr, + $ inpe_arr,omegas_arr,inQ_arr, + $ psi_n_rational,ind_beta_arr,D_beta_norm_arr REAL(r8), DIMENSION(8) :: inpr_prof REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, $ all_Im_deltas,all_roots @@ -73,12 +73,13 @@ PROGRAM slayer $ inQs_left,inQs_right,coarse_deltas REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, + $ dels_db_arr,lar_gamma_arr COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas TYPE(result_type) :: results(8) ! Assuming max 8 rational surfaces - REAL(r8), DIMENSION(:), ALLOCATABLE :: growthrates, + REAL(r8), DIMENSION(:), ALLOCATABLE :: gammafac_arr,growthrates, $ growthrate_err NAMELIST/slayer_input/input_flag,infile, @@ -299,6 +300,69 @@ PROGRAM slayer ENDIF c----------------------------------------------------------------------- c LAR (cylindrical) growthrates via restive layer thickness +c----------------------------------------------------------------------- + IF (lar_gamma_eq_flag) THEN + + ! propagate inpr value to inpr_prof if inpr_prof is turned off + IF (inpr_prof(1) < 0) THEN + inpr_prof = inpr + END IF + + CALL build_inputs(infile,ncfile,inpr_prof, + $ inpe,Pe_flag,qval_arr,psi_n_rational, + $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, + $ inds_arr,ind_beta_arr,D_beta_norm_arr, + $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, + $ omegas_arr,gammafac_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr) + + WRITE(*,*)"Safety factor values=",qval_arr + WRITE(*,*)"inQ values=",inQ_arr + WRITE(*,*)"Prantdl numbers=",inpr_arr + WRITE(*,*)"Electron viscosities=",inpe_arr + WRITE(*,*)"Omega ExB values=",omegas_arr + WRITE(*,*)"outer region real deltaprimes=",Re_deltaprime_arr + WRITE(*,*)"outer region imag deltaprimes=",Im_deltaprime_arr + WRITE(*,*)"inQ_e_arr=",inQ_e_arr + WRITE(*,*)"ind_beta_arr=",ind_beta_arr + WRITE(*,*)"D_beta_norm_arr=",D_beta_norm_arr + WRITE(*,*)"intau_arr=",intau_arr + WRITE(*,*)"gammafac_arr=",gammafac_arr + + n_k = SIZE(qval_arr) + + ALLOCATE(lar_gamma_arr(n_k),dels_db_arr(n_k)) + + DO k=1,n_k + WRITE(*,*) "Calculating growth rate on q=", qval_arr(k), + $ " rational surface" + + dels_db=riccati_del_s(inQ_arr(k),inQ_e_arr(k), + $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), + $ D_beta_norm_arr(k),intau_arr(k)) + + del_s = dels_db * ind_beta_arr(k) + lar_gamma = gammafac_arr(k)/del_s + + lar_gamma_arr(k) = lar_gamma + dels_db_arr(k) = dels_db + + ENDDO + WRITE(*,*)"Calling slayer_netcdf_out" + + br_th = 0.0 + + CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, + $ lar_gamma_arr) + + stop + ENDIF +c----------------------------------------------------------------------- +c LAR (cylindrical) growthrates via restive layer thickness c----------------------------------------------------------------------- IF (lar_gamma_flag) THEN WRITE(*,*)"intau=",intau @@ -350,16 +414,23 @@ PROGRAM slayer del_s = dels_db * d_beta lar_gamma = (REAL(delta_n_p)/tau_r) * (rs/del_s) + ind_beta_arr = (/ d_beta /) + dels_db_arr = (/ dels_db /) + lar_gamma_arr = (/ lar_gamma /) + WRITE(*,*)"dels_db=",dels_db WRITE(*,*)"lar_gamma=",lar_gamma WRITE(*,*)"slayer.f lar_gamma=",lar_gamma - CALL get_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + br_th = 0.0 + + CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr, - $ dels_db,d_beta,lar_gamma) + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, + $ lar_gamma_arr) stop ENDIF @@ -378,8 +449,10 @@ PROGRAM slayer CALL build_inputs(infile,ncfile,inpr_prof, $ inpe,Pe_flag,qval_arr,psi_n_rational, $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, - $ inds_arr,intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,Re_deltaprime_arr,Im_deltaprime_arr) + $ inds_arr,ind_beta_arr,D_beta_norm_arr, + $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, + $ omegas_arr,gammafac_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr WRITE(*,*)"inQ values=",inQ_arr diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 267c0ba08..1bee40819 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -51,8 +51,8 @@ END SUBROUTINE check SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db, - $ d_beta,D_beta_norm,lar_gamma,inQs,iinQs,results) + $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, + $ ind_beta_arr,D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) ! ds = D_beta_norm for lar growth rate routines @@ -66,13 +66,15 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, - $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr + $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr,ind_beta_arr, + $ D_beta_norm_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, $ Im_deltaprime_arr,inQs,iinQs - REAL(r8) :: br_th, d_beta, D_beta_norm - COMPLEX(r8) :: dels_db, lar_gamma + REAL(r8) :: br_th + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: dels_db_arr, + $ lar_gamma_arr TYPE(result_type), INTENT(IN) :: results(8) @@ -82,7 +84,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id,S_id, $ gamma_err_id,gamma_loc_id,roots_dim,Re_dp_id,Im_dp_id, $ rdpp_id,idpp_id,inpr_id,br_th_id,dels_db_id,d_b_id, - $ inds_id,lar_gamma_id,qsing_id + $ inds_id,lar_gamma_id,qsing_id,indnorm_id INTEGER :: run, run_dimid, point_dimid, varids(4), $ max_points @@ -192,7 +194,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL check( nf90_def_var(ncid,"d_beta",nf90_double, $ qsing_dim,d_b_id) ) CALL check( nf90_def_var(ncid,"D_beta_norm",nf90_double, - $ qsing_dim,inds_id) ) + $ qsing_dim,indnorm_id) ) CALL check( nf90_def_var(ncid,"growthrate",nf90_double, $ (/qsing_dim,i_dim/),lar_gamma_id) ) END IF @@ -234,11 +236,14 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN CALL check( nf90_put_var(ncid,dels_db_id, - $ RESHAPE((/REAL(dels_db),AIMAG(dels_db)/),(/qsing_dim,2/)))) - CALL check( nf90_put_var(ncid,d_b_id, (/ d_beta /))) - CALL check( nf90_put_var(ncid,inds_id, (/ D_beta_norm /))) + $ RESHAPE((/REAL(dels_db_arr),AIMAG(dels_db_arr)/), + $ (/msing,2/)))) + CALL check( nf90_put_var(ncid,d_b_id,ind_beta_arr)) + CALL check( nf90_put_var(ncid,indnorm_id, D_beta_norm_arr)) CALL check( nf90_put_var(ncid,lar_gamma_id, - $ RESHAPE((/REAL(lar_gamma),AIMAG(lar_gamma)/),(/qsing_dim,2/)))) + $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), + $ (/msing,2/)))) + END IF c ----------------------------------------------------------------------- @@ -271,9 +276,9 @@ SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, INTEGER :: i, ncid,r_id,qsing_dim,qsing_id,msing_id, $ i_dim,ne_id,te_id,ni_id,ti_id,zeff_id,shear_id,bt_id,rs_id, $ R0_id,resm_id,nns_id,inQ_id,inQ_e_id,inc_beta_id, - $ inds_id,qval_id,inQ_i_id,qr_id, + $ inds_id,qval_id,inQ_i_id,qr_id,indnorm_id $ intau_id,inpr_id,inpe_id,omegas_id,Re_delta_id,Im_delta_id, - $ omegas_e_id,omegas_i_id + $ omegas_e_id,omegas_i_id,intau_id CHARACTER(64) :: ncfile LOGICAL, PARAMETER :: debug_flag = .FALSE. From af3bb305653e2db68698b3f1257013f9eb39ebc2 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 17 Mar 2025 13:24:30 -0400 Subject: [PATCH 026/118] WIP: layer thickness usability updates --- slayer/delta.f | 5 ++++- slayer/gslayer.f | 28 ++++++++++++------------- slayer/layerinputs.f | 9 ++++---- slayer/slayer.f | 47 ++++++++++++++---------------------------- slayer/slayer_netcdf.f | 7 ++++--- 5 files changed, 43 insertions(+), 53 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 9a0b2aea5..53053def1 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -160,8 +160,11 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, ! x=10.0*(1.0+log10(Q/pr)) !!!!!!!! - my_q=10.0 ! "starting backwards integration at large q" + my_q=inx ! "starting backwards integration at large q" !!!!!!!! + WRITE(*,*)"myq starting point = ",my_q + WRITE(*,*)"myq starting point = ",my_q + WRITE(*,*)"myq starting point = ",my_q xmin=1e-5 IF(present(inx)) x=inx diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 74a85245f..1072bab98 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -178,15 +178,15 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- -c Subprogram 3. scan_grid -c Run stability scan on real and imaginary rotation axes +c Subprogram 2. output_lar_gamma +c Run c----------------------------------------------------------------------- SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lar_gamma_arr) - + $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, + $ lar_gamma_arr) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag @@ -195,7 +195,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr + $ D_beta_norm_arr,lu_arr COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, $ lar_gamma_arr @@ -214,13 +214,13 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) END SUBROUTINE output_lar_gamma c----------------------------------------------------------------------- -c Subprogram 2. growthrate_scan -c Set up and iterate stability scans if no match is found +c subprogram 3. growthrate_scan +c set up and iterate stability scans if no match is found c----------------------------------------------------------------------- SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, @@ -347,8 +347,8 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, RETURN END SUBROUTINE growthrate_scan c----------------------------------------------------------------------- -c Subprogram 3. scan_grid -c Run stability scan on real and imaginary rotation axes +c subprogram 4. scan_grid +c run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, @@ -454,8 +454,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, END DO END SUBROUTINE scan_grid c----------------------------------------------------------------------- -c Subprogram 4. shrink_array -c Remove excess scan array size from memory +c subprogram 5. shrink_array +c remove excess scan array size from memory c----------------------------------------------------------------------- SUBROUTINE shrink_array(arr, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) @@ -467,7 +467,7 @@ SUBROUTINE shrink_array(arr, new_size) CALL move_alloc(temp, arr) END SUBROUTINE shrink_array c----------------------------------------------------------------------- -c Subprogram 5. grow_array +c subprogram 6. grow_array c Increase scan array size if necessary c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 6a8b57897..0b9655efe 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -9,7 +9,7 @@ MODULE layerinputs_mod USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq USE bicube_mod, ONLY: bicube_eval_external,bicube_type - USE slayer_netcdf_mod!, ONLY: slayer_netcdf_inputs + USE slayer_netcdf_mod IMPLICIT NONE @@ -228,7 +228,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, $ D_beta_norm_arr,intau_arr,Q0_arr,inpr_arr, - $ inpe_arr,omegas_arr,gammafac_arr, + $ inpe_arr,omegas_arr,lu_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) c----------------------------------------------------------------------- c declarations. @@ -254,7 +254,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb,gammafac REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, - $ inQ_e_arr,psi_n_rational,D_beta_norm_arr, + $ inQ_e_arr,psi_n_rational,D_beta_norm_arr,lu_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, $ intau_arr,Q0_arr,inpr_arr,inpe_arr,omegas_arr, $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr @@ -302,7 +302,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, $ inpe_arr(msing),omegas_arr(msing),omegas_e_arr(msing), $ omegas_i_arr(msing),gammafac_arr(msing), $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), - $ D_beta_norm_arr(msing)) + $ D_beta_norm_arr(msing),lu_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) @@ -443,6 +443,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, inds_arr(ising)=ds ind_beta_arr(ising)=d_beta D_beta_norm_arr(ising)=D_beta_norm + lu_arr(ising)=lu intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr diff --git a/slayer/slayer.f b/slayer/slayer.f index 4193aa9d4..9d216799d 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -44,33 +44,28 @@ PROGRAM slayer COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, - $ kpower, - $ Qratio + $ kpower,Qratio INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl, - $ bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, + $ bal,prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr, + $ inpe_arr,omegas_arr,inQ_arr,lu_arr, $ psi_n_rational,ind_beta_arr,D_beta_norm_arr + REAL(r8), DIMENSION(8) :: inpr_prof - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, - $ all_Im_deltas,all_roots - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_inQs + REAL(r8), DIMENSION(:,:),ALLOCATABLE :: Re_deltas,Im_deltas INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: - $ Re_deltaprime_arr,Im_deltaprime_arr, - $ all_growthrates,all_growthrate_locs - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: - $ js,ks,psis,jxbs,Q_sols,br_ths, - $ inQs_left,inQs_right,coarse_deltas + $ Re_deltaprime_arr,Im_deltaprime_arr + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: js,ks,psis,jxbs, + $ Q_sols,br_ths REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, @@ -313,7 +308,7 @@ PROGRAM slayer $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,ind_beta_arr,D_beta_norm_arr, $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,gammafac_arr, + $ omegas_arr,lu_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr @@ -338,8 +333,8 @@ PROGRAM slayer $ " rational surface" dels_db=riccati_del_s(inQ_arr(k),inQ_e_arr(k), - $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), - $ D_beta_norm_arr(k),intau_arr(k)) + $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), + $ D_beta_norm_arr(k),intau_arr(k),5*D_beta_norm) del_s = dels_db * ind_beta_arr(k) lar_gamma = gammafac_arr(k)/del_s @@ -355,7 +350,7 @@ PROGRAM slayer CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational, + $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, $ lar_gamma_arr) @@ -404,7 +399,7 @@ PROGRAM slayer WRITE(*,*)"lar_gamma inQ = ",inQ dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,d_beta, - $ intau) + $ intau,5*D_beta_norm) WRITE(*,*)"dels_db() call successful" @@ -419,6 +414,7 @@ PROGRAM slayer lar_gamma_arr = (/ lar_gamma /) WRITE(*,*)"dels_db=",dels_db + WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 WRITE(*,*)"lar_gamma=",lar_gamma WRITE(*,*)"slayer.f lar_gamma=",lar_gamma @@ -428,7 +424,7 @@ PROGRAM slayer CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational, + $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, $ lar_gamma_arr) @@ -451,7 +447,7 @@ PROGRAM slayer $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,ind_beta_arr,D_beta_norm_arr, $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,gammafac_arr, + $ omegas_arr,lu_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr @@ -589,17 +585,6 @@ PROGRAM slayer inQs = (/ 1.0 /) n_k = SIZE(qval_arr) - k=1 - IF (k==1) THEN - ALLOCATE(all_RE_deltas(1,1,n_k)) - ALLOCATE(all_Im_deltas(1,1,n_k)) - ALLOCATE(all_inQs(1,n_k)) - ALLOCATE(all_growthrates(n_k)) - ALLOCATE(all_growthrate_locs(n_k)) - ENDIF - all_Re_deltas(:,:,k) = 0.0 - all_Im_deltas(:,:,k) = 0.0 - all_inQs(:,k) = 0.0 qval_arr = (/ 3 /) inQs = (/ 1.0 /) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 1bee40819..62991adfa 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -52,7 +52,8 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ ind_beta_arr,D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) + $ lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, + $ inQs,iinQs,results) ! ds = D_beta_norm for lar growth rate routines @@ -67,7 +68,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr + $ D_beta_norm_arr,lu_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, $ Im_deltaprime_arr,inQs,iinQs @@ -208,7 +209,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) - CALL check( nf90_put_var(ncid,S_id, (/lu/))) + CALL check( nf90_put_var(ncid,S_id, lu_arr)) CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) !CALL check( nf90_put_var(ncid,qr_id, qval_arr)) From 295ff40eb8b9c3206caf8665184464e1810446f3 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 31 Mar 2025 13:52:08 -0400 Subject: [PATCH 027/118] SLAYER delta netcdf updates --- slayer/gslayer.f | 51 ++++++++++++++++++++++++------------------------ slayer/slayer.f | 35 +++++++++++++++++++++++++++------ 2 files changed, 54 insertions(+), 32 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 1072bab98..9b721dc34 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -222,7 +222,7 @@ END SUBROUTINE output_lar_gamma c subprogram 3. growthrate_scan c set up and iterate stability scans if no match is found c----------------------------------------------------------------------- - SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, + SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, $ compress_deltas,deltaprime,results) c----------------------------------------------------------------------- @@ -230,21 +230,21 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, c----------------------------------------------------------------------- ! Inputs REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe + $ intau,inQ0,inpr,inpe,my_lu INTEGER, INTENT(IN) :: qval,scan_radius,ncoarse - INTEGER :: new_scan_radius,new_ncoarse - !REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQs,iinQs - COMPLEX(r8) :: delta REAL(r8), INTENT(IN) :: deltaprime + LOGICAL, INTENT(IN) :: compress_deltas + TYPE(result_type), INTENT(INOUT) :: results + + COMPLEX(r8) :: delta + INTEGER :: new_scan_radius,new_ncoarse INTEGER :: nfine, new_nfine REAL(r8), PARAMETER :: tolerance = 1.0E-6 REAL(r8) :: delta_real, delta_imag, threshold INTEGER :: i, j, k, l, m, count, match_count LOGICAL :: repeat - LOGICAL, INTENT(IN) :: compress_deltas REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, $ inQ_coarse, iinQ_coarse - TYPE(result_type), INTENT(INOUT) :: results INTEGER :: max_points, new_max_points INTEGER :: ci, cj, nx, ny REAL(r8) :: dx, dy, overlap_factor @@ -279,19 +279,19 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, match_count = 0 ! Run scan - CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, - $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, - $ results,count,match_count,dx,dy) + CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe,my_lu, + $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, + $ results,count,match_count,dx,dy) - IF (match_count == 0) THEN + IF (match_count == 0) THEN ! ALL REPEATS TURNED OFF FOR NOW WRITE(*,*)"No match found, rescanning" - repeat = .TRUE. + repeat = .FALSE. !new_scan_radius = scan_radius + 2 new_ncoarse = ncoarse + 100 new_nfine = nfine ELSE IF (match_count > 0 .AND. match_count < 3) THEN WRITE(*,*)"Match not definitive, rescanning" - repeat = .TRUE. + repeat = .FALSE. new_scan_radius = scan_radius new_ncoarse = ncoarse new_nfine = 8 @@ -327,10 +327,9 @@ SUBROUTINE growthrate_scan(qval,inQ,inQ_e,inQ_i,inc_beta, match_count = 0 ! COARSE AND FINE LOOPS - CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, + CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe,my_lu, $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, $ results,count,match_count,dx,dy) - END IF ! End repeat "if" ! Set the actual count of points @@ -350,13 +349,13 @@ END SUBROUTINE growthrate_scan c subprogram 4. scan_grid c run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, - $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, - $ results,count,match_count,dx,dy) + SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, + $ inpe,my_lu,scan_radius,ncoarse,nfine,deltaprime, + $ compress_deltas,results,count,match_count,dx,dy) ! Declarations (include necessary type declarations from original code) - REAL(r8), INTENT(IN) :: inQ_e, inQ_i, inpr, inc_beta, inds, - $ intau, inpe, deltaprime + REAL(r8), INTENT(IN) :: inQ_e,inQ_i,inpr,inc_beta,inds, + $ intau,inpe,my_lu,deltaprime INTEGER, INTENT(IN) :: scan_radius, ncoarse, nfine LOGICAL, INTENT(IN) :: compress_deltas TYPE(result_type), INTENT(INOUT) :: results @@ -387,8 +386,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, ! Evaluate riccati function delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, $ inds,intau,inpe,iinQ=iinQ_coarse) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) + delta_real = REAL(delta)*(my_lu**(1.0/3.0)) ! Critical normalization + delta_imag = AIMAG(delta)*(my_lu**(1.0/3.0)) ! Critical normalization IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 4)) THEN ! Store coarse grid point @@ -406,8 +405,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, END IF ! Check if refinement is needed - IF ((ABS(delta_real) > threshold) .AND. - $ (ABS(deltaprime) > 4)) THEN + IF (2 == 3) THEN !((ABS(delta_real) > threshold) .AND. + !$ (ABS(deltaprime) > 4)) THEN ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, !$ delta_real) == SIGN(1.0, deltaprime))) THEN @@ -434,8 +433,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, ! Evaluate riccati function delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) - delta_real = REAL(delta) - delta_imag = AIMAG(delta) + delta_real = REAL(delta)*(my_lu**(1.0/3.0)) + delta_imag = AIMAG(delta)*(my_lu**(1.0/3.0)) IF (ABS(delta_real)>ABS(deltaprime)) THEN match_count = match_count + 1 diff --git a/slayer/slayer.f b/slayer/slayer.f index 9d216799d..19356bca8 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -344,6 +344,20 @@ PROGRAM slayer ENDDO WRITE(*,*)"Calling slayer_netcdf_out" + WRITE(*,*)"qval_arr=",qval_arr + WRITE(*,*)"omegas_arr=",omegas_arr + WRITE(*,*)"inQ_arr=",inQ_arr + WRITE(*,*)"inQ_e_arr=",inQ_e_arr + WRITE(*,*)"inQ_i_arr=",inQ_i_arr + WRITE(*,*)"ind_beta_arr=",ind_beta_arr + WRITE(*,*)"D_beta_norm_arr=",D_beta_norm_arr + WRITE(*,*)"inpr_arr=",inpr_arr + WRITE(*,*)"psi_n_rational=",psi_n_rational + WRITE(*,*)"lu_arr=",lu_arr + WRITE(*,*)"Re_deltaprime_arr=",Re_deltaprime_arr + WRITE(*,*)"Im_deltaprime_arr=",Im_deltaprime_arr + WRITE(*,*)"dels_db_arr=",dels_db_arr + WRITE(*,*)"lar_gamma_arr=",lar_gamma_arr br_th = 0.0 @@ -466,17 +480,26 @@ PROGRAM slayer WRITE(*,*) "Finding roots on q=", qval_arr(k), $ " rational surface" - CALL growthrate_scan(qval_arr(k),inQ_arr(k),inQ_e_arr(k), - $ inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), - $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ scan_radius,reQ_num,compress_deltas, - $ Re_deltaprime_arr(k),results(k)) + CALL growthrate_scan(qval_arr(k),lu_arr(k),inQ_arr(k), + $ inQ_e_arr(k),inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), + $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), + $ scan_radius,reQ_num,compress_deltas, + $ Re_deltaprime_arr(k),results(k)) WRITE(*,*)"Exited growthrate_scan" ENDDO WRITE(*,*)"Calling slayer_netcdf_out" br_th = 0.0 + WRITE(*,*)"Successfully entered output_lar_gamma()" + WRITE(*,*)"qval_arr = ",qval_arr + + CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, + $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, + $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, c $ stabscan_eq_flag,stabscan_flag,br_th_flag) stop @@ -505,7 +528,7 @@ PROGRAM slayer Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) inpr_arr = (/ inpr /) - CALL growthrate_scan(qval_arr(1),inQ,inQ_e, + CALL growthrate_scan(qval_arr(1),lu,inQ,inQ_e, $ inQ_i,inc_beta,inds, $ intau,inQ,inpr,inpe, $ scan_radius,reQ_num,compress_deltas, From 4e1e98dab8291c4409360bc6d92ef8c7e3051011 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 31 Mar 2025 13:54:19 -0400 Subject: [PATCH 028/118] Revert "WIP: layer thickness usability updates" This reverts commit af3bb305653e2db68698b3f1257013f9eb39ebc2. --- slayer/delta.f | 5 +---- slayer/gslayer.f | 28 ++++++++++++------------- slayer/layerinputs.f | 9 ++++---- slayer/slayer.f | 47 ++++++++++++++++++++++++++++-------------- slayer/slayer_netcdf.f | 7 +++---- 5 files changed, 53 insertions(+), 43 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 53053def1..9a0b2aea5 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -160,11 +160,8 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, ! x=10.0*(1.0+log10(Q/pr)) !!!!!!!! - my_q=inx ! "starting backwards integration at large q" + my_q=10.0 ! "starting backwards integration at large q" !!!!!!!! - WRITE(*,*)"myq starting point = ",my_q - WRITE(*,*)"myq starting point = ",my_q - WRITE(*,*)"myq starting point = ",my_q xmin=1e-5 IF(present(inx)) x=inx diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 9b721dc34..ce3565048 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -178,15 +178,15 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- -c Subprogram 2. output_lar_gamma -c Run +c Subprogram 3. scan_grid +c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lar_gamma_arr) + $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, + $ Im_deltaprime_arr,dels_db_arr,lar_gamma_arr) + ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag @@ -195,7 +195,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr,lu_arr + $ D_beta_norm_arr COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, $ lar_gamma_arr @@ -214,13 +214,13 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) END SUBROUTINE output_lar_gamma c----------------------------------------------------------------------- -c subprogram 3. growthrate_scan -c set up and iterate stability scans if no match is found +c Subprogram 2. growthrate_scan +c Set up and iterate stability scans if no match is found c----------------------------------------------------------------------- SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, @@ -346,8 +346,8 @@ SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, RETURN END SUBROUTINE growthrate_scan c----------------------------------------------------------------------- -c subprogram 4. scan_grid -c run stability scan on real and imaginary rotation axes +c Subprogram 3. scan_grid +c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, $ inpe,my_lu,scan_radius,ncoarse,nfine,deltaprime, @@ -453,8 +453,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, END DO END SUBROUTINE scan_grid c----------------------------------------------------------------------- -c subprogram 5. shrink_array -c remove excess scan array size from memory +c Subprogram 4. shrink_array +c Remove excess scan array size from memory c----------------------------------------------------------------------- SUBROUTINE shrink_array(arr, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) @@ -466,7 +466,7 @@ SUBROUTINE shrink_array(arr, new_size) CALL move_alloc(temp, arr) END SUBROUTINE shrink_array c----------------------------------------------------------------------- -c subprogram 6. grow_array +c Subprogram 5. grow_array c Increase scan array size if necessary c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 0b9655efe..6a8b57897 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -9,7 +9,7 @@ MODULE layerinputs_mod USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq USE bicube_mod, ONLY: bicube_eval_external,bicube_type - USE slayer_netcdf_mod + USE slayer_netcdf_mod!, ONLY: slayer_netcdf_inputs IMPLICIT NONE @@ -228,7 +228,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, $ D_beta_norm_arr,intau_arr,Q0_arr,inpr_arr, - $ inpe_arr,omegas_arr,lu_arr,gammafac_arr, + $ inpe_arr,omegas_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) c----------------------------------------------------------------------- c declarations. @@ -254,7 +254,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, $ rho,tau_v,inpr,Qconv,lbeta,qintb,gammafac REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, - $ inQ_e_arr,psi_n_rational,D_beta_norm_arr,lu_arr, + $ inQ_e_arr,psi_n_rational,D_beta_norm_arr, $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, $ intau_arr,Q0_arr,inpr_arr,inpe_arr,omegas_arr, $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr @@ -302,7 +302,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, $ inpe_arr(msing),omegas_arr(msing),omegas_e_arr(msing), $ omegas_i_arr(msing),gammafac_arr(msing), $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), - $ D_beta_norm_arr(msing),lu_arr(msing)) + $ D_beta_norm_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) @@ -443,7 +443,6 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, inds_arr(ising)=ds ind_beta_arr(ising)=d_beta D_beta_norm_arr(ising)=D_beta_norm - lu_arr(ising)=lu intau_arr(ising)=tau Q0_arr(ising)=Q inpr_arr(ising) = inpr diff --git a/slayer/slayer.f b/slayer/slayer.f index 19356bca8..437c33101 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -44,28 +44,33 @@ PROGRAM slayer COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, - $ kpower,Qratio + $ kpower, + $ Qratio INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl, - $ bal,prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, + $ bal, + $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr,lu_arr, + $ inpe_arr,omegas_arr,inQ_arr, $ psi_n_rational,ind_beta_arr,D_beta_norm_arr - REAL(r8), DIMENSION(8) :: inpr_prof - + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, + $ all_Im_deltas,all_roots + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_inQs REAL(r8), DIMENSION(:,:),ALLOCATABLE :: Re_deltas,Im_deltas INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: - $ Re_deltaprime_arr,Im_deltaprime_arr - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: js,ks,psis,jxbs, - $ Q_sols,br_ths + $ Re_deltaprime_arr,Im_deltaprime_arr, + $ all_growthrates,all_growthrate_locs + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: + $ js,ks,psis,jxbs,Q_sols,br_ths, + $ inQs_left,inQs_right,coarse_deltas REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, @@ -308,7 +313,7 @@ PROGRAM slayer $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,ind_beta_arr,D_beta_norm_arr, $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,lu_arr,gammafac_arr, + $ omegas_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr @@ -333,8 +338,8 @@ PROGRAM slayer $ " rational surface" dels_db=riccati_del_s(inQ_arr(k),inQ_e_arr(k), - $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), - $ D_beta_norm_arr(k),intau_arr(k),5*D_beta_norm) + $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), + $ D_beta_norm_arr(k),intau_arr(k)) del_s = dels_db * ind_beta_arr(k) lar_gamma = gammafac_arr(k)/del_s @@ -364,7 +369,7 @@ PROGRAM slayer CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, $ lar_gamma_arr) @@ -413,7 +418,7 @@ PROGRAM slayer WRITE(*,*)"lar_gamma inQ = ",inQ dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,d_beta, - $ intau,5*D_beta_norm) + $ intau) WRITE(*,*)"dels_db() call successful" @@ -428,7 +433,6 @@ PROGRAM slayer lar_gamma_arr = (/ lar_gamma /) WRITE(*,*)"dels_db=",dels_db - WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 WRITE(*,*)"lar_gamma=",lar_gamma WRITE(*,*)"slayer.f lar_gamma=",lar_gamma @@ -438,7 +442,7 @@ PROGRAM slayer CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational,lu_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, $ lar_gamma_arr) @@ -461,7 +465,7 @@ PROGRAM slayer $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, $ inds_arr,ind_beta_arr,D_beta_norm_arr, $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,lu_arr,gammafac_arr, + $ omegas_arr,gammafac_arr, $ Re_deltaprime_arr,Im_deltaprime_arr) WRITE(*,*)"Safety factor values=",qval_arr @@ -608,6 +612,17 @@ PROGRAM slayer inQs = (/ 1.0 /) n_k = SIZE(qval_arr) + k=1 + IF (k==1) THEN + ALLOCATE(all_RE_deltas(1,1,n_k)) + ALLOCATE(all_Im_deltas(1,1,n_k)) + ALLOCATE(all_inQs(1,n_k)) + ALLOCATE(all_growthrates(n_k)) + ALLOCATE(all_growthrate_locs(n_k)) + ENDIF + all_Re_deltas(:,:,k) = 0.0 + all_Im_deltas(:,:,k) = 0.0 + all_inQs(:,k) = 0.0 qval_arr = (/ 3 /) inQs = (/ 1.0 /) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 62991adfa..1bee40819 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -52,8 +52,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, - $ inQs,iinQs,results) + $ ind_beta_arr,D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) ! ds = D_beta_norm for lar growth rate routines @@ -68,7 +67,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr,lu_arr + $ D_beta_norm_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, $ Im_deltaprime_arr,inQs,iinQs @@ -209,7 +208,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) - CALL check( nf90_put_var(ncid,S_id, lu_arr)) + CALL check( nf90_put_var(ncid,S_id, (/lu/))) CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) !CALL check( nf90_put_var(ncid,qr_id, qval_arr)) From bff21878915a887a67924bc72a7985f39248d14f Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 4 Apr 2025 10:25:14 -0400 Subject: [PATCH 029/118] netcdf working again, minor slayer fixes --- equil/lar.f | 15 +++++++++++---- slayer/slayer.f | 3 ++- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/equil/lar.f b/equil/lar.f index 59f882cec..c73657a2c 100644 --- a/equil/lar.f +++ b/equil/lar.f @@ -24,6 +24,7 @@ MODULE lar_mod INTEGER :: lar_m=2,lar_n=1 REAL(r8) :: lar_a,lar_r0,p_pres,p_sig REAL(r8), PRIVATE :: beta0,p,p00,q,sigma,sigma0 + CHARACTER(20) :: sigma_type TYPE(spline_type), PRIVATE :: spl CONTAINS @@ -45,7 +46,7 @@ SUBROUTINE lar_der(neq,r,y,dy) c----------------------------------------------------------------------- c compute derivatives. c----------------------------------------------------------------------- - CALL lar_profile(r,y,p,pp,sigma,bsq,q) + CALL lar_profile(r,y,p,pp,sigma,bsq,q,sigma_type) dy(1)=-pp/bsq*y(1)+sigma*y(2)*r dy(2)=-pp/bsq*y(2)-sigma*y(1)/r dy(3)=y(1)*lar_r0/r @@ -78,7 +79,7 @@ SUBROUTINE lar_run REAL(r8), DIMENSION(:,:), POINTER :: temp NAMELIST/lar_input/mtau,ma,lar_r0,lar_a,beta0,q0,p_pres,p_sig, - $ zeroth,out,bin,lar_m,lar_n + $ zeroth,out,bin,sigma_type,lar_m,lar_n REAL(r8), DIMENSION(:), POINTER :: xptr,fsptr,fs1ptr c----------------------------------------------------------------------- @@ -277,11 +278,12 @@ END SUBROUTINE lar_coefs c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- - SUBROUTINE lar_profile(r,y,p,pp,sigma,bsq,q) + SUBROUTINE lar_profile(r,y,p,pp,sigma,bsq,q,sigma_type) REAL(r8), INTENT(IN) :: r REAL(r8), INTENT(OUT) :: p,pp,sigma,bsq,q REAL(r8), DIMENSION(:), INTENT(IN) :: y + CHARACTER(20) :: sigma_type REAL(r8) :: x,xfac c----------------------------------------------------------------------- @@ -291,7 +293,12 @@ SUBROUTINE lar_profile(r,y,p,pp,sigma,bsq,q) xfac=1-x*x p=p00*xfac**p_pres pp=-2*p_pres*p00*x*xfac**(p_pres-1) - sigma=sigma0/(1+x**(2*p_sig))**(1+1/p_sig) + SELECT CASE(sigma_type) + CASE("wesson") + sigma=sigma0*xfac**p_sig + CASE default + sigma=sigma0/(1+x**(2*p_sig))**(1+1/p_sig) + END SELECT bsq=(y(1)/r)**2+y(2)**2 q=r**2*y(2)/(lar_r0*y(1)) c----------------------------------------------------------------------- diff --git a/slayer/slayer.f b/slayer/slayer.f index 437c33101..3ea016ba6 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -409,8 +409,9 @@ PROGRAM slayer Re_deltaprime_arr = (/ REAL(delta_n_p) /) Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) inpr_arr = (/ inpr /) + D_beta_norm_arr = (/ D_beta_norm /) - D_beta_norm = inds ! NAMELIST + !D_beta_norm = inds ! NAMELIST WRITE(*,*)"D_beta_norm = ",D_beta_norm WRITE(*,*)"inds = ",inds From 25292b2d84bb04b22169c48684768b3fa08c3fe8 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Sat, 12 Apr 2025 16:00:35 -0400 Subject: [PATCH 030/118] Bug fixes and ease of use --- input/slayer.in | 2 +- slayer/delta.f | 10 +- slayer/gslayer.f | 124 ++----------------- slayer/layerinputs.f | 48 ++++---- slayer/slayer.f | 61 ++++++---- slayer/slayer_netcdf.f | 263 +++++++++++++++++++++-------------------- 6 files changed, 214 insertions(+), 294 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 53994eef1..103e69a0c 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -26,7 +26,7 @@ inQ_e=2.0 ! normalized electron diamagnetic frequency inQ_i=-2.0 ! normalized ion diamagnetic frequency inc_beta=0.128 ! dimensionless measure of the plasma pressure - inds=2.26 ! normalized ion sound radius + inds=2.26 ! normalized ion sound radius. NOTE: set inds = 0 for internal D_norm caltulation intau=1.0 ! ion temperature divided by electron temperature Q0=1.5 ! unnecessary placeholder variable for inQ? delta_n_p=(5.0,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). diff --git a/slayer/delta.f b/slayer/delta.f index 0fffd1828..06332f1a3 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -160,7 +160,7 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, ! x=10.0*(1.0+log10(Q/pr)) !!!!!!!! - my_q=10.0 ! "starting backwards integration at large q" + my_q=inx!10.0 ! "starting backwards integration at large q" !!!!!!!! xmin=1e-5 @@ -239,7 +239,7 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat COMPLEX(r8) :: E,F - COMPLEX(r8), PARAMETER :: ifac=(0,1) + !COMPLEX(r8), PARAMETER :: ifac=(0,1) !Q_hat = Q / ds**4 Q_hat = (Q_e*(1+tau)/tau) / D_beta_norm**4 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark @@ -272,7 +272,7 @@ SUBROUTINE w_der(neq,x,y,dy) COMPLEX(r8) :: C2p COMPLEX(r8) :: A1 COMPLEX(r8) :: A2 - COMPLEX(r8), PARAMETER :: ifac=(0,1) + !COMPLEX(r8), PARAMETER :: ifac=(0,1) IF (parflow_flag) THEN C1=((1 + tau)*x**2*pe* @@ -736,7 +736,7 @@ SUBROUTINE w_der_temp(neq,x,y,dy) REAL(r8), INTENT(IN) :: x COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy - COMPLEX(r8), PARAMETER :: ifac=(0,1) + !COMPLEX(r8), PARAMETER :: ifac=(0,1) dy(1)=(2.0*x/(ifac*(Q-Q_e)+x**2.0)-1.0/x)*y(1)-y(1)*y(1)/x $ +x*(ifac*(Q-Q_e)+x**2.0) @@ -823,7 +823,7 @@ SUBROUTINE phi_der(neq,x,y,dy) REAL(r8), INTENT(IN) :: x COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy - COMPLEX(r8), PARAMETER :: ifac=(0,1) + !COMPLEX(r8), PARAMETER :: ifac=(0,1) dy(1)=(1+ifac*(Q-Q_e)*x**2.0)/x**2.0*y(2) dy(2)=(-Q*(Q-Q_i)*x**4.0+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 diff --git a/slayer/gslayer.f b/slayer/gslayer.f index fdc782e2c..9346fbdc9 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -185,7 +185,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lar_gamma_arr) + $ Im_deltaprime_arr,dels_db_arr,lu_arr,lar_gamma_arr) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, @@ -195,7 +195,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr + $ D_beta_norm_arr,lu_arr COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, $ lar_gamma_arr @@ -214,7 +214,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) END SUBROUTINE output_lar_gamma @@ -283,55 +283,6 @@ SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, $ results,count,match_count,dx,dy) - IF (match_count == 0) THEN ! ALL REPEATS TURNED OFF FOR NOW - WRITE(*,*)"No match found, rescanning" - repeat = .FALSE. - !new_scan_radius = scan_radius + 2 - new_ncoarse = ncoarse + 100 - new_nfine = nfine - ELSE IF (match_count > 0 .AND. match_count < 3) THEN - WRITE(*,*)"Match not definitive, rescanning" - repeat = .FALSE. - new_scan_radius = scan_radius - new_ncoarse = ncoarse - new_nfine = 8 - ELSE - repeat = .FALSE. - WRITE(*,*)"Match found" - - END IF - - IF (repeat) THEN - WRITE(*,*)"Rerunning growth rate scan" - - new_max_points = new_ncoarse**2 * (1 + - $ (new_nfine-1)**2) - - ! Resize arrays to new max number of points - CALL grow_array(results%inQs, max_points, new_max_points) - CALL grow_array(results%iinQs, max_points, new_max_points) - CALL grow_array(results%Re_deltas, max_points, new_max_points) - CALL grow_array(results%Im_deltas, max_points, new_max_points) - - results%inQs=0.0 - results%iinQs=0.0 - results%Re_deltas=0.0 - results%Im_deltas=0.0 - ! Initialize counter - count = 0 - - ! Calculate step sizes - inQ_step = (2.0 * new_scan_radius)/(new_ncoarse - 1) - iinQ_step = (2.0 * new_scan_radius)/(new_ncoarse - 1) - - match_count = 0 - - ! COARSE AND FINE LOOPS - CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe,my_lu, - $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, - $ results,count,match_count,dx,dy) - END IF ! End repeat "if" - ! Set the actual count of points results%count = count @@ -378,7 +329,8 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, iinQ_step = (2.0 * scan_radius) / (ncoarse - 1) dx = inQ_step dy = iinQ_step - + count = 0 + DO i = 1, ncoarse DO j = 1, ncoarse inQ_coarse = -scan_radius + (i - 1) * inQ_step @@ -389,66 +341,12 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, delta_real = REAL(delta)*(my_lu**(1.0/3.0)) ! Critical normalization delta_imag = AIMAG(delta)*(my_lu**(1.0/3.0)) ! Critical normalization - IF ((.NOT. compress_deltas) .OR. (ABS(deltaprime) < 4)) THEN - ! Store coarse grid point - count = count + 1 - results%inQs(count) = inQ_coarse - results%iinQs(count) = iinQ_coarse - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END IF - - IF (ABS(deltaprime) > 8) THEN - threshold = ABS(deltaprime)**(1./3.) - ELSE - threshold = 0.25 * ABS(deltaprime) - END IF - - ! Check if refinement is needed - IF (2 == 3) THEN !((ABS(delta_real) > threshold) .AND. - !$ (ABS(deltaprime) > 4)) THEN - ! IF ((ABS(delta_real) > threshold) .AND. (SIGN(1.0, - !$ delta_real) == SIGN(1.0, deltaprime))) THEN - - ! Fine grid loop - fine_dx = dx / nfine - fine_dy = dy / nfine - - overlap_x = overlap_factor * fine_dx - overlap_y = overlap_factor * fine_dy - - x_start = inQ_coarse - dx/2 + overlap_x - x_end = inQ_coarse + dx/2 - overlap_x - y_start = iinQ_coarse - dy/2 + overlap_y - y_end = iinQ_coarse + dy/2 - overlap_y - - DO fj = 0, nfine-1 - iinQ_fine = y_start + fj * (y_end-y_start) / (nfine-1) - DO fi = 0, nfine-1 - inQ_fine = x_start + fi * (x_end-x_start) / (nfine-1) - IF ((ABS(inQ_coarse - inQ_fine) < - $ tolerance) .AND. (ABS(iinQ_coarse - - $ iinQ_fine) < tolerance)) CYCLE - - ! Evaluate riccati function - delta = riccati(inQ_fine,inQ_e,inQ_i,inpr, - $ inc_beta,inds,intau,inpe,iinQ=iinQ_fine) - delta_real = REAL(delta)*(my_lu**(1.0/3.0)) - delta_imag = AIMAG(delta)*(my_lu**(1.0/3.0)) - - IF (ABS(delta_real)>ABS(deltaprime)) THEN - match_count = match_count + 1 - END IF - - ! Store fine grid point - count = count + 1 - results%inQs(count) = inQ_fine - results%iinQs(count) = iinQ_fine - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - END DO - END DO - END IF + count = count + 1 + results%inQs(count) = inQ_coarse + results%iinQs(count) = iinQ_coarse + results%Re_deltas(count) = delta_real + results%Im_deltas(count) = delta_imag + END DO END DO END SUBROUTINE scan_grid diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 6a8b57897..dfa924f9f 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -47,14 +47,14 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) - CALL check(stat) ! Error handling + CALL sl_check(stat) ! Error handling stat = nf90_inquire_attribute(ncid,msing_id,"msing", $ len = msing_len) - CALL check(stat) + CALL sl_check(stat) ALLOCATE(msing_arr(msing_len)) stat = nf90_get_att(ncid,msing_id,"msing",msing_arr) - CALL check(stat) + CALL sl_check(stat) msing=INT(msing_arr(1)) @@ -65,16 +65,16 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ALLOCATE(delta_prime(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inquire_attribute(ncid,bt0_id,"bt0",len=bt0_len) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inquire_attribute(ncid,psio_id,"psio",len=psio_len) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inquire_attribute(ncid,mpsi_id,"mpsi",len=mpsi_len) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) - CALL check(stat) + CALL sl_check(stat) bt0_id=0 !!!!! THIS COULD BE A PROBLEM nn_id=0 @@ -88,39 +88,39 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Get Variable IDs stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inq_varid(ncid, "q_rational", qr_id) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inq_varid(ncid, "shear", shear_id) - CALL check(stat) + CALL sl_check(stat) stat = nf90_inq_varid(ncid, "resm", resm_id) - CALL check(stat) + CALL sl_check(stat) ! Get attributes stat = nf90_get_att(ncid, ro_id, "ro", r_o) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_att(ncid, bt0_id, "bt0", my_bt0) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_att(ncid, psio_id, "psio", my_psio) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_att(ncid, nn_id, "n", nn) - CALL check(stat) + CALL sl_check(stat) ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) - CALL check(stat) + CALL sl_check(stat) ! Read 1D variables stat = nf90_get_var(ncid, qr_id, q_rational) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_var(ncid, pr_id, psi_n_rational) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_var(ncid, shear_id, shear) - CALL check(stat) + CALL sl_check(stat) stat = nf90_get_var(ncid, resm_id, resm) - CALL check(stat) + CALL sl_check(stat) ! Extract Diagonal, with 3rd index signifying REAL part DO i = 1, msing @@ -130,7 +130,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Clean Up DEALLOCATE(delta_prime) stat = nf90_close(ncid) - CALL check(stat) + CALL sl_check(stat) END SUBROUTINE read_stride_netcdf_diagonal c----------------------------------------------------------------------- diff --git a/slayer/slayer.f b/slayer/slayer.f index 3c159e3ce..b8e093bdd 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -34,7 +34,7 @@ PROGRAM slayer $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,stabscan_eq_flag,stabscan_flag, - $ lar_gamma_eq_flag,lar_gamma_flag,Pe_flag, + $ lar_gamma_eq_flag,lar_gamma_flag, $ br_th_flag,compress_deltas REAL(r8) :: n_e,t_e,t_i,omega,omega0, @@ -56,7 +56,7 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, $ inQ_i_arr,inc_beta_arr,inds_arr, $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr, + $ inpe_arr,omegas_arr,inQ_arr,lu_arr, $ psi_n_rational,ind_beta_arr,D_beta_norm_arr REAL(r8), DIMENSION(8) :: inpr_prof REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, @@ -91,7 +91,6 @@ PROGRAM slayer $ scan_radius,QPscan_flag,QPscan2_flag, $ QPescan_flag,QDscan2_flag,Qbscan_flag,Qscan_flag, $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, - $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ stability_flag,lar_gamma_eq_flag,lar_gamma_flag, @@ -341,7 +340,8 @@ PROGRAM slayer dels_db=riccati_del_s(inQ_arr(k),inQ_e_arr(k), $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), - $ D_beta_norm_arr(k),intau_arr(k)) + $ D_beta_norm_arr(k),intau_arr(k), + $ 5.0*D_beta_norm_arr(k)) del_s = dels_db * ind_beta_arr(k) lar_gamma = gammafac_arr(k)/del_s @@ -373,7 +373,7 @@ PROGRAM slayer $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lar_gamma_arr) + $ lu_arr,lar_gamma_arr) stop ENDIF @@ -394,13 +394,25 @@ PROGRAM slayer CALL params(n_e,t_e,t_i,omega, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - !inQ=Q ! TAKEN FROM NAMELIST - !inQ_e=Q_e ! TAKEN FROM NAMELIST - !inQ_i=Q_i ! TAKEN FROM NAMELIST - !inc_beta=c_beta - !inds=ds - !intau=tau - !Q0=Q + + IF (inQ > 0.0) THEN + Q = inQ ! NAMELIST + END IF + IF (inQ_e > 0.0) THEN + Q_e = inQ_e ! NAMELIST + END IF + IF (inQ_i > 0.0) THEN + Q_i = inQ_i ! NAMELIST + END IF + IF (inpr > 0.0) THEN + pr = inpr ! NAMELIST + END IF + IF (intau > 0.0) THEN + tau = intau ! NAMELIST + END IF + IF (inds > 0.0) THEN + D_beta_norm = inds ! NAMELIST + END IF qval_arr = (/ qval /) omegas_arr = (/ omega /) @@ -413,15 +425,13 @@ PROGRAM slayer inpr_arr = (/ inpr /) D_beta_norm_arr = (/ D_beta_norm /) - !D_beta_norm = inds ! NAMELIST - WRITE(*,*)"D_beta_norm = ",D_beta_norm WRITE(*,*)"inds = ",inds WRITE(*,*)"lar_gamma inQ = ",inQ dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,d_beta, - $ intau) + $ intau,5.0*D_beta_norm) WRITE(*,*)"dels_db() call successful" @@ -436,9 +446,8 @@ PROGRAM slayer lar_gamma_arr = (/ lar_gamma /) WRITE(*,*)"dels_db=",dels_db - WRITE(*,*)"lar_gamma=",lar_gamma - - WRITE(*,*)"slayer.f lar_gamma=",lar_gamma + WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 + WRITE(*,*)"growth rate=",lar_gamma br_th = 0.0 @@ -447,7 +456,7 @@ PROGRAM slayer $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lar_gamma_arr) + $ lu_arr,lar_gamma_arr) stop ENDIF @@ -535,6 +544,12 @@ PROGRAM slayer Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) inpr_arr = (/ inpr /) + + CALL params(n_e,t_e,t_i,omega, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + + D_beta_norm_arr = (/ D_beta_norm /) + CALL growthrate_scan(qval_arr(1),lu,inQ,inQ_e, $ inQ_i,inc_beta,inds, $ intau,inQ,inpr,inpe, @@ -544,8 +559,12 @@ PROGRAM slayer WRITE(*,*)"allocations successful" br_th = 0.0 -c CALL slayer_netcdf_out(1,lar_gamma_eq_flag,lar_gamma_flag, -c $ stabscan_eq_flag,stabscan_flag,br_th_flag) + CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, + $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, + $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, + $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) stop ENDIF c----------------------------------------------------------------------- diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 1bee40819..152a0093f 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -20,15 +20,11 @@ MODULE slayer_netcdf_mod IMPLICIT NONE CONTAINS c ----------------------------------------------------------------------- -c ----------------------------------------------------------------------- -c subprogram 2. stride_netcdf_out. -c Replicate stride.out information in netcdf format. -c ----------------------------------------------------------------------- c----------------------------------------------------------------------- c subprogram 1. check. c Check status of netcdf file. c----------------------------------------------------------------------- - SUBROUTINE check(stat) + SUBROUTINE sl_check(stat) c----------------------------------------------------------------------- c declaration. c----------------------------------------------------------------------- @@ -37,14 +33,18 @@ SUBROUTINE check(stat) c stop if it is an error. c----------------------------------------------------------------------- IF(stat /= nf90_noerr) THEN - PRINT *, TRIM(nf90_strerror(stat)) - !STOP "ERROR: failed to write/read netcdf file" + PRINT *, TRIM(nf90_strerror(stat)) + STOP "ERROR: failed to write/read netcdf file" ENDIF c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- RETURN - END SUBROUTINE check + END SUBROUTINE sl_check +c ----------------------------------------------------------------------- +c subprogram 2. slayer_netcdf_out. +c Replicate stride.out information in netcdf format. +c ----------------------------------------------------------------------- c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- @@ -52,8 +52,8 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ ind_beta_arr,D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) - + $ lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, + $ inQs,iinQs,results) ! ds = D_beta_norm for lar growth rate routines c OPTIONAL @@ -65,9 +65,10 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr + REAL(r8), DIMENSION(msing) :: gamma_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, - $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr + $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr, + $ ind_beta_arr,D_beta_norm_arr,lu_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, $ Im_deltaprime_arr,inQs,iinQs @@ -115,7 +116,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, c open files c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Creating netcdf files" - CALL check( nf90_create(ncfile, + CALL sl_check( nf90_create(ncfile, $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) max_points = maxval([(results(run)%count, run=1,msing)]) @@ -123,12 +124,12 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, c define global file attributes c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Defining netcdf globals" - CALL check( nf90_put_att(ncid,nf90_global,"title", + CALL sl_check( nf90_put_att(ncid,nf90_global,"title", $ "SLAYER outputs")) - !CALL check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) - !CALL check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) - !CALL check( nf90_put_att(ncid,nf90_global,"n", nn)) - CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + !CALL sl_check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) + !CALL sl_check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) + !CALL sl_check( nf90_put_att(ncid,nf90_global,"n", nn)) + CALL sl_check( nf90_put_att(ncid,nf90_global,"version", version)) ! define global attributes ! define dimensions IF(debug_flag) PRINT *," - Defining dimensions in netcdf" @@ -138,109 +139,111 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, WRITE(*,*)"netcdf qval_arr=",qval_arr IF(msing>0)THEN - CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational - CALL check( nf90_def_dim(ncid, "i", 2, i_dim) ) - CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, + CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) + CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) - CALL check( nf90_def_var(ncid,"omegas",nf90_double, + CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) - CALL check( nf90_def_var(ncid,"Q",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, $ qsing_dim,Q_id)) - CALL check( nf90_def_var(ncid,"Q_e",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Q_e",nf90_double, $ qsing_dim,Q_e_id)) - CALL check( nf90_def_var(ncid,"Q_i",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Q_i",nf90_double, $ qsing_dim,Q_i_id)) - CALL check( nf90_def_var(ncid,"S",nf90_double, + CALL sl_check( nf90_def_var(ncid,"S",nf90_double, $ qsing_dim,S_id)) - CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, - $ qsing_dim,pr_id) ) - CALL check( nf90_def_var(ncid,"P",nf90_double, + CALL sl_check( nf90_def_var(ncid,"psi_n_rational", + $ nf90_double,qsing_dim,pr_id) ) + CALL sl_check( nf90_def_var(ncid,"P",nf90_double, $ qsing_dim,inpr_id) ) - CALL check( nf90_def_var(ncid,"q_rational",nf90_double, + CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, $ qsing_dim,qr_id) ) - CALL check( nf90_def_dim(ncid, "points", max_points, + CALL sl_check( nf90_def_dim(ncid, "points", max_points, $ point_dimid) ) IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL check( nf90_def_var(ncid,"growthrates",nf90_double, + CALL sl_check( nf90_def_var(ncid,"growthrate",nf90_double, $ qsing_dim,gamma_id)) - CALL check(nf90_def_var(ncid,"growthrate_locs",nf90_double, - $ qsing_dim,gamma_loc_id)) - CALL check( nf90_def_var(ncid, "Re_Qs", nf90_double, + CALL sl_check(nf90_def_var(ncid,"growthrate_locs", + $ nf90_double,qsing_dim,gamma_loc_id)) + CALL sl_check( nf90_def_var(ncid, "Re_Qs", nf90_double, $ [point_dimid, qsing_dim], varids(1)) ) - CALL check( nf90_def_var(ncid, "Im_Qs", nf90_double, + CALL sl_check( nf90_def_var(ncid, "Im_Qs", nf90_double, $ [point_dimid, qsing_dim], varids(2)) ) - CALL check( nf90_def_var(ncid, "Re_deltas", nf90_double, + CALL sl_check( nf90_def_var(ncid, "Re_deltas",nf90_double, $ [point_dimid, qsing_dim], varids(3)) ) - CALL check( nf90_def_var(ncid, "Im_deltas", nf90_double, + CALL sl_check( nf90_def_var(ncid, "Im_deltas",nf90_double, $ [point_dimid, qsing_dim], varids(4)) ) END IF IF (br_th_flag) THEN - CALL check( nf90_def_var(ncid,"br_th",nf90_double, + CALL sl_check( nf90_def_var(ncid,"br_th",nf90_double, $ qsing_dim,br_th_id) ) END IF END IF IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, $ qsing_dim,rdpp_id) ) - CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, $ qsing_dim,idpp_id) ) END IF IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN - CALL check( nf90_def_var(ncid,"delta_s_d_b",nf90_double, + CALL sl_check( nf90_def_var(ncid,"delta_s_d_b",nf90_double, $ (/qsing_dim,i_dim/),dels_db_id) ) - CALL check( nf90_def_var(ncid,"d_beta",nf90_double, + CALL sl_check( nf90_def_var(ncid,"d_beta",nf90_double, $ qsing_dim,d_b_id) ) - CALL check( nf90_def_var(ncid,"D_beta_norm",nf90_double, + CALL sl_check( nf90_def_var(ncid,"D_beta_norm",nf90_double, $ qsing_dim,indnorm_id) ) - CALL check( nf90_def_var(ncid,"growthrate",nf90_double, - $ (/qsing_dim,i_dim/),lar_gamma_id) ) + CALL sl_check( nf90_def_var(ncid,"growthrate_estimate", + $ nf90_double,(/qsing_dim,i_dim/),lar_gamma_id) ) END IF ! end definitions - CALL check( nf90_enddef(ncid) ) + CALL sl_check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- - CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) - CALL check( nf90_put_var(ncid,Q_id, inQ_arr)) - CALL check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) - CALL check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) - CALL check( nf90_put_var(ncid,S_id, (/lu/))) - CALL check( nf90_put_var(ncid,pr_id, psi_n_rational)) - CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) - !CALL check( nf90_put_var(ncid,qr_id, qval_arr)) + CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) + CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) + CALL sl_check( nf90_put_var(ncid,Q_id, inQ_arr)) + CALL sl_check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) + CALL sl_check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) + CALL sl_check( nf90_put_var(ncid,S_id, (/lu/))) + CALL sl_check( nf90_put_var(ncid,pr_id, psi_n_rational)) + CALL sl_check( nf90_put_var(ncid,inpr_id, inpr_arr)) + !CALL sl_check( nf90_put_var(ncid,qr_id, qval_arr)) IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) - CALL check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) + CALL sl_check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) + CALL sl_check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) DO run = 1, msing - CALL check( nf90_put_var(ncid,varids(1),results(run)%inQs, - $ start=[1, run], count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid,varids(2),results(run)%iinQs, - $ start=[1, run], count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid, varids(3), + CALL sl_check( nf90_put_var(ncid,varids(1), + $ results(run)%inQs,start=[1, run], + $ count=[results(run)%count, 1]) ) + CALL sl_check( nf90_put_var(ncid,varids(2), + $ results(run)%iinQs,start=[1, run], + $ count=[results(run)%count, 1])) + CALL sl_check( nf90_put_var(ncid, varids(3), $ results(run)%Re_deltas, start=[1, run], $ count=[results(run)%count, 1]) ) - CALL check( nf90_put_var(ncid, varids(4), + CALL sl_check( nf90_put_var(ncid, varids(4), $ results(run)%Im_deltas, start=[1, run], $ count=[results(run)%count, 1]) ) END DO END IF IF (br_th_flag) THEN - CALL check( nf90_put_var(ncid,br_th_id, (/ br_th /))) + CALL sl_check( nf90_put_var(ncid,br_th_id, (/ br_th /))) END IF IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN - CALL check( nf90_put_var(ncid,dels_db_id, + CALL sl_check( nf90_put_var(ncid,dels_db_id, $ RESHAPE((/REAL(dels_db_arr),AIMAG(dels_db_arr)/), $ (/msing,2/)))) - CALL check( nf90_put_var(ncid,d_b_id,ind_beta_arr)) - CALL check( nf90_put_var(ncid,indnorm_id, D_beta_norm_arr)) - CALL check( nf90_put_var(ncid,lar_gamma_id, + CALL sl_check( nf90_put_var(ncid,d_b_id,ind_beta_arr)) + CALL sl_check( nf90_put_var(ncid,indnorm_id, D_beta_norm_arr)) + CALL sl_check( nf90_put_var(ncid,lar_gamma_id, $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), $ (/msing,2/)))) @@ -250,7 +253,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, c close file c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Closing netcdf file" - CALL check( nf90_close(ncid) ) + CALL sl_check( nf90_close(ncid) ) c ----------------------------------------------------------------------- c terminate. c ----------------------------------------------------------------------- @@ -326,117 +329,117 @@ SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, c open files c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Creating netcdf files" - CALL check( nf90_create(ncfile, + CALL sl_check( nf90_create(ncfile, $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) c ----------------------------------------------------------------------- c define global file attributes c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Defining netcdf globals" - CALL check( nf90_put_att(ncid,nf90_global,"title", + CALL sl_check( nf90_put_att(ncid,nf90_global,"title", $ "SLAYER outputs")) - CALL check( nf90_put_att(ncid,nf90_global,"version", version)) + CALL sl_check( nf90_put_att(ncid,nf90_global,"version", version)) IF(debug_flag) PRINT *," - Defining dimensions in netcdf" IF(msing>0)THEN - !CALL check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational - CALL check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, + !CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, $ qsing_id)) - CALL check( nf90_def_var(ncid,"ne",nf90_double, + CALL sl_check( nf90_def_var(ncid,"ne",nf90_double, $ qsing_dim,ne_id)) - CALL check( nf90_def_var(ncid,"te",nf90_double, + CALL sl_check( nf90_def_var(ncid,"te",nf90_double, $ qsing_dim,te_id)) - CALL check( nf90_def_var(ncid,"ni",nf90_double, + CALL sl_check( nf90_def_var(ncid,"ni",nf90_double, $ qsing_dim,ni_id)) - CALL check( nf90_def_var(ncid,"ti",nf90_double, + CALL sl_check( nf90_def_var(ncid,"ti",nf90_double, $ qsing_dim,ti_id)) - CALL check( nf90_def_var(ncid,"zeff",nf90_double, + CALL sl_check( nf90_def_var(ncid,"zeff",nf90_double, $ qsing_dim,zeff_id)) - CALL check( nf90_def_var(ncid,"shear",nf90_double, + CALL sl_check( nf90_def_var(ncid,"shear",nf90_double, $ qsing_dim,shear_id)) - CALL check( nf90_def_var(ncid,"bt",nf90_double, + CALL sl_check( nf90_def_var(ncid,"bt",nf90_double, $ qsing_dim,bt_id)) - CALL check( nf90_def_var(ncid,"rs",nf90_double, + CALL sl_check( nf90_def_var(ncid,"rs",nf90_double, $ qsing_dim,rs_id)) - CALL check( nf90_def_var(ncid,"R0",nf90_double, + CALL sl_check( nf90_def_var(ncid,"R0",nf90_double, $ qsing_dim,R0_id)) - !CALL check( nf90_def_var(ncid,"mu_i",nf90_double, + !CALL sl_check( nf90_def_var(ncid,"mu_i",nf90_double, !$ qsing_dim,mu_i_id)) - CALL check( nf90_def_var(ncid,"resm",nf90_int, + CALL sl_check( nf90_def_var(ncid,"resm",nf90_int, $ qsing_dim,resm_id)) - CALL check( nf90_def_var(ncid,"nns_arr",nf90_int, + CALL sl_check( nf90_def_var(ncid,"nns_arr",nf90_int, $ qsing_dim,nns_id)) - !CALL check( nf90_def_var(ncid,"qval",nf90_int, + !CALL sl_check( nf90_def_var(ncid,"qval",nf90_int, !$ qsing_dim,qval_id)) - CALL check( nf90_def_var(ncid,"Q",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, $ qsing_dim,inQ_id)) - ! CALL check( nf90_def_var(ncid,"Q_e",nf90_double, + ! CALL sl_check( nf90_def_var(ncid,"Q_e",nf90_double, !$ qsing_dim,inQ_e_id)) - ! CALL check( nf90_def_var(ncid,"Q_i",nf90_double, + ! CALL sl_check( nf90_def_var(ncid,"Q_i",nf90_double, !$ qsing_dim,inQ_i_id)) - CALL check( nf90_def_var(ncid,"c_beta",nf90_double, + CALL sl_check( nf90_def_var(ncid,"c_beta",nf90_double, $ qsing_dim,inc_beta_id)) - CALL check( nf90_def_var(ncid,"ds",nf90_double, + CALL sl_check( nf90_def_var(ncid,"ds",nf90_double, $ qsing_dim,inds_id)) - CALL check( nf90_def_var(ncid,"tau",nf90_double, + CALL sl_check( nf90_def_var(ncid,"tau",nf90_double, $ qsing_dim,intau_id)) - CALL check( nf90_def_var(ncid,"pr",nf90_double, + CALL sl_check( nf90_def_var(ncid,"pr",nf90_double, $ qsing_dim,inpr_id)) - CALL check( nf90_def_var(ncid,"pe",nf90_double, + CALL sl_check( nf90_def_var(ncid,"pe",nf90_double, $ qsing_dim,inpe_id)) - CALL check( nf90_def_var(ncid,"omegas",nf90_double, + CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) - CALL check( nf90_def_var(ncid,"omegas_e",nf90_double, + CALL sl_check( nf90_def_var(ncid,"omegas_e",nf90_double, $ qsing_dim,omegas_e_id)) - CALL check( nf90_def_var(ncid,"omegas_i",nf90_double, + CALL sl_check( nf90_def_var(ncid,"omegas_i",nf90_double, $ qsing_dim,omegas_i_id)) - CALL check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, $ qsing_dim,Re_delta_id)) - CALL check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, + CALL sl_check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, $ qsing_dim,Im_delta_id)) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" ! end definitions - CALL check( nf90_enddef(ncid) ) + CALL sl_check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" - CALL check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL check( nf90_put_var(ncid,ne_id, ne_arr)) - CALL check( nf90_put_var(ncid,ni_id, ni_arr)) - CALL check( nf90_put_var(ncid,te_id, te_arr)) - CALL check( nf90_put_var(ncid,ti_id, ti_arr)) - CALL check( nf90_put_var(ncid,zeff_id, zeff_arr)) - CALL check( nf90_put_var(ncid,shear_id, shear)) - CALL check( nf90_put_var(ncid,bt_id, bt_arr)) - CALL check( nf90_put_var(ncid,rs_id, rs_arr)) - CALL check( nf90_put_var(ncid,R0_id, R0_arr)) - !CALL check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) - CALL check( nf90_put_var(ncid,resm_id, resm)) - CALL check( nf90_put_var(ncid,nns_id, nns_arr)) - !CALL check( nf90_put_var(ncid,qval_id, qval_arr)) - CALL check( nf90_put_var(ncid,inQ_id, inQ_arr)) - !CALL check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) - !CALL check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) - CALL check( nf90_put_var(ncid,inc_beta_id, inc_beta_arr)) - CALL check( nf90_put_var(ncid,inds_id, inds_arr)) - CALL check( nf90_put_var(ncid,intau_id, intau_arr)) - CALL check( nf90_put_var(ncid,inpr_id, inpr_arr)) - CALL check( nf90_put_var(ncid,inpe_id, inpe_arr)) - CALL check( nf90_put_var(ncid,omegas_id, omegas_arr)) - CALL check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) - CALL check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) - CALL check( nf90_put_var(ncid,Re_delta_id,Re_deltaprime_arr)) - CALL check( nf90_put_var(ncid,Im_delta_id,Im_deltaprime_arr)) + CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) + CALL sl_check( nf90_put_var(ncid,ne_id, ne_arr)) + CALL sl_check( nf90_put_var(ncid,ni_id, ni_arr)) + CALL sl_check( nf90_put_var(ncid,te_id, te_arr)) + CALL sl_check( nf90_put_var(ncid,ti_id, ti_arr)) + CALL sl_check( nf90_put_var(ncid,zeff_id, zeff_arr)) + CALL sl_check( nf90_put_var(ncid,shear_id, shear)) + CALL sl_check( nf90_put_var(ncid,bt_id, bt_arr)) + CALL sl_check( nf90_put_var(ncid,rs_id, rs_arr)) + CALL sl_check( nf90_put_var(ncid,R0_id, R0_arr)) + !CALL sl_check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) + CALL sl_check( nf90_put_var(ncid,resm_id, resm)) + CALL sl_check( nf90_put_var(ncid,nns_id, nns_arr)) + !CALL sl_check( nf90_put_var(ncid,qval_id, qval_arr)) + CALL sl_check( nf90_put_var(ncid,inQ_id, inQ_arr)) + !CALL sl_check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) + !CALL sl_check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) + CALL sl_check( nf90_put_var(ncid,inc_beta_id, inc_beta_arr)) + CALL sl_check( nf90_put_var(ncid,inds_id, inds_arr)) + CALL sl_check( nf90_put_var(ncid,intau_id, intau_arr)) + CALL sl_check( nf90_put_var(ncid,inpr_id, inpr_arr)) + CALL sl_check( nf90_put_var(ncid,inpe_id, inpe_arr)) + CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) + CALL sl_check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) + CALL sl_check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) + CALL sl_check( nf90_put_var(ncid,Re_delta_id,Re_deltaprime_arr)) + CALL sl_check( nf90_put_var(ncid,Im_delta_id,Im_deltaprime_arr)) c ----------------------------------------------------------------------- c close file c ----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Closing netcdf file" - CALL check( nf90_close(ncid) ) + CALL sl_check( nf90_close(ncid) ) c ----------------------------------------------------------------------- c terminate. c ----------------------------------------------------------------------- From 066a3713d8ce1196a5f6b14051ca5d389d257c1b Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 15 Apr 2025 17:18:30 -0400 Subject: [PATCH 031/118] layfac=tau_R, STRIDE effective rs in netcdf --- slayer/slayer.f | 7 +++++-- stride/stride_netcdf.f | 39 ++++++++++++++++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 3 deletions(-) diff --git a/slayer/slayer.f b/slayer/slayer.f index b8e093bdd..b79564e3c 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -435,8 +435,11 @@ PROGRAM slayer WRITE(*,*)"dels_db() call successful" - eta = 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - tau_r = mu0*rs**2.0/eta ! resistive time scale + tau_r = layfac !!!! CRITICAL + WRITE(*,*)"tau_r = ",tau_r + + !eta = 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + !tau_r = mu0*rs**2.0/eta ! resistive time scale del_s = dels_db * d_beta lar_gamma = (REAL(delta_n_p)/tau_r) * (rs/del_s) diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 6345c8abd..4f89c8e5a 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -61,12 +61,20 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id,prandtl_id + $ shear_id,resm_id,prandtl_id,rs_id,rf_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile REAL(r8) :: resnum,shear,respsi,resm_sing + + REAL(r8), DIMENSION(msing) :: rs_array + REAL(r8), DIMENSION(:), ALLOCATABLE :: rs_full + + TYPE(spline_type) :: sr + REAL(r8), DIMENSION(0:mpsi) :: rhotor + + INTEGER, DIMENSION(msing) :: resm INTEGER :: ising,jsing,m @@ -90,6 +98,29 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) ev = CMPLX(evi, 0.0) et = CMPLX(eti, 0.0) c----------------------------------------------------------------------- +c loop across singular surfaces, evaluate minor radius +c----------------------------------------------------------------------- + WRITE(*,*)"REACHED RS CALCULATION" + rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen + CALL spline_alloc(sr,mpsi,1) + sr%xs = sq%xs + sr%fs(:, 1) = rhotor(:) + CALL spline_fit(sr,"extrap") + + ALLOCATE(rs_full(sq%mx+1)) + + DO i=1,msing + respsi = sing(i)%psifac + WRITE(*,*)"respsi=",respsi + CALL spline_eval(sr,respsi,1) + rs_array(i) = sr%f1(1) + END DO + DO i=1,sq%mx+1 + respsi = sq%xs(i)!*psio + CALL spline_eval(sr,respsi,1) + rs_full(i) = sr%f1(1) + END DO +c----------------------------------------------------------------------- c open files c----------------------------------------------------------------------- IF(debug_flag) PRINT *," - Creating netcdf files" @@ -175,6 +206,10 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid,"r_prime",nf90_int,rp_dim,rp_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ r_dim,pr_id) ) + CALL check( nf90_def_var(ncid,"eff_rs_rational",nf90_double, + $ r_dim,rs_id) ) + CALL check( nf90_def_var(ncid,"eff_rs",nf90_double, + $ p_dim,rf_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, @@ -236,6 +271,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,pr_id, (/(sing(i)%psifac, $ i=1,msing)/)) ) + CALL check( nf90_put_var(ncid,rs_id, rs_array) ) + CALL check( nf90_put_var(ncid,rf_id, rs_full) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) From d6002588edea3931fe5ae84c708c03fac056c995 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 18 Apr 2025 18:30:53 -0400 Subject: [PATCH 032/118] STRIDE rs flux avg, SLAYER fixes --- slayer/delta.f | 7 ++- slayer/slayer.f | 12 ++-- stride/stride_netcdf.f | 135 ++++++++++++++++++++++++++++++++++++----- 3 files changed, 131 insertions(+), 23 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 06332f1a3..50ac741ab 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -172,7 +172,8 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, P_hat = inpr / ind_beta**6 ! P_perp, 0.377 for Pperp_hat benchmark WRITE(*,*)"riccati_del_s inpr = ",inpr - WRITE(*,*)"riccati_del_s inQ = ",inQ + WRITE(*,*)"riccati_del_s Q_e = ",Q_e + WRITE(*,*)"riccati_del_s ind_beta = ",ind_beta alpha = (P_hat/(1+1/tau))**0.5 ! this is actually tau', we need tau W(1) = -alpha*my_q**2 - 0.5 @@ -245,7 +246,9 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) Q_hat = (Q_e*(1+tau)/tau) / D_beta_norm**4 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark P_perp_hat = pr / D_beta_norm**6 ! 0.377 for benchmark P_tor_hat = pr / D_beta_norm**6 ! 1.15 for benchmark - + !WRITE(*,*)"w_der inpr = ",pr + !WRITE(*,*)"w_der Q_e = ",Q_e + !WRITE(*,*)"w_der D_beta_norm = ",D_beta_norm E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) ! P_tor = P_perp F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 diff --git a/slayer/slayer.f b/slayer/slayer.f index b79564e3c..03b54b734 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -426,17 +426,19 @@ PROGRAM slayer D_beta_norm_arr = (/ D_beta_norm /) WRITE(*,*)"D_beta_norm = ",D_beta_norm - WRITE(*,*)"inds = ",inds + !WRITE(*,*)"inds = ",inds - WRITE(*,*)"lar_gamma inQ = ",inQ + !WRITE(*,*)"lar_gamma inQ = ",inQ - dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,d_beta, - $ intau,5.0*D_beta_norm) + dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta, + $ D_beta_norm,intau,5.0*D_beta_norm) - WRITE(*,*)"dels_db() call successful" + !WRITE(*,*)"dels_db() call successful" tau_r = layfac !!!! CRITICAL WRITE(*,*)"tau_r = ",tau_r + WRITE(*,*)"deltaprime = ",REAL(delta_n_p) + WRITE(*,*)"rs = ",rs !eta = 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) !tau_r = mu0*rs**2.0/eta ! resistive time scale diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 4f89c8e5a..5be759f90 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -17,6 +17,7 @@ MODULE stride_netcdf_mod USE dcon_mod USE netcdf + !USE dcon_interface, ONLY: issurfint IMPLICIT NONE CONTAINS @@ -42,6 +43,93 @@ SUBROUTINE check(stat) RETURN END SUBROUTINE check c----------------------------------------------------------------------- +c subprogram 2. issurfint. +c surface integration by simple method. copied from EQUIL +c----------------------------------------------------------------------- + FUNCTION issurfint(func,fs,inpsi,wegt,ave, + $ fsave,psave,jacs,delpsi,inr,ina,first) +c----------------------------------------------------------------------- +c declaration. +c----------------------------------------------------------------------- + !IMPLICIT NONE + INTEGER, INTENT(IN) :: fs,wegt,ave + REAL(r8), INTENT(IN) :: inpsi + REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func + + LOGICAL, INTENT(INOUT) :: first + INTEGER, INTENT(INOUT) :: fsave + REAL(r8), INTENT(INOUT) :: psave + REAL(r8),DIMENSION(0:),INTENT(INOUT) :: jacs,delpsi,inr,ina + INTEGER :: itheta, ix, iy + REAL(r8) :: issurfint + REAL(r8) :: rfac,ineta,injac,inarea + REAL(r8), DIMENSION(1,2) :: w + REAL(r8), DIMENSION(0:fs) :: z,thetas + REAL(r8), dimension(4) :: rzphi_f, rzphi_fx, rzphi_fy + + issurfint=0 + inarea=0 + ix = 0 + iy = 0 + IF(first .OR. inpsi/=psave .OR. fs/=fsave)THEN + psave = inpsi + fsave = fs + !first = .FALSE. + DO itheta=0,fs + thetas(itheta) = REAL(itheta,r8)/REAL(fs,r8) + ENDDO + DO itheta=0,fs-1 + CALL bicube_eval_external(rzphi, inpsi, thetas(itheta), 1, + $ ix, iy, rzphi_f, rzphi_fx, rzphi_fy) + rfac=SQRT(rzphi_f(1)) + ineta=twopi*(thetas(itheta)+rzphi_f(2)) + ina(itheta)=rfac + inr(itheta)=ro+rfac*COS(ineta) + z(itheta)=zo+rfac*SIN(ineta) + injac=rzphi_f(4) + jacs(itheta)=injac + w(1,1)=(1+rzphi_fy(2))*twopi**2*rfac*inr(itheta)/injac + w(1,2)=-rzphi_fy(1)*pi*inr(itheta)/(rfac*injac) + delpsi(itheta)=SQRT(w(1,1)**2+w(1,2)**2) + ENDDO + ENDIF + + IF (wegt==0) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE IF (wegt==1) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE IF (wegt==2) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs + ENDDO + ELSE IF (wegt==3) THEN + DO itheta=0,fs-1 + issurfint=issurfint+ + $ ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ENDDO + ELSE + STOP "ERROR: issurfint wegt must be in [0,1,2,3]" + ENDIF + + IF (ave==1) THEN + DO itheta=0,fs-1 + inarea=inarea+jacs(itheta)*delpsi(itheta)/fs + ENDDO + issurfint=issurfint/inarea + ENDIF +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- + RETURN + END FUNCTION issurfint +c----------------------------------------------------------------------- c subprogram 2. stride_netcdf_out. c Replicate stride.out information in netcdf format. c----------------------------------------------------------------------- @@ -55,7 +143,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: dp INTEGER, DIMENSION(mpert) :: mvec - INTEGER :: i, ncid, + INTEGER :: i, ncid,mthsur, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, $ f_id, q_id, dv_id, mu_id, di_id, dr_id, ca_id, $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, @@ -73,7 +161,15 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) TYPE(spline_type) :: sr REAL(r8), DIMENSION(0:mpsi) :: rhotor - + + ! MINOR RADIUS INTEGRAL QUANTITIES + LOGICAL :: firstsur + REAL(r8), DIMENSION(0:512) :: my_unitfun + INTEGER :: my_fsave + REAL(r8) :: my_psave + REAL(r8), DIMENSION(:), ALLOCATABLE :: my_jacs,my_delpsi, + $ my_rsurf,my_asurf + REAL(r8) :: my_rfac,my_jac,a_surf INTEGER, DIMENSION(msing) :: resm @@ -100,25 +196,32 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) c----------------------------------------------------------------------- c loop across singular surfaces, evaluate minor radius c----------------------------------------------------------------------- - WRITE(*,*)"REACHED RS CALCULATION" - rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen - CALL spline_alloc(sr,mpsi,1) - sr%xs = sq%xs - sr%fs(:, 1) = rhotor(:) - CALL spline_fit(sr,"extrap") + !WRITE(*,*)"REACHED RS CALCULATION" + !rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen + !CALL spline_alloc(sr,mpsi,1) + !sr%xs = sq%xs + !sr%fs(:, 1) = rhotor(:) + !CALL spline_fit(sr,"extrap") ALLOCATE(rs_full(sq%mx+1)) + mthsur = 512 ! Hardcoded, but this is a default value + ALLOCATE(my_jacs(0:mthsur),my_delpsi(0:mthsur), + $ my_rsurf(0:mthsur),my_asurf(0:mthsur)) DO i=1,msing respsi = sing(i)%psifac - WRITE(*,*)"respsi=",respsi - CALL spline_eval(sr,respsi,1) - rs_array(i) = sr%f1(1) + ! SURFACE INTEGRAL + firstsur = .TRUE. + my_unitfun = 1 + rs_array(i) = issurfint(my_unitfun,mthsur,respsi,3,1, + $ my_fsave,my_psave,my_jacs,my_delpsi,my_rsurf, + $ my_asurf,firstsur) END DO DO i=1,sq%mx+1 - respsi = sq%xs(i)!*psio - CALL spline_eval(sr,respsi,1) - rs_full(i) = sr%f1(1) + respsi = sq%xs(i)!*psio + rs_full(i) = issurfint(my_unitfun,mthsur,respsi,3,1, + $ my_fsave,my_psave,my_jacs,my_delpsi,my_rsurf, + $ my_asurf,firstsur) END DO c----------------------------------------------------------------------- c open files @@ -206,9 +309,9 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid,"r_prime",nf90_int,rp_dim,rp_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ r_dim,pr_id) ) - CALL check( nf90_def_var(ncid,"eff_rs_rational",nf90_double, + CALL check( nf90_def_var(ncid,"rs_rational",nf90_double, $ r_dim,rs_id) ) - CALL check( nf90_def_var(ncid,"eff_rs",nf90_double, + CALL check( nf90_def_var(ncid,"flux_avg_rs",nf90_double, $ p_dim,rf_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) From 610914fd2d598b2e0fb64b87f2edba2d31cc1cbf Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 22 Apr 2025 16:16:54 -0400 Subject: [PATCH 033/118] draft of rfitzp growth rate solve --- input/slayer.in | 2 + slayer/delta.f | 167 +++++++++++++++++++++++++++++ slayer/gslayer.f | 238 ++++++++++++++++++++++++++++++++++++++++- slayer/sglobal.f | 5 +- slayer/slayer.f | 126 +++++++++++++++++++--- slayer/slayer_netcdf.f | 24 ++++- 6 files changed, 536 insertions(+), 26 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 103e69a0c..b1de1d750 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -30,6 +30,7 @@ intau=1.0 ! ion temperature divided by electron temperature Q0=1.5 ! unnecessary placeholder variable for inQ? delta_n_p=(5.0,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). + ingam=(0.1,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). / &SLAYER_CONTROL @@ -61,6 +62,7 @@ stability_flag=f ! calculate delta dependence on complex Q lar_gamma_eq_flag=f ! Calculate cylindrical growthrates for each rational surface of input equilibrium lar_gamma_flag=f ! Calculate cylindrical growthrate for namelist parameters + fitz_gamma_flag=f ! Calculate Fitzpatrick layer model stabscan_eq_flag=f ! Generate Re(Q),Im(Q) scans for each rational surface of input equilibrium stabscan_flag=f ! Generate Re(Q),Im(Q) scan for namelist parameters br_th_flag=f ! Calculate br_th diff --git a/slayer/delta.f b/slayer/delta.f index 50ac741ab..30d3e6b9a 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -259,6 +259,173 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) END SUBROUTINE w_der_del_s c c +c +c----------------------------------------------------------------------- +c calculate delta based on Fitzpatrick delta formulation. +c----------------------------------------------------------------------- + FUNCTION riccati_f(tmp_g,inQ_e,inQ_i,inpr,inD_beta_norm, + $ intau,inx) + REAL(r8),INTENT(IN) :: inQ_e,inQ_i,inpr,inD_beta_norm + REAL(r8),INTENT(IN) :: intau + COMPLEX(r8), INTENT(IN) :: tmp_g + REAL(r8),INTENT(IN),OPTIONAL :: inx + COMPLEX(r8) :: riccati_f + + INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf + INTEGER :: ml = 0, mu = 0, nrpd = 1 + + REAL(r8) :: xintv,x,xout,rtol,jac,xmin,my_p,P_hat,alpha,bk + COMPLEX(r8) :: ak,ck_1,ck_2,ck,xk,W_bound + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dWdp,y,dy + + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork + REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork + + !IF(present(iinQ)) Q=inQ+ifac*iinQ + Q_e=inQ_e + Q_i=inQ_i + pr=inpr + D_beta_norm=inD_beta_norm + tau=intau + + neq = 2 + itol = 2 + rtol = 1e-10 !changed to 1e-08 !1e-7*pr**0.4 ! !1e-7 at front 1e-6 !e-4 + ALLOCATE(atol(neq),W(1),dWdp(1)) + atol(:) = 1e-10!*pr**0.4 ! changed to 1e-08 1e-8 !e-4 + itask = 2 + istate = 1 + iopt = 0 + mf = 21!21 IS STIFF WITH USER-SPECIFIED JACOBIAN, 10 iS NON STIFF + liw = 20*2 + lrw = 22+9*neq+neq**2 !just (22+16*neq) for mf=10 + ALLOCATE(iwork(liw+neq),rwork(lrw)) ! just iwork(liw) for mf=10 + +! MXSTEP? + iopt = 1 + iwork=0 + iwork(6)=50000 !5000 ! maximum # of steps per call, e.g. 50000 + rwork=0 +! x=10.0*(1.0+log10(Q/pr)) + + !!!!!!!! + !IF(present(inx)) my_p=inx!10.0 ! "starting backwards integration at large q" + !!!!!!!! + my_p=6.0 + xmin=1e-6 + xout=xmin + + ! SOLVE FOR W BOUNDARY CONDITION + IF (D_beta_norm > (pr**(1.0/6.0))) THEN + ak = -(g_tmp + ifac*Q_e) + bk = pr/(2.0*(D_beta_norm**2.0)) + + ck_1 = 2.0*(g_tmp + ifac*Q_i)/pr + ck_2 = (pr + (g_tmp + + $ ifac*Q_i)*(D_beta_norm**2.0))/(2.0*pr*(D_beta_norm**2.0)) + ck = (pr/(2.0*(D_beta_norm**2.0)))*(1 + ck_1 - ck_2) + + xk = (ck - SQRT(bk)*(1 - + $ SQRT(bk)*ak))/(2.0*SQRT(bk)) + + W_bound = xk - SQRT(bk)*my_p + ELSE + ak = -(g_tmp + ifac*Q_e) + bk = pr + ck = -ifac*(Q_e - Q_i) + (g_tmp + ifac*Q_i) + xk = (ak*bk - ck)/(2.0*SQRT(bk)) + + W_bound = -1 + xk*my_p - SQRT(bk)*(my_p**3.0) + END IF + + W(1) = W_bound + + IF (riccati_out) THEN + istep = 1 + itask = 2 + OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn)//'.bin',STATUS='UNKNOWN', + $ POSITION='REWIND',FORM='UNFORMATTED') + + OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn)//'.out',STATUS='UNKNOWN') + WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" + DO WHILE (my_p>xout) + istep=istep+1 + CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) + WRITE(bin_unit)REAL(my_p,4),REAL(REAL(W),4),REAL(AIMAG(W),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')my_p,REAL(W),AIMAG(W) + ENDDO + CLOSE(bin_unit) + CLOSE(out2_unit) + ELSE + istep = 1 + itask = 1 + CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) + + ENDIF + + ! w=0 when Q=Q_e. Why? + + CALL w_der_f(neq,my_p,W,dWdp) + WRITE(*,*)"riccati Q_e = ",Q_e + WRITE(*,*)"riccati Q_i = ",Q_i + WRITE(*,*)"riccati pr = ",pr + WRITE(*,*)"riccati D_beta_norm = ",D_beta_norm + WRITE(*,*)"riccati g_tmp = ",g_tmp + + ! delta = np.pi * p_min / (W_value + 1) + riccati_f = pi / dWdp(1) + DEALLOCATE(atol,W,dWdp,iwork,rwork) + + END FUNCTION riccati_f +c----------------------------------------------------------------------- +c jacobian for riccati_del_s() +c------------------------------------------- ---------------------------- + SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: my_p + COMPLEX(r8) :: fA_p + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + + fA_p = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + + $ ifac*Q_e + (my_p**2.0)) + + pd(1,1) = (-fA_p/my_p) - (2.0*W(1))/my_p + END SUBROUTINE jac_f +c----------------------------------------------------------------------- +c riccati integration. +c----------------------------------------------------------------------- + SUBROUTINE w_der_f(neq,my_p,W,dWdp) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: my_p + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dWdp + COMPLEX(r8) :: fA, fA_prime, fB, fC + + !WRITE(*,*)"w_der g_tmp = ",g_tmp + + ! Evaluate coefficients at the current p + fA = (my_p**2)/(g_tmp + ifac*Q_e + (my_p**2.0)) + fA_prime = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + + $ ifac*Q_e + (my_p**2.0)) + fB = g_tmp*(g_tmp + ifac*Q_i) + 2.0*(g_tmp + + $ ifac*Q_i)*pr*(my_p**2.0) + (pr**2.0)*(my_p**4.0) + fC = g_tmp + ifac*Q_e + ( pr + (g_tmp + + $ ifac*Q_i)*(D_beta_norm**2.0))*(my_p**2.0) + + $ 2.0*pr*(D_beta_norm**2.0)*(my_p**4.0) + + dWdp(1) = -(fA_prime/my_p)*W(1) - (W(1)**2.0)/my_p + + $ (fB/(fA*fC))*(my_p**3.0) + + RETURN + END SUBROUTINE w_der_f +c +c c SUBROUTINE w_der(neq,x,y,dy) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 9346fbdc9..13a84384c 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -182,14 +182,17 @@ END SUBROUTINE gpec_slayer c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ fitz_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,lar_gamma_arr) + $ Im_deltaprime_arr,dels_db_arr,lu_arr,delta_arr, + $ lar_gamma_arr) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag + $ stabscan_eq_flag,stabscan_flag,br_th_flag, + $ fitz_gamma_flag INTEGER, INTENT(IN), DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, @@ -198,7 +201,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ D_beta_norm_arr,lu_arr COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, - $ lar_gamma_arr + $ lar_gamma_arr,delta_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs TYPE(result_type) :: results(8) @@ -211,10 +214,12 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, iinQs = (/0.0/) CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag, + $ stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, + $ ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) END SUBROUTINE output_lar_gamma @@ -376,4 +381,227 @@ SUBROUTINE grow_array(arr, old_size, new_size) temp(1:old_size) = arr(1:old_size) CALL move_alloc(temp, arr) END SUBROUTINE grow_array +c +c +c + subroutine NewtonRoot(g_r, g_i, verbose) + REAL(r8), intent(inout) :: g_r, g_i + integer, intent(in) :: verbose + + REAL(r8) :: F1, F2, J11, J12, J21, J22, det, iJ11, iJ12 + REAL(r8) :: iJ21, iJ22, dx1, dx2, dx, f, g1, g2, lambda, + $ Residual + integer :: iter + + REAL(r8), parameter :: Eps = 1.0e-12 ! Tolerance parameter + REAL(r8), parameter :: Smin = 1.0e-07 ! Min step size + REAL(r8), parameter :: Smax = 0.1 ! Max step size + integer, parameter :: MaxIter = 100 ! Maximum iterations + + iter = 0 + do + call NewtonFunction(g_r, g_i, F1, F2) + + call NewtonJacobian(g_r, g_i, J11, J12, J21, J22) + + det = J11 * J22 - J12 * J21 + + iJ11 = J22 / det + iJ12 = -J12 / det + iJ21 = -J21 / det + iJ22 = J11 / det + + dx1 = -(iJ11 * F1 + iJ12 * F2) + dx2 = -(iJ21 * F1 + iJ22 * F2) + + dx = sqrt(dx1*dx1 + dx2*dx2) + + f = 0.5 * (F1*F1 + F2*F2) + + g1 = F1*J11 + F2*J21 + g2 = F1*J12 + F2*J22 + + call NewtonBackTrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda) + + call NewtonFunction(g_r, g_i, F1, F2) + + Residual = sqrt(F1*F1 + F2*F2) + + if (verbose .ne. 0) then + write(*, '("x = (", ES10.3, ", ", ES10.3, ") F = (", + & ES10.3, ", ", ES10.3, ") Residual = ", ES10.3, + & " lambda = ", ES10.3, " dx = ", ES10.3)') + & g_r, g_i, F1, F2, Residual, lambda, dx + endif + + iter = iter + 1 + + if (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit + enddo + + end subroutine NewtonRoot + +!----------------------------------------------------------------------- +! Function to backtrack along Newton step in order to minimize f = (F1*F1 + F2*F2) /2 +! +! Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies in C (Cambridge, 1992), Sect. 9.7 +!----------------------------------------------------------------------- + subroutine NewtonBackTrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, + & lambda) + REAL(r8), intent(inout) :: g_r, g_i, dx, lambda + REAL(r8), intent(inout) :: dx1, dx2, f, g1, g2 + + REAL(r8) :: x1old, x2old, dxold, fold, slope, F1, F2 + REAL(r8) :: tmplam, rhs1, rhs2, a, b, disc, lambd2, mf2 + integer :: i + + REAL(r8), parameter :: Smin = 1.0d-10 ! Min step size + REAL(r8), parameter :: Smax = 1.0d0 ! Max step size + REAL(r8), parameter :: alpha = 1.0d-4 ! Line search parameter + integer, parameter :: Maxiter = 100 ! Maximum iterations + + x1old = g_r + x2old = g_i + dxold = dx + fold = f + + if (dxold > Smax) then + dx1 = dx1 * Smax / dxold + dx2 = dx2 * Smax / dxold + dxold = Smax + endif + + slope = g1*dx1 + g2*dx2 + + if (slope >= 0.0d0) then + write(*, *) "NewtonBackTrack: Error - roundoff problem" + endif + + lambda = 1.0d0 + + do i = 0, Maxiter + g_r = x1old + lambda * dx1 + g_i = x2old + lambda * dx2 + + call NewtonFunction(g_r, g_i, F1, F2) + + f = 0.5 * (F1*F1 + F2*F2) + + if (f <= fold + alpha * lambda * slope .or. + & lambda * dxold < Smin) then + dx = lambda * dxold + return + else + if (lambda == 1.0d0) then + tmplam = -slope / 2.0d0 / (f - fold - slope) + else + rhs1 = f - fold - lambda * slope + rhs2 = mf2 - fold - lambd2 * slope + + a = (rhs1/lambda/lambda - rhs2/lambd2/lambd2) + & / (lambda - lambd2) + b = (-lambd2 * rhs1/lambda/lambda + lambda * + & rhs2/lambd2/lambd2) / (lambda - lambd2) + + if (a == 0.0d0) then + tmplam = -slope / 2.0d0 / b + else + disc = b*b - 3.0d0 * a * slope + + if (disc < 0.0d0) then + tmplam = 0.5d0 * lambda + else if (b <= 0.0d0) then + tmplam = (-b + sqrt(disc)) / 3.0d0 / a + else + tmplam = -slope / (b + sqrt(disc)) + endif + endif + + if (tmplam > 0.5d0 * lambda) then + tmplam = 0.5d0 * lambda + endif + endif + endif + + lambd2 = lambda + mf2 = f + lambda = max(tmplam, 0.1d0*lambda) + enddo + + dx = lambda * dxold + + end subroutine NewtonBackTrack + +!----------------------------------------------------------------------- +! Function to calculate Jacobian matrix for Newton-Raphson root finding +!----------------------------------------------------------------------- + subroutine NewtonJacobian(g_r, g_i, J11, J12, J21, J22) + REAL(r8), intent(in) :: g_r, g_i + REAL(r8), intent(out) :: J11, J12, J21, J22 + + REAL(r8) :: F1m, F2m, F1p, F2p + REAL(r8), parameter :: dS = 1.0e-06 ! Step size for derivatives + + call NewtonFunction(g_r - dS, g_i, F1m, F2m) + call NewtonFunction(g_r + dS, g_i, F1p, F2p) + + J11 = (F1p - F1m) / 2.0d0 / dS + J21 = (F2p - F2m) / 2.0d0 / dS + + call NewtonFunction(g_r, g_i - dS, F1m, F2m) + call NewtonFunction(g_r, g_i + dS, F1p, F2p) + + J12 = (F1p - F1m) / 2.0d0 / dS + J22 = (F2p - F2m) / 2.0d0 / dS + + end subroutine NewtonJacobian + +!----------------------------------------------------------------------- +! Function to return maximum of two values +!----------------------------------------------------------------------- + function Fmax(f1, f2) result(res) + double precision, intent(in) :: f1, f2 + double precision :: res + + if (f1 > f2) then + res = f1 + else + res = f2 + endif + + end function Fmax + +!----------------------------------------------------------------------- +! Function to return minimum of two values +!----------------------------------------------------------------------- + function Fmin(f1, f2) result(res) + REAL(r8), intent(in) :: f1, f2 + REAL(r8) :: res + + if (f1 < f2) then + res = f1 + else + res = f2 + endif + + end function Fmin + +!----------------------------------------------------------------------- +! Function to calculate target functions for Newton-Raphson root finding +!----------------------------------------------------------------------- + subroutine NewtonFunction(g_r, g_i, F1, F2) + REAL(r8), intent(in) :: g_r, g_i + REAL(r8), intent(out) :: F1, F2 + + ! These would be module-level variables in the original code + COMPLEX(r8) :: Deltas + REAL(r8) :: Delta + + g_tmp = CMPLX(g_r,g_i) + Deltas=riccati_f(g_tmp,Q_e,Q_i,pr,D_beta_norm,tau) + + F1 = REAL(Deltas) - deltaprim + F2 = dimag(Deltas) + + end subroutine NewtonFunction END MODULE gslayer_mod diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 00b751f3f..74e8a9589 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -10,8 +10,9 @@ MODULE sglobal_mod REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, $ d_beta,D_beta_norm,gamma_fac REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, - $ delta_n,layfac,Qconv - COMPLEX(r8) :: Q + $ delta_n,layfac,Qconv,deltaprim, + $ g_r, g_i + COMPLEX(r8) :: Q,g_tmp REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6022e-19, diff --git a/slayer/slayer.f b/slayer/slayer.f index 03b54b734..00353156e 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -34,14 +34,15 @@ PROGRAM slayer $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,stabscan_eq_flag,stabscan_flag, - $ lar_gamma_eq_flag,lar_gamma_flag, + $ lar_gamma_eq_flag,lar_gamma_flag,fitz_gamma_flag, $ br_th_flag,compress_deltas REAL(r8) :: n_e,t_e,t_i,omega,omega0, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,tau_r,d_b - COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma + REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,tau_r,d_b,Residual + COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, + $ tmp_gamma,ingam REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower, @@ -74,7 +75,8 @@ PROGRAM slayer REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, - $ dels_db_arr,lar_gamma_arr + $ dels_db_arr,lar_gamma_arr, + $ delta_arr COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas TYPE(result_type) :: results(8) ! Assuming max 8 rational surfaces @@ -86,7 +88,7 @@ PROGRAM slayer $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, $ inQ_i,inpr,inpr_prof,inpe,inc_beta,inds, - $ intau,inlu,Q0,delta_n_p + $ intau,inlu,Q0,delta_n_p,ingam NAMELIST/slayer_control/inum,jnum,knum,ReQ_num,ImQ_num, $ scan_radius,QPscan_flag,QPscan2_flag, $ QPescan_flag,QDscan2_flag,Qbscan_flag,Qscan_flag, @@ -94,8 +96,8 @@ PROGRAM slayer $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ stability_flag,lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,compress_deltas, - $ bal_flag + $ fitz_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ compress_deltas,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -130,6 +132,7 @@ PROGRAM slayer inlu=1e8 Q0=4.0 delta_n_p=(1e-2,1e-2) + ingam=(0.0,1e-2) inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. @@ -172,6 +175,7 @@ PROGRAM slayer stabscan_flag=.FALSE. stabscan_eq_flag=.FALSE. lar_gamma_flag=.FALSE. + fitz_gamma_flag=.FALSE. lar_gamma_eq_flag=.FALSE. br_th_flag=.FALSE. compress_deltas=.FALSE. @@ -332,7 +336,7 @@ PROGRAM slayer n_k = SIZE(qval_arr) - ALLOCATE(lar_gamma_arr(n_k),dels_db_arr(n_k)) + ALLOCATE(lar_gamma_arr(n_k),dels_db_arr(n_k),delta_arr(n_k)) DO k=1,n_k WRITE(*,*) "Calculating growth rate on q=", qval_arr(k), @@ -369,11 +373,12 @@ PROGRAM slayer br_th = 0.0 CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ fitz_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,lar_gamma_arr) + $ lu_arr,delta_arr,lar_gamma_arr) stop ENDIF @@ -457,11 +462,100 @@ PROGRAM slayer br_th = 0.0 CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ fitz_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,lar_gamma_arr) + $ lu_arr,delta_arr,lar_gamma_arr) + + stop + ENDIF +c----------------------------------------------------------------------- +c LAR (cylindrical) growthrates via restive layer thickness +c----------------------------------------------------------------------- + IF (fitz_gamma_flag) THEN + WRITE(*,*)"Calculating Fitzpatrick inner delta" + + ! CALL params(n_e,t_e,t_i,omega, + !$ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + + + IF (inQ > 0.0) THEN + Q = inQ ! NAMELIST + END IF + IF (inQ_e > 0.0) THEN + Q_e = inQ_e ! NAMELIST + END IF + IF (inQ_i > 0.0) THEN + Q_i = inQ_i ! NAMELIST + END IF + IF (inpr > 0.0) THEN + pr = inpr ! NAMELIST + END IF + IF (intau > 0.0) THEN + tau = intau ! NAMELIST + END IF + IF (inds > 0.0) THEN + D_beta_norm = inds ! NAMELIST + END IF + + WRITE(*,*)"intau=",tau + WRITE(*,*)"inQ=",Q + WRITE(*,*)"inQ_e=",Q_e + WRITE(*,*)"inQ_i=",Q_i + WRITE(*,*)"Prantdl number=",pr + WRITE(*,*)"inQ_e=",inQ_e + WRITE(*,*)"D_beta_norm=",D_beta_norm + WRITE(*,*)"inc_beta=",inc_beta + + qval_arr = (/ qval /) + omegas_arr = (/ omega /) + inQ_arr = (/ inQ /) + inQ_e_arr = (/ inQ_e /) + inQ_i_arr = (/ inQ_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ 0.0 /) + Im_deltaprime_arr = (/ 0.0 /) + inpr_arr = (/ inpr /) + D_beta_norm_arr = (/ D_beta_norm /) + + ! INPUT GAMMA = delta_n_p + + deltaprim = REAL(delta_n_p) + g_tmp = ingam + WRITE(*,*)"g_tmp = ",g_tmp + + delta=riccati_f(g_tmp,Q_e,Q_i,pr, + $ D_beta_norm,tau) + + WRITE(*,*)"Fitz delta = ",delta + + g_r = 0.0 + g_i = -Q_e + CALL NewtonRoot(g_r, g_i, 1) + + lar_gamma = g_r + WRITE(*,*)"Fitz gamma success! growth rate = ",g_r + + ind_beta_arr = (/ 0. /) + dels_db_arr = (/ 0. /) ! USING DELS_DB_ARR FOR DELTA + delta_arr = (/ delta /) ! USING DELS_DB_ARR FOR DELTA + lar_gamma_arr = (/ g_r /) + + !WRITE(*,*)"dels_db=",dels_db + !WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 + !WRITE(*,*)"growth rate=",lar_gamma + + br_th = 0.0 + + CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, + $ fitz_gamma_flag, + $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, + $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, + $ D_beta_norm_arr,inpr_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, + $ lu_arr,delta_arr,lar_gamma_arr) stop ENDIF @@ -516,10 +610,12 @@ PROGRAM slayer WRITE(*,*)"qval_arr = ",qval_arr CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ lar_gamma_flag, + $ fitz_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, + $ ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, c $ stabscan_eq_flag,stabscan_flag,br_th_flag) @@ -565,10 +661,12 @@ PROGRAM slayer br_th = 0.0 CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag, + $ stabscan_flag,br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,ind_beta_arr, + $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, + $ ind_beta_arr, $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) stop ENDIF diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 152a0093f..589e66fcf 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -49,10 +49,11 @@ END SUBROUTINE sl_check c declarations. c ----------------------------------------------------------------------- SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, - $ lar_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, + $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag,stabscan_flag, + $ br_th_flag, $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, + $ delta_arr,lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, $ inQs,iinQs,results) ! ds = D_beta_norm for lar growth rate routines @@ -62,7 +63,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, INTEGER, INTENT(IN) :: msing LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag + $ stabscan_eq_flag,stabscan_flag,br_th_flag,fitz_gamma_flag INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr REAL(r8), DIMENSION(msing) :: gamma_arr @@ -75,7 +76,7 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, REAL(r8) :: br_th COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: dels_db_arr, - $ lar_gamma_arr + $ lar_gamma_arr,delta_arr TYPE(result_type), INTENT(IN) :: results(8) @@ -197,6 +198,12 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL sl_check( nf90_def_var(ncid,"D_beta_norm",nf90_double, $ qsing_dim,indnorm_id) ) CALL sl_check( nf90_def_var(ncid,"growthrate_estimate", + $ nf90_double,(/qsing_dim,i_dim/),lar_gamma_id) ) + END IF + IF (fitz_gamma_flag) THEN + CALL sl_check( nf90_def_var(ncid,"delta_hat",nf90_double, + $ (/qsing_dim,i_dim/),dels_db_id) ) + CALL sl_check( nf90_def_var(ncid,"growthrate", $ nf90_double,(/qsing_dim,i_dim/),lar_gamma_id) ) END IF ! end definitions @@ -246,7 +253,14 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL sl_check( nf90_put_var(ncid,lar_gamma_id, $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), $ (/msing,2/)))) - + END IF + IF (fitz_gamma_flag) THEN + CALL sl_check( nf90_put_var(ncid,dels_db_id, + $ RESHAPE((/REAL(delta_arr),AIMAG(delta_arr)/), + $ (/msing,2/)))) + CALL sl_check( nf90_put_var(ncid,lar_gamma_id, + $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), + $ (/msing,2/)))) END IF c ----------------------------------------------------------------------- From 64d45d3771b700dad9476253982b53afe7709be9 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 6 May 2025 13:28:34 -0400 Subject: [PATCH 034/118] old stabscan architecture backup --- slayer/delta.f | 12 ++++---- slayer/gslayer.f | 5 ++-- slayer/slayer.f | 64 +++++++++++++++++++++++++++++++++++++----- slayer/slayer_netcdf.f | 29 +++++++++++++++++++ 4 files changed, 95 insertions(+), 15 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 30d3e6b9a..1989a5c62 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -370,13 +370,13 @@ FUNCTION riccati_f(tmp_g,inQ_e,inQ_i,inpr,inD_beta_norm, ! w=0 when Q=Q_e. Why? CALL w_der_f(neq,my_p,W,dWdp) - WRITE(*,*)"riccati Q_e = ",Q_e - WRITE(*,*)"riccati Q_i = ",Q_i - WRITE(*,*)"riccati pr = ",pr - WRITE(*,*)"riccati D_beta_norm = ",D_beta_norm - WRITE(*,*)"riccati g_tmp = ",g_tmp + !WRITE(*,*)"riccati Q_e = ",Q_e + !WRITE(*,*)"riccati Q_i = ",Q_i + !WRITE(*,*)"riccati pr = ",pr + !WRITE(*,*)"riccati D_beta_norm = ",D_beta_norm + !WRITE(*,*)"riccati g_tmp = ",g_tmp - ! delta = np.pi * p_min / (W_value + 1) + !riccati_f = pi * my_p / (dWdp(1) + 1) riccati_f = pi / dWdp(1) DEALLOCATE(atol,W,dWdp,iwork,rwork) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 13a84384c..7d6b047e9 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -187,7 +187,7 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, $ Im_deltaprime_arr,dels_db_arr,lu_arr,delta_arr, - $ lar_gamma_arr) + $ lar_gamma_arr,results) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, @@ -204,7 +204,8 @@ SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ lar_gamma_arr,delta_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs - TYPE(result_type) :: results(8) + !TYPE(result_type) :: results(8) + TYPE(result_type), INTENT(IN) :: results(8) REAL(r8) :: br_th = 0 diff --git a/slayer/slayer.f b/slayer/slayer.f index 00353156e..8a8196082 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -24,8 +24,8 @@ PROGRAM slayer IMPLICIT NONE CHARACTER(512) :: infile,ncfile - INTEGER :: i,j,k,inum,jnum,knum,inn, - $ ReQ_num,ImQ_num,n_k,scan_radius + INTEGER :: i,j,k,inum,jnum,knum,inn,count, + $ ReQ_num,ImQ_num,n_k,scan_radius,max_points INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -45,8 +45,8 @@ PROGRAM slayer $ tmp_gamma,ingam REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, - $ kpower, - $ Qratio + $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, + $ delta_imag,Qratio INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns @@ -378,7 +378,7 @@ PROGRAM slayer $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr) + $ lu_arr,delta_arr,lar_gamma_arr,results) stop ENDIF @@ -467,7 +467,7 @@ PROGRAM slayer $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr) + $ lu_arr,delta_arr,lar_gamma_arr,results) stop ENDIF @@ -549,13 +549,63 @@ PROGRAM slayer br_th = 0.0 + max_points = 50*50 + scan_radius = 1.5 + + ! Calculate step sizes +c ALLOCATE(results(1)%inQs(max_points), +c $ results(1)%iinQs(max_points)) +c ALLOCATE(results(1)%Re_deltas(max_points), +c $ results(1)%Im_deltas(max_points)) + ing_step = (2.0 * scan_radius) / (200 - 1) + count = 0 + + ALLOCATE(inQs(1:201),iinQs(1:200)) + ALLOCATE(deltas(1:201,1:200)) + + DO i = 1, 201 + DO j = 1, 200 + ing_coarse = -scan_radius + (i - 1) * ing_step + iing_coarse = -scan_radius + (j - 1) * ing_step + ! Evaluate riccati function + g_tmp = CMPLX(ing_coarse,iing_coarse) + delta=riccati_f(g_tmp, + $ Q_e,Q_i,pr,D_beta_norm,tau) + !delta_real = REAL(delta) + !delta_imag = AIMAG(delta) + + !count = count + 1 + !results(1)%inQs(count) = ing_coarse + !results(1)%iinQs(count) = iing_coarse + !results(1)%Re_deltas(count) = delta_real + !results(1)%Im_deltas(count) = delta_imag + inQs(i) = ing_coarse + iinQs(j) = iing_coarse + deltas(i,j) = delta + + END DO + END DO + + OPEN(UNIT=out_unit,FILE="slayer_stability_n1.out", + $ STATUS="UNKNOWN") + WRITE(out_unit,'(1x,4(a17))') "RE(Q)", + $ "IM(Q)","RE(delta)","IM(delta)" + DO i=1,201 + DO j=1,200 + WRITE(out_unit,'(1x,4(es17.8e3))') + $ inQs(i),iinQs(j), + $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) + ENDDO + ENDDO + CLOSE(out_unit) + CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, $ fitz_gamma_flag, $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, $ D_beta_norm_arr,inpr_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr) + $ lu_arr,delta_arr,lar_gamma_arr,results) stop ENDIF diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 589e66fcf..1b61d38f0 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -178,6 +178,17 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ [point_dimid, qsing_dim], varids(4)) ) END IF +c IF (fitz_gamma_flag) THEN +c CALL sl_check( nf90_def_var(ncid, "Re_Qs", nf90_double, +c $ [point_dimid, qsing_dim], varids(1)) ) +c CALL sl_check( nf90_def_var(ncid, "Im_Qs", nf90_double, +c $ [point_dimid, qsing_dim], varids(2)) ) +c CALL sl_check( nf90_def_var(ncid,"Re_deltas",nf90_double, +c $ [point_dimid, qsing_dim], varids(3)) ) +c CALL sl_check( nf90_def_var(ncid,"Im_deltas",nf90_double, +c $ [point_dimid, qsing_dim], varids(4)) ) +c END IF + IF (br_th_flag) THEN CALL sl_check( nf90_def_var(ncid,"br_th",nf90_double, $ qsing_dim,br_th_id) ) @@ -240,6 +251,24 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, END DO END IF +c IF (fitz_gamma_flag) THEN +c DO run = 1, msing +c run = 1 +c CALL sl_check( nf90_put_var(ncid,varids(1), +c $ results(run)%inQs,start=[1, run], +c $ count=[results(run)%count, 1]) ) +c CALL sl_check( nf90_put_var(ncid,varids(2), +c $ results(run)%iinQs,start=[1, run], +c $ count=[results(run)%count, 1])) +c CALL sl_check( nf90_put_var(ncid, varids(3), +c $ results(run)%Re_deltas, start=[1, run], +c $ count=[results(run)%count, 1]) ) +c CALL sl_check( nf90_put_var(ncid, varids(4), +c $ results(run)%Im_deltas, start=[1, run], +c $ count=[results(run)%count, 1]) ) +c END DO +c END IF + IF (br_th_flag) THEN CALL sl_check( nf90_put_var(ncid,br_th_id, (/ br_th /))) END IF From 096a60df56f87fdf020c79803982be36e6c4be25 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 9 May 2025 17:39:33 -0400 Subject: [PATCH 035/118] new architecture! toggle fitz vs JKP --- input/slayer.in | 73 ++-- slayer/delta.f | 72 ++-- slayer/gslayer.f | 329 +++++++++--------- slayer/layerinputs.f | 205 ++++++----- slayer/params.f | 68 +++- slayer/sglobal.f | 13 +- slayer/slayer.f | 761 ++++++++++++++++------------------------- slayer/slayer_netcdf.f | 404 ++++------------------ stride/stride_netcdf.f | 142 +------- 9 files changed, 776 insertions(+), 1291 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index b1de1d750..1d8df39d0 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -1,45 +1,53 @@ &SLAYER_INPUT - ! Default values taken from R. Fitzpatrick 'High Field' case in "Tearing Mode Dynamics in Tokamak Plasmas", 2023 input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table - infile='' ! Path to ascii table of profile quantities read when using input_flag - ncfile='' ! Path to netCDF file of STRIDE outputs + infile='' ! Path to ascii table of profile quantities read when using input_flag + ncfile='' ! Path to netCDF file of STRIDE outputs params_flag=f ! calculates normalized parameters from profile quantities + ! >>> + ! >>> Input rational surface quantities + ! >>> mm=2 ! poloidal mode number nn=1 ! toroidal mode number - n_e=5.10E+020 ! electron density [m^-3] - t_e=7000.0 ! electron temperature [eV] - t_i=7000.0 ! ion temperature [eV] - sval=1.34 ! magnetic shear at the layer - bt=12.0 ! toroidal field [T] - rs=0.53 ! minor radius of resonant surface [m] - R0=3.2 ! major radius of magnetic axis [m] - omega=5.45E+03 ! ExB frequency [rad/s] + n_e=5.50E+19 ! electron density [m^-3] + t_e=1000.0 ! electron temperature [eV] + t_i=1000.0 ! ion temperature [eV] + sval=1.5 ! magnetic shear at the layer + bt=2.0 ! toroidal field [T] + rs=0.5 ! minor radius of resonant surface [m] + R0=1.67 ! major radius of magnetic axis [m] + omega=5.00E+03 ! ExB frequency [Hz] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface - mu_i=2.0 ! ion mass ratio to proton ?? + mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma zeff=2.0 ! plasma Z_effective - inpr=500.0 ! Prantdl number - inpr_prof=1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0 ! Prandtl number profile, set < 0 to only use inpr instead - inpe=0.0 ! Electron viscosity - inQ=1.5 ! normalized ExB frequency - inQ_e=2.0 ! normalized electron diamagnetic frequency - inQ_i=-2.0 ! normalized ion diamagnetic frequency - inc_beta=0.128 ! dimensionless measure of the plasma pressure - inds=2.26 ! normalized ion sound radius. NOTE: set inds = 0 for internal D_norm caltulation - intau=1.0 ! ion temperature divided by electron temperature - Q0=1.5 ! unnecessary placeholder variable for inQ? - delta_n_p=(5.0,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). - ingam=(0.1,0.01) ! input Delta', OR delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). + dr_val=-0.1 ! GGJ resistive interchange criterion D_R + chi_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface perpendicular ion momentum diffusivity OR perpendicular energy diffusivity profile + ! >>> + ! >>> Input normalized layer parameters. If read_eq=f, each will individually override internal calcuation using above inputs + ! >>> + inpr=0.0 ! Prantdl number. Set /= 0.0 to override internal calculation + inpe=0.0 ! electron viscosity + inQ=1.0 ! normalized ExB frequency. TO DO: update for mode rotation frequency calculation! + inQ_e=0.0 ! normalized electron diamagnetic frequency. Set /= 0.0 to override internal calculation + inQ_i=0.0 ! normalized ion diamagnetic frequency. Set /= 0.0 to override internal calculation + inc_beta=0.0 ! dimensionless measure of the plasma pressure. Set /= 0.0 to override internal calculation + inds=0.0 ! normalized ion sound radius, or normalized ion skin depth. Set /= 0.0 to override internal calculation + intau=1.0 ! ratio of ion to electron temperature + Q0=1.0 ! unnecessary placeholder variable for inQ? + delta_prime=(0.0,0.0) ! input Delta' or (Delta' - Delta_crit) for growth rate calculation, set /= 0.0 to override internal calculation + delta_n_p=(0.01,0.01) ! delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). + ingamma=(0.0,0.0) ! input (Re(Q),Im(Q)) to calculate inner layer Delta. Set /= 0.0 to override internal root finding / &SLAYER_CONTROL inum=400 ! resolution to find error field thresholds. jnum=100 ! resolution for 2d scan along with Q,omega. - knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=300 ! resolution for stability scan along Re(Q) axis - ImQ_num=300 ! resolution for stability scan along Im(Q) axis - scan_radius=3 ! stability scan width in Q + knum=100 ! resolution for 2d scan along with the other. + Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes + scan_radius=2.0 ! stability scan width for Re(Q),Im(Q) scan + read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 + fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space QPescan_flag=f ! scan (Q,Pe) space for delta and torque. @@ -59,14 +67,11 @@ ascii_flag=f ! writes results to ascii files bin_flag=f ! writes results to binary files netcdf_flag=f ! writes results to netcdf files + est_gamma_flag=t ! Calculate and output growth rate estimate + match_gamma_flag=t ! Find Delta_hat = Delta_prime match to solve for growth rate stability_flag=f ! calculate delta dependence on complex Q - lar_gamma_eq_flag=f ! Calculate cylindrical growthrates for each rational surface of input equilibrium - lar_gamma_flag=f ! Calculate cylindrical growthrate for namelist parameters - fitz_gamma_flag=f ! Calculate Fitzpatrick layer model - stabscan_eq_flag=f ! Generate Re(Q),Im(Q) scans for each rational surface of input equilibrium - stabscan_flag=f ! Generate Re(Q),Im(Q) scan for namelist parameters + stabscan_flag=f ! Generate Re(Q),Im(Q) scan and output as ASCII br_th_flag=f ! Calculate br_th - compress_deltas=f ! Only output essential growth rate grid points bal_flag=f ! calculate the resonant field penetration threshold from torque balance / diff --git a/slayer/delta.f b/slayer/delta.f index 1989a5c62..cd29ead93 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -125,19 +125,9 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - Q=inQ - !IF(present(iinQ)) Q=inQ+ifac*iinQ - Q_e=inQ_e - Q_i=inQ_i - pr=inpr - !pe=inpe - c_beta=inc_beta - !ds=inds - tau=intau - - IF ((layfac>0).AND.(ABS(Q-Q_e)0).AND.(ABS(Q-Q_e) (pr**(1.0/6.0))) THEN + IF (D_norm > (P_perp**(1.0/6.0))) THEN ak = -(g_tmp + ifac*Q_e) - bk = pr/(2.0*(D_beta_norm**2.0)) + bk = P_perp/(2.0*(D_norm**2.0)) - ck_1 = 2.0*(g_tmp + ifac*Q_i)/pr - ck_2 = (pr + (g_tmp + - $ ifac*Q_i)*(D_beta_norm**2.0))/(2.0*pr*(D_beta_norm**2.0)) - ck = (pr/(2.0*(D_beta_norm**2.0)))*(1 + ck_1 - ck_2) + ck_1 = 2.0*(g_tmp + ifac*Q_i)/P_perp + ck_2 = (P_perp + (g_tmp + + $ ifac*Q_i)*(D_norm**2.0))/(2.0*P_perp*(D_norm**2.0)) + ck = (P_perp/(2.0*(D_norm**2.0)))*(1 + ck_1 - ck_2) xk = (ck - SQRT(bk)*(1 - $ SQRT(bk)*ak))/(2.0*SQRT(bk)) @@ -331,7 +310,7 @@ FUNCTION riccati_f(tmp_g,inQ_e,inQ_i,inpr,inD_beta_norm, W_bound = xk - SQRT(bk)*my_p ELSE ak = -(g_tmp + ifac*Q_e) - bk = pr + bk = P_perp ck = -ifac*(Q_e - Q_i) + (g_tmp + ifac*Q_i) xk = (ak*bk - ck)/(2.0*SQRT(bk)) @@ -354,7 +333,8 @@ FUNCTION riccati_f(tmp_g,inQ_e,inQ_i,inpr,inD_beta_norm, istep=istep+1 CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) - WRITE(bin_unit)REAL(my_p,4),REAL(REAL(W),4),REAL(AIMAG(W),4) + WRITE(bin_unit)REAL(my_p,4),REAL(REAL(W),4), + $ REAL(AIMAG(W),4) WRITE(out2_unit,'(1x,3(es17.8e3))')my_p,REAL(W),AIMAG(W) ENDDO CLOSE(bin_unit) @@ -414,10 +394,10 @@ SUBROUTINE w_der_f(neq,my_p,W,dWdp) fA_prime = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + $ ifac*Q_e + (my_p**2.0)) fB = g_tmp*(g_tmp + ifac*Q_i) + 2.0*(g_tmp + - $ ifac*Q_i)*pr*(my_p**2.0) + (pr**2.0)*(my_p**4.0) - fC = g_tmp + ifac*Q_e + ( pr + (g_tmp + - $ ifac*Q_i)*(D_beta_norm**2.0))*(my_p**2.0) + - $ 2.0*pr*(D_beta_norm**2.0)*(my_p**4.0) + $ ifac*Q_i)*P_perp*(my_p**2.0) + (P_perp**2.0)*(my_p**4.0) + fC = g_tmp + ifac*Q_e + ( P_perp + (g_tmp + + $ ifac*Q_i)*(D_norm**2.0))*(my_p**2.0) + + $ 2.0*P_perp*(D_norm**2.0)*(my_p**4.0) dWdp(1) = -(fA_prime/my_p)*W(1) - (W(1)**2.0)/my_p + $ (fB/(fA*fC))*(my_p**3.0) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 7d6b047e9..7d5e62a73 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -46,7 +46,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, REAL(r8) :: inQ,inQ_e,inQ_i,inpe,inc_beta,inds,intau,inlu REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, - $ lbeta,tau_i,tau_h,tau_r,tau_v + $ lbeta,tau_i,tau_h,tau_v REAL(r8) :: inQ_min,inQ_max,Q_sol REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal @@ -99,12 +99,12 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - ! note Q depends on Qconv even if omega is fixed. + ! note Q depends on Qconv even IF omega is fixed. Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i - ! This is the most critical parameter + ! This is the most critical PARAMETER ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 @@ -157,7 +157,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, ! Write torque balance curves to file for diagnostic purposes IF(ascii_flag)THEN OPEN(UNIT=out_unit,FILE="gpec_slayer_torque_balance_m"// - $ TRIM(sm)//"_n"//TRIM(sn)//".out", + $ TRIM(sm)//"_n"//TRIM(sn)//".OUT", $ STATUS="UNKNOWN") WRITE(out_unit,'(1x,5(a17))') "inQ","RE(delta)", $ "IM(delta)","jxb","bal" @@ -168,7 +168,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, CLOSE(out_unit) ENDIF - ! Identify the threshold from the maximum of the balance parameter + ! Identify the threshold from the maximum of the balance PARAMETER index=MAXLOC(bal) Q_sol=inQs(index(1)) omega_sol=inQs(index(1))/Qconv @@ -181,52 +181,36 @@ END SUBROUTINE gpec_slayer c Subprogram 3. scan_grid c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, - $ fitz_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,lu_arr,delta_arr, - $ lar_gamma_arr,results) + SUBROUTINE output_gamma(est_gamma_flag,qval_arr, + $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, + $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, + $ im_trace) ! Declarations (include necessary type declarations from original code) - LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag, - $ fitz_gamma_flag - - INTEGER, INTENT(IN), DIMENSION(:), ALLOCATABLE :: qval_arr - REAL(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: omegas_arr, - $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,inpr_arr,ind_beta_arr, - $ D_beta_norm_arr,lu_arr - - COMPLEX(r8), INTENT(IN), DIMENSION(:), ALLOCATABLE :: dels_db_arr, - $ lar_gamma_arr,delta_arr - - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs - !TYPE(result_type) :: results(8) - TYPE(result_type), INTENT(IN) :: results(8) - - REAL(r8) :: br_th = 0 - - WRITE(*,*)"Successfully entered output_lar_gamma()" - - inQs = (/0.0/) - iinQs = (/0.0/) - - CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag, - $ stabscan_flag,br_th_flag, - $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, - $ ind_beta_arr, - $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) - - END SUBROUTINE output_lar_gamma + LOGICAL, INTENT(IN) :: est_gamma_flag + INTEGER, INTENT(IN), DIMENSION(:) :: qval_arr + REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, + $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, + $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, + $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace + COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, + $ gamma_sol_arr,gamma_est_arr + + WRITE(*,*)"Successfully entered output_gamma()" + + CALL slayer_netcdf_out(SIZE(qval_arr),est_gamma_flag, + $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, + $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, + $ im_trace) + + END SUBROUTINE output_gamma c----------------------------------------------------------------------- c Subprogram 2. growthrate_scan -c Set up and iterate stability scans if no match is found +c Set up and iterate stability scans IF no match is found c----------------------------------------------------------------------- SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, @@ -341,7 +325,7 @@ SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, DO j = 1, ncoarse inQ_coarse = -scan_radius + (i - 1) * inQ_step iinQ_coarse = -scan_radius + (j - 1) * iinQ_step - ! Evaluate riccati function + ! Evaluate riccati FUNCTION delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, $ inds,intau,inpe,iinQ=iinQ_coarse) delta_real = REAL(delta)*(my_lu**(1.0/3.0)) ! Critical normalization @@ -371,7 +355,7 @@ SUBROUTINE shrink_array(arr, new_size) END SUBROUTINE shrink_array c----------------------------------------------------------------------- c Subprogram 5. grow_array -c Increase scan array size if necessary +c Increase scan array size IF necessary c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) @@ -384,26 +368,28 @@ SUBROUTINE grow_array(arr, old_size, new_size) END SUBROUTINE grow_array c c -c - subroutine NewtonRoot(g_r, g_i, verbose) - REAL(r8), intent(inout) :: g_r, g_i - integer, intent(in) :: verbose +c Adapted from + SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(INOUT) :: g_r, g_i + INTEGER, INTENT(IN) :: verbose REAL(r8) :: F1, F2, J11, J12, J21, J22, det, iJ11, iJ12 REAL(r8) :: iJ21, iJ22, dx1, dx2, dx, f, g1, g2, lambda, $ Residual - integer :: iter + INTEGER :: iter - REAL(r8), parameter :: Eps = 1.0e-12 ! Tolerance parameter - REAL(r8), parameter :: Smin = 1.0e-07 ! Min step size - REAL(r8), parameter :: Smax = 0.1 ! Max step size - integer, parameter :: MaxIter = 100 ! Maximum iterations + REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER + REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size + REAL(r8), PARAMETER :: Smax = 0.1 ! Max step size + INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations iter = 0 - do - call NewtonFunction(g_r, g_i, F1, F2) + DO + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - call NewtonJacobian(g_r, g_i, J11, J12, J21, J22) + CALL newton_jacobian(g_r, g_i, J11, J12, J21, J22, + $ fitz_flag) det = J11 * J22 - J12 * J21 @@ -422,187 +408,206 @@ subroutine NewtonRoot(g_r, g_i, verbose) g1 = F1*J11 + F2*J21 g2 = F1*J12 + F2*J22 - call NewtonBackTrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda) + CALL newton_backtrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda, + $ fitz_flag) - call NewtonFunction(g_r, g_i, F1, F2) + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) Residual = sqrt(F1*F1 + F2*F2) - if (verbose .ne. 0) then - write(*, '("x = (", ES10.3, ", ", ES10.3, ") F = (", - & ES10.3, ", ", ES10.3, ") Residual = ", ES10.3, - & " lambda = ", ES10.3, " dx = ", ES10.3)') - & g_r, g_i, F1, F2, Residual, lambda, dx - endif + n_trace = n_trace + 1 + + IF (n_trace < 100) THEN + re_trace(n_trace) = g_r + im_trace(n_trace) = g_i + END IF + + IF (verbose .ne. 0) THEN + WRITE(*, '(" Q step = (", ES10.3, ", ", ES10.3,")" )') + $ g_r, g_i + ENDIF iter = iter + 1 - if (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit - enddo + IF (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit + ENDDO - end subroutine NewtonRoot + END SUBROUTINE newton_root -!----------------------------------------------------------------------- -! Function to backtrack along Newton step in order to minimize f = (F1*F1 + F2*F2) /2 -! -! Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies in C (Cambridge, 1992), Sect. 9.7 -!----------------------------------------------------------------------- - subroutine NewtonBackTrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, - & lambda) - REAL(r8), intent(inout) :: g_r, g_i, dx, lambda - REAL(r8), intent(inout) :: dx1, dx2, f, g1, g2 +c----------------------------------------------------------------------- +c Function to backtrack along Newton step IN order to minimize f = (F1*F1 + F2*F2) /2 +c Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies IN C (Cambridge, 1992), Sect. 9.7 +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, + $ lambda, fitz_flag) + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(INOUT) :: g_r, g_i, dx, lambda + REAL(r8), INTENT(INOUT) :: dx1, dx2, f, g1, g2 REAL(r8) :: x1old, x2old, dxold, fold, slope, F1, F2 REAL(r8) :: tmplam, rhs1, rhs2, a, b, disc, lambd2, mf2 - integer :: i + INTEGER :: i - REAL(r8), parameter :: Smin = 1.0d-10 ! Min step size - REAL(r8), parameter :: Smax = 1.0d0 ! Max step size - REAL(r8), parameter :: alpha = 1.0d-4 ! Line search parameter - integer, parameter :: Maxiter = 100 ! Maximum iterations + REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size + REAL(r8), PARAMETER :: Smax = 1.0d0 ! Max step size + REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER + INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations x1old = g_r x2old = g_i dxold = dx fold = f - if (dxold > Smax) then + IF (dxold > Smax) THEN dx1 = dx1 * Smax / dxold dx2 = dx2 * Smax / dxold dxold = Smax - endif + ENDIF slope = g1*dx1 + g2*dx2 - if (slope >= 0.0d0) then - write(*, *) "NewtonBackTrack: Error - roundoff problem" - endif + IF (slope >= 0.0d0) THEN + WRITE(*,*) "NewtonBackTrack: Error - roundoff problem" + ENDIF lambda = 1.0d0 - do i = 0, Maxiter + DO i = 0, Maxiter g_r = x1old + lambda * dx1 g_i = x2old + lambda * dx2 - call NewtonFunction(g_r, g_i, F1, F2) + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) f = 0.5 * (F1*F1 + F2*F2) - if (f <= fold + alpha * lambda * slope .or. - & lambda * dxold < Smin) then + IF (f <= fold + alpha * lambda * slope .or. + $ lambda * dxold < Smin) THEN dx = lambda * dxold - return - else - if (lambda == 1.0d0) then + RETURN + ELSE + IF (lambda == 1.0d0) THEN tmplam = -slope / 2.0d0 / (f - fold - slope) - else + ELSE rhs1 = f - fold - lambda * slope rhs2 = mf2 - fold - lambd2 * slope a = (rhs1/lambda/lambda - rhs2/lambd2/lambd2) - & / (lambda - lambd2) + $ / (lambda - lambd2) b = (-lambd2 * rhs1/lambda/lambda + lambda * - & rhs2/lambd2/lambd2) / (lambda - lambd2) + $ rhs2/lambd2/lambd2) / (lambda - lambd2) - if (a == 0.0d0) then + IF (a == 0.0d0) THEN tmplam = -slope / 2.0d0 / b - else + ELSE disc = b*b - 3.0d0 * a * slope - if (disc < 0.0d0) then + IF (disc < 0.0d0) THEN tmplam = 0.5d0 * lambda - else if (b <= 0.0d0) then + ELSE IF (b <= 0.0d0) THEN tmplam = (-b + sqrt(disc)) / 3.0d0 / a - else + ELSE tmplam = -slope / (b + sqrt(disc)) - endif - endif + ENDIF + ENDIF - if (tmplam > 0.5d0 * lambda) then + IF (tmplam > 0.5d0 * lambda) THEN tmplam = 0.5d0 * lambda - endif - endif - endif + ENDIF + ENDIF + ENDIF lambd2 = lambda mf2 = f lambda = max(tmplam, 0.1d0*lambda) - enddo + ENDDO dx = lambda * dxold - end subroutine NewtonBackTrack - -!----------------------------------------------------------------------- -! Function to calculate Jacobian matrix for Newton-Raphson root finding -!----------------------------------------------------------------------- - subroutine NewtonJacobian(g_r, g_i, J11, J12, J21, J22) - REAL(r8), intent(in) :: g_r, g_i - REAL(r8), intent(out) :: J11, J12, J21, J22 + END SUBROUTINE newton_backtrack +c----------------------------------------------------------------------- +c Function to calculate Jacobian matrix for Newton-Raphson root finding +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_jacobian(g_r, g_i, J11, J12, J21, J22, + $ fitz_flag) + REAL(r8), INTENT(IN) :: g_r, g_i + LOGICAL, INTENT(IN) :: fitz_flag + + REAL(r8), INTENT(OUT) :: J11, J12, J21, J22 REAL(r8) :: F1m, F2m, F1p, F2p - REAL(r8), parameter :: dS = 1.0e-06 ! Step size for derivatives + REAL(r8), PARAMETER :: dS = 1.0e-06 ! Step size for derivatives - call NewtonFunction(g_r - dS, g_i, F1m, F2m) - call NewtonFunction(g_r + dS, g_i, F1p, F2p) + CALL newton_function(g_r - dS, g_i,F1m,F2m,fitz_flag) + CALL newton_function(g_r + dS, g_i,F1p,F2p,fitz_flag) J11 = (F1p - F1m) / 2.0d0 / dS J21 = (F2p - F2m) / 2.0d0 / dS - call NewtonFunction(g_r, g_i - dS, F1m, F2m) - call NewtonFunction(g_r, g_i + dS, F1p, F2p) + CALL newton_function(g_r, g_i - dS,F1m,F2m,fitz_flag) + CALL newton_function(g_r, g_i + dS,F1p,F2p,fitz_flag) J12 = (F1p - F1m) / 2.0d0 / dS J22 = (F2p - F2m) / 2.0d0 / dS - end subroutine NewtonJacobian + END SUBROUTINE newton_jacobian -!----------------------------------------------------------------------- -! Function to return maximum of two values -!----------------------------------------------------------------------- - function Fmax(f1, f2) result(res) - double precision, intent(in) :: f1, f2 - double precision :: res +c----------------------------------------------------------------------- +c Function to RETURN maximum of two values +c Adapted from +c----------------------------------------------------------------------- + FUNCTION Fmax(f1, f2) result(res) + REAL(r8), INTENT(IN) :: f1, f2 + REAL(r8) :: res - if (f1 > f2) then + IF (f1 > f2) THEN res = f1 - else + ELSE res = f2 - endif + ENDIF - end function Fmax + END FUNCTION Fmax -!----------------------------------------------------------------------- -! Function to return minimum of two values -!----------------------------------------------------------------------- - function Fmin(f1, f2) result(res) - REAL(r8), intent(in) :: f1, f2 +c----------------------------------------------------------------------- +c Function to RETURN minimum of two values +c Adapted from +c----------------------------------------------------------------------- + FUNCTION Fmin(f1, f2) result(res) + REAL(r8), INTENT(IN) :: f1, f2 REAL(r8) :: res - if (f1 < f2) then + IF (f1 < f2) THEN res = f1 - else + ELSE res = f2 - endif - - end function Fmin + ENDIF -!----------------------------------------------------------------------- -! Function to calculate target functions for Newton-Raphson root finding -!----------------------------------------------------------------------- - subroutine NewtonFunction(g_r, g_i, F1, F2) - REAL(r8), intent(in) :: g_r, g_i - REAL(r8), intent(out) :: F1, F2 + END FUNCTION Fmin - ! These would be module-level variables in the original code +c----------------------------------------------------------------------- +c Function to calculate target functions for Newton-Raphson root finding +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_function(g_r,g_i,F1,F2,fitz_flag) + REAL(r8), INTENT(IN) :: g_r,g_i + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(OUT) :: F1, F2 + COMPLEX(r8) :: Deltas - REAL(r8) :: Delta - - g_tmp = CMPLX(g_r,g_i) - Deltas=riccati_f(g_tmp,Q_e,Q_i,pr,D_beta_norm,tau) - - F1 = REAL(Deltas) - deltaprim - F2 = dimag(Deltas) + + IF (fitz_flag) THEN ! use Fitzpatrick formalism + g_tmp = CMPLX(g_r,g_i) + Deltas=riccati_f(g_tmp) + ELSE ! use J.K. Park formalism + g_tmp = CMPLX(g_i,g_r) + Deltas=riccati(g_i,Q_e,Q_i,P_perp, + $ c_beta,D_norm,tau,pe, + $ iinQ=g_r) + END IF + + F1 = REAL(Deltas) - delta_eff + F2 = AIMAG(Deltas) - end subroutine NewtonFunction + END SUBROUTINE newton_function END MODULE gslayer_mod diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index dfa924f9f..eb8b3e565 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -20,16 +20,16 @@ MODULE layerinputs_mod c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,shear, - $ r_o,my_bt0,my_psio,mpsi,nn,resm) + $ r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: - $ Re_dp_diagonal,Im_dp_diagonal + $ Re_dp_diagonal,Im_dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, - $ psi_n_rational, shear + $ psi_n_rational, shear REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, - $ my_psio,mpsi + $ my_psio,mpsi,dr_vals INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm INTEGER, INTENT(OUT) :: msing @@ -38,12 +38,12 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Internal Variables INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, - $ msing_id,nn_id,resm_id ! Explicit kind for NetCDF variables + $ msing_id,nn_id,resm_id,drr_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, - $ msing_len,nn_len ! Attribute lengths + $ msing_len,nn_len,dr_len ! Attribute lengths ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) @@ -61,7 +61,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Allocate Arrays (based on dimension) ALLOCATE(Re_dp_diagonal(msing),q_rational(msing), $ psi_n_rational(msing),shear(msing), - $ resm(msing),Im_dp_diagonal(msing)) + $ resm(msing),Im_dp_diagonal(msing),dr_vals(msing)) ALLOCATE(delta_prime(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) @@ -76,11 +76,11 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) CALL sl_check(stat) - bt0_id=0 !!!!! THIS COULD BE A PROBLEM - nn_id=0 - mpsi_id=0 - psio_id=0 - ro_id=0 + !bt0_id=0 !!!!! THIS COULD BE A PROBLEM + !nn_id=0 + !mpsi_id=0 + !psio_id=0 + !ro_id=0 ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), $ my_psio(INT(psio_len)), @@ -97,6 +97,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, CALL sl_check(stat) stat = nf90_inq_varid(ncid, "resm", resm_id) CALL sl_check(stat) + stat = nf90_inq_varid(ncid, "dr_rational", drr_id) + CALL sl_check(stat) ! Get attributes stat = nf90_get_att(ncid, ro_id, "ro", r_o) CALL sl_check(stat) @@ -121,6 +123,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, CALL sl_check(stat) stat = nf90_get_var(ncid, resm_id, resm) CALL sl_check(stat) + stat = nf90_get_var(ncid, drr_id, dr_vals) + CALL sl_check(stat) ! Extract Diagonal, with 3rd index signifying REAL part DO i = 1, msing @@ -224,21 +228,19 @@ END FUNCTION issurfint c subprogram 3. build_inputs. c build input arrays for SLAYER c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, - $ qval_arr,psi_n_rational,inQ_arr,inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, - $ D_beta_norm_arr,intau_arr,Q0_arr,inpr_arr, - $ inpe_arr,omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr) + SUBROUTINE build_inputs(infile,ncfile,chi_prof, + $ qval_arr,psi_n_rational,lu_arr,Qconv_arr,Q_arr, + $ Q_e_arr,Q_i_arr,c_beta_arr,d_beta_arr, + $ D_norm_arr,tau_arr,P_perp_arr, + $ omegas_arr,gammafac_arr,Re_deltaprime_arr, + $ Im_deltaprime_arr,delta_crit_arr) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- ! Inputs CHARACTER(512), INTENT(IN) :: infile,ncfile ! Internals - REAL(r8), DIMENSION(8), INTENT(IN) :: inpr_prof - REAL(r8), INTENT(IN) :: inpe - LOGICAL, INTENT(IN) :: Pe_flag + REAL(r8), DIMENSION(8), INTENT(IN) :: chi_prof LOGICAL :: firstsurf REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf,ising INTEGER :: zi, zimp, mi, mimp @@ -251,20 +253,25 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0 - REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_r,tau_h, - $ rho,tau_v,inpr,Qconv,lbeta,qintb,gammafac - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: inQ_arr, - $ inQ_e_arr,psi_n_rational,D_beta_norm_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr,ind_beta_arr, - $ intau_arr,Q0_arr,inpr_arr,inpe_arr,omegas_arr, - $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr + REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_h, + $ rho,tau_v,chi,Qconv,lbeta,qintb,gammafac + REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, + $ sigma_par_2,sigma_par,tau_perp,Wd,vte, + $ dr_val,chi_par_smfp,chi_par_lmfp,chi_par + INTEGER :: wit + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: Q_arr, + $ Q_e_arr,psi_n_rational,D_norm_arr,P_perp_arr, + $ Q_i_arr,c_beta_arr,d_beta_arr, + $ tau_arr,omegas_arr,lu_arr,Qconv_arr, + $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr, + $ delta_crit_arr INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor - REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, - $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal + REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal,dr_arr, + $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, + $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal,dr_vals REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, $ ti_arr,zeff_arr,bt_arr,rs_arr,R0_arr,mu_i_arr INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm,nns_arr @@ -279,7 +286,7 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile,msing,Re_dp_diagonal, $ Im_dp_diagonal,q_rational,psi_n_rational, - $ shear,r_o,my_bt0,my_psio,mpsi_arr,nn,resm) + $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing WRITE(*,*)"Re_dp_diagonal=",Re_dp_diagonal WRITE(*,*)"Im_dp_diagonal=",Im_dp_diagonal @@ -295,17 +302,18 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, mpsi = INT(mpsi_arr(1)) mthsurf = 512 ! Hardcoded, but this is a default value - ALLOCATE(qval_arr(msing),inQ_arr(msing),inQ_e_arr(msing), - $ inQ_i_arr(msing), - $ inc_beta_arr(msing),inds_arr(msing),ind_beta_arr(msing), - $ intau_arr(msing),Q0_arr(msing),inpr_arr(msing), - $ inpe_arr(msing),omegas_arr(msing),omegas_e_arr(msing), + ALLOCATE(qval_arr(msing),Q_arr(msing),Q_e_arr(msing), + $ Q_i_arr(msing),lu_arr(msing),Qconv_arr(msing), + $ c_beta_arr(msing),d_beta_arr(msing), + $ tau_arr(msing), + $ omegas_arr(msing),omegas_e_arr(msing), $ omegas_i_arr(msing),gammafac_arr(msing), $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), - $ D_beta_norm_arr(msing)) + $ D_norm_arr(msing),P_perp_arr(msing), + $ delta_crit_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), - $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing)) + $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing),dr_arr(msing)) ALLOCATE(jacs(0:mthsurf),delpsi(0:mthsurf), $ rsurf(0:mthsurf),asurf(0:mthsurf)) @@ -360,22 +368,16 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, zeff = kin%f(9) omega = kin%f(5) my_qval = q_rational(ising)!sq%f(4) - my_sval = shear(ising) ! SHEAR SO MUCH SMALLER THAN BEFORE???? 500 puts it on the root + my_sval = shear(ising) my_bt = my_bt0(1) my_rs = a_surf R_0 = r_o(1) mu_i = 2.0 + dr_val = dr_vals(ising) eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - inpr = inpr_prof(ising) - - ! Check whether to include classical electron viscosity - IF (Pe_flag) THEN - my_inpe=0.0165*inpr - ELSE - my_inpe=inpe - ENDIF + chi = chi_prof(ising) ne_arr(ising) = n_e te_arr(ising) = t_e @@ -392,29 +394,44 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, mrs = real(mms,4) nrs = real(nns,4) - nns_arr = nn(1) + nns_arr(ising) = nn(1) - tau= t_i/t_e ! ratio of ion to electron temperature + lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) + + ! mu_i: ion mass ratio to proton + tau= t_i/t_e ! ratio of ion to electron temperature tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. - rho=(mu_i*m_p)*n_e ! mass density + eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) + rho=(mu_i*m_p)*n_e ! mass density + + tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5)* + $ (eps0**2.0)*(m_e**0.5)*(t_e**1.5) + tau_ee_denom = lnLamb*(chag**2.5)*n_e + tau_ee = tau_ee_num / tau_ee_denom - b_l=(nrs/mrs)*nrs*my_sval*my_bt/R_0 ! characteristic magnetic field + sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) / + $ (Zeff*(SQRT(2.0) + Zeff)) + sigma_par_2 = (n_e * (chag**2.0) * tau_ee) / m_e + sigma_par = sigma_par_1*sigma_par_2 - v_a=b_l/(mu0*rho)**0.5 ! alfven velocity, B_L IS BROKEN + b_l=(nr/mr)*my_rs*my_sval*my_bt/R_0 ! characteristic magnetic field + v_a=b_l/(mu0*rho)**0.5 ! alfven velocity rho_s=1.02e-4*(mu_i*t_e)**0.5/my_bt ! ion Lamour by elec. Temp. d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth - tau_h=R_0*(mu0*rho)**0.5/(nns*my_sval*my_bt) ! alfven time across surface - tau_r=mu0*my_rs**2.0/eta ! resistive time scale - tau_v=tau_r/inpr ! rho*rs**2.0/visc ! viscous time scale - - ! this one must be anomalous. calculated back from pr. - visc= rho*my_rs**2.0/tau_v - - lu=tau_r/tau_h ! Lundquist number + tau_h=R_0*(mu0*rho)**0.5/(nr*my_sval*my_bt) ! alfven time across surface + tau_r=mu0*(my_rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale + IF (ABS(chi) > 0.0) THEN + tau_perp = ( my_rs**2.0 ) / chi + ELSE + tau_perp = 0.0 + END IF + + lu=tau_r/tau_h ! Lundquist number Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - + tauk = Qconv + ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega Q_e=-Qconv*omega_e @@ -426,33 +443,57 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/my_bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 + IF (ABS(tau_perp) > 0.0) THEN + P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number + ELSE + P_perp = 0.0 + END IF ! this is using Fitzpatrick's tau', we need tau eventually d_beta = c_beta*d_i - D_beta_norm = (d_beta/my_rs)*(lu**(1.0/3.0))*(tau/(1+ - $ tau))**(0.5) + D_norm = (d_beta/my_rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) + + ! Calculate Delta_crit + IF (ABS(dr_val) > 0.0) THEN + vte = SQRT((2.0*(t_e*chag))/m_e) + chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ + $ (1.0+0.2535*Zeff) + + Wd = 0.1 + DO wit = 1,10 + chi_par_lmfp = (2.0*R_0*vte)/ + $ (SQRT(pi)*nr*my_sval*Wd) + chi_par = (chi_par_smfp*chi_par_lmfp)/ + $ (chi_par_smfp+chi_par_lmfp) + Wd = SQRT(8.0)*((chi/chi_par)**0.25)* + $ (1.0/SQRT((my_rs/R_0)*my_sval*nr)) + END DO + delta_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd + ELSE + delta_crit = 0.0 + END IF - delta_n=lu**(1.0/3.0)/my_rs ! norm factor for delta primes +!!!!!!!!!!! gammafac = (my_rs*Re_dp_diagonal(ising))/tau_r ! scalar to convert thickness into growth rate qval_arr(ising) = INT(my_qval) - inQ_arr(ising)=REAL(Q) - inQ_e_arr(ising)=Q_e - inQ_i_arr(ising)=Q_i - inc_beta_arr(ising)=c_beta - inds_arr(ising)=ds - ind_beta_arr(ising)=d_beta - D_beta_norm_arr(ising)=D_beta_norm - intau_arr(ising)=tau - Q0_arr(ising)=Q - inpr_arr(ising) = inpr - inpe_arr(ising) = my_inpe + lu_arr(ising)=lu + Q_arr(ising)=REAL(Q) + Q_e_arr(ising)=Q_e + Q_i_arr(ising)=Q_i + c_beta_arr(ising)=c_beta + d_beta_arr(ising)=d_beta + D_norm_arr(ising)=D_norm + tau_arr(ising)=tau omegas_arr(ising) = omega omegas_e_arr(ising) = omega_e omegas_i_arr(ising) = omega_i gammafac_arr(ising) = gammafac Re_deltaprime_arr(ising) = Re_dp_diagonal(ising) Im_deltaprime_arr(ising) = Im_dp_diagonal(ising) + delta_crit_arr(ising) = delta_crit + P_perp_arr(ising) = P_perp + Qconv_arr(ising) = tauk ENDDO !WRITE(*,*)"msing=",msing @@ -479,12 +520,12 @@ SUBROUTINE build_inputs(infile,ncfile,inpr_prof,inpe,Pe_flag, !WRITE(*,*)"Re_deltaprime_arr=",Re_deltaprime_arr !WRITE(*,*)"Im_deltaprime_arr=",Im_deltaprime_arr !stop - CALL slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr,ni_arr, - $ ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, - $ resm,nns_arr,inc_beta_arr,inds_arr, - $ intau_arr,inpr_arr,inpe_arr,inQ_arr,omegas_arr, - $ omegas_e_arr,omegas_i_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr) + !CALL slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr,ni_arr, + !$ ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, + !$ resm,nns_arr,inc_beta_arr,inds_arr, + !$ intau_arr,inpr_arr,inpe_arr,inQ_arr,omegas_arr, + !$ omegas_e_arr,omegas_i_arr, + !$ Re_deltaprime_arr,Im_deltaprime_arr) c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- diff --git a/slayer/params.f b/slayer/params.f index c8651932e..2e2cf1138 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -8,16 +8,22 @@ MODULE params_mod c----------------------------------------------------------------------- c calculate parameters. c----------------------------------------------------------------------- - SUBROUTINE params(n_e,t_e,t_i,omega, + SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega, + REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,chi,dr_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff LOGICAL, INTENT(IN) :: params_check REAL(r8) :: rho,b_l,v_a,Qconv, - $ lbeta,tau_i,tau_h,tau_r,tau_v + $ lbeta,tau_i,tau_h,tau_v + REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, + $ sigma_par_2,sigma_par,tau_perp,Wd,vte, + $ chi_par_smfp,chi_par_lmfp,chi_par + INTEGER :: wit + + lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) ! mu_i: ion mass ratio to proton tau= t_i/t_e ! ratio of ion to electron temperature @@ -25,20 +31,37 @@ SUBROUTINE params(n_e,t_e,t_i,omega, eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) rho=(mu_i*m_p)*n_e ! mass density + tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5)* + $ (eps0**2.0)*(m_e**0.5)*(t_e**1.5) + tau_ee_denom = lnLamb*(chag**2.5)*n_e + tau_ee = tau_ee_num / tau_ee_denom + !tau_ee = 1.09e16 * (t_e/1.0e3)**1.5 / (n_e * lnLamb) + + + sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) / + $ (Zeff*(SQRT(2.0) + Zeff)) + sigma_par_2 = (n_e * (chag**2.0) * tau_ee) / m_e + sigma_par = sigma_par_1*sigma_par_2 + b_l=(nr/mr)*rs*sval*bt/R0 ! characteristic magnetic field v_a=b_l/(mu0*rho)**0.5 ! alfven velocity rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth tau_h=R0*(mu0*rho)**0.5/(nn*sval*bt) ! alfven time across surface - tau_r=mu0*rs**2.0/eta ! resistive time scale + !tau_r=mu0*rs**2.0/eta ! resistive time scale + tau_r=mu0*(rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale tau_v=tau_r/pr !rho*rs**2.0/visc ! viscous time scale - + IF (ABS(chi) > 0.0) THEN + tau_perp = ( rs**2.0 ) / chi + ELSE + tau_perp = 0.0 + END IF + ! this one must be anomalous. calculated back from pr. visc= rho*rs**2.0/tau_v lu=tau_r/tau_h ! Lundquist number -! pr=tau_r/tau_v ! Prandtl number. Only place needs viscosity. omega_e=-t_e/(bt*R0)*(1.0/l_n+1.0/l_t)*qval ! elec. diamag omega_i=t_i/(bt*R0)*(1.0/l_n+1.0/l_t)*qval ! ion diamag @@ -46,24 +69,51 @@ SUBROUTINE params(n_e,t_e,t_i,omega, ! now calculate the main 7 normalized parameters. Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - + tauk = Qconv + ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i - + ! This is the most critical parameter ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 + IF (ABS(tau_perp) > 0.0) THEN + P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number + ELSE + P_perp = 0.0 + END IF + ! this is using Fitzpatrick's tau', we need tau eventually d_beta = c_beta*d_i - D_beta_norm = (d_beta/rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) + D_norm = (d_beta/rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes + ! Calculate Delta_crit + IF (ABS(dr_val) > 0.0) THEN + vte = SQRT((2.0*(t_e*chag))/m_e) + chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ + $ (1.0+0.2535*Zeff) + + Wd = 0.1 + DO wit = 1,10 + + chi_par_lmfp = (2.0*R0*vte)/(SQRT(pi)*nr*sval*Wd) + chi_par = (chi_par_smfp*chi_par_lmfp)/ + $ (chi_par_smfp+chi_par_lmfp) + Wd = SQRT(8.0)*((chi/chi_par)**0.25)* + $ (1.0/SQRT((rs/R0)*sval*nr)) + END DO + delta_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd + ELSE + delta_crit = 0.0 + END IF + ! quick diagnostics. IF (params_check) THEN WRITE(*,*)"eta=",eta diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 74e8a9589..f3ccca6c7 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -3,20 +3,21 @@ MODULE sglobal_mod IMPLICIT NONE INTEGER :: mm,nn INTEGER :: in_unit,out_unit,out2_unit,out3_unit, - $ bin_unit,bin_2d_unit,input_unit + $ bin_unit,bin_2d_unit,input_unit,n_trace INTEGER, PARAMETER :: r8=SELECTED_REAL_KIND(13,307) REAL(r8) :: mr,nr REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, - $ d_beta,D_beta_norm,gamma_fac + $ d_beta,D_norm,P_perp,gamma_fac REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, - $ delta_n,layfac,Qconv,deltaprim, - $ g_r, g_i + $ delta_n,layfac,Qconv,lnLamb,deltaprim, + $ delta_crit,tau_r,tauk,g_r,g_i,delta_eff + REAL(r8), DIMENSION(:), ALLOCATABLE :: re_trace,im_trace COMPLEX(r8) :: Q,g_tmp REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, - $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6022e-19, - $ kval=1.3807e-23,lnLamb=17.0 + $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6021917e-19, + $ kval=1.3807e-23,eps0 = 8.8542e-12 TYPE result_type REAL(r8), ALLOCATABLE :: inQs(:), iinQs(:), diff --git a/slayer/slayer.f b/slayer/slayer.f index 8a8196082..5eca1a8f2 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -13,11 +13,8 @@ PROGRAM slayer USE sglobal_mod - !USE params_mod USE delta_mod, ONLY: riccati,riccati_del_s,riccati_out, $ parflow_flag,PeOhmOnly_flag - - ! FOR TESTING: USE gslayer_mod USE layerinputs_mod @@ -25,7 +22,7 @@ PROGRAM slayer CHARACTER(512) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,count, - $ ReQ_num,ImQ_num,n_k,scan_radius,max_points + $ Q_num,n_k,scan_radius,max_points INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -33,112 +30,99 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,stabscan_eq_flag,stabscan_flag, - $ lar_gamma_eq_flag,lar_gamma_flag,fitz_gamma_flag, - $ br_th_flag,compress_deltas - + $ params_check,stabscan_flag,read_eq,est_gamma_flag, + $ match_gamma_flag,fitz_flag,br_th_flag REAL(r8) :: n_e,t_e,t_i,omega,omega0, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,tau_r,d_b,Residual + REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, - $ tmp_gamma,ingam + $ tmp_gamma,ingamma,delta_prime REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, - $ delta_imag,Qratio + $ delta_imag,Qratio,chi INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl, - $ bal, + REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl,bal, $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQ_e_arr, - $ inQ_i_arr,inc_beta_arr,inds_arr, - $ intau_arr,inQ0_arr,inpr_arr, - $ inpe_arr,omegas_arr,inQ_arr,lu_arr, - $ psi_n_rational,ind_beta_arr,D_beta_norm_arr - REAL(r8), DIMENSION(8) :: inpr_prof - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: all_Re_deltas, - $ all_Im_deltas,all_roots - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: all_inQs - REAL(r8), DIMENSION(:,:),ALLOCATABLE :: Re_deltas,Im_deltas - + REAL(r8), DIMENSION(:), ALLOCATABLE :: Q_e_arr,Q_i_arr, + $ c_beta_arr,D_norm_arr,tau_arr,P_perp_arr, + $ omegas_arr,Q_arr,lu_arr,psi_n_rational, + $ d_beta_arr,Qconv_arr + REAL(r8), DIMENSION(8) :: chi_prof INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr - REAL(r8), DIMENSION(:), ALLOCATABLE :: + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs, $ Re_deltaprime_arr,Im_deltaprime_arr, - $ all_growthrates,all_growthrate_locs + $ gammafac_arr,delta_crit_arr REAL(r8), DIMENSION(:,:), ALLOCATABLE :: - $ js,ks,psis,jxbs,Q_sols,br_ths, - $ inQs_left,inQs_right,coarse_deltas + $ js,ks,psis,jxbs,Q_sols,br_ths REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, $ dels_db_arr,lar_gamma_arr, - $ delta_arr + $ gamma_sol_arr,gamma_est_arr COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas - TYPE(result_type) :: results(8) ! Assuming max 8 rational surfaces - - REAL(r8), DIMENSION(:), ALLOCATABLE :: gammafac_arr,growthrates, - $ growthrate_err - NAMELIST/slayer_input/input_flag,infile, - $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,omega,l_n,l_t, - $ qval,sval,bt,rs,R0,zeff,mu_i,inQ,inQ_e, - $ inQ_i,inpr,inpr_prof,inpe,inc_beta,inds, - $ intau,inlu,Q0,delta_n_p,ingam - NAMELIST/slayer_control/inum,jnum,knum,ReQ_num,ImQ_num, - $ scan_radius,QPscan_flag,QPscan2_flag, - $ QPescan_flag,QDscan2_flag,Qbscan_flag,Qscan_flag, - $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, - $ layfac,Qratio,parflow_flag,peohmonly_flag,Pe_flag + $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, + $ l_t,l_n,qval,mu_i,zeff,dr_val,chi_prof,inpr,inpe,inQ, + $ inQ_e,inQ_i,inc_beta,inds,intau,Q0,delta_prime,delta_n_p, + $ ingamma + NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_radius, + $ read_eq,fitz_flag,QPscan_flag,Qscan_flag,QPescan_flag, + $ Qbscan_flag,onscan_flag,otscan_flag,ntscan_flag, + $ nbtscan_flag,parflow_flag,peohmonly_flag,Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ stability_flag,lar_gamma_eq_flag,lar_gamma_flag, - $ fitz_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, - $ compress_deltas,bal_flag + $ est_gamma_flag,match_gamma_flag,stability_flag, + $ stabscan_flag,br_th_flag,bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- c set initial values. c----------------------------------------------------------------------- - mm=2 - nn=1 - mr = real(mm,4) - nr = real(nn,4) - n_e=1e19 - t_e=1e3 - t_i=1e3 - omega=1e4 - l_n=2e-1 - l_t=2e-1 - qval=2.0 - sval=2.0 - bt=1.0 - rs=0.5 - R0=1.0 - mu_i=2.0 - zeff=2.0 - inQ=20.0 ! Q=23.0 for DIII-D example. - inQ_e=2.0 ! Q_e=2.0 for DIII-D example. - inQ_i=-2.6 ! Q_i=-2.6 for DIII-D example. - inpr=0.5 ! 0.5 for DIII-D example. - inpr_prof=1.0 - inpe=0.1 !I added this - inc_beta=0.7 ! c_beta=0.7 for DIII-D example. - inds=6.0 ! 6.0 for DIII-D example. - intau=1.0 ! 1.0 for DIII-D example. - inlu=1e8 - Q0=4.0 - delta_n_p=(1e-2,1e-2) - ingam=(0.0,1e-2) + mm=0.0 + nn=0.0 + mr = 0.0!real(mm,4) + nr = 0.0!real(nn,4) + n_e=0.0 + t_e=0.0 + t_i=0.0 + omega=0.0 + l_n=0.0 + l_t=0.0 + qval=0.0 + sval=0.0 + bt=0.0 + rs=0.0 + R0=0.0 + mu_i=0.0 + zeff=0.0 + dr_val=0.0 + inQ=0.0 + inQ_e=0.0 + inQ_i=0.0 + inpr=0.0 + chi_prof=0.0 + inpe=0.0 + inc_beta=0.0 + inds=0.0 + intau=0.0 + inlu=0.0 + Q0=0.0 + chi=0.0 + dr_val=0.0 + gamma_fac=0.0 + delta_prime=(0.0,0.0) + delta_n_p=(0.0,0.0) + ingamma=(0.0,0.0) inum=400 ! resolution to find error field thresholds. jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. - ReQ_num=350 ! resolution for stab. scan along Re(Q) axis - ImQ_num=350 ! resolution for stab. scan along Im(Q) axis - scan_radius = 3 + Q_num=100 ! resolution for stab. scan along Re(Q) axis + scan_radius = 2.0 in_unit=1 out_unit=2 out2_unit=3 @@ -146,6 +130,10 @@ PROGRAM slayer bin_unit=5 bin_2d_unit=6 input_unit=7 + read_eq=.FALSE. + est_gamma_flag=.FALSE. + match_gamma_flag=.FALSE. + fitz_flag=.FALSE. QPscan_flag=.FALSE. ! scan (Q,P) space for delta and torque. QPescan_flag=.FALSE. ! scan (Q,Pe) space for delta and torque. Qbscan_flag=.FALSE. ! scan (Q,beta) space for delta and torque. @@ -158,7 +146,6 @@ PROGRAM slayer parflow_flag=.FALSE. PeOhmOnly_flag=.TRUE. Pe_flag=.FALSE. - Pe_flag=.FALSE. params_flag=.TRUE. input_flag=.FALSE. infile="" @@ -173,12 +160,7 @@ PROGRAM slayer bal_flag=.FALSE. stability_flag=.FALSE. stabscan_flag=.FALSE. - stabscan_eq_flag=.FALSE. - lar_gamma_flag=.FALSE. - fitz_gamma_flag=.FALSE. - lar_gamma_eq_flag=.FALSE. br_th_flag=.FALSE. - compress_deltas=.FALSE. c----------------------------------------------------------------------- c read slayer.in. c----------------------------------------------------------------------- @@ -202,7 +184,7 @@ PROGRAM slayer c calculate parameters as needed. c----------------------------------------------------------------------- IF (params_flag) THEN - CALL params(n_e,t_e,t_i,omega, + CALL params(n_e,t_e,t_i,omega,chi,dr_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -217,12 +199,14 @@ PROGRAM slayer c----------------------------------------------------------------------- c calculate basic delta, torque, balance, error fields. c----------------------------------------------------------------------- + IF (.NOT. (match_gamma_flag)) THEN delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) psi0=1.0/ABS(delta+delta_n_p) ! a.u. jxb=-AIMAG(1.0/(delta+delta_n_p)) ! a.u. WRITE(*,*)"delta=",delta WRITE(*,*)"psi0=",psi0 WRITE(*,*)"jxb=",jxb + ENDIF c----------------------------------------------------------------------- c calculate parameters as needed. c----------------------------------------------------------------------- @@ -248,7 +232,7 @@ PROGRAM slayer mr=REAL(mms(k)) nr=REAL(nns(k)) inpr=prs(k) - CALL params(n_es(k),t_es(k),t_is(k),omegas(k), + CALL params(n_es(k),t_es(k),t_is(k),omegas(k),chi,dr_val, $ l_ns(k),l_ts(k),qvals(k),svals(k),bts(k),rss(k),R0s(k), $ mu_is(k),zeffs(k),params_check) inQ=Q @@ -306,288 +290,240 @@ PROGRAM slayer c----------------------------------------------------------------------- c LAR (cylindrical) growthrates via restive layer thickness c----------------------------------------------------------------------- - IF (lar_gamma_eq_flag) THEN + IF (est_gamma_flag) THEN + WRITE(*,*)">>> Estimating growth rate" - ! propagate inpr value to inpr_prof if inpr_prof is turned off - IF (inpr_prof(1) < 0) THEN - inpr_prof = inpr - END IF + IF (read_eq) THEN - CALL build_inputs(infile,ncfile,inpr_prof, - $ inpe,Pe_flag,qval_arr,psi_n_rational, - $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, - $ inds_arr,ind_beta_arr,D_beta_norm_arr, - $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr) - - WRITE(*,*)"Safety factor values=",qval_arr - WRITE(*,*)"inQ values=",inQ_arr - WRITE(*,*)"Prantdl numbers=",inpr_arr - WRITE(*,*)"Electron viscosities=",inpe_arr - WRITE(*,*)"Omega ExB values=",omegas_arr - WRITE(*,*)"outer region real deltaprimes=",Re_deltaprime_arr - WRITE(*,*)"outer region imag deltaprimes=",Im_deltaprime_arr - WRITE(*,*)"inQ_e_arr=",inQ_e_arr - WRITE(*,*)"ind_beta_arr=",ind_beta_arr - WRITE(*,*)"D_beta_norm_arr=",D_beta_norm_arr - WRITE(*,*)"intau_arr=",intau_arr - WRITE(*,*)"gammafac_arr=",gammafac_arr + CALL build_inputs(infile,ncfile,chi_prof,qval_arr, + $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, + $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, + $ P_perp_arr,omegas_arr,gammafac_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr) - n_k = SIZE(qval_arr) + n_k = SIZE(qval_arr) + ELSE + n_k = 1 + mr = mm + nr = nn - ALLOCATE(lar_gamma_arr(n_k),dels_db_arr(n_k),delta_arr(n_k)) + CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + IF (ABS(inQ) > 0.0) THEN + Q = inQ ! NAMELIST + END IF + IF (ABS(inQ_e) > 0.0) THEN + Q_e = inQ_e ! NAMELIST + END IF + IF (ABS(inQ_i) > 0.0) THEN + Q_i = inQ_i ! NAMELIST + END IF + IF (inpr > 0.0) THEN + pr = inpr ! NAMELIST + END IF + IF (intau > 0.0) THEN + tau = intau ! NAMELIST + END IF + IF (inds > 0.0) THEN + D_norm = inds ! NAMELIST + END IF + + qval_arr = (/ qval /) + omegas_arr = (/ omega /) + Q_arr = (/ Q /) + Q_e_arr = (/ Q_e /) + Q_i_arr = (/ Q_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ REAL(delta_prime) /) + Im_deltaprime_arr = (/ AIMAG(delta_prime) /) + P_perp_arr = (/ P_perp /) + tau_arr = (/ tau /) + D_norm_arr = (/ D_norm /) + d_beta_arr = (/ d_beta /) + delta_eff = REAL(delta_prime)-delta_crit + gamma_fac = (rs*delta_eff)/tau_r + gammafac_arr = (/ gamma_fac /) + END IF + + ALLOCATE(gamma_est_arr(n_k),dels_db_arr(n_k)) DO k=1,n_k - WRITE(*,*) "Calculating growth rate on q=", qval_arr(k), - $ " rational surface" + WRITE(*,*) "Calculating growth rate estimate on q=", + $ qval_arr(k)," rational surface" - dels_db=riccati_del_s(inQ_arr(k),inQ_e_arr(k), - $ inQ_i_arr(k),inpr_arr(k),inc_beta_arr(k), - $ D_beta_norm_arr(k),intau_arr(k), - $ 5.0*D_beta_norm_arr(k)) + dels_db=riccati_del_s(Q_arr(k),Q_e_arr(k), + $ Q_i_arr(k),P_perp_arr(k),c_beta_arr(k), + $ D_norm_arr(k),tau_arr(k), + $ 5.0*D_norm_arr(k)) - del_s = dels_db * ind_beta_arr(k) - lar_gamma = gammafac_arr(k)/del_s + del_s = dels_db * d_beta_arr(k) - lar_gamma_arr(k) = lar_gamma + gamma_est_arr(k) = gammafac_arr(k)/del_s dels_db_arr(k) = dels_db + WRITE(*,*)"Growth rate estimate=", + $ REAL(gamma_est_arr(k))," [Hz]" ENDDO - WRITE(*,*)"Calling slayer_netcdf_out" - WRITE(*,*)"qval_arr=",qval_arr - WRITE(*,*)"omegas_arr=",omegas_arr - WRITE(*,*)"inQ_arr=",inQ_arr - WRITE(*,*)"inQ_e_arr=",inQ_e_arr - WRITE(*,*)"inQ_i_arr=",inQ_i_arr - WRITE(*,*)"ind_beta_arr=",ind_beta_arr - WRITE(*,*)"D_beta_norm_arr=",D_beta_norm_arr - WRITE(*,*)"inpr_arr=",inpr_arr - WRITE(*,*)"psi_n_rational=",psi_n_rational - WRITE(*,*)"lu_arr=",lu_arr - WRITE(*,*)"Re_deltaprime_arr=",Re_deltaprime_arr - WRITE(*,*)"Im_deltaprime_arr=",Im_deltaprime_arr - WRITE(*,*)"dels_db_arr=",dels_db_arr - WRITE(*,*)"lar_gamma_arr=",lar_gamma_arr - - br_th = 0.0 - - CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, - $ fitz_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr,results) - stop + IF (.NOT. (match_gamma_flag)) THEN + gamma_sol_arr = (/0./) + CALL output_gamma(est_gamma_flag,qval_arr, + $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, + $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ re_trace,im_trace) + END IF ENDIF c----------------------------------------------------------------------- c LAR (cylindrical) growthrates via restive layer thickness c----------------------------------------------------------------------- - IF (lar_gamma_flag) THEN - WRITE(*,*)"intau=",intau - WRITE(*,*)"inQ=",inQ - WRITE(*,*)"Prantdl numbers=",inpr - WRITE(*,*)"Electron viscosities=",inpe - WRITE(*,*)"inQ_e=",inQ_e - WRITE(*,*)"inds=",inds - WRITE(*,*)"inc_beta=",inc_beta - - WRITE(*,*)"Calculating LAR growth rate" - - CALL params(n_e,t_e,t_i,omega, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + IF (match_gamma_flag) THEN + WRITE(*,*)">>> Calculating asymptotically matched growth rate" + IF (read_eq) THEN - IF (inQ > 0.0) THEN - Q = inQ ! NAMELIST - END IF - IF (inQ_e > 0.0) THEN - Q_e = inQ_e ! NAMELIST - END IF - IF (inQ_i > 0.0) THEN - Q_i = inQ_i ! NAMELIST - END IF - IF (inpr > 0.0) THEN - pr = inpr ! NAMELIST - END IF - IF (intau > 0.0) THEN - tau = intau ! NAMELIST - END IF - IF (inds > 0.0) THEN - D_beta_norm = inds ! NAMELIST - END IF - - qval_arr = (/ qval /) - omegas_arr = (/ omega /) - inQ_arr = (/ inQ /) - inQ_e_arr = (/ inQ_e /) - inQ_i_arr = (/ inQ_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ REAL(delta_n_p) /) - Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) - inpr_arr = (/ inpr /) - D_beta_norm_arr = (/ D_beta_norm /) + CALL build_inputs(infile,ncfile,chi_prof,qval_arr, + $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, + $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, + $ P_perp_arr,omegas_arr,gammafac_arr, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr) - WRITE(*,*)"D_beta_norm = ",D_beta_norm - !WRITE(*,*)"inds = ",inds + n_k = SIZE(qval_arr) - !WRITE(*,*)"lar_gamma inQ = ",inQ - - dels_db=riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta, - $ D_beta_norm,intau,5.0*D_beta_norm) - - !WRITE(*,*)"dels_db() call successful" - - tau_r = layfac !!!! CRITICAL - WRITE(*,*)"tau_r = ",tau_r - WRITE(*,*)"deltaprime = ",REAL(delta_n_p) - WRITE(*,*)"rs = ",rs + ELSE + n_k = 1 - !eta = 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - !tau_r = mu0*rs**2.0/eta ! resistive time scale + ! Use namelist kinetic inputs instead of equilibrium files + CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - del_s = dels_db * d_beta - lar_gamma = (REAL(delta_n_p)/tau_r) * (rs/del_s) + ! Override desired normalized parameters + IF (ABS(inQ) > 0.0) THEN + Q = inQ ! NAMELIST + END IF + IF (ABS(inQ_e) > 0.0) THEN + Q_e = inQ_e ! NAMELIST + END IF + IF (ABS(inQ_i) > 0.0) THEN + Q_i = inQ_i ! NAMELIST + END IF + IF (inpr > 0.0) THEN + P_perp = inpr ! NAMELIST + END IF + IF (intau > 0.0) THEN + tau = intau ! NAMELIST + END IF + IF (inds > 0.0) THEN + D_norm = inds ! NAMELIST + END IF + + qval_arr = (/ qval /) + omegas_arr = (/ omega /) + Q_arr = (/ Q /) + Q_e_arr = (/ Q_e /) + Q_i_arr = (/ Q_i /) + psi_n_rational = (/ 0.0 /) + Re_deltaprime_arr = (/ REAL(delta_prime) /) + Im_deltaprime_arr = (/ AIMAG(delta_prime) /) + delta_crit_arr = (/ delta_crit /) + P_perp_arr = (/ P_perp /) + tau_arr = (/ tau /) + D_norm_arr = (/ D_norm /) + d_beta_arr = (/ d_beta /) + gammafac_arr = (/ gamma_fac /) + c_beta_arr = (/ c_beta /) + lu_arr = (/ lu /) + Qconv_arr = (/ tauk /) + END IF + + ALLOCATE(gamma_sol_arr(n_k)) - ind_beta_arr = (/ d_beta /) - dels_db_arr = (/ dels_db /) - lar_gamma_arr = (/ lar_gamma /) + DO k=1,n_k + WRITE(*,*) "Calculating growth rates on q=", + $ qval_arr(k)," rational surface" + + Q_e = Q_e_arr(k) + Q_i = Q_i_arr(k) + P_perp = P_perp_arr(k) + tau = tau_arr(k) + D_norm = D_norm_arr(k) + c_beta = c_beta_arr(k) + tauk = Qconv_arr(k) + + ! (Deltaprime - delta_crit)/S^1/3 + delta_eff = (Re_deltaprime_arr(k) - + $ delta_crit_arr(k))/(lu_arr(k)**(1.0/3.0)) + pe = 0.0 + + ALLOCATE(re_trace(100),im_trace(100)) + re_trace = 0.0 + im_trace = 0.0 + n_trace = 1 + + IF (fitz_flag) THEN + g_r = 0.0 + g_i = -Q_e + re_trace(1) = 0.0 + im_trace(1) = -Q_e + ELSE + g_i = 0.0 + g_r = -Q_e + im_trace(1) = 0.0 + re_trace(1) = -Q_e + END IF - WRITE(*,*)"dels_db=",dels_db - WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 - WRITE(*,*)"growth rate=",lar_gamma + CALL newton_root(g_r,g_i,1,fitz_flag) - br_th = 0.0 + WRITE(*,*)"Success! growth rate = ", + $ g_r/tauk," [Hz]" - CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, - $ fitz_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr,results) + CALL shrink_array(re_trace, n_trace) + CALL shrink_array(im_trace, n_trace) - stop - ENDIF -c----------------------------------------------------------------------- -c LAR (cylindrical) growthrates via restive layer thickness -c----------------------------------------------------------------------- - IF (fitz_gamma_flag) THEN - WRITE(*,*)"Calculating Fitzpatrick inner delta" + re_trace = re_trace/tauk + im_trace = im_trace/tauk - ! CALL params(n_e,t_e,t_i,omega, - !$ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + gamma_sol_arr(k) = g_r/tauk + ENDDO - IF (inQ > 0.0) THEN - Q = inQ ! NAMELIST - END IF - IF (inQ_e > 0.0) THEN - Q_e = inQ_e ! NAMELIST - END IF - IF (inQ_i > 0.0) THEN - Q_i = inQ_i ! NAMELIST - END IF - IF (inpr > 0.0) THEN - pr = inpr ! NAMELIST - END IF - IF (intau > 0.0) THEN - tau = intau ! NAMELIST - END IF - IF (inds > 0.0) THEN - D_beta_norm = inds ! NAMELIST + IF (.NOT. (est_gamma_flag)) THEN + d_beta_arr = (/ 0. /) + dels_db_arr = (/ 0. /) END IF - WRITE(*,*)"intau=",tau - WRITE(*,*)"inQ=",Q - WRITE(*,*)"inQ_e=",Q_e - WRITE(*,*)"inQ_i=",Q_i - WRITE(*,*)"Prantdl number=",pr - WRITE(*,*)"inQ_e=",inQ_e - WRITE(*,*)"D_beta_norm=",D_beta_norm - WRITE(*,*)"inc_beta=",inc_beta - - qval_arr = (/ qval /) - omegas_arr = (/ omega /) - inQ_arr = (/ inQ /) - inQ_e_arr = (/ inQ_e /) - inQ_i_arr = (/ inQ_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ 0.0 /) - Im_deltaprime_arr = (/ 0.0 /) - inpr_arr = (/ inpr /) - D_beta_norm_arr = (/ D_beta_norm /) - - ! INPUT GAMMA = delta_n_p - - deltaprim = REAL(delta_n_p) - g_tmp = ingam - WRITE(*,*)"g_tmp = ",g_tmp + IF (stabscan_flag) THEN + max_points = 50*50 + scan_radius = 1.5 - delta=riccati_f(g_tmp,Q_e,Q_i,pr, - $ D_beta_norm,tau) - - WRITE(*,*)"Fitz delta = ",delta - - g_r = 0.0 - g_i = -Q_e - CALL NewtonRoot(g_r, g_i, 1) - - lar_gamma = g_r - WRITE(*,*)"Fitz gamma success! growth rate = ",g_r - - ind_beta_arr = (/ 0. /) - dels_db_arr = (/ 0. /) ! USING DELS_DB_ARR FOR DELTA - delta_arr = (/ delta /) ! USING DELS_DB_ARR FOR DELTA - lar_gamma_arr = (/ g_r /) - - !WRITE(*,*)"dels_db=",dels_db - !WRITE(*,*)"[mm] del_s=",dels_db*d_beta*1000 - !WRITE(*,*)"growth rate=",lar_gamma - - br_th = 0.0 - - max_points = 50*50 - scan_radius = 1.5 - - ! Calculate step sizes -c ALLOCATE(results(1)%inQs(max_points), -c $ results(1)%iinQs(max_points)) -c ALLOCATE(results(1)%Re_deltas(max_points), -c $ results(1)%Im_deltas(max_points)) - ing_step = (2.0 * scan_radius) / (200 - 1) - count = 0 + ing_step = (2.0 * scan_radius) / (Q_num - 1) + count = 0 - ALLOCATE(inQs(1:201),iinQs(1:200)) - ALLOCATE(deltas(1:201,1:200)) - - DO i = 1, 201 - DO j = 1, 200 - ing_coarse = -scan_radius + (i - 1) * ing_step - iing_coarse = -scan_radius + (j - 1) * ing_step - ! Evaluate riccati function - g_tmp = CMPLX(ing_coarse,iing_coarse) - delta=riccati_f(g_tmp, - $ Q_e,Q_i,pr,D_beta_norm,tau) - !delta_real = REAL(delta) - !delta_imag = AIMAG(delta) - - !count = count + 1 - !results(1)%inQs(count) = ing_coarse - !results(1)%iinQs(count) = iing_coarse - !results(1)%Re_deltas(count) = delta_real - !results(1)%Im_deltas(count) = delta_imag - inQs(i) = ing_coarse - iinQs(j) = iing_coarse - deltas(i,j) = delta - - END DO - END DO - - OPEN(UNIT=out_unit,FILE="slayer_stability_n1.out", - $ STATUS="UNKNOWN") + ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) + ALLOCATE(deltas(1:(Q_num+1),1:Q_num)) + + DO i = 1, (Q_num+1) + DO j = 1, Q_num + ing_coarse = -scan_radius + (i - 1) * ing_step + iing_coarse = -scan_radius + (j - 1) * ing_step + ! Evaluate riccati function + g_tmp = CMPLX(ing_coarse,iing_coarse) + IF (fitz_flag) THEN + delta=riccati_f(g_tmp) + ELSE + delta=riccati(iing_coarse,Q_e,Q_i,P_perp, + $ c_beta,D_norm,tau,pe, + $ iinQ=ing_coarse) + END IF + inQs(i) = ing_coarse + iinQs(j) = iing_coarse + deltas(i,j) = delta + ENDDO + ENDDO + + OPEN(UNIT=out_unit,FILE="slayer_stability_n"// + $ TRIM(sn)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" DO i=1,201 @@ -599,125 +535,14 @@ PROGRAM slayer ENDDO CLOSE(out_unit) - CALL output_lar_gamma(lar_gamma_eq_flag,lar_gamma_flag, - $ fitz_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,qval_arr, - $ omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,ind_beta_arr, - $ D_beta_norm_arr,inpr_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ lu_arr,delta_arr,lar_gamma_arr,results) - - stop - ENDIF -c----------------------------------------------------------------------- -c TEST GAMMA_MATCH IN GSLAYER.F, FOR TESTING ONLY -c----------------------------------------------------------------------- - IF (stabscan_eq_flag) THEN - !WRITE(*,*)"infile=",infile - !WRITE(*,*)"ncfile=",ncfile - - ! propagate inpr value to inpr_prof if inpr_prof is turned off - IF (inpr_prof(1) < 0) THEN - inpr_prof = inpr - END IF - - CALL build_inputs(infile,ncfile,inpr_prof, - $ inpe,Pe_flag,qval_arr,psi_n_rational, - $ inQ_arr,inQ_e_arr,inQ_i_arr,inc_beta_arr, - $ inds_arr,ind_beta_arr,D_beta_norm_arr, - $ intau_arr,inQ0_arr,inpr_arr,inpe_arr, - $ omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr) - - WRITE(*,*)"Safety factor values=",qval_arr - WRITE(*,*)"inQ values=",inQ_arr - WRITE(*,*)"Prantdl numbers=",inpr_arr - WRITE(*,*)"Electron viscosities=",inpe_arr - WRITE(*,*)"Omega ExB values=",omegas_arr - WRITE(*,*)"outer region real deltaprimes=",Re_deltaprime_arr - WRITE(*,*)"outer region imag deltaprimes=",Im_deltaprime_arr - WRITE(*,*)"inQ_e_arr=",inQ_e_arr - WRITE(*,*)"inds_arr=",inds_arr - WRITE(*,*)"intau_arr=",intau_arr - n_k = SIZE(qval_arr) - - DO k=1,n_k - WRITE(*,*) "Finding roots on q=", qval_arr(k), - $ " rational surface" - - CALL growthrate_scan(qval_arr(k),lu_arr(k),inQ_arr(k), - $ inQ_e_arr(k),inQ_i_arr(k),inc_beta_arr(k),inds_arr(k), - $ intau_arr(k),inQ0_arr(k),inpr_arr(k),inpe_arr(k), - $ scan_radius,reQ_num,compress_deltas, - $ Re_deltaprime_arr(k),results(k)) - WRITE(*,*)"Exited growthrate_scan" - - ENDDO - WRITE(*,*)"Calling slayer_netcdf_out" - - br_th = 0.0 - WRITE(*,*)"Successfully entered output_lar_gamma()" - WRITE(*,*)"qval_arr = ",qval_arr - - CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag, - $ fitz_gamma_flag,stabscan_eq_flag,stabscan_flag,br_th_flag, - $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, - $ ind_beta_arr, - $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) -c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, -c $ stabscan_eq_flag,stabscan_flag,br_th_flag) - stop - ENDIF -c----------------------------------------------------------------------- -c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY -c----------------------------------------------------------------------- - IF (stabscan_flag) THEN - WRITE(*,*)"intau=",intau - WRITE(*,*)"inQ=",inQ - WRITE(*,*)"Prantdl numbers=",inpr - WRITE(*,*)"Electron viscosities=",inpe - WRITE(*,*)"inQ_e=",inQ_e - WRITE(*,*)"inds=",inds - WRITE(*,*)"inc_beta=",inc_beta - - WRITE(*,*)"running analytic scan" - - qval_arr = (/ qval /) - omegas_arr = (/ omega /) - inQ_arr = (/ inQ /) - inQ_e_arr = (/ inQ_e /) - inQ_i_arr = (/ inQ_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ REAL(delta_n_p) /) - Im_deltaprime_arr = (/ AIMAG(delta_n_p) /) - inpr_arr = (/ inpr /) - - - CALL params(n_e,t_e,t_i,omega, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - - D_beta_norm_arr = (/ D_beta_norm /) + ENDIF - CALL growthrate_scan(qval_arr(1),lu,inQ,inQ_e, - $ inQ_i,inc_beta,inds, - $ intau,inQ,inpr,inpe, - $ scan_radius,reQ_num,compress_deltas, - $ Re_deltaprime_arr(1),results(1)) - - WRITE(*,*)"allocations successful" - - br_th = 0.0 - CALL slayer_netcdf_out(SIZE(qval_arr),lar_gamma_eq_flag, - $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag, - $ stabscan_flag,br_th_flag, - $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr, - $ psi_n_rational,inpr_arr,br_th,Re_deltaprime_arr, - $ Im_deltaprime_arr,dels_db_arr,delta_arr,lu_arr, - $ ind_beta_arr, - $ D_beta_norm_arr,lar_gamma_arr,inQs,iinQs,results) + CALL output_gamma(est_gamma_flag,qval_arr, + $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, + $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ re_trace,im_trace) stop ENDIF c----------------------------------------------------------------------- @@ -727,7 +552,7 @@ PROGRAM slayer WRITE(*,*)"running br_th scan" - CALL params(n_e,t_e,t_i,omega, + CALL params(n_e,t_e,t_i,omega,chi,dr_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -787,30 +612,19 @@ PROGRAM slayer inQs = (/ 1.0 /) n_k = SIZE(qval_arr) - k=1 - IF (k==1) THEN - ALLOCATE(all_RE_deltas(1,1,n_k)) - ALLOCATE(all_Im_deltas(1,1,n_k)) - ALLOCATE(all_inQs(1,n_k)) - ALLOCATE(all_growthrates(n_k)) - ALLOCATE(all_growthrate_locs(n_k)) - ENDIF - all_Re_deltas(:,:,k) = 0.0 - all_Im_deltas(:,:,k) = 0.0 - all_inQs(:,k) = 0.0 qval_arr = (/ 3 /) inQs = (/ 1.0 /) inQs = (/ 1.0 /) omegas_arr = (/ 0.0 /) - inQ_arr = (/ inQ /) - inQ_e_arr = (/ inQ_e /) - inQ_i_arr = (/ inQ_i /) + Q_arr = (/ inQ /) + Q_e_arr = (/ inQ_e /) + Q_i_arr = (/ inQ_i /) psi_n_rational = (/ 0.0 /) Re_deltaprime_arr = (/ 0.0 /) Im_deltaprime_arr = (/ 0.0 /) - inpr_arr = (/ inpr /) + P_perp_arr = (/ inpr /) WRITE(*,*)"allocations successful" @@ -1215,7 +1029,7 @@ PROGRAM slayer DO k=0,knum ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) - CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k), + CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chi,dr_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1303,7 +1117,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e,t_e*ks(j,k),t_i*ks(j,k), - $ omega*js(j,k),l_n,l_t,qval,sval,bt, + $ omega*js(j,k),chi,dr_val,l_n,l_t,qval,sval,bt, $ rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1389,7 +1203,8 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e*ks(j,k),t_e*js(j,k),t_i*js(j,k),omega, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + $ chi,dr_val,l_n,l_t,qval,sval,bt,rs,R0,mu_i, + $ zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -1473,7 +1288,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) - CALL params(n_e*ks(j,k),t_e,t_i,omega, + CALL params(n_e*ks(j,k),t_e,t_i,omega,chi,dr_val, $ l_n,l_t,qval,sval,bt*js(j,k),rs,R0,mu_i,zeff, $ params_check) inQ=Q diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 1b61d38f0..5f299c9fd 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -48,48 +48,28 @@ END SUBROUTINE sl_check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, - $ lar_gamma_flag,fitz_gamma_flag,stabscan_eq_flag,stabscan_flag, - $ br_th_flag, - $ qval_arr,omegas_arr,inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational, - $ inpr_arr,br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db_arr, - $ delta_arr,lu_arr,ind_beta_arr,D_beta_norm_arr,lar_gamma_arr, - $ inQs,iinQs,results) - ! ds = D_beta_norm for lar growth rate routines - -c OPTIONAL -c br_th,Re_deltaprime_arr,Im_deltaprime_arr,dels_db,d_b,ds,lar_gamma, -c inQs,iinQs,results, + SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, + $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, + $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, + $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, + $ im_trace) INTEGER, INTENT(IN) :: msing - LOGICAL, INTENT(IN) :: lar_gamma_eq_flag,lar_gamma_flag, - $ stabscan_eq_flag,stabscan_flag,br_th_flag,fitz_gamma_flag - - INTEGER, ALLOCATABLE, DIMENSION(:) :: qval_arr - REAL(r8), DIMENSION(msing) :: gamma_arr - REAL(r8), DIMENSION(:), ALLOCATABLE :: omegas_arr, - $ inQ_arr,inQ_e_arr,inQ_i_arr,psi_n_rational,inpr_arr, - $ ind_beta_arr,D_beta_norm_arr,lu_arr - - REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_deltaprime_arr, - $ Im_deltaprime_arr,inQs,iinQs + LOGICAL, INTENT(IN) :: est_gamma_flag + INTEGER, INTENT(IN), DIMENSION(:) :: qval_arr + REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, + $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, + $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, + $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace + COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, + $ gamma_sol_arr,gamma_est_arr - REAL(r8) :: br_th - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: dels_db_arr, - $ lar_gamma_arr,delta_arr + INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, + $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,inpr_id,S_id, + $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,tr_id,tr_dim - TYPE(result_type), INTENT(IN) :: results(8) - - INTEGER :: i,ncid,r_id,ReQ_dim,ImQ_dim,qsing_dim, - $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, - $ ReQ_id,ImQ_id,gamma_id,omegas_id,Q_id,Q_e_id,Q_i_id, - $ r_dim,pr_id, qr_id,shear_id,slice_id,inQs_id,S_id, - $ gamma_err_id,gamma_loc_id,roots_dim,Re_dp_id,Im_dp_id, - $ rdpp_id,idpp_id,inpr_id,br_th_id,dels_db_id,d_b_id, - $ inds_id,lar_gamma_id,qsing_id,indnorm_id - - INTEGER :: run, run_dimid, point_dimid, varids(4), - $ max_points + INTEGER :: run, run_dimid, point_dimid, varids(4) CHARACTER(64) :: ncfile LOGICAL, PARAMETER :: debug_flag = .FALSE. @@ -97,13 +77,6 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- -c i=0; ncid=0;r_id=0;ReQ_dim=0;ImQ_dim=0;qsing_dim=0;qsing_id=0; -c $ i_dim=0;m_dim=0;mo_dim=0;p_dim=0;i_id=0;m_id=0;mo_id=0;p_id=0; -c $ ReQ_id=0;ImQ_id=0;gamma_id=0;omegas_id=0;Q_id=0;Q_e_id=0; -c $ Q_i_id=0;r_dim=0;pr_id=0;qr_id=0;shear_id=0;slice_id=0; -c $ inQs_id=0;S_id=0;gamma_err_id=0;gamma_loc_id=0;roots_dim=0; -c $ Re_dp_id=0;Im_dp_id=0;rdpp_id=0;idpp_id=0;inpr_id=0; -c $ br_th_id=0;dels_db_id=0;d_b_id=0;inds_id=0;lar_gamma_id=0 IF(debug_flag) PRINT *,"Called slayer_netcdf_out" IF (nn<10) THEN WRITE(UNIT=sn,FMT='(I1)')nn @@ -120,7 +93,6 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, CALL sl_check( nf90_create(ncfile, $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) - max_points = maxval([(results(run)%count, run=1,msing)]) c ----------------------------------------------------------------------- c define global file attributes c ----------------------------------------------------------------------- @@ -142,8 +114,8 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, IF(msing>0)THEN CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) - CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, - $ qsing_id)) + CALL sl_check( nf90_def_dim(ncid, "step", SIZE(re_trace), + $ tr_dim) ) CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, @@ -160,323 +132,65 @@ SUBROUTINE slayer_netcdf_out(msing,lar_gamma_eq_flag, $ qsing_dim,inpr_id) ) CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, $ qsing_dim,qr_id) ) - CALL sl_check( nf90_def_dim(ncid, "points", max_points, - $ point_dimid) ) - - IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL sl_check( nf90_def_var(ncid,"growthrate",nf90_double, - $ qsing_dim,gamma_id)) - CALL sl_check(nf90_def_var(ncid,"growthrate_locs", - $ nf90_double,qsing_dim,gamma_loc_id)) - CALL sl_check( nf90_def_var(ncid, "Re_Qs", nf90_double, - $ [point_dimid, qsing_dim], varids(1)) ) - CALL sl_check( nf90_def_var(ncid, "Im_Qs", nf90_double, - $ [point_dimid, qsing_dim], varids(2)) ) - CALL sl_check( nf90_def_var(ncid, "Re_deltas",nf90_double, - $ [point_dimid, qsing_dim], varids(3)) ) - CALL sl_check( nf90_def_var(ncid, "Im_deltas",nf90_double, - $ [point_dimid, qsing_dim], varids(4)) ) - END IF - -c IF (fitz_gamma_flag) THEN -c CALL sl_check( nf90_def_var(ncid, "Re_Qs", nf90_double, -c $ [point_dimid, qsing_dim], varids(1)) ) -c CALL sl_check( nf90_def_var(ncid, "Im_Qs", nf90_double, -c $ [point_dimid, qsing_dim], varids(2)) ) -c CALL sl_check( nf90_def_var(ncid,"Re_deltas",nf90_double, -c $ [point_dimid, qsing_dim], varids(3)) ) -c CALL sl_check( nf90_def_var(ncid,"Im_deltas",nf90_double, -c $ [point_dimid, qsing_dim], varids(4)) ) -c END IF - - IF (br_th_flag) THEN - CALL sl_check( nf90_def_var(ncid,"br_th",nf90_double, - $ qsing_dim,br_th_id) ) - END IF END IF - IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL sl_check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, - $ qsing_dim,rdpp_id) ) - CALL sl_check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, - $ qsing_dim,idpp_id) ) - END IF - IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN + CALL sl_check( nf90_def_var(ncid,"D",nf90_double, + $ qsing_dim,Dnorm_id) ) + CALL sl_check( nf90_def_var(ncid,"Delta_prime_rational", + $ nf90_double,(/qsing_dim,i_dim/),dpp_id) ) + CALL sl_check( nf90_def_var(ncid,"Delta_crit_rational", + $ nf90_double,qsing_dim,dc_id) ) + + IF (est_gamma_flag) THEN CALL sl_check( nf90_def_var(ncid,"delta_s_d_b",nf90_double, $ (/qsing_dim,i_dim/),dels_db_id) ) CALL sl_check( nf90_def_var(ncid,"d_beta",nf90_double, $ qsing_dim,d_b_id) ) - CALL sl_check( nf90_def_var(ncid,"D_beta_norm",nf90_double, - $ qsing_dim,indnorm_id) ) - CALL sl_check( nf90_def_var(ncid,"growthrate_estimate", - $ nf90_double,(/qsing_dim,i_dim/),lar_gamma_id) ) - END IF - IF (fitz_gamma_flag) THEN - CALL sl_check( nf90_def_var(ncid,"delta_hat",nf90_double, - $ (/qsing_dim,i_dim/),dels_db_id) ) - CALL sl_check( nf90_def_var(ncid,"growthrate", - $ nf90_double,(/qsing_dim,i_dim/),lar_gamma_id) ) + CALL sl_check( nf90_def_var(ncid,"est. growth rate", + $ nf90_double,(/qsing_dim,i_dim/),ge_id) ) END IF + + CALL sl_check( nf90_def_var(ncid,"growth rate", + $ nf90_double,(/qsing_dim,i_dim/),gs_id) ) + CALL sl_check( nf90_def_var(ncid,"growth rate trace", + $ nf90_double,(/tr_dim,i_dim/),tr_id) ) ! end definitions CALL sl_check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- - CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) - CALL sl_check( nf90_put_var(ncid,Q_id, inQ_arr)) - CALL sl_check( nf90_put_var(ncid,Q_e_id, inQ_e_arr)) - CALL sl_check( nf90_put_var(ncid,Q_i_id, inQ_i_arr)) - CALL sl_check( nf90_put_var(ncid,S_id, (/lu/))) + CALL sl_check( nf90_put_var(ncid,qr_id, qval_arr)) CALL sl_check( nf90_put_var(ncid,pr_id, psi_n_rational)) - CALL sl_check( nf90_put_var(ncid,inpr_id, inpr_arr)) - !CALL sl_check( nf90_put_var(ncid,qr_id, qval_arr)) - - IF ((stabscan_eq_flag) .OR. (stabscan_flag)) THEN - CALL sl_check( nf90_put_var(ncid,rdpp_id, Re_deltaprime_arr)) - CALL sl_check( nf90_put_var(ncid,idpp_id, Im_deltaprime_arr)) - DO run = 1, msing - CALL sl_check( nf90_put_var(ncid,varids(1), - $ results(run)%inQs,start=[1, run], - $ count=[results(run)%count, 1]) ) - CALL sl_check( nf90_put_var(ncid,varids(2), - $ results(run)%iinQs,start=[1, run], - $ count=[results(run)%count, 1])) - CALL sl_check( nf90_put_var(ncid, varids(3), - $ results(run)%Re_deltas, start=[1, run], - $ count=[results(run)%count, 1]) ) - CALL sl_check( nf90_put_var(ncid, varids(4), - $ results(run)%Im_deltas, start=[1, run], - $ count=[results(run)%count, 1]) ) - END DO - END IF - -c IF (fitz_gamma_flag) THEN -c DO run = 1, msing -c run = 1 -c CALL sl_check( nf90_put_var(ncid,varids(1), -c $ results(run)%inQs,start=[1, run], -c $ count=[results(run)%count, 1]) ) -c CALL sl_check( nf90_put_var(ncid,varids(2), -c $ results(run)%iinQs,start=[1, run], -c $ count=[results(run)%count, 1])) -c CALL sl_check( nf90_put_var(ncid, varids(3), -c $ results(run)%Re_deltas, start=[1, run], -c $ count=[results(run)%count, 1]) ) -c CALL sl_check( nf90_put_var(ncid, varids(4), -c $ results(run)%Im_deltas, start=[1, run], -c $ count=[results(run)%count, 1]) ) -c END DO -c END IF - - IF (br_th_flag) THEN - CALL sl_check( nf90_put_var(ncid,br_th_id, (/ br_th /))) - END IF + CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) + CALL sl_check( nf90_put_var(ncid,S_id, lu_arr)) + CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) + CALL sl_check( nf90_put_var(ncid,Q_e_id, Q_e_arr)) + CALL sl_check( nf90_put_var(ncid,Q_i_id, Q_i_arr)) + CALL sl_check( nf90_put_var(ncid,inpr_id, P_perp_arr)) + CALL sl_check( nf90_put_var(ncid,Dnorm_id, D_norm_arr)) + + CALL sl_check( nf90_put_var(ncid,dpp_id, + $ RESHAPE((/Re_deltaprime_arr,Im_deltaprime_arr/), + $ (/msing,2/)))) + CALL sl_check( nf90_put_var(ncid,dc_id, delta_crit_arr)) - IF ((lar_gamma_flag) .OR. (lar_gamma_eq_flag)) THEN + IF (est_gamma_flag) THEN CALL sl_check( nf90_put_var(ncid,dels_db_id, $ RESHAPE((/REAL(dels_db_arr),AIMAG(dels_db_arr)/), $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,d_b_id,ind_beta_arr)) - CALL sl_check( nf90_put_var(ncid,indnorm_id, D_beta_norm_arr)) - CALL sl_check( nf90_put_var(ncid,lar_gamma_id, - $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), - $ (/msing,2/)))) - END IF - IF (fitz_gamma_flag) THEN - CALL sl_check( nf90_put_var(ncid,dels_db_id, - $ RESHAPE((/REAL(delta_arr),AIMAG(delta_arr)/), - $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,lar_gamma_id, - $ RESHAPE((/REAL(lar_gamma_arr),AIMAG(lar_gamma_arr)/), + CALL sl_check( nf90_put_var(ncid,d_b_id,d_beta_arr)) + CALL sl_check( nf90_put_var(ncid,ge_id, + $ RESHAPE((/REAL(gamma_est_arr),AIMAG(gamma_est_arr)/), $ (/msing,2/)))) END IF -c ----------------------------------------------------------------------- -c close file -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Closing netcdf file" - CALL sl_check( nf90_close(ncid) ) -c ----------------------------------------------------------------------- -c terminate. -c ----------------------------------------------------------------------- - RETURN - END SUBROUTINE slayer_netcdf_out -c ----------------------------------------------------------------------- -c declarations. -c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, - $ ni_arr,ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, - $ resm,nns_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr,inpe_arr, - $ inQ_arr,omegas_arr,omegas_e_arr,omegas_i_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr) - - INTEGER, INTENT(IN) :: msing - REAL(r8), DIMENSION(:), INTENT(IN) :: ne_arr,te_arr,ni_arr, - $ ti_arr,zeff_arr,shear,bt_arr,rs_arr, - $ R0_arr,inc_beta_arr,inds_arr,intau_arr,inpr_arr, - $ inpe_arr,omegas_arr,omegas_e_arr,omegas_i_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr,inQ_arr - INTEGER, DIMENSION(:), INTENT(IN) :: qval_arr,resm,nns_arr - - INTEGER :: i, ncid,r_id,qsing_dim,qsing_id,msing_id, - $ i_dim,ne_id,te_id,ni_id,ti_id,zeff_id,shear_id,bt_id,rs_id, - $ R0_id,resm_id,nns_id,inQ_id,inQ_e_id,inc_beta_id, - $ inds_id,qval_id,inQ_i_id,qr_id,indnorm_id - $ intau_id,inpr_id,inpe_id,omegas_id,Re_delta_id,Im_delta_id, - $ omegas_e_id,omegas_i_id,intau_id - - CHARACTER(64) :: ncfile - LOGICAL, PARAMETER :: debug_flag = .FALSE. - CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' -c ----------------------------------------------------------------------- -c set variables -c ----------------------------------------------------------------------- - ne_id=0 - te_id=0 - ni_id=0 - ti_id=0 - zeff_id=0 - shear_id=0 - bt_id=0 - rs_id=0 - R0_id=0 - resm_id=0 - nns_id=0 - inQ_id=0 - inQ_e_id=0 - inc_beta_id=0 - inds_id=0 - qval_id=0 - inQ_i_id=0 - qr_id=0 - intau_id=0 - inpr_id=0 - inpe_id=0 - omegas_id=0 - Re_delta_id=0 - Im_delta_id=0 - omegas_e_id=0 - omegas_i_id=0 - - IF(debug_flag) PRINT *,"Called slayer_netcdf_inputs" - IF (nn<10) THEN - WRITE(UNIT=sn,FMT='(I1)')nn - sn=ADJUSTL(sn) - ELSE - WRITE(UNIT=sn,FMT='(I2)')nn - ENDIF - ncfile = "slayer_inputs_n"//TRIM(sn)//".nc" - IF(debug_flag) PRINT *, ncfile -c ----------------------------------------------------------------------- -c open files -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Creating netcdf files" - CALL sl_check( nf90_create(ncfile, - $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) -c ----------------------------------------------------------------------- -c define global file attributes -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Defining netcdf globals" - CALL sl_check( nf90_put_att(ncid,nf90_global,"title", - $ "SLAYER outputs")) - CALL sl_check( nf90_put_att(ncid,nf90_global,"version", version)) - - IF(debug_flag) PRINT *," - Defining dimensions in netcdf" + CALL sl_check( nf90_put_var(ncid,gs_id, + $ RESHAPE((/REAL(gamma_sol_arr),AIMAG(gamma_sol_arr)/), + $ (/msing,2/)))) - IF(msing>0)THEN - !CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational - CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, - $ qsing_id)) - - CALL sl_check( nf90_def_var(ncid,"ne",nf90_double, - $ qsing_dim,ne_id)) - CALL sl_check( nf90_def_var(ncid,"te",nf90_double, - $ qsing_dim,te_id)) - CALL sl_check( nf90_def_var(ncid,"ni",nf90_double, - $ qsing_dim,ni_id)) - CALL sl_check( nf90_def_var(ncid,"ti",nf90_double, - $ qsing_dim,ti_id)) - CALL sl_check( nf90_def_var(ncid,"zeff",nf90_double, - $ qsing_dim,zeff_id)) - CALL sl_check( nf90_def_var(ncid,"shear",nf90_double, - $ qsing_dim,shear_id)) - CALL sl_check( nf90_def_var(ncid,"bt",nf90_double, - $ qsing_dim,bt_id)) - CALL sl_check( nf90_def_var(ncid,"rs",nf90_double, - $ qsing_dim,rs_id)) - CALL sl_check( nf90_def_var(ncid,"R0",nf90_double, - $ qsing_dim,R0_id)) - !CALL sl_check( nf90_def_var(ncid,"mu_i",nf90_double, - !$ qsing_dim,mu_i_id)) - CALL sl_check( nf90_def_var(ncid,"resm",nf90_int, - $ qsing_dim,resm_id)) - CALL sl_check( nf90_def_var(ncid,"nns_arr",nf90_int, - $ qsing_dim,nns_id)) - !CALL sl_check( nf90_def_var(ncid,"qval",nf90_int, - !$ qsing_dim,qval_id)) - CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, - $ qsing_dim,inQ_id)) - ! CALL sl_check( nf90_def_var(ncid,"Q_e",nf90_double, - !$ qsing_dim,inQ_e_id)) - ! CALL sl_check( nf90_def_var(ncid,"Q_i",nf90_double, - !$ qsing_dim,inQ_i_id)) - CALL sl_check( nf90_def_var(ncid,"c_beta",nf90_double, - $ qsing_dim,inc_beta_id)) - CALL sl_check( nf90_def_var(ncid,"ds",nf90_double, - $ qsing_dim,inds_id)) - CALL sl_check( nf90_def_var(ncid,"tau",nf90_double, - $ qsing_dim,intau_id)) - CALL sl_check( nf90_def_var(ncid,"pr",nf90_double, - $ qsing_dim,inpr_id)) - CALL sl_check( nf90_def_var(ncid,"pe",nf90_double, - $ qsing_dim,inpe_id)) - CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, - $ qsing_dim,omegas_id)) - CALL sl_check( nf90_def_var(ncid,"omegas_e",nf90_double, - $ qsing_dim,omegas_e_id)) - CALL sl_check( nf90_def_var(ncid,"omegas_i",nf90_double, - $ qsing_dim,omegas_i_id)) - CALL sl_check( nf90_def_var(ncid,"Re_deltaprime",nf90_double, - $ qsing_dim,Re_delta_id)) - CALL sl_check( nf90_def_var(ncid,"Im_deltaprime",nf90_double, - $ qsing_dim,Im_delta_id)) - ENDIF - ! define variables - IF(debug_flag) PRINT *," - Defining variables in netcdf" - ! end definitions - CALL sl_check( nf90_enddef(ncid) ) -c ----------------------------------------------------------------------- -c set variables -c ----------------------------------------------------------------------- - ! IF(debug_flag) PRINT *," - Putting profile variables in netcdf" - CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL sl_check( nf90_put_var(ncid,ne_id, ne_arr)) - CALL sl_check( nf90_put_var(ncid,ni_id, ni_arr)) - CALL sl_check( nf90_put_var(ncid,te_id, te_arr)) - CALL sl_check( nf90_put_var(ncid,ti_id, ti_arr)) - CALL sl_check( nf90_put_var(ncid,zeff_id, zeff_arr)) - CALL sl_check( nf90_put_var(ncid,shear_id, shear)) - CALL sl_check( nf90_put_var(ncid,bt_id, bt_arr)) - CALL sl_check( nf90_put_var(ncid,rs_id, rs_arr)) - CALL sl_check( nf90_put_var(ncid,R0_id, R0_arr)) - !CALL sl_check( nf90_put_var(ncid,mu_i_id, mu_i_arr)) - CALL sl_check( nf90_put_var(ncid,resm_id, resm)) - CALL sl_check( nf90_put_var(ncid,nns_id, nns_arr)) - !CALL sl_check( nf90_put_var(ncid,qval_id, qval_arr)) - CALL sl_check( nf90_put_var(ncid,inQ_id, inQ_arr)) - !CALL sl_check( nf90_put_var(ncid,inQ_e_id, inQ_e_arr)) - !CALL sl_check( nf90_put_var(ncid,inQ_i_id, inQ_i_arr)) - CALL sl_check( nf90_put_var(ncid,inc_beta_id, inc_beta_arr)) - CALL sl_check( nf90_put_var(ncid,inds_id, inds_arr)) - CALL sl_check( nf90_put_var(ncid,intau_id, intau_arr)) - CALL sl_check( nf90_put_var(ncid,inpr_id, inpr_arr)) - CALL sl_check( nf90_put_var(ncid,inpe_id, inpe_arr)) - CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) - CALL sl_check( nf90_put_var(ncid,omegas_e_id, omegas_e_arr)) - CALL sl_check( nf90_put_var(ncid,omegas_i_id, omegas_i_arr)) - CALL sl_check( nf90_put_var(ncid,Re_delta_id,Re_deltaprime_arr)) - CALL sl_check( nf90_put_var(ncid,Im_delta_id,Im_deltaprime_arr)) + CALL sl_check( nf90_put_var(ncid,tr_id, + $ RESHAPE((/re_trace,im_trace/), + $ (/SIZE(re_trace),2/)))) c ----------------------------------------------------------------------- c close file @@ -487,5 +201,5 @@ SUBROUTINE slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr, c terminate. c ----------------------------------------------------------------------- RETURN - END SUBROUTINE slayer_netcdf_inputs + END SUBROUTINE slayer_netcdf_out END MODULE slayer_netcdf_mod \ No newline at end of file diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 5be759f90..edd055ccc 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -43,93 +43,6 @@ SUBROUTINE check(stat) RETURN END SUBROUTINE check c----------------------------------------------------------------------- -c subprogram 2. issurfint. -c surface integration by simple method. copied from EQUIL -c----------------------------------------------------------------------- - FUNCTION issurfint(func,fs,inpsi,wegt,ave, - $ fsave,psave,jacs,delpsi,inr,ina,first) -c----------------------------------------------------------------------- -c declaration. -c----------------------------------------------------------------------- - !IMPLICIT NONE - INTEGER, INTENT(IN) :: fs,wegt,ave - REAL(r8), INTENT(IN) :: inpsi - REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func - - LOGICAL, INTENT(INOUT) :: first - INTEGER, INTENT(INOUT) :: fsave - REAL(r8), INTENT(INOUT) :: psave - REAL(r8),DIMENSION(0:),INTENT(INOUT) :: jacs,delpsi,inr,ina - INTEGER :: itheta, ix, iy - REAL(r8) :: issurfint - REAL(r8) :: rfac,ineta,injac,inarea - REAL(r8), DIMENSION(1,2) :: w - REAL(r8), DIMENSION(0:fs) :: z,thetas - REAL(r8), dimension(4) :: rzphi_f, rzphi_fx, rzphi_fy - - issurfint=0 - inarea=0 - ix = 0 - iy = 0 - IF(first .OR. inpsi/=psave .OR. fs/=fsave)THEN - psave = inpsi - fsave = fs - !first = .FALSE. - DO itheta=0,fs - thetas(itheta) = REAL(itheta,r8)/REAL(fs,r8) - ENDDO - DO itheta=0,fs-1 - CALL bicube_eval_external(rzphi, inpsi, thetas(itheta), 1, - $ ix, iy, rzphi_f, rzphi_fx, rzphi_fy) - rfac=SQRT(rzphi_f(1)) - ineta=twopi*(thetas(itheta)+rzphi_f(2)) - ina(itheta)=rfac - inr(itheta)=ro+rfac*COS(ineta) - z(itheta)=zo+rfac*SIN(ineta) - injac=rzphi_f(4) - jacs(itheta)=injac - w(1,1)=(1+rzphi_fy(2))*twopi**2*rfac*inr(itheta)/injac - w(1,2)=-rzphi_fy(1)*pi*inr(itheta)/(rfac*injac) - delpsi(itheta)=SQRT(w(1,1)**2+w(1,2)**2) - ENDDO - ENDIF - - IF (wegt==0) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ jacs(itheta)*delpsi(itheta)*func(itheta)/fs - ENDDO - ELSE IF (wegt==1) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs - ENDDO - ELSE IF (wegt==2) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs - ENDDO - ELSE IF (wegt==3) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs - ENDDO - ELSE - STOP "ERROR: issurfint wegt must be in [0,1,2,3]" - ENDIF - - IF (ave==1) THEN - DO itheta=0,fs-1 - inarea=inarea+jacs(itheta)*delpsi(itheta)/fs - ENDDO - issurfint=issurfint/inarea - ENDIF -c----------------------------------------------------------------------- -c terminate. -c----------------------------------------------------------------------- - RETURN - END FUNCTION issurfint -c----------------------------------------------------------------------- c subprogram 2. stride_netcdf_out. c Replicate stride.out information in netcdf format. c----------------------------------------------------------------------- @@ -149,27 +62,18 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id,prandtl_id,rs_id,rf_id + $ shear_id,resm_id,drr_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile REAL(r8) :: resnum,shear,respsi,resm_sing - REAL(r8), DIMENSION(msing) :: rs_array + REAL(r8), DIMENSION(msing) :: dr_rationals REAL(r8), DIMENSION(:), ALLOCATABLE :: rs_full TYPE(spline_type) :: sr REAL(r8), DIMENSION(0:mpsi) :: rhotor - - ! MINOR RADIUS INTEGRAL QUANTITIES - LOGICAL :: firstsur - REAL(r8), DIMENSION(0:512) :: my_unitfun - INTEGER :: my_fsave - REAL(r8) :: my_psave - REAL(r8), DIMENSION(:), ALLOCATABLE :: my_jacs,my_delpsi, - $ my_rsurf,my_asurf - REAL(r8) :: my_rfac,my_jac,a_surf INTEGER, DIMENSION(msing) :: resm @@ -193,35 +97,12 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) ep = CMPLX(epi, 0.0) ev = CMPLX(evi, 0.0) et = CMPLX(eti, 0.0) -c----------------------------------------------------------------------- -c loop across singular surfaces, evaluate minor radius -c----------------------------------------------------------------------- - !WRITE(*,*)"REACHED RS CALCULATION" - !rhotor(:) = SQRT(sq%fsi(:, 4)*twopi*psio / (pi * bt0)) ! effective minor radius in Callen - !CALL spline_alloc(sr,mpsi,1) - !sr%xs = sq%xs - !sr%fs(:, 1) = rhotor(:) - !CALL spline_fit(sr,"extrap") - ALLOCATE(rs_full(sq%mx+1)) - - mthsur = 512 ! Hardcoded, but this is a default value - ALLOCATE(my_jacs(0:mthsur),my_delpsi(0:mthsur), - $ my_rsurf(0:mthsur),my_asurf(0:mthsur)) + ! evaluate resistive interchange parameter on rational surfaces DO i=1,msing respsi = sing(i)%psifac - ! SURFACE INTEGRAL - firstsur = .TRUE. - my_unitfun = 1 - rs_array(i) = issurfint(my_unitfun,mthsur,respsi,3,1, - $ my_fsave,my_psave,my_jacs,my_delpsi,my_rsurf, - $ my_asurf,firstsur) - END DO - DO i=1,sq%mx+1 - respsi = sq%xs(i)!*psio - rs_full(i) = issurfint(my_unitfun,mthsur,respsi,3,1, - $ my_fsave,my_psave,my_jacs,my_delpsi,my_rsurf, - $ my_asurf,firstsur) + CALL spline_eval(locstab,respsi,0) + dr_rationals(i)=locstab%f(1)/respsi END DO c----------------------------------------------------------------------- c open files @@ -309,16 +190,10 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid,"r_prime",nf90_int,rp_dim,rp_id)) CALL check( nf90_def_var(ncid,"psi_n_rational",nf90_double, $ r_dim,pr_id) ) - CALL check( nf90_def_var(ncid,"rs_rational",nf90_double, - $ r_dim,rs_id) ) - CALL check( nf90_def_var(ncid,"flux_avg_rs",nf90_double, - $ p_dim,rf_id) ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) - CALL check( nf90_def_var(ncid, "prandtl", nf90_double, r_dim, - $ prandtl_id) ) CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, $ resm_id) ) ENDIF @@ -330,6 +205,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_def_var(ncid, "q", nf90_double, p_dim, q_id) ) CALL check( nf90_def_var(ncid, "di", nf90_double, p_dim, di_id) ) CALL check( nf90_def_var(ncid, "dr", nf90_double, p_dim, dr_id) ) + CALL check( nf90_def_var(ncid, "dr_rational", nf90_double, p_dim, + $ drr_id) ) CALL check( nf90_def_var(ncid, "ca1", nf90_double, p_dim, ca_id)) CALL check( nf90_def_var(ncid, "W_p_eigenvector", nf90_double, $ (/m_dim, mo_dim, i_dim/), wp_id) ) @@ -374,8 +251,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,pr_id, (/(sing(i)%psifac, $ i=1,msing)/)) ) - CALL check( nf90_put_var(ncid,rs_id, rs_array) ) - CALL check( nf90_put_var(ncid,rf_id, rs_full) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) @@ -389,8 +264,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) !ENDDO CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, - $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? - CALL check( nf90_put_var(ncid,prandtl_id, (/(0.0, $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? CALL check( nf90_put_var(ncid,resm_id, resm) ) ! CALL check( nf90_put_var(ncid,shear_id,shear) ) ! GPEC HAS DIFFERENT SHEAR CALC? @@ -403,6 +276,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) CALL check( nf90_put_var(ncid,q_id, sq%fs(:,4))) CALL check( nf90_put_var(ncid,di_id, locstab%fs(:,1)/sq%xs(:))) CALL check( nf90_put_var(ncid,dr_id, locstab%fs(:,2)/sq%xs(:))) + CALL check( nf90_put_var(ncid,drr_id, dr_rationals)) CALL check( nf90_put_var(ncid,ca_id, locstab%fs(:,4))) IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" From 54369b0eae8b7c3ff9ad1036207cdb15ad65b896 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 9 May 2025 19:35:54 -0400 Subject: [PATCH 036/118] bug and sign fixes --- input/slayer.in | 2 +- slayer/gslayer.f | 11 ++++++----- slayer/layerinputs.f | 6 +++--- slayer/params.f | 4 ++-- slayer/slayer.f | 17 ++++++++++------- slayer/slayer_netcdf.f | 16 ++++++++++++---- 6 files changed, 34 insertions(+), 22 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 1d8df39d0..23eb8a29b 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -45,7 +45,7 @@ jnum=100 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan along with the other. Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes - scan_radius=2.0 ! stability scan width for Re(Q),Im(Q) scan + scan_radius=1.5 ! stability scan width for Re(Q),Im(Q) scan read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation QPscan_flag=f ! scan (Q,P) space for delta and torque. diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 7d5e62a73..1863a4c09 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -185,8 +185,8 @@ SUBROUTINE output_gamma(est_gamma_flag,qval_arr, $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, - $ im_trace) + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, + $ re_trace,im_trace) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: est_gamma_flag @@ -194,7 +194,8 @@ SUBROUTINE output_gamma(est_gamma_flag,qval_arr, REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace + $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace, + $ Qconv_arr COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, $ gamma_sol_arr,gamma_est_arr @@ -204,8 +205,8 @@ SUBROUTINE output_gamma(est_gamma_flag,qval_arr, $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, - $ im_trace) + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, + $ re_trace,im_trace) END SUBROUTINE output_gamma c----------------------------------------------------------------------- diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index eb8b3e565..d5f13d5df 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -431,11 +431,11 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole tauk = Qconv - + ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega - Q_e=-Qconv*omega_e - Q_i=-Qconv*omega_i + Q_e=Qconv*omega_e + Q_i=Qconv*omega_i ! This is the most critical parameter ds=lu**(1.0/3.0)*rho_s/my_rs ! conversion based on Cole. diff --git a/slayer/params.f b/slayer/params.f index 2e2cf1138..ef79e0287 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -73,8 +73,8 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val, ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega - Q_e=-Qconv*omega_e - Q_i=-Qconv*omega_i + Q_e=Qconv*omega_e + Q_i=Qconv*omega_i ! This is the most critical parameter ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. diff --git a/slayer/slayer.f b/slayer/slayer.f index 5eca1a8f2..6d7bc1080 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -22,7 +22,7 @@ PROGRAM slayer CHARACTER(512) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,count, - $ Q_num,n_k,scan_radius,max_points + $ Q_num,n_k,scan_radius INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -291,6 +291,7 @@ PROGRAM slayer c LAR (cylindrical) growthrates via restive layer thickness c----------------------------------------------------------------------- IF (est_gamma_flag) THEN + WRITE(*,*)"------------------------------------------" WRITE(*,*)">>> Estimating growth rate" IF (read_eq) THEN @@ -371,7 +372,7 @@ PROGRAM slayer $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, $ re_trace,im_trace) END IF ENDIF @@ -379,6 +380,7 @@ PROGRAM slayer c LAR (cylindrical) growthrates via restive layer thickness c----------------------------------------------------------------------- IF (match_gamma_flag) THEN + WRITE(*,*)"------------------------------------------" WRITE(*,*)">>> Calculating asymptotically matched growth rate" IF (read_eq) THEN @@ -494,8 +496,9 @@ PROGRAM slayer END IF IF (stabscan_flag) THEN - max_points = 50*50 - scan_radius = 1.5 + WRITE(*,*)"------------------------------------------" + WRITE(*,*)">>> Running Re(Q),Im(Q) scan, radius=", + $ scan_radius ing_step = (2.0 * scan_radius) / (Q_num - 1) count = 0 @@ -526,8 +529,8 @@ PROGRAM slayer $ TRIM(sn)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" - DO i=1,201 - DO j=1,200 + DO i=1,Q_num+1 + DO j=1,Q_num WRITE(out_unit,'(1x,4(es17.8e3))') $ inQs(i),iinQs(j), $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) @@ -541,7 +544,7 @@ PROGRAM slayer $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, $ re_trace,im_trace) stop ENDIF diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 5f299c9fd..eb2ed6a0f 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -52,8 +52,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,re_trace, - $ im_trace) + $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, + $ re_trace,im_trace) INTEGER, INTENT(IN) :: msing LOGICAL, INTENT(IN) :: est_gamma_flag @@ -61,13 +61,15 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace + $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace, + $ Qconv_arr COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, $ gamma_sol_arr,gamma_est_arr INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,inpr_id,S_id, - $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,tr_id,tr_dim + $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,tr_id,tr_dim, + $ qsing_id,qc_id INTEGER :: run, run_dimid, point_dimid, varids(4) @@ -114,10 +116,14 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, IF(msing>0)THEN CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) + CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, + $ qsing_id)) CALL sl_check( nf90_def_dim(ncid, "step", SIZE(re_trace), $ tr_dim) ) CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) + CALL sl_check( nf90_def_var(ncid,"tau_k",nf90_double, + $ qsing_dim,qc_id)) CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, $ qsing_dim,Q_id)) CALL sl_check( nf90_def_var(ncid,"Q_e",nf90_double, @@ -159,10 +165,12 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- + CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) CALL sl_check( nf90_put_var(ncid,qr_id, qval_arr)) CALL sl_check( nf90_put_var(ncid,pr_id, psi_n_rational)) CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) CALL sl_check( nf90_put_var(ncid,S_id, lu_arr)) + CALL sl_check( nf90_put_var(ncid,qc_id, Qconv_arr)) CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) CALL sl_check( nf90_put_var(ncid,Q_e_id, Q_e_arr)) CALL sl_check( nf90_put_var(ncid,Q_i_id, Q_i_arr)) From 5a533c3df92ce28faed4b8830fa297191ef13439 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 21 May 2025 17:19:00 -0400 Subject: [PATCH 037/118] SLAYER print statement cleanups --- slayer/gslayer.f | 7 +++--- slayer/slayer.f | 49 ++++++++++++++++++++++++++---------------- slayer/slayer_netcdf.f | 3 +-- 3 files changed, 35 insertions(+), 24 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 1863a4c09..aaf280c1d 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -199,8 +199,6 @@ SUBROUTINE output_gamma(est_gamma_flag,qval_arr, COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, $ gamma_sol_arr,gamma_est_arr - WRITE(*,*)"Successfully entered output_gamma()" - CALL slayer_netcdf_out(SIZE(qval_arr),est_gamma_flag, $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, @@ -424,8 +422,9 @@ SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) END IF IF (verbose .ne. 0) THEN - WRITE(*, '(" Q step = (", ES10.3, ", ", ES10.3,")" )') - $ g_r, g_i + WRITE(*, '(A, ES10.3, A, ES10.3, A, A, ES10.3)') + $ 'Q step = (', g_r, ' + ', + $ g_i, 'j )', ' Residual =', Residual ENDIF iter = iter + 1 diff --git a/slayer/slayer.f b/slayer/slayer.f index 6d7bc1080..e20e575bb 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -22,7 +22,7 @@ PROGRAM slayer CHARACTER(512) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,count, - $ Q_num,n_k,scan_radius + $ Q_num,n_k INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -32,7 +32,7 @@ PROGRAM slayer $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,stabscan_flag,read_eq,est_gamma_flag, $ match_gamma_flag,fitz_flag,br_th_flag - REAL(r8) :: n_e,t_e,t_i,omega,omega0, + REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_radius, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual @@ -349,8 +349,10 @@ PROGRAM slayer ALLOCATE(gamma_est_arr(n_k),dels_db_arr(n_k)) DO k=1,n_k - WRITE(*,*) "Calculating growth rate estimate on q=", - $ qval_arr(k)," rational surface" + WRITE(*,*) + WRITE(*,'(A,I0,A)') 'Calculating growth rate '// + $ 'estimate on q = ', + $ qval_arr(k),' rational surface' dels_db=riccati_del_s(Q_arr(k),Q_e_arr(k), $ Q_i_arr(k),P_perp_arr(k),c_beta_arr(k), @@ -361,8 +363,9 @@ PROGRAM slayer gamma_est_arr(k) = gammafac_arr(k)/del_s dels_db_arr(k) = dels_db - WRITE(*,*)"Growth rate estimate=", - $ REAL(gamma_est_arr(k))," [Hz]" + WRITE(*,*) + WRITE(*,'(A,F0.3,A)')'Growth rate estimate = ', + $ REAL(gamma_est_arr(k)),' [Hz]' ENDDO @@ -442,9 +445,9 @@ PROGRAM slayer ALLOCATE(gamma_sol_arr(n_k)) DO k=1,n_k - WRITE(*,*) "Calculating growth rates on q=", - $ qval_arr(k)," rational surface" - + WRITE(*,*) + WRITE(*,'(A,I0,A)') 'Calculating growth rates on q = ', + $ qval_arr(k),' rational surface' Q_e = Q_e_arr(k) Q_i = Q_i_arr(k) P_perp = P_perp_arr(k) @@ -477,17 +480,22 @@ PROGRAM slayer CALL newton_root(g_r,g_i,1,fitz_flag) - WRITE(*,*)"Success! growth rate = ", - $ g_r/tauk," [Hz]" + WRITE(*,*) + WRITE(*,'(A,F0.3,A)') 'Success! Growth rate = ', + $ g_r/tauk, ' [Hz]' CALL shrink_array(re_trace, n_trace) CALL shrink_array(im_trace, n_trace) - re_trace = re_trace/tauk - im_trace = im_trace/tauk - - gamma_sol_arr(k) = g_r/tauk - + IF (fitz_flag) THEN + re_trace = re_trace/tauk + im_trace = im_trace/tauk + gamma_sol_arr(k) = g_r/tauk + ELSE + re_trace = re_trace/tauk + im_trace = -im_trace/tauk + gamma_sol_arr(k) = -g_r/tauk + END IF ENDDO IF (.NOT. (est_gamma_flag)) THEN @@ -497,7 +505,8 @@ PROGRAM slayer IF (stabscan_flag) THEN WRITE(*,*)"------------------------------------------" - WRITE(*,*)">>> Running Re(Q),Im(Q) scan, radius=", + WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// + $ 'Im(Q)] scan with radius = ', $ scan_radius ing_step = (2.0 * scan_radius) / (Q_num - 1) @@ -520,7 +529,11 @@ PROGRAM slayer $ iinQ=ing_coarse) END IF inQs(i) = ing_coarse - iinQs(j) = iing_coarse + IF (fitz_flag) THEN + iinQs(j) = iing_coarse + ELSE + iinQs(j) = -iing_coarse + END IF deltas(i,j) = delta ENDDO ENDDO diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index eb2ed6a0f..4b45df4c1 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -109,9 +109,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, ! define dimensions IF(debug_flag) PRINT *," - Defining dimensions in netcdf" - WRITE(*,*)"netcdf msing=",msing !WRITE(*,*)"netcdf qval=",qval - WRITE(*,*)"netcdf qval_arr=",qval_arr + WRITE(*,*)">>> Writing results to NetCDF output file" IF(msing>0)THEN CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational From 832c9e3feae4b5f8eb8eb471ddc660b85b803147 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 11 Jun 2025 17:51:25 -0400 Subject: [PATCH 038/118] pre-merge updates --- slayer/gslayer.f | 6 +++--- slayer/params.f | 4 ++-- slayer/slayer.f | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index aaf280c1d..07a4282e4 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -380,7 +380,7 @@ SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.1 ! Max step size + REAL(r8), PARAMETER :: Smax = 0.05 ! Max step size INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations iter = 0 @@ -424,7 +424,7 @@ SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) IF (verbose .ne. 0) THEN WRITE(*, '(A, ES10.3, A, ES10.3, A, A, ES10.3)') $ 'Q step = (', g_r, ' + ', - $ g_i, 'j )', ' Residual =', Residual + $ g_i, 'j ),', ' Residual =', Residual ENDIF iter = iter + 1 @@ -450,7 +450,7 @@ SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, INTEGER :: i REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size - REAL(r8), PARAMETER :: Smax = 1.0d0 ! Max step size + REAL(r8), PARAMETER :: Smax = 0.05 ! Max step size REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations diff --git a/slayer/params.f b/slayer/params.f index ef79e0287..2e2cf1138 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -73,8 +73,8 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val, ! note Q depends on Qconv even if omega is fixed. Q=Qconv*omega - Q_e=Qconv*omega_e - Q_i=Qconv*omega_i + Q_e=-Qconv*omega_e + Q_i=-Qconv*omega_i ! This is the most critical parameter ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. diff --git a/slayer/slayer.f b/slayer/slayer.f index e20e575bb..438b5a2d8 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -446,8 +446,8 @@ PROGRAM slayer DO k=1,n_k WRITE(*,*) - WRITE(*,'(A,I0,A)') 'Calculating growth rates on q = ', - $ qval_arr(k),' rational surface' + WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', + $ qval_arr(k),' rational surface:' Q_e = Q_e_arr(k) Q_i = Q_i_arr(k) P_perp = P_perp_arr(k) From 633821bd984389b4ce5867cd6d5cd80658cd90ab Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 24 Jun 2025 17:10:20 -0400 Subject: [PATCH 039/118] small changes post merge --- slayer/gslayer.f | 6 ++---- slayer/layerinputs.f | 8 ++++---- slayer/makefile | 2 +- slayer/sglobal.f | 2 +- slayer/slayer.f | 4 ++-- 5 files changed, 10 insertions(+), 12 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 07a4282e4..a663ce3b4 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -17,8 +17,6 @@ MODULE gslayer_mod USE slayer_netcdf_mod - USE grid, ONLY : powspace,linspace - IMPLICIT NONE CONTAINS @@ -380,7 +378,7 @@ SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.05 ! Max step size + REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations iter = 0 @@ -450,7 +448,7 @@ SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, INTEGER :: i REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.05 ! Max step size + REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index d5f13d5df..50cb53064 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -3,13 +3,13 @@ MODULE layerinputs_mod USE inputs, ONLY : read_kin,read_equil,kin,chi1 USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, $ spline_dealloc,spline_int,spline_fit - USE sglobal_mod, ONLY: m_p, chag, lnLamb, - $ Q_e,Q_i,pr,pe,c_beta,ds,d_beta,d_i,tau,r8,mu0,pi,out_unit, ! NOT out_unit - $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q + USE sglobal_mod!, ONLY: m_p, chag, lnLamb, +c $ Q_e,Q_i,pr,pe,c_beta,ds,d_beta,d_i,tau,r8,mu0,pi,out_unit, ! NOT out_unit +c $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q,eps0,m_e USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq USE bicube_mod, ONLY: bicube_eval_external,bicube_type - USE slayer_netcdf_mod!, ONLY: slayer_netcdf_inputs + USE slayer_netcdf_mod IMPLICIT NONE diff --git a/slayer/makefile b/slayer/makefile index 6a6d33750..2326a9c91 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -55,7 +55,7 @@ sglobal.o: ../equil/local_mod.mod params.o : sglobal.o delta.o : sglobal.o gslayer.o : sglobal.o delta.o -slayer.o : sglobal.o params.o delta.o ../pentrc/grid.mod ../equil/spline_mod.mod +slayer.o : sglobal.o params.o delta.o ../equil/spline_mod.mod slayer_netcdf.o : sglobal.o clean: diff --git a/slayer/sglobal.f b/slayer/sglobal.f index c0f6d9193..527e069ce 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -5,7 +5,7 @@ MODULE sglobal_mod INTEGER :: mm,nn INTEGER :: in_unit,out_unit,out2_unit,out3_unit, $ bin_unit,bin_2d_unit,input_unit,n_trace - INTEGER, PARAMETER :: r8=SELECTED_REAL_KIND(13,307) +c INTEGER, PARAMETER :: r8=SELECTED_REAL_KIND(13,307) REAL(r8) :: mr,nr REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, diff --git a/slayer/slayer.f b/slayer/slayer.f index 438b5a2d8..ea062c8d3 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -490,11 +490,11 @@ PROGRAM slayer IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk - gamma_sol_arr(k) = g_r/tauk + gamma_sol_arr(k) = g_r!/tauk THIS IS FOR PLOT ELSE re_trace = re_trace/tauk im_trace = -im_trace/tauk - gamma_sol_arr(k) = -g_r/tauk + gamma_sol_arr(k) = -g_r!/tauk THIS IS FOR PLOT END IF ENDDO From 609787fb88bc65d13a7afe7afd2447e3400cc595 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 2 Jul 2025 15:54:04 -0400 Subject: [PATCH 040/118] toroidal Delta_crit --- input/slayer.in | 2 + slayer/gslayer.f | 17 +++--- slayer/layerinputs.f | 12 ++-- slayer/params.f | 22 ++++++-- slayer/sglobal.f | 5 +- slayer/slayer.f | 77 +++++++++++++------------- slayer/slayer_netcdf.f | 12 ++-- stride/free.f | 122 ++++++++++++++++++++++++++++++++++++++++- stride/stride_netcdf.f | 13 +++-- 9 files changed, 212 insertions(+), 70 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 23eb8a29b..8a5b514d5 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -22,6 +22,7 @@ mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma zeff=2.0 ! plasma Z_effective dr_val=-0.1 ! GGJ resistive interchange criterion D_R + dgeo_val=10.0 ! J.W. Connor geometric prefactor for Delta_crit chi_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface perpendicular ion momentum diffusivity OR perpendicular energy diffusivity profile ! >>> ! >>> Input normalized layer parameters. If read_eq=f, each will individually override internal calcuation using above inputs @@ -46,6 +47,7 @@ knum=100 ! resolution for 2d scan along with the other. Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes scan_radius=1.5 ! stability scan width for Re(Q),Im(Q) scan + dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation QPscan_flag=f ! scan (Q,P) space for delta and torque. diff --git a/slayer/gslayer.f b/slayer/gslayer.f index a663ce3b4..0b03f8dc4 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -182,9 +182,9 @@ END SUBROUTINE gpec_slayer SUBROUTINE output_gamma(est_gamma_flag,qval_arr, $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, - $ re_trace,im_trace) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ Qconv_arr,re_trace,im_trace) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: est_gamma_flag @@ -192,17 +192,18 @@ SUBROUTINE output_gamma(est_gamma_flag,qval_arr, REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace, - $ Qconv_arr + $ Im_deltaprime_arr,re_trace,im_trace, + $ Qconv_arr,d_crit_arr COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, $ gamma_sol_arr,gamma_est_arr + WRITE(*,*)'d_crit_arr',d_crit_arr CALL slayer_netcdf_out(SIZE(qval_arr),est_gamma_flag, $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, - $ re_trace,im_trace) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ Qconv_arr,re_trace,im_trace) END SUBROUTINE output_gamma c----------------------------------------------------------------------- diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 50cb53064..af68ed926 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -233,7 +233,7 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, $ Q_e_arr,Q_i_arr,c_beta_arr,d_beta_arr, $ D_norm_arr,tau_arr,P_perp_arr, $ omegas_arr,gammafac_arr,Re_deltaprime_arr, - $ Im_deltaprime_arr,delta_crit_arr) + $ Im_deltaprime_arr,d_crit_arr) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- @@ -264,7 +264,7 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, $ Q_i_arr,c_beta_arr,d_beta_arr, $ tau_arr,omegas_arr,lu_arr,Qconv_arr, $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr, - $ delta_crit_arr + $ d_crit_arr INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor @@ -310,7 +310,7 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, $ omegas_i_arr(msing),gammafac_arr(msing), $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), $ D_norm_arr(msing),P_perp_arr(msing), - $ delta_crit_arr(msing)) + $ d_crit_arr(msing)) ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing),dr_arr(msing)) @@ -467,9 +467,9 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, Wd = SQRT(8.0)*((chi/chi_par)**0.25)* $ (1.0/SQRT((my_rs/R_0)*my_sval*nr)) END DO - delta_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd + d_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd ELSE - delta_crit = 0.0 + d_crit = 0.0 END IF @@ -491,7 +491,7 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, gammafac_arr(ising) = gammafac Re_deltaprime_arr(ising) = Re_dp_diagonal(ising) Im_deltaprime_arr(ising) = Im_dp_diagonal(ising) - delta_crit_arr(ising) = delta_crit + d_crit_arr(ising) = dc_tmp P_perp_arr(ising) = P_perp Qconv_arr(ising) = tauk ENDDO diff --git a/slayer/params.f b/slayer/params.f index 2e2cf1138..ce70a8a27 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -8,10 +8,10 @@ MODULE params_mod c----------------------------------------------------------------------- c calculate parameters. c----------------------------------------------------------------------- - SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val, + SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,chi,dr_val, + REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff LOGICAL, INTENT(IN) :: params_check @@ -109,9 +109,23 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val, Wd = SQRT(8.0)*((chi/chi_par)**0.25)* $ (1.0/SQRT((rs/R0)*sval*nr)) END DO - delta_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd + + SELECT CASE(dc_type) + CASE("lar") + dc_tmp = 0.5*(-dr_val)*(pi**1.5)*((chi_par/chi)**0.25)* + $ ( (nr*sval)/(R0*rs) )**0.5 + CASE("rfitzp") + dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd + CASE("toroidal") + dc_tmp = 0.5*(-dr_val)*(pi**1.5)* + $ ((chi_par/chi)**0.25)*dgeo_val + CASE default + dc_tmp = 0.5*(-dr_val)*(pi**1.5)* + $ ((chi_par/chi)**0.25)*dgeo_val + END SELECT + ELSE - delta_crit = 0.0 + dc_tmp = 0.0 END IF ! quick diagnostics. diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 527e069ce..45b703aaa 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -11,10 +11,11 @@ MODULE sglobal_mod REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, $ d_beta,D_norm,P_perp,gamma_fac REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, - $ delta_n,layfac,Qconv,lnLamb,deltaprim, - $ delta_crit,tau_r,tauk,g_r,g_i,delta_eff + $ delta_n,layfac,Qconv,lnLamb,deltaprim,dc_tmp, + $ d_crit,tau_r,tauk,g_r,g_i,delta_eff REAL(r8), DIMENSION(:), ALLOCATABLE :: re_trace,im_trace COMPLEX(r8) :: Q,g_tmp + CHARACTER(20) :: dc_type REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6021917e-19, diff --git a/slayer/slayer.f b/slayer/slayer.f index ea062c8d3..ee575887e 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -33,7 +33,7 @@ PROGRAM slayer $ params_check,stabscan_flag,read_eq,est_gamma_flag, $ match_gamma_flag,fitz_flag,br_th_flag REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_radius, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, @@ -56,7 +56,7 @@ PROGRAM slayer INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs, $ Re_deltaprime_arr,Im_deltaprime_arr, - $ gammafac_arr,delta_crit_arr + $ gammafac_arr,d_crit_arr REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths REAL(r8) :: spot, slayer_inpr @@ -68,13 +68,14 @@ PROGRAM slayer NAMELIST/slayer_input/input_flag,infile, $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, - $ l_t,l_n,qval,mu_i,zeff,dr_val,chi_prof,inpr,inpe,inQ, - $ inQ_e,inQ_i,inc_beta,inds,intau,Q0,delta_prime,delta_n_p, - $ ingamma + $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_prof,inpr,inpe, + $ inQ,inQ_e,inQ_i,inc_beta,inds,intau,Q0,delta_prime, + $ delta_n_p,ingamma NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_radius, - $ read_eq,fitz_flag,QPscan_flag,Qscan_flag,QPescan_flag, - $ Qbscan_flag,onscan_flag,otscan_flag,ntscan_flag, - $ nbtscan_flag,parflow_flag,peohmonly_flag,Pe_flag,layfac + $ dc_type,read_eq,fitz_flag,QPscan_flag,Qscan_flag, + $ QPescan_flag,Qbscan_flag,onscan_flag,otscan_flag, + $ ntscan_flag,nbtscan_flag,parflow_flag,peohmonly_flag, + $ Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ est_gamma_flag,match_gamma_flag,stability_flag, $ stabscan_flag,br_th_flag,bal_flag @@ -101,6 +102,7 @@ PROGRAM slayer mu_i=0.0 zeff=0.0 dr_val=0.0 + dgeo_val=0.0 inQ=0.0 inQ_e=0.0 inQ_i=0.0 @@ -113,8 +115,8 @@ PROGRAM slayer inlu=0.0 Q0=0.0 chi=0.0 - dr_val=0.0 gamma_fac=0.0 + dc_type="" delta_prime=(0.0,0.0) delta_n_p=(0.0,0.0) ingamma=(0.0,0.0) @@ -184,7 +186,7 @@ PROGRAM slayer c calculate parameters as needed. c----------------------------------------------------------------------- IF (params_flag) THEN - CALL params(n_e,t_e,t_i,omega,chi,dr_val, + CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -233,8 +235,8 @@ PROGRAM slayer nr=REAL(nns(k)) inpr=prs(k) CALL params(n_es(k),t_es(k),t_is(k),omegas(k),chi,dr_val, - $ l_ns(k),l_ts(k),qvals(k),svals(k),bts(k),rss(k),R0s(k), - $ mu_is(k),zeffs(k),params_check) + $ dgeo_val,l_ns(k),l_ts(k),qvals(k),svals(k),bts(k), + $ rss(k),R0s(k),mu_is(k),zeffs(k),params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -299,8 +301,8 @@ PROGRAM slayer CALL build_inputs(infile,ncfile,chi_prof,qval_arr, $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, - $ P_perp_arr,omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr) + $ P_perp_arr,omegas_arr,gammafac_arr,Re_deltaprime_arr, + $ Im_deltaprime_arr,d_crit_arr) n_k = SIZE(qval_arr) ELSE @@ -308,7 +310,7 @@ PROGRAM slayer mr = mm nr = nn - CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val, + CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) IF (ABS(inQ) > 0.0) THEN @@ -342,7 +344,7 @@ PROGRAM slayer tau_arr = (/ tau /) D_norm_arr = (/ D_norm /) d_beta_arr = (/ d_beta /) - delta_eff = REAL(delta_prime)-delta_crit + delta_eff = REAL(delta_prime)-d_crit gamma_fac = (rs*delta_eff)/tau_r gammafac_arr = (/ gamma_fac /) END IF @@ -374,9 +376,9 @@ PROGRAM slayer CALL output_gamma(est_gamma_flag,qval_arr, $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, - $ re_trace,im_trace) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ Qconv_arr,re_trace,im_trace) END IF ENDIF c----------------------------------------------------------------------- @@ -392,7 +394,7 @@ PROGRAM slayer $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, $ P_perp_arr,omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr) n_k = SIZE(qval_arr) @@ -400,7 +402,7 @@ PROGRAM slayer n_k = 1 ! Use namelist kinetic inputs instead of equilibrium files - CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val, + CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) ! Override desired normalized parameters @@ -431,7 +433,7 @@ PROGRAM slayer psi_n_rational = (/ 0.0 /) Re_deltaprime_arr = (/ REAL(delta_prime) /) Im_deltaprime_arr = (/ AIMAG(delta_prime) /) - delta_crit_arr = (/ delta_crit /) + d_crit_arr = (/ dc_tmp /) P_perp_arr = (/ P_perp /) tau_arr = (/ tau /) D_norm_arr = (/ D_norm /) @@ -456,9 +458,10 @@ PROGRAM slayer c_beta = c_beta_arr(k) tauk = Qconv_arr(k) - ! (Deltaprime - delta_crit)/S^1/3 + ! (Deltaprime - d_crit)/S^1/3 delta_eff = (Re_deltaprime_arr(k) - - $ delta_crit_arr(k))/(lu_arr(k)**(1.0/3.0)) + $ d_crit_arr(k))/(lu_arr(k)**(1.0/3.0)) +c delta_eff = Re_deltaprime_arr(k) pe = 0.0 ALLOCATE(re_trace(100),im_trace(100)) @@ -490,11 +493,11 @@ PROGRAM slayer IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk - gamma_sol_arr(k) = g_r!/tauk THIS IS FOR PLOT + gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT ELSE re_trace = re_trace/tauk im_trace = -im_trace/tauk - gamma_sol_arr(k) = -g_r!/tauk THIS IS FOR PLOT + gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT END IF ENDDO @@ -556,9 +559,9 @@ PROGRAM slayer CALL output_gamma(est_gamma_flag,qval_arr, $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, - $ re_trace,im_trace) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ Qconv_arr,re_trace,im_trace) stop ENDIF c----------------------------------------------------------------------- @@ -568,7 +571,7 @@ PROGRAM slayer WRITE(*,*)"running br_th scan" - CALL params(n_e,t_e,t_i,omega,chi,dr_val, + CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1046,7 +1049,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chi,dr_val, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + $ dgeo_val,l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -1133,8 +1136,8 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e,t_e*ks(j,k),t_i*ks(j,k), - $ omega*js(j,k),chi,dr_val,l_n,l_t,qval,sval,bt, - $ rs,R0,mu_i,zeff,params_check) + $ omega*js(j,k),chi,dr_val,dgeo_val,l_n,l_t,qval, + $ sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -1219,8 +1222,8 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e*ks(j,k),t_e*js(j,k),t_i*js(j,k),omega, - $ chi,dr_val,l_n,l_t,qval,sval,bt,rs,R0,mu_i, - $ zeff,params_check) + $ chi,dr_val,dgeo_val,l_n,l_t,qval,sval,bt,rs,R0, + $ mu_i,zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -1305,8 +1308,8 @@ PROGRAM slayer CALL params(n_e*ks(j,k),t_e,t_i,omega,chi,dr_val, - $ l_n,l_t,qval,sval,bt*js(j,k),rs,R0,mu_i,zeff, - $ params_check) + $ dgeo_val,l_n,l_t,qval,sval,bt*js(j,k),rs,R0,mu_i, + $ zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 4b45df4c1..614f7054a 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -51,9 +51,9 @@ END SUBROUTINE sl_check SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,delta_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr,Qconv_arr, - $ re_trace,im_trace) + $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, + $ dels_db_arr,gamma_sol_arr,gamma_est_arr, + $ Qconv_arr,re_trace,im_trace) INTEGER, INTENT(IN) :: msing LOGICAL, INTENT(IN) :: est_gamma_flag @@ -61,8 +61,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,delta_crit_arr,re_trace,im_trace, - $ Qconv_arr + $ Im_deltaprime_arr,d_crit_arr,re_trace, + $ im_trace,Qconv_arr COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, $ gamma_sol_arr,gamma_est_arr @@ -179,7 +179,7 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, CALL sl_check( nf90_put_var(ncid,dpp_id, $ RESHAPE((/Re_deltaprime_arr,Im_deltaprime_arr/), $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,dc_id, delta_crit_arr)) + CALL sl_check( nf90_put_var(ncid,dc_id, d_crit_arr)) IF (est_gamma_flag) THEN CALL sl_check( nf90_put_var(ncid,dels_db_id, diff --git a/stride/free.f b/stride/free.f index b2ddcc627..5143be4d6 100755 --- a/stride/free.f +++ b/stride/free.f @@ -166,7 +166,6 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) INTEGER :: ipert,jpert,isol,info,lwork INTEGER, DIMENSION(mpert) :: m INTEGER, DIMENSION(1) :: imax - REAL(r8) :: v1 REAL(r8), DIMENSION(mpert) :: ep,ev,et REAL(r8), DIMENSION(3*mpert-1) :: rwork COMPLEX(r8) :: phase,norm @@ -174,6 +173,17 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) COMPLEX(r8), DIMENSION(mpert,mpert) :: wt,wpt,wvt COMPLEX(r8), DIMENSION(mpert,mpert) :: nmat,smat CHARACTER(24), DIMENSION(mpert) :: message + !!!!!!!!!!!!!!! + INTEGER :: ipsi,itheta + REAL(r8), DIMENSION(sq%mx+1) :: ln_q + REAL(r8), DIMENSION(msing) :: dgeo,shr + TYPE(spline_type) :: psi_t,avg_dpsi_spl,avg_bsq_spl,v_spl, + $ shr_spl + REAL(r8) :: bsq,chi1,dpsisq,myeta,jac,psifac,q,q1,respsi, + $ rfac,v1,v2,v21,v22,v23,v33,al,Lam,mytheta,myr + REAL(r8), DIMENSION(:), POINTER :: avg + TYPE(spline_type), TARGET :: fspl + !!!!!!!!!!!!!! c----------------------------------------------------------------------- c write formats. c----------------------------------------------------------------------- @@ -292,12 +302,120 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) WRITE(out_unit,80) WRITE(out_unit,90)(isol,ep(isol),ev(isol),isol=1,mpert) WRITE(out_unit,80) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c----------------------------------------------------------------------- +c compute toroidal Delta_crit +c----------------------------------------------------------------------- + ! Prepare toroidal flux spline + CALL spline_alloc(psi_t,SIZE(sq%fsi(:, 4))-1,1) + psi_t%xs=sq%xs(:) + psi_t%fs(:,1)=sq%fsi(:,4)*twopi*psio ! Un-normalize toroidal flux + CALL spline_fit(psi_t,"extrap") + + ! Prepare geometric splines + CALL spline_alloc(avg_dpsi_spl,SIZE(sq%xs(:))-1,1) + avg_dpsi_spl%xs=sq%xs(:) + CALL spline_alloc(avg_bsq_spl,SIZE(sq%xs(:))-1,1) + avg_bsq_spl%xs=sq%xs(:) + CALL spline_alloc(v_spl,SIZE(sq%xs(:))-1,1) + v_spl%xs=sq%xs(:) + + ! Prepare shear spline + CALL spline_alloc(shr_spl,SIZE(sq%xs(:))-1,1) + shr_spl%xs=sq%xs(:) + ln_q=LOG(sq%fs(:,4)) + !ln_q(SIZE(ln_q)) = ln_q(SIZE(ln_q)-1) + shr_spl%fs(:,1)=ln_q ! log(q) + CALL spline_fit(shr_spl,"extrap") + + CALL spline_alloc(fspl,mtheta,3) + fspl%xs=rzphi%ys + + DO ipsi=0,mpsi + psifac=sq%xs(ipsi) + v1=sq%fs(ipsi,3) + v2=sq%fs1(ipsi,3) + q=sq%fs(ipsi,4) + q1=sq%fs1(ipsi,4) + chi1=twopi*psio +c----------------------------------------------------------------------- +c evaluate coordinates and jacobian. +c----------------------------------------------------------------------- + DO itheta=0,mtheta + CALL bicube_eval(rzphi,rzphi%xs(ipsi),rzphi%ys(itheta),1) + mytheta=rzphi%ys(itheta) + rfac=SQRT(rzphi%f(1)) + myeta=twopi*(mytheta+rzphi%f(2)) + myr=ro+rfac*COS(myeta) + jac=rzphi%f(4) +c----------------------------------------------------------------------- +c evaluate other local quantities. +c----------------------------------------------------------------------- + v21=rzphi%fy(1)/(2*rfac*jac) + v22=(1+rzphi%fy(2))*twopi*rfac/jac + v23=rzphi%fy(3)*myr/jac + v33=twopi*myr/jac + bsq=chi1**2*(v21**2+v22**2+(v23+q*v33)**2) + dpsisq=(twopi*myr)**2*(v21**2+v22**2) +c----------------------------------------------------------------------- +c evaluate integrands. +c----------------------------------------------------------------------- + fspl%fs(itheta,1)=dpsisq*(v1**2) ! Converting to \nabla V + fspl%fs(itheta,2)=bsq + fspl%fs(itheta,3)=v1 + fspl%fs(itheta,:)=fspl%fs(itheta,:)*(jac/v1) + ENDDO +c----------------------------------------------------------------------- +c integrate quantities with respect to theta. +c----------------------------------------------------------------------- + CALL spline_fit(fspl,"periodic") + CALL spline_int(fspl) + avg => fspl%fsi(mtheta,:) + avg_dpsi_spl%fs(ipsi,1)=avg(1) + avg_bsq_spl%fs(ipsi,1)=avg(2) + v_spl%fs(ipsi,1)=avg(3) + ENDDO + CALL spline_dealloc(fspl) + + CALL spline_fit(avg_dpsi_spl,"extrap") + CALL spline_fit(avg_bsq_spl,"extrap") + CALL spline_fit(v_spl,"extrap") + + WRITE(*,*)'shr_spl%fs(:,1)=',shr_spl%fs(:,1) + WRITE(*,*)'avg_dpsi_spl%fs(:,1)=',avg_dpsi_spl%fs(:,1) + WRITE(*,*)'avg_bsq_spl%fs(:,1)=',avg_bsq_spl%fs(:,1) + WRITE(*,*)'v_spl%fs(:,1)=',v_spl%fs(:,1) + + DO ising=1,msing + respsi=sing(ising)%psifac + WRITE(*,*)"respsi=",respsi + + ! Evaluate splines on rational surface + CALL spline_eval(sq,respsi,1) + CALL spline_eval(psi_t,respsi,1) + CALL spline_eval(avg_dpsi_spl,respsi,1) + CALL spline_eval(avg_bsq_spl,respsi,1) + CALL spline_eval(v_spl,respsi,1) + CALL spline_eval(shr_spl,respsi,1) + + al = twopi*nn*sq%f(3)*(1.0/chi1) + Lam = (psi_t%f1(1)/sq%f(3))* + $ (-1.0/(sq%f(4)**2.0))*(sq%f1(4)/sq%f(3)) + WRITE(*,*)'shr_spl%f(1)=',shr_spl%f(1) + + shr(ising) = shr_spl%f(1) + dgeo(ising) = v_spl%f(1)*( (((al**2.0)*(Lam**2.0))/ + $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) + ENDDO + WRITE(*,*)'new shear=',shr + WRITE(*,*)'dgeo=',dgeo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c----------------------------------------------------------------------- c optionally write netcdf file. c----------------------------------------------------------------------- IF(present(op_netcdf_out))THEN IF(op_netcdf_out) CALL stride_netcdf_out(wp,wv,wt,ep,ev,et, - $ delta_prime_mat) + $ delta_prime_mat,shr,dgeo) ENDIF c----------------------------------------------------------------------- c deallocate diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 27e3fd5c2..e5c4d8450 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -49,12 +49,13 @@ END SUBROUTINE check c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- - SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) + SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) REAL(r8), DIMENSION(mpert), INTENT(IN) :: epi,evi,eti COMPLEX(r8), DIMENSION(mpert,mpert), INTENT(IN) :: wp,wv,wt COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: dp INTEGER, DIMENSION(mpert) :: mvec + REAL(r8), DIMENSION(msing), INTENT(IN) :: shr,dgeo INTEGER :: i, ncid,mthsur, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, @@ -62,12 +63,12 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id,drr_id + $ shear_id,resm_id,drr_id,dgeo_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile - REAL(r8) :: resnum,shear,respsi,resm_sing + REAL(r8) :: resnum,respsi,resm_sing REAL(r8), DIMENSION(msing) :: dr_rationals REAL(r8), DIMENSION(:), ALLOCATABLE :: rs_full @@ -204,6 +205,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) $ r_dim,qr_id) ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) + CALL check( nf90_def_var(ncid, "Delta_geo", nf90_double, r_dim, + $ dgeo_id) ) CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, $ resm_id) ) ENDIF @@ -277,9 +280,9 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp) ! WRITE(*,*)"SHEAR=",shear !ENDDO - CALL check( nf90_put_var(ncid,shear_id, (/(sing(i)%q1, - $ i=1,msing)/)) ) ! GPEC HAS DIFFERENT SHEAR CALC? + CALL check( nf90_put_var(ncid,shear_id, shr) ) CALL check( nf90_put_var(ncid,resm_id, resm) ) + CALL check( nf90_put_var(ncid,dgeo_id, dgeo) ) ! CALL check( nf90_put_var(ncid,shear_id,shear) ) ! GPEC HAS DIFFERENT SHEAR CALC? ENDIF From 56f9dc50fdfa5ec2e23efb11aadc50d69f8303a0 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 19 Aug 2025 19:00:51 -0400 Subject: [PATCH 041/118] WIP: SLAYER in/out struct overhaul --- slayer/gslayer.f | 52 ++++++----- slayer/layerinputs.f | 193 ++++++++++++-------------------------- slayer/sglobal.f | 15 +++ slayer/slayer.f | 204 ++++++++++++++++++++--------------------- slayer/slayer_netcdf.f | 61 ++++++------ 5 files changed, 230 insertions(+), 295 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 0b03f8dc4..9eaa11a67 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -179,33 +179,41 @@ END SUBROUTINE gpec_slayer c Subprogram 3. scan_grid c Run stability scan on real and imaginary rotation axes c----------------------------------------------------------------------- - SUBROUTINE output_gamma(est_gamma_flag,qval_arr, - $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, - $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, - $ Qconv_arr,re_trace,im_trace) + SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: est_gamma_flag - INTEGER, INTENT(IN), DIMENSION(:) :: qval_arr - REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, - $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, - $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,re_trace,im_trace, - $ Qconv_arr,d_crit_arr - COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, - $ gamma_sol_arr,gamma_est_arr - - WRITE(*,*)'d_crit_arr',d_crit_arr - CALL slayer_netcdf_out(SIZE(qval_arr),est_gamma_flag, - $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, - $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, - $ Qconv_arr,re_trace,im_trace) + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + TYPE(slayer_outputs_type), INTENT(IN) :: sl_out + + CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),est_gamma_flag, + $ sl_in,sl_out) END SUBROUTINE output_gamma + + SUBROUTINE allocate_inputs(n_k,sl_in) + INTEGER, INTENT(IN) :: n_k + TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in + + ALLOCATE(sl_in%qval_arr(n_k),sl_in%omegas_arr(n_k), + $ sl_in%Q_e_arr(n_k),sl_in%Q_i_arr(n_k),sl_in%psi_n_arr(n_k), + $ sl_in%Re_dp_arr(n_k),sl_in%Im_dp_arr(n_k), + $ sl_in%d_crit_arr(n_k), + $ sl_in%P_perp_arr(n_k),sl_in%tau_arr(n_k), + $ sl_in%D_norm_arr(n_k), + $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), + $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k)) + RETURN + END SUBROUTINE allocate_inputs + + SUBROUTINE allocate_outputs(n_k,sl_out) + INTEGER, INTENT(IN) :: n_k + TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out + + ALLOCATE(sl_out%dels_db_arr(n_k),sl_out%gamma_sol_arr(n_k), + $ sl_out%gamma_est_arr(n_k) ) + RETURN + END SUBROUTINE allocate_outputs c----------------------------------------------------------------------- c Subprogram 2. growthrate_scan c Set up and iterate stability scans IF no match is found diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index af68ed926..ceee31f4d 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -3,9 +3,8 @@ MODULE layerinputs_mod USE inputs, ONLY : read_kin,read_equil,kin,chi1 USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, $ spline_dealloc,spline_int,spline_fit - USE sglobal_mod!, ONLY: m_p, chag, lnLamb, -c $ Q_e,Q_i,pr,pe,c_beta,ds,d_beta,d_i,tau,r8,mu0,pi,out_unit, ! NOT out_unit -c $ eta,visc,rho_s,lu,omega_e,omega_i,delta_n,Q,eps0,m_e + USE sglobal_mod + USE params_mod USE netcdf USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq USE bicube_mod, ONLY: bicube_eval_external,bicube_type @@ -19,15 +18,15 @@ MODULE layerinputs_mod c Read STRIDE netcdf file for SLAYER inputs only. c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, - $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,shear, - $ r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) + $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, + $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) ! Input/Output Arguments CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ Re_dp_diagonal,Im_dp_diagonal REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, - $ psi_n_rational, shear + $ psi_n_rational, shear,dgeo REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, $ my_psio,mpsi,dr_vals INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm @@ -37,8 +36,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Internal Variables INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, - $ dp_id, qr_id,pr_id,shear_id,ro_id,bt0_id,psio_id,mpsi_id, - $ msing_id,nn_id,resm_id,drr_id ! Explicit kind for NetCDF variables + $ dp_id, qr_id,pr_id,dgeo_id,shear_id,ro_id,bt0_id,psio_id, + $ mpsi_id,msing_id,nn_id,resm_id,drr_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i @@ -93,6 +92,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, CALL sl_check(stat) stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) CALL sl_check(stat) + stat = nf90_inq_varid(ncid, "Delta_geo", dgeo_id) + CALL sl_check(stat) stat = nf90_inq_varid(ncid, "shear", shear_id) CALL sl_check(stat) stat = nf90_inq_varid(ncid, "resm", resm_id) @@ -119,6 +120,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, CALL sl_check(stat) stat = nf90_get_var(ncid, pr_id, psi_n_rational) CALL sl_check(stat) + stat = nf90_get_var(ncid, dgeo_id, dgeo) + CALL sl_check(stat) stat = nf90_get_var(ncid, shear_id, shear) CALL sl_check(stat) stat = nf90_get_var(ncid, resm_id, resm) @@ -228,19 +231,14 @@ END FUNCTION issurfint c subprogram 3. build_inputs. c build input arrays for SLAYER c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,chi_prof, - $ qval_arr,psi_n_rational,lu_arr,Qconv_arr,Q_arr, - $ Q_e_arr,Q_i_arr,c_beta_arr,d_beta_arr, - $ D_norm_arr,tau_arr,P_perp_arr, - $ omegas_arr,gammafac_arr,Re_deltaprime_arr, - $ Im_deltaprime_arr,d_crit_arr) + SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- ! Inputs CHARACTER(512), INTENT(IN) :: infile,ncfile + TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in ! Internals - REAL(r8), DIMENSION(8), INTENT(IN) :: chi_prof LOGICAL :: firstsurf REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf,ising INTEGER :: zi, zimp, mi, mimp @@ -252,26 +250,21 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, INTEGER :: mms,nns,mrs,nrs,mpsi REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0 - REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_h, + $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0,dgeo_val + REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_h,l_n,l_t, $ rho,tau_v,chi,Qconv,lbeta,qintb,gammafac REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, $ sigma_par_2,sigma_par,tau_perp,Wd,vte, $ dr_val,chi_par_smfp,chi_par_lmfp,chi_par INTEGER :: wit - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: Q_arr, - $ Q_e_arr,psi_n_rational,D_norm_arr,P_perp_arr, - $ Q_i_arr,c_beta_arr,d_beta_arr, - $ tau_arr,omegas_arr,lu_arr,Qconv_arr, - $ gammafac_arr,Re_deltaprime_arr,Im_deltaprime_arr, - $ d_crit_arr - INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: qval_arr + REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal,dr_arr, $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal,dr_vals + $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal,dr_vals, + $ psi_n_rational,dgeo REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, $ ti_arr,zeff_arr,bt_arr,rs_arr,R0_arr,mu_i_arr INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm,nns_arr @@ -285,13 +278,14 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, c Read in STRIDE netcdf c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile,msing,Re_dp_diagonal, - $ Im_dp_diagonal,q_rational,psi_n_rational, + $ Im_dp_diagonal,q_rational,psi_n_rational,dgeo, $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing WRITE(*,*)"Re_dp_diagonal=",Re_dp_diagonal WRITE(*,*)"Im_dp_diagonal=",Im_dp_diagonal WRITE(*,*)"q_rational=",q_rational WRITE(*,*)"psi_n_rational=",psi_n_rational + WRITE(*,*)"dgeo=",dgeo WRITE(*,*)"shear=",shear WRITE(*,*)"r_o=",r_o WRITE(*,*)"my_bt0=",my_bt0 @@ -302,18 +296,23 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, mpsi = INT(mpsi_arr(1)) mthsurf = 512 ! Hardcoded, but this is a default value - ALLOCATE(qval_arr(msing),Q_arr(msing),Q_e_arr(msing), - $ Q_i_arr(msing),lu_arr(msing),Qconv_arr(msing), - $ c_beta_arr(msing),d_beta_arr(msing), - $ tau_arr(msing), - $ omegas_arr(msing),omegas_e_arr(msing), - $ omegas_i_arr(msing),gammafac_arr(msing), - $ Re_deltaprime_arr(msing),Im_deltaprime_arr(msing), - $ D_norm_arr(msing),P_perp_arr(msing), - $ d_crit_arr(msing)) +c Allocate SLAYER input type arrays + ALLOCATE(sl_in%qval_arr(msing),sl_in%omegas_arr(msing), + $ sl_in%Q_e_arr(msing),sl_in%Q_i_arr(msing), + $ sl_in%psi_n_arr(msing), + $ sl_in%Re_dp_arr(msing),sl_in%Im_dp_arr(msing), + $ sl_in%d_crit_arr(msing), + $ sl_in%P_perp_arr(msing),sl_in%tau_arr(msing), + $ sl_in%D_norm_arr(msing), + $ sl_in%d_beta_arr(msing),sl_in%gammafac_arr(msing), + $ sl_in%c_beta_arr(msing),sl_in%lu_arr(msing), + $ sl_in%Qconv_arr(msing)) + +c Allocate local kinetic arrays ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), - $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing),dr_arr(msing)) + $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing),dr_arr(msing), + $ omegas_e_arr(msing),omegas_i_arr(msing)) ALLOCATE(jacs(0:mthsurf),delpsi(0:mthsurf), $ rsurf(0:mthsurf),asurf(0:mthsurf)) @@ -361,6 +360,9 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) + sl_in%omegas_e_arr(ising) = omega_e + sl_in%omegas_i_arr(ising) = omega_i + n_e = kin%f(2) t_e = kin%f(4)/e n_i = kin%f(1) @@ -369,15 +371,14 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, omega = kin%f(5) my_qval = q_rational(ising)!sq%f(4) my_sval = shear(ising) + dgeo_val = dgeo(ising) my_bt = my_bt0(1) my_rs = a_surf R_0 = r_o(1) mu_i = 2.0 dr_val = dr_vals(ising) - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - - chi = chi_prof(ising) + chi = sl_in%chi_prof_arr(ising) ne_arr(ising) = n_e te_arr(ising) = t_e @@ -396,104 +397,30 @@ SUBROUTINE build_inputs(infile,ncfile,chi_prof, nns_arr(ising) = nn(1) - lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) - - ! mu_i: ion mass ratio to proton - tau= t_i/t_e ! ratio of ion to electron temperature - tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - rho=(mu_i*m_p)*n_e ! mass density - - tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5)* - $ (eps0**2.0)*(m_e**0.5)*(t_e**1.5) - tau_ee_denom = lnLamb*(chag**2.5)*n_e - tau_ee = tau_ee_num / tau_ee_denom - - sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) / - $ (Zeff*(SQRT(2.0) + Zeff)) - sigma_par_2 = (n_e * (chag**2.0) * tau_ee) / m_e - sigma_par = sigma_par_1*sigma_par_2 - - b_l=(nr/mr)*my_rs*my_sval*my_bt/R_0 ! characteristic magnetic field - v_a=b_l/(mu0*rho)**0.5 ! alfven velocity - rho_s=1.02e-4*(mu_i*t_e)**0.5/my_bt ! ion Lamour by elec. Temp. - d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth - - tau_h=R_0*(mu0*rho)**0.5/(nr*my_sval*my_bt) ! alfven time across surface - tau_r=mu0*(my_rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale - IF (ABS(chi) > 0.0) THEN - tau_perp = ( my_rs**2.0 ) / chi - ELSE - tau_perp = 0.0 - END IF - - lu=tau_r/tau_h ! Lundquist number - - Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - tauk = Qconv - - ! note Q depends on Qconv even if omega is fixed. - Q=Qconv*omega - Q_e=Qconv*omega_e - Q_i=Qconv*omega_i - - ! This is the most critical parameter - ds=lu**(1.0/3.0)*rho_s/my_rs ! conversion based on Cole. - - lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/my_bt**2.0 - c_beta=(lbeta/(1.0+lbeta))**0.5 - - IF (ABS(tau_perp) > 0.0) THEN - P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number - ELSE - P_perp = 0.0 - END IF - ! this is using Fitzpatrick's tau', we need tau eventually - d_beta = c_beta*d_i - D_norm = (d_beta/my_rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) - - ! Calculate Delta_crit - IF (ABS(dr_val) > 0.0) THEN - vte = SQRT((2.0*(t_e*chag))/m_e) - chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ - $ (1.0+0.2535*Zeff) - - Wd = 0.1 - DO wit = 1,10 - chi_par_lmfp = (2.0*R_0*vte)/ - $ (SQRT(pi)*nr*my_sval*Wd) - chi_par = (chi_par_smfp*chi_par_lmfp)/ - $ (chi_par_smfp+chi_par_lmfp) - Wd = SQRT(8.0)*((chi/chi_par)**0.25)* - $ (1.0/SQRT((my_rs/R_0)*my_sval*nr)) - END DO - d_crit = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd - ELSE - d_crit = 0.0 - END IF - + l_n = 0.0 + l_t = 0.0 + CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i,zeff,.false.) !!!!!!!!!!! gammafac = (my_rs*Re_dp_diagonal(ising))/tau_r ! scalar to convert thickness into growth rate - qval_arr(ising) = INT(my_qval) - lu_arr(ising)=lu - Q_arr(ising)=REAL(Q) - Q_e_arr(ising)=Q_e - Q_i_arr(ising)=Q_i - c_beta_arr(ising)=c_beta - d_beta_arr(ising)=d_beta - D_norm_arr(ising)=D_norm - tau_arr(ising)=tau - omegas_arr(ising) = omega - omegas_e_arr(ising) = omega_e - omegas_i_arr(ising) = omega_i - gammafac_arr(ising) = gammafac - Re_deltaprime_arr(ising) = Re_dp_diagonal(ising) - Im_deltaprime_arr(ising) = Im_dp_diagonal(ising) - d_crit_arr(ising) = dc_tmp - P_perp_arr(ising) = P_perp - Qconv_arr(ising) = tauk + sl_in%qval_arr(ising) = INT(my_qval) + sl_in%lu_arr(ising)=lu + sl_in%Q_e_arr(ising)=Q_e + sl_in%Q_i_arr(ising)=Q_i + sl_in%c_beta_arr(ising)=c_beta + sl_in%d_beta_arr(ising)=d_beta + sl_in%D_norm_arr(ising)=D_norm + sl_in%tau_arr(ising)=tau + sl_in%omegas_arr(ising) = omega + + sl_in%gammafac_arr(ising) = gammafac + sl_in%Re_dp_arr(ising) = Re_dp_diagonal(ising) + sl_in%Im_dp_arr(ising) = Im_dp_diagonal(ising) + sl_in%d_crit_arr(ising) = dc_tmp + sl_in%P_perp_arr(ising) = P_perp + sl_in%Qconv_arr(ising) = tauk ENDDO !WRITE(*,*)"msing=",msing diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 45b703aaa..77a8699af 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -27,6 +27,21 @@ MODULE sglobal_mod INTEGER :: count END TYPE result_type + TYPE slayer_inputs_type + INTEGER, ALLOCATABLE :: qval_arr(:) + REAL(r8), ALLOCATABLE :: chi_prof_arr(:),psi_n_arr(:), + $ lu_arr(:),Qconv_arr(:),Q_e_arr(:),Q_i_arr(:),c_beta_arr(:), + $ d_beta_arr(:),D_norm_arr(:),tau_arr(:),P_perp_arr(:), + $ omegas_arr(:),omegas_e_arr(:),omegas_i_arr(:), + $ gammafac_arr(:),Re_dp_arr(:),Im_dp_arr(:),d_crit_arr(:) + END TYPE slayer_inputs_type + + TYPE slayer_outputs_type + COMPLEX(r8), ALLOCATABLE :: dels_db_arr(:),gamma_sol_arr(:), + $ gamma_est_arr(:) + REAL(r8), ALLOCATABLE :: r_trace(:,:),i_trace(:,:) + END TYPE slayer_outputs_type + ! lnLamb will be updated. COMPLEX(r8), PARAMETER :: ifac=(0,1) diff --git a/slayer/slayer.f b/slayer/slayer.f index ee575887e..bcb0aadd9 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -48,23 +48,17 @@ PROGRAM slayer REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl,bal, $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes - REAL(r8), DIMENSION(:), ALLOCATABLE :: Q_e_arr,Q_i_arr, - $ c_beta_arr,D_norm_arr,tau_arr,P_perp_arr, - $ omegas_arr,Q_arr,lu_arr,psi_n_rational, - $ d_beta_arr,Qconv_arr REAL(r8), DIMENSION(8) :: chi_prof - INTEGER, DIMENSION(:), ALLOCATABLE :: qval_arr - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs, - $ Re_deltaprime_arr,Im_deltaprime_arr, - $ gammafac_arr,d_crit_arr + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths REAL(r8) :: spot, slayer_inpr REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas, - $ dels_db_arr,lar_gamma_arr, - $ gamma_sol_arr,gamma_est_arr + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas + + TYPE(slayer_inputs_type) :: sl_in + TYPE(slayer_outputs_type) :: sl_out NAMELIST/slayer_input/input_flag,infile, $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, @@ -298,13 +292,11 @@ PROGRAM slayer IF (read_eq) THEN - CALL build_inputs(infile,ncfile,chi_prof,qval_arr, - $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, - $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, - $ P_perp_arr,omegas_arr,gammafac_arr,Re_deltaprime_arr, - $ Im_deltaprime_arr,d_crit_arr) + sl_in%chi_prof_arr = chi_prof + + CALL build_inputs(infile,ncfile,sl_in) - n_k = SIZE(qval_arr) + n_k = SIZE(sl_in%qval_arr) ELSE n_k = 1 mr = mm @@ -332,53 +324,53 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF - qval_arr = (/ qval /) - omegas_arr = (/ omega /) - Q_arr = (/ Q /) - Q_e_arr = (/ Q_e /) - Q_i_arr = (/ Q_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ REAL(delta_prime) /) - Im_deltaprime_arr = (/ AIMAG(delta_prime) /) - P_perp_arr = (/ P_perp /) - tau_arr = (/ tau /) - D_norm_arr = (/ D_norm /) - d_beta_arr = (/ d_beta /) - delta_eff = REAL(delta_prime)-d_crit - gamma_fac = (rs*delta_eff)/tau_r - gammafac_arr = (/ gamma_fac /) + CALL allocate_inputs(n_k,sl_in) + CALL allocate_outputs(n_k,sl_out) + + sl_in%qval_arr = (/ qval /) + sl_in%omegas_arr = (/ omega /) + !sl_in%Q_arr = (/ Q /) + sl_in%Q_e_arr = (/ Q_e /) + sl_in%Q_i_arr = (/ Q_i /) + sl_in%psi_n_arr = (/ 0.0 /) + sl_in%Re_dp_arr = (/ REAL(delta_prime) /) + sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) + sl_in%d_crit_arr = (/ dc_tmp /) + sl_in%P_perp_arr = (/ P_perp /) + sl_in%tau_arr = (/ tau /) + sl_in%D_norm_arr = (/ D_norm /) + sl_in%d_beta_arr = (/ d_beta /) + sl_in%gammafac_arr = (/ gamma_fac /) + sl_in%c_beta_arr = (/ c_beta /) + sl_in%lu_arr = (/ lu /) + sl_in%Qconv_arr = (/ tauk /) END IF - ALLOCATE(gamma_est_arr(n_k),dels_db_arr(n_k)) + ALLOCATE(sl_out%gamma_est_arr(n_k),sl_out%dels_db_arr(n_k)) DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate '// $ 'estimate on q = ', - $ qval_arr(k),' rational surface' + $ sl_in%qval_arr(k),' rational surface' - dels_db=riccati_del_s(Q_arr(k),Q_e_arr(k), - $ Q_i_arr(k),P_perp_arr(k),c_beta_arr(k), - $ D_norm_arr(k),tau_arr(k), - $ 5.0*D_norm_arr(k)) + dels_db=riccati_del_s(sl_in%Q_e_arr(k),sl_in%Q_e_arr(k), ! NOT using Q_arr + $ sl_in%Q_i_arr(k),sl_in%P_perp_arr(k), + $ sl_in%c_beta_arr(k),sl_in%D_norm_arr(k), + $ sl_in%tau_arr(k),5.0*sl_in%D_norm_arr(k)) - del_s = dels_db * d_beta_arr(k) + del_s = dels_db * sl_in%d_beta_arr(k) - gamma_est_arr(k) = gammafac_arr(k)/del_s - dels_db_arr(k) = dels_db + sl_out%gamma_est_arr(k) = sl_in%gammafac_arr(k)/del_s + sl_out%dels_db_arr(k) = dels_db WRITE(*,*) WRITE(*,'(A,F0.3,A)')'Growth rate estimate = ', - $ REAL(gamma_est_arr(k)),' [Hz]' - + $ REAL(sl_out%gamma_est_arr(k)),' [Hz]' + ENDDO IF (.NOT. (match_gamma_flag)) THEN - gamma_sol_arr = (/0./) - CALL output_gamma(est_gamma_flag,qval_arr, - $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, - $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, - $ Qconv_arr,re_trace,im_trace) + sl_out%gamma_sol_arr = (/0./) + CALL output_gamma(est_gamma_flag,sl_in,sl_out) END IF ENDIF c----------------------------------------------------------------------- @@ -389,14 +381,12 @@ PROGRAM slayer WRITE(*,*)">>> Calculating asymptotically matched growth rate" IF (read_eq) THEN + + sl_in%chi_prof_arr = chi_prof - CALL build_inputs(infile,ncfile,chi_prof,qval_arr, - $ psi_n_rational,lu_arr,Qconv_arr,Q_arr,Q_e_arr,Q_i_arr, - $ c_beta_arr,d_beta_arr,D_norm_arr,tau_arr, - $ P_perp_arr,omegas_arr,gammafac_arr, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr) + CALL build_inputs(infile,ncfile,sl_in) - n_k = SIZE(qval_arr) + n_k = SIZE(sl_in%qval_arr) ELSE n_k = 1 @@ -425,42 +415,45 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF - qval_arr = (/ qval /) - omegas_arr = (/ omega /) - Q_arr = (/ Q /) - Q_e_arr = (/ Q_e /) - Q_i_arr = (/ Q_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ REAL(delta_prime) /) - Im_deltaprime_arr = (/ AIMAG(delta_prime) /) - d_crit_arr = (/ dc_tmp /) - P_perp_arr = (/ P_perp /) - tau_arr = (/ tau /) - D_norm_arr = (/ D_norm /) - d_beta_arr = (/ d_beta /) - gammafac_arr = (/ gamma_fac /) - c_beta_arr = (/ c_beta /) - lu_arr = (/ lu /) - Qconv_arr = (/ tauk /) + CALL allocate_inputs(n_k,sl_in) + CALL allocate_outputs(n_k,sl_out) + + sl_in%qval_arr = (/ qval /) + sl_in%omegas_arr = (/ omega /) + !sl_in%Q_arr = (/ Q /) + sl_in%Q_e_arr = (/ Q_e /) + sl_in%Q_i_arr = (/ Q_i /) + sl_in%psi_n_arr = (/ 0.0 /) + sl_in%Re_dp_arr = (/ REAL(delta_prime) /) + sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) + sl_in%d_crit_arr = (/ dc_tmp /) + sl_in%P_perp_arr = (/ P_perp /) + sl_in%tau_arr = (/ tau /) + sl_in%D_norm_arr = (/ D_norm /) + sl_in%d_beta_arr = (/ d_beta /) + sl_in%gammafac_arr = (/ gamma_fac /) + sl_in%c_beta_arr = (/ c_beta /) + sl_in%lu_arr = (/ lu /) + sl_in%Qconv_arr = (/ tauk /) END IF - ALLOCATE(gamma_sol_arr(n_k)) + ALLOCATE(sl_out%gamma_sol_arr(n_k)) DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', - $ qval_arr(k),' rational surface:' - Q_e = Q_e_arr(k) - Q_i = Q_i_arr(k) - P_perp = P_perp_arr(k) - tau = tau_arr(k) - D_norm = D_norm_arr(k) - c_beta = c_beta_arr(k) - tauk = Qconv_arr(k) + $ sl_in%qval_arr(k),' rational surface:' + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + P_perp = sl_in%P_perp_arr(k) + tau = sl_in%tau_arr(k) + D_norm = sl_in%D_norm_arr(k) + c_beta = sl_in%c_beta_arr(k) + tauk = sl_in%Qconv_arr(k) ! (Deltaprime - d_crit)/S^1/3 - delta_eff = (Re_deltaprime_arr(k) - - $ d_crit_arr(k))/(lu_arr(k)**(1.0/3.0)) + delta_eff = (sl_in%Re_dp_arr(k) - + $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) c delta_eff = Re_deltaprime_arr(k) pe = 0.0 @@ -493,17 +486,23 @@ PROGRAM slayer IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk - gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT ELSE re_trace = re_trace/tauk im_trace = -im_trace/tauk - gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT END IF ENDDO + ALLOCATE(sl_out%r_trace(n_k,n_trace), + $ sl_out%i_trace(n_k,n_trace)) + + sl_out%r_trace(k,:) = re_trace + sl_out%i_trace(k,:) = im_trace + IF (.NOT. (est_gamma_flag)) THEN - d_beta_arr = (/ 0. /) - dels_db_arr = (/ 0. /) + sl_in%d_beta_arr = (/ 0. /) + sl_out%dels_db_arr = (/ 0. /) END IF IF (stabscan_flag) THEN @@ -556,12 +555,7 @@ PROGRAM slayer ENDIF - CALL output_gamma(est_gamma_flag,qval_arr, - $ omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, - $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, - $ Qconv_arr,re_trace,im_trace) + CALL output_gamma(est_gamma_flag,sl_in,sl_out) stop ENDIF c----------------------------------------------------------------------- @@ -626,24 +620,24 @@ PROGRAM slayer DEALLOCATE(inQs,deltal,jxbl,bal) WRITE(*,*)"allocating" - qval_arr = (/ 3 /) + sl_in%qval_arr = (/ 3 /) inQs = (/ 1.0 /) inQs = (/ 1.0 /) - n_k = SIZE(qval_arr) + n_k = SIZE(sl_in%qval_arr) - qval_arr = (/ 3 /) + sl_in%qval_arr = (/ 3 /) inQs = (/ 1.0 /) inQs = (/ 1.0 /) - omegas_arr = (/ 0.0 /) - Q_arr = (/ inQ /) - Q_e_arr = (/ inQ_e /) - Q_i_arr = (/ inQ_i /) - psi_n_rational = (/ 0.0 /) - Re_deltaprime_arr = (/ 0.0 /) - Im_deltaprime_arr = (/ 0.0 /) - P_perp_arr = (/ inpr /) + sl_in%omegas_arr = (/ 0.0 /) + !sl_in%Q_arr = (/ inQ /) + sl_in%Q_e_arr = (/ inQ_e /) + sl_in%Q_i_arr = (/ inQ_i /) + sl_in%psi_n_arr = (/ 0.0 /) + sl_in%Re_dp_arr = (/ 0.0 /) + sl_in%Im_dp_arr = (/ 0.0 /) + sl_in%P_perp_arr = (/ inpr /) WRITE(*,*)"allocations successful" diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 614f7054a..8f09f7931 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -49,22 +49,12 @@ END SUBROUTINE sl_check c declarations. c ----------------------------------------------------------------------- SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, - $ qval_arr,omegas_arr,Q_arr,Q_e_arr,Q_i_arr,d_beta_arr, - $ c_beta_arr,D_norm_arr,P_perp_arr,lu_arr,psi_n_rational, - $ Re_deltaprime_arr,Im_deltaprime_arr,d_crit_arr, - $ dels_db_arr,gamma_sol_arr,gamma_est_arr, - $ Qconv_arr,re_trace,im_trace) + $ sl_in,sl_out) INTEGER, INTENT(IN) :: msing LOGICAL, INTENT(IN) :: est_gamma_flag - INTEGER, INTENT(IN), DIMENSION(:) :: qval_arr - REAL(r8), INTENT(IN), DIMENSION(:) :: omegas_arr, - $ Q_arr,Q_e_arr,Q_i_arr,d_beta_arr,c_beta_arr,D_norm_arr, - $ P_perp_arr,lu_arr,psi_n_rational,Re_deltaprime_arr, - $ Im_deltaprime_arr,d_crit_arr,re_trace, - $ im_trace,Qconv_arr - COMPLEX(r8),INTENT(IN),DIMENSION(:) :: dels_db_arr, - $ gamma_sol_arr,gamma_est_arr + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + TYPE(slayer_outputs_type), INTENT(IN) :: sl_out INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,inpr_id,S_id, @@ -164,40 +154,41 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- - CALL sl_check( nf90_put_var(ncid,qsing_id, qval_arr)) - CALL sl_check( nf90_put_var(ncid,qr_id, qval_arr)) - CALL sl_check( nf90_put_var(ncid,pr_id, psi_n_rational)) - CALL sl_check( nf90_put_var(ncid,omegas_id, omegas_arr)) - CALL sl_check( nf90_put_var(ncid,S_id, lu_arr)) - CALL sl_check( nf90_put_var(ncid,qc_id, Qconv_arr)) - CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) - CALL sl_check( nf90_put_var(ncid,Q_e_id, Q_e_arr)) - CALL sl_check( nf90_put_var(ncid,Q_i_id, Q_i_arr)) - CALL sl_check( nf90_put_var(ncid,inpr_id, P_perp_arr)) - CALL sl_check( nf90_put_var(ncid,Dnorm_id, D_norm_arr)) + CALL sl_check( nf90_put_var(ncid,qsing_id, sl_in%qval_arr)) + CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) + CALL sl_check( nf90_put_var(ncid,pr_id, sl_in%psi_n_arr)) + CALL sl_check( nf90_put_var(ncid,omegas_id, sl_in%omegas_arr)) + CALL sl_check( nf90_put_var(ncid,S_id, sl_in%lu_arr)) + CALL sl_check( nf90_put_var(ncid,qc_id, sl_in%Qconv_arr)) + !CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) + CALL sl_check( nf90_put_var(ncid,Q_e_id, sl_in%Q_e_arr)) + CALL sl_check( nf90_put_var(ncid,Q_i_id, sl_in%Q_i_arr)) + CALL sl_check( nf90_put_var(ncid,inpr_id, sl_in%P_perp_arr)) + CALL sl_check( nf90_put_var(ncid,Dnorm_id, sl_in%D_norm_arr)) CALL sl_check( nf90_put_var(ncid,dpp_id, - $ RESHAPE((/Re_deltaprime_arr,Im_deltaprime_arr/), + $ RESHAPE((/sl_in%Re_dp_arr,sl_in%Im_dp_arr/), $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,dc_id, d_crit_arr)) + CALL sl_check( nf90_put_var(ncid,dc_id,sl_in%d_crit_arr)) IF (est_gamma_flag) THEN CALL sl_check( nf90_put_var(ncid,dels_db_id, - $ RESHAPE((/REAL(dels_db_arr),AIMAG(dels_db_arr)/), - $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,d_b_id,d_beta_arr)) + $ RESHAPE((/REAL(sl_out%dels_db_arr), + $ AIMAG(sl_out%dels_db_arr)/),(/msing,2/)))) + + CALL sl_check( nf90_put_var(ncid,d_b_id,sl_in%d_beta_arr)) CALL sl_check( nf90_put_var(ncid,ge_id, - $ RESHAPE((/REAL(gamma_est_arr),AIMAG(gamma_est_arr)/), - $ (/msing,2/)))) + $ RESHAPE((/REAL(sl_out%gamma_est_arr), + $ AIMAG(sl_out%gamma_est_arr)/),(/msing,2/)))) END IF CALL sl_check( nf90_put_var(ncid,gs_id, - $ RESHAPE((/REAL(gamma_sol_arr),AIMAG(gamma_sol_arr)/), - $ (/msing,2/)))) + $ RESHAPE((/REAL(sl_out%gamma_sol_arr), + $ AIMAG(sl_out%gamma_sol_arr)/),(/msing,2/)))) CALL sl_check( nf90_put_var(ncid,tr_id, - $ RESHAPE((/re_trace,im_trace/), - $ (/SIZE(re_trace),2/)))) + $ RESHAPE((/sl_out%r_trace,sl_out%i_trace/), + $ (/msing,SIZE(re_trace),2/)))) c ----------------------------------------------------------------------- c close file From 5ff13d58614de808e68b756e53a20e8b822ba8de Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 20 Aug 2025 15:34:23 -0400 Subject: [PATCH 042/118] working: SLAYER structs --- slayer/delta.f | 11 ++++++--- slayer/layerinputs.f | 22 +++++++++++------ slayer/params.f | 1 + slayer/slayer.f | 55 ++++++++++++++++++++++++++++++++---------- slayer/slayer_netcdf.f | 12 ++++----- 5 files changed, 72 insertions(+), 29 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index cd29ead93..970b77522 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -161,9 +161,9 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, P_hat = P_perp / D_norm**6.0 ! P_perp, 0.377 for Pperp_hat benchmark - !WRITE(*,*)"riccati_del_s inpr = ",inpr - !WRITE(*,*)"riccati_del_s Q_e = ",Q_e - !WRITE(*,*)"riccati_del_s ind_beta = ",ind_beta + Q_e = inQ_e + Q_i = inQ_i + P_perp = inpr alpha = (P_hat/(1+1/tau))**0.5 ! this is actually tau', we need tau W(1) = -alpha*my_q**2 - 0.5 @@ -236,6 +236,11 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark P_perp_hat = P_perp / D_norm**6.0 ! 0.377 for benchmark P_tor_hat = P_perp / D_norm**6.0 ! 1.15 for benchmark + + !WRITE(*,*)"w_der_del_s P_perp_hat = ",P_perp_hat + !WRITE(*,*)"w_der_del_s P_tor_hat = ",P_tor_hat + !WRITE(*,*)"w_der_del_s Q_hat = ",Q_hat + !WRITE(*,*)"w_der inpr = ",pr !WRITE(*,*)"w_der Q_e = ",Q_e !WRITE(*,*)"w_der D_beta_norm = ",D_beta_norm diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index ceee31f4d..cb2751453 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -44,6 +44,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, $ msing_len,nn_len,dr_len ! Attribute lengths + WRITE(*,*)"$^$ opening netcdf file",ncfile + ! Open the NetCDF file stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) CALL sl_check(stat) ! Error handling @@ -59,7 +61,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Allocate Arrays (based on dimension) ALLOCATE(Re_dp_diagonal(msing),q_rational(msing), - $ psi_n_rational(msing),shear(msing), + $ psi_n_rational(msing),shear(msing),dgeo(msing), $ resm(msing),Im_dp_diagonal(msing),dr_vals(msing)) ALLOCATE(delta_prime(msing, msing,2)) @@ -82,8 +84,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, !ro_id=0 ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), - $ my_psio(INT(psio_len)), - $mpsi(INT(mpsi_len)),nn(INT(nn_len))) + $ my_psio(INT(psio_len)), + $ mpsi(INT(mpsi_len)),nn(INT(nn_len))) ! Get Variable IDs stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) @@ -277,6 +279,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- c Read in STRIDE netcdf c----------------------------------------------------------------------- + CALL read_stride_netcdf_diagonal(ncfile,msing,Re_dp_diagonal, $ Im_dp_diagonal,q_rational,psi_n_rational,dgeo, $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi_arr,nn,resm) @@ -298,6 +301,8 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c Allocate SLAYER input type arrays ALLOCATE(sl_in%qval_arr(msing),sl_in%omegas_arr(msing), + $ sl_in%omegas_e_arr(msing), + $ sl_in%omegas_i_arr(msing),!sl_in%chi_prof_arr(msing), $ sl_in%Q_e_arr(msing),sl_in%Q_i_arr(msing), $ sl_in%psi_n_arr(msing), $ sl_in%Re_dp_arr(msing),sl_in%Im_dp_arr(msing), @@ -377,7 +382,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) R_0 = r_o(1) mu_i = 2.0 dr_val = dr_vals(ising) - + chi = sl_in%chi_prof_arr(ising) ne_arr(ising) = n_e @@ -396,9 +401,12 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) nrs = real(nns,4) nns_arr(ising) = nn(1) + nr = nn(1) l_n = 0.0 l_t = 0.0 + WRITE(*,*)"$^$ calling params()" + CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i,zeff,.false.) @@ -407,14 +415,14 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) sl_in%qval_arr(ising) = INT(my_qval) sl_in%lu_arr(ising)=lu - sl_in%Q_e_arr(ising)=Q_e - sl_in%Q_i_arr(ising)=Q_i + sl_in%Q_e_arr(ising)=-tauk*omega_e ! skipping params() calculation + sl_in%Q_i_arr(ising)=-tauk*omega_i ! skipping params() calculation sl_in%c_beta_arr(ising)=c_beta sl_in%d_beta_arr(ising)=d_beta sl_in%D_norm_arr(ising)=D_norm sl_in%tau_arr(ising)=tau sl_in%omegas_arr(ising) = omega - + sl_in%psi_n_arr(ising) = respsi sl_in%gammafac_arr(ising) = gammafac sl_in%Re_dp_arr(ising) = Re_dp_diagonal(ising) sl_in%Im_dp_arr(ising) = Im_dp_diagonal(ising) diff --git a/slayer/params.f b/slayer/params.f index ce70a8a27..c648c3702 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -52,6 +52,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, !tau_r=mu0*rs**2.0/eta ! resistive time scale tau_r=mu0*(rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale tau_v=tau_r/pr !rho*rs**2.0/visc ! viscous time scale + IF (ABS(chi) > 0.0) THEN tau_perp = ( rs**2.0 ) / chi ELSE diff --git a/slayer/slayer.f b/slayer/slayer.f index bcb0aadd9..28341a853 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -291,12 +291,20 @@ PROGRAM slayer WRITE(*,*)">>> Estimating growth rate" IF (read_eq) THEN + WRITE(*,*)"$^$ entered read_eq" sl_in%chi_prof_arr = chi_prof + WRITE(*,*)"$^$ entering build_inputs" + + WRITE(*,*)"$^$ infile: ",infile + WRITE(*,*)"$^$ ncfile: ",ncfile + CALL build_inputs(infile,ncfile,sl_in) n_k = SIZE(sl_in%qval_arr) + CALL allocate_outputs(n_k,sl_out) + ELSE n_k = 1 mr = mm @@ -324,7 +332,9 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF + WRITE(*,*)"$^$ entering allocate_inputs" CALL allocate_inputs(n_k,sl_in) + WRITE(*,*)"$^$ entering allocate_outputs" CALL allocate_outputs(n_k,sl_out) sl_in%qval_arr = (/ qval /) @@ -346,13 +356,22 @@ PROGRAM slayer sl_in%Qconv_arr = (/ tauk /) END IF - ALLOCATE(sl_out%gamma_est_arr(n_k),sl_out%dels_db_arr(n_k)) DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate '// $ 'estimate on q = ', $ sl_in%qval_arr(k),' rational surface' + WRITE(*,*)"sl_in%Q_e_arr(k): ",sl_in%Q_e_arr(k) + WRITE(*,*)"sl_in%Q_e_arr(k): ",sl_in%Q_e_arr(k) + WRITE(*,*)"sl_in%Q_i_arr(k): ",sl_in%Q_i_arr(k) + WRITE(*,*)"sl_in%P_perp_arr(k): ",sl_in%P_perp_arr(k) + WRITE(*,*)"sl_in%c_beta_arr(k): ",sl_in%c_beta_arr(k) + WRITE(*,*)"sl_in%D_norm_arr(k): ",sl_in%D_norm_arr(k) + WRITE(*,*)"sl_in%tau_arr(k): ",sl_in%tau_arr(k) + WRITE(*,*)"sl_in%gammafac_arr(k): ",sl_in%gammafac_arr(k) + WRITE(*,*)"sl_in%d_beta_arr(k): ",sl_in%d_beta_arr(k) + dels_db=riccati_del_s(sl_in%Q_e_arr(k),sl_in%Q_e_arr(k), ! NOT using Q_arr $ sl_in%Q_i_arr(k),sl_in%P_perp_arr(k), $ sl_in%c_beta_arr(k),sl_in%D_norm_arr(k), @@ -360,6 +379,8 @@ PROGRAM slayer del_s = dels_db * sl_in%d_beta_arr(k) + WRITE(*,*)"del_s: ",del_s + sl_out%gamma_est_arr(k) = sl_in%gammafac_arr(k)/del_s sl_out%dels_db_arr(k) = dels_db WRITE(*,*) @@ -382,15 +403,19 @@ PROGRAM slayer IF (read_eq) THEN - sl_in%chi_prof_arr = chi_prof + IF (.NOT. est_gamma_flag) THEN + sl_in%chi_prof_arr = chi_prof - CALL build_inputs(infile,ncfile,sl_in) - - n_k = SIZE(sl_in%qval_arr) + CALL build_inputs(infile,ncfile,sl_in) + n_k = SIZE(sl_in%qval_arr) + CALL allocate_outputs(n_k,sl_out) + END IF ELSE n_k = 1 + IF (.NOT. est_gamma_flag) THEN + ! Use namelist kinetic inputs instead of equilibrium files CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) @@ -415,8 +440,10 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF - CALL allocate_inputs(n_k,sl_in) - CALL allocate_outputs(n_k,sl_out) + IF (.NOT. est_gamma_flag) THEN + CALL allocate_inputs(n_k,sl_in) + CALL allocate_outputs(n_k,sl_out) + END IF sl_in%qval_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) @@ -435,10 +462,11 @@ PROGRAM slayer sl_in%c_beta_arr = (/ c_beta /) sl_in%lu_arr = (/ lu /) sl_in%Qconv_arr = (/ tauk /) - END IF - ALLOCATE(sl_out%gamma_sol_arr(n_k)) + END IF + END IF + ALLOCATE(re_trace(100),im_trace(100)) DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', @@ -457,7 +485,6 @@ PROGRAM slayer c delta_eff = Re_deltaprime_arr(k) pe = 0.0 - ALLOCATE(re_trace(100),im_trace(100)) re_trace = 0.0 im_trace = 0.0 n_trace = 1 @@ -474,15 +501,17 @@ PROGRAM slayer re_trace(1) = -Q_e END IF + WRITE(*,*)"$^$ calling newton_root(): " CALL newton_root(g_r,g_i,1,fitz_flag) WRITE(*,*) WRITE(*,'(A,F0.3,A)') 'Success! Growth rate = ', $ g_r/tauk, ' [Hz]' - CALL shrink_array(re_trace, n_trace) - CALL shrink_array(im_trace, n_trace) - + !CALL shrink_array(re_trace, n_trace) + !CALL shrink_array(im_trace, n_trace) + n_trace = 100 + IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 8f09f7931..1f06295dd 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -105,8 +105,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, IF(msing>0)THEN CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) - CALL sl_check( nf90_def_var(ncid,"qsing",nf90_int,qsing_dim, - $ qsing_id)) + CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_int, + $ qsing_dim,qsing_id)) CALL sl_check( nf90_def_dim(ncid, "step", SIZE(re_trace), $ tr_dim) ) CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, @@ -125,8 +125,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ nf90_double,qsing_dim,pr_id) ) CALL sl_check( nf90_def_var(ncid,"P",nf90_double, $ qsing_dim,inpr_id) ) - CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, - $ qsing_dim,qr_id) ) + !CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, + !$ qsing_dim,qr_id) ) END IF CALL sl_check( nf90_def_var(ncid,"D",nf90_double, @@ -148,14 +148,14 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, CALL sl_check( nf90_def_var(ncid,"growth rate", $ nf90_double,(/qsing_dim,i_dim/),gs_id) ) CALL sl_check( nf90_def_var(ncid,"growth rate trace", - $ nf90_double,(/tr_dim,i_dim/),tr_id) ) + $ nf90_double,(/qsing_dim,tr_dim,i_dim/),tr_id) ) ! end definitions CALL sl_check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- c set variables c ----------------------------------------------------------------------- CALL sl_check( nf90_put_var(ncid,qsing_id, sl_in%qval_arr)) - CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) + !CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) CALL sl_check( nf90_put_var(ncid,pr_id, sl_in%psi_n_arr)) CALL sl_check( nf90_put_var(ncid,omegas_id, sl_in%omegas_arr)) CALL sl_check( nf90_put_var(ncid,S_id, sl_in%lu_arr)) From 7e7de3fb9d96c037ee88ca39997005ca79970254 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 20 Aug 2025 17:17:22 -0400 Subject: [PATCH 043/118] WIP: P_perp and P_tor --- slayer/delta.f | 41 +++++++++++++++++++++++------------- slayer/gslayer.f | 2 +- slayer/layerinputs.f | 12 +++++++---- slayer/params.f | 41 ++++++++++++++++++++++-------------- slayer/sglobal.f | 9 ++++---- slayer/slayer.f | 47 +++++++++++++++++++++++++++++------------- slayer/slayer_netcdf.f | 13 +++++++----- 7 files changed, 107 insertions(+), 58 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 970b77522..ce8dc2d46 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -295,28 +295,40 @@ FUNCTION riccati_f(tmp_g,inx) !!!!!!!! !IF(present(inx)) my_p=inx!10.0 ! "starting backwards integration at large q" !!!!!!!! - my_p=6.0 + !my_p=6.0 xmin=1e-6 xout=xmin ! SOLVE FOR W BOUNDARY CONDITION - IF (D_norm > (P_perp**(1.0/6.0))) THEN + IF ((D_norm**2.0) > ((iota_e*P_perp)/(P_tor**(2.0/3.0)))) THEN + my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25 + IF (my_p < 6.0) THEN + my_p = 6.0 + END IF + ak = -(g_tmp + ifac*Q_e) - bk = P_perp/(2.0*(D_norm**2.0)) + bk = (iota_e*P_perp*P_tor)/(P_tor*(D_norm**2.0)) - ck_1 = 2.0*(g_tmp + ifac*Q_i)/P_perp - ck_2 = (P_perp + (g_tmp + - $ ifac*Q_i)*(D_norm**2.0))/(2.0*P_perp*(D_norm**2.0)) - ck = (P_perp/(2.0*(D_norm**2.0)))*(1 + ck_1 - ck_2) + ck = bk*(1+(g_tmp+ifac*Q_i)*((P_tor+P_perp)/(P_tor*P_perp))- + $ (P_perp+(g_tmp + + $ ifac*Q_i)*(D_norm**2.0) )*(iota_e/(P_tor*(D_norm**2.0)))) + ! ck_1 = 2.0*(g_tmp + ifac*Q_i)/P_perp + ! ck_2 = (P_perp + (g_tmp + + !$ ifac*Q_i)*(D_norm**2.0))/(2.0*P_perp*(D_norm**2.0)) + ! ck = (P_perp/(2.0*(D_norm**2.0)))*(1 + ck_1 - ck_2) - xk = (ck - SQRT(bk)*(1 - - $ SQRT(bk)*ak))/(2.0*SQRT(bk)) + xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0*SQRT(bk)) W_bound = xk - SQRT(bk)*my_p ELSE + my_p = 1.0/(P_tor**(1.0/6.0)) + IF (my_p < 6.0) THEN + my_p = 6.0 + END IF + ak = -(g_tmp + ifac*Q_e) - bk = P_perp - ck = -ifac*(Q_e - Q_i) + (g_tmp + ifac*Q_i) + bk = P_tor + ck = -ifac*(Q_e - Q_i)*(P_tor/P_perp) + (g_tmp + ifac*Q_i) xk = (ak*bk - ck)/(2.0*SQRT(bk)) W_bound = -1 + xk*my_p - SQRT(bk)*(my_p**3.0) @@ -398,11 +410,12 @@ SUBROUTINE w_der_f(neq,my_p,W,dWdp) fA = (my_p**2)/(g_tmp + ifac*Q_e + (my_p**2.0)) fA_prime = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + $ ifac*Q_e + (my_p**2.0)) - fB = g_tmp*(g_tmp + ifac*Q_i) + 2.0*(g_tmp + - $ ifac*Q_i)*P_perp*(my_p**2.0) + (P_perp**2.0)*(my_p**4.0) + fB = g_tmp*(g_tmp + ifac*Q_i) + (g_tmp + + $ ifac*Q_i)*(P_perp+P_tor)*(my_p**2.0) + + $ (P_perp*P_tor)*(my_p**4.0) fC = g_tmp + ifac*Q_e + ( P_perp + (g_tmp + $ ifac*Q_i)*(D_norm**2.0))*(my_p**2.0) + - $ 2.0*P_perp*(D_norm**2.0)*(my_p**4.0) + $ (1.0/iota_e)*P_tor*(D_norm**2.0)*(my_p**4.0) dWdp(1) = -(fA_prime/my_p)*W(1) - (W(1)**2.0)/my_p + $ (fB/(fA*fC))*(my_p**3.0) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 9eaa11a67..93c016c2d 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -198,7 +198,7 @@ SUBROUTINE allocate_inputs(n_k,sl_in) ALLOCATE(sl_in%qval_arr(n_k),sl_in%omegas_arr(n_k), $ sl_in%Q_e_arr(n_k),sl_in%Q_i_arr(n_k),sl_in%psi_n_arr(n_k), $ sl_in%Re_dp_arr(n_k),sl_in%Im_dp_arr(n_k), - $ sl_in%d_crit_arr(n_k), + $ sl_in%d_crit_arr(n_k),sl_in%P_tor_arr(n_k), $ sl_in%P_perp_arr(n_k),sl_in%tau_arr(n_k), $ sl_in%D_norm_arr(n_k), $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index cb2751453..7fb55ba8d 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -254,10 +254,11 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0,dgeo_val REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_h,l_n,l_t, - $ rho,tau_v,chi,Qconv,lbeta,qintb,gammafac + $ rho,tau_v,Qconv,lbeta,qintb,gammafac REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, $ sigma_par_2,sigma_par,tau_perp,Wd,vte, $ dr_val,chi_par_smfp,chi_par_lmfp,chi_par + REAL(r8), DIMENSION(3) :: chi_s INTEGER :: wit REAL(r8), DIMENSION(0:128) :: psitor, rhotor @@ -306,7 +307,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%Q_e_arr(msing),sl_in%Q_i_arr(msing), $ sl_in%psi_n_arr(msing), $ sl_in%Re_dp_arr(msing),sl_in%Im_dp_arr(msing), - $ sl_in%d_crit_arr(msing), + $ sl_in%d_crit_arr(msing),sl_in%P_tor_arr(msing), $ sl_in%P_perp_arr(msing),sl_in%tau_arr(msing), $ sl_in%D_norm_arr(msing), $ sl_in%d_beta_arr(msing),sl_in%gammafac_arr(msing), @@ -383,7 +384,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) mu_i = 2.0 dr_val = dr_vals(ising) - chi = sl_in%chi_prof_arr(ising) + chi_s(1) = sl_in%chi_p_arr(ising) ! chi_perp + chi_s(2) = sl_in%chi_t_arr(ising) ! chi_tor + chi_s(3) = sl_in%kappa_arr(ising) ! kappa (thermal cond.) ne_arr(ising) = n_e te_arr(ising) = t_e @@ -407,7 +410,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) l_t = 0.0 WRITE(*,*)"$^$ calling params()" - CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + CALL params(n_e,t_e,t_i,omega,chi_s,dr_val,dgeo_val, $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i,zeff,.false.) !!!!!!!!!!! @@ -428,6 +431,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) sl_in%Im_dp_arr(ising) = Im_dp_diagonal(ising) sl_in%d_crit_arr(ising) = dc_tmp sl_in%P_perp_arr(ising) = P_perp + sl_in%P_tor_arr(ising) = P_tor sl_in%Qconv_arr(ising) = tauk ENDDO diff --git a/slayer/params.f b/slayer/params.f index c648c3702..c935c7292 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -8,15 +8,16 @@ MODULE params_mod c----------------------------------------------------------------------- c calculate parameters. c----------------------------------------------------------------------- - SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff + REAL(r8), DIMENSION(3), INTENT(IN) :: chis LOGICAL, INTENT(IN) :: params_check - REAL(r8) :: rho,b_l,v_a,Qconv, + REAL(r8) :: rho,b_l,v_a,Qconv,K_val, $ lbeta,tau_i,tau_h,tau_v REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, $ sigma_par_2,sigma_par,tau_perp,Wd,vte, @@ -53,12 +54,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, tau_r=mu0*(rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale tau_v=tau_r/pr !rho*rs**2.0/visc ! viscous time scale - IF (ABS(chi) > 0.0) THEN - tau_perp = ( rs**2.0 ) / chi - ELSE - tau_perp = 0.0 - END IF - ! this one must be anomalous. calculated back from pr. visc= rho*rs**2.0/tau_v @@ -83,12 +78,25 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 c_beta=(lbeta/(1.0+lbeta))**0.5 - IF (ABS(tau_perp) > 0.0) THEN - P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number + ! CALCULATE Ps + ! chi_tor = the anomalous perpendicular ion momentum diffusivity at the rational surface + ! chi_perp = the anomalous perpendicular energy diffusivity at the rational surface + + K_val = chis(3)/eta ! kappa/eta + Csq = (c_beta**2.0 + (1.0-c_beta**2.0)*K_val ) ! = P_perp + + IF (ABS(Csq) > 0.0) THEN + P_perp = Csq ELSE - P_perp = 0.0 + tau_perp = ( rs**2.0 ) / chis(1) END IF + tau_perp = ( rs**2.0 ) / chis(1) + P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number + + tau_tor = ( rs**2.0 ) / chis(2) + P_tor = tau_r / tau_tor ! toroidal magnetic Prandtl number + ! this is using Fitzpatrick's tau', we need tau eventually d_beta = c_beta*d_i D_norm = (d_beta/rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) @@ -101,28 +109,29 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ $ (1.0+0.2535*Zeff) + ! chis(1) = chi_perp Wd = 0.1 DO wit = 1,10 chi_par_lmfp = (2.0*R0*vte)/(SQRT(pi)*nr*sval*Wd) chi_par = (chi_par_smfp*chi_par_lmfp)/ $ (chi_par_smfp+chi_par_lmfp) - Wd = SQRT(8.0)*((chi/chi_par)**0.25)* + Wd = SQRT(8.0)*((chis(1)/chi_par)**0.25)* $ (1.0/SQRT((rs/R0)*sval*nr)) END DO SELECT CASE(dc_type) CASE("lar") - dc_tmp = 0.5*(-dr_val)*(pi**1.5)*((chi_par/chi)**0.25)* + dc_tmp = 0.5*(-dr_val)*(pi**1.5)*((chi_par/chis(1))**0.25)* $ ( (nr*sval)/(R0*rs) )**0.5 CASE("rfitzp") dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd CASE("toroidal") dc_tmp = 0.5*(-dr_val)*(pi**1.5)* - $ ((chi_par/chi)**0.25)*dgeo_val + $ ((chi_par/chis(1))**0.25)*dgeo_val CASE default dc_tmp = 0.5*(-dr_val)*(pi**1.5)* - $ ((chi_par/chi)**0.25)*dgeo_val + $ ((chi_par/chis(1))**0.25)*dgeo_val END SELECT ELSE diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 77a8699af..817385600 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -9,8 +9,8 @@ MODULE sglobal_mod REAL(r8) :: mr,nr REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, - $ d_beta,D_norm,P_perp,gamma_fac - REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i, + $ d_beta,D_norm,P_perp,P_tor,gamma_fac + REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i,iota_e, $ delta_n,layfac,Qconv,lnLamb,deltaprim,dc_tmp, $ d_crit,tau_r,tauk,g_r,g_i,delta_eff REAL(r8), DIMENSION(:), ALLOCATABLE :: re_trace,im_trace @@ -29,10 +29,11 @@ MODULE sglobal_mod TYPE slayer_inputs_type INTEGER, ALLOCATABLE :: qval_arr(:) - REAL(r8), ALLOCATABLE :: chi_prof_arr(:),psi_n_arr(:), + REAL(r8), ALLOCATABLE :: chi_p_arr(:),chi_t_arr(:), + $ kappa_arr(:),psi_n_arr(:), $ lu_arr(:),Qconv_arr(:),Q_e_arr(:),Q_i_arr(:),c_beta_arr(:), $ d_beta_arr(:),D_norm_arr(:),tau_arr(:),P_perp_arr(:), - $ omegas_arr(:),omegas_e_arr(:),omegas_i_arr(:), + $ P_tor_arr(:),omegas_arr(:),omegas_e_arr(:),omegas_i_arr(:), $ gammafac_arr(:),Re_dp_arr(:),Im_dp_arr(:),d_crit_arr(:) END TYPE slayer_inputs_type diff --git a/slayer/slayer.f b/slayer/slayer.f index 28341a853..08f323068 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -41,7 +41,9 @@ PROGRAM slayer REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, - $ delta_imag,Qratio,chi + $ delta_imag,Qratio + REAL(r8), DIMENSION(3) :: chis + INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns @@ -108,7 +110,7 @@ PROGRAM slayer intau=0.0 inlu=0.0 Q0=0.0 - chi=0.0 + chis=0.0 gamma_fac=0.0 dc_type="" delta_prime=(0.0,0.0) @@ -180,7 +182,7 @@ PROGRAM slayer c calculate parameters as needed. c----------------------------------------------------------------------- IF (params_flag) THEN - CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -228,7 +230,7 @@ PROGRAM slayer mr=REAL(mms(k)) nr=REAL(nns(k)) inpr=prs(k) - CALL params(n_es(k),t_es(k),t_is(k),omegas(k),chi,dr_val, + CALL params(n_es(k),t_es(k),t_is(k),omegas(k),chis,dr_val, $ dgeo_val,l_ns(k),l_ts(k),qvals(k),svals(k),bts(k), $ rss(k),R0s(k),mu_is(k),zeffs(k),params_check) inQ=Q @@ -293,7 +295,9 @@ PROGRAM slayer IF (read_eq) THEN WRITE(*,*)"$^$ entered read_eq" - sl_in%chi_prof_arr = chi_prof + sl_in%chi_p_arr = chi_p_prof + sl_in%chi_t_arr = chi_t_prof + sl_in%kappa_arr = kappa_prof WRITE(*,*)"$^$ entering build_inputs" @@ -310,7 +314,11 @@ PROGRAM slayer mr = mm nr = nn - CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val,dgeo_val, + chis(1) = chi_p_prof(1) ! chi_perp + chis(2) = chi_t_prof(1) ! chi_tor + chis(3) = kappa_prof(1) ! kappa (thermal cond.) + + CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) IF (ABS(inQ) > 0.0) THEN @@ -347,6 +355,7 @@ PROGRAM slayer sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) sl_in%d_crit_arr = (/ dc_tmp /) sl_in%P_perp_arr = (/ P_perp /) + sl_in%P_tor_arr = (/ P_tor /) sl_in%tau_arr = (/ tau /) sl_in%D_norm_arr = (/ D_norm /) sl_in%d_beta_arr = (/ d_beta /) @@ -366,6 +375,7 @@ PROGRAM slayer WRITE(*,*)"sl_in%Q_e_arr(k): ",sl_in%Q_e_arr(k) WRITE(*,*)"sl_in%Q_i_arr(k): ",sl_in%Q_i_arr(k) WRITE(*,*)"sl_in%P_perp_arr(k): ",sl_in%P_perp_arr(k) + WRITE(*,*)"sl_in%P_tor_arr(k): ",sl_in%P_tor_arr(k) WRITE(*,*)"sl_in%c_beta_arr(k): ",sl_in%c_beta_arr(k) WRITE(*,*)"sl_in%D_norm_arr(k): ",sl_in%D_norm_arr(k) WRITE(*,*)"sl_in%tau_arr(k): ",sl_in%tau_arr(k) @@ -404,7 +414,9 @@ PROGRAM slayer IF (read_eq) THEN IF (.NOT. est_gamma_flag) THEN - sl_in%chi_prof_arr = chi_prof + sl_in%chi_p_arr = chi_p_prof + sl_in%chi_t_arr = chi_t_prof + sl_in%kappa_arr = kappa_prof CALL build_inputs(infile,ncfile,sl_in) @@ -416,8 +428,12 @@ PROGRAM slayer IF (.NOT. est_gamma_flag) THEN + chis(1) = chi_p_prof(1) ! chi_perp + chis(2) = chi_t_prof(1) ! chi_tor + chis(3) = kappa_prof(1) ! kappa (thermal cond.) + ! Use namelist kinetic inputs instead of equilibrium files - CALL params(n_e,t_e,t_i,omega,chi_prof(1),dr_val,dgeo_val, + CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) ! Override desired normalized parameters @@ -455,6 +471,7 @@ PROGRAM slayer sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) sl_in%d_crit_arr = (/ dc_tmp /) sl_in%P_perp_arr = (/ P_perp /) + sl_in%P_tor_arr = (/ P_tor /) sl_in%tau_arr = (/ tau /) sl_in%D_norm_arr = (/ D_norm /) sl_in%d_beta_arr = (/ d_beta /) @@ -474,10 +491,12 @@ PROGRAM slayer Q_e = sl_in%Q_e_arr(k) Q_i = sl_in%Q_i_arr(k) P_perp = sl_in%P_perp_arr(k) + P_tor = sl_in%P_tor_arr(k) tau = sl_in%tau_arr(k) D_norm = sl_in%D_norm_arr(k) c_beta = sl_in%c_beta_arr(k) tauk = sl_in%Qconv_arr(k) + iota_e = Q_e / (Q_e - Q_i) ! (Deltaprime - d_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - @@ -511,7 +530,7 @@ PROGRAM slayer !CALL shrink_array(re_trace, n_trace) !CALL shrink_array(im_trace, n_trace) n_trace = 100 - + IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk @@ -594,7 +613,7 @@ PROGRAM slayer WRITE(*,*)"running br_th scan" - CALL params(n_e,t_e,t_i,omega,chi,dr_val,dgeo_val, + CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1071,7 +1090,7 @@ PROGRAM slayer DO k=0,knum ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) - CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chi,dr_val, + CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chis,dr_val, $ dgeo_val,l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1159,7 +1178,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e,t_e*ks(j,k),t_i*ks(j,k), - $ omega*js(j,k),chi,dr_val,dgeo_val,l_n,l_t,qval, + $ omega*js(j,k),chis,dr_val,dgeo_val,l_n,l_t,qval, $ sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1245,7 +1264,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) CALL params(n_e*ks(j,k),t_e*js(j,k),t_i*js(j,k),omega, - $ chi,dr_val,dgeo_val,l_n,l_t,qval,sval,bt,rs,R0, + $ chis,dr_val,dgeo_val,l_n,l_t,qval,sval,bt,rs,R0, $ mu_i,zeff,params_check) inQ=Q inQ_e=Q_e @@ -1330,7 +1349,7 @@ PROGRAM slayer ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) - CALL params(n_e*ks(j,k),t_e,t_i,omega,chi,dr_val, + CALL params(n_e*ks(j,k),t_e,t_i,omega,chis,dr_val, $ dgeo_val,l_n,l_t,qval,sval,bt*js(j,k),rs,R0,mu_i, $ zeff,params_check) inQ=Q diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 1f06295dd..df20f48c5 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -57,9 +57,9 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, TYPE(slayer_outputs_type), INTENT(IN) :: sl_out INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, - $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,inpr_id,S_id, + $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,p_perp_id,S_id, $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,tr_id,tr_dim, - $ qsing_id,qc_id + $ qsing_id,qc_id,p_tor_id INTEGER :: run, run_dimid, point_dimid, varids(4) @@ -123,8 +123,10 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ qsing_dim,S_id)) CALL sl_check( nf90_def_var(ncid,"psi_n_rational", $ nf90_double,qsing_dim,pr_id) ) - CALL sl_check( nf90_def_var(ncid,"P",nf90_double, - $ qsing_dim,inpr_id) ) + CALL sl_check( nf90_def_var(ncid,"P_perp",nf90_double, + $ qsing_dim,p_perp_id) ) + CALL sl_check( nf90_def_var(ncid,"P_tor",nf90_double, + $ qsing_dim,p_tor_id) ) !CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, !$ qsing_dim,qr_id) ) END IF @@ -163,7 +165,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, !CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) CALL sl_check( nf90_put_var(ncid,Q_e_id, sl_in%Q_e_arr)) CALL sl_check( nf90_put_var(ncid,Q_i_id, sl_in%Q_i_arr)) - CALL sl_check( nf90_put_var(ncid,inpr_id, sl_in%P_perp_arr)) + CALL sl_check( nf90_put_var(ncid,p_perp_id, sl_in%P_perp_arr)) + CALL sl_check( nf90_put_var(ncid,p_tor_id, sl_in%P_tor_arr)) CALL sl_check( nf90_put_var(ncid,Dnorm_id, sl_in%D_norm_arr)) CALL sl_check( nf90_put_var(ncid,dpp_id, From 762f854b343707bd76bfc452b1027bc7b3257c18 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 21 Aug 2025 14:43:38 -0400 Subject: [PATCH 044/118] WIP: 2x2 coupling --- input/slayer.in | 9 ++- slayer/gslayer.f | 40 ++++++++++++ slayer/layerinputs.f | 29 +++++---- slayer/params.f | 7 +-- slayer/sglobal.f | 5 +- slayer/slayer.f | 141 +++++++++++++++++++++++++++++++++++-------- 6 files changed, 184 insertions(+), 47 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 8a5b514d5..dd0230d69 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -23,7 +23,9 @@ zeff=2.0 ! plasma Z_effective dr_val=-0.1 ! GGJ resistive interchange criterion D_R dgeo_val=10.0 ! J.W. Connor geometric prefactor for Delta_crit - chi_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface perpendicular ion momentum diffusivity OR perpendicular energy diffusivity profile + chi_p_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular energy diffusivity profile + chi_t_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular ion momentum diffusivity profile + kappa_prof=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 ! Rational surface thermal conductivity profile (NOTE: set > 0 to override chi_p_prof) ! >>> ! >>> Input normalized layer parameters. If read_eq=f, each will individually override internal calcuation using above inputs ! >>> @@ -46,10 +48,11 @@ jnum=100 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan along with the other. Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes - scan_radius=1.5 ! stability scan width for Re(Q),Im(Q) scan + scan_width=1.5 ! stability scan width for Re(Q),Im(Q) scan dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 - fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation + fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation + coupling_flag=t ! Solve determinant problem and output 2D scan QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space QPescan_flag=f ! scan (Q,Pe) space for delta and torque. diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 93c016c2d..ccf5dbbad 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -374,6 +374,46 @@ SUBROUTINE grow_array(arr, old_size, new_size) END SUBROUTINE grow_array c c +c +c----------------------------------------------------------------------- +c Subprogram 6. determinant +c Increase scan array size IF necessary +c----------------------------------------------------------------------- + SUBROUTINE calc_determinant(matk, nk, detk) + IMPLICIT NONE + + ! Arguments + INTEGER, INTENT(IN) :: nk ! Matrix size (2 or 3) + COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! Input matrix + COMPLEX(r8), INTENT(OUT) :: detk ! Determinant result + INTEGER :: status ! Status (0=success, -1=error) + + ! Local variables + + status = 0 ! Initialize status as success + + SELECT CASE (nk) + CASE (2) + ! 2x2 determinant: ad - bc + detk = matk(1,1) * matk(2,2) - matk(1,2) * matk(2,1) + + CASE (3) + ! 3x3 determinant using cofactor expansion along first row + detk = matk(1,1)*(matk(2,2)*matk(3,3)-matk(2,3) + $ *matk(3,2))-matk(1,2)*(matk(2,1)*matk(3,3) + $ -matk(2,3)*matk(3,1))+matk(1,3)*(matk(2,1) + $ *matk(3,2)-matk(2,2)*matk(3,1)) + + CASE default + ! Unsupported matrix size + detk = (0.0, 0.0) + status = -1 + + END SELECT + RETURN + END SUBROUTINE calc_determinant +c +c c Adapted from SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) LOGICAL, INTENT(IN) :: fitz_flag diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 7fb55ba8d..dd2adeec1 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -17,7 +17,7 @@ MODULE layerinputs_mod c subprogram 1. read_stride_netcdf_diagonal. c Read STRIDE netcdf file for SLAYER inputs only. c----------------------------------------------------------------------- - SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, + SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) @@ -25,6 +25,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, CHARACTER(512), INTENT(IN) :: ncfile REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ Re_dp_diagonal,Im_dp_diagonal + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT):: dp_mat REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, $ psi_n_rational, shear,dgeo REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, @@ -39,7 +40,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, $ dp_id, qr_id,pr_id,dgeo_id,shear_id,ro_id,bt0_id,psio_id, $ mpsi_id,msing_id,nn_id,resm_id,drr_id ! Explicit kind for NetCDF variables INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: delta_prime INTEGER :: i INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, $ msing_len,nn_len,dr_len ! Attribute lengths @@ -63,7 +63,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ALLOCATE(Re_dp_diagonal(msing),q_rational(msing), $ psi_n_rational(msing),shear(msing),dgeo(msing), $ resm(msing),Im_dp_diagonal(msing),dr_vals(msing)) - ALLOCATE(delta_prime(msing, msing,2)) + ALLOCATE(dp_mat(msing, msing,2)) stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) CALL sl_check(stat) @@ -114,8 +114,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, stat = nf90_get_att(ncid, nn_id, "n", nn) CALL sl_check(stat) - ! Read the diagonal of delta_prime. The results will be put on a 1D temporary array. - stat = nf90_get_var(ncid, dp_id, delta_prime,start=(/ 1,1,1 /)) + ! Read the diagonal of delta prime. The results will be put on a 1D temporary array. + stat = nf90_get_var(ncid, dp_id, dp_mat,start=(/ 1,1,1 /)) CALL sl_check(stat) ! Read 1D variables stat = nf90_get_var(ncid, qr_id, q_rational) @@ -133,11 +133,10 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing, ! Extract Diagonal, with 3rd index signifying REAL part DO i = 1, msing - Re_dp_diagonal(i) = delta_prime(i, i, 1) - Im_dp_diagonal(i) = delta_prime(i, i, 2) + Re_dp_diagonal(i) = dp_mat(i, i, 1) + Im_dp_diagonal(i) = dp_mat(i, i, 2) END DO ! Clean Up - DEALLOCATE(delta_prime) stat = nf90_close(ncid) CALL sl_check(stat) @@ -263,7 +262,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8), DIMENSION(0:128) :: psitor, rhotor REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor - + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: dp_mat REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal,dr_arr, $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal,dr_vals, @@ -281,9 +280,10 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c Read in STRIDE netcdf c----------------------------------------------------------------------- - CALL read_stride_netcdf_diagonal(ncfile,msing,Re_dp_diagonal, - $ Im_dp_diagonal,q_rational,psi_n_rational,dgeo, - $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi_arr,nn,resm) + CALL read_stride_netcdf_diagonal(ncfile,msing,dp_mat, + $ Re_dp_diagonal,Im_dp_diagonal,q_rational, + $ psi_n_rational,dgeo,shear,r_o,my_bt0,my_psio,dr_vals, + $ mpsi_arr,nn,resm) WRITE(*,*)"msing_out=",msing WRITE(*,*)"Re_dp_diagonal=",Re_dp_diagonal WRITE(*,*)"Im_dp_diagonal=",Im_dp_diagonal @@ -302,7 +302,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c Allocate SLAYER input type arrays ALLOCATE(sl_in%qval_arr(msing),sl_in%omegas_arr(msing), - $ sl_in%omegas_e_arr(msing), + $ sl_in%omegas_e_arr(msing),sl_in%dp_matrix(msing,msing), $ sl_in%omegas_i_arr(msing),!sl_in%chi_prof_arr(msing), $ sl_in%Q_e_arr(msing),sl_in%Q_i_arr(msing), $ sl_in%psi_n_arr(msing), @@ -342,6 +342,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) CALL equil_read(out_unit) + ! Input Delta' matrix + sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1),dp_mat(:,:,2)) + c----------------------------------------------------------------------- c loop across singular surfaces, evaluate spline quantities. c----------------------------------------------------------------------- diff --git a/slayer/params.f b/slayer/params.f index c935c7292..088c29b7b 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -17,7 +17,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, LOGICAL, INTENT(IN) :: params_check - REAL(r8) :: rho,b_l,v_a,Qconv,K_val, + REAL(r8) :: rho,b_l,v_a,Qconv,K_val,Csq,tau_tor, $ lbeta,tau_i,tau_h,tau_v REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, $ sigma_par_2,sigma_par,tau_perp,Wd,vte, @@ -122,7 +122,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, SELECT CASE(dc_type) CASE("lar") - dc_tmp = 0.5*(-dr_val)*(pi**1.5)*((chi_par/chis(1))**0.25)* + dc_tmp=0.5*(-dr_val)*(pi**1.5)*((chi_par/chis(1))**0.25)* $ ( (nr*sval)/(R0*rs) )**0.5 CASE("rfitzp") dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd @@ -130,8 +130,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, dc_tmp = 0.5*(-dr_val)*(pi**1.5)* $ ((chi_par/chis(1))**0.25)*dgeo_val CASE default - dc_tmp = 0.5*(-dr_val)*(pi**1.5)* - $ ((chi_par/chis(1))**0.25)*dgeo_val + dc_tmp = 0.0 END SELECT ELSE diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 817385600..a91bf55a5 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -35,6 +35,7 @@ MODULE sglobal_mod $ d_beta_arr(:),D_norm_arr(:),tau_arr(:),P_perp_arr(:), $ P_tor_arr(:),omegas_arr(:),omegas_e_arr(:),omegas_i_arr(:), $ gammafac_arr(:),Re_dp_arr(:),Im_dp_arr(:),d_crit_arr(:) + COMPLEX(r8), ALLOCATABLE :: dp_matrix(:,:) END TYPE slayer_inputs_type TYPE slayer_outputs_type @@ -47,6 +48,6 @@ MODULE sglobal_mod COMPLEX(r8), PARAMETER :: ifac=(0,1) - CHARACTER(2) :: sn - + CHARACTER(2) :: sn,sm + END MODULE sglobal_mod diff --git a/slayer/slayer.f b/slayer/slayer.f index 08f323068..c969e3fb5 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -31,26 +31,26 @@ PROGRAM slayer $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,stabscan_flag,read_eq,est_gamma_flag, - $ match_gamma_flag,fitz_flag,br_th_flag - REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_radius, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val + $ match_gamma_flag,fitz_flag,coupling_flag,br_th_flag + REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_width,l_n,l_t, + $ qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, - $ tmp_gamma,ingamma,delta_prime + $ tmp_gamma,ingamma,delta_prime,det_val REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, $ delta_imag,Qratio - REAL(r8), DIMENSION(3) :: chis - + REAL(r8) :: chis(3) + COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:),result_matrix(:,:) INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl,bal, $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes - REAL(r8), DIMENSION(8) :: chi_prof + REAL(r8), DIMENSION(8) :: chi_p_prof, chi_t_prof, kappa_prof REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs REAL(r8), DIMENSION(:,:), ALLOCATABLE :: $ js,ks,psis,jxbs,Q_sols,br_ths @@ -64,12 +64,12 @@ PROGRAM slayer NAMELIST/slayer_input/input_flag,infile, $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, - $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_prof,inpr,inpe, - $ inQ,inQ_e,inQ_i,inc_beta,inds,intau,Q0,delta_prime, - $ delta_n_p,ingamma - NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_radius, - $ dc_type,read_eq,fitz_flag,QPscan_flag,Qscan_flag, - $ QPescan_flag,Qbscan_flag,onscan_flag,otscan_flag, + $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_p_prof, + $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,Q0,delta_prime,delta_n_p,ingamma + NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, + $ dc_type,read_eq,fitz_flag,coupling_flag,QPscan_flag, + $ Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag,otscan_flag, $ ntscan_flag,nbtscan_flag,parflow_flag,peohmonly_flag, $ Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, @@ -103,7 +103,9 @@ PROGRAM slayer inQ_e=0.0 inQ_i=0.0 inpr=0.0 - chi_prof=0.0 + chi_p_prof=0.0 + chi_t_prof=0.0 + kappa_prof=0.0 inpe=0.0 inc_beta=0.0 inds=0.0 @@ -120,7 +122,7 @@ PROGRAM slayer jnum=500 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan alont with the other. Q_num=100 ! resolution for stab. scan along Re(Q) axis - scan_radius = 2.0 + scan_width = 2.0 in_unit=1 out_unit=2 out2_unit=3 @@ -132,6 +134,7 @@ PROGRAM slayer est_gamma_flag=.FALSE. match_gamma_flag=.FALSE. fitz_flag=.FALSE. + coupling_flag=.FALSE. QPscan_flag=.FALSE. ! scan (Q,P) space for delta and torque. QPescan_flag=.FALSE. ! scan (Q,Pe) space for delta and torque. Qbscan_flag=.FALSE. ! scan (Q,beta) space for delta and torque. @@ -178,6 +181,12 @@ PROGRAM slayer ELSE WRITE(UNIT=sn,FMT='(I2)') nn ENDIF + IF (mm<10) THEN + WRITE(UNIT=sm,FMT='(I1)') nn + sm=ADJUSTL(sm) + ELSE + WRITE(UNIT=sm,FMT='(I2)') nn + ENDIF c----------------------------------------------------------------------- c calculate parameters as needed. c----------------------------------------------------------------------- @@ -484,6 +493,8 @@ PROGRAM slayer END IF ALLOCATE(re_trace(100),im_trace(100)) + ALLOCATE(sl_out%r_trace(n_k,100), + $ sl_out%i_trace(n_k,100)) DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', @@ -542,9 +553,6 @@ PROGRAM slayer END IF ENDDO - ALLOCATE(sl_out%r_trace(n_k,n_trace), - $ sl_out%i_trace(n_k,n_trace)) - sl_out%r_trace(k,:) = re_trace sl_out%i_trace(k,:) = im_trace @@ -557,9 +565,9 @@ PROGRAM slayer WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// $ 'Im(Q)] scan with radius = ', - $ scan_radius + $ scan_width - ing_step = (2.0 * scan_radius) / (Q_num - 1) + ing_step = (2.0 * scan_width) / (Q_num - 1) count = 0 ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) @@ -567,8 +575,8 @@ PROGRAM slayer DO i = 1, (Q_num+1) DO j = 1, Q_num - ing_coarse = -scan_radius + (i - 1) * ing_step - iing_coarse = -scan_radius + (j - 1) * ing_step + ing_coarse = -scan_width + (i - 1) * ing_step + iing_coarse = -scan_width + (j - 1) * ing_step ! Evaluate riccati function g_tmp = CMPLX(ing_coarse,iing_coarse) IF (fitz_flag) THEN @@ -589,7 +597,7 @@ PROGRAM slayer ENDDO OPEN(UNIT=out_unit,FILE="slayer_stability_n"// - $ TRIM(sn)//".out", STATUS="UNKNOWN") + $ TRIM(sn)//"m"//TRIM(sm)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" DO i=1,Q_num+1 @@ -603,6 +611,88 @@ PROGRAM slayer ENDIF + IF (coupling_flag) THEN + WRITE(*,*)"------------------------------------------" + WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// + $ 'Im(Q)] determinant scan with radius = ', + $ scan_width + + ing_step = (2.0 * scan_width) / (Q_num - 1) + count = 0 + + IF (.NOT. stabscan_flag) THEN + ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) + ALLOCATE(deltas(1:(Q_num+1),1:Q_num)) + END IF + + inQs=0.0; iinQs=0.0; deltas=(0.0,0.0) + ALLOCATE(delta_Q(n_k,n_k)) + delta_Q=(0.0,0.0) + + DO i = 1, (Q_num+1) + DO j = 1, Q_num + ing_coarse = -scan_width + (i - 1) * ing_step + iing_coarse = -scan_width + (j - 1) * ing_step + inQs(i) = ing_coarse + iinQs(j) = iing_coarse + + ! Evaluate riccati function + g_tmp = CMPLX(ing_coarse,iing_coarse) + IF (n_k == 1) THEN + WRITE(*,*)"Error: no coupling for msing = 1" + stop + ELSEIF (n_k == 2) THEN + DO k=1,2 + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + P_perp = sl_in%P_perp_arr(k) + P_tor = sl_in%P_tor_arr(k) + tau = sl_in%tau_arr(k) + D_norm = sl_in%D_norm_arr(k) + c_beta = sl_in%c_beta_arr(k) + tauk = sl_in%Qconv_arr(k) + iota_e = Q_e / (Q_e - Q_i) + + ! (Deltaprime - d_crit)/S^1/3 + delta_eff = (sl_in%Re_dp_arr(k) - + $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) + + delta=riccati_f(((g_tmp*sl_in%Qconv_arr(1))/ + $ tauk)) + delta_Q(k,k) = delta + END DO + + ! Calculate Deltaprime - Delta(Q) + result_matrix = sl_in%dp_matrix - delta_Q + + ! Calculate determinant + CALL calc_determinant(result_matrix, n_k, det_val) + deltas(i,j) = det_val + ELSEIF (n_k == 3) THEN + WRITE(*,*)"Error: no support for msing = 3" + stop + ELSE + WRITE(*,*)"Error: no support for msing < 3" + stop + END IF + ENDDO + ENDDO + + OPEN(UNIT=out_unit,FILE="slayer_determinants_n"// + $ TRIM(sn)//".out", STATUS="UNKNOWN") + WRITE(out_unit,'(1x,4(a17))') "RE(Q)", + $ "IM(Q)","RE(det)","IM(det)" + DO i=1,Q_num+1 + DO j=1,Q_num + WRITE(out_unit,'(1x,4(es17.8e3))') + $ inQs(i),iinQs(j), + $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) + ENDDO + ENDDO + CLOSE(out_unit) + + END IF + CALL output_gamma(est_gamma_flag,sl_in,sl_out) stop ENDIF @@ -1090,8 +1180,9 @@ PROGRAM slayer DO k=0,knum ks(j,k)=k_min+(k_max-k_min)*(REAL(k)/knum) - CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chis,dr_val, - $ dgeo_val,l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + CALL params(n_e*ks(j,k),t_e,t_i,omega*js(j,k),chis, + $ dr_val,dgeo_val,l_n,l_t,qval,sval,bt,rs, + $ R0,mu_i,zeff,params_check) inQ=Q inQ_e=Q_e inQ_i=Q_i From b90a844b46b78ce07da1248d04e8ac2ea3b7e6d8 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 11 Sep 2025 23:14:34 -0400 Subject: [PATCH 045/118] WIP: improved scan logic --- slayer/layerinputs.f | 4 +- slayer/params.f | 20 ++++++- slayer/slayer.f | 130 ++++++++++++++++++++++++----------------- slayer/slayer_netcdf.f | 10 +++- 4 files changed, 104 insertions(+), 60 deletions(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index dd2adeec1..be8f64e8a 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -376,7 +376,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) t_e = kin%f(4)/e n_i = kin%f(1) t_i = kin%f(3)/e - zeff = kin%f(9) + + zeff = 2.0!kin%f(9) + omega = kin%f(5) my_qval = q_rational(ising)!sq%f(4) my_sval = shear(ising) diff --git a/slayer/params.f b/slayer/params.f index 088c29b7b..dcf069788 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -24,6 +24,10 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ chi_par_smfp,chi_par_lmfp,chi_par INTEGER :: wit + WRITE(*,*)"params.f n_e: ",n_e + WRITE(*,*)"params.f t_e: ",t_e + WRITE(*,*)"params.f t_i: ",t_i + lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) ! mu_i: ion mass ratio to proton @@ -108,6 +112,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, vte = SQRT((2.0*(t_e*chag))/m_e) chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ $ (1.0+0.2535*Zeff) + WRITE(*,*)"params.f Zeff: ",Zeff ! chis(1) = chi_perp Wd = 0.1 @@ -118,7 +123,16 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ (chi_par_smfp+chi_par_lmfp) Wd = SQRT(8.0)*((chis(1)/chi_par)**0.25)* $ (1.0/SQRT((rs/R0)*sval*nr)) + END DO + WRITE(*,*)"params.f Wd: ",Wd + WRITE(*,*)"params.f chis(1): ",chis(1) + WRITE(*,*)"params.f chis(2): ",chis(2) + WRITE(*,*)"params.f chis(3): ",chis(3) + WRITE(*,*)"params.f rs: ",rs + WRITE(*,*)"params.f R0: ",R0 + WRITE(*,*)"params.f sval: ",sval + WRITE(*,*)"params.f nr: ",nr SELECT CASE(dc_type) CASE("lar") @@ -133,6 +147,10 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, dc_tmp = 0.0 END SELECT + WRITE(*,*)"params.f dr_val: ",dr_val + WRITE(*,*)"params.f dgeo_val: ",dgeo_val + WRITE(*,*)"params.f dc_tmp: ",dc_tmp + ELSE dc_tmp = 0.0 END IF @@ -151,4 +169,4 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, RETURN END SUBROUTINE params - END MODULE params_mod + END MODULE params_mod \ No newline at end of file diff --git a/slayer/slayer.f b/slayer/slayer.f index c969e3fb5..703722053 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -181,12 +181,6 @@ PROGRAM slayer ELSE WRITE(UNIT=sn,FMT='(I2)') nn ENDIF - IF (mm<10) THEN - WRITE(UNIT=sm,FMT='(I1)') nn - sm=ADJUSTL(sm) - ELSE - WRITE(UNIT=sm,FMT='(I2)') nn - ENDIF c----------------------------------------------------------------------- c calculate parameters as needed. c----------------------------------------------------------------------- @@ -495,6 +489,10 @@ PROGRAM slayer ALLOCATE(re_trace(100),im_trace(100)) ALLOCATE(sl_out%r_trace(n_k,100), $ sl_out%i_trace(n_k,100)) + + !-------------- + n_k = 1 + !-------------- DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', @@ -509,6 +507,18 @@ PROGRAM slayer tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) + WRITE(*,*)"slayer.f Q_e: ",Q_e + WRITE(*,*)"slayer.f Q_i: ",Q_i + WRITE(*,*)"slayer.f P_perp: ",P_perp + WRITE(*,*)"slayer.f P_tor: ",P_tor + WRITE(*,*)"slayer.f tau: ",tau + WRITE(*,*)"slayer.f D_norm: ",D_norm + WRITE(*,*)"slayer.f tauk: ",tauk + + WRITE(*,*)"slayer.f iota_e: ",iota_e + WRITE(*,*)"slayer.f D_prime: ",sl_in%Re_dp_arr(k) + WRITE(*,*)"slayer.f D_crit: ",sl_in%d_crit_arr(k) + ! (Deltaprime - d_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) @@ -545,71 +555,80 @@ PROGRAM slayer IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk - sl_out%gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = 0.0!g_r/tauk! THIS IS FOR PLOT ELSE re_trace = re_trace/tauk im_trace = -im_trace/tauk - sl_out%gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = 0.0!-g_r/tauk! THIS IS FOR PLOT END IF - ENDDO - sl_out%r_trace(k,:) = re_trace - sl_out%i_trace(k,:) = im_trace - - IF (.NOT. (est_gamma_flag)) THEN - sl_in%d_beta_arr = (/ 0. /) - sl_out%dels_db_arr = (/ 0. /) - END IF - - IF (stabscan_flag) THEN - WRITE(*,*)"------------------------------------------" - WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// + IF (stabscan_flag) THEN + WRITE(*,*)"------------------------------------------" + WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// $ 'Im(Q)] scan with radius = ', $ scan_width - ing_step = (2.0 * scan_width) / (Q_num - 1) - count = 0 - - ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) - ALLOCATE(deltas(1:(Q_num+1),1:Q_num)) - - DO i = 1, (Q_num+1) - DO j = 1, Q_num - ing_coarse = -scan_width + (i - 1) * ing_step - iing_coarse = -scan_width + (j - 1) * ing_step - ! Evaluate riccati function - g_tmp = CMPLX(ing_coarse,iing_coarse) - IF (fitz_flag) THEN - delta=riccati_f(g_tmp) - ELSE - delta=riccati(iing_coarse,Q_e,Q_i,P_perp, + ing_step = (2.0 * scan_width) / (Q_num - 1) + count = 0 + + ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) + ALLOCATE(deltas(1:(Q_num+1),1:Q_num)) + + DO i = 1, (Q_num+1) + DO j = 1, Q_num + ing_coarse = -scan_width + (i - 1) * ing_step + iing_coarse = -scan_width + (j - 1) * ing_step + ! Evaluate riccati function + g_tmp = CMPLX(ing_coarse,iing_coarse) + IF (fitz_flag) THEN + delta=riccati_f(g_tmp) + ELSE + delta=riccati(iing_coarse,Q_e,Q_i,P_perp, $ c_beta,D_norm,tau,pe, $ iinQ=ing_coarse) - END IF - inQs(i) = ing_coarse - IF (fitz_flag) THEN - iinQs(j) = iing_coarse - ELSE - iinQs(j) = -iing_coarse - END IF - deltas(i,j) = delta + END IF + inQs(i) = ing_coarse + IF (fitz_flag) THEN + iinQs(j) = iing_coarse + ELSE + iinQs(j) = -iing_coarse + END IF + deltas(i,j) = delta + ENDDO ENDDO - ENDDO - OPEN(UNIT=out_unit,FILE="slayer_stability_n"// + + IF (k<10) THEN + WRITE(UNIT=sm,FMT='(I1)') sl_in%qval_arr(k) + sm=ADJUSTL(sm) + ELSE + WRITE(UNIT=sm,FMT='(I2)') sl_in%qval_arr(k) + ENDIF + + OPEN(UNIT=out_unit,FILE="slayer_stability_n"// $ TRIM(sn)//"m"//TRIM(sm)//".out", STATUS="UNKNOWN") - WRITE(out_unit,'(1x,4(a17))') "RE(Q)", + WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" - DO i=1,Q_num+1 - DO j=1,Q_num - WRITE(out_unit,'(1x,4(es17.8e3))') + DO i=1,Q_num+1 + DO j=1,Q_num + WRITE(out_unit,'(1x,4(es17.8e3))') $ inQs(i),iinQs(j), $ REAL(deltas(i,j)),AIMAG(deltas(i,j)) + ENDDO ENDDO - ENDDO - CLOSE(out_unit) + CLOSE(out_unit) + + DEALLOCATE(inQs,iinQs,deltas) + ENDIF + ENDDO + + sl_out%r_trace(k,:) = re_trace + sl_out%i_trace(k,:) = im_trace - ENDIF + IF (.NOT. (est_gamma_flag)) THEN + sl_in%d_beta_arr = (/ 0. /) + sl_out%dels_db_arr = (/ 0. /) + END IF IF (coupling_flag) THEN WRITE(*,*)"------------------------------------------" @@ -620,10 +639,10 @@ PROGRAM slayer ing_step = (2.0 * scan_width) / (Q_num - 1) count = 0 - IF (.NOT. stabscan_flag) THEN + !IF (.NOT. stabscan_flag) THEN ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) ALLOCATE(deltas(1:(Q_num+1),1:Q_num)) - END IF + !END IF inQs=0.0; iinQs=0.0; deltas=(0.0,0.0) ALLOCATE(delta_Q(n_k,n_k)) @@ -691,6 +710,7 @@ PROGRAM slayer ENDDO CLOSE(out_unit) + DEALLOCATE(inQs,iinQs,deltas) END IF CALL output_gamma(est_gamma_flag,sl_in,sl_out) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index df20f48c5..f665e3279 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -102,11 +102,15 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, !WRITE(*,*)"netcdf qval=",qval WRITE(*,*)">>> Writing results to NetCDF output file" + !CALL check( nf90_def_dim(ncid,"r",msing,r_dim) ) + !CALL check( nf90_def_var(ncid,"r",nf90_int,r_dim,r_id)) IF(msing>0)THEN - CALL sl_check( nf90_def_dim(ncid,"qsing",msing,qsing_dim) ) !r_dim = q_rational + CALL sl_check( nf90_def_dim(ncid,"r",msing,qsing_dim) ) !r_dim = q_rational CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) - CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_int, + CALL sl_check( nf90_def_var(ncid,"r",nf90_int, $ qsing_dim,qsing_id)) + CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_int, + $ qsing_dim,qr_id)) CALL sl_check( nf90_def_dim(ncid, "step", SIZE(re_trace), $ tr_dim) ) CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, @@ -157,7 +161,7 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, c set variables c ----------------------------------------------------------------------- CALL sl_check( nf90_put_var(ncid,qsing_id, sl_in%qval_arr)) - !CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) + CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) CALL sl_check( nf90_put_var(ncid,pr_id, sl_in%psi_n_arr)) CALL sl_check( nf90_put_var(ncid,omegas_id, sl_in%omegas_arr)) CALL sl_check( nf90_put_var(ncid,S_id, sl_in%lu_arr)) From 0348b2a205bbf7e0afe65bd08ddf421bad630223 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 9 Oct 2025 17:14:50 -0400 Subject: [PATCH 046/118] WIP: backup, working version --- slayer/slayer.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slayer/slayer.f b/slayer/slayer.f index 703722053..9997ff634 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -491,7 +491,7 @@ PROGRAM slayer $ sl_out%i_trace(n_k,100)) !-------------- - n_k = 1 + !n_k = 1 !-------------- DO k=1,n_k WRITE(*,*) From e6a825f2e6174cf237aa3a60fb522cd7fdd5711b Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 9 Oct 2025 20:12:11 -0400 Subject: [PATCH 047/118] WIP: reverting coupling workflow to fix gamma bug --- slayer/gslayer.f | 540 +++++++++++++++++++++++++++-------------------- slayer/sglobal.f | 20 ++ 2 files changed, 331 insertions(+), 229 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index ccf5dbbad..2fb525e22 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -412,249 +412,331 @@ SUBROUTINE calc_determinant(matk, nk, detk) END SELECT RETURN END SUBROUTINE calc_determinant -c -c -c Adapted from - SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(INOUT) :: g_r, g_i - INTEGER, INTENT(IN) :: verbose - - REAL(r8) :: F1, F2, J11, J12, J21, J22, det, iJ11, iJ12 - REAL(r8) :: iJ21, iJ22, dx1, dx2, dx, f, g1, g2, lambda, - $ Residual - INTEGER :: iter - REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER - REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size - INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations - - iter = 0 - DO - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - - CALL newton_jacobian(g_r, g_i, J11, J12, J21, J22, - $ fitz_flag) + !=========================================================================== + ! Initialize the adaptive grid + !=========================================================================== + subroutine init_grid(grid, omega_min, omega_max, gamma_min, gamma_max, initial_capacity) + type(adaptive_grid), intent(out) :: grid + real(dp), intent(in) :: omega_min, omega_max, gamma_min, gamma_max + integer, intent(in) :: initial_capacity - det = J11 * J22 - J12 * J21 + grid%omega_min = omega_min + grid%omega_max = omega_max + grid%gamma_min = gamma_min + grid%gamma_max = gamma_max + grid%capacity = initial_capacity + grid%npoints = 0 - iJ11 = J22 / det - iJ12 = -J12 / det - iJ21 = -J21 / det - iJ22 = J11 / det + allocate(grid%points(initial_capacity)) - dx1 = -(iJ11 * F1 + iJ12 * F2) - dx2 = -(iJ21 * F1 + iJ22 * F2) + end subroutine init_grid + + !=========================================================================== + ! Add a point to the grid (with automatic reallocation if needed) + !=========================================================================== + subroutine add_point(grid, omega, gamma, delta_val) + type(adaptive_grid), intent(inout) :: grid + real(dp), intent(in) :: omega, gamma + complex(dp), intent(in) :: delta_val - dx = sqrt(dx1*dx1 + dx2*dx2) + type(grid_point), allocatable :: temp(:) + integer :: new_capacity - f = 0.5 * (F1*F1 + F2*F2) + ! Check if we need to reallocate + if (grid%npoints >= grid%capacity) then + new_capacity = grid%capacity * 2 + allocate(temp(new_capacity)) + temp(1:grid%npoints) = grid%points(1:grid%npoints) + call move_alloc(temp, grid%points) + grid%capacity = new_capacity + end if - g1 = F1*J11 + F2*J21 - g2 = F1*J12 + F2*J22 + ! Add the new point + grid%npoints = grid%npoints + 1 + grid%points(grid%npoints)%omega = omega + grid%points(grid%npoints)%gamma = gamma + grid%points(grid%npoints)%delta = delta_val + grid%points(grid%npoints)%computed = .true. + grid%points(grid%npoints)%distance_to_contour = huge(1.0_dp) - CALL newton_backtrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda, - $ fitz_flag) + end subroutine add_point + + !=========================================================================== + ! Check if a point already exists in the grid (within tolerance) + !=========================================================================== + logical function point_exists(grid, omega, gamma, tol) + type(adaptive_grid), intent(in) :: grid + real(dp), intent(in) :: omega, gamma, tol + integer :: i - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) + point_exists = .false. + do i = 1, grid%npoints + if (abs(grid%points(i)%omega - omega) < tol .and. & + abs(grid%points(i)%gamma - gamma) < tol) then + point_exists = .true. + return + end if + end do - Residual = sqrt(F1*F1 + F2*F2) + end function point_exists + + !=========================================================================== + ! Perform initial coarse scan + !=========================================================================== + subroutine coarse_scan(grid, delta_function, n_omega, n_gamma) + type(adaptive_grid), intent(inout) :: grid + interface + function delta_function(omega, gamma) result(delta) + import :: dp + real(dp), intent(in) :: omega, gamma + complex(dp) :: delta + end function delta_function + end interface + integer, intent(in) :: n_omega, n_gamma - n_trace = n_trace + 1 - - IF (n_trace < 100) THEN - re_trace(n_trace) = g_r - im_trace(n_trace) = g_i - END IF - - IF (verbose .ne. 0) THEN - WRITE(*, '(A, ES10.3, A, ES10.3, A, A, ES10.3)') - $ 'Q step = (', g_r, ' + ', - $ g_i, 'j ),', ' Residual =', Residual - ENDIF + real(dp) :: omega, gamma, domega, dgamma + complex(dp) :: delta_val + integer :: i, j - iter = iter + 1 + domega = (grid%omega_max - grid%omega_min) / real(n_omega - 1, dp) + dgamma = (grid%gamma_max - grid%gamma_min) / real(n_gamma - 1, dp) - IF (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit - ENDDO - - END SUBROUTINE newton_root - -c----------------------------------------------------------------------- -c Function to backtrack along Newton step IN order to minimize f = (F1*F1 + F2*F2) /2 -c Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies IN C (Cambridge, 1992), Sect. 9.7 -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, - $ lambda, fitz_flag) - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(INOUT) :: g_r, g_i, dx, lambda - REAL(r8), INTENT(INOUT) :: dx1, dx2, f, g1, g2 - - REAL(r8) :: x1old, x2old, dxold, fold, slope, F1, F2 - REAL(r8) :: tmplam, rhs1, rhs2, a, b, disc, lambd2, mf2 - INTEGER :: i - - REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size - REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER - INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations - - x1old = g_r - x2old = g_i - dxold = dx - fold = f - - IF (dxold > Smax) THEN - dx1 = dx1 * Smax / dxold - dx2 = dx2 * Smax / dxold - dxold = Smax - ENDIF - - slope = g1*dx1 + g2*dx2 - - IF (slope >= 0.0d0) THEN - WRITE(*,*) "NewtonBackTrack: Error - roundoff problem" - ENDIF - - lambda = 1.0d0 - - DO i = 0, Maxiter - g_r = x1old + lambda * dx1 - g_i = x2old + lambda * dx2 - - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - - f = 0.5 * (F1*F1 + F2*F2) - - IF (f <= fold + alpha * lambda * slope .or. - $ lambda * dxold < Smin) THEN - dx = lambda * dxold - RETURN - ELSE - IF (lambda == 1.0d0) THEN - tmplam = -slope / 2.0d0 / (f - fold - slope) - ELSE - rhs1 = f - fold - lambda * slope - rhs2 = mf2 - fold - lambd2 * slope + do i = 1, n_omega + omega = grid%omega_min + real(i-1, dp) * domega + do j = 1, n_gamma + gamma = grid%gamma_min + real(j-1, dp) * dgamma - a = (rhs1/lambda/lambda - rhs2/lambd2/lambd2) - $ / (lambda - lambd2) - b = (-lambd2 * rhs1/lambda/lambda + lambda * - $ rhs2/lambd2/lambd2) / (lambda - lambd2) + ! Compute delta at this point + delta_val = delta_function(omega, gamma) + call add_point(grid, omega, gamma, delta_val) - IF (a == 0.0d0) THEN - tmplam = -slope / 2.0d0 / b - ELSE - disc = b*b - 3.0d0 * a * slope + end do + end do + + print *, 'Coarse scan complete. Points computed:', grid%npoints + + end subroutine coarse_scan + + !=========================================================================== + ! Identify contour regions based on sign changes + !=========================================================================== + subroutine identify_contour_regions(grid, deltaprime, contour_tol) + type(adaptive_grid), intent(inout) :: grid + complex(dp), intent(in) :: deltaprime + real(dp), intent(in) :: contour_tol + + integer :: i + real(dp) :: dist_real, dist_imag, min_dist + + ! For each point, compute distance to contours + do i = 1, grid%npoints + dist_real = abs(real(grid%points(i)%delta) - real(deltaprime)) + dist_imag = abs(aimag(grid%points(i)%delta) - aimag(deltaprime)) + min_dist = min(dist_real, dist_imag) + grid%points(i)%distance_to_contour = min_dist + end do + + end subroutine identify_contour_regions + + !=========================================================================== + ! Adaptive refinement around contours + !=========================================================================== + subroutine adaptive_refine(grid, delta_function, deltaprime, & + refinement_width, refinement_levels, min_spacing) + type(adaptive_grid), intent(inout) :: grid + interface + function delta_function(omega, gamma) result(delta) + import :: dp + real(dp), intent(in) :: omega, gamma + complex(dp) :: delta + end function delta_function + end interface + complex(dp), intent(in) :: deltaprime + real(dp), intent(in) :: refinement_width + integer, intent(in) :: refinement_levels + real(dp), intent(in) :: min_spacing + + integer :: level, i, j, n_original + real(dp) :: omega, gamma, spacing + complex(dp) :: delta_val + logical, allocatable :: needs_refinement(:) + real(dp) :: omega_new, gamma_new + integer :: n_refined + + do level = 1, refinement_levels + n_original = grid%npoints + allocate(needs_refinement(n_original)) + + ! Identify points that need refinement + do i = 1, n_original + needs_refinement(i) = grid%points(i)%distance_to_contour < refinement_width + end do + + n_refined = 0 + spacing = refinement_width / (2.0_dp**level) + + ! Add refined points around identified regions + do i = 1, n_original + if (needs_refinement(i)) then + omega = grid%points(i)%omega + gamma = grid%points(i)%gamma - IF (disc < 0.0d0) THEN - tmplam = 0.5d0 * lambda - ELSE IF (b <= 0.0d0) THEN - tmplam = (-b + sqrt(disc)) / 3.0d0 / a - ELSE - tmplam = -slope / (b + sqrt(disc)) - ENDIF - ENDIF - - IF (tmplam > 0.5d0 * lambda) THEN - tmplam = 0.5d0 * lambda - ENDIF - ENDIF - ENDIF - - lambd2 = lambda - mf2 = f - lambda = max(tmplam, 0.1d0*lambda) - ENDDO - - dx = lambda * dxold - - END SUBROUTINE newton_backtrack -c----------------------------------------------------------------------- -c Function to calculate Jacobian matrix for Newton-Raphson root finding -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_jacobian(g_r, g_i, J11, J12, J21, J22, - $ fitz_flag) - REAL(r8), INTENT(IN) :: g_r, g_i - LOGICAL, INTENT(IN) :: fitz_flag - - REAL(r8), INTENT(OUT) :: J11, J12, J21, J22 - - REAL(r8) :: F1m, F2m, F1p, F2p - REAL(r8), PARAMETER :: dS = 1.0e-06 ! Step size for derivatives - - CALL newton_function(g_r - dS, g_i,F1m,F2m,fitz_flag) - CALL newton_function(g_r + dS, g_i,F1p,F2p,fitz_flag) - - J11 = (F1p - F1m) / 2.0d0 / dS - J21 = (F2p - F2m) / 2.0d0 / dS - - CALL newton_function(g_r, g_i - dS,F1m,F2m,fitz_flag) - CALL newton_function(g_r, g_i + dS,F1p,F2p,fitz_flag) - - J12 = (F1p - F1m) / 2.0d0 / dS - J22 = (F2p - F2m) / 2.0d0 / dS - - END SUBROUTINE newton_jacobian - -c----------------------------------------------------------------------- -c Function to RETURN maximum of two values -c Adapted from -c----------------------------------------------------------------------- - FUNCTION Fmax(f1, f2) result(res) - REAL(r8), INTENT(IN) :: f1, f2 - REAL(r8) :: res - - IF (f1 > f2) THEN - res = f1 - ELSE - res = f2 - ENDIF - - END FUNCTION Fmax - -c----------------------------------------------------------------------- -c Function to RETURN minimum of two values -c Adapted from -c----------------------------------------------------------------------- - FUNCTION Fmin(f1, f2) result(res) - REAL(r8), INTENT(IN) :: f1, f2 - REAL(r8) :: res - - IF (f1 < f2) THEN - res = f1 - ELSE - res = f2 - ENDIF - - END FUNCTION Fmin - -c----------------------------------------------------------------------- -c Function to calculate target functions for Newton-Raphson root finding -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_function(g_r,g_i,F1,F2,fitz_flag) - REAL(r8), INTENT(IN) :: g_r,g_i - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(OUT) :: F1, F2 - - COMPLEX(r8) :: Deltas - - IF (fitz_flag) THEN ! use Fitzpatrick formalism - g_tmp = CMPLX(g_r,g_i) - Deltas=riccati_f(g_tmp) - ELSE ! use J.K. Park formalism - g_tmp = CMPLX(g_i,g_r) - Deltas=riccati(g_i,Q_e,Q_i,P_perp, - $ c_beta,D_norm,tau,pe, - $ iinQ=g_r) - END IF - - F1 = REAL(Deltas) - delta_eff - F2 = AIMAG(Deltas) - - END SUBROUTINE newton_function + ! Add points in a 3x3 grid around this point + do j = -1, 1 + omega_new = omega + real(j, dp) * spacing + if (omega_new < grid%omega_min .or. omega_new > grid%omega_max) cycle + + gamma_new = gamma - spacing + if (gamma_new >= grid%gamma_min .and. gamma_new <= grid%gamma_max) then + if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then + delta_val = delta_function(omega_new, gamma_new) + call add_point(grid, omega_new, gamma_new, delta_val) + n_refined = n_refined + 1 + end if + end if + + if (j /= 0) then + gamma_new = gamma + if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then + delta_val = delta_function(omega_new, gamma_new) + call add_point(grid, omega_new, gamma_new, delta_val) + n_refined = n_refined + 1 + end if + end if + + gamma_new = gamma + spacing + if (gamma_new >= grid%gamma_min .and. gamma_new <= grid%gamma_max) then + if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then + delta_val = delta_function(omega_new, gamma_new) + call add_point(grid, omega_new, gamma_new, delta_val) + n_refined = n_refined + 1 + end if + end if + end do + end if + end do + + print *, 'Refinement level', level, ': Added', n_refined, 'points' + + ! Update distances for new points + call identify_contour_regions(grid, deltaprime, refinement_width) + + deallocate(needs_refinement) + + ! Stop if no new points were added + if (n_refined == 0) exit + end do + + end subroutine adaptive_refine + + !=========================================================================== + ! Marching squares helper for more accurate contour following + !=========================================================================== + subroutine refine_with_marching_squares(grid, delta_function, deltaprime, & + contour_tol, max_new_points) + type(adaptive_grid), intent(inout) :: grid + interface + function delta_function(omega, gamma) result(delta) + import :: dp + real(dp), intent(in) :: omega, gamma + complex(dp) :: delta + end function delta_function + end interface + complex(dp), intent(in) :: deltaprime + real(dp), intent(in) :: contour_tol + integer, intent(in) :: max_new_points + + ! Implementation of marching squares refinement + ! This would trace along detected contours for extra precision + ! Left as a stub for brevity, but can be expanded if needed + + end subroutine refine_with_marching_squares + + !=========================================================================== + ! Export grid to file + !=========================================================================== + subroutine export_grid(grid, filename) + type(adaptive_grid), intent(in) :: grid + character(len=*), intent(in) :: filename + + integer :: i, unit_num + + open(newunit=unit_num, file=filename, status='replace', action='write') + + ! Write header + write(unit_num, '(A)') '# omega, gamma, Re(delta), Im(delta), distance_to_contour' + write(unit_num, '(A,I0)') '# Number of points: ', grid%npoints + + ! Write data + do i = 1, grid%npoints + write(unit_num, '(5E16.8)') grid%points(i)%omega, grid%points(i)%gamma, & + real(grid%points(i)%delta), & + aimag(grid%points(i)%delta), & + grid%points(i)%distance_to_contour + end do + + close(unit_num) + + print *, 'Grid exported to ', trim(filename) + print *, 'Total points: ', grid%npoints + + end subroutine export_grid + + !=========================================================================== + ! Main driver routine + !=========================================================================== + subroutine find_contours(delta_function, omega_min, omega_max, & + gamma_min, gamma_max, deltaprime, & + n_coarse_omega, n_coarse_gamma, & + refinement_width, refinement_levels, & + min_spacing, output_file) + interface + function delta_function(omega, gamma) result(delta) + import :: dp + real(dp), intent(in) :: omega, gamma + complex(dp) :: delta + end function delta_function + end interface + real(dp), intent(in) :: omega_min, omega_max, gamma_min, gamma_max + complex(dp), intent(in) :: deltaprime + integer, intent(in) :: n_coarse_omega, n_coarse_gamma + real(dp), intent(in) :: refinement_width + integer, intent(in) :: refinement_levels + real(dp), intent(in) :: min_spacing + character(len=*), intent(in) :: output_file + + type(adaptive_grid) :: grid + integer :: initial_capacity + + print *, '========================================' + print *, 'Starting adaptive contour finding' + print *, '========================================' + + ! Initialize grid + initial_capacity = n_coarse_omega * n_coarse_gamma * 4 + call init_grid(grid, omega_min, omega_max, gamma_min, gamma_max, initial_capacity) + + ! Perform coarse scan + print *, 'Step 1: Coarse scanning...' + call coarse_scan(grid, delta_function, n_coarse_omega, n_coarse_gamma) + + ! Identify contour regions + print *, 'Step 2: Identifying contour regions...' + call identify_contour_regions(grid, deltaprime, refinement_width) + + ! Adaptive refinement + print *, 'Step 3: Adaptive refinement...' + call adaptive_refine(grid, delta_function, deltaprime, & + refinement_width, refinement_levels, min_spacing) + + ! Export results + print *, 'Step 4: Exporting results...' + call export_grid(grid, output_file) + + ! Clean up + deallocate(grid%points) + + end subroutine find_contours + END MODULE gslayer_mod diff --git a/slayer/sglobal.f b/slayer/sglobal.f index a91bf55a5..b4b982913 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -44,6 +44,26 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: r_trace(:,:),i_trace(:,:) END TYPE slayer_outputs_type + real(dp), parameter :: UNCOMPUTED = -huge(1.0_dp) + + ! Data structure for storing computed points + type :: grid_point + real(dp) :: omega + real(dp) :: gamma + complex(dp) :: delta + logical :: computed + real(dp) :: distance_to_contour ! minimum distance to any contour + end type grid_point + + ! Main grid structure + type :: adaptive_grid + type(grid_point), allocatable :: points(:) + integer :: npoints + integer :: capacity + real(dp) :: omega_min, omega_max + real(dp) :: gamma_min, gamma_max + end type adaptive_grid + ! lnLamb will be updated. COMPLEX(r8), PARAMETER :: ifac=(0,1) From ee8cef40b58ac7edc3f059b6a6329c91e8525092 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 9 Oct 2025 20:13:45 -0400 Subject: [PATCH 048/118] Revert "WIP: backup, working version" This reverts commit 0348b2a205bbf7e0afe65bd08ddf421bad630223. --- slayer/slayer.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slayer/slayer.f b/slayer/slayer.f index 9997ff634..703722053 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -491,7 +491,7 @@ PROGRAM slayer $ sl_out%i_trace(n_k,100)) !-------------- - !n_k = 1 + n_k = 1 !-------------- DO k=1,n_k WRITE(*,*) From ce0b1f99dc884578255e2076e790df2cbf86c8bb Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 14 Oct 2025 13:56:38 -0400 Subject: [PATCH 049/118] checkpoint: working with brute force scans --- slayer/gslayer.f | 542 ++++++++++++++++++++--------------------------- slayer/sglobal.f | 20 -- slayer/slayer.f | 11 +- 3 files changed, 237 insertions(+), 336 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 2fb525e22..39ca4a763 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -412,331 +412,249 @@ SUBROUTINE calc_determinant(matk, nk, detk) END SELECT RETURN END SUBROUTINE calc_determinant +c +c +c Adapted from + SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(INOUT) :: g_r, g_i + INTEGER, INTENT(IN) :: verbose + + REAL(r8) :: F1, F2, J11, J12, J21, J22, det, iJ11, iJ12 + REAL(r8) :: iJ21, iJ22, dx1, dx2, dx, f, g1, g2, lambda, + $ Residual + INTEGER :: iter - !=========================================================================== - ! Initialize the adaptive grid - !=========================================================================== - subroutine init_grid(grid, omega_min, omega_max, gamma_min, gamma_max, initial_capacity) - type(adaptive_grid), intent(out) :: grid - real(dp), intent(in) :: omega_min, omega_max, gamma_min, gamma_max - integer, intent(in) :: initial_capacity + REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER + REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size + REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size + INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations + + iter = 0 + DO + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) + + CALL newton_jacobian(g_r, g_i, J11, J12, J21, J22, + $ fitz_flag) - grid%omega_min = omega_min - grid%omega_max = omega_max - grid%gamma_min = gamma_min - grid%gamma_max = gamma_max - grid%capacity = initial_capacity - grid%npoints = 0 + det = J11 * J22 - J12 * J21 - allocate(grid%points(initial_capacity)) + iJ11 = J22 / det + iJ12 = -J12 / det + iJ21 = -J21 / det + iJ22 = J11 / det - end subroutine init_grid - - !=========================================================================== - ! Add a point to the grid (with automatic reallocation if needed) - !=========================================================================== - subroutine add_point(grid, omega, gamma, delta_val) - type(adaptive_grid), intent(inout) :: grid - real(dp), intent(in) :: omega, gamma - complex(dp), intent(in) :: delta_val + dx1 = -(iJ11 * F1 + iJ12 * F2) + dx2 = -(iJ21 * F1 + iJ22 * F2) - type(grid_point), allocatable :: temp(:) - integer :: new_capacity + dx = sqrt(dx1*dx1 + dx2*dx2) - ! Check if we need to reallocate - if (grid%npoints >= grid%capacity) then - new_capacity = grid%capacity * 2 - allocate(temp(new_capacity)) - temp(1:grid%npoints) = grid%points(1:grid%npoints) - call move_alloc(temp, grid%points) - grid%capacity = new_capacity - end if + f = 0.5 * (F1*F1 + F2*F2) - ! Add the new point - grid%npoints = grid%npoints + 1 - grid%points(grid%npoints)%omega = omega - grid%points(grid%npoints)%gamma = gamma - grid%points(grid%npoints)%delta = delta_val - grid%points(grid%npoints)%computed = .true. - grid%points(grid%npoints)%distance_to_contour = huge(1.0_dp) + g1 = F1*J11 + F2*J21 + g2 = F1*J12 + F2*J22 - end subroutine add_point - - !=========================================================================== - ! Check if a point already exists in the grid (within tolerance) - !=========================================================================== - logical function point_exists(grid, omega, gamma, tol) - type(adaptive_grid), intent(in) :: grid - real(dp), intent(in) :: omega, gamma, tol - integer :: i + CALL newton_backtrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda, + $ fitz_flag) - point_exists = .false. - do i = 1, grid%npoints - if (abs(grid%points(i)%omega - omega) < tol .and. & - abs(grid%points(i)%gamma - gamma) < tol) then - point_exists = .true. - return - end if - end do + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - end function point_exists - - !=========================================================================== - ! Perform initial coarse scan - !=========================================================================== - subroutine coarse_scan(grid, delta_function, n_omega, n_gamma) - type(adaptive_grid), intent(inout) :: grid - interface - function delta_function(omega, gamma) result(delta) - import :: dp - real(dp), intent(in) :: omega, gamma - complex(dp) :: delta - end function delta_function - end interface - integer, intent(in) :: n_omega, n_gamma + Residual = sqrt(F1*F1 + F2*F2) - real(dp) :: omega, gamma, domega, dgamma - complex(dp) :: delta_val - integer :: i, j + n_trace = n_trace + 1 + + IF (n_trace < 100) THEN + re_trace(n_trace) = g_r + im_trace(n_trace) = g_i + END IF + + IF (verbose .ne. 0) THEN + WRITE(*, '(A, ES10.3, A, ES10.3, A, A, ES10.3)') + $ 'Q step = (', g_r, ' + ', + $ g_i, 'j ),', ' Residual =', Residual + ENDIF - domega = (grid%omega_max - grid%omega_min) / real(n_omega - 1, dp) - dgamma = (grid%gamma_max - grid%gamma_min) / real(n_gamma - 1, dp) + iter = iter + 1 - do i = 1, n_omega - omega = grid%omega_min + real(i-1, dp) * domega - do j = 1, n_gamma - gamma = grid%gamma_min + real(j-1, dp) * dgamma + IF (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit + ENDDO + + END SUBROUTINE newton_root + +c----------------------------------------------------------------------- +c Function to backtrack along Newton step IN order to minimize f = (F1*F1 + F2*F2) /2 +c Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies IN C (Cambridge, 1992), Sect. 9.7 +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, + $ lambda, fitz_flag) + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(INOUT) :: g_r, g_i, dx, lambda + REAL(r8), INTENT(INOUT) :: dx1, dx2, f, g1, g2 + + REAL(r8) :: x1old, x2old, dxold, fold, slope, F1, F2 + REAL(r8) :: tmplam, rhs1, rhs2, a, b, disc, lambd2, mf2 + INTEGER :: i + + REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size + REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size + REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER + INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations + + x1old = g_r + x2old = g_i + dxold = dx + fold = f + + IF (dxold > Smax) THEN + dx1 = dx1 * Smax / dxold + dx2 = dx2 * Smax / dxold + dxold = Smax + ENDIF + + slope = g1*dx1 + g2*dx2 + + IF (slope >= 0.0d0) THEN + WRITE(*,*) "NewtonBackTrack: Error - roundoff problem" + ENDIF + + lambda = 1.0d0 + + DO i = 0, Maxiter + g_r = x1old + lambda * dx1 + g_i = x2old + lambda * dx2 + + CALL newton_function(g_r, g_i, F1, F2, fitz_flag) + + f = 0.5 * (F1*F1 + F2*F2) + + IF (f <= fold + alpha * lambda * slope .or. + $ lambda * dxold < Smin) THEN + dx = lambda * dxold + RETURN + ELSE + IF (lambda == 1.0d0) THEN + tmplam = -slope / 2.0d0 / (f - fold - slope) + ELSE + rhs1 = f - fold - lambda * slope + rhs2 = mf2 - fold - lambd2 * slope - ! Compute delta at this point - delta_val = delta_function(omega, gamma) - call add_point(grid, omega, gamma, delta_val) + a = (rhs1/lambda/lambda - rhs2/lambd2/lambd2) + $ / (lambda - lambd2) + b = (-lambd2 * rhs1/lambda/lambda + lambda * + $ rhs2/lambd2/lambd2) / (lambda - lambd2) - end do - end do - - print *, 'Coarse scan complete. Points computed:', grid%npoints - - end subroutine coarse_scan - - !=========================================================================== - ! Identify contour regions based on sign changes - !=========================================================================== - subroutine identify_contour_regions(grid, deltaprime, contour_tol) - type(adaptive_grid), intent(inout) :: grid - complex(dp), intent(in) :: deltaprime - real(dp), intent(in) :: contour_tol - - integer :: i - real(dp) :: dist_real, dist_imag, min_dist - - ! For each point, compute distance to contours - do i = 1, grid%npoints - dist_real = abs(real(grid%points(i)%delta) - real(deltaprime)) - dist_imag = abs(aimag(grid%points(i)%delta) - aimag(deltaprime)) - min_dist = min(dist_real, dist_imag) - grid%points(i)%distance_to_contour = min_dist - end do - - end subroutine identify_contour_regions - - !=========================================================================== - ! Adaptive refinement around contours - !=========================================================================== - subroutine adaptive_refine(grid, delta_function, deltaprime, & - refinement_width, refinement_levels, min_spacing) - type(adaptive_grid), intent(inout) :: grid - interface - function delta_function(omega, gamma) result(delta) - import :: dp - real(dp), intent(in) :: omega, gamma - complex(dp) :: delta - end function delta_function - end interface - complex(dp), intent(in) :: deltaprime - real(dp), intent(in) :: refinement_width - integer, intent(in) :: refinement_levels - real(dp), intent(in) :: min_spacing - - integer :: level, i, j, n_original - real(dp) :: omega, gamma, spacing - complex(dp) :: delta_val - logical, allocatable :: needs_refinement(:) - real(dp) :: omega_new, gamma_new - integer :: n_refined - - do level = 1, refinement_levels - n_original = grid%npoints - allocate(needs_refinement(n_original)) - - ! Identify points that need refinement - do i = 1, n_original - needs_refinement(i) = grid%points(i)%distance_to_contour < refinement_width - end do - - n_refined = 0 - spacing = refinement_width / (2.0_dp**level) - - ! Add refined points around identified regions - do i = 1, n_original - if (needs_refinement(i)) then - omega = grid%points(i)%omega - gamma = grid%points(i)%gamma + IF (a == 0.0d0) THEN + tmplam = -slope / 2.0d0 / b + ELSE + disc = b*b - 3.0d0 * a * slope - ! Add points in a 3x3 grid around this point - do j = -1, 1 - omega_new = omega + real(j, dp) * spacing - if (omega_new < grid%omega_min .or. omega_new > grid%omega_max) cycle - - gamma_new = gamma - spacing - if (gamma_new >= grid%gamma_min .and. gamma_new <= grid%gamma_max) then - if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then - delta_val = delta_function(omega_new, gamma_new) - call add_point(grid, omega_new, gamma_new, delta_val) - n_refined = n_refined + 1 - end if - end if - - if (j /= 0) then - gamma_new = gamma - if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then - delta_val = delta_function(omega_new, gamma_new) - call add_point(grid, omega_new, gamma_new, delta_val) - n_refined = n_refined + 1 - end if - end if - - gamma_new = gamma + spacing - if (gamma_new >= grid%gamma_min .and. gamma_new <= grid%gamma_max) then - if (.not. point_exists(grid, omega_new, gamma_new, min_spacing)) then - delta_val = delta_function(omega_new, gamma_new) - call add_point(grid, omega_new, gamma_new, delta_val) - n_refined = n_refined + 1 - end if - end if - end do - end if - end do - - print *, 'Refinement level', level, ': Added', n_refined, 'points' - - ! Update distances for new points - call identify_contour_regions(grid, deltaprime, refinement_width) - - deallocate(needs_refinement) - - ! Stop if no new points were added - if (n_refined == 0) exit - end do - - end subroutine adaptive_refine - - !=========================================================================== - ! Marching squares helper for more accurate contour following - !=========================================================================== - subroutine refine_with_marching_squares(grid, delta_function, deltaprime, & - contour_tol, max_new_points) - type(adaptive_grid), intent(inout) :: grid - interface - function delta_function(omega, gamma) result(delta) - import :: dp - real(dp), intent(in) :: omega, gamma - complex(dp) :: delta - end function delta_function - end interface - complex(dp), intent(in) :: deltaprime - real(dp), intent(in) :: contour_tol - integer, intent(in) :: max_new_points - - ! Implementation of marching squares refinement - ! This would trace along detected contours for extra precision - ! Left as a stub for brevity, but can be expanded if needed - - end subroutine refine_with_marching_squares - - !=========================================================================== - ! Export grid to file - !=========================================================================== - subroutine export_grid(grid, filename) - type(adaptive_grid), intent(in) :: grid - character(len=*), intent(in) :: filename - - integer :: i, unit_num - - open(newunit=unit_num, file=filename, status='replace', action='write') - - ! Write header - write(unit_num, '(A)') '# omega, gamma, Re(delta), Im(delta), distance_to_contour' - write(unit_num, '(A,I0)') '# Number of points: ', grid%npoints - - ! Write data - do i = 1, grid%npoints - write(unit_num, '(5E16.8)') grid%points(i)%omega, grid%points(i)%gamma, & - real(grid%points(i)%delta), & - aimag(grid%points(i)%delta), & - grid%points(i)%distance_to_contour - end do - - close(unit_num) - - print *, 'Grid exported to ', trim(filename) - print *, 'Total points: ', grid%npoints - - end subroutine export_grid - - !=========================================================================== - ! Main driver routine - !=========================================================================== - subroutine find_contours(delta_function, omega_min, omega_max, & - gamma_min, gamma_max, deltaprime, & - n_coarse_omega, n_coarse_gamma, & - refinement_width, refinement_levels, & - min_spacing, output_file) - interface - function delta_function(omega, gamma) result(delta) - import :: dp - real(dp), intent(in) :: omega, gamma - complex(dp) :: delta - end function delta_function - end interface - real(dp), intent(in) :: omega_min, omega_max, gamma_min, gamma_max - complex(dp), intent(in) :: deltaprime - integer, intent(in) :: n_coarse_omega, n_coarse_gamma - real(dp), intent(in) :: refinement_width - integer, intent(in) :: refinement_levels - real(dp), intent(in) :: min_spacing - character(len=*), intent(in) :: output_file - - type(adaptive_grid) :: grid - integer :: initial_capacity - - print *, '========================================' - print *, 'Starting adaptive contour finding' - print *, '========================================' - - ! Initialize grid - initial_capacity = n_coarse_omega * n_coarse_gamma * 4 - call init_grid(grid, omega_min, omega_max, gamma_min, gamma_max, initial_capacity) - - ! Perform coarse scan - print *, 'Step 1: Coarse scanning...' - call coarse_scan(grid, delta_function, n_coarse_omega, n_coarse_gamma) - - ! Identify contour regions - print *, 'Step 2: Identifying contour regions...' - call identify_contour_regions(grid, deltaprime, refinement_width) - - ! Adaptive refinement - print *, 'Step 3: Adaptive refinement...' - call adaptive_refine(grid, delta_function, deltaprime, & - refinement_width, refinement_levels, min_spacing) - - ! Export results - print *, 'Step 4: Exporting results...' - call export_grid(grid, output_file) - - ! Clean up - deallocate(grid%points) - - end subroutine find_contours - - END MODULE gslayer_mod + IF (disc < 0.0d0) THEN + tmplam = 0.5d0 * lambda + ELSE IF (b <= 0.0d0) THEN + tmplam = (-b + sqrt(disc)) / 3.0d0 / a + ELSE + tmplam = -slope / (b + sqrt(disc)) + ENDIF + ENDIF + + IF (tmplam > 0.5d0 * lambda) THEN + tmplam = 0.5d0 * lambda + ENDIF + ENDIF + ENDIF + + lambd2 = lambda + mf2 = f + lambda = max(tmplam, 0.1d0*lambda) + ENDDO + + dx = lambda * dxold + + END SUBROUTINE newton_backtrack +c----------------------------------------------------------------------- +c Function to calculate Jacobian matrix for Newton-Raphson root finding +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_jacobian(g_r, g_i, J11, J12, J21, J22, + $ fitz_flag) + REAL(r8), INTENT(IN) :: g_r, g_i + LOGICAL, INTENT(IN) :: fitz_flag + + REAL(r8), INTENT(OUT) :: J11, J12, J21, J22 + + REAL(r8) :: F1m, F2m, F1p, F2p + REAL(r8), PARAMETER :: dS = 1.0e-06 ! Step size for derivatives + + CALL newton_function(g_r - dS, g_i,F1m,F2m,fitz_flag) + CALL newton_function(g_r + dS, g_i,F1p,F2p,fitz_flag) + + J11 = (F1p - F1m) / 2.0d0 / dS + J21 = (F2p - F2m) / 2.0d0 / dS + + CALL newton_function(g_r, g_i - dS,F1m,F2m,fitz_flag) + CALL newton_function(g_r, g_i + dS,F1p,F2p,fitz_flag) + + J12 = (F1p - F1m) / 2.0d0 / dS + J22 = (F2p - F2m) / 2.0d0 / dS + + END SUBROUTINE newton_jacobian + +c----------------------------------------------------------------------- +c Function to RETURN maximum of two values +c Adapted from +c----------------------------------------------------------------------- + FUNCTION Fmax(f1, f2) result(res) + REAL(r8), INTENT(IN) :: f1, f2 + REAL(r8) :: res + + IF (f1 > f2) THEN + res = f1 + ELSE + res = f2 + ENDIF + + END FUNCTION Fmax + +c----------------------------------------------------------------------- +c Function to RETURN minimum of two values +c Adapted from +c----------------------------------------------------------------------- + FUNCTION Fmin(f1, f2) result(res) + REAL(r8), INTENT(IN) :: f1, f2 + REAL(r8) :: res + + IF (f1 < f2) THEN + res = f1 + ELSE + res = f2 + ENDIF + + END FUNCTION Fmin + +c----------------------------------------------------------------------- +c Function to calculate target functions for Newton-Raphson root finding +c Adapted from +c----------------------------------------------------------------------- + SUBROUTINE newton_function(g_r,g_i,F1,F2,fitz_flag) + REAL(r8), INTENT(IN) :: g_r,g_i + LOGICAL, INTENT(IN) :: fitz_flag + REAL(r8), INTENT(OUT) :: F1, F2 + + COMPLEX(r8) :: Deltas + + IF (fitz_flag) THEN ! use Fitzpatrick formalism + g_tmp = CMPLX(g_r,g_i) + Deltas=riccati_f(g_tmp) + ELSE ! use J.K. Park formalism + g_tmp = CMPLX(g_i,g_r) + Deltas=riccati(g_i,Q_e,Q_i,P_perp, + $ c_beta,D_norm,tau,pe, + $ iinQ=g_r) + END IF + + F1 = REAL(Deltas) - delta_eff + F2 = AIMAG(Deltas) + + END SUBROUTINE newton_function + END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index b4b982913..a91bf55a5 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -44,26 +44,6 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: r_trace(:,:),i_trace(:,:) END TYPE slayer_outputs_type - real(dp), parameter :: UNCOMPUTED = -huge(1.0_dp) - - ! Data structure for storing computed points - type :: grid_point - real(dp) :: omega - real(dp) :: gamma - complex(dp) :: delta - logical :: computed - real(dp) :: distance_to_contour ! minimum distance to any contour - end type grid_point - - ! Main grid structure - type :: adaptive_grid - type(grid_point), allocatable :: points(:) - integer :: npoints - integer :: capacity - real(dp) :: omega_min, omega_max - real(dp) :: gamma_min, gamma_max - end type adaptive_grid - ! lnLamb will be updated. COMPLEX(r8), PARAMETER :: ifac=(0,1) diff --git a/slayer/slayer.f b/slayer/slayer.f index 703722053..565ed93ca 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -491,7 +491,7 @@ PROGRAM slayer $ sl_out%i_trace(n_k,100)) !-------------- - n_k = 1 + !n_k = 1 !-------------- DO k=1,n_k WRITE(*,*) @@ -555,11 +555,11 @@ PROGRAM slayer IF (fitz_flag) THEN re_trace = re_trace/tauk im_trace = im_trace/tauk - sl_out%gamma_sol_arr(k) = 0.0!g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT ELSE re_trace = re_trace/tauk im_trace = -im_trace/tauk - sl_out%gamma_sol_arr(k) = 0.0!-g_r/tauk! THIS IS FOR PLOT + sl_out%gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT END IF IF (stabscan_flag) THEN @@ -673,9 +673,12 @@ PROGRAM slayer iota_e = Q_e / (Q_e - Q_i) ! (Deltaprime - d_crit)/S^1/3 + ! delta_eff = (sl_in%Re_dp_arr(k) - + !$ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) ! NO DELTA_CRIT + delta_eff = (sl_in%Re_dp_arr(k) - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) - + delta=riccati_f(((g_tmp*sl_in%Qconv_arr(1))/ $ tauk)) delta_Q(k,k) = delta From 83465f8ce16299eb4c0ac0fd57c252313985a0b3 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 15 Dec 2025 15:16:24 -0500 Subject: [PATCH 050/118] WIP: latest working version --- slayer/gslayer.f | 298 +++++++++-------------------------------------- slayer/sglobal.f | 2 +- slayer/slayer.f | 70 +++-------- 3 files changed, 74 insertions(+), 296 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 39ca4a763..d10d3280b 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -415,246 +415,64 @@ END SUBROUTINE calc_determinant c c c Adapted from - SUBROUTINE newton_root(g_r, g_i, verbose, fitz_flag) - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(INOUT) :: g_r, g_i - INTEGER, INTENT(IN) :: verbose + FUNCTION dispersion_det(g_tmp,n_k,sl_in) - REAL(r8) :: F1, F2, J11, J12, J21, J22, det, iJ11, iJ12 - REAL(r8) :: iJ21, iJ22, dx1, dx2, dx, f, g1, g2, lambda, - $ Residual - INTEGER :: iter - - REAL(r8), PARAMETER :: Eps = 1.0e-12 ! Tolerance PARAMETER - REAL(r8), PARAMETER :: Smin = 1.0e-07 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size - INTEGER, PARAMETER :: MaxIter = 100 ! Maximum iterations - - iter = 0 - DO - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - - CALL newton_jacobian(g_r, g_i, J11, J12, J21, J22, - $ fitz_flag) - - det = J11 * J22 - J12 * J21 - - iJ11 = J22 / det - iJ12 = -J12 / det - iJ21 = -J21 / det - iJ22 = J11 / det - - dx1 = -(iJ11 * F1 + iJ12 * F2) - dx2 = -(iJ21 * F1 + iJ22 * F2) - - dx = sqrt(dx1*dx1 + dx2*dx2) - - f = 0.5 * (F1*F1 + F2*F2) - - g1 = F1*J11 + F2*J21 - g2 = F1*J12 + F2*J22 - - CALL newton_backtrack(g_r,g_i,dx1,dx2,dx,f,g1,g2,lambda, - $ fitz_flag) - - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - - Residual = sqrt(F1*F1 + F2*F2) - - n_trace = n_trace + 1 - - IF (n_trace < 100) THEN - re_trace(n_trace) = g_r - im_trace(n_trace) = g_i - END IF - - IF (verbose .ne. 0) THEN - WRITE(*, '(A, ES10.3, A, ES10.3, A, A, ES10.3)') - $ 'Q step = (', g_r, ' + ', - $ g_i, 'j ),', ' Residual =', Residual - ENDIF - - iter = iter + 1 - - IF (Residual<=Eps .or. dx<=Smin .or. iter>=MaxIter) exit - ENDDO - - END SUBROUTINE newton_root - -c----------------------------------------------------------------------- -c Function to backtrack along Newton step IN order to minimize f = (F1*F1 + F2*F2) /2 -c Press, Teukolsky, Vetterling, and Flannery, Numerical Recipies IN C (Cambridge, 1992), Sect. 9.7 -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_backtrack(g_r, g_i, dx1, dx2, dx, f, g1, g2, - $ lambda, fitz_flag) - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(INOUT) :: g_r, g_i, dx, lambda - REAL(r8), INTENT(INOUT) :: dx1, dx2, f, g1, g2 - - REAL(r8) :: x1old, x2old, dxold, fold, slope, F1, F2 - REAL(r8) :: tmplam, rhs1, rhs2, a, b, disc, lambd2, mf2 - INTEGER :: i - - REAL(r8), PARAMETER :: Smin = 1.0d-10 ! Min step size - REAL(r8), PARAMETER :: Smax = 0.02 ! Max step size - REAL(r8), PARAMETER :: alpha = 1.0d-4 ! Line search PARAMETER - INTEGER, PARAMETER :: Maxiter = 100 ! Maximum iterations - - x1old = g_r - x2old = g_i - dxold = dx - fold = f - - IF (dxold > Smax) THEN - dx1 = dx1 * Smax / dxold - dx2 = dx2 * Smax / dxold - dxold = Smax - ENDIF - - slope = g1*dx1 + g2*dx2 - - IF (slope >= 0.0d0) THEN - WRITE(*,*) "NewtonBackTrack: Error - roundoff problem" - ENDIF - - lambda = 1.0d0 - - DO i = 0, Maxiter - g_r = x1old + lambda * dx1 - g_i = x2old + lambda * dx2 - - CALL newton_function(g_r, g_i, F1, F2, fitz_flag) - - f = 0.5 * (F1*F1 + F2*F2) - - IF (f <= fold + alpha * lambda * slope .or. - $ lambda * dxold < Smin) THEN - dx = lambda * dxold - RETURN - ELSE - IF (lambda == 1.0d0) THEN - tmplam = -slope / 2.0d0 / (f - fold - slope) - ELSE - rhs1 = f - fold - lambda * slope - rhs2 = mf2 - fold - lambd2 * slope - - a = (rhs1/lambda/lambda - rhs2/lambd2/lambd2) - $ / (lambda - lambd2) - b = (-lambd2 * rhs1/lambda/lambda + lambda * - $ rhs2/lambd2/lambd2) / (lambda - lambd2) - - IF (a == 0.0d0) THEN - tmplam = -slope / 2.0d0 / b - ELSE - disc = b*b - 3.0d0 * a * slope - - IF (disc < 0.0d0) THEN - tmplam = 0.5d0 * lambda - ELSE IF (b <= 0.0d0) THEN - tmplam = (-b + sqrt(disc)) / 3.0d0 / a - ELSE - tmplam = -slope / (b + sqrt(disc)) - ENDIF - ENDIF - - IF (tmplam > 0.5d0 * lambda) THEN - tmplam = 0.5d0 * lambda - ENDIF - ENDIF - ENDIF - - lambd2 = lambda - mf2 = f - lambda = max(tmplam, 0.1d0*lambda) - ENDDO - - dx = lambda * dxold - - END SUBROUTINE newton_backtrack -c----------------------------------------------------------------------- -c Function to calculate Jacobian matrix for Newton-Raphson root finding -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_jacobian(g_r, g_i, J11, J12, J21, J22, - $ fitz_flag) - REAL(r8), INTENT(IN) :: g_r, g_i - LOGICAL, INTENT(IN) :: fitz_flag - - REAL(r8), INTENT(OUT) :: J11, J12, J21, J22 - - REAL(r8) :: F1m, F2m, F1p, F2p - REAL(r8), PARAMETER :: dS = 1.0e-06 ! Step size for derivatives - - CALL newton_function(g_r - dS, g_i,F1m,F2m,fitz_flag) - CALL newton_function(g_r + dS, g_i,F1p,F2p,fitz_flag) - - J11 = (F1p - F1m) / 2.0d0 / dS - J21 = (F2p - F2m) / 2.0d0 / dS - - CALL newton_function(g_r, g_i - dS,F1m,F2m,fitz_flag) - CALL newton_function(g_r, g_i + dS,F1p,F2p,fitz_flag) - - J12 = (F1p - F1m) / 2.0d0 / dS - J22 = (F2p - F2m) / 2.0d0 / dS - - END SUBROUTINE newton_jacobian - -c----------------------------------------------------------------------- -c Function to RETURN maximum of two values -c Adapted from -c----------------------------------------------------------------------- - FUNCTION Fmax(f1, f2) result(res) - REAL(r8), INTENT(IN) :: f1, f2 - REAL(r8) :: res - - IF (f1 > f2) THEN - res = f1 - ELSE - res = f2 - ENDIF - - END FUNCTION Fmax - -c----------------------------------------------------------------------- -c Function to RETURN minimum of two values -c Adapted from -c----------------------------------------------------------------------- - FUNCTION Fmin(f1, f2) result(res) - REAL(r8), INTENT(IN) :: f1, f2 - REAL(r8) :: res - - IF (f1 < f2) THEN - res = f1 + COMPLEX(r8), INTENT(IN) :: g_tmp + INTEGER, INTENT(IN) :: n_k + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + COMPLEX(r8) :: dispersion_det,det_val,tmp_delta + COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:),result_matrix(:,:) + INTEGER :: k + + IF (n_k < 2) THEN + Q_e = sl_in%Q_e_arr(1) + Q_i = sl_in%Q_i_arr(1) + P_perp = sl_in%P_perp_arr(1) + P_tor = sl_in%P_tor_arr(1) + tau = sl_in%tau_arr(1) + D_norm = sl_in%D_norm_arr(1) + c_beta = sl_in%c_beta_arr(1) + tauk = sl_in%Qconv_arr(1) + iota_e = Q_e / (Q_e - Q_i) + + tmp_delta=riccati_f(g_tmp) + det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) ! DE-NORMALIZE + + ! Calculate Deltaprime - Delta(Q) + dispersion_det = sl_in%Re_dp_arr(1) - det_val + + ELSEIF ((n_k == 2) .OR. (n_k == 3)) THEN + ALLOCATE(delta_Q(n_k,n_k)) + delta_Q=(0.0,0.0) + DO k=1,2 !!! MAXING OUT AT 2X2 + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + P_perp = sl_in%P_perp_arr(k) + P_tor = sl_in%P_tor_arr(k) + tau = sl_in%tau_arr(k) + D_norm = sl_in%D_norm_arr(k) + c_beta = sl_in%c_beta_arr(k) + tauk = sl_in%Qconv_arr(k) + iota_e = Q_e / (Q_e - Q_i) + + delta_eff = (sl_in%Re_dp_arr(k) - + $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) + + delta_Q(k,k)=riccati_f(((g_tmp*sl_in%Qconv_arr(1)) + $ /tauk)) + delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) ! DE-NORMALIZE + END DO + + ! Calculate Deltaprime - Delta(Q) + result_matrix = sl_in%dp_matrix - delta_Q + + ! Calculate determinant + CALL calc_determinant(result_matrix, n_k, det_val) + dispersion_det = det_val ELSE - res = f2 - ENDIF - - END FUNCTION Fmin - -c----------------------------------------------------------------------- -c Function to calculate target functions for Newton-Raphson root finding -c Adapted from -c----------------------------------------------------------------------- - SUBROUTINE newton_function(g_r,g_i,F1,F2,fitz_flag) - REAL(r8), INTENT(IN) :: g_r,g_i - LOGICAL, INTENT(IN) :: fitz_flag - REAL(r8), INTENT(OUT) :: F1, F2 - - COMPLEX(r8) :: Deltas - - IF (fitz_flag) THEN ! use Fitzpatrick formalism - g_tmp = CMPLX(g_r,g_i) - Deltas=riccati_f(g_tmp) - ELSE ! use J.K. Park formalism - g_tmp = CMPLX(g_i,g_r) - Deltas=riccati(g_i,Q_e,Q_i,P_perp, - $ c_beta,D_norm,tau,pe, - $ iinQ=g_r) - END IF - - F1 = REAL(Deltas) - delta_eff - F2 = AIMAG(Deltas) - - END SUBROUTINE newton_function + WRITE(*,*)"Error: no support for msing > 3" + stop + END IF + END FUNCTION dispersion_det + END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index a91bf55a5..eafcd4386 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -14,7 +14,7 @@ MODULE sglobal_mod $ delta_n,layfac,Qconv,lnLamb,deltaprim,dc_tmp, $ d_crit,tau_r,tauk,g_r,g_i,delta_eff REAL(r8), DIMENSION(:), ALLOCATABLE :: re_trace,im_trace - COMPLEX(r8) :: Q,g_tmp + COMPLEX(r8) :: Q,g_tmp,delta_det CHARACTER(20) :: dc_type REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, diff --git a/slayer/slayer.f b/slayer/slayer.f index 565ed93ca..08971bee5 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -43,7 +43,6 @@ PROGRAM slayer $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, $ delta_imag,Qratio REAL(r8) :: chis(3) - COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:),result_matrix(:,:) INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns @@ -493,7 +492,7 @@ PROGRAM slayer !-------------- !n_k = 1 !-------------- - DO k=1,n_k + DO k=1,2!!!!!!!!!!!!!! ONLY DOING TWO SURFACES WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', $ sl_in%qval_arr(k),' rational surface:' @@ -517,7 +516,9 @@ PROGRAM slayer WRITE(*,*)"slayer.f iota_e: ",iota_e WRITE(*,*)"slayer.f D_prime: ",sl_in%Re_dp_arr(k) + WRITE(*,*)"slayer.f D_prime: ",sl_in%Re_dp_arr(k) WRITE(*,*)"slayer.f D_crit: ",sl_in%d_crit_arr(k) + WRITE(*,*),"sl_in%qval_arr: ",sl_in%qval_arr ! (Deltaprime - d_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - @@ -541,25 +542,25 @@ PROGRAM slayer re_trace(1) = -Q_e END IF - WRITE(*,*)"$^$ calling newton_root(): " - CALL newton_root(g_r,g_i,1,fitz_flag) + WRITE(*,*)"no longer using newton_root(): " + !CALL newton_root(g_r,g_i,1,fitz_flag) WRITE(*,*) - WRITE(*,'(A,F0.3,A)') 'Success! Growth rate = ', - $ g_r/tauk, ' [Hz]' + !WRITE(*,'(A,F0.3,A)') 'Success! Growth rate = ', + !$ g_r/tauk, ' [Hz]' !CALL shrink_array(re_trace, n_trace) !CALL shrink_array(im_trace, n_trace) n_trace = 100 IF (fitz_flag) THEN - re_trace = re_trace/tauk - im_trace = im_trace/tauk - sl_out%gamma_sol_arr(k) = g_r/tauk! THIS IS FOR PLOT + !re_trace = re_trace/tauk + !im_trace = im_trace/tauk + sl_out%gamma_sol_arr(k) = 0.0!g_r/tauk! THIS IS FOR PLOT ELSE - re_trace = re_trace/tauk - im_trace = -im_trace/tauk - sl_out%gamma_sol_arr(k) = -g_r/tauk! THIS IS FOR PLOT + !re_trace = re_trace/tauk + !im_trace = -im_trace/tauk + sl_out%gamma_sol_arr(k) = 0.0!-g_r/tauk! THIS IS FOR PLOT END IF IF (stabscan_flag) THEN @@ -645,8 +646,6 @@ PROGRAM slayer !END IF inQs=0.0; iinQs=0.0; deltas=(0.0,0.0) - ALLOCATE(delta_Q(n_k,n_k)) - delta_Q=(0.0,0.0) DO i = 1, (Q_num+1) DO j = 1, Q_num @@ -655,48 +654,9 @@ PROGRAM slayer inQs(i) = ing_coarse iinQs(j) = iing_coarse - ! Evaluate riccati function + ! Evaluate determinant g_tmp = CMPLX(ing_coarse,iing_coarse) - IF (n_k == 1) THEN - WRITE(*,*)"Error: no coupling for msing = 1" - stop - ELSEIF (n_k == 2) THEN - DO k=1,2 - Q_e = sl_in%Q_e_arr(k) - Q_i = sl_in%Q_i_arr(k) - P_perp = sl_in%P_perp_arr(k) - P_tor = sl_in%P_tor_arr(k) - tau = sl_in%tau_arr(k) - D_norm = sl_in%D_norm_arr(k) - c_beta = sl_in%c_beta_arr(k) - tauk = sl_in%Qconv_arr(k) - iota_e = Q_e / (Q_e - Q_i) - - ! (Deltaprime - d_crit)/S^1/3 - ! delta_eff = (sl_in%Re_dp_arr(k) - - !$ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) ! NO DELTA_CRIT - - delta_eff = (sl_in%Re_dp_arr(k) - - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) - - delta=riccati_f(((g_tmp*sl_in%Qconv_arr(1))/ - $ tauk)) - delta_Q(k,k) = delta - END DO - - ! Calculate Deltaprime - Delta(Q) - result_matrix = sl_in%dp_matrix - delta_Q - - ! Calculate determinant - CALL calc_determinant(result_matrix, n_k, det_val) - deltas(i,j) = det_val - ELSEIF (n_k == 3) THEN - WRITE(*,*)"Error: no support for msing = 3" - stop - ELSE - WRITE(*,*)"Error: no support for msing < 3" - stop - END IF + deltas(i,j) = dispersion_det(g_tmp,n_k,sl_in) ENDDO ENDDO From b26cf4158f585800cccf6858834d2323bc7d602d Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Wed, 17 Dec 2025 13:58:18 -0500 Subject: [PATCH 051/118] WIP: cleanups and prep for PR --- input/slayer.in | 1 + slayer/delta.f | 85 +++++---------------- slayer/gslayer.f | 175 ++++++------------------------------------- slayer/layerinputs.f | 6 -- slayer/slayer.f | 65 ++++------------ 5 files changed, 57 insertions(+), 275 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index dd0230d69..ef9e225d4 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -49,6 +49,7 @@ knum=100 ! resolution for 2d scan along with the other. Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes scan_width=1.5 ! stability scan width for Re(Q),Im(Q) scan + msing_max=2 ! number of surfaces to include in coupled tearing growth rate calculation dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation diff --git a/slayer/delta.f b/slayer/delta.f index ce8dc2d46..de3041d47 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -115,29 +115,22 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, REAL(r8),INTENT(IN),OPTIONAL :: inx COMPLEX(r8), INTENT(IN), OPTIONAL :: iny COMPLEX(r8) :: riccati_del_s - INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf INTEGER :: ml = 0, mu = 0, nrpd = 1 - REAL(r8) :: xintv,x,xout,rtol,jac,xmin,my_q,P_hat,alpha COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq,y,dy - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - !IF ((layfac>0).AND.(ABS(Q-Q_e)xout) istep=istep+1 CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,my_jac,mf) + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) WRITE(bin_unit)REAL(my_q,4),REAL(REAL(W),4),REAL(AIMAG(W),4) WRITE(out2_unit,'(1x,3(es17.8e3))')my_q,REAL(W),AIMAG(W) ENDDO @@ -196,7 +185,7 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, istep = 1 itask = 1 CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,my_jac,mf) + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) ENDIF @@ -211,15 +200,15 @@ END FUNCTION riccati_del_s c----------------------------------------------------------------------- c jacobian for riccati_del_s() c------------------------------------------- ---------------------------- - SUBROUTINE my_jac(neq, my_q, W, ml, mu, pd, nrpd) + SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) INTEGER, INTENT(IN) :: neq, ml, mu, nrpd REAL(r8), INTENT(IN) :: my_q COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd pd(1,1) = 1.0/my_q - 2.0d0*W(1)/my_q - END SUBROUTINE my_jac + END SUBROUTINE jac_del_s c----------------------------------------------------------------------- -c riccati integration. +c W derivative for riccati_del_s() c----------------------------------------------------------------------- SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) @@ -230,20 +219,10 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat COMPLEX(r8) :: E,F - !COMPLEX(r8), PARAMETER :: ifac=(0,1) - !Q_hat = Q / ds**4 Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark P_perp_hat = P_perp / D_norm**6.0 ! 0.377 for benchmark P_tor_hat = P_perp / D_norm**6.0 ! 1.15 for benchmark - - !WRITE(*,*)"w_der_del_s P_perp_hat = ",P_perp_hat - !WRITE(*,*)"w_der_del_s P_tor_hat = ",P_tor_hat - !WRITE(*,*)"w_der_del_s Q_hat = ",Q_hat - - !WRITE(*,*)"w_der inpr = ",pr - !WRITE(*,*)"w_der Q_e = ",Q_e - !WRITE(*,*)"w_der D_beta_norm = ",D_beta_norm E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) ! P_tor = P_perp F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 @@ -252,11 +231,8 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F !p*D = my_q RETURN END SUBROUTINE w_der_del_s -c -c -c c----------------------------------------------------------------------- -c calculate delta based on Fitzpatrick delta formulation. +c calculate delta based on Fitzpatrick P_perp and P_tor formulation. c----------------------------------------------------------------------- FUNCTION riccati_f(tmp_g,inx) COMPLEX(r8), INTENT(IN) :: tmp_g @@ -265,41 +241,34 @@ FUNCTION riccati_f(tmp_g,inx) INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf INTEGER :: ml = 0, mu = 0, nrpd = 1 - REAL(r8) :: xintv,x,xout,rtol,jac,xmin,my_p,alpha,bk COMPLEX(r8) :: ak,ck_1,ck_2,ck,xk,W_bound COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dWdp,y,dy - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork neq = 2 itol = 2 - rtol = 1e-10 !changed to 1e-08 !1e-7*pr**0.4 ! !1e-7 at front 1e-6 !e-4 + rtol = 1e-10 ALLOCATE(atol(neq),W(1),dWdp(1)) - atol(:) = 1e-10!*pr**0.4 ! changed to 1e-08 1e-8 !e-4 + atol(:) = 1e-10 itask = 2 istate = 1 iopt = 0 - mf = 21!21 IS STIFF WITH USER-SPECIFIED JACOBIAN, 10 iS NON STIFF + mf = 21 !21 IS STIFF WITH USER-SPECIFIED JACOBIAN, 10 iS NON STIFF liw = 20*2 lrw = 22+9*neq+neq**2 !just (22+16*neq) for mf=10 ALLOCATE(iwork(liw+neq),rwork(lrw)) ! just iwork(liw) for mf=10 -! MXSTEP? iopt = 1 iwork=0 iwork(6)=50000 ! maximum # of steps per call, e.g. 50000 rwork=0 - !!!!!!!! - !IF(present(inx)) my_p=inx!10.0 ! "starting backwards integration at large q" - !!!!!!!! - !my_p=6.0 xmin=1e-6 xout=xmin - ! SOLVE FOR W BOUNDARY CONDITION + ! Solve for p and W boundary conditions IF ((D_norm**2.0) > ((iota_e*P_perp)/(P_tor**(2.0/3.0)))) THEN my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25 IF (my_p < 6.0) THEN @@ -312,10 +281,6 @@ FUNCTION riccati_f(tmp_g,inx) ck = bk*(1+(g_tmp+ifac*Q_i)*((P_tor+P_perp)/(P_tor*P_perp))- $ (P_perp+(g_tmp + $ ifac*Q_i)*(D_norm**2.0) )*(iota_e/(P_tor*(D_norm**2.0)))) - ! ck_1 = 2.0*(g_tmp + ifac*Q_i)/P_perp - ! ck_2 = (P_perp + (g_tmp + - !$ ifac*Q_i)*(D_norm**2.0))/(2.0*P_perp*(D_norm**2.0)) - ! ck = (P_perp/(2.0*(D_norm**2.0)))*(1 + ck_1 - ck_2) xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0*SQRT(bk)) @@ -361,17 +326,9 @@ FUNCTION riccati_f(tmp_g,inx) itask = 1 CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) - ENDIF - ! w=0 when Q=Q_e. Why? - CALL w_der_f(neq,my_p,W,dWdp) - !WRITE(*,*)"riccati Q_e = ",Q_e - !WRITE(*,*)"riccati Q_i = ",Q_i - !WRITE(*,*)"riccati pr = ",pr - !WRITE(*,*)"riccati D_beta_norm = ",D_beta_norm - !WRITE(*,*)"riccati g_tmp = ",g_tmp !riccati_f = pi * my_p / (dWdp(1) + 1) riccati_f = pi / dWdp(1) @@ -379,7 +336,7 @@ FUNCTION riccati_f(tmp_g,inx) END FUNCTION riccati_f c----------------------------------------------------------------------- -c jacobian for riccati_del_s() +c jacobian for riccati_f() c------------------------------------------- ---------------------------- SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) INTEGER, INTENT(IN) :: neq, ml, mu, nrpd @@ -394,7 +351,7 @@ SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) pd(1,1) = (-fA_p/my_p) - (2.0*W(1))/my_p END SUBROUTINE jac_f c----------------------------------------------------------------------- -c riccati integration. +c W derivative for riccati_f() c----------------------------------------------------------------------- SUBROUTINE w_der_f(neq,my_p,W,dWdp) @@ -404,8 +361,6 @@ SUBROUTINE w_der_f(neq,my_p,W,dWdp) COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dWdp COMPLEX(r8) :: fA, fA_prime, fB, fC - !WRITE(*,*)"w_der g_tmp = ",g_tmp - ! Evaluate coefficients at the current p fA = (my_p**2)/(g_tmp + ifac*Q_e + (my_p**2.0)) fA_prime = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + @@ -422,9 +377,9 @@ SUBROUTINE w_der_f(neq,my_p,W,dWdp) RETURN END SUBROUTINE w_der_f -c -c -c +c----------------------------------------------------------------------- +c W derivative for riccati() +c----------------------------------------------------------------------- SUBROUTINE w_der(neq,x,y,dy) INTEGER, INTENT(IN) :: neq diff --git a/slayer/gslayer.f b/slayer/gslayer.f index d10d3280b..d79f9bfce 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -176,8 +176,8 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- -c Subprogram 3. scan_grid -c Run stability scan on real and imaginary rotation axes +c Subprogram 2. output_gamma +c Take SLAYER input and output dicts, send to netCDF subroutine c----------------------------------------------------------------------- SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out) @@ -190,7 +190,10 @@ SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out) $ sl_in,sl_out) END SUBROUTINE output_gamma - +c----------------------------------------------------------------------- +c Subprogram 3. allocate_inputs +c Allocate arrays inside SLAYER inputs type (dictionary-esque) +c----------------------------------------------------------------------- SUBROUTINE allocate_inputs(n_k,sl_in) INTEGER, INTENT(IN) :: n_k TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in @@ -205,7 +208,10 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k)) RETURN END SUBROUTINE allocate_inputs - +c----------------------------------------------------------------------- +c Subprogram 4. allocate_outputs +c Allocate arrays inside SLAYER outputs type (dictionary-esque) +c----------------------------------------------------------------------- SUBROUTINE allocate_outputs(n_k,sl_out) INTEGER, INTENT(IN) :: n_k TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out @@ -215,139 +221,7 @@ SUBROUTINE allocate_outputs(n_k,sl_out) RETURN END SUBROUTINE allocate_outputs c----------------------------------------------------------------------- -c Subprogram 2. growthrate_scan -c Set up and iterate stability scans IF no match is found -c----------------------------------------------------------------------- - SUBROUTINE growthrate_scan(qval,my_lu,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,inQ0,inpr,inpe,scan_radius,ncoarse, - $ compress_deltas,deltaprime,results) -c----------------------------------------------------------------------- -c Declarations -c----------------------------------------------------------------------- - ! Inputs - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inc_beta,inds, - $ intau,inQ0,inpr,inpe,my_lu - INTEGER, INTENT(IN) :: qval,scan_radius,ncoarse - REAL(r8), INTENT(IN) :: deltaprime - LOGICAL, INTENT(IN) :: compress_deltas - TYPE(result_type), INTENT(INOUT) :: results - - COMPLEX(r8) :: delta - INTEGER :: new_scan_radius,new_ncoarse - INTEGER :: nfine, new_nfine - REAL(r8), PARAMETER :: tolerance = 1.0E-6 - REAL(r8) :: delta_real, delta_imag, threshold - INTEGER :: i, j, k, l, m, count, match_count - LOGICAL :: repeat - REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, - $ inQ_coarse, iinQ_coarse - INTEGER :: max_points, new_max_points - INTEGER :: ci, cj, nx, ny - REAL(r8) :: dx, dy, overlap_factor - INTEGER :: fi, fj - REAL(r8) :: fine_dx, fine_dy, overlap_x, overlap_y - REAL(r8) :: x_start, x_end, y_start, y_end, x, y - !!!!!!!!!!!!!!!! - repeat = .FALSE. - dx = 1.0 - dy = 1.0 - nfine = 6 - overlap_factor = 0.5 - max_points = ncoarse**2 * ((nfine)**2 - 1) - - ! Allocate arrays with maximum possible size - ALLOCATE(results%inQs(max_points), results%iinQs(max_points)) - ALLOCATE(results%Re_deltas(max_points), - $ results%Im_deltas(max_points)) - - results%inQs=0.0 - results%iinQs=0.0 - results%Re_deltas=0.0 - results%Im_deltas=0.0 - ! Initialize counter - count = 0 - - ! Calculate step sizes - inQ_step = (2.0 * scan_radius) / (ncoarse - 1) - iinQ_step = (2.0 * scan_radius) / (ncoarse - 1) - dx = inQ_step - dy = iinQ_step - - match_count = 0 - ! Run scan - CALL scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe,my_lu, - $ scan_radius,ncoarse,nfine,deltaprime,compress_deltas, - $ results,count,match_count,dx,dy) - - ! Set the actual count of points - results%count = count - - IF (count < max_points) THEN - ! Resize arrays to actual number of points - CALL shrink_array(results%inQs, count) - CALL shrink_array(results%iinQs, count) - CALL shrink_array(results%Re_deltas, count) - CALL shrink_array(results%Im_deltas, count) - END IF - - RETURN - END SUBROUTINE growthrate_scan -c----------------------------------------------------------------------- -c Subprogram 3. scan_grid -c Run stability scan on real and imaginary rotation axes -c----------------------------------------------------------------------- - SUBROUTINE scan_grid(inQ_e,inQ_i,inpr,inc_beta,inds,intau, - $ inpe,my_lu,scan_radius,ncoarse,nfine,deltaprime, - $ compress_deltas,results,count,match_count,dx,dy) - - ! Declarations (include necessary type declarations from original code) - REAL(r8), INTENT(IN) :: inQ_e,inQ_i,inpr,inc_beta,inds, - $ intau,inpe,my_lu,deltaprime - INTEGER, INTENT(IN) :: scan_radius, ncoarse, nfine - LOGICAL, INTENT(IN) :: compress_deltas - TYPE(result_type), INTENT(INOUT) :: results - INTEGER, INTENT(INOUT) :: count, match_count - REAL(r8), INTENT(INOUT) :: dx, dy - - ! Local variables - REAL(r8) :: inQ_step, iinQ_step, inQ_fine, iinQ_fine, - $ inQ_coarse, iinQ_coarse - REAL(r8) :: delta_real, delta_imag, threshold - COMPLEX(r8) :: delta - REAL(r8) :: fine_dx, fine_dy, overlap_x, overlap_y - REAL(r8) :: x_start, x_end, y_start, y_end - INTEGER :: i, j, fi, fj - REAL(r8), PARAMETER :: tolerance = 1.0E-6 - REAL(r8) :: overlap_factor = 0.5 - - ! Calculate step sizes - inQ_step = (2.0 * scan_radius) / (ncoarse - 1) - iinQ_step = (2.0 * scan_radius) / (ncoarse - 1) - dx = inQ_step - dy = iinQ_step - count = 0 - - DO i = 1, ncoarse - DO j = 1, ncoarse - inQ_coarse = -scan_radius + (i - 1) * inQ_step - iinQ_coarse = -scan_radius + (j - 1) * iinQ_step - ! Evaluate riccati FUNCTION - delta = riccati(inQ_coarse,inQ_e,inQ_i,inpr,inc_beta, - $ inds,intau,inpe,iinQ=iinQ_coarse) - delta_real = REAL(delta)*(my_lu**(1.0/3.0)) ! Critical normalization - delta_imag = AIMAG(delta)*(my_lu**(1.0/3.0)) ! Critical normalization - - count = count + 1 - results%inQs(count) = inQ_coarse - results%iinQs(count) = iinQ_coarse - results%Re_deltas(count) = delta_real - results%Im_deltas(count) = delta_imag - - END DO - END DO - END SUBROUTINE scan_grid -c----------------------------------------------------------------------- -c Subprogram 4. shrink_array +c Subprogram 5. shrink_array c Remove excess scan array size from memory c----------------------------------------------------------------------- SUBROUTINE shrink_array(arr, new_size) @@ -360,7 +234,7 @@ SUBROUTINE shrink_array(arr, new_size) CALL move_alloc(temp, arr) END SUBROUTINE shrink_array c----------------------------------------------------------------------- -c Subprogram 5. grow_array +c Subprogram 6. grow_array c Increase scan array size IF necessary c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) @@ -372,12 +246,9 @@ SUBROUTINE grow_array(arr, old_size, new_size) temp(1:old_size) = arr(1:old_size) CALL move_alloc(temp, arr) END SUBROUTINE grow_array -c -c -c c----------------------------------------------------------------------- -c Subprogram 6. determinant -c Increase scan array size IF necessary +c Subprogram 7. calc_determinant +c Calculate determinant of 2x2 and 3x3 matrices c----------------------------------------------------------------------- SUBROUTINE calc_determinant(matk, nk, detk) IMPLICIT NONE @@ -387,9 +258,7 @@ SUBROUTINE calc_determinant(matk, nk, detk) COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! Input matrix COMPLEX(r8), INTENT(OUT) :: detk ! Determinant result INTEGER :: status ! Status (0=success, -1=error) - - ! Local variables - + status = 0 ! Initialize status as success SELECT CASE (nk) @@ -412,13 +281,14 @@ SUBROUTINE calc_determinant(matk, nk, detk) END SELECT RETURN END SUBROUTINE calc_determinant -c -c -c Adapted from - FUNCTION dispersion_det(g_tmp,n_k,sl_in) +c----------------------------------------------------------------------- +c Subprogram 8. dispersion_det +c Calculate determinant of coupling matrix e-value problem +c----------------------------------------------------------------------- + FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) COMPLEX(r8), INTENT(IN) :: g_tmp - INTEGER, INTENT(IN) :: n_k + INTEGER, INTENT(IN) :: n_k,msing_max TYPE(slayer_inputs_type), INTENT(IN) :: sl_in COMPLEX(r8) :: dispersion_det,det_val,tmp_delta COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:),result_matrix(:,:) @@ -444,7 +314,7 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in) ELSEIF ((n_k == 2) .OR. (n_k == 3)) THEN ALLOCATE(delta_Q(n_k,n_k)) delta_Q=(0.0,0.0) - DO k=1,2 !!! MAXING OUT AT 2X2 + DO k=1,msing_max ! maxing out at msing_max Q_e = sl_in%Q_e_arr(k) Q_i = sl_in%Q_i_arr(k) P_perp = sl_in%P_perp_arr(k) @@ -474,5 +344,4 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in) stop END IF END FUNCTION dispersion_det - END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index be8f64e8a..7dabfbae8 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -77,12 +77,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) CALL sl_check(stat) - !bt0_id=0 !!!!! THIS COULD BE A PROBLEM - !nn_id=0 - !mpsi_id=0 - !psio_id=0 - !ro_id=0 - ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), $ my_psio(INT(psio_len)), $ mpsi(INT(mpsi_len)),nn(INT(nn_len))) diff --git a/slayer/slayer.f b/slayer/slayer.f index 08971bee5..773a6cdf0 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -22,7 +22,7 @@ PROGRAM slayer CHARACTER(512) :: infile,ncfile INTEGER :: i,j,k,inum,jnum,knum,inn,count, - $ Q_num,n_k + $ Q_num,msing_max,n_k INTEGER, DIMENSION(1) :: index LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, @@ -32,8 +32,8 @@ PROGRAM slayer $ bal_flag,stability_flag,riccatiscan_flag,input_flag, $ params_check,stabscan_flag,read_eq,est_gamma_flag, $ match_gamma_flag,fitz_flag,coupling_flag,br_th_flag - REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_width,l_n,l_t, - $ qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val + REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_width,l_n, + $ l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, @@ -67,10 +67,10 @@ PROGRAM slayer $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,Q0,delta_prime,delta_n_p,ingamma NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, - $ dc_type,read_eq,fitz_flag,coupling_flag,QPscan_flag, - $ Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag,otscan_flag, - $ ntscan_flag,nbtscan_flag,parflow_flag,peohmonly_flag, - $ Pe_flag,layfac + $ msing_max,dc_type,read_eq,fitz_flag,coupling_flag, + $ QPscan_flag,Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag, + $ otscan_flag,ntscan_flag,nbtscan_flag,parflow_flag, + $ peohmonly_flag,Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ est_gamma_flag,match_gamma_flag,stability_flag, $ stabscan_flag,br_th_flag,bal_flag @@ -122,6 +122,7 @@ PROGRAM slayer knum=100 ! resolution for 2d scan alont with the other. Q_num=100 ! resolution for stab. scan along Re(Q) axis scan_width = 2.0 + msing_max = 2 in_unit=1 out_unit=2 out2_unit=3 @@ -485,14 +486,10 @@ PROGRAM slayer END IF END IF - ALLOCATE(re_trace(100),im_trace(100)) - ALLOCATE(sl_out%r_trace(n_k,100), - $ sl_out%i_trace(n_k,100)) - !-------------- !n_k = 1 !-------------- - DO k=1,2!!!!!!!!!!!!!! ONLY DOING TWO SURFACES + DO k=1,msing_max WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', $ sl_in%qval_arr(k),' rational surface:' @@ -520,53 +517,19 @@ PROGRAM slayer WRITE(*,*)"slayer.f D_crit: ",sl_in%d_crit_arr(k) WRITE(*,*),"sl_in%qval_arr: ",sl_in%qval_arr - ! (Deltaprime - d_crit)/S^1/3 + ! Calculate (Deltaprime - d_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) c delta_eff = Re_deltaprime_arr(k) pe = 0.0 - re_trace = 0.0 - im_trace = 0.0 - n_trace = 1 - - IF (fitz_flag) THEN - g_r = 0.0 - g_i = -Q_e - re_trace(1) = 0.0 - im_trace(1) = -Q_e - ELSE - g_i = 0.0 - g_r = -Q_e - im_trace(1) = 0.0 - re_trace(1) = -Q_e - END IF - - WRITE(*,*)"no longer using newton_root(): " - !CALL newton_root(g_r,g_i,1,fitz_flag) - - WRITE(*,*) - !WRITE(*,'(A,F0.3,A)') 'Success! Growth rate = ', - !$ g_r/tauk, ' [Hz]' - - !CALL shrink_array(re_trace, n_trace) - !CALL shrink_array(im_trace, n_trace) - n_trace = 100 - - IF (fitz_flag) THEN - !re_trace = re_trace/tauk - !im_trace = im_trace/tauk - sl_out%gamma_sol_arr(k) = 0.0!g_r/tauk! THIS IS FOR PLOT - ELSE - !re_trace = re_trace/tauk - !im_trace = -im_trace/tauk - sl_out%gamma_sol_arr(k) = 0.0!-g_r/tauk! THIS IS FOR PLOT - END IF +c ! Fill gamma_sol_arr with 0's, will by used by python root finding + sl_out%gamma_sol_arr(k) = 0.0 IF (stabscan_flag) THEN WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// - $ 'Im(Q)] scan with radius = ', + $ 'Im(Q)] scan with Q width = ', $ scan_width ing_step = (2.0 * scan_width) / (Q_num - 1) @@ -656,7 +619,7 @@ PROGRAM slayer ! Evaluate determinant g_tmp = CMPLX(ing_coarse,iing_coarse) - deltas(i,j) = dispersion_det(g_tmp,n_k,sl_in) + deltas(i,j)=dispersion_det(g_tmp,n_k,sl_in,msing_max) ENDDO ENDDO From 357aadf432566af8b6f9d0ba15e2e663a2b0454a Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 22 Jan 2026 20:39:39 -0500 Subject: [PATCH 052/118] WIP: SLAYER AMR using hash table --- input/slayer.in | 2 + slayer/gslayer.f | 269 ++++++++++++++++++++++++++++++++++++++++- slayer/sglobal.f | 20 ++- slayer/slayer.f | 72 ++++++++--- slayer/slayer_netcdf.f | 81 +++++++++++-- 5 files changed, 411 insertions(+), 33 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index ef9e225d4..1889bca87 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -77,6 +77,8 @@ match_gamma_flag=t ! Find Delta_hat = Delta_prime match to solve for growth rate stability_flag=f ! calculate delta dependence on complex Q stabscan_flag=f ! Generate Re(Q),Im(Q) scan and output as ASCII + coupled_stabscan_flag=f ! Generate Re(Q),Im(Q) scan and output as ASCII + amr_flag=t ! Generate Re(Q),Im(Q) scan and output as ASCII br_th_flag=f ! Calculate br_th bal_flag=f ! calculate the resonant field penetration threshold from torque balance / diff --git a/slayer/gslayer.f b/slayer/gslayer.f index d79f9bfce..3bf091245 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -179,15 +179,18 @@ END SUBROUTINE gpec_slayer c Subprogram 2. output_gamma c Take SLAYER input and output dicts, send to netCDF subroutine c----------------------------------------------------------------------- - SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out) + SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out, + $ all_deltas_out) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: est_gamma_flag TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out + TYPE(deltas_outputs_type), INTENT(IN) :: + $ all_deltas_out(SIZE(sl_in%qval_arr)) CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),est_gamma_flag, - $ sl_in,sl_out) + $ sl_in,sl_out,all_deltas_out) END SUBROUTINE output_gamma c----------------------------------------------------------------------- @@ -324,9 +327,6 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) c_beta = sl_in%c_beta_arr(k) tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) - - delta_eff = (sl_in%Re_dp_arr(k) - - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) delta_Q(k,k)=riccati_f(((g_tmp*sl_in%Qconv_arr(1)) $ /tauk)) @@ -344,4 +344,263 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) stop END IF END FUNCTION dispersion_det + + SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, + $ scan_width,Q_num,AMR_passes, + $ coupling_flag) + !WRITE(*,*)"------------------------------------------" + !WRITE(*,'(A,F0.1,A,I2,A)')' >>> Running Adaptive AMR Scan [Width=',scan_width, & + ! ', Passes=', AMR_PASSES, ']' + INTEGER, INTENT(IN) :: n_k,msing_max,Q_num,AMR_passes + REAL(r8), INTENT(IN) :: scan_width + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + + !COMPLEX(r8), INTENT(OUT), ALLOCATABLE :: Q_store(:) ! Stores Q coordinates + !COMPLEX(r8), INTENT(OUT), ALLOCATABLE :: D_store(:) ! Stores Result Delta + INTEGER, ALLOCATABLE :: cells(:,:) ! 4 corners (indices) per cell + INTEGER, ALLOCATABLE :: new_cells(:,:) ! Temp array for next level + INTEGER :: n_cells, n_new_cells, i, j + INTEGER :: h_idx, pt_idx, c_idx, pass + INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! Corner indices + INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! Midpoint indices + REAL(r8) :: r_min, r_max, i_min, i_max, ing_step, + $ ing_coarse,iing_coarse + LOGICAL :: cross_real, cross_imag + !INTEGER, INTENT(OUT) :: n_pts + + COMPLEX(r8) :: q_curr + + ! (Re-allocate or just reset counters. Re-allocating ensures clean slate) + !IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store, D_store) + !IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head, hash_next) + !IF (ALLOCATED(cells)) DEALLOCATE(cells, new_cells) + + ! --- 1. Initialize Memory --- + ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) + ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) + ALLOCATE(cells(4, 200000), new_cells(4, 200000)) ! Estimate cell count + + hash_head = 0 + hash_next = 0 + n_pts = 0 + n_cells = 0 + + ! --- 2. Build Initial Coarse Grid (100x100) --- + ! We treat the grid as a collection of quadrilateral cells + ing_step = (2.0*scan_width) / (Q_num - 1) + + ! A. Generate Points & Evaluate + DO i = 1, Q_num + DO j = 1, Q_num + ing_coarse = -scan_width + (i - 1) * ing_step + iing_coarse = -scan_width + (j - 1) * ing_step + q_curr = CMPLX(ing_coarse, iing_coarse) + + ! Check/Compute (Using inline logic to simulate a function call) + CALL get_or_compute(q_curr, pt_idx,n_k,sl_in,msing_max, + $ coupling_flag) + + ! If we are not at the right/bottom edge, form a cell with neighbors + IF (i < Q_num .AND. j < Q_num) THEN + n_cells = n_cells + 1 + ! Store indices of corners: TL, TR, BL, BR (row-major logic) + ! Note: This indexing assumes we inserted in order, but for AMR + ! we must rely on the returned pt_idx, not loop counters. + ! To simplify, we just store the TL index and calculate others? + ! No, AMR breaks structure. We must look up all 4 corners. + + ! Top-Left (current) + cells(1, n_cells) = pt_idx + + ! Top-Right (i+1, j) + q_curr = CMPLX(ing_coarse + ing_step, iing_coarse) + CALL get_or_compute(q_curr, cells(2, n_cells),n_k, + $ sl_in,msing_max,coupling_flag) + + ! Bottom-Left (i, j+1) + q_curr = CMPLX(ing_coarse, iing_coarse+ing_step) + CALL get_or_compute(q_curr, cells(3, n_cells),n_k, + $ sl_in,msing_max,coupling_flag) + + ! Bottom-Right (i+1, j+1) + q_curr = CMPLX(ing_coarse + ing_step, iing_coarse+ + $ ing_step) + CALL get_or_compute(q_curr, cells(4, n_cells),n_k, + $ sl_in,msing_max,coupling_flag) + END IF + END DO + END DO + + ! --- 3. Refinement Loops --- + DO pass = 1, AMR_PASSES + WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, + $ ': Checking ', n_cells, ' cells...' + n_new_cells = 0 + + DO c_idx = 1, n_cells + idx_TL = cells(1, c_idx) + idx_TR = cells(2, c_idx) + idx_BL = cells(3, c_idx) + idx_BR = cells(4, c_idx) + + ! Check for contours (Sign changes across the cell) + ! Real Part Check + r_min = MIN(REAL(D_store(idx_TL)), + $ REAL(D_store(idx_TR)), + $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BR))) + r_max = MAX(REAL(D_store(idx_TL)), + $ REAL(D_store(idx_TR)), + $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BR))) + cross_real = (r_min * r_max <= 0.0d0) + + ! Imag Part Check + i_min = MIN(AIMAG(D_store(idx_TL)), + $ AIMAG(D_store(idx_TR)), + $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BR))) + i_max = MAX(AIMAG(D_store(idx_TL)), + $ AIMAG(D_store(idx_TR)), + $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BR))) + cross_imag = (i_min * i_max <= 0.0d0) + + IF (cross_real .OR. cross_imag) THEN + ! --- REFINE THIS CELL --- + ! We need 5 new points: Top-Mid, Bot-Mid, Left-Mid, Right-Mid, Center + + ! Calculate coords from corners + ! TL: Q_store(idx_TL), BR: Q_store(idx_BR) + + ! Top-Mid + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_TR)) + CALL get_or_compute(q_curr, idx_TM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Bot-Mid + q_curr = 0.5d0*(Q_store(idx_BL)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_BM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Left-Mid + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BL)) + CALL get_or_compute(q_curr, idx_LM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Right-Mid + q_curr = 0.5d0*(Q_store(idx_TR)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_RM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Center + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_MM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Create 4 new sub-cells (Top-Left, Top-Right, Bot-Left, Bot-Right) + ! Sub 1 (Top-Left) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_TL + new_cells(2, n_new_cells) = idx_TM + new_cells(3, n_new_cells) = idx_LM + new_cells(4, n_new_cells) = idx_MM + + ! Sub 2 (Top-Right) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_TM + new_cells(2, n_new_cells) = idx_TR + new_cells(3, n_new_cells) = idx_MM + new_cells(4, n_new_cells) = idx_RM + + ! Sub 3 (Bot-Left) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_LM + new_cells(2, n_new_cells) = idx_MM + new_cells(3, n_new_cells) = idx_BL + new_cells(4, n_new_cells) = idx_BM + + ! Sub 4 (Bot-Right) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_MM + new_cells(2, n_new_cells) = idx_RM + new_cells(3, n_new_cells) = idx_BM + new_cells(4, n_new_cells) = idx_BR + + ELSE + ! No refinement needed, keep original cell + n_new_cells = n_new_cells + 1 + new_cells(:, n_new_cells) = cells(:, c_idx) + END IF + END DO + + ! Swap arrays for next iteration + n_cells = n_new_cells + cells(:, 1:n_cells) = new_cells(:, 1:n_cells) + + END DO + DEALLOCATE(cells, new_cells) + WRITE(*,*) "AMR Scan Complete. Total Points:", n_pts + WRITE(*,*)"gslayer.f Q_store(10) = ",Q_store(10) + RETURN + END SUBROUTINE dispersion_AMR + + SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, + $ coupling_flag) + COMPLEX(r8), INTENT(IN) :: q_in + !INTEGER, INTENT(INOUT) :: n_pts + !COMPLEX(r8), INTENT(INOUT) :: Q_store(:),D_store(:) + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + INTEGER, INTENT(IN) :: n_k, msing_max + INTEGER, INTENT(OUT) :: idx_out + LOGICAL, INTENT(IN) :: coupling_flag + INTEGER :: h, curr, ix, iy + COMPLEX(r8) :: delta_val + + ! 1. Calculate Hash + ix = NINT(REAL(q_in) * HASH_SCALE) + iy = NINT(AIMAG(q_in) * HASH_SCALE) + ! Simple hash mix + h = MOD(ABS(ix * 73856093 + iy * 19349663), HASH_SZ) + 1 + + ! 2. Check collisions + curr = hash_head(h) + DO WHILE (curr /= 0) + ! Check if point matches (with small tolerance) + IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN + idx_out = curr + RETURN ! Found it, return existing index + END IF + curr = hash_next(curr) + END DO + + ! 3. Not found: Compute and Store + n_pts = n_pts + 1 + + IF (n_pts > MAX_PTS) THEN + WRITE(*,*) "ERROR: AMR exceeded MAX_PTS" + STOP + END IF + + idx_out = n_pts + Q_store(idx_out) = q_in + + ! --- PHYSICS EVALUATION --- + IF (coupling_flag) THEN + g_tmp = q_in + delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) + ELSE + g_tmp = q_in + delta_val = riccati_f(g_tmp) + !delta_val = delta_val - delta_eff + END IF + D_store(idx_out) = delta_val + ! -------------------------- + + ! 4. Add to Hash Table + hash_next(idx_out) = hash_head(h) + hash_head(h) = idx_out + + END SUBROUTINE get_or_compute END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index eafcd4386..334ebc530 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -13,7 +13,6 @@ MODULE sglobal_mod REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i,iota_e, $ delta_n,layfac,Qconv,lnLamb,deltaprim,dc_tmp, $ d_crit,tau_r,tauk,g_r,g_i,delta_eff - REAL(r8), DIMENSION(:), ALLOCATABLE :: re_trace,im_trace COMPLEX(r8) :: Q,g_tmp,delta_det CHARACTER(20) :: dc_type @@ -21,6 +20,15 @@ MODULE sglobal_mod $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6021917e-19, $ kval=1.3807e-23,eps0 = 8.8542e-12 + INTEGER, PARAMETER :: MAX_PTS = 500000 ! Max unique points allowed + INTEGER, PARAMETER :: HASH_SZ = 500009 ! Prime number for hash table + REAL(r8), PARAMETER :: HASH_SCALE = 1.0d5 ! Scaling factor for integer hashing + INTEGER, ALLOCATABLE :: hash_head(:) ! Hash bucket heads + INTEGER, ALLOCATABLE :: hash_next(:) ! Linked list next pointers + INTEGER :: n_pts + COMPLEX(r8), ALLOCATABLE :: Q_store(:) ! Stores Q coordinates + COMPLEX(r8), ALLOCATABLE :: D_store(:) ! Stores Result Delta + TYPE result_type REAL(r8), ALLOCATABLE :: inQs(:), iinQs(:), $ Re_deltas(:), Im_deltas(:) @@ -40,10 +48,16 @@ MODULE sglobal_mod TYPE slayer_outputs_type COMPLEX(r8), ALLOCATABLE :: dels_db_arr(:),gamma_sol_arr(:), - $ gamma_est_arr(:) - REAL(r8), ALLOCATABLE :: r_trace(:,:),i_trace(:,:) + $ gamma_est_arr(:) END TYPE slayer_outputs_type + TYPE deltas_outputs_type + REAL(r8), ALLOCATABLE :: inQs(:) + REAL(r8), ALLOCATABLE :: iinQs(:) + REAL(r8), ALLOCATABLE :: real_deltas(:) + REAL(r8), ALLOCATABLE :: imag_deltas(:) + END TYPE deltas_outputs_type + ! lnLamb will be updated. COMPLEX(r8), PARAMETER :: ifac=(0,1) diff --git a/slayer/slayer.f b/slayer/slayer.f index 773a6cdf0..3f398681a 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -30,7 +30,8 @@ PROGRAM slayer $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,stabscan_flag,read_eq,est_gamma_flag, + $ params_check,stabscan_flag,coupled_stabscan_flag,amr_flag, + $ read_eq,est_gamma_flag, $ match_gamma_flag,fitz_flag,coupling_flag,br_th_flag REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_width,l_n, $ l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val @@ -57,9 +58,13 @@ PROGRAM slayer REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas - + + ! AMR DECLARATIONS + INTEGER, PARAMETER :: AMR_passes = 4 ! Number of refinement levels (User Set) + TYPE(slayer_inputs_type) :: sl_in TYPE(slayer_outputs_type) :: sl_out + TYPE(deltas_outputs_type), ALLOCATABLE :: all_deltas_out(:) NAMELIST/slayer_input/input_flag,infile, $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, @@ -73,7 +78,8 @@ PROGRAM slayer $ peohmonly_flag,Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ est_gamma_flag,match_gamma_flag,stability_flag, - $ stabscan_flag,br_th_flag,bal_flag + $ stabscan_flag,coupled_stabscan_flag,amr_flag,br_th_flag, + $ bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, $ params_check c----------------------------------------------------------------------- @@ -161,6 +167,8 @@ PROGRAM slayer bal_flag=.FALSE. stability_flag=.FALSE. stabscan_flag=.FALSE. + coupled_stabscan_flag=.FALSE. + amr_flag=.FALSE. br_th_flag=.FALSE. c----------------------------------------------------------------------- c read slayer.in. @@ -404,7 +412,8 @@ PROGRAM slayer IF (.NOT. (match_gamma_flag)) THEN sl_out%gamma_sol_arr = (/0./) - CALL output_gamma(est_gamma_flag,sl_in,sl_out) + CALL output_gamma(est_gamma_flag,sl_in,sl_out, + $ all_deltas_out) END IF ENDIF c----------------------------------------------------------------------- @@ -486,10 +495,12 @@ PROGRAM slayer END IF END IF - !-------------- - !n_k = 1 - !-------------- - DO k=1,msing_max + IF (amr_flag) THEN + !IF (ALLOCATED(all_deltas_out)) DEALLOCATE(all_deltas_out) + ALLOCATE(all_deltas_out(n_k)) + END IF + + DO k=1,MIN(n_k,msing_max) WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', $ sl_in%qval_arr(k),' rational surface:' @@ -526,13 +537,45 @@ PROGRAM slayer c ! Fill gamma_sol_arr with 0's, will by used by python root finding sl_out%gamma_sol_arr(k) = 0.0 - IF (stabscan_flag) THEN + IF (amr_flag) THEN + + CALL dispersion_AMR(n_k,sl_in,msing_max,scan_width, + $ Q_num,AMR_passes,coupling_flag) + WRITE(*,*)"Q_store(10) = ",Q_store(10) + + WRITE(*,*)"n_pts = ",n_pts + + ! --- 4. Export to Output Arrays --- + ! Flatten the unique points store into the requested 1D arrays + ALLOCATE(all_deltas_out(k)%inQs(n_pts), + $ all_deltas_out(k)%iinQs(n_pts)) + ! Assumes you also have real_deltas/imag_deltas declared as 1D + ALLOCATE(all_deltas_out(k)%real_deltas(n_pts), + $ all_deltas_out(k)%imag_deltas(n_pts)) + + DO i = 1, n_pts + all_deltas_out(k)%inQs(i) = REAL(Q_store(i)) + IF (fitz_flag) THEN + all_deltas_out(k)%iinQs(i) = AIMAG(Q_store(i)) + ELSE + all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) + END IF + all_deltas_out(k)%real_deltas(i) = REAL(D_store(i)) + all_deltas_out(k)%imag_deltas(i) = AIMAG(D_store(i)) + END DO + + ! Clean up temporary AMR memory + DEALLOCATE(Q_store, D_store, hash_head, hash_next) + + END IF + + IF ((stabscan_flag)) THEN ! was .AND. (k == 2) WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// $ 'Im(Q)] scan with Q width = ', $ scan_width - ing_step = (2.0 * scan_width) / (Q_num - 1) + ing_step = (2.0*scan_width) / (Q_num - 1) ! was (2.0 * scan_width) / (Q_num - 1) count = 0 ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) @@ -540,7 +583,7 @@ PROGRAM slayer DO i = 1, (Q_num+1) DO j = 1, Q_num - ing_coarse = -scan_width + (i - 1) * ing_step + ing_coarse = -scan_width + (i - 1) * ing_step ! added 0.5* iing_coarse = -scan_width + (j - 1) * ing_step ! Evaluate riccati function g_tmp = CMPLX(ing_coarse,iing_coarse) @@ -586,15 +629,12 @@ PROGRAM slayer ENDIF ENDDO - sl_out%r_trace(k,:) = re_trace - sl_out%i_trace(k,:) = im_trace - IF (.NOT. (est_gamma_flag)) THEN sl_in%d_beta_arr = (/ 0. /) sl_out%dels_db_arr = (/ 0. /) END IF - IF (coupling_flag) THEN + IF (coupled_stabscan_flag) THEN WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// $ 'Im(Q)] determinant scan with radius = ', @@ -639,7 +679,7 @@ PROGRAM slayer DEALLOCATE(inQs,iinQs,deltas) END IF - CALL output_gamma(est_gamma_flag,sl_in,sl_out) + CALL output_gamma(est_gamma_flag,sl_in,sl_out,all_deltas_out) stop ENDIF c----------------------------------------------------------------------- diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index f665e3279..c597c7311 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -49,20 +49,30 @@ END SUBROUTINE sl_check c declarations. c ----------------------------------------------------------------------- SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, - $ sl_in,sl_out) + $ sl_in,sl_out,all_deltas_out) INTEGER, INTENT(IN) :: msing LOGICAL, INTENT(IN) :: est_gamma_flag TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out + TYPE(deltas_outputs_type), INTENT(IN) :: all_deltas_out(msing) INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,p_perp_id,S_id, - $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,tr_id,tr_dim, + $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id, $ qsing_id,qc_id,p_tor_id INTEGER :: run, run_dimid, point_dimid, varids(4) + ! AMR declarations + INTEGER :: max_pts_all, s, n_curr + INTEGER :: dim_pts_id + INTEGER :: var_q_id, var_d_id, var_npts_id + REAL(r8), ALLOCATABLE :: buffer_q(:,:,:), buffer_d(:,:,:) + INTEGER, ALLOCATABLE :: n_pts_arr(:) + REAL(r8) :: fill_val = -9.99E33 ! Standard NetCDF Fill Value + ! AMR declarations + CHARACTER(64) :: ncfile LOGICAL, PARAMETER :: debug_flag = .FALSE. CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' @@ -84,7 +94,48 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, IF(debug_flag) PRINT *," - Creating netcdf files" CALL sl_check( nf90_create(ncfile, $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) +c +c reform "ragged" AMR delta ouputs into rectangular array +c + ! 1. Find the Maximum AMR Grid Size across all surfaces + max_pts_all = 0 + DO s = 1, msing + IF (ALLOCATED(all_deltas_out(s)%inQs)) THEN + max_pts_all = MAX(max_pts_all,SIZE(all_deltas_out(s)%inQs)) + END IF + END DO + + ! 2. Allocate Rectangular Buffers (Points, Surfaces, Re/Im) + ! Shape: (Max_Points, Number_Surfaces, 2) + ALLOCATE(buffer_q(max_pts_all, msing, 2)) + ALLOCATE(buffer_d(max_pts_all, msing, 2)) + ALLOCATE(n_pts_arr(msing)) + + ! Initialize with Fill Value (so unused space is ignored by plotters) + buffer_q = 0.0 + buffer_d = 0.0 + n_pts_arr = 0 + + ! 3. Flatten the Ragged Data into the Buffers + DO s = 1, msing + IF (ALLOCATED(all_deltas_out(s)%inQs)) THEN + n_curr = SIZE(all_deltas_out(s)%inQs) + n_pts_arr(s) = n_curr + + ! --- FILL Q (Coordinate) --- + ! Real part (inQs) -> Index 1 + buffer_q(1:n_curr,s,1) = all_deltas_out(s)%inQs(1:n_curr) + ! Imag part (iinQs) -> Index 2 + buffer_q(1:n_curr,s,2) = all_deltas_out(s)%iinQs(1:n_curr) + + ! --- FILL DELTA (Result) --- + ! Real part -> Index 1 + buffer_d(1:n_curr,s,1)=all_deltas_out(s)%real_deltas(1:n_curr) + ! Imag part -> Index 2 + buffer_d(1:n_curr,s,2)=all_deltas_out(s)%imag_deltas(1:n_curr) + END IF + END DO c ----------------------------------------------------------------------- c define global file attributes c ----------------------------------------------------------------------- @@ -111,8 +162,6 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ qsing_dim,qsing_id)) CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_int, $ qsing_dim,qr_id)) - CALL sl_check( nf90_def_dim(ncid, "step", SIZE(re_trace), - $ tr_dim) ) CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, $ qsing_dim,omegas_id)) CALL sl_check( nf90_def_var(ncid,"tau_k",nf90_double, @@ -153,8 +202,19 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, CALL sl_check( nf90_def_var(ncid,"growth rate", $ nf90_double,(/qsing_dim,i_dim/),gs_id) ) - CALL sl_check( nf90_def_var(ncid,"growth rate trace", - $ nf90_double,(/qsing_dim,tr_dim,i_dim/),tr_id) ) + + !!! AMR + CALL sl_check(nf90_def_dim(ncid, 'amr_pts', max_pts_all, + $ dim_pts_id)) + ! Define Variables + CALL sl_check(nf90_def_var(ncid, 'n_amr_pts', NF90_INT, + $ (/qsing_dim/), var_npts_id)) + ! Note: Dimensions order is (pts, surf, cplx) + CALL sl_check(nf90_def_var(ncid, 'Q_AMR', NF90_DOUBLE, + $ (/dim_pts_id, qsing_dim, i_dim/), var_q_id)) + CALL sl_check(nf90_def_var(ncid, 'Deltas_AMR', NF90_DOUBLE, + $ (/dim_pts_id, qsing_dim, i_dim/), var_d_id)) + ! end definitions CALL sl_check( nf90_enddef(ncid) ) c ----------------------------------------------------------------------- @@ -193,9 +253,12 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ RESHAPE((/REAL(sl_out%gamma_sol_arr), $ AIMAG(sl_out%gamma_sol_arr)/),(/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,tr_id, - $ RESHAPE((/sl_out%r_trace,sl_out%i_trace/), - $ (/msing,SIZE(re_trace),2/)))) + CALL sl_check(nf90_put_var(ncid, var_npts_id, n_pts_arr)) + CALL sl_check(nf90_put_var(ncid, var_q_id, buffer_q)) + CALL sl_check(nf90_put_var(ncid, var_d_id, buffer_d)) + + ! 6. Clean Up + DEALLOCATE(buffer_q, buffer_d, n_pts_arr) c ----------------------------------------------------------------------- c close file From 8f45f0913d19e56818f1e64d6535510763c95de9 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 23 Jan 2026 14:20:40 -0500 Subject: [PATCH 053/118] WIP: AMR V2 with cell types --- slayer/gslayer.f | 511 +++++++++++++++++++++++++++++++++++++++++++---- slayer/sglobal.f | 14 +- slayer/slayer.f | 14 +- 3 files changed, 489 insertions(+), 50 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 3bf091245..06dfae536 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -370,67 +370,63 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, !INTEGER, INTENT(OUT) :: n_pts COMPLEX(r8) :: q_curr - + INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Re-allocate or just reset counters. Re-allocating ensures clean slate) !IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store, D_store) !IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head, hash_next) !IF (ALLOCATED(cells)) DEALLOCATE(cells, new_cells) ! --- 1. Initialize Memory --- + !ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) + !ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) + !ALLOCATE(cells(4, 200000), new_cells(4, 200000)) ! Estimate cell count + + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) + ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) - ALLOCATE(cells(4, 200000), new_cells(4, 200000)) ! Estimate cell count + ALLOCATE(cells(4, 200000), new_cells(4, 200000)) hash_head = 0 hash_next = 0 n_pts = 0 n_cells = 0 - ! --- 2. Build Initial Coarse Grid (100x100) --- - ! We treat the grid as a collection of quadrilateral cells + ! --- 2. Build Initial Coarse Grid (Robust 2-Pass Method) --- + ALLOCATE(coarse_indices(Q_num, Q_num)) ing_step = (2.0*scan_width) / (Q_num - 1) - - ! A. Generate Points & Evaluate + + ! PASS 1: Compute ALL points and store their indices + ! This ensures every grid node is computed exactly once and hashed consistently DO i = 1, Q_num - DO j = 1, Q_num + DO j = 1, Q_num ing_coarse = -scan_width + (i - 1) * ing_step iing_coarse = -scan_width + (j - 1) * ing_step q_curr = CMPLX(ing_coarse, iing_coarse) - ! Check/Compute (Using inline logic to simulate a function call) - CALL get_or_compute(q_curr, pt_idx,n_k,sl_in,msing_max, - $ coupling_flag) + CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, + $ sl_in, msing_max, coupling_flag) + END DO + END DO + + ! PASS 2: Stitch cells together using the stored indices + ! No floating point math here, just integer lookups -> Perfect Topology + DO i = 1, Q_num - 1 + DO j = 1, Q_num - 1 + n_cells = n_cells + 1 - ! If we are not at the right/bottom edge, form a cell with neighbors - IF (i < Q_num .AND. j < Q_num) THEN - n_cells = n_cells + 1 - ! Store indices of corners: TL, TR, BL, BR (row-major logic) - ! Note: This indexing assumes we inserted in order, but for AMR - ! we must rely on the returned pt_idx, not loop counters. - ! To simplify, we just store the TL index and calculate others? - ! No, AMR breaks structure. We must look up all 4 corners. - - ! Top-Left (current) - cells(1, n_cells) = pt_idx - - ! Top-Right (i+1, j) - q_curr = CMPLX(ing_coarse + ing_step, iing_coarse) - CALL get_or_compute(q_curr, cells(2, n_cells),n_k, - $ sl_in,msing_max,coupling_flag) - - ! Bottom-Left (i, j+1) - q_curr = CMPLX(ing_coarse, iing_coarse+ing_step) - CALL get_or_compute(q_curr, cells(3, n_cells),n_k, - $ sl_in,msing_max,coupling_flag) - - ! Bottom-Right (i+1, j+1) - q_curr = CMPLX(ing_coarse + ing_step, iing_coarse+ - $ ing_step) - CALL get_or_compute(q_curr, cells(4, n_cells),n_k, - $ sl_in,msing_max,coupling_flag) - END IF - END DO + ! Define corners using the pre-calculated indices + cells(1, n_cells) = coarse_indices(i, j) ! Top-Left + cells(2, n_cells) = coarse_indices(i+1, j) ! Top-Right + cells(3, n_cells) = coarse_indices(i, j+1) ! Bot-Left + cells(4, n_cells) = coarse_indices(i+1, j+1) ! Bot-Right + END DO END DO + + DEALLOCATE(coarse_indices) ! Clean up temp array ! --- 3. Refinement Loops --- DO pass = 1, AMR_PASSES @@ -555,15 +551,29 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, INTEGER, INTENT(IN) :: n_k, msing_max INTEGER, INTENT(OUT) :: idx_out LOGICAL, INTENT(IN) :: coupling_flag - INTEGER :: h, curr, ix, iy + INTEGER :: h, curr COMPLEX(r8) :: delta_val + INTEGER(8) :: ix8, iy8, h8 ! 64-bit integers for hash calculation ! 1. Calculate Hash - ix = NINT(REAL(q_in) * HASH_SCALE) - iy = NINT(AIMAG(q_in) * HASH_SCALE) + !ix = NINT(REAL(q_in) * HASH_SCALE) + !iy = NINT(AIMAG(q_in) * HASH_SCALE) ! Simple hash mix - h = MOD(ABS(ix * 73856093 + iy * 19349663), HASH_SZ) + 1 + !h = MOD(ABS(ix * 73856093 + iy * 19349663), HASH_SZ) + 1 + + ! 1. Calculate Hash using 64-bit arithmetic + ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) + iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) + h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), + $ INT(HASH_SZ, 8)) + 1_8 + h = INT(h8) ! Safe to convert back, result is within HASH_SZ + IF (h < 1 .OR. h > HASH_SZ) THEN + WRITE(*,*) "HASH ERROR: h=", h, " q_in=", q_in + WRITE(*,*) " ix=", ix8, " iy=", iy8 + STOP + END IF + ! 2. Check collisions curr = hash_head(h) DO WHILE (curr /= 0) @@ -593,7 +603,7 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, ELSE g_tmp = q_in delta_val = riccati_f(g_tmp) - !delta_val = delta_val - delta_eff + delta_val = delta_val - delta_eff END IF D_store(idx_out) = delta_val ! -------------------------- @@ -603,4 +613,417 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, hash_head(h) = idx_out END SUBROUTINE get_or_compute + SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, + $ scan_width, Q_num, AMR_passes, + $ coupling_flag) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: n_k, msing_max, Q_num, AMR_passes + REAL(r8), INTENT(IN) :: scan_width + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + + TYPE(amr_cell_type), ALLOCATABLE :: new_cells(:) + INTEGER :: i, j, c, corner, pass + REAL(r8) :: step, x, y + COMPLEX(r8) :: delta_val + LOGICAL :: cross_real, cross_imag + INTEGER :: n_new_cells + INTEGER :: cells_to_refine, cells_kept + + ! --- 1. Clean Initialization --- + WRITE(*,*) '=== AMR v2 Starting ===' + + IF (ALLOCATED(amr_cells)) THEN + WRITE(*,*) 'Deallocating old amr_cells' + DEALLOCATE(amr_cells) + END IF + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + + ALLOCATE(amr_cells(MAX_CELLS)) + ALLOCATE(new_cells(MAX_CELLS)) + + ! Initialize all cells + DO i = 1, MAX_CELLS + amr_cells(i)%Q = (0.0d0, 0.0d0) + amr_cells(i)%D = (0.0d0, 0.0d0) + amr_cells(i)%needs_refine = .FALSE. + new_cells(i)%Q = (0.0d0, 0.0d0) + new_cells(i)%D = (0.0d0, 0.0d0) + new_cells(i)%needs_refine = .FALSE. + END DO + + n_amr_cells = 0 + step = (2.0d0 * scan_width) / DBLE(Q_num - 1) + + WRITE(*,*) 'Scan width:', scan_width + WRITE(*,*) 'Q_num:', Q_num + WRITE(*,*) 'Step size:', step + WRITE(*,*) 'AMR passes:', AMR_passes + + ! --- 2. Build Initial Coarse Grid --- + WRITE(*,*) 'Building initial coarse grid...' + + DO i = 1, Q_num - 1 + DO j = 1, Q_num - 1 + x = -scan_width + DBLE(i-1) * step + y = -scan_width + DBLE(j-1) * step + + n_amr_cells = n_amr_cells + 1 + + IF (n_amr_cells > MAX_CELLS) THEN + WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in init' + STOP + END IF + + ! Define corner coordinates (BL, BR, TL, TR) + amr_cells(n_amr_cells)%Q(1) = CMPLX(x, y, KIND=r8) + amr_cells(n_amr_cells)%Q(2) = CMPLX(x+step, y, KIND=r8) + amr_cells(n_amr_cells)%Q(3) = CMPLX(x, y+step, KIND=r8) + amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, + $ KIND=r8) + + ! Compute Delta at each corner + DO corner = 1, 4 + CALL compute_delta_sub( + $ amr_cells(n_amr_cells)%Q(corner), + $ n_k, sl_in, msing_max, coupling_flag, + $ amr_cells(n_amr_cells)%D(corner)) + END DO + + amr_cells(n_amr_cells)%needs_refine = .FALSE. + END DO + END DO + + WRITE(*,*) 'Initial grid cells:', n_amr_cells + WRITE(*,*) 'Sample cell 1 Q(1):', amr_cells(1)%Q(1) + WRITE(*,*) 'Sample cell 1 D(1):', amr_cells(1)%D(1) + + ! --- 3. Refinement Passes --- + DO pass = 1, AMR_passes + WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, + $ ': Processing ', n_amr_cells, ' cells' + + ! Mark cells that need refinement + cells_to_refine = 0 + DO c = 1, n_amr_cells + CALL check_cell_crossing_sub(amr_cells(c), + $ cross_real, cross_imag) + amr_cells(c)%needs_refine = (cross_real .OR. cross_imag) + IF (amr_cells(c)%needs_refine) THEN + cells_to_refine = cells_to_refine + 1 + END IF + END DO + + WRITE(*,*) ' Cells to refine:', cells_to_refine + + ! Build new cell list + n_new_cells = 0 + cells_kept = 0 + + DO c = 1, n_amr_cells + IF (amr_cells(c)%needs_refine) THEN + ! Subdivide this cell into 4 + CALL subdivide_cell_sub(amr_cells(c), + $ new_cells, n_new_cells, MAX_CELLS, + $ n_k, sl_in, msing_max, coupling_flag) + ELSE + ! Keep cell as-is + n_new_cells = n_new_cells + 1 + IF (n_new_cells > MAX_CELLS) THEN + WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in refine' + STOP + END IF + new_cells(n_new_cells) = amr_cells(c) + cells_kept = cells_kept + 1 + END IF + END DO + + WRITE(*,*) ' Cells kept:', cells_kept + WRITE(*,*) ' New total cells:', n_new_cells + + ! Copy new_cells back to amr_cells + n_amr_cells = n_new_cells + DO c = 1, n_amr_cells + amr_cells(c) = new_cells(c) + END DO + + END DO + + ! --- 4. Flatten to Output Arrays --- + WRITE(*,*) 'Flattening cells to output arrays...' + CALL flatten_cells_to_points_sub(n_amr_cells) + + ! Cleanup + DEALLOCATE(new_cells) + ! Keep amr_cells allocated for potential debugging + + WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts + + RETURN + END SUBROUTINE dispersion_AMR_v2 + + +! ============================================================ + SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, + $ coupling_flag, delta_out) + + IMPLICIT NONE + + COMPLEX(r8), INTENT(IN) :: q_in + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + COMPLEX(r8), INTENT(OUT) :: delta_out + + IF (coupling_flag) THEN + g_tmp = q_in*ifac + delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) + ELSE + g_tmp = q_in*ifac + delta_out = riccati_f(g_tmp) + delta_out = delta_out - delta_eff + END IF + + RETURN + END SUBROUTINE compute_delta_sub + + +! ============================================================ + SUBROUTINE check_cell_crossing_sub(cell, cross_real, cross_imag) + + IMPLICIT NONE + + TYPE(amr_cell_type), INTENT(IN) :: cell + LOGICAL, INTENT(OUT) :: cross_real, cross_imag + + REAL(r8) :: r_vals(4), i_vals(4) + REAL(r8) :: r_min, r_max, i_min, i_max + INTEGER :: k + + ! Extract real and imaginary parts + DO k = 1, 4 + r_vals(k) = REAL(cell%D(k), KIND=r8) + i_vals(k) = AIMAG(cell%D(k)) + END DO + + r_min = MINVAL(r_vals) + r_max = MAXVAL(r_vals) + cross_real = (r_min * r_max <= 0.0d0) + + i_min = MINVAL(i_vals) + i_max = MAXVAL(i_vals) + cross_imag = (i_min * i_max <= 0.0d0) + + RETURN + END SUBROUTINE check_cell_crossing_sub + + +! ============================================================ + SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, + $ max_cells, n_k, sl_in, + $ msing_max, coupling_flag) + + IMPLICIT NONE + + TYPE(amr_cell_type), INTENT(IN) :: parent + TYPE(amr_cell_type), INTENT(INOUT) :: new_cells(*) + INTEGER, INTENT(INOUT) :: n_new + INTEGER, INTENT(IN) :: max_cells + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + + COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr + COMPLEX(r8) :: q_bm, q_tm, q_lm, q_rm, q_mm + COMPLEX(r8) :: d_bm, d_tm, d_lm, d_rm, d_mm + COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr + + ! Extract parent corners (BL=1, BR=2, TL=3, TR=4) + q_bl = parent%Q(1) + q_br = parent%Q(2) + q_tl = parent%Q(3) + q_tr = parent%Q(4) + + d_bl = parent%D(1) + d_br = parent%D(2) + d_tl = parent%D(3) + d_tr = parent%D(4) + + ! Compute midpoint coordinates + q_bm = 0.5d0 * (q_bl + q_br) ! Bottom middle + q_tm = 0.5d0 * (q_tl + q_tr) ! Top middle + q_lm = 0.5d0 * (q_bl + q_tl) ! Left middle + q_rm = 0.5d0 * (q_br + q_tr) ! Right middle + q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) ! Center + + ! Compute Delta at new midpoints (5 new evaluations) + CALL compute_delta_sub(q_bm, n_k, sl_in, msing_max, + $ coupling_flag, d_bm) + CALL compute_delta_sub(q_tm, n_k, sl_in, msing_max, + $ coupling_flag, d_tm) + CALL compute_delta_sub(q_lm, n_k, sl_in, msing_max, + $ coupling_flag, d_lm) + CALL compute_delta_sub(q_rm, n_k, sl_in, msing_max, + $ coupling_flag, d_rm) + CALL compute_delta_sub(q_mm, n_k, sl_in, msing_max, + $ coupling_flag, d_mm) + + ! Check space for 4 new cells + IF (n_new + 4 > max_cells) THEN + WRITE(*,*) 'ERROR: Would exceed MAX_CELLS in subdivide' + STOP + END IF + + ! Child 1: Bottom-Left quadrant (BL, BM, LM, MM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_bl + new_cells(n_new)%Q(2) = q_bm + new_cells(n_new)%Q(3) = q_lm + new_cells(n_new)%Q(4) = q_mm + new_cells(n_new)%D(1) = d_bl + new_cells(n_new)%D(2) = d_bm + new_cells(n_new)%D(3) = d_lm + new_cells(n_new)%D(4) = d_mm + new_cells(n_new)%needs_refine = .FALSE. + + ! Child 2: Bottom-Right quadrant (BM, BR, MM, RM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_bm + new_cells(n_new)%Q(2) = q_br + new_cells(n_new)%Q(3) = q_mm + new_cells(n_new)%Q(4) = q_rm + new_cells(n_new)%D(1) = d_bm + new_cells(n_new)%D(2) = d_br + new_cells(n_new)%D(3) = d_mm + new_cells(n_new)%D(4) = d_rm + new_cells(n_new)%needs_refine = .FALSE. + + ! Child 3: Top-Left quadrant (LM, MM, TL, TM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_lm + new_cells(n_new)%Q(2) = q_mm + new_cells(n_new)%Q(3) = q_tl + new_cells(n_new)%Q(4) = q_tm + new_cells(n_new)%D(1) = d_lm + new_cells(n_new)%D(2) = d_mm + new_cells(n_new)%D(3) = d_tl + new_cells(n_new)%D(4) = d_tm + new_cells(n_new)%needs_refine = .FALSE. + + ! Child 4: Top-Right quadrant (MM, RM, TM, TR) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_mm + new_cells(n_new)%Q(2) = q_rm + new_cells(n_new)%Q(3) = q_tm + new_cells(n_new)%Q(4) = q_tr + new_cells(n_new)%D(1) = d_mm + new_cells(n_new)%D(2) = d_rm + new_cells(n_new)%D(3) = d_tm + new_cells(n_new)%D(4) = d_tr + new_cells(n_new)%needs_refine = .FALSE. + + RETURN + END SUBROUTINE subdivide_cell_sub + + +! ============================================================ + SUBROUTINE flatten_cells_to_points_sub(num_cells) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: num_cells + + INTEGER :: c, corner, i, j, idx + INTEGER :: n_total_corners + COMPLEX(r8), ALLOCATABLE :: temp_Q(:), temp_D(:) + LOGICAL, ALLOCATABLE :: is_unique(:) + REAL(r8) :: tol + + tol = 1.0d-10 + n_total_corners = num_cells * 4 + + WRITE(*,*) 'Flatten: num_cells =', num_cells + WRITE(*,*) 'Flatten: n_total_corners =', n_total_corners + + IF (num_cells <= 0) THEN + WRITE(*,*) 'ERROR: No cells to flatten' + n_pts = 0 + RETURN + END IF + + ! Allocate temporary arrays + ALLOCATE(temp_Q(n_total_corners)) + ALLOCATE(temp_D(n_total_corners)) + ALLOCATE(is_unique(n_total_corners)) + + ! Initialize + temp_Q = (0.0d0, 0.0d0) + temp_D = (0.0d0, 0.0d0) + is_unique = .TRUE. + + ! Gather all corners from cells + idx = 0 + DO c = 1, num_cells + DO corner = 1, 4 + idx = idx + 1 + temp_Q(idx) = amr_cells(c)%Q(corner) + temp_D(idx) = amr_cells(c)%D(corner) + END DO + END DO + + WRITE(*,*) 'Gathered corners:', idx + + ! Mark duplicate points as non-unique + ! (Simple O(n²) approach - works fine for moderate sizes) + DO i = 1, n_total_corners + IF (.NOT. is_unique(i)) CYCLE + DO j = i + 1, n_total_corners + IF (is_unique(j)) THEN + IF (ABS(temp_Q(j) - temp_Q(i)) < tol) THEN + is_unique(j) = .FALSE. + END IF + END IF + END DO + END DO + + ! Count unique points + n_pts = 0 + DO i = 1, n_total_corners + IF (is_unique(i)) n_pts = n_pts + 1 + END DO + + WRITE(*,*) 'Unique points found:', n_pts + + IF (n_pts <= 0) THEN + WRITE(*,*) 'ERROR: No unique points found' + DEALLOCATE(temp_Q, temp_D, is_unique) + RETURN + END IF + + ! Allocate output arrays + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + ALLOCATE(Q_store(n_pts)) + ALLOCATE(D_store(n_pts)) + + ! Copy unique points to output + idx = 0 + DO i = 1, n_total_corners + IF (is_unique(i)) THEN + idx = idx + 1 + Q_store(idx) = temp_Q(i) + D_store(idx) = temp_D(i) + END IF + END DO + + WRITE(*,*) 'Copied to output:', idx + + ! Cleanup temporaries + DEALLOCATE(temp_Q, temp_D, is_unique) + + RETURN + END SUBROUTINE flatten_cells_to_points_sub END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 334ebc530..3711e695c 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -25,9 +25,19 @@ MODULE sglobal_mod REAL(r8), PARAMETER :: HASH_SCALE = 1.0d5 ! Scaling factor for integer hashing INTEGER, ALLOCATABLE :: hash_head(:) ! Hash bucket heads INTEGER, ALLOCATABLE :: hash_next(:) ! Linked list next pointers + + ! Replace hash-based storage with cell-based storage + INTEGER, PARAMETER :: MAX_CELLS = 500000 + TYPE :: amr_cell_type + COMPLEX(r8) :: Q(4) ! Corner Q values (TL, TR, BL, BR) + COMPLEX(r8) :: D(4) ! Corner Delta values + LOGICAL :: needs_refine ! Flag for refinement + END TYPE amr_cell_type + TYPE(amr_cell_type), ALLOCATABLE :: amr_cells(:) + INTEGER :: n_amr_cells + ! For output: flattened unique points + COMPLEX(r8), ALLOCATABLE :: Q_store(:), D_store(:) INTEGER :: n_pts - COMPLEX(r8), ALLOCATABLE :: Q_store(:) ! Stores Q coordinates - COMPLEX(r8), ALLOCATABLE :: D_store(:) ! Stores Result Delta TYPE result_type REAL(r8), ALLOCATABLE :: inQs(:), iinQs(:), diff --git a/slayer/slayer.f b/slayer/slayer.f index 3f398681a..e21065ec3 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -539,9 +539,10 @@ PROGRAM slayer IF (amr_flag) THEN - CALL dispersion_AMR(n_k,sl_in,msing_max,scan_width, + CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) WRITE(*,*)"Q_store(10) = ",Q_store(10) + WRITE(*,*)"D_store(10) = ",D_store(10) WRITE(*,*)"n_pts = ",n_pts @@ -553,22 +554,27 @@ PROGRAM slayer ALLOCATE(all_deltas_out(k)%real_deltas(n_pts), $ all_deltas_out(k)%imag_deltas(n_pts)) + WRITE(*,*)"Allocated all_deltas_out" + DO i = 1, n_pts all_deltas_out(k)%inQs(i) = REAL(Q_store(i)) IF (fitz_flag) THEN - all_deltas_out(k)%iinQs(i) = AIMAG(Q_store(i)) + all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) ELSE all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) END IF all_deltas_out(k)%real_deltas(i) = REAL(D_store(i)) all_deltas_out(k)%imag_deltas(i) = AIMAG(D_store(i)) END DO + + WRITE(*,*)"all_deltas_out(1)%real_deltas(10): ", + $ all_deltas_out(1)%real_deltas(10) ! Clean up temporary AMR memory - DEALLOCATE(Q_store, D_store, hash_head, hash_next) + DEALLOCATE(Q_store, D_store)!, hash_head, hash_next) END IF - + WRITE(*,*)"Exited if_AMR" IF ((stabscan_flag)) THEN ! was .AND. (k == 2) WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// From 2a73a4661eb8868eab305b40575c8dd01058e54c Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 29 Jan 2026 20:25:10 -0500 Subject: [PATCH 054/118] WIP: fixes for coupled AMR scans --- input/slayer.in | 1 + slayer/gslayer.f | 9 ++- slayer/slayer.f | 133 +++++++++++++++++++++++++++++------------ slayer/slayer_netcdf.f | 34 ++++++----- 4 files changed, 118 insertions(+), 59 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 1889bca87..cd5194a90 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -49,6 +49,7 @@ knum=100 ! resolution for 2d scan along with the other. Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes scan_width=1.5 ! stability scan width for Re(Q),Im(Q) scan + AMR_passes=4 msing_max=2 ! number of surfaces to include in coupled tearing growth rate calculation dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 06dfae536..d9ebff46c 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -179,17 +179,18 @@ END SUBROUTINE gpec_slayer c Subprogram 2. output_gamma c Take SLAYER input and output dicts, send to netCDF subroutine c----------------------------------------------------------------------- - SUBROUTINE output_gamma(est_gamma_flag,sl_in,sl_out, + SUBROUTINE output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, $ all_deltas_out) ! Declarations (include necessary type declarations from original code) LOGICAL, INTENT(IN) :: est_gamma_flag + INTEGER, INTENT(IN) :: m_AMR TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out TYPE(deltas_outputs_type), INTENT(IN) :: $ all_deltas_out(SIZE(sl_in%qval_arr)) - CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),est_gamma_flag, + CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),m_AMR,est_gamma_flag, $ sl_in,sl_out,all_deltas_out) END SUBROUTINE output_gamma @@ -698,9 +699,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, END DO WRITE(*,*) 'Initial grid cells:', n_amr_cells - WRITE(*,*) 'Sample cell 1 Q(1):', amr_cells(1)%Q(1) - WRITE(*,*) 'Sample cell 1 D(1):', amr_cells(1)%D(1) - + ! --- 3. Refinement Passes --- DO pass = 1, AMR_passes WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, diff --git a/slayer/slayer.f b/slayer/slayer.f index e21065ec3..37566a191 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -60,28 +60,28 @@ PROGRAM slayer COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas ! AMR DECLARATIONS - INTEGER, PARAMETER :: AMR_passes = 4 ! Number of refinement levels (User Set) + INTEGER :: AMR_passes, m_AMR ! Number of refinement levels TYPE(slayer_inputs_type) :: sl_in TYPE(slayer_outputs_type) :: sl_out TYPE(deltas_outputs_type), ALLOCATABLE :: all_deltas_out(:) NAMELIST/slayer_input/input_flag,infile, - $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, - $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_p_prof, - $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,Q0,delta_prime,delta_n_p,ingamma + $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, + $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_p_prof, + $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, + $ inds,intau,Q0,delta_prime,delta_n_p,ingamma NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, - $ msing_max,dc_type,read_eq,fitz_flag,coupling_flag, - $ QPscan_flag,Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag, - $ otscan_flag,ntscan_flag,nbtscan_flag,parflow_flag, - $ peohmonly_flag,Pe_flag,layfac + $ AMR_passes,msing_max,dc_type,read_eq,fitz_flag,coupling_flag, + $ QPscan_flag,Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag, + $ otscan_flag,ntscan_flag,nbtscan_flag,parflow_flag, + $ peohmonly_flag,Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, - $ est_gamma_flag,match_gamma_flag,stability_flag, - $ stabscan_flag,coupled_stabscan_flag,amr_flag,br_th_flag, - $ bal_flag + $ est_gamma_flag,match_gamma_flag,stability_flag, + $ stabscan_flag,coupled_stabscan_flag,amr_flag,br_th_flag, + $ bal_flag NAMELIST/slayer_diagnose/riccati_out,riccatiscan_flag, - $ params_check + $ params_check c----------------------------------------------------------------------- c set initial values. c----------------------------------------------------------------------- @@ -128,6 +128,7 @@ PROGRAM slayer knum=100 ! resolution for 2d scan alont with the other. Q_num=100 ! resolution for stab. scan along Re(Q) axis scan_width = 2.0 + AMR_passes = 4 msing_max = 2 in_unit=1 out_unit=2 @@ -412,7 +413,7 @@ PROGRAM slayer IF (.NOT. (match_gamma_flag)) THEN sl_out%gamma_sol_arr = (/0./) - CALL output_gamma(est_gamma_flag,sl_in,sl_out, + CALL output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, $ all_deltas_out) END IF ENDIF @@ -495,11 +496,19 @@ PROGRAM slayer END IF END IF - IF (amr_flag) THEN - !IF (ALLOCATED(all_deltas_out)) DEALLOCATE(all_deltas_out) - ALLOCATE(all_deltas_out(n_k)) + IF (AMR_flag .AND. .NOT. coupling_flag) THEN + ALLOCATE(all_deltas_out(n_k)) + ELSEIF (AMR_flag .AND. coupling_flag) THEN + ALLOCATE(all_deltas_out(1)) END IF + IF (AMR_flag) THEN + m_AMR = 1 + ELSE + m_AMR = MIN(n_k,msing_max) + END IF + + WRITE(*,*),"Rational q domain: ",sl_in%qval_arr DO k=1,MIN(n_k,msing_max) WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', @@ -514,19 +523,16 @@ PROGRAM slayer tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) - WRITE(*,*)"slayer.f Q_e: ",Q_e - WRITE(*,*)"slayer.f Q_i: ",Q_i - WRITE(*,*)"slayer.f P_perp: ",P_perp - WRITE(*,*)"slayer.f P_tor: ",P_tor - WRITE(*,*)"slayer.f tau: ",tau - WRITE(*,*)"slayer.f D_norm: ",D_norm - WRITE(*,*)"slayer.f tauk: ",tauk - - WRITE(*,*)"slayer.f iota_e: ",iota_e - WRITE(*,*)"slayer.f D_prime: ",sl_in%Re_dp_arr(k) - WRITE(*,*)"slayer.f D_prime: ",sl_in%Re_dp_arr(k) - WRITE(*,*)"slayer.f D_crit: ",sl_in%d_crit_arr(k) - WRITE(*,*),"sl_in%qval_arr: ",sl_in%qval_arr + WRITE(*,*)"Q_e: ",Q_e + WRITE(*,*)"Q_i: ",Q_i + WRITE(*,*)"P_perp: ",P_perp + WRITE(*,*)"P_tor: ",P_tor + WRITE(*,*)"tau: ",tau + WRITE(*,*)"D_norm: ",D_norm + WRITE(*,*)"tauk: ",tauk + WRITE(*,*)"iota_e: ",iota_e + WRITE(*,*)"Delta_prime: ",sl_in%Re_dp_arr(k) + WRITE(*,*)"Delta_crit: ",sl_in%d_crit_arr(k) ! Calculate (Deltaprime - d_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - @@ -537,17 +543,23 @@ PROGRAM slayer c ! Fill gamma_sol_arr with 0's, will by used by python root finding sl_out%gamma_sol_arr(k) = 0.0 - IF (amr_flag) THEN + IF (AMR_flag .AND. .NOT. coupling_flag) THEN + WRITE(*,'(A,I0,A)') 'Calling uncoupled AMR scan on q = ', + $ sl_in%qval_arr(k),' rational surface:' CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) - WRITE(*,*)"Q_store(10) = ",Q_store(10) - WRITE(*,*)"D_store(10) = ",D_store(10) - WRITE(*,*)"n_pts = ",n_pts + IF (ALLOCATED(all_deltas_out(k)%inQs)) + $ DEALLOCATE(all_deltas_out(k)%inQs) + IF (ALLOCATED(all_deltas_out(k)%iinQs)) + $ DEALLOCATE(all_deltas_out(k)%iinQs) + IF (ALLOCATED(all_deltas_out(k)%real_deltas)) + $ DEALLOCATE(all_deltas_out(k)%real_deltas) + IF (ALLOCATED(all_deltas_out(k)%imag_deltas)) + $ DEALLOCATE(all_deltas_out(k)%imag_deltas) - ! --- 4. Export to Output Arrays --- - ! Flatten the unique points store into the requested 1D arrays + ! Flatten the unique points store into 1D arrays ALLOCATE(all_deltas_out(k)%inQs(n_pts), $ all_deltas_out(k)%iinQs(n_pts)) ! Assumes you also have real_deltas/imag_deltas declared as 1D @@ -574,7 +586,7 @@ PROGRAM slayer DEALLOCATE(Q_store, D_store)!, hash_head, hash_next) END IF - WRITE(*,*)"Exited if_AMR" + IF ((stabscan_flag)) THEN ! was .AND. (k == 2) WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// @@ -640,6 +652,50 @@ PROGRAM slayer sl_out%dels_db_arr = (/ 0. /) END IF + IF (AMR_flag .AND. coupling_flag) THEN + + WRITE(*,*)"Calling coupled AMR scan" + + CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, + $ Q_num,AMR_passes,coupling_flag) + + WRITE(*,*)"Successfully exited coupled AMR scan" + + IF (ALLOCATED(all_deltas_out(1)%inQs)) + $ DEALLOCATE(all_deltas_out(1)%inQs) + IF (ALLOCATED(all_deltas_out(1)%iinQs)) + $ DEALLOCATE(all_deltas_out(1)%iinQs) + IF (ALLOCATED(all_deltas_out(1)%real_deltas)) + $ DEALLOCATE(all_deltas_out(1)%real_deltas) + IF (ALLOCATED(all_deltas_out(1)%imag_deltas)) + $ DEALLOCATE(all_deltas_out(1)%imag_deltas) + + WRITE(*,*)"Successfully checked array allocation" + + ALLOCATE(all_deltas_out(1)%inQs(n_pts), + $ all_deltas_out(1)%iinQs(n_pts)) + ALLOCATE(all_deltas_out(1)%real_deltas(n_pts), + $ all_deltas_out(1)%imag_deltas(n_pts)) + + WRITE(*,*)"Successfully allocated all_deltas_out subarrays" + + DO i = 1, n_pts + all_deltas_out(1)%inQs(i) = REAL(Q_store(i)) + IF (fitz_flag) THEN + all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) + ELSE + all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) + END IF + all_deltas_out(1)%real_deltas(i) = REAL(D_store(i)) + all_deltas_out(1)%imag_deltas(i) = AIMAG(D_store(i)) + END DO + + ! Clean up temporary AMR memory + DEALLOCATE(Q_store, D_store)!, hash_head, hash_next) + WRITE(*,*)"Successfully deallocated Q_store and D_store" + + END IF + IF (coupled_stabscan_flag) THEN WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// @@ -685,7 +741,8 @@ PROGRAM slayer DEALLOCATE(inQs,iinQs,deltas) END IF - CALL output_gamma(est_gamma_flag,sl_in,sl_out,all_deltas_out) + CALL output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, + $ all_deltas_out) stop ENDIF c----------------------------------------------------------------------- diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index c597c7311..45fdfef89 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -48,18 +48,18 @@ END SUBROUTINE sl_check c ----------------------------------------------------------------------- c declarations. c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, + SUBROUTINE slayer_netcdf_out(msing,m_AMR,est_gamma_flag, $ sl_in,sl_out,all_deltas_out) - INTEGER, INTENT(IN) :: msing + INTEGER, INTENT(IN) :: msing,m_AMR LOGICAL, INTENT(IN) :: est_gamma_flag TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out - TYPE(deltas_outputs_type), INTENT(IN) :: all_deltas_out(msing) + TYPE(deltas_outputs_type), INTENT(IN) :: all_deltas_out(m_AMR) INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,p_perp_id,S_id, - $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id, + $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,nAMR_dim, $ qsing_id,qc_id,p_tor_id INTEGER :: run, run_dimid, point_dimid, varids(4) @@ -100,17 +100,17 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, ! 1. Find the Maximum AMR Grid Size across all surfaces max_pts_all = 0 - DO s = 1, msing - IF (ALLOCATED(all_deltas_out(s)%inQs)) THEN + IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN + DO s = 1, m_AMR max_pts_all = MAX(max_pts_all,SIZE(all_deltas_out(s)%inQs)) - END IF END DO - + END IF + ! 2. Allocate Rectangular Buffers (Points, Surfaces, Re/Im) ! Shape: (Max_Points, Number_Surfaces, 2) - ALLOCATE(buffer_q(max_pts_all, msing, 2)) - ALLOCATE(buffer_d(max_pts_all, msing, 2)) - ALLOCATE(n_pts_arr(msing)) + ALLOCATE(buffer_q(max_pts_all, m_AMR, 2)) + ALLOCATE(buffer_d(max_pts_all, m_AMR, 2)) + ALLOCATE(n_pts_arr(m_AMR)) ! Initialize with Fill Value (so unused space is ignored by plotters) buffer_q = 0.0 @@ -118,8 +118,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, n_pts_arr = 0 ! 3. Flatten the Ragged Data into the Buffers - DO s = 1, msing - IF (ALLOCATED(all_deltas_out(s)%inQs)) THEN + IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN + DO s = 1, m_AMR n_curr = SIZE(all_deltas_out(s)%inQs) n_pts_arr(s) = n_curr @@ -134,8 +134,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, buffer_d(1:n_curr,s,1)=all_deltas_out(s)%real_deltas(1:n_curr) ! Imag part -> Index 2 buffer_d(1:n_curr,s,2)=all_deltas_out(s)%imag_deltas(1:n_curr) - END IF END DO + END IF c ----------------------------------------------------------------------- c define global file attributes c ----------------------------------------------------------------------- @@ -157,6 +157,8 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, !CALL check( nf90_def_var(ncid,"r",nf90_int,r_dim,r_id)) IF(msing>0)THEN CALL sl_check( nf90_def_dim(ncid,"r",msing,qsing_dim) ) !r_dim = q_rational + CALL sl_check( nf90_def_dim(ncid,"r_AMR",m_AMR, + $ nAMR_dim) ) !r_dim = q_rational CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) CALL sl_check( nf90_def_var(ncid,"r",nf90_int, $ qsing_dim,qsing_id)) @@ -211,9 +213,9 @@ SUBROUTINE slayer_netcdf_out(msing,est_gamma_flag, $ (/qsing_dim/), var_npts_id)) ! Note: Dimensions order is (pts, surf, cplx) CALL sl_check(nf90_def_var(ncid, 'Q_AMR', NF90_DOUBLE, - $ (/dim_pts_id, qsing_dim, i_dim/), var_q_id)) + $ (/dim_pts_id, nAMR_dim, i_dim/), var_q_id)) CALL sl_check(nf90_def_var(ncid, 'Deltas_AMR', NF90_DOUBLE, - $ (/dim_pts_id, qsing_dim, i_dim/), var_d_id)) + $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id)) ! end definitions CALL sl_check( nf90_enddef(ncid) ) From 4849e008f9ebfd95aad23f335ea86c15a579ebb4 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 13 Feb 2026 23:56:22 -0500 Subject: [PATCH 055/118] WIP: big cleanup, not compiling yet --- slayer/delta.f | 327 +++++++++----- slayer/gslayer.f | 936 +++++++++++++++++++++++------------------ slayer/layerinputs.f | 713 ++++++++++++++++++------------- slayer/params.f | 342 +++++++++------ slayer/sglobal.f | 244 ++++++++--- slayer/slayer.f | 647 +++++++++++++++++----------- slayer/slayer_netcdf.f | 587 ++++++++++++++++---------- 7 files changed, 2363 insertions(+), 1433 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index de3041d47..aff31a2c8 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -1,32 +1,83 @@ MODULE delta_mod +c----------------------------------------------------------------------- +c delta_mod: Riccati-based tearing-mode layer Delta solvers. +c +c Contains three Riccati formulations: +c riccati - standard formulation (non-stiff, lsode mf=10) +c riccati_del_s - del_s formulation (stiff, lsode mf=21) +c riccati_f - Fitzpatrick P_perp/P_tor formulation (mf=21) +c +c Each solver integrates a Riccati ODE for W(x) from a large-|x| +c asymptotic boundary condition inward to x ~ 0, then extracts +c Delta = pi / W'(0). +c +c Associated ODE subroutines (w_der, w_der_del_s, w_der_f) and +c Jacobian subroutines (jac_del_s, jac_f) follow below. +c +c Module-level flags: +c riccati_out - write W(x) profile to binary + text file +c parflow_flag - include parallel electron flow terms in w_der +c PeOhmOnly_flag - retain only Pe-Ohm coupling in w_der +c----------------------------------------------------------------------- USE sglobal_mod IMPLICIT NONE - LOGICAL :: riccati_out,parflow_flag,PeOhmOnly_flag +c --- module-level control flags + LOGICAL :: riccati_out ! write W(x) profile to binary + text + LOGICAL :: parflow_flag ! enable parallel-flow terms in w_der + LOGICAL :: PeOhmOnly_flag ! Pe-Ohm-only coupling in w_der CONTAINS c----------------------------------------------------------------------- -c calculate delta based on riccati w_der formulation. +c riccati: compute Delta via Riccati integration of w_der. +c +c Integrates W(x) from x_start inward to x_min using lsode +c (non-stiff, mf=10). Optionally applies the layfac singularity +c guard when Q is near Q_e. Returns Delta = pi / W'(x_min). +c +c If riccati_out = .TRUE., writes the W(x) profile to +c slayer_riccati_profile_n.{bin,out}. +c +c BUG FLAG 1: xintv and xfac are declared but never used. +c Remove them. c----------------------------------------------------------------------- FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, $ iinQ,inx,iny) - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds - REAL(r8),INTENT(IN) :: intau - REAL(r8),INTENT(IN),OPTIONAL :: iinQ,inx - COMPLEX(r8), INTENT(IN), OPTIONAL :: iny +c --- input arguments: physical parameters for this surface + REAL(r8),INTENT(IN) :: inQ ! real part of Q + REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq + REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq + REAL(r8),INTENT(IN) :: inpr ! Prandtl number + REAL(r8),INTENT(IN) :: inpe ! electron Prandtl number + REAL(r8),INTENT(IN) :: inc_beta ! c_beta parameter + REAL(r8),INTENT(IN) :: inds ! magnetic shear ds + REAL(r8),INTENT(IN) :: intau ! ion-to-electron temp ratio +c --- optional arguments + REAL(r8),INTENT(IN),OPTIONAL :: iinQ ! imaginary part of Q + REAL(r8),INTENT(IN),OPTIONAL :: inx ! override starting x + COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W +c --- function result COMPLEX(r8) :: riccati - INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - - REAL(r8) :: xintv,x,xout,rtol,jac,xmin - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy - - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork - REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER :: neq ! number of equations (=2) + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER :: liw,lrw ! lsode work array sizes + REAL(r8) :: x,xout ! current and target x + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance + REAL(r8) :: jac ! dummy Jacobian (unused for mf=10) +c --- work arrays + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy ! W and dW + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work + REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work + +c --- copy input arguments to module-level globals for w_der Q=inQ IF(present(iinQ)) Q=inQ+ifac*iinQ Q_e=inQ_e @@ -37,40 +88,43 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, ds=inds tau=intau +c --- singularity guard: displace Q away from Q_e when too close IF ((layfac>0).AND.(ABS(Q-Q_e) 0 when Q -> Q_e (see layfac guard above). CALL w_der(neq,x,y,dy) riccati=pi/dy(1) DEALLOCATE(atol,y,dy,iwork,rwork) END FUNCTION riccati c----------------------------------------------------------------------- -c calculate delta based on riccati w_der formulation. +c riccati_del_s: compute Delta via the del_s Riccati formulation. +c +c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian +c (jac_del_s). Integrates W(q) from large q inward to q_min. +c Returns Delta = -(pi / sqrt(1+1/tau)) * W'(q_min). +c +c BUG FLAG 3: arguments inQ, inc_beta, ind_beta, intau are never +c used to set their module-level counterparts (Q, c_beta, d_beta, +c tau). Either add assignments (e.g. tau=intau) or remove the +c unused arguments if the caller sets them beforehand. +c BUG FLAG 4: variables y, dy, xfac, xintv, ml, mu, nrpd are +c declared but never used -- remove them. c----------------------------------------------------------------------- FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, $ intau,inx,iny) - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta - REAL(r8),INTENT(IN) :: intau - REAL(r8),INTENT(IN),OPTIONAL :: inx - COMPLEX(r8), INTENT(IN), OPTIONAL :: iny +c --- input arguments + REAL(r8),INTENT(IN) :: inQ ! (UNUSED -- see BUG FLAG 3) + REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq + REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq + REAL(r8),INTENT(IN) :: inpr ! mapped to P_perp (see below) + REAL(r8),INTENT(IN) :: inc_beta ! (UNUSED -- see BUG FLAG 3) + REAL(r8),INTENT(IN) :: ind_beta ! (UNUSED -- see BUG FLAG 3) + REAL(r8),INTENT(IN) :: intau ! (UNUSED -- see BUG FLAG 3) +c --- optional arguments +c BUG FLAG 5: inx is declared OPTIONAL but my_q=inx is accessed +c unconditionally. If inx is ever absent, this will crash. +c Either make inx required or add IF(present(inx)) guard. + REAL(r8),INTENT(IN),OPTIONAL :: inx ! starting q for integration + COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W +c --- function result COMPLEX(r8) :: riccati_del_s - INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - INTEGER :: ml = 0, mu = 0, nrpd = 1 - REAL(r8) :: xintv,x,xout,rtol,jac,xmin,my_q,P_hat,alpha - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq,y,dy - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork - REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER :: neq ! number of equations (=2) + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER :: liw,lrw ! lsode work array sizes + REAL(r8) :: x ! secondary x variable (set from inx) + REAL(r8) :: xout ! target integration endpoint + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance + REAL(r8) :: jac ! dummy (overridden by jac_del_s) + REAL(r8) :: my_q ! integration variable (large -> small) + REAL(r8) :: P_hat ! normalized P_perp + REAL(r8) :: alpha ! boundary condition coefficient +c --- work arrays + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq ! W and dW/dq + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work + REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work + +c --- configure lsode: stiff BDF method with user Jacobian (mf=21) neq = 2 itol = 2 rtol = 1e-10 @@ -129,40 +219,40 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, atol(:) = 1e-10 itask = 2 istate = 1 - iopt = 0 - mf = 21 !21 IS STIFF WITH USER-SPECIFIED JACOBIAN, 10 iS NON STIFF + iopt = 1 ! enable optional inputs (iwork(6)) + mf = 21 ! stiff, user-supplied Jacobian (jac_del_s) liw = 20*2 - lrw = 22+9*neq+neq**2 !just (22+16*neq) for mf=10 - ALLOCATE(iwork(liw+neq),rwork(lrw)) ! just iwork(liw) for mf=10 + lrw = 22+9*neq+neq**2 ! stiff work array size + ALLOCATE(iwork(liw+neq),rwork(lrw)) -! MXSTEP? - iopt = 1 +c --- set maximum internal steps iwork=0 - iwork(6)=50000 ! maximum # of steps per call, e.g. 50000 + iwork(6)=50000 ! MXSTEP: max internal steps per call rwork=0 -! x=10.0*(1.0+log10(Q/pr)) - my_q=inx ! "starting backwards integration at large q" +c --- set starting integration point + my_q=inx ! start backwards integration at large q xmin=1e-5 IF(present(inx)) x=inx xout=xmin - !y(1)=-c_beta/sqrt((1+tau))/ds*x**2.0 ! it was (1+tau*ds). To be updated. - - P_hat = P_perp / D_norm**6.0 ! P_perp, 0.377 for Pperp_hat benchmark - +c --- copy input arguments to module-level globals for w_der_del_s Q_e = inQ_e Q_i = inQ_i P_perp = inpr - alpha = (P_hat/(1+1/tau))**0.5 ! this is actually tau', we need tau - W(1) = -alpha*my_q**2 - 0.5 +c --- BUG FLAG 6: P_hat was computed BEFORE P_perp=inpr, so it used +c the stale module-level P_perp. Now moved after assignment. + P_hat = P_perp / D_norm**6.0 +c --- asymptotic boundary condition at large q + alpha = (P_hat/(1+1/tau))**0.5 + W(1) = -alpha*my_q**2 - 0.5 IF(present(iny)) W(1)=iny -! y(1)=0.5-ifac*10.0 -! WRITE(*,*)y(1) +c --- integrate W(q) from q_start inward to q_min via lsode IF (riccati_out) THEN +c profile output: step-by-step integration with file writes istep = 1 itask = 2 OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// @@ -182,24 +272,22 @@ FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, CLOSE(bin_unit) CLOSE(out2_unit) ELSE +c single-shot integration to q_min istep = 1 itask = 1 CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) - ENDIF - ! w=0 when Q=Q_e. Why? - +c --- extract Delta from final W derivative at q_min CALL w_der_del_s(neq,my_q,W,dW_dq) - riccati_del_s=-( pi/((1+1/tau)**0.5) )*dW_dq(1) DEALLOCATE(atol,W,dW_dq,iwork,rwork) END FUNCTION riccati_del_s c----------------------------------------------------------------------- -c jacobian for riccati_del_s() -c------------------------------------------- ---------------------------- +c jacobian for riccati_del_s(): pd = dF/dW for stiff lsode. +c----------------------------------------------------------------------- SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) INTEGER, INTENT(IN) :: neq, ml, mu, nrpd REAL(r8), INTENT(IN) :: my_q @@ -208,7 +296,9 @@ SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) pd(1,1) = 1.0/my_q - 2.0d0*W(1)/my_q END SUBROUTINE jac_del_s c----------------------------------------------------------------------- -c W derivative for riccati_del_s() +c w_der_del_s: ODE right-hand side dW/dq for riccati_del_s. +c Implements the del_s dispersion relation using normalised +c quantities Q_hat, P_perp_hat, P_tor_hat. c----------------------------------------------------------------------- SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) @@ -219,34 +309,72 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat COMPLEX(r8) :: E,F - !Q_hat = Q / ds**4 - Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 ! Q_star = Q_e * (1+tau), 2.4e-02 for benchmark - P_perp_hat = P_perp / D_norm**6.0 ! 0.377 for benchmark - P_tor_hat = P_perp / D_norm**6.0 ! 1.15 for benchmark +c --- normalise physical quantities + Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 + P_perp_hat = P_perp / D_norm**6.0 +c BUG FLAG 7: P_tor_hat is assigned from P_perp, not P_tor. +c Benchmark values differ (P_perp_hat=0.377, P_tor_hat=1.15), +c suggesting this should be: P_tor_hat = P_tor / D_norm**6.0 + P_tor_hat = P_perp / D_norm**6.0 +c --- build the E and F dispersion coefficients E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ - $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) ! P_tor = P_perp + $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 - !dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x - dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F !p*D = my_q +c --- Riccati ODE: dW/dq = W/q - W^2/q + q*E/F + dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F RETURN END SUBROUTINE w_der_del_s c----------------------------------------------------------------------- -c calculate delta based on Fitzpatrick P_perp and P_tor formulation. +c riccati_f: compute Delta via Fitzpatrick P_perp / P_tor +c Riccati formulation. +c +c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian +c (jac_f). Boundary conditions are set analytically from the +c large-p asymptotic behaviour; the branch depends on whether +c D_norm^2 exceeds iota_e * P_perp / P_tor^(2/3). +c +c BUG FLAG 8: argument tmp_g (COMPLEX) is never used in the +c function body. All references use the module-level variable +c g_tmp instead. The caller (slayer.f:785) passes g_tmp as +c tmp_g, so in practice the values match -- but tmp_g is +c redundant. Likely needs: g_tmp = tmp_g at the top, or +c remove the argument and rely on the module variable. +c BUG FLAG 9: variables xintv, xfac, y, dy, ck_1, ck_2, ml, mu, +c nrpd, alpha are declared but never used -- remove them. +c Optional argument inx is also never referenced in the body. c----------------------------------------------------------------------- FUNCTION riccati_f(tmp_g,inx) - COMPLEX(r8), INTENT(IN) :: tmp_g - REAL(r8),INTENT(IN),OPTIONAL :: inx - COMPLEX(r8) :: riccati_f - INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - INTEGER :: ml = 0, mu = 0, nrpd = 1 - REAL(r8) :: xintv,x,xout,rtol,jac,xmin,my_p,alpha,bk - COMPLEX(r8) :: ak,ck_1,ck_2,ck,xk,W_bound - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dWdp,y,dy - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork - REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork +c --- input arguments + COMPLEX(r8),INTENT(IN) :: tmp_g ! growth rate (UNUSED -- BUG FLAG 8) + REAL(r8),INTENT(IN),OPTIONAL :: inx ! (UNUSED -- BUG FLAG 9) +c --- function result + COMPLEX(r8) :: riccati_f +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER :: neq ! number of equations (=2) + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER :: liw,lrw ! lsode work array sizes + REAL(r8) :: xout ! target integration endpoint + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance + REAL(r8) :: jac ! dummy (overridden by jac_f) + REAL(r8) :: my_p ! integration variable p (large -> small) + REAL(r8) :: bk ! asymptotic coefficient b_k +c --- boundary-condition intermediates + COMPLEX(r8) :: ak ! asymptotic coefficient a_k + COMPLEX(r8) :: ck ! asymptotic coefficient c_k + COMPLEX(r8) :: xk ! asymptotic coefficient x_k + COMPLEX(r8) :: W_bound ! boundary value for W(p_start) +c --- work arrays + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dWdp ! W and dW/dp + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work + REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work + +c --- configure lsode: stiff BDF method with user Jacobian (mf=21) neq = 2 itol = 2 rtol = 1e-10 @@ -254,21 +382,24 @@ FUNCTION riccati_f(tmp_g,inx) atol(:) = 1e-10 itask = 2 istate = 1 - iopt = 0 - mf = 21 !21 IS STIFF WITH USER-SPECIFIED JACOBIAN, 10 iS NON STIFF + iopt = 1 ! enable optional inputs (iwork(6)) + mf = 21 ! stiff, user-supplied Jacobian (jac_f) liw = 20*2 - lrw = 22+9*neq+neq**2 !just (22+16*neq) for mf=10 - ALLOCATE(iwork(liw+neq),rwork(lrw)) ! just iwork(liw) for mf=10 + lrw = 22+9*neq+neq**2 ! stiff work array size + ALLOCATE(iwork(liw+neq),rwork(lrw)) - iopt = 1 +c --- set maximum internal steps iwork=0 - iwork(6)=50000 ! maximum # of steps per call, e.g. 50000 + iwork(6)=50000 ! MXSTEP: max internal steps per call rwork=0 xmin=1e-6 xout=xmin - ! Solve for p and W boundary conditions +c --- compute starting p and W boundary condition +c Branch on asymptotic regime: D_norm^2 vs iota_e*P_perp/P_tor^(2/3) +c --- branch 1: D_norm^2 > iota_e * P_perp / P_tor^(2/3) +c large-D_norm regime: p scales with (P_tor*D_norm^2/(iota_e*...)) IF ((D_norm**2.0) > ((iota_e*P_perp)/(P_tor**(2.0/3.0)))) THEN my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25 IF (my_p < 6.0) THEN @@ -286,6 +417,8 @@ FUNCTION riccati_f(tmp_g,inx) W_bound = xk - SQRT(bk)*my_p ELSE +c --- branch 2: D_norm^2 <= iota_e * P_perp / P_tor^(2/3) +c small-D_norm regime: p scales with 1/P_tor^(1/6) my_p = 1.0/(P_tor**(1.0/6.0)) IF (my_p < 6.0) THEN my_p = 6.0 @@ -301,7 +434,9 @@ FUNCTION riccati_f(tmp_g,inx) W(1) = W_bound +c --- integrate W(p) from p_start inward to p_min via lsode IF (riccati_out) THEN +c profile output: step-by-step integration with file writes istep = 1 itask = 2 OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// @@ -322,22 +457,22 @@ FUNCTION riccati_f(tmp_g,inx) CLOSE(bin_unit) CLOSE(out2_unit) ELSE +c single-shot integration to p_min istep = 1 itask = 1 CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) ENDIF +c --- extract Delta from final W derivative at p_min CALL w_der_f(neq,my_p,W,dWdp) - - !riccati_f = pi * my_p / (dWdp(1) + 1) riccati_f = pi / dWdp(1) DEALLOCATE(atol,W,dWdp,iwork,rwork) END FUNCTION riccati_f c----------------------------------------------------------------------- -c jacobian for riccati_f() -c------------------------------------------- ---------------------------- +c jacobian for riccati_f(): pd = dF/dW for stiff lsode. +c----------------------------------------------------------------------- SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) INTEGER, INTENT(IN) :: neq, ml, mu, nrpd REAL(r8), INTENT(IN) :: my_p @@ -351,7 +486,9 @@ SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) pd(1,1) = (-fA_p/my_p) - (2.0*W(1))/my_p END SUBROUTINE jac_f c----------------------------------------------------------------------- -c W derivative for riccati_f() +c w_der_f: ODE right-hand side dW/dp for riccati_f. +c Implements the Fitzpatrick P_perp / P_tor dispersion relation. +c Coefficients fA, fB, fC are evaluated at the current p. c----------------------------------------------------------------------- SUBROUTINE w_der_f(neq,my_p,W,dWdp) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index d9ebff46c..edef6d8d9 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -1,20 +1,47 @@ MODULE gslayer_mod +c----------------------------------------------------------------------- +c gslayer_mod: SLAYER driver routines and AMR dispersion scanners. +c +c Subprograms: +c 1. gpec_slayer - single-surface delta/torque driver +c 2. output_gamma - write results to netCDF via +c slayer_netcdf_mod +c 3. allocate_inputs - allocate slayer_inputs_type arrays +c 4. allocate_outputs - allocate slayer_outputs_type arrays +c 5. shrink_array - trim over-allocated scan arrays +c 6. grow_array - expand scan arrays dynamically +c 7. calc_determinant - 2x2 / 3x3 complex determinant +c 8. dispersion_det - coupled dispersion determinant +c 9. dispersion_AMR - AMR scan v1 (hash-based dedup) +c 10. dispersion_AMR_v2 - AMR scan v2 (cell-based storage) +c +c Helper subroutines (v1): get_or_compute +c Helper subroutines (v2): compute_delta_sub, +c check_cell_crossing_sub, subdivide_cell_sub, +c flatten_cells_to_points_sub +c----------------------------------------------------------------------- USE omp_lib - USE sglobal_mod, ONLY: out_unit,r8, mu0, m_p, chag, lnLamb, + USE sglobal_mod, ONLY: out_unit,r8,mu0,m_p,chag,lnLamb, $ Q_e,Q_i,pr,pe,c_beta,ds,tau, $ eta,visc,rho_s,lu,omega_e,omega_i, - $ delta_n, - $ Q - USE delta_mod - !, ONLY: riccati,riccati_out, - !$ parflow_flag,PeOhmOnly_flag - + $ delta_n,Q, + $ ifac,g_tmp,pi, ! used by AMR + $ tauk,iota_e,D_norm,P_perp,P_tor,delta_eff, ! used by det + $ amr_cell_type,amr_cells,n_amr_cells, ! v2 types + $ Q_store,D_store,n_pts, ! output arrays + $ MAX_PTS,HASH_SZ,HASH_SCALE, ! v1 constants + $ hash_head,hash_next, ! v1 hash + $ MAX_CELLS, ! v2 limit + $ slayer_inputs_type,slayer_outputs_type, + $ deltas_outputs_type, + $ tau_r,d_crit,delta_det,dc_tmp,dc_type, + $ sn,sm + USE delta_mod, ONLY: riccati,riccati_f,riccati_out, + $ parflow_flag,PeOhmOnly_flag USE params_mod - USE layerinputs_mod - USE slayer_netcdf_mod IMPLICIT NONE @@ -23,93 +50,144 @@ MODULE gslayer_mod c----------------------------------------------------------------------- c subprogram 1. gpec_slayer. -c run slayer to provide b_crit(ising). -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- -c declarations. +c Single-surface SLAYER driver: compute Delta, torque, and b_crit +c for one rational surface characterised by its plasma profiles. +c +c Steps: +c 1. Derive normalised SLAYER parameters (lu, ds, Q, Q_e, etc.) +c from dimensional inputs. +c 2. Compute baseline Delta via riccati(). +c 3. Scan over a range of Q (rotation) to build a torque +c balance curve, then identify the critical threshold br_th. +c +c BUG FLAG 1: `index` variable shadows the Fortran intrinsic +c INDEX(). Rename to e.g. `max_idx`. +c BUG FLAG 2: `iinQs` is declared but never used. Remove it. +c BUG FLAG 3: `zeff`, `qval`, `v_a`, `inlu` are declared / +c passed in but never used. Remove or document intent. c----------------------------------------------------------------------- SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, $ omega_i,qval,sval,bt,rs,R0,mu_i,inpr,mms,nns,ascii_flag, $ delta,psi0,jxb,omega_sol,br_th) - REAL(r8),INTENT(IN) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ qval,sval,bt,rs,R0,zeff,inpr - INTEGER, INTENT(IN) :: mms,nns,mu_i - LOGICAL, INTENT(IN) :: ascii_flag - COMPLEX(r8),INTENT(OUT) :: delta,psi0 - REAL(r8),INTENT(OUT) :: jxb,omega_sol,br_th +c --- input arguments: dimensional plasma profiles for this surface + REAL(r8),INTENT(IN) :: n_e ! electron density [m^-3] + REAL(r8),INTENT(IN) :: t_e ! electron temperature [eV] + REAL(r8),INTENT(IN) :: n_i ! ion density [m^-3] + REAL(r8),INTENT(IN) :: t_i ! ion temperature [eV] + REAL(r8),INTENT(IN) :: zeff ! (UNUSED -- BUG FLAG 3) + REAL(r8),INTENT(IN) :: omega ! plasma rotation frequency + REAL(r8),INTENT(IN) :: omega_e ! electron diamagnetic freq + REAL(r8),INTENT(IN) :: omega_i ! ion diamagnetic freq + REAL(r8),INTENT(IN) :: qval ! (UNUSED -- BUG FLAG 3) + REAL(r8),INTENT(IN) :: sval ! magnetic shear + REAL(r8),INTENT(IN) :: bt ! toroidal field [T] + REAL(r8),INTENT(IN) :: rs ! minor radius of surface [m] + REAL(r8),INTENT(IN) :: R0 ! major radius [m] + REAL(r8),INTENT(IN) :: inpr ! Prandtl number + INTEGER, INTENT(IN) :: mms ! poloidal mode number + INTEGER, INTENT(IN) :: nns ! toroidal mode number + INTEGER, INTENT(IN) :: mu_i ! ion mass number (AMU) + LOGICAL, INTENT(IN) :: ascii_flag ! write ASCII torque-balance file +c --- output arguments + COMPLEX(r8),INTENT(OUT) :: delta ! complex Delta + COMPLEX(r8),INTENT(OUT) :: psi0 ! reconnected flux (a.u.) + REAL(r8),INTENT(OUT) :: jxb ! JxB torque (a.u.) + REAL(r8),INTENT(OUT) :: omega_sol ! rotation at torque-balance + REAL(r8),INTENT(OUT) :: br_th ! critical radial field threshold - INTEGER :: i,inum - INTEGER, DIMENSION(1) :: index - - REAL(r8) :: inQ,inQ_e,inQ_i,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: mrs,nrs,rho,b_l,v_a,Qconv,Q0,delta_n_p, - $ lbeta,tau_i,tau_h,tau_v - REAL(r8) :: inQ_min,inQ_max,Q_sol - - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs,jxbl,bal - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal - CHARACTER(3) :: sn,sm +c --- loop / scan control + INTEGER :: i ! loop index + INTEGER :: inum ! number of scan points + INTEGER, DIMENSION(1) :: max_idx ! index of max torque balance +c --- local copies of normalised parameters for riccati() + REAL(r8) :: inQ,inQ_e,inQ_i ! normalised frequencies + REAL(r8) :: inpe ! electron Prandtl (set to 0) + REAL(r8) :: inc_beta,inds ! c_beta, ds copies + REAL(r8) :: intau ! tau copy +c --- derived dimensional quantities + REAL(r8) :: mrs,nrs ! real-valued mode numbers + REAL(r8) :: rho ! mass density [kg/m^3] + REAL(r8) :: b_l ! characteristic magnetic field + REAL(r8) :: Qconv ! Q normalisation factor + REAL(r8) :: Q0 ! initial Q (before scan) + REAL(r8) :: delta_n_p ! Delta_n perturbation + REAL(r8) :: lbeta ! local beta + REAL(r8) :: tau_i ! ion collision time + REAL(r8) :: tau_h ! Alfven time across surface + REAL(r8) :: tau_v ! viscous diffusion time +c --- scan workspace + REAL(r8) :: inQ_min,inQ_max ! scan bounds in Q + REAL(r8) :: Q_sol ! Q at torque-balance threshold + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs ! Q scan array + REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl ! JxB scan array + REAL(r8), DIMENSION(:), ALLOCATABLE :: bal ! balance scan array + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal ! delta scan array + CHARACTER(3) :: l_sn,l_sm ! local mode number strings +c --- set delta_mod control flags for this single-surface call parflow_flag=.FALSE. PeOhmOnly_flag=.TRUE. riccati_out=.FALSE. mrs = real(mms,4) nrs = real(nns,4) - - ! String representations of the m and n mode numbers +c----------------------------------------------------------------------- +c build string representations of m and n for file names. +c----------------------------------------------------------------------- IF (nns<10) THEN - WRITE(UNIT=sn,FMT='(I1)') nns - sn=ADJUSTL(sn) + WRITE(UNIT=l_sn,FMT='(I1)') nns + l_sn=ADJUSTL(l_sn) ELSE - WRITE(UNIT=sn,FMT='(I2)') nns + WRITE(UNIT=l_sn,FMT='(I2)') nns ENDIF IF (mms<10) THEN - WRITE(UNIT=sm,FMT='(I1)') mms - sm=ADJUSTL(sm) + WRITE(UNIT=l_sm,FMT='(I1)') mms + l_sm=ADJUSTL(l_sm) ELSEIF (mms<100) THEN - WRITE(UNIT=sm,FMT='(I2)') mms - sm=ADJUSTL(sm) + WRITE(UNIT=l_sm,FMT='(I2)') mms + l_sm=ADJUSTL(l_sm) ELSE - WRITE(UNIT=sm,FMT='(I3)') mms + WRITE(UNIT=l_sm,FMT='(I3)') mms ENDIF - inpe=0.0 ! Waybright added this + inpe=0.0 ! electron Prandtl not used here - tau= t_i/t_e ! ratio of ion to electron temperature - tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) +c----------------------------------------------------------------------- +c derive normalised SLAYER parameters from dimensional inputs. +c tau, eta, rho, b_l, v_a are intermediate dimensional quantities; +c lu (Lundquist), ds, Qconv, Q, Q_e, Q_i, c_beta are the +c normalised parameters used by riccati(). +c----------------------------------------------------------------------- + tau= t_i/t_e ! ion-to-electron temp ratio + tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion coll. time + eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! Spitzer resistivity (Wesson) rho=(mu_i*m_p)*n_e ! mass density b_l=(nrs/mrs)*nrs*sval*bt/R0 ! characteristic magnetic field - v_a=b_l/(mu0*rho)**0.5 ! alfven velocity - rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. - - tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! alfven time across surface - tau_r=mu0*rs**2.0/eta ! resistive time scale - tau_v=tau_r/inpr ! rho*rs**2.0/visc ! viscous time scale + rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Larmor radius at T_e - ! this one must be anomalous. calculated back from pr. - visc= rho*rs**2.0/tau_v + tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! Alfven transit time + tau_r=mu0*rs**2.0/eta ! resistive diffusion time + tau_v=tau_r/inpr ! viscous diffusion time + visc= rho*rs**2.0/tau_v ! back-calculated viscosity - lu=tau_r/tau_h ! Lundquist number + lu=tau_r/tau_h ! Lundquist number + Qconv=lu**(1.0/3.0)*tau_h ! Q normalisation factor - Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - - ! note Q depends on Qconv even IF omega is fixed. +c --- normalised frequencies Q=Qconv*omega Q_e=-Qconv*omega_e Q_i=-Qconv*omega_i - ! This is the most critical PARAMETER - ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. + ds=lu**(1.0/3.0)*rho_s/rs ! normalised ion sound radius lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 - c_beta=(lbeta/(1.0+lbeta))**0.5 + c_beta=(lbeta/(1.0+lbeta))**0.5 ! compressibility parameter - delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes + delta_n=lu**(1.0/3.0)/rs ! Delta normalisation factor +c --- copy normalised values into local variables for riccati() call inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -118,14 +196,22 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, intau=tau Q0=Q c----------------------------------------------------------------------- -c calculate basic delta, torque, balance, error fields. +c compute baseline Delta, reconnected flux, and JxB torque. +c BUG FLAG 4: delta_n_p = 1e-2 is hardcoded; should this come +c from the namelist or caller? c----------------------------------------------------------------------- delta_n_p=1e-2 delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) - psi0=1.0/ABS(delta+delta_n_p) ! a.u. - jxb=-AIMAG(1.0/(delta+delta_n_p)) ! a.u. + psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux (a.u.) + jxb=-AIMAG(1.0/(delta+delta_n_p)) ! JxB torque (a.u.) c----------------------------------------------------------------------- -c find solutions based on simple torque balance. +c torque-balance scan: sweep Q over [inQ_min, inQ_max] and +c compute delta(Q), JxB(Q), and the balance parameter. +c The threshold br_th is sqrt(max(bal)/lu * s^2/2). +c +c BUG FLAG 5: scan bounds from Q0/Q_e physics (lines above) are +c immediately overridden by hardcoded inQ_max=10, inQ_min=-10. +c Either remove the dead code above or use the physics bounds. c----------------------------------------------------------------------- IF (Q0>inQ_e) THEN inQ_max=2.0*Q0 @@ -139,8 +225,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, ENDIF ENDIF - ! Scan of rotation - inQ_max=10.0 + inQ_max=10.0 ! hardcoded override (see BUG FLAG 5) inQ_min=-10.0 inum=200 ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum),bal(0:inum)) @@ -152,10 +237,10 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) ENDDO - ! Write torque balance curves to file for diagnostic purposes +c --- optionally write torque balance curve to ASCII file IF(ascii_flag)THEN OPEN(UNIT=out_unit,FILE="gpec_slayer_torque_balance_m"// - $ TRIM(sm)//"_n"//TRIM(sn)//".OUT", + $ TRIM(l_sm)//"_n"//TRIM(l_sn)//".OUT", $ STATUS="UNKNOWN") WRITE(out_unit,'(1x,5(a17))') "inQ","RE(delta)", $ "IM(delta)","jxb","bal" @@ -166,28 +251,29 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, CLOSE(out_unit) ENDIF - ! Identify the threshold from the maximum of the balance PARAMETER - index=MAXLOC(bal) - Q_sol=inQs(index(1)) - omega_sol=inQs(index(1))/Qconv +c --- identify the critical threshold from the maximum balance value + max_idx=MAXLOC(bal) + Q_sol=inQs(max_idx(1)) + omega_sol=inQs(max_idx(1))/Qconv br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0)) DEALLOCATE(inQs,deltal,jxbl,bal) RETURN END SUBROUTINE gpec_slayer c----------------------------------------------------------------------- -c Subprogram 2. output_gamma -c Take SLAYER input and output dicts, send to netCDF subroutine +c subprogram 2. output_gamma. +c Write growth-rate results to netCDF via slayer_netcdf_out. +c Passes the input/output structured types and AMR results +c through to the netCDF writer (slayer_netcdf_mod). c----------------------------------------------------------------------- SUBROUTINE output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, $ all_deltas_out) - ! Declarations (include necessary type declarations from original code) - LOGICAL, INTENT(IN) :: est_gamma_flag - INTEGER, INTENT(IN) :: m_AMR + LOGICAL, INTENT(IN) :: est_gamma_flag ! single-surface mode? + INTEGER, INTENT(IN) :: m_AMR ! AMR pass count TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out - TYPE(deltas_outputs_type), INTENT(IN) :: + TYPE(deltas_outputs_type), INTENT(IN) :: $ all_deltas_out(SIZE(sl_in%qval_arr)) CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),m_AMR,est_gamma_flag, @@ -195,11 +281,12 @@ SUBROUTINE output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, END SUBROUTINE output_gamma c----------------------------------------------------------------------- -c Subprogram 3. allocate_inputs -c Allocate arrays inside SLAYER inputs type (dictionary-esque) +c subprogram 3. allocate_inputs. +c Allocate all per-surface arrays inside slayer_inputs_type. c----------------------------------------------------------------------- SUBROUTINE allocate_inputs(n_k,sl_in) - INTEGER, INTENT(IN) :: n_k + + INTEGER, INTENT(IN) :: n_k ! number of surfaces TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in ALLOCATE(sl_in%qval_arr(n_k),sl_in%omegas_arr(n_k), @@ -213,11 +300,12 @@ SUBROUTINE allocate_inputs(n_k,sl_in) RETURN END SUBROUTINE allocate_inputs c----------------------------------------------------------------------- -c Subprogram 4. allocate_outputs -c Allocate arrays inside SLAYER outputs type (dictionary-esque) +c subprogram 4. allocate_outputs. +c Allocate per-surface arrays inside slayer_outputs_type. c----------------------------------------------------------------------- SUBROUTINE allocate_outputs(n_k,sl_out) - INTEGER, INTENT(IN) :: n_k + + INTEGER, INTENT(IN) :: n_k ! number of surfaces TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out ALLOCATE(sl_out%dels_db_arr(n_k),sl_out%gamma_sol_arr(n_k), @@ -225,43 +313,54 @@ SUBROUTINE allocate_outputs(n_k,sl_out) RETURN END SUBROUTINE allocate_outputs c----------------------------------------------------------------------- -c Subprogram 5. shrink_array -c Remove excess scan array size from memory +c subprogram 5. shrink_array. +c Trim an over-allocated REAL(r8) array down to new_size using +c MOVE_ALLOC (no copy of trailing elements). c----------------------------------------------------------------------- SUBROUTINE shrink_array(arr, new_size) + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) - INTEGER, INTENT(IN) :: new_size - REAL(r8), ALLOCATABLE :: temp(:) + INTEGER, INTENT(IN) :: new_size ! target size + REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer ALLOCATE(temp(new_size)) temp(1:new_size) = arr(1:new_size) CALL move_alloc(temp, arr) END SUBROUTINE shrink_array c----------------------------------------------------------------------- -c Subprogram 6. grow_array -c Increase scan array size IF necessary +c subprogram 6. grow_array. +c Expand a REAL(r8) array from old_size to new_size, preserving +c existing data via MOVE_ALLOC. c----------------------------------------------------------------------- SUBROUTINE grow_array(arr, old_size, new_size) + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) - INTEGER, INTENT(IN) :: old_size,new_size - REAL(r8), ALLOCATABLE :: temp(:) + INTEGER, INTENT(IN) :: old_size ! current valid element count + INTEGER, INTENT(IN) :: new_size ! target allocation size + REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer ALLOCATE(temp(new_size)) temp(1:old_size) = arr(1:old_size) CALL move_alloc(temp, arr) END SUBROUTINE grow_array c----------------------------------------------------------------------- -c Subprogram 7. calc_determinant -c Calculate determinant of 2x2 and 3x3 matrices +c subprogram 7. calc_determinant. +c Compute the determinant of a 2x2 or 3x3 complex matrix. +c Returns (0,0) and sets status=-1 for unsupported sizes. +c +c BUG FLAG 6: variable `status` is computed but never returned +c to the caller. Either add an INTENT(OUT) argument or remove. c----------------------------------------------------------------------- SUBROUTINE calc_determinant(matk, nk, detk) + IMPLICIT NONE - - ! Arguments - INTEGER, INTENT(IN) :: nk ! Matrix size (2 or 3) - COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! Input matrix - COMPLEX(r8), INTENT(OUT) :: detk ! Determinant result - INTEGER :: status ! Status (0=success, -1=error) + +c --- arguments + INTEGER, INTENT(IN) :: nk ! matrix rank (2 or 3) + COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! input matrix + COMPLEX(r8), INTENT(OUT) :: detk ! determinant result +c --- local + INTEGER :: status ! error status (unused externally) status = 0 ! Initialize status as success @@ -286,19 +385,38 @@ SUBROUTINE calc_determinant(matk, nk, detk) RETURN END SUBROUTINE calc_determinant c----------------------------------------------------------------------- -c Subprogram 8. dispersion_det -c Calculate determinant of coupling matrix e-value problem +c subprogram 8. dispersion_det. +c Compute the coupled dispersion determinant for n_k surfaces. +c +c For n_k = 1 (single surface): +c Evaluate riccati_f(g_tmp), de-normalise by lu^(1/3), and +c return Deltaprime - delta(Q). +c +c For n_k = 2 or 3 (coupled surfaces): +c Build the diagonal delta(Q) matrix, subtract from dp_matrix, +c and return det(dp_matrix - delta_Q). +c +c BUG FLAG 7: bare `stop` on n_k > 3 -- use STOP with message +c consistently, or return a NaN sentinel. c----------------------------------------------------------------------- FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) - - COMPLEX(r8), INTENT(IN) :: g_tmp - INTEGER, INTENT(IN) :: n_k,msing_max + +c --- arguments + COMPLEX(r8), INTENT(IN) :: g_tmp ! complex growth rate + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces to include TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - COMPLEX(r8) :: dispersion_det,det_val,tmp_delta - COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:),result_matrix(:,:) - INTEGER :: k +c --- function result and locals + COMPLEX(r8) :: dispersion_det ! returned determinant + COMPLEX(r8) :: det_val ! intermediate determinant + COMPLEX(r8) :: tmp_delta ! single-surface delta + COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:) ! diagonal delta matrix + COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! dp - delta_Q + INTEGER :: k ! surface loop index +c --- single-surface branch IF (n_k < 2) THEN +c set module-level variables for riccati_f Q_e = sl_in%Q_e_arr(1) Q_i = sl_in%Q_i_arr(1) P_perp = sl_in%P_perp_arr(1) @@ -310,15 +428,18 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) iota_e = Q_e / (Q_e - Q_i) tmp_delta=riccati_f(g_tmp) - det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) ! DE-NORMALIZE +c de-normalise delta by lu^(1/3) + det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) - ! Calculate Deltaprime - Delta(Q) +c return Deltaprime - delta(Q) dispersion_det = sl_in%Re_dp_arr(1) - det_val +c --- coupled-surface branch (2 or 3 surfaces) ELSEIF ((n_k == 2) .OR. (n_k == 3)) THEN ALLOCATE(delta_Q(n_k,n_k)) delta_Q=(0.0,0.0) - DO k=1,msing_max ! maxing out at msing_max + DO k=1,msing_max +c set module-level variables for this surface Q_e = sl_in%Q_e_arr(k) Q_i = sl_in%Q_i_arr(k) P_perp = sl_in%P_perp_arr(k) @@ -328,176 +449,172 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) c_beta = sl_in%c_beta_arr(k) tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) - + +c evaluate riccati_f at rescaled growth rate, de-normalise delta_Q(k,k)=riccati_f(((g_tmp*sl_in%Qconv_arr(1)) $ /tauk)) - delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) ! DE-NORMALIZE + delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) END DO - - ! Calculate Deltaprime - Delta(Q) - result_matrix = sl_in%dp_matrix - delta_Q - ! Calculate determinant +c compute det(dp_matrix - delta_Q) + result_matrix = sl_in%dp_matrix - delta_Q CALL calc_determinant(result_matrix, n_k, det_val) dispersion_det = det_val ELSE - WRITE(*,*)"Error: no support for msing > 3" - stop + WRITE(*,*) "Error: no support for msing > 3" + STOP "dispersion_det: unsupported n_k" END IF END FUNCTION dispersion_det +c----------------------------------------------------------------------- +c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc Scans a 2D complex-Q grid for zeros of the dispersion relation +c D(Q) using adaptive refinement. A coarse grid is evaluated +c first (two-pass: nodes then cells), then cells that span a zero +c crossing in Re(D) or Im(D) are subdivided. +c +c Point deduplication uses a spatial hash table (HASH_SZ buckets, +c chained) so that midpoints shared between neighbouring cells +c are evaluated only once. +c +c BUG FLAG 8 \u2013 h_idx, pt_idx are declared but never referenced. +c Remove them. +c----------------------------------------------------------------------- SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, $ scan_width,Q_num,AMR_passes, $ coupling_flag) - !WRITE(*,*)"------------------------------------------" - !WRITE(*,'(A,F0.1,A,I2,A)')' >>> Running Adaptive AMR Scan [Width=',scan_width, & - ! ', Passes=', AMR_PASSES, ']' - INTEGER, INTENT(IN) :: n_k,msing_max,Q_num,AMR_passes - REAL(r8), INTENT(IN) :: scan_width - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag - !COMPLEX(r8), INTENT(OUT), ALLOCATABLE :: Q_store(:) ! Stores Q coordinates - !COMPLEX(r8), INTENT(OUT), ALLOCATABLE :: D_store(:) ! Stores Result Delta - INTEGER, ALLOCATABLE :: cells(:,:) ! 4 corners (indices) per cell - INTEGER, ALLOCATABLE :: new_cells(:,:) ! Temp array for next level +c --- arguments + INTEGER, INTENT(IN) :: n_k ! number of rational surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling + INTEGER, INTENT(IN) :: Q_num ! grid points per axis + INTEGER, INTENT(IN) :: AMR_passes ! refinement passes + REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? +c --- cell storage + INTEGER, ALLOCATABLE :: cells(:,:) ! (4, max) corner indices per cell + INTEGER, ALLOCATABLE :: new_cells(:,:) ! scratch for next level +c --- loop / index variables INTEGER :: n_cells, n_new_cells, i, j - INTEGER :: h_idx, pt_idx, c_idx, pass - INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! Corner indices - INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! Midpoint indices - REAL(r8) :: r_min, r_max, i_min, i_max, ing_step, - $ ing_coarse,iing_coarse - LOGICAL :: cross_real, cross_imag - !INTEGER, INTENT(OUT) :: n_pts - - COMPLEX(r8) :: q_curr - INTEGER, ALLOCATABLE :: coarse_indices(:,:) - ! (Re-allocate or just reset counters. Re-allocating ensures clean slate) - !IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store, D_store) - !IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head, hash_next) - !IF (ALLOCATED(cells)) DEALLOCATE(cells, new_cells) - - ! --- 1. Initialize Memory --- - !ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) - !ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) - !ALLOCATE(cells(4, 200000), new_cells(4, 200000)) ! Estimate cell count - + INTEGER :: h_idx, pt_idx, c_idx, pass ! h_idx, pt_idx UNUSED (BUG FLAG 8) + INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! corner indices + INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! midpoint indices +c --- scan workspace + REAL(r8) :: r_min, r_max, i_min, i_max ! min/max Re/Im across corners + REAL(r8) :: ing_step ! coarse grid spacing + REAL(r8) :: ing_coarse, iing_coarse ! Re/Im coords for coarse node + LOGICAL :: cross_real, cross_imag ! zero-crossing flags + COMPLEX(r8) :: q_curr ! current evaluation point + INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Q_num,Q_num) node index map + +c --- 1. initialise hash table and point/cell storage IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) IF (ALLOCATED(D_store)) DEALLOCATE(D_store) IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - + ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) ALLOCATE(cells(4, 200000), new_cells(4, 200000)) - + hash_head = 0 hash_next = 0 n_pts = 0 n_cells = 0 - - ! --- 2. Build Initial Coarse Grid (Robust 2-Pass Method) --- + +c --- 2. build initial coarse grid (two-pass method) +c Pass 1 computes and hashes every node; Pass 2 stitches cells +c from the stored indices -- no floating-point comparison needed. ALLOCATE(coarse_indices(Q_num, Q_num)) ing_step = (2.0*scan_width) / (Q_num - 1) - ! PASS 1: Compute ALL points and store their indices - ! This ensures every grid node is computed exactly once and hashed consistently +c Pass 1: compute all grid nodes and store their hash indices DO i = 1, Q_num DO j = 1, Q_num ing_coarse = -scan_width + (i - 1) * ing_step iing_coarse = -scan_width + (j - 1) * ing_step q_curr = CMPLX(ing_coarse, iing_coarse) - - CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, + + CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, $ sl_in, msing_max, coupling_flag) END DO END DO - ! PASS 2: Stitch cells together using the stored indices - ! No floating point math here, just integer lookups -> Perfect Topology +c Pass 2: stitch cells from the stored integer indices DO i = 1, Q_num - 1 DO j = 1, Q_num - 1 n_cells = n_cells + 1 - - ! Define corners using the pre-calculated indices - cells(1, n_cells) = coarse_indices(i, j) ! Top-Left - cells(2, n_cells) = coarse_indices(i+1, j) ! Top-Right - cells(3, n_cells) = coarse_indices(i, j+1) ! Bot-Left - cells(4, n_cells) = coarse_indices(i+1, j+1) ! Bot-Right + cells(1, n_cells) = coarse_indices(i, j) ! TL + cells(2, n_cells) = coarse_indices(i+1, j) ! TR + cells(3, n_cells) = coarse_indices(i, j+1) ! BL + cells(4, n_cells) = coarse_indices(i+1, j+1) ! BR END DO END DO - - DEALLOCATE(coarse_indices) ! Clean up temp array + DEALLOCATE(coarse_indices) - ! --- 3. Refinement Loops --- +c --- 3. refinement passes: subdivide cells with zero crossings DO pass = 1, AMR_PASSES - WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, + WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, $ ': Checking ', n_cells, ' cells...' n_new_cells = 0 - + DO c_idx = 1, n_cells idx_TL = cells(1, c_idx) idx_TR = cells(2, c_idx) idx_BL = cells(3, c_idx) idx_BR = cells(4, c_idx) - - ! Check for contours (Sign changes across the cell) - ! Real Part Check - r_min = MIN(REAL(D_store(idx_TL)), + +c check for sign change in Re(D) across cell corners + r_min = MIN(REAL(D_store(idx_TL)), $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BL)), $ REAL(D_store(idx_BR))) - r_max = MAX(REAL(D_store(idx_TL)), + r_max = MAX(REAL(D_store(idx_TL)), $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BL)), $ REAL(D_store(idx_BR))) cross_real = (r_min * r_max <= 0.0d0) - - ! Imag Part Check - i_min = MIN(AIMAG(D_store(idx_TL)), + +c check for sign change in Im(D) across cell corners + i_min = MIN(AIMAG(D_store(idx_TL)), $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BL)), $ AIMAG(D_store(idx_BR))) - i_max = MAX(AIMAG(D_store(idx_TL)), + i_max = MAX(AIMAG(D_store(idx_TL)), $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BL)), $ AIMAG(D_store(idx_BR))) cross_imag = (i_min * i_max <= 0.0d0) IF (cross_real .OR. cross_imag) THEN - ! --- REFINE THIS CELL --- - ! We need 5 new points: Top-Mid, Bot-Mid, Left-Mid, Right-Mid, Center - - ! Calculate coords from corners - ! TL: Q_store(idx_TL), BR: Q_store(idx_BR) +c refine: compute 5 midpoints, create 4 sub-cells ! Top-Mid q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_TR)) CALL get_or_compute(q_curr, idx_TM,n_k, $ sl_in,msing_max,coupling_flag) - + ! Bot-Mid q_curr = 0.5d0*(Q_store(idx_BL)+Q_store(idx_BR)) CALL get_or_compute(q_curr, idx_BM,n_k, $ sl_in,msing_max,coupling_flag) - + ! Left-Mid q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BL)) CALL get_or_compute(q_curr, idx_LM,n_k, $ sl_in,msing_max,coupling_flag) - + ! Right-Mid q_curr = 0.5d0*(Q_store(idx_TR)+Q_store(idx_BR)) CALL get_or_compute(q_curr, idx_RM,n_k, $ sl_in,msing_max,coupling_flag) - + ! Center q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BR)) CALL get_or_compute(q_curr, idx_MM,n_k, $ sl_in,msing_max,coupling_flag) - ! Create 4 new sub-cells (Top-Left, Top-Right, Bot-Left, Bot-Right) - ! Sub 1 (Top-Left) + ! Create 4 sub-cells (TL, TR, BL, BR quadrants) n_new_cells = n_new_cells + 1 new_cells(1, n_new_cells) = idx_TL new_cells(2, n_new_cells) = idx_TM @@ -532,72 +649,73 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, END IF END DO - ! Swap arrays for next iteration +c --- swap arrays for next refinement pass n_cells = n_new_cells cells(:, 1:n_cells) = new_cells(:, 1:n_cells) - + END DO DEALLOCATE(cells, new_cells) WRITE(*,*) "AMR Scan Complete. Total Points:", n_pts - WRITE(*,*)"gslayer.f Q_store(10) = ",Q_store(10) RETURN END SUBROUTINE dispersion_AMR +c----------------------------------------------------------------------- +c get_or_compute: hash-based point lookup for dispersion_AMR v1. +c If q_in is already in the hash table, return its index. +c Otherwise, evaluate the dispersion relation at q_in, store +c the result, and insert into the hash table. +c +c Uses 64-bit arithmetic internally to avoid integer overflow +c in the hash function. +c----------------------------------------------------------------------- SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, $ coupling_flag) - COMPLEX(r8), INTENT(IN) :: q_in - !INTEGER, INTENT(INOUT) :: n_pts - !COMPLEX(r8), INTENT(INOUT) :: Q_store(:),D_store(:) + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point + INTEGER, INTENT(OUT) :: idx_out ! returned point index + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces to include TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - INTEGER, INTENT(IN) :: n_k, msing_max - INTEGER, INTENT(OUT) :: idx_out - LOGICAL, INTENT(IN) :: coupling_flag - INTEGER :: h, curr - COMPLEX(r8) :: delta_val - INTEGER(8) :: ix8, iy8, h8 ! 64-bit integers for hash calculation - - ! 1. Calculate Hash - !ix = NINT(REAL(q_in) * HASH_SCALE) - !iy = NINT(AIMAG(q_in) * HASH_SCALE) - ! Simple hash mix - !h = MOD(ABS(ix * 73856093 + iy * 19349663), HASH_SZ) + 1 - - ! 1. Calculate Hash using 64-bit arithmetic + LOGICAL, INTENT(IN) :: coupling_flag ! use coupled dispersion_det? +c --- locals + INTEGER :: h ! hash bucket index + INTEGER :: curr ! linked-list traversal index + COMPLEX(r8) :: delta_val ! computed dispersion result + INTEGER(8) :: ix8, iy8, h8 ! 64-bit intermediates for hash + +c --- 1. compute hash from quantised Re/Im coordinates (64-bit safe) ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) - h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), - $ INT(HASH_SZ, 8)) + 1_8 - h = INT(h8) ! Safe to convert back, result is within HASH_SZ - + h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), + $ INT(HASH_SZ, 8)) + 1_8 + h = INT(h8) + IF (h < 1 .OR. h > HASH_SZ) THEN WRITE(*,*) "HASH ERROR: h=", h, " q_in=", q_in - WRITE(*,*) " ix=", ix8, " iy=", iy8 - STOP + STOP "get_or_compute: hash out of bounds" END IF - ! 2. Check collisions +c --- 2. search hash chain for existing point curr = hash_head(h) DO WHILE (curr /= 0) - ! Check if point matches (with small tolerance) IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN idx_out = curr - RETURN ! Found it, return existing index + RETURN END IF curr = hash_next(curr) END DO - - ! 3. Not found: Compute and Store - n_pts = n_pts + 1 +c --- 3. point not found: evaluate dispersion relation and store + n_pts = n_pts + 1 IF (n_pts > MAX_PTS) THEN WRITE(*,*) "ERROR: AMR exceeded MAX_PTS" - STOP + STOP "get_or_compute: MAX_PTS exceeded" END IF - + idx_out = n_pts Q_store(idx_out) = q_in - - ! --- PHYSICS EVALUATION --- + IF (coupling_flag) THEN g_tmp = q_in delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) @@ -607,46 +725,59 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, delta_val = delta_val - delta_eff END IF D_store(idx_out) = delta_val - ! -------------------------- - - ! 4. Add to Hash Table + +c --- 4. insert into hash chain (prepend) hash_next(idx_out) = hash_head(h) hash_head(h) = idx_out - + END SUBROUTINE get_or_compute +c----------------------------------------------------------------------- +c dispersion_AMR_v2: cell-based adaptive mesh refinement scanner. +c Unlike v1 (hash-based point deduplication), v2 stores complete +c cells (TYPE amr_cell_type), each carrying 4 corner Q- and D- +c values. Refinement subdivides cells that contain a zero in +c Re(D) or Im(D) and re-evaluates the dispersion relation at the +c 5 new midpoints. +c +c After refinement, flatten_cells_to_points_sub extracts unique +c (Q, D) points into Q_store / D_store for output. +c +c BUG FLAG 9 – several bare stop statements should carry messages. +c----------------------------------------------------------------------- SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, $ scan_width, Q_num, AMR_passes, $ coupling_flag) - + IMPLICIT NONE - - INTEGER, INTENT(IN) :: n_k, msing_max, Q_num, AMR_passes - REAL(r8), INTENT(IN) :: scan_width + +c --- arguments + INTEGER, INTENT(IN) :: n_k ! number of rational surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling + INTEGER, INTENT(IN) :: Q_num ! grid points per axis + INTEGER, INTENT(IN) :: AMR_passes ! refinement passes + REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag - + LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? +c --- locals TYPE(amr_cell_type), ALLOCATABLE :: new_cells(:) - INTEGER :: i, j, c, corner, pass - REAL(r8) :: step, x, y - COMPLEX(r8) :: delta_val - LOGICAL :: cross_real, cross_imag - INTEGER :: n_new_cells - INTEGER :: cells_to_refine, cells_kept - - ! --- 1. Clean Initialization --- - WRITE(*,*) '=== AMR v2 Starting ===' - - IF (ALLOCATED(amr_cells)) THEN - WRITE(*,*) 'Deallocating old amr_cells' - DEALLOCATE(amr_cells) - END IF - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - + INTEGER :: i, j, c, corner, pass ! loop counters + REAL(r8) :: step ! grid spacing + REAL(r8) :: x, y ! real / imag grid coords + COMPLEX(r8) :: delta_val ! (unused – computed inside helper) + LOGICAL :: cross_real, cross_imag ! zero-crossing flags + INTEGER :: n_new_cells ! count during refinement + INTEGER :: cells_to_refine ! cells flagged per pass + INTEGER :: cells_kept ! cells kept per pass + +c --- 1. initialise cell storage + + IF (ALLOCATED(amr_cells)) DEALLOCATE(amr_cells) + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + ALLOCATE(amr_cells(MAX_CELLS)) ALLOCATE(new_cells(MAX_CELLS)) - - ! Initialize all cells + DO i = 1, MAX_CELLS amr_cells(i)%Q = (0.0d0, 0.0d0) amr_cells(i)%D = (0.0d0, 0.0d0) @@ -655,128 +786,117 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, new_cells(i)%D = (0.0d0, 0.0d0) new_cells(i)%needs_refine = .FALSE. END DO - + n_amr_cells = 0 step = (2.0d0 * scan_width) / DBLE(Q_num - 1) - WRITE(*,*) 'Scan width:', scan_width - WRITE(*,*) 'Q_num:', Q_num - WRITE(*,*) 'Step size:', step - WRITE(*,*) 'AMR passes:', AMR_passes - - ! --- 2. Build Initial Coarse Grid --- - WRITE(*,*) 'Building initial coarse grid...' - +c --- 2. build initial coarse grid of (Q_num-1)^2 cells + DO i = 1, Q_num - 1 DO j = 1, Q_num - 1 x = -scan_width + DBLE(i-1) * step y = -scan_width + DBLE(j-1) * step - + n_amr_cells = n_amr_cells + 1 - + IF (n_amr_cells > MAX_CELLS) THEN WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in init' - STOP + STOP 'dispersion_AMR_v2: MAX_CELLS in init' END IF - - ! Define corner coordinates (BL, BR, TL, TR) + +c corner order: BL=1, BR=2, TL=3, TR=4 amr_cells(n_amr_cells)%Q(1) = CMPLX(x, y, KIND=r8) amr_cells(n_amr_cells)%Q(2) = CMPLX(x+step, y, KIND=r8) amr_cells(n_amr_cells)%Q(3) = CMPLX(x, y+step, KIND=r8) - amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, + amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, $ KIND=r8) - - ! Compute Delta at each corner + +c evaluate dispersion at each corner DO corner = 1, 4 CALL compute_delta_sub( $ amr_cells(n_amr_cells)%Q(corner), $ n_k, sl_in, msing_max, coupling_flag, $ amr_cells(n_amr_cells)%D(corner)) END DO - + amr_cells(n_amr_cells)%needs_refine = .FALSE. END DO END DO - - WRITE(*,*) 'Initial grid cells:', n_amr_cells - ! --- 3. Refinement Passes --- +c --- 3. refinement passes: subdivide cells with zero crossings DO pass = 1, AMR_passes - WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, + WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, $ ': Processing ', n_amr_cells, ' cells' - - ! Mark cells that need refinement + +c flag cells that span a zero in Re(D) or Im(D) cells_to_refine = 0 DO c = 1, n_amr_cells - CALL check_cell_crossing_sub(amr_cells(c), + CALL check_cell_crossing_sub(amr_cells(c), $ cross_real, cross_imag) amr_cells(c)%needs_refine = (cross_real .OR. cross_imag) IF (amr_cells(c)%needs_refine) THEN cells_to_refine = cells_to_refine + 1 END IF END DO - - WRITE(*,*) ' Cells to refine:', cells_to_refine - - ! Build new cell list + +c build new cell list: subdivide flagged, keep the rest n_new_cells = 0 cells_kept = 0 - + DO c = 1, n_amr_cells IF (amr_cells(c)%needs_refine) THEN - ! Subdivide this cell into 4 - CALL subdivide_cell_sub(amr_cells(c), + CALL subdivide_cell_sub(amr_cells(c), $ new_cells, n_new_cells, MAX_CELLS, $ n_k, sl_in, msing_max, coupling_flag) ELSE - ! Keep cell as-is n_new_cells = n_new_cells + 1 IF (n_new_cells > MAX_CELLS) THEN WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in refine' - STOP + STOP 'dispersion_AMR_v2: MAX_CELLS in refine' END IF new_cells(n_new_cells) = amr_cells(c) cells_kept = cells_kept + 1 END IF END DO - - WRITE(*,*) ' Cells kept:', cells_kept - WRITE(*,*) ' New total cells:', n_new_cells - - ! Copy new_cells back to amr_cells + +c swap arrays for next pass n_amr_cells = n_new_cells DO c = 1, n_amr_cells amr_cells(c) = new_cells(c) END DO - + END DO - - ! --- 4. Flatten to Output Arrays --- - WRITE(*,*) 'Flattening cells to output arrays...' + +c --- 4. flatten cells to unique (Q, D) output arrays CALL flatten_cells_to_points_sub(n_amr_cells) - - ! Cleanup + DEALLOCATE(new_cells) - ! Keep amr_cells allocated for potential debugging - +c keep amr_cells allocated for potential post-run inspection + WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts - + RETURN END SUBROUTINE dispersion_AMR_v2 - -! ============================================================ +c----------------------------------------------------------------------- +c compute_delta_sub: evaluate the dispersion relation at a single +c complex-Q point for dispersion_AMR_v2. Multiplies q_in by ifac +c before passing to the Riccati solver or coupled-surface +c determinant routine. +c----------------------------------------------------------------------- SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, $ coupling_flag, delta_out) - + IMPLICIT NONE - - COMPLEX(r8), INTENT(IN) :: q_in - INTEGER, INTENT(IN) :: n_k, msing_max + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag - COMPLEX(r8), INTENT(OUT) :: delta_out - + LOGICAL, INTENT(IN) :: coupling_flag ! use coupled det? + COMPLEX(r8), INTENT(OUT) :: delta_out ! dispersion result + IF (coupling_flag) THEN g_tmp = q_in*ifac delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) @@ -785,98 +905,109 @@ SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, delta_out = riccati_f(g_tmp) delta_out = delta_out - delta_eff END IF - + RETURN END SUBROUTINE compute_delta_sub -! ============================================================ +c----------------------------------------------------------------------- +c check_cell_crossing_sub: test whether a cell’s 4 corner D-values +c span a zero crossing in Re(D) and/or Im(D). Used by +c dispersion_AMR_v2 to decide which cells to refine. +c----------------------------------------------------------------------- SUBROUTINE check_cell_crossing_sub(cell, cross_real, cross_imag) - + IMPLICIT NONE - + TYPE(amr_cell_type), INTENT(IN) :: cell LOGICAL, INTENT(OUT) :: cross_real, cross_imag - - REAL(r8) :: r_vals(4), i_vals(4) + + REAL(r8) :: r_vals(4), i_vals(4) ! corner Re/Im values REAL(r8) :: r_min, r_max, i_min, i_max - INTEGER :: k - - ! Extract real and imaginary parts + INTEGER :: k + DO k = 1, 4 r_vals(k) = REAL(cell%D(k), KIND=r8) i_vals(k) = AIMAG(cell%D(k)) END DO - + r_min = MINVAL(r_vals) r_max = MAXVAL(r_vals) cross_real = (r_min * r_max <= 0.0d0) - + i_min = MINVAL(i_vals) i_max = MAXVAL(i_vals) cross_imag = (i_min * i_max <= 0.0d0) - + RETURN END SUBROUTINE check_cell_crossing_sub -! ============================================================ - SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, - $ max_cells, n_k, sl_in, +c----------------------------------------------------------------------- +c subdivide_cell_sub: split a parent cell into 4 child cells by +c computing 5 midpoints (bottom-mid, top-mid, left-mid, right-mid, +c centre) and evaluating the dispersion relation at each. The 4 +c resulting child cells are appended to new_cells. +c----------------------------------------------------------------------- + SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, + $ max_cells, n_k, sl_in, $ msing_max, coupling_flag) - + IMPLICIT NONE - - TYPE(amr_cell_type), INTENT(IN) :: parent + +c --- arguments + TYPE(amr_cell_type), INTENT(IN) :: parent TYPE(amr_cell_type), INTENT(INOUT) :: new_cells(*) - INTEGER, INTENT(INOUT) :: n_new - INTEGER, INTENT(IN) :: max_cells - INTEGER, INTENT(IN) :: n_k, msing_max + INTEGER, INTENT(INOUT) :: n_new ! running count of new cells + INTEGER, INTENT(IN) :: max_cells ! capacity of new_cells + INTEGER, INTENT(IN) :: n_k + INTEGER, INTENT(IN) :: msing_max TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag - + LOGICAL, INTENT(IN) :: coupling_flag +c --- corner coordinates and D-values from parent COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr + COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr +c --- midpoint coordinates and D-values (5 new evaluations) COMPLEX(r8) :: q_bm, q_tm, q_lm, q_rm, q_mm COMPLEX(r8) :: d_bm, d_tm, d_lm, d_rm, d_mm - COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr - ! Extract parent corners (BL=1, BR=2, TL=3, TR=4) +c --- extract parent corners (BL=1, BR=2, TL=3, TR=4) q_bl = parent%Q(1) q_br = parent%Q(2) q_tl = parent%Q(3) q_tr = parent%Q(4) - + d_bl = parent%D(1) d_br = parent%D(2) d_tl = parent%D(3) d_tr = parent%D(4) - - ! Compute midpoint coordinates - q_bm = 0.5d0 * (q_bl + q_br) ! Bottom middle - q_tm = 0.5d0 * (q_tl + q_tr) ! Top middle - q_lm = 0.5d0 * (q_bl + q_tl) ! Left middle - q_rm = 0.5d0 * (q_br + q_tr) ! Right middle - q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) ! Center - - ! Compute Delta at new midpoints (5 new evaluations) - CALL compute_delta_sub(q_bm, n_k, sl_in, msing_max, + +c --- compute 5 midpoint coordinates + q_bm = 0.5d0 * (q_bl + q_br) + q_tm = 0.5d0 * (q_tl + q_tr) + q_lm = 0.5d0 * (q_bl + q_tl) + q_rm = 0.5d0 * (q_br + q_tr) + q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) + +c --- evaluate dispersion at new midpoints (5 calls) + CALL compute_delta_sub(q_bm, n_k, sl_in, msing_max, $ coupling_flag, d_bm) - CALL compute_delta_sub(q_tm, n_k, sl_in, msing_max, + CALL compute_delta_sub(q_tm, n_k, sl_in, msing_max, $ coupling_flag, d_tm) - CALL compute_delta_sub(q_lm, n_k, sl_in, msing_max, + CALL compute_delta_sub(q_lm, n_k, sl_in, msing_max, $ coupling_flag, d_lm) - CALL compute_delta_sub(q_rm, n_k, sl_in, msing_max, + CALL compute_delta_sub(q_rm, n_k, sl_in, msing_max, $ coupling_flag, d_rm) - CALL compute_delta_sub(q_mm, n_k, sl_in, msing_max, + CALL compute_delta_sub(q_mm, n_k, sl_in, msing_max, $ coupling_flag, d_mm) - - ! Check space for 4 new cells + +c --- check space for 4 new cells IF (n_new + 4 > max_cells) THEN WRITE(*,*) 'ERROR: Would exceed MAX_CELLS in subdivide' - STOP + STOP 'subdivide_cell_sub: MAX_CELLS exceeded' END IF - - ! Child 1: Bottom-Left quadrant (BL, BM, LM, MM) + +c --- child 1: bottom-left quadrant (BL, BM, LM, MM) n_new = n_new + 1 new_cells(n_new)%Q(1) = q_bl new_cells(n_new)%Q(2) = q_bm @@ -888,7 +1019,7 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, new_cells(n_new)%D(4) = d_mm new_cells(n_new)%needs_refine = .FALSE. - ! Child 2: Bottom-Right quadrant (BM, BR, MM, RM) +c --- child 2: bottom-right quadrant (BM, BR, MM, RM) n_new = n_new + 1 new_cells(n_new)%Q(1) = q_bm new_cells(n_new)%Q(2) = q_br @@ -900,7 +1031,7 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, new_cells(n_new)%D(4) = d_rm new_cells(n_new)%needs_refine = .FALSE. - ! Child 3: Top-Left quadrant (LM, MM, TL, TM) +c --- child 3: top-left quadrant (LM, MM, TL, TM) n_new = n_new + 1 new_cells(n_new)%Q(1) = q_lm new_cells(n_new)%Q(2) = q_mm @@ -912,7 +1043,7 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, new_cells(n_new)%D(4) = d_tm new_cells(n_new)%needs_refine = .FALSE. - ! Child 4: Top-Right quadrant (MM, RM, TM, TR) +c --- child 4: top-right quadrant (MM, RM, TM, TR) n_new = n_new + 1 new_cells(n_new)%Q(1) = q_mm new_cells(n_new)%Q(2) = q_rm @@ -928,42 +1059,48 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, END SUBROUTINE subdivide_cell_sub -! ============================================================ +c----------------------------------------------------------------------- +c flatten_cells_to_points_sub: extract unique (Q, D) points from +c the cell array into the module-level Q_store / D_store arrays. +c Uses a brute-force O(n^2) duplicate check which is acceptable +c for moderate cell counts; could be replaced by a hash set for +c very large scans. +c +c BUG FLAG 10 – n_total_corners could exceed MAX_PTS for large +c grids. No guard is present. +c----------------------------------------------------------------------- SUBROUTINE flatten_cells_to_points_sub(num_cells) - + IMPLICIT NONE - - INTEGER, INTENT(IN) :: num_cells - + +c --- arguments + INTEGER, INTENT(IN) :: num_cells ! number of cells to flatten +c --- locals INTEGER :: c, corner, i, j, idx - INTEGER :: n_total_corners - COMPLEX(r8), ALLOCATABLE :: temp_Q(:), temp_D(:) - LOGICAL, ALLOCATABLE :: is_unique(:) - REAL(r8) :: tol - + INTEGER :: n_total_corners ! = num_cells * 4 + COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! all corner Q-values + COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! all corner D-values + LOGICAL, ALLOCATABLE :: is_unique(:) ! dedup mask + REAL(r8) :: tol ! duplicate tolerance + tol = 1.0d-10 n_total_corners = num_cells * 4 - - WRITE(*,*) 'Flatten: num_cells =', num_cells - WRITE(*,*) 'Flatten: n_total_corners =', n_total_corners - + IF (num_cells <= 0) THEN WRITE(*,*) 'ERROR: No cells to flatten' n_pts = 0 RETURN END IF - - ! Allocate temporary arrays + +c --- gather all corners from cells ALLOCATE(temp_Q(n_total_corners)) ALLOCATE(temp_D(n_total_corners)) ALLOCATE(is_unique(n_total_corners)) - - ! Initialize + temp_Q = (0.0d0, 0.0d0) temp_D = (0.0d0, 0.0d0) is_unique = .TRUE. - - ! Gather all corners from cells + idx = 0 DO c = 1, num_cells DO corner = 1, 4 @@ -972,11 +1109,8 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) temp_D(idx) = amr_cells(c)%D(corner) END DO END DO - - WRITE(*,*) 'Gathered corners:', idx - - ! Mark duplicate points as non-unique - ! (Simple O(n²) approach - works fine for moderate sizes) + +c --- mark duplicates (O(n^2) pairwise comparison) DO i = 1, n_total_corners IF (.NOT. is_unique(i)) CYCLE DO j = i + 1, n_total_corners @@ -987,28 +1121,25 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) END IF END DO END DO - - ! Count unique points + +c --- count unique points n_pts = 0 DO i = 1, n_total_corners IF (is_unique(i)) n_pts = n_pts + 1 END DO - - WRITE(*,*) 'Unique points found:', n_pts - + IF (n_pts <= 0) THEN WRITE(*,*) 'ERROR: No unique points found' DEALLOCATE(temp_Q, temp_D, is_unique) RETURN END IF - - ! Allocate output arrays + +c --- copy unique points to module-level output arrays IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) IF (ALLOCATED(D_store)) DEALLOCATE(D_store) ALLOCATE(Q_store(n_pts)) ALLOCATE(D_store(n_pts)) - - ! Copy unique points to output + idx = 0 DO i = 1, n_total_corners IF (is_unique(i)) THEN @@ -1017,12 +1148,9 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) D_store(idx) = temp_D(i) END IF END DO - - WRITE(*,*) 'Copied to output:', idx - - ! Cleanup temporaries + DEALLOCATE(temp_Q, temp_D, is_unique) - + RETURN END SUBROUTINE flatten_cells_to_points_sub END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 7dabfbae8..c9756bce0 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -1,117 +1,161 @@ +c======================================================================= +c MODULE layerinputs_mod +c +c Reads STRIDE NetCDF output and constructs the per-surface +c input arrays required by the SLAYER layer-physics solver. +c +c Subprograms contained: +c 1. read_stride_netcdf_diagonal -- read STRIDE NetCDF, extract +c Deltaprime diagonal, geometry, and equilibrium scalars. +c 2. issurfint -- surface integral by simple +c quadrature (adapted from EQUIL). +c 3. build_inputs -- master driver: reads kinetic +c profiles, evaluates params(), and populates +c slayer_inputs_type for every rational surface. +c======================================================================= MODULE layerinputs_mod - USE inputs, ONLY : read_kin,read_equil,kin,chi1 - USE spline_mod, ONLY : spline_alloc,spline_eval,spline_type, - $ spline_dealloc,spline_int,spline_fit - USE sglobal_mod - USE params_mod - USE netcdf - USE equil_mod, ONLY: equil_read,rzphi,twopi,ro,zo,sq - USE bicube_mod, ONLY: bicube_eval_external,bicube_type - USE slayer_netcdf_mod + USE inputs, ONLY : read_kin, read_equil, kin, chi1 + USE spline_mod, ONLY : spline_alloc, spline_eval, spline_type, + $ spline_dealloc, spline_int, spline_fit + USE sglobal_mod ! SLAYER global scalars, types, constants + USE params_mod ! params() -- compute derived layer params + USE netcdf ! NetCDF Fortran bindings + USE equil_mod, ONLY : equil_read, rzphi, twopi, ro, zo, sq + USE bicube_mod, ONLY : bicube_eval_external, bicube_type + USE slayer_netcdf_mod ! sl_check(), SLAYER NetCDF output IMPLICIT NONE CONTAINS c----------------------------------------------------------------------- c subprogram 1. read_stride_netcdf_diagonal. -c Read STRIDE netcdf file for SLAYER inputs only. +c Read the STRIDE NetCDF file and extract the Deltaprime matrix, +c rational-surface geometry (q, psi_n, shear, dgeo, dr), and +c equilibrium scalars (R0, B_t0, psi0, m_psi, n, resm). +c +c BUG FLAG 1 -- NetCDF variable IDs (dp_id, qr_id, ...) are +c declared but never initialised via nf90_inq_varid before +c being passed to nf90_inquire_attribute. The attribute +c reads for ro, bt0, psio, mpsi, n use *_id variables that +c are still zero at that point; the calls appear to succeed +c only because the NetCDF library treats the id argument as +c a global-attribute flag when it is NF90_GLOBAL (=0). +c Suggested fix: either replace the id arguments with +c NF90_GLOBAL explicitly, or move the nf90_inq_varid calls +c above the nf90_inquire_attribute calls. c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) - ! Input/Output Arguments - CHARACTER(512), INTENT(IN) :: ncfile +c --- arguments (all INTENT(OUT) except ncfile) + CHARACTER(512), INTENT(IN) :: ncfile ! path to STRIDE NetCDF + INTEGER, INTENT(OUT) :: msing ! number of singular surfaces + REAL(r8), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT) :: dp_mat + ! Deltaprime matrix (msing x msing x 2) REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: - $ Re_dp_diagonal,Im_dp_diagonal - REAL(r8), DIMENSION(:,:,:), ALLOCATABLE, INTENT(OUT):: dp_mat - REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: q_rational, - $ psi_n_rational, shear,dgeo - REAL(r8), DIMENSION(:),ALLOCATABLE,INTENT(OUT) :: r_o,my_bt0, - $ my_psio,mpsi,dr_vals - INTEGER, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: nn,resm - INTEGER, INTENT(OUT) :: msing - - REAL(r8), DIMENSION(:), ALLOCATABLE :: msing_arr - - ! Internal Variables - INTEGER(kind=nf90_int) :: ncid, stat, r_dim_id, r_dim, - $ dp_id, qr_id,pr_id,dgeo_id,shear_id,ro_id,bt0_id,psio_id, - $ mpsi_id,msing_id,nn_id,resm_id,drr_id ! Explicit kind for NetCDF variables - INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! Explicit kind for NetCDF variables - INTEGER :: i - INTEGER :: bt0_len,ro_len,psio_len,mpsi_len, - $ msing_len,nn_len,dr_len ! Attribute lengths - - WRITE(*,*)"$^$ opening netcdf file",ncfile - - ! Open the NetCDF file - stat = nf90_open(path=ncfile,mode=NF90_WRITE,ncid=ncid) - CALL sl_check(stat) ! Error handling - - stat = nf90_inquire_attribute(ncid,msing_id,"msing", + $ Re_dp_diagonal, ! Re diag(Deltaprime) + $ Im_dp_diagonal ! Im diag(Deltaprime) + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: + $ q_rational, ! rational-surface q values + $ psi_n_rational, ! normalised psi at each surface + $ shear, ! magnetic shear + $ dgeo ! geometric delta (Shafranov shift) + REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: + $ r_o, ! major radius R0 + $ my_bt0, ! toroidal field B_t0 + $ my_psio, ! poloidal flux psi_0 + $ mpsi, ! poloidal mode number array + $ dr_vals ! radial width dr at each surface + INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: + $ nn, ! toroidal mode number(s) + $ resm ! resonant poloidal mode numbers + +c --- locals + REAL(r8), DIMENSION(:), ALLOCATABLE :: msing_arr ! temp for reading msing attribute + INTEGER(kind=nf90_int) :: ncid, stat ! NetCDF file id / return status + INTEGER(kind=nf90_int) :: r_dim_id, r_dim ! dimension id / length (unused) + INTEGER(kind=nf90_int) :: dp_id, qr_id, pr_id ! variable ids + INTEGER(kind=nf90_int) :: dgeo_id, shear_id ! variable ids + INTEGER(kind=nf90_int) :: ro_id, bt0_id, psio_id ! attribute ids (see BUG FLAG 1) + INTEGER(kind=nf90_int) :: mpsi_id, msing_id ! attribute ids + INTEGER(kind=nf90_int) :: nn_id, resm_id, drr_id ! variable / attribute ids + INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! NetCDF hyperslab + INTEGER :: i ! loop index + INTEGER :: bt0_len, ro_len, psio_len ! attribute lengths + INTEGER :: mpsi_len, msing_len, nn_len, dr_len ! attribute lengths + +c----------------------------------------------------------------------- +c open the STRIDE NetCDF file and read dimension / attribute data. +c----------------------------------------------------------------------- + WRITE(*,*) '$^$ opening netcdf file', ncfile + + stat = nf90_open(path=ncfile, mode=NF90_WRITE, ncid=ncid) + CALL sl_check(stat) + +c --- read msing (number of singular surfaces) from global attribute + stat = nf90_inquire_attribute(ncid, msing_id, 'msing', $ len = msing_len) CALL sl_check(stat) ALLOCATE(msing_arr(msing_len)) - stat = nf90_get_att(ncid,msing_id,"msing",msing_arr) + stat = nf90_get_att(ncid, msing_id, 'msing', msing_arr) CALL sl_check(stat) + msing = INT(msing_arr(1)) - msing=INT(msing_arr(1)) - - ! Allocate Arrays (based on dimension) - ALLOCATE(Re_dp_diagonal(msing),q_rational(msing), - $ psi_n_rational(msing),shear(msing),dgeo(msing), - $ resm(msing),Im_dp_diagonal(msing),dr_vals(msing)) - ALLOCATE(dp_mat(msing, msing,2)) +c --- allocate output arrays sized by msing + ALLOCATE(Re_dp_diagonal(msing), q_rational(msing), + $ psi_n_rational(msing), shear(msing), dgeo(msing), + $ resm(msing), Im_dp_diagonal(msing), dr_vals(msing)) + ALLOCATE(dp_mat(msing, msing, 2)) - stat = nf90_inquire_attribute(ncid,ro_id,"ro",len = ro_len) +c --- read lengths of scalar / small-array global attributes + stat = nf90_inquire_attribute(ncid, ro_id, 'ro', len=ro_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid,bt0_id,"bt0",len=bt0_len) + stat = nf90_inquire_attribute(ncid, bt0_id, 'bt0', len=bt0_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid,psio_id,"psio",len=psio_len) + stat = nf90_inquire_attribute(ncid, psio_id, 'psio', len=psio_len) CALL sl_check(stat) - - stat = nf90_inquire_attribute(ncid,mpsi_id,"mpsi",len=mpsi_len) + stat = nf90_inquire_attribute(ncid, mpsi_id, 'mpsi', len=mpsi_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid,nn_id,"n",len = nn_len) + stat = nf90_inquire_attribute(ncid, nn_id, 'n', len=nn_len) CALL sl_check(stat) - ALLOCATE(my_bt0(INT(bt0_len)),r_o(INT(ro_len)), + ALLOCATE(my_bt0(INT(bt0_len)), r_o(INT(ro_len)), $ my_psio(INT(psio_len)), - $ mpsi(INT(mpsi_len)),nn(INT(nn_len))) + $ mpsi(INT(mpsi_len)), nn(INT(nn_len))) - ! Get Variable IDs - stat = nf90_inq_varid(ncid, "Delta_prime", dp_id) +c --- obtain NetCDF variable IDs + stat = nf90_inq_varid(ncid, 'Delta_prime', dp_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "q_rational", qr_id) + stat = nf90_inq_varid(ncid, 'q_rational', qr_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "psi_n_rational", pr_id) + stat = nf90_inq_varid(ncid, 'psi_n_rational', pr_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "Delta_geo", dgeo_id) + stat = nf90_inq_varid(ncid, 'Delta_geo', dgeo_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "shear", shear_id) + stat = nf90_inq_varid(ncid, 'shear', shear_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "resm", resm_id) + stat = nf90_inq_varid(ncid, 'resm', resm_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, "dr_rational", drr_id) + stat = nf90_inq_varid(ncid, 'dr_rational', drr_id) CALL sl_check(stat) - ! Get attributes - stat = nf90_get_att(ncid, ro_id, "ro", r_o) + +c --- read global attributes (equilibrium scalars) + stat = nf90_get_att(ncid, ro_id, 'ro', r_o) CALL sl_check(stat) - stat = nf90_get_att(ncid, bt0_id, "bt0", my_bt0) + stat = nf90_get_att(ncid, bt0_id, 'bt0', my_bt0) CALL sl_check(stat) - stat = nf90_get_att(ncid, psio_id, "psio", my_psio) + stat = nf90_get_att(ncid, psio_id, 'psio', my_psio) CALL sl_check(stat) - stat = nf90_get_att(ncid, mpsi_id, "mpsi", mpsi) + stat = nf90_get_att(ncid, mpsi_id, 'mpsi', mpsi) CALL sl_check(stat) - stat = nf90_get_att(ncid, nn_id, "n", nn) + stat = nf90_get_att(ncid, nn_id, 'n', nn) CALL sl_check(stat) - ! Read the diagonal of delta prime. The results will be put on a 1D temporary array. - stat = nf90_get_var(ncid, dp_id, dp_mat,start=(/ 1,1,1 /)) +c --- read variable data: Deltaprime matrix and 1-D surface arrays + stat = nf90_get_var(ncid, dp_id, dp_mat, start=(/1,1,1/)) CALL sl_check(stat) - ! Read 1D variables stat = nf90_get_var(ncid, qr_id, q_rational) CALL sl_check(stat) stat = nf90_get_var(ncid, pr_id, psi_n_rational) @@ -125,97 +169,139 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, stat = nf90_get_var(ncid, drr_id, dr_vals) CALL sl_check(stat) - ! Extract Diagonal, with 3rd index signifying REAL part +c --- extract diagonal of the complex Deltaprime matrix DO i = 1, msing Re_dp_diagonal(i) = dp_mat(i, i, 1) Im_dp_diagonal(i) = dp_mat(i, i, 2) END DO - ! Clean Up + +c --- close file stat = nf90_close(ncid) CALL sl_check(stat) END SUBROUTINE read_stride_netcdf_diagonal c----------------------------------------------------------------------- c subprogram 2. issurfint. -c surface integration by simple method. copied from EQUIL +c Surface integral by simple quadrature, adapted from EQUIL. +c Computes int f(theta) * W(theta) d(theta) where W depends +c on the weight flag `wegt`: +c 0 = jac * |grad psi| +c 1 = R * jac * |grad psi| (R-weighted) +c 2 = jac * |grad psi| / R (1/R-weighted) +c 3 = a * jac * |grad psi| (minor-radius weighted) +c If ave==1, the result is divided by the unweighted surface area. +c +c Geometry is cached via first/fsave/psave to avoid recomputing +c Jacobians when the same surface is queried repeatedly. +c +c BUG FLAG 2 -- `first = .FALSE.` is commented out (line after +c `fsave = fs`). The caching logic therefore never sets +c first=.FALSE., so geometry is recomputed on every call +c even when psi and fs are unchanged. Uncomment the line +c or remove the caching branch entirely. +c +c BUG FLAG 3 -- `z` (toroidal-Z coordinate) is computed inside +c the geometry loop but never used outside it. Remove or +c document its intended purpose. c----------------------------------------------------------------------- FUNCTION issurfint(func,fs,inpsi,wegt,ave, $ fsave,psave,jacs,delpsi,inr,ina,first) c----------------------------------------------------------------------- -c declaration. +c declarations. c----------------------------------------------------------------------- - !IMPLICIT NONE - INTEGER, INTENT(IN) :: fs,wegt,ave - REAL(r8), INTENT(IN) :: inpsi - REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func - - LOGICAL, INTENT(INOUT) :: first - INTEGER, INTENT(INOUT) :: fsave - REAL(r8), INTENT(INOUT) :: psave - REAL(r8),DIMENSION(0:),INTENT(INOUT) :: jacs,delpsi,inr,ina - INTEGER :: itheta, ix, iy +c --- arguments + INTEGER, INTENT(IN) :: fs ! number of poloidal segments + INTEGER, INTENT(IN) :: wegt ! weight flag (0..3) + INTEGER, INTENT(IN) :: ave ! 1 = return surface average + REAL(r8), INTENT(IN) :: inpsi ! normalised psi of surface + REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func ! integrand array + + LOGICAL, INTENT(INOUT) :: first ! .TRUE. on first call (see BUG FLAG 2) + INTEGER, INTENT(INOUT) :: fsave ! cached fs + REAL(r8), INTENT(INOUT) :: psave ! cached psi + REAL(r8), DIMENSION(0:), INTENT(INOUT) :: jacs ! Jacobian cache + REAL(r8), DIMENSION(0:), INTENT(INOUT) :: delpsi ! |grad psi| cache + REAL(r8), DIMENSION(0:), INTENT(INOUT) :: inr ! R(theta) cache + REAL(r8), DIMENSION(0:), INTENT(INOUT) :: ina ! a(theta) cache +c --- return value REAL(r8) :: issurfint - REAL(r8) :: rfac,ineta,injac,inarea - REAL(r8), DIMENSION(1,2) :: w - REAL(r8), DIMENSION(0:fs) :: z,thetas - REAL(r8), dimension(4) :: rzphi_f, rzphi_fx, rzphi_fy - - issurfint=0 - inarea=0 +c --- locals + INTEGER :: itheta ! poloidal loop index + INTEGER :: ix, iy ! bicube grid hints + REAL(r8) :: rfac, ineta, injac, inarea ! geometry intermediates + REAL(r8), DIMENSION(1,2) :: w ! gradient components + REAL(r8), DIMENSION(0:fs) :: z ! Z coords (UNUSED -- BUG FLAG 3) + REAL(r8), DIMENSION(0:fs) :: thetas ! normalised theta grid + REAL(r8), DIMENSION(4) :: rzphi_f, rzphi_fx, rzphi_fy + ! bicube_eval_external outputs +c----------------------------------------------------------------------- +c compute / cache geometry if surface changed. +c [bicube_eval_external]: external bicubic interpolation from EQUIL. +c----------------------------------------------------------------------- + issurfint = 0 + inarea = 0 ix = 0 iy = 0 - IF(first .OR. inpsi/=psave .OR. fs/=fsave)THEN + + IF (first .OR. inpsi /= psave .OR. fs /= fsave) THEN psave = inpsi fsave = fs - !first = .FALSE. - DO itheta=0,fs - thetas(itheta) = REAL(itheta,r8)/REAL(fs,r8) + !first = .FALSE. ! BUG FLAG 2: should be uncommented + DO itheta = 0, fs + thetas(itheta) = REAL(itheta, r8) / REAL(fs, r8) ENDDO - DO itheta=0,fs-1 + DO itheta = 0, fs-1 CALL bicube_eval_external(rzphi, inpsi, thetas(itheta), 1, $ ix, iy, rzphi_f, rzphi_fx, rzphi_fy) - rfac=SQRT(rzphi_f(1)) - ineta=twopi*(thetas(itheta)+rzphi_f(2)) - ina(itheta)=rfac - inr(itheta)=ro+rfac*COS(ineta) - z(itheta)=zo+rfac*SIN(ineta) - injac=rzphi_f(4) - jacs(itheta)=injac - w(1,1)=(1+rzphi_fy(2))*twopi**2*rfac*inr(itheta)/injac - w(1,2)=-rzphi_fy(1)*pi*inr(itheta)/(rfac*injac) - delpsi(itheta)=SQRT(w(1,1)**2+w(1,2)**2) + rfac = SQRT(rzphi_f(1)) + ineta = twopi * (thetas(itheta) + rzphi_f(2)) + ina(itheta) = rfac + inr(itheta) = ro + rfac * COS(ineta) + z(itheta) = zo + rfac * SIN(ineta) + injac = rzphi_f(4) + jacs(itheta) = injac +c gradient magnitude: |grad psi| from metric components + w(1,1) = (1 + rzphi_fy(2)) * twopi**2 + $ * rfac * inr(itheta) / injac + w(1,2) = -rzphi_fy(1) * pi * inr(itheta) + $ / (rfac * injac) + delpsi(itheta) = SQRT(w(1,1)**2 + w(1,2)**2) ENDDO ENDIF - - IF (wegt==0) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ jacs(itheta)*delpsi(itheta)*func(itheta)/fs +c----------------------------------------------------------------------- +c perform weighted surface integral based on wegt flag. +c----------------------------------------------------------------------- + IF (wegt == 0) THEN + DO itheta = 0, fs-1 + issurfint = issurfint + $ + jacs(itheta)*delpsi(itheta)*func(itheta)/fs ENDDO - ELSE IF (wegt==1) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ELSE IF (wegt == 1) THEN + DO itheta = 0, fs-1 + issurfint = issurfint + $ + inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs ENDDO - ELSE IF (wegt==2) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs + ELSE IF (wegt == 2) THEN + DO itheta = 0, fs-1 + issurfint = issurfint + $ + jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs ENDDO - ELSE IF (wegt==3) THEN - DO itheta=0,fs-1 - issurfint=issurfint+ - $ ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + ELSE IF (wegt == 3) THEN + DO itheta = 0, fs-1 + issurfint = issurfint + $ + ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs ENDDO ELSE - STOP "ERROR: issurfint wegt must be in [0,1,2,3]" + STOP 'ERROR: issurfint wegt must be in [0,1,2,3]' ENDIF - - IF (ave==1) THEN - DO itheta=0,fs-1 - inarea=inarea+jacs(itheta)*delpsi(itheta)/fs +c----------------------------------------------------------------------- +c optionally normalise by unweighted surface area. +c----------------------------------------------------------------------- + IF (ave == 1) THEN + DO itheta = 0, fs-1 + inarea = inarea + jacs(itheta)*delpsi(itheta)/fs ENDDO - issurfint=issurfint/inarea + issurfint = issurfint / inarea ENDIF c----------------------------------------------------------------------- c terminate. @@ -224,246 +310,273 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, END FUNCTION issurfint c----------------------------------------------------------------------- c subprogram 3. build_inputs. -c build input arrays for SLAYER +c Master driver: reads the STRIDE NetCDF file, sets up kinetic +c profiles from the input file, reads the equilibrium, and then +c loops over every singular surface to compute derived layer +c parameters via params() and populate slayer_inputs_type. +c +c BUG FLAG 4 -- many local scalars declared here (lpsi, rpsi, +c hdist, sbnosurf, spl, sr, my_inpe, tau_i, b_l, v_a, tau_h, +c rho, tau_v, Qconv, lbeta, qintb, tau_ee_num..chi_par, +c psitor, rhotor, my_rhotor, my_psitor, rfac, jac, wit) +c are never used. They appear to be left over from an earlier +c version. Remove to reduce confusion. +c +c BUG FLAG 5 -- `ising` is declared REAL(r8) but is used as a +c DO-loop index (integer context). This works in Fortran but +c is non-standard in F90+ and may fail with strict compilers. +c Declare as INTEGER. +c +c BUG FLAG 6 -- `zeff = 2.0` is hardcoded on every surface +c (the kin%f(9) alternative is commented out). If the +c kinetic file provides Z_eff, this should use it. +c +c BUG FLAG 7 -- `mrs` and `nrs` are assigned +c `real(mms,4)` / `real(nns,4)` (single precision) but are +c declared INTEGER, so the float is silently truncated. +c They are also never used afterwards. Remove or fix. +c +c BUG FLAG 8 -- the local arrays ne_arr, te_arr, ... mu_i_arr, +c nns_arr, dr_arr, omegas_e_arr, omegas_i_arr are populated +c inside the loop but never used outside it (the old +c slayer_netcdf_inputs call is commented out). Remove or +c gate behind a diagnostic flag. c----------------------------------------------------------------------- SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- - ! Inputs - CHARACTER(512), INTENT(IN) :: infile,ncfile +c --- arguments + CHARACTER(512), INTENT(IN) :: infile ! kinetic input file path + CHARACTER(512), INTENT(IN) :: ncfile ! STRIDE NetCDF file path TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in - ! Internals - LOGICAL :: firstsurf - REAL(r8) :: respsi,lpsi,rpsi,hdist,sbnosurf,ising - INTEGER :: zi, zimp, mi, mimp - REAL(r8) :: nfac,tfac,wefac,wpfac,e - +c --- surface-loop control + LOGICAL :: firstsurf ! first-call flag for issurfint + REAL(r8) :: respsi ! normalised psi at current surface + REAL(r8) :: ising ! loop index (BUG FLAG 5: should be INTEGER) +c --- unused scalars (BUG FLAG 4 -- remove) + REAL(r8) :: lpsi, rpsi, hdist, sbnosurf +c --- kinetic profile parameters (for read_kin) + INTEGER :: zi, zimp, mi, mimp ! charge/mass species ids + REAL(r8) :: nfac, tfac, wefac, wpfac ! profile scale factors + REAL(r8) :: e ! elementary charge [C] +c --- unused spline temporaries (BUG FLAG 4) TYPE(spline_type) :: spl TYPE(spline_type) :: sr - - INTEGER :: mms,nns,mrs,nrs,mpsi - - REAL(r8) :: n_e,t_e,n_i,t_i,omega,omega_e,omega_i, - $ my_qval,my_sval,my_bt,my_rs,my_inpe,zeff,R_0,dgeo_val - REAL(r8) :: mu_i,tau_i,b_l,v_a,tau_h,l_n,l_t, - $ rho,tau_v,Qconv,lbeta,qintb,gammafac - REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, - $ sigma_par_2,sigma_par,tau_perp,Wd,vte, - $ dr_val,chi_par_smfp,chi_par_lmfp,chi_par - REAL(r8), DIMENSION(3) :: chi_s - INTEGER :: wit - +c --- mode number workspace + INTEGER :: mms, nns ! poloidal / toroidal mode nums + INTEGER :: mrs, nrs ! UNUSED, wrongly typed (BUG FLAG 7) + INTEGER :: mpsi ! poloidal-flux index from attr +c --- local plasma quantities at current surface + REAL(r8) :: n_e, t_e, n_i, t_i ! densities [m^-3], temperatures [eV] + REAL(r8) :: omega, omega_e, omega_i ! toroidal & diamagnetic freqs [rad/s] + REAL(r8) :: my_qval, my_sval ! safety factor, magnetic shear + REAL(r8) :: my_bt, my_rs, R_0 ! toroidal field, minor radius, major radius + REAL(r8) :: my_inpe ! UNUSED (BUG FLAG 4) + REAL(r8) :: zeff ! effective charge (hardcoded -- BUG FLAG 6) + REAL(r8) :: dgeo_val ! geometric delta (Shafranov) + REAL(r8) :: mu_i ! ion mass ratio to proton + REAL(r8) :: dr_val ! radial width dr at surface + REAL(r8) :: l_n, l_t ! density / temperature gradient lengths + REAL(r8) :: gammafac ! growth-rate conversion factor + REAL(r8), DIMENSION(3) :: chi_s ! chi_perp, chi_tor, kappa +c --- unused derived quantities (BUG FLAG 4 -- left over from params duplication) + REAL(r8) :: tau_i, b_l, v_a, tau_h, rho, tau_v + REAL(r8) :: Qconv, lbeta, qintb + REAL(r8) :: tau_ee_num, tau_ee_denom, tau_ee + REAL(r8) :: sigma_par_1, sigma_par_2, sigma_par + REAL(r8) :: tau_perp, Wd, vte + REAL(r8) :: chi_par_smfp, chi_par_lmfp, chi_par + INTEGER :: wit +c --- unused flux-coordinate arrays (BUG FLAG 4) REAL(r8), DIMENSION(0:128) :: psitor, rhotor - REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor,my_psitor + REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor, my_psitor +c --- STRIDE data (from read_stride_netcdf_diagonal) REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: dp_mat - REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal,dr_arr, - $ q_rational,shear,r_o,my_bt0,my_psio,mpsi_arr, - $ omegas_e_arr,omegas_i_arr,Im_dp_diagonal,dr_vals, - $ psi_n_rational,dgeo - REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr,te_arr,ni_arr, - $ ti_arr,zeff_arr,bt_arr,rs_arr,R0_arr,mu_i_arr - INTEGER,DIMENSION(:),ALLOCATABLE :: nn,resm,nns_arr - INTEGER :: msing,i,mthsurf - REAL(r8), DIMENSION(0:512) :: unitfun - INTEGER :: fsave - REAL(r8) :: psave - REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs,delpsi,rsurf,asurf - REAL(r8) :: rfac,jac,a_surf -c----------------------------------------------------------------------- -c Read in STRIDE netcdf + REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, + $ Im_dp_diagonal, q_rational, psi_n_rational, + $ shear, dgeo, r_o, my_bt0, my_psio, mpsi_arr, + $ dr_vals, dr_arr +c --- local per-surface kinetic arrays (UNUSED outside loop -- BUG FLAG 8) + REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr, te_arr, + $ ni_arr, ti_arr, zeff_arr, bt_arr, rs_arr, R0_arr, + $ mu_i_arr, omegas_e_arr, omegas_i_arr + INTEGER, DIMENSION(:), ALLOCATABLE :: nn, resm, nns_arr +c --- surface-integral workspace + INTEGER :: msing, i, mthsurf ! surface count, loop idx, theta pts + REAL(r8), DIMENSION(0:512) :: unitfun ! unit function for area integral + INTEGER :: fsave ! cached fs for issurfint + REAL(r8) :: psave ! cached psi for issurfint + REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs, delpsi, rsurf, asurf + REAL(r8) :: rfac, jac, a_surf ! rfac/jac UNUSED (BUG FLAG 4) +c----------------------------------------------------------------------- +c read STRIDE NetCDF: Deltaprime matrix, geometry, equilibrium scalars. c----------------------------------------------------------------------- - CALL read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational, $ psi_n_rational,dgeo,shear,r_o,my_bt0,my_psio,dr_vals, $ mpsi_arr,nn,resm) - WRITE(*,*)"msing_out=",msing - WRITE(*,*)"Re_dp_diagonal=",Re_dp_diagonal - WRITE(*,*)"Im_dp_diagonal=",Im_dp_diagonal - WRITE(*,*)"q_rational=",q_rational - WRITE(*,*)"psi_n_rational=",psi_n_rational - WRITE(*,*)"dgeo=",dgeo - WRITE(*,*)"shear=",shear - WRITE(*,*)"r_o=",r_o - WRITE(*,*)"my_bt0=",my_bt0 - WRITE(*,*)"my_psio=",my_psio - WRITE(*,*)"nn=",nn - WRITE(*,*)"resm=",resm mpsi = INT(mpsi_arr(1)) - mthsurf = 512 ! Hardcoded, but this is a default value + mthsurf = 512 ! poloidal segments for surface integral -c Allocate SLAYER input type arrays - ALLOCATE(sl_in%qval_arr(msing),sl_in%omegas_arr(msing), - $ sl_in%omegas_e_arr(msing),sl_in%dp_matrix(msing,msing), - $ sl_in%omegas_i_arr(msing),!sl_in%chi_prof_arr(msing), - $ sl_in%Q_e_arr(msing),sl_in%Q_i_arr(msing), +c --- allocate slayer_inputs_type arrays (one entry per surface) + ALLOCATE(sl_in%qval_arr(msing), sl_in%omegas_arr(msing), + $ sl_in%omegas_e_arr(msing), sl_in%dp_matrix(msing,msing), + $ sl_in%omegas_i_arr(msing), + $ sl_in%Q_e_arr(msing), sl_in%Q_i_arr(msing), $ sl_in%psi_n_arr(msing), - $ sl_in%Re_dp_arr(msing),sl_in%Im_dp_arr(msing), - $ sl_in%d_crit_arr(msing),sl_in%P_tor_arr(msing), - $ sl_in%P_perp_arr(msing),sl_in%tau_arr(msing), + $ sl_in%Re_dp_arr(msing), sl_in%Im_dp_arr(msing), + $ sl_in%d_crit_arr(msing), sl_in%P_tor_arr(msing), + $ sl_in%P_perp_arr(msing), sl_in%tau_arr(msing), $ sl_in%D_norm_arr(msing), - $ sl_in%d_beta_arr(msing),sl_in%gammafac_arr(msing), - $ sl_in%c_beta_arr(msing),sl_in%lu_arr(msing), + $ sl_in%d_beta_arr(msing), sl_in%gammafac_arr(msing), + $ sl_in%c_beta_arr(msing), sl_in%lu_arr(msing), $ sl_in%Qconv_arr(msing)) -c Allocate local kinetic arrays - ALLOCATE(ne_arr(msing),te_arr(msing),ni_arr(msing), - $ ti_arr(msing),zeff_arr(msing),bt_arr(msing),rs_arr(msing), - $ R0_arr(msing),mu_i_arr(msing),nns_arr(msing),dr_arr(msing), - $ omegas_e_arr(msing),omegas_i_arr(msing)) +c --- allocate local kinetic arrays (diagnostic, BUG FLAG 8) + ALLOCATE(ne_arr(msing), te_arr(msing), ni_arr(msing), + $ ti_arr(msing), zeff_arr(msing), bt_arr(msing), + $ rs_arr(msing), R0_arr(msing), mu_i_arr(msing), + $ nns_arr(msing), dr_arr(msing), + $ omegas_e_arr(msing), omegas_i_arr(msing)) - ALLOCATE(jacs(0:mthsurf),delpsi(0:mthsurf), - $ rsurf(0:mthsurf),asurf(0:mthsurf)) + ALLOCATE(jacs(0:mthsurf), delpsi(0:mthsurf), + $ rsurf(0:mthsurf), asurf(0:mthsurf)) c----------------------------------------------------------------------- -c set up kin +c set up kinetic profiles and equilibrium. +c [read_kin]: external, reads kinetic input file into kin spline. +c [equil_read]: external, reads equilibrium into EQUIL module. c----------------------------------------------------------------------- - ! manually set the kinetic profiles - zi = 1 - zimp = 6 - mi = 2 - mimp = 12 - nfac = 1.0 - tfac = 1.0 + zi = 1 ! main-ion charge + zimp = 6 ! impurity charge (carbon) + mi = 2 ! main-ion mass (deuterium) + mimp = 12 ! impurity mass + nfac = 1.0 + tfac = 1.0 wefac = 1.0 wpfac = 1.0 - e=1.6021917e-19 - chi1 = twopi*my_psio(1) + e = 1.6021917e-19 ! elementary charge [C] + chi1 = twopi * my_psio(1) ! total poloidal flux (module-level) CALL read_kin(infile,zi,zimp,mi,mimp,nfac, $ tfac,wefac,wpfac,.false.) CALL equil_read(out_unit) - ! Input Delta' matrix - sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1),dp_mat(:,:,2)) +c store full complex Deltaprime matrix in sl_in + sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1), dp_mat(:,:,2)) c----------------------------------------------------------------------- -c loop across singular surfaces, evaluate spline quantities. +c loop over singular surfaces: evaluate kinetic/equilibrium +c quantities via spline interpolation, compute derived layer +c parameters via params(), and populate sl_in arrays. c----------------------------------------------------------------------- - DO ising=1,msing - - respsi = psi_n_rational(ising) + DO ising = 1, msing + respsi = psi_n_rational(ising) ! normalised psi firstsurf = .TRUE. unitfun = 1 - ! Minor radius! +c compute flux-surface-averaged minor radius a_surf = issurfint(unitfun,mthsurf,respsi,3,1, $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) c----------------------------------------------------------------------- -c SLAYER inputs for sing surface +c evaluate kinetic splines at this surface. +c [spline_eval]: external, evaluates kin spline at respsi. +c kin%f(1..5) = n_i, n_e, t_i, t_e, omega (SI units) +c kin%f1(1..5) = d/d(psi_n) of the above c----------------------------------------------------------------------- CALL spline_eval(kin,respsi,1) - omega_i=-twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) - $ -twopi*kin%f1(3)/(e*zi*chi1) - omega_e=twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) - $ +twopi*kin%f1(4)/(e*chi1) +c diamagnetic frequencies (rad/s) + omega_i = -twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) + $ -twopi*kin%f1(3)/(e*zi*chi1) + omega_e = twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) + $ +twopi*kin%f1(4)/(e*chi1) sl_in%omegas_e_arr(ising) = omega_e sl_in%omegas_i_arr(ising) = omega_i +c extract local plasma quantities from spline n_e = kin%f(2) - t_e = kin%f(4)/e + t_e = kin%f(4) / e ! convert J -> eV n_i = kin%f(1) - t_i = kin%f(3)/e + t_i = kin%f(3) / e - zeff = 2.0!kin%f(9) - - omega = kin%f(5) - my_qval = q_rational(ising)!sq%f(4) - my_sval = shear(ising) + zeff = 2.0 ! hardcoded (BUG FLAG 6) + + omega = kin%f(5) + my_qval = q_rational(ising) + my_sval = shear(ising) dgeo_val = dgeo(ising) - my_bt = my_bt0(1) - my_rs = a_surf - R_0 = r_o(1) - mu_i = 2.0 - dr_val = dr_vals(ising) - + my_bt = my_bt0(1) + my_rs = a_surf + R_0 = r_o(1) + mu_i = 2.0 ! deuterium + dr_val = dr_vals(ising) + +c transport coefficients from caller-provided arrays chi_s(1) = sl_in%chi_p_arr(ising) ! chi_perp chi_s(2) = sl_in%chi_t_arr(ising) ! chi_tor chi_s(3) = sl_in%kappa_arr(ising) ! kappa (thermal cond.) - ne_arr(ising) = n_e - te_arr(ising) = t_e - ni_arr(ising) = n_i - ti_arr(ising) = t_i +c store local kinetic arrays (BUG FLAG 8: unused) + ne_arr(ising) = n_e + te_arr(ising) = t_e + ni_arr(ising) = n_i + ti_arr(ising) = t_i zeff_arr(ising) = zeff - bt_arr(ising) = my_bt - rs_arr(ising) = my_rs - R0_arr(ising) = R_0 + bt_arr(ising) = my_bt + rs_arr(ising) = my_rs + R0_arr(ising) = R_0 mu_i_arr(ising) = mu_i mms = resm(ising) nns = nn(1) - mrs = real(mms,4) - nrs = real(nns,4) - + mrs = real(mms, 4) ! BUG FLAG 7: float -> integer truncation + nrs = real(nns, 4) nns_arr(ising) = nn(1) - nr = nn(1) + nr = nn(1) ! module-level toroidal mode number l_n = 0.0 l_t = 0.0 - WRITE(*,*)"$^$ calling params()" +c----------------------------------------------------------------------- +c compute derived layer parameters. +c [params]: external (params_mod), sets module-level globals +c tau, tau_r, tauk, lu, c_beta, d_beta, D_norm, P_perp, +c P_tor, dc_tmp, etc. in sglobal_mod. +c----------------------------------------------------------------------- CALL params(n_e,t_e,t_i,omega,chi_s,dr_val,dgeo_val, - $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i,zeff,.false.) - -!!!!!!!!!!! - gammafac = (my_rs*Re_dp_diagonal(ising))/tau_r ! scalar to convert thickness into growth rate - - sl_in%qval_arr(ising) = INT(my_qval) - sl_in%lu_arr(ising)=lu - sl_in%Q_e_arr(ising)=-tauk*omega_e ! skipping params() calculation - sl_in%Q_i_arr(ising)=-tauk*omega_i ! skipping params() calculation - sl_in%c_beta_arr(ising)=c_beta - sl_in%d_beta_arr(ising)=d_beta - sl_in%D_norm_arr(ising)=D_norm - sl_in%tau_arr(ising)=tau - sl_in%omegas_arr(ising) = omega - sl_in%psi_n_arr(ising) = respsi - sl_in%gammafac_arr(ising) = gammafac - sl_in%Re_dp_arr(ising) = Re_dp_diagonal(ising) - sl_in%Im_dp_arr(ising) = Im_dp_diagonal(ising) - sl_in%d_crit_arr(ising) = dc_tmp - sl_in%P_perp_arr(ising) = P_perp - sl_in%P_tor_arr(ising) = P_tor - sl_in%Qconv_arr(ising) = tauk - ENDDO + $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i, + $ zeff,.false.) + +c growth-rate conversion factor: Deltaprime -> gamma + gammafac = (my_rs * Re_dp_diagonal(ising)) / tau_r - !WRITE(*,*)"msing=",msing - !WRITE(*,*)"qval_arr=",qval_arr - !WRITE(*,*)"ne_arr=",ne_arr - !WRITE(*,*)"te_arr=",te_arr - !WRITE(*,*)"ni_arr=",ni_arr - !WRITE(*,*)"ti_arr=",ti_arr - !WRITE(*,*)"zeff_arr=",zeff_arr - !WRITE(*,*)"shear=",shear - !WRITE(*,*)"bt_arr=",bt_arr - !WRITE(*,*)"rs_arr=",rs_arr - !WRITE(*,*)"R0_arr=",R0_arr - !WRITE(*,*)"resm=",resm - !WRITE(*,*)"nns_arr=",nns_arr - !WRITE(*,*)"inc_beta_arr=",inc_beta_arr - !WRITE(*,*)"inds_arr=",inds_arr - !WRITE(*,*)"intau_arr=",intau_arr - !WRITE(*,*)"inpr_arr=",inpr_arr - !WRITE(*,*)"inpe_arr=",inpe_arr - !WRITE(*,*)"omegas_arr=",omegas_arr - !WRITE(*,*)"omegas_e_arr=",omegas_e_arr - !WRITE(*,*)"omegas_i_arr=",omegas_i_arr - !WRITE(*,*)"Re_deltaprime_arr=",Re_deltaprime_arr - !WRITE(*,*)"Im_deltaprime_arr=",Im_deltaprime_arr - !stop - !CALL slayer_netcdf_inputs(msing,qval_arr,ne_arr,te_arr,ni_arr, - !$ ti_arr,zeff_arr,shear,bt_arr,rs_arr,R0_arr, - !$ resm,nns_arr,inc_beta_arr,inds_arr, - !$ intau_arr,inpr_arr,inpe_arr,inQ_arr,omegas_arr, - !$ omegas_e_arr,omegas_i_arr, - !$ Re_deltaprime_arr,Im_deltaprime_arr) +c----------------------------------------------------------------------- +c populate sl_in for this surface from params() globals. +c----------------------------------------------------------------------- + sl_in%qval_arr(ising) = INT(my_qval) + sl_in%lu_arr(ising) = lu + sl_in%Q_e_arr(ising) = -tauk * omega_e + sl_in%Q_i_arr(ising) = -tauk * omega_i + sl_in%c_beta_arr(ising) = c_beta + sl_in%d_beta_arr(ising) = d_beta + sl_in%D_norm_arr(ising) = D_norm + sl_in%tau_arr(ising) = tau + sl_in%omegas_arr(ising) = omega + sl_in%psi_n_arr(ising) = respsi + sl_in%gammafac_arr(ising)= gammafac + sl_in%Re_dp_arr(ising) = Re_dp_diagonal(ising) + sl_in%Im_dp_arr(ising) = Im_dp_diagonal(ising) + sl_in%d_crit_arr(ising) = dc_tmp + sl_in%P_perp_arr(ising) = P_perp + sl_in%P_tor_arr(ising) = P_tor + sl_in%Qconv_arr(ising) = tauk + ENDDO c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- diff --git a/slayer/params.f b/slayer/params.f index dcf069788..c68e0032e 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -1,172 +1,264 @@ +c======================================================================= +c MODULE params_mod +c +c Computes the normalised layer-physics parameters needed by the +c SLAYER dispersion solver from dimensional equilibrium and +c kinetic-profile inputs. +c +c Subprograms contained: +c 1. params -- derive all normalised quantities (Q, ds, c_beta, +c D_norm, P_perp, P_tor, lu, delta_crit, ...) for a +c single rational surface and store them in sglobal_mod. +c======================================================================= MODULE params_mod - USE sglobal_mod + USE sglobal_mod ! SLAYER global scalars, types, constants IMPLICIT NONE CONTAINS c----------------------------------------------------------------------- -c calculate parameters. +c subprogram 1. params. +c Compute all derived layer-physics parameters for a single +c rational surface from dimensional equilibrium / kinetic inputs. +c Results are written to module-level variables in sglobal_mod +c (tau, tau_r, tauk, lu, Q, Q_e, Q_i, ds, c_beta, d_beta, +c D_norm, P_perp, P_tor, delta_n, dc_tmp, eta, visc, rho_s, ...). +c +c BUG FLAG 1 -- `pr` (magnetic Prandtl number) and `pe` are read +c from sglobal_mod but never set within this routine. They must +c be initialised elsewhere before calling params(), otherwise +c `tau_v = tau_r / pr` will divide by zero or garbage. +c Suggested fix: add pr/pe as INTENT(IN) arguments, or +c document the required initialisation order. +c +c BUG FLAG 2 -- Several debug WRITE statements print to stdout +c unconditionally on every call. For a public release these +c should either be removed or guarded behind `params_check`. c----------------------------------------------------------------------- SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - REAL(r8), INTENT(IN) :: n_e,t_e,t_i,omega,dr_val,dgeo_val, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff +c --- arguments + REAL(r8), INTENT(IN) :: n_e ! electron density [m^-3] + REAL(r8), INTENT(IN) :: t_e ! electron temperature [eV] + REAL(r8), INTENT(IN) :: t_i ! ion temperature [eV] + REAL(r8), INTENT(IN) :: omega ! toroidal rotation [rad/s] + REAL(r8), INTENT(IN) :: dr_val ! radial width dr at surface + REAL(r8), INTENT(IN) :: dgeo_val ! geometric delta (Shafranov shift factor) + REAL(r8), INTENT(IN) :: l_n ! density gradient length + REAL(r8), INTENT(IN) :: l_t ! temperature gradient length + REAL(r8), INTENT(IN) :: qval ! safety factor + REAL(r8), INTENT(IN) :: sval ! magnetic shear + REAL(r8), INTENT(IN) :: bt ! toroidal field [T] + REAL(r8), INTENT(IN) :: rs ! minor radius [m] + REAL(r8), INTENT(IN) :: R0 ! major radius [m] + REAL(r8), INTENT(IN) :: mu_i ! ion mass ratio to proton + REAL(r8), INTENT(IN) :: zeff ! effective charge REAL(r8), DIMENSION(3), INTENT(IN) :: chis + ! (1) chi_perp [m^2/s] + ! (2) chi_tor [m^2/s] + ! (3) kappa [m^2/s] + LOGICAL, INTENT(IN) :: params_check ! .TRUE. = print diagnostics + +c --- local variables: basic plasma + REAL(r8) :: rho ! mass density [kg/m^3] + REAL(r8) :: b_l ! characteristic magnetic field [T] + REAL(r8) :: v_a ! Alfvén velocity [m/s] + REAL(r8) :: lbeta ! local beta-related quantity +c --- local variables: electron collision time (Braginskii) + REAL(r8) :: tau_ee_num ! numerator of tau_ee formula + REAL(r8) :: tau_ee_denom ! denominator of tau_ee formula + REAL(r8) :: tau_ee ! electron-electron collision time [s] +c --- local variables: parallel conductivity (Spitzer-Härm) + REAL(r8) :: sigma_par_1 ! neoclassical correction factor + REAL(r8) :: sigma_par_2 ! classical conductivity [1/(Ohm*m)] + REAL(r8) :: sigma_par ! parallel conductivity [1/(Ohm*m)] +c --- local variables: timescales + REAL(r8) :: tau_i ! ion collision time [s] + REAL(r8) :: tau_h ! Alfvén transit time [s] + REAL(r8) :: tau_v ! viscous time [s] + REAL(r8) :: tau_tor ! toroidal diffusion time [s] + REAL(r8) :: tau_perp ! perp. diffusion time [s] +c --- local variables: delta_crit iteration + REAL(r8) :: vte ! thermal electron speed [m/s] + REAL(r8) :: chi_par_smfp ! chi_par in short mfp limit + REAL(r8) :: chi_par_lmfp ! chi_par in long mfp limit + REAL(r8) :: chi_par ! effective parallel thermal cond. + REAL(r8) :: Wd ! magnetic island width proxy + INTEGER :: wit ! iteration counter +c --- local variables: unused intermediates + REAL(r8) :: Qconv ! (shadowed by module-level Qconv) + REAL(r8) :: K_val, Csq ! kappa/eta and composite quantity - LOGICAL, INTENT(IN) :: params_check - - REAL(r8) :: rho,b_l,v_a,Qconv,K_val,Csq,tau_tor, - $ lbeta,tau_i,tau_h,tau_v - REAL(r8) :: tau_ee_num,tau_ee_denom,tau_ee,sigma_par_1, - $ sigma_par_2,sigma_par,tau_perp,Wd,vte, - $ chi_par_smfp,chi_par_lmfp,chi_par - INTEGER :: wit - - WRITE(*,*)"params.f n_e: ",n_e - WRITE(*,*)"params.f t_e: ",t_e - WRITE(*,*)"params.f t_i: ",t_i - +c----------------------------------------------------------------------- +c Coulomb logarithm, basic plasma quantities, and Spitzer +c resistivity. +c----------------------------------------------------------------------- lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) - ! mu_i: ion mass ratio to proton - tau= t_i/t_e ! ratio of ion to electron temperature - tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5/(n_e*lnLamb) ! ion colls. - eta= 1.65e-9*lnLamb/(t_e/1e3)**1.5 ! spitzer resistivity (wesson) - rho=(mu_i*m_p)*n_e ! mass density + tau = t_i / t_e ! T_i / T_e + tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5 + $ / (n_e*lnLamb) ! ion collision time [s] + eta = 1.65e-9*lnLamb / (t_e/1e3)**1.5 ! Spitzer resistivity (Wesson) + rho = (mu_i*m_p)*n_e ! mass density [kg/m^3] - tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5)* - $ (eps0**2.0)*(m_e**0.5)*(t_e**1.5) +c----------------------------------------------------------------------- +c Electron-electron collision time (Braginskii) and Spitzer-Härm +c parallel conductivity. +c----------------------------------------------------------------------- + tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5) + $ *(eps0**2.0)*(m_e**0.5)*(t_e**1.5) tau_ee_denom = lnLamb*(chag**2.5)*n_e - tau_ee = tau_ee_num / tau_ee_denom - !tau_ee = 1.09e16 * (t_e/1.0e3)**1.5 / (n_e * lnLamb) - + tau_ee = tau_ee_num / tau_ee_denom - sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) / - $ (Zeff*(SQRT(2.0) + Zeff)) + sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) + $ / (Zeff*(SQRT(2.0) + Zeff)) sigma_par_2 = (n_e * (chag**2.0) * tau_ee) / m_e - sigma_par = sigma_par_1*sigma_par_2 + sigma_par = sigma_par_1 * sigma_par_2 - b_l=(nr/mr)*rs*sval*bt/R0 ! characteristic magnetic field - v_a=b_l/(mu0*rho)**0.5 ! alfven velocity - rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Lamour by elec. Temp. - d_i = ( (mu_i*m_p)/(n_e * (chag**2) * mu0) )**0.5 ! collisionless ion skin depth +c----------------------------------------------------------------------- +c Characteristic field, Alfvén speed, length scales, and +c fundamental timescales. +c Note: mr, nr (rational m/n) and nn (toroidal mode number) are +c module-level variables set before calling params(). +c----------------------------------------------------------------------- + b_l = (nr/mr)*rs*sval*bt/R0 ! characteristic B [T] + v_a = b_l / (mu0*rho)**0.5 ! Alfvén velocity [m/s] + rho_s = 1.02e-4*(mu_i*t_e)**0.5 / bt ! ion Larmor at T_e [m] + d_i = ( (mu_i*m_p) / (n_e*(chag**2)*mu0) )**0.5 + ! ion skin depth [m] - tau_h=R0*(mu0*rho)**0.5/(nn*sval*bt) ! alfven time across surface - !tau_r=mu0*rs**2.0/eta ! resistive time scale - tau_r=mu0*(rs**2.0)*(sigma_par) ! R. Fitzpatrick resistive time scale - tau_v=tau_r/pr !rho*rs**2.0/visc ! viscous time scale + tau_h = R0*(mu0*rho)**0.5 / (nn*sval*bt) ! Alfvén time [s] + tau_r = mu0*(rs**2.0)*sigma_par ! resistive time [s] (Fitzpatrick) + tau_v = tau_r / pr ! viscous time [s] (BUG FLAG 1) - ! this one must be anomalous. calculated back from pr. - visc= rho*rs**2.0/tau_v - - lu=tau_r/tau_h ! Lundquist number - - omega_e=-t_e/(bt*R0)*(1.0/l_n+1.0/l_t)*qval ! elec. diamag - omega_i=t_i/(bt*R0)*(1.0/l_n+1.0/l_t)*qval ! ion diamag +c back-compute anomalous viscosity from tau_v + visc = rho*rs**2.0 / tau_v - ! now calculate the main 7 normalized parameters. +c Lundquist number + lu = tau_r / tau_h + +c----------------------------------------------------------------------- +c Diamagnetic frequencies and normalised Q parameters. +c Qconv converts dimensional frequencies to the normalised Q +c used in the SLAYER dispersion relation (Cole scaling). +c----------------------------------------------------------------------- + omega_e = -t_e/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval ! electron diamagnetic [rad/s] + omega_i = t_i/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval ! ion diamagnetic [rad/s] - Qconv=lu**(1.0/3.0)*tau_h ! conversion to Qs based on Cole - tauk = Qconv + Qconv = lu**(1.0/3.0) * tau_h ! frequency normalisation (Cole) + tauk = Qconv ! stored in sglobal_mod - ! note Q depends on Qconv even if omega is fixed. - Q=Qconv*omega - Q_e=-Qconv*omega_e - Q_i=-Qconv*omega_i - - ! This is the most critical parameter - ds=lu**(1.0/3.0)*rho_s/rs ! conversion based on Cole. + Q = Qconv * omega ! normalised rotation frequency + Q_e = -Qconv * omega_e ! normalised electron diamagnetic + Q_i = -Qconv * omega_i ! normalised ion diamagnetic - lbeta=(5.0/3.0)*mu0*n_e*chag*(t_e+t_i)/bt**2.0 - c_beta=(lbeta/(1.0+lbeta))**0.5 +c normalised ion Larmor radius (critical stability parameter) + ds = lu**(1.0/3.0) * rho_s / rs - ! CALCULATE Ps - ! chi_tor = the anomalous perpendicular ion momentum diffusivity at the rational surface - ! chi_perp = the anomalous perpendicular energy diffusivity at the rational surface +c----------------------------------------------------------------------- +c Plasma beta and Prandtl-number-like transport ratios. +c +c BUG FLAG 3 -- The K_val/Csq block (kappa-based P_perp) is +c immediately overridden by the tau_perp definition below it, +c so K_val and the IF(ABS(Csq)>0) branch are dead code. +c Either remove the dead block or delete the override. +c----------------------------------------------------------------------- + lbeta = (5.0/3.0)*mu0*n_e*chag*(t_e+t_i) / bt**2.0 + c_beta = (lbeta / (1.0+lbeta))**0.5 - K_val = chis(3)/eta ! kappa/eta - Csq = (c_beta**2.0 + (1.0-c_beta**2.0)*K_val ) ! = P_perp +c --- dead code begin (BUG FLAG 3) --- + K_val = chis(3) / eta + Csq = c_beta**2.0 + (1.0 - c_beta**2.0)*K_val IF (ABS(Csq) > 0.0) THEN P_perp = Csq ELSE - tau_perp = ( rs**2.0 ) / chis(1) + tau_perp = (rs**2.0) / chis(1) END IF +c --- dead code end (BUG FLAG 3) --- - tau_perp = ( rs**2.0 ) / chis(1) - P_perp = tau_r / tau_perp ! perpendicular magnetic Prandtl number +c effective perpendicular and toroidal Prandtl numbers + tau_perp = (rs**2.0) / chis(1) + P_perp = tau_r / tau_perp ! perp magnetic Prandtl number - tau_tor = ( rs**2.0 ) / chis(2) - P_tor = tau_r / tau_tor ! toroidal magnetic Prandtl number + tau_tor = (rs**2.0) / chis(2) + P_tor = tau_r / tau_tor ! toroidal magnetic Prandtl number - ! this is using Fitzpatrick's tau', we need tau eventually - d_beta = c_beta*d_i - D_norm = (d_beta/rs)*(lu**(1.0/3.0))*(tau/(1+tau))**(0.5) +c----------------------------------------------------------------------- +c Normalised beta-related width and Delta norm factor. +c----------------------------------------------------------------------- +c d_beta uses Fitzpatrick's definition (tau' form) + d_beta = c_beta * d_i + D_norm = (d_beta/rs) * lu**(1.0/3.0) + $ * (tau/(1+tau))**(0.5) - delta_n=lu**(1.0/3.0)/rs ! norm factor for delta primes + delta_n = lu**(1.0/3.0) / rs ! normalisation for Delta values - ! Calculate Delta_crit +c----------------------------------------------------------------------- +c Critical Deltaprime (dc_tmp) via iterative chi_parallel calculation. +c The island-width Wd is iterated 10 times to converge the +c short-mfp / long-mfp interpolation for chi_parallel. +c dc_type (from sglobal_mod) selects the formula: +c 'lar' -- cylindrical (Lutjens) +c 'rfitzp' -- R. Fitzpatrick +c 'toroidal' -- toroidal geometry using dgeo_val +c default -- dc_tmp = 0 +c +c BUG FLAG 4 -- iteration count 10 is hardcoded with no +c convergence check. Consider adding a tolerance test. +c----------------------------------------------------------------------- IF (ABS(dr_val) > 0.0) THEN - vte = SQRT((2.0*(t_e*chag))/m_e) - chi_par_smfp = (1.581*tau_ee*(vte**2.0))/ - $ (1.0+0.2535*Zeff) - WRITE(*,*)"params.f Zeff: ",Zeff - - ! chis(1) = chi_perp - Wd = 0.1 - DO wit = 1,10 - - chi_par_lmfp = (2.0*R0*vte)/(SQRT(pi)*nr*sval*Wd) - chi_par = (chi_par_smfp*chi_par_lmfp)/ - $ (chi_par_smfp+chi_par_lmfp) - Wd = SQRT(8.0)*((chis(1)/chi_par)**0.25)* - $ (1.0/SQRT((rs/R0)*sval*nr)) - - END DO - WRITE(*,*)"params.f Wd: ",Wd - WRITE(*,*)"params.f chis(1): ",chis(1) - WRITE(*,*)"params.f chis(2): ",chis(2) - WRITE(*,*)"params.f chis(3): ",chis(3) - WRITE(*,*)"params.f rs: ",rs - WRITE(*,*)"params.f R0: ",R0 - WRITE(*,*)"params.f sval: ",sval - WRITE(*,*)"params.f nr: ",nr - - SELECT CASE(dc_type) - CASE("lar") - dc_tmp=0.5*(-dr_val)*(pi**1.5)*((chi_par/chis(1))**0.25)* - $ ( (nr*sval)/(R0*rs) )**0.5 - CASE("rfitzp") - dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val)/Wd - CASE("toroidal") - dc_tmp = 0.5*(-dr_val)*(pi**1.5)* - $ ((chi_par/chis(1))**0.25)*dgeo_val - CASE default - dc_tmp = 0.0 - END SELECT - - WRITE(*,*)"params.f dr_val: ",dr_val - WRITE(*,*)"params.f dgeo_val: ",dgeo_val - WRITE(*,*)"params.f dc_tmp: ",dc_tmp + + vte = SQRT((2.0*(t_e*chag)) / m_e) + chi_par_smfp = (1.581*tau_ee*(vte**2.0)) + $ / (1.0 + 0.2535*Zeff) + + Wd = 0.1 ! initial guess + DO wit = 1, 10 + chi_par_lmfp = (2.0*R0*vte) + $ / (SQRT(pi)*nr*sval*Wd) + chi_par = (chi_par_smfp*chi_par_lmfp) + $ / (chi_par_smfp + chi_par_lmfp) + Wd = SQRT(8.0)*((chis(1)/chi_par)**0.25) + $ * (1.0/SQRT((rs/R0)*sval*nr)) + END DO + + SELECT CASE(dc_type) + CASE('lar') + dc_tmp = 0.5*(-dr_val)*(pi**1.5) + $ *((chi_par/chis(1))**0.25) + $ *( (nr*sval)/(R0*rs) )**0.5 + CASE('rfitzp') + dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val) / Wd + CASE('toroidal') + dc_tmp = 0.5*(-dr_val)*(pi**1.5) + $ *((chi_par/chis(1))**0.25)*dgeo_val + CASE default + dc_tmp = 0.0 + END SELECT ELSE - dc_tmp = 0.0 + dc_tmp = 0.0 END IF - ! quick diagnostics. +c----------------------------------------------------------------------- +c optional diagnostics (guarded by params_check flag). +c----------------------------------------------------------------------- IF (params_check) THEN - WRITE(*,*)"eta=",eta - WRITE(*,*)"S=",lu - WRITE(*,*)"Q=",Q - WRITE(*,*)"Q_e=",Q_e - WRITE(*,*)"Q_i=",Q_i - WRITE(*,*)"ds=",ds - WRITE(*,*)"c_beta=",c_beta + WRITE(*,*) 'eta = ', eta + WRITE(*,*) 'S = ', lu + WRITE(*,*) 'Q = ', Q + WRITE(*,*) 'Q_e = ', Q_e + WRITE(*,*) 'Q_i = ', Q_i + WRITE(*,*) 'ds = ', ds + WRITE(*,*) 'c_beta = ', c_beta ENDIF - +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- RETURN - END SUBROUTINE params - + END SUBROUTINE params + END MODULE params_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 3711e695c..7c94683c9 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -1,77 +1,207 @@ +c======================================================================= +c MODULE sglobal_mod +c +c Global shared state for the SLAYER layer-physics package. +c Contains: +c - physical and mathematical constants +c - module-level scalar variables written by params() and +c consumed by the dispersion solvers (delta, slayer, gslayer) +c - AMR scanner storage (hash-based v1, cell-based v2) +c - derived types: slayer_inputs_type, slayer_outputs_type, +c deltas_outputs_type, result_type, amr_cell_type +c +c BUG FLAG 1 -- `pr` and `pe` (magnetic Prandtl number and its +c electron analogue) are declared but never explicitly set +c within this module or in params(). They must be initialised +c before params() is called (tau_v = tau_r / pr). Consider +c adding a dedicated init routine or making them INTENT(IN) +c arguments of params(). +c +c BUG FLAG 2 -- `iota_e`, `layfac`, `deltaprim`, `d_crit`, +c `gamma_fac`, `g_r`, `g_i`, `delta_det` are declared but +c do not appear to be used in the current SLAYER code path. +c Verify whether they are needed; if not, remove. +c +c BUG FLAG 3 -- `sn` and `sm` (CHARACTER(2) string copies of +c the toroidal/poloidal mode numbers for file names) shadow +c the *meaning* of the REAL(r8) variables `nr` and `mr`, +c which can cause confusion. Consider renaming the strings +c to `sn_str` / `sm_str`. +c======================================================================= MODULE sglobal_mod - USE local_mod, ONLY: r8 + + USE local_mod, ONLY: r8 ! double-precision kind parameter IMPLICIT NONE - INTEGER :: mm,nn - INTEGER :: in_unit,out_unit,out2_unit,out3_unit, - $ bin_unit,bin_2d_unit,input_unit,n_trace -c INTEGER, PARAMETER :: r8=SELECTED_REAL_KIND(13,307) - - REAL(r8) :: mr,nr - REAL(r8) :: Q_e,Q_i,pr,pe,c_beta,ds,tau,d_i, - $ d_beta,D_norm,P_perp,P_tor,gamma_fac - REAL(r8) :: eta,visc,rho_s,lu,omega_e,omega_i,iota_e, - $ delta_n,layfac,Qconv,lnLamb,deltaprim,dc_tmp, - $ d_crit,tau_r,tauk,g_r,g_i,delta_eff - COMPLEX(r8) :: Q,g_tmp,delta_det - CHARACTER(20) :: dc_type - - REAL(r8), PARAMETER :: pi=3.1415926535897932385, mu0=4e-7*pi, - $ m_e=9.1094e-31,m_p=1.6726e-27,chag=1.6021917e-19, - $ kval=1.3807e-23,eps0 = 8.8542e-12 - - INTEGER, PARAMETER :: MAX_PTS = 500000 ! Max unique points allowed - INTEGER, PARAMETER :: HASH_SZ = 500009 ! Prime number for hash table - REAL(r8), PARAMETER :: HASH_SCALE = 1.0d5 ! Scaling factor for integer hashing - INTEGER, ALLOCATABLE :: hash_head(:) ! Hash bucket heads - INTEGER, ALLOCATABLE :: hash_next(:) ! Linked list next pointers - - ! Replace hash-based storage with cell-based storage - INTEGER, PARAMETER :: MAX_CELLS = 500000 + +c----------------------------------------------------------------------- +c I/O unit numbers and trace control. +c----------------------------------------------------------------------- + INTEGER :: in_unit ! standard input unit + INTEGER :: out_unit ! primary output unit + INTEGER :: out2_unit ! secondary output unit + INTEGER :: out3_unit ! tertiary output unit + INTEGER :: bin_unit ! binary output unit + INTEGER :: bin_2d_unit ! 2-D binary output unit + INTEGER :: input_unit ! namelist / input unit + INTEGER :: n_trace ! trace / debug verbosity level + +c----------------------------------------------------------------------- +c Mode numbers (integer and real representations). +c----------------------------------------------------------------------- + INTEGER :: mm ! poloidal mode number (integer) + INTEGER :: nn ! toroidal mode number (integer) + REAL(r8) :: mr ! poloidal mode number (real copy) + REAL(r8) :: nr ! toroidal mode number (real copy) + CHARACTER(2) :: sn ! toroidal n as string (BUG FLAG 3) + CHARACTER(2) :: sm ! poloidal m as string (BUG FLAG 3) + +c----------------------------------------------------------------------- +c Layer-physics scalars (set by params(), read by solvers). +c These are the normalised parameters that enter the SLAYER +c dispersion relation. +c----------------------------------------------------------------------- +c --- temperature / collisionality + REAL(r8) :: tau ! T_i / T_e + REAL(r8) :: eta ! Spitzer resistivity [Ohm*m] + REAL(r8) :: visc ! anomalous viscosity [m^2/s] + REAL(r8) :: lnLamb ! Coulomb logarithm (updated at runtime) +c --- length scales + REAL(r8) :: rho_s ! ion Larmor radius at T_e [m] + REAL(r8) :: d_i ! ion skin depth [m] + REAL(r8) :: d_beta ! beta-weighted ion scale d_beta = c_beta * d_i +c --- timescales + REAL(r8) :: tau_r ! resistive diffusion time [s] + REAL(r8) :: tauk ! Q-conversion factor (= Qconv) +c --- Lundquist and Prandtl numbers + REAL(r8) :: lu ! Lundquist number S = tau_r / tau_h + REAL(r8) :: pr ! magnetic Prandtl number (BUG FLAG 1) + REAL(r8) :: pe ! electron Prandtl number (BUG FLAG 1) + REAL(r8) :: P_perp ! perpendicular magnetic Prandtl number + REAL(r8) :: P_tor ! toroidal magnetic Prandtl number +c --- normalised layer parameters + REAL(r8) :: ds ! normalised ion Larmor radius + REAL(r8) :: c_beta ! compressional beta parameter + REAL(r8) :: D_norm ! normalised beta-related width + REAL(r8) :: delta_n ! Delta normalisation factor + REAL(r8) :: Qconv ! frequency normalisation (Cole) +c --- diamagnetic and rotation frequencies + REAL(r8) :: omega_e ! electron diamagnetic frequency [rad/s] + REAL(r8) :: omega_i ! ion diamagnetic frequency [rad/s] + COMPLEX(r8) :: Q ! normalised complex rotation frequency + REAL(r8) :: Q_e ! normalised electron diamagnetic Q + REAL(r8) :: Q_i ! normalised ion diamagnetic Q +c --- stability / Delta_crit + REAL(r8) :: deltaprim ! Deltaprime value (BUG FLAG 2: may be unused) + REAL(r8) :: dc_tmp ! computed Delta_crit + REAL(r8) :: d_crit ! stored Delta_crit (BUG FLAG 2) + REAL(r8) :: delta_eff ! effective Deltaprime shift + CHARACTER(20) :: dc_type ! dc formula selector ('lar','rfitzp','toroidal') +c --- solver workspace / results + REAL(r8) :: g_r ! real part of growth rate (BUG FLAG 2) + REAL(r8) :: g_i ! imag part of growth rate (BUG FLAG 2) + COMPLEX(r8) :: g_tmp ! temporary complex growth rate + COMPLEX(r8) :: delta_det ! dispersion determinant (BUG FLAG 2) + REAL(r8) :: gamma_fac ! growth-rate conversion factor (BUG FLAG 2) +c --- miscellaneous + REAL(r8) :: iota_e ! (BUG FLAG 2: may be unused) + REAL(r8) :: layfac ! (BUG FLAG 2: may be unused) + +c----------------------------------------------------------------------- +c Physical and mathematical constants. +c----------------------------------------------------------------------- + REAL(r8), PARAMETER :: pi = 3.1415926535897932385d0 + REAL(r8), PARAMETER :: mu0 = 4.0d-7 * pi ! vacuum permeability [H/m] + REAL(r8), PARAMETER :: m_e = 9.1094d-31 ! electron mass [kg] + REAL(r8), PARAMETER :: m_p = 1.6726d-27 ! proton mass [kg] + REAL(r8), PARAMETER :: chag = 1.6021917d-19 ! elementary charge [C] + REAL(r8), PARAMETER :: kval = 1.3807d-23 ! Boltzmann constant [J/K] + REAL(r8), PARAMETER :: eps0 = 8.8542d-12 ! vacuum permittivity [F/m] + COMPLEX(r8), PARAMETER :: ifac = (0.0d0, 1.0d0) ! imaginary unit + +c----------------------------------------------------------------------- +c AMR scanner storage -- hash-based deduplication (v1). +c----------------------------------------------------------------------- + INTEGER, PARAMETER :: MAX_PTS = 500000 ! max unique eval points + INTEGER, PARAMETER :: HASH_SZ = 500009 ! hash table size (prime) + REAL(r8), PARAMETER :: HASH_SCALE = 1.0d5 ! Re/Im quantisation scale + INTEGER, ALLOCATABLE :: hash_head(:) ! bucket heads (HASH_SZ) + INTEGER, ALLOCATABLE :: hash_next(:) ! chain pointers (MAX_PTS) + +c----------------------------------------------------------------------- +c AMR scanner storage -- cell-based refinement (v2). +c----------------------------------------------------------------------- + INTEGER, PARAMETER :: MAX_CELLS = 500000 ! max AMR cells + TYPE :: amr_cell_type - COMPLEX(r8) :: Q(4) ! Corner Q values (TL, TR, BL, BR) - COMPLEX(r8) :: D(4) ! Corner Delta values - LOGICAL :: needs_refine ! Flag for refinement + COMPLEX(r8) :: Q(4) ! corner Q-values (BL, BR, TL, TR) + COMPLEX(r8) :: D(4) ! corner dispersion values + LOGICAL :: needs_refine ! flagged for subdivision END TYPE amr_cell_type + TYPE(amr_cell_type), ALLOCATABLE :: amr_cells(:) - INTEGER :: n_amr_cells - ! For output: flattened unique points - COMPLEX(r8), ALLOCATABLE :: Q_store(:), D_store(:) - INTEGER :: n_pts + INTEGER :: n_amr_cells ! current number of active cells + +c----------------------------------------------------------------------- +c AMR output arrays (shared by v1 and v2). +c----------------------------------------------------------------------- + COMPLEX(r8), ALLOCATABLE :: Q_store(:) ! unique Q-points + COMPLEX(r8), ALLOCATABLE :: D_store(:) ! corresponding D-values + INTEGER :: n_pts ! number of stored points + +c----------------------------------------------------------------------- +c Derived types: solver I/O and scan results. +c----------------------------------------------------------------------- +c result_type -- torque-scan output bucket TYPE result_type - REAL(r8), ALLOCATABLE :: inQs(:), iinQs(:), - $ Re_deltas(:), Im_deltas(:) - INTEGER :: count + REAL(r8), ALLOCATABLE :: inQs(:) ! Re(Q) scan values + REAL(r8), ALLOCATABLE :: iinQs(:) ! Im(Q) scan values + REAL(r8), ALLOCATABLE :: Re_deltas(:) ! Re(Delta) results + REAL(r8), ALLOCATABLE :: Im_deltas(:) ! Im(Delta) results + INTEGER :: count ! number of entries END TYPE result_type +c slayer_inputs_type -- per-surface input arrays for SLAYER TYPE slayer_inputs_type - INTEGER, ALLOCATABLE :: qval_arr(:) - REAL(r8), ALLOCATABLE :: chi_p_arr(:),chi_t_arr(:), - $ kappa_arr(:),psi_n_arr(:), - $ lu_arr(:),Qconv_arr(:),Q_e_arr(:),Q_i_arr(:),c_beta_arr(:), - $ d_beta_arr(:),D_norm_arr(:),tau_arr(:),P_perp_arr(:), - $ P_tor_arr(:),omegas_arr(:),omegas_e_arr(:),omegas_i_arr(:), - $ gammafac_arr(:),Re_dp_arr(:),Im_dp_arr(:),d_crit_arr(:) - COMPLEX(r8), ALLOCATABLE :: dp_matrix(:,:) + INTEGER, ALLOCATABLE :: qval_arr(:) ! safety-factor integers + REAL(r8), ALLOCATABLE :: chi_p_arr(:) ! chi_perp [m^2/s] + REAL(r8), ALLOCATABLE :: chi_t_arr(:) ! chi_tor [m^2/s] + REAL(r8), ALLOCATABLE :: kappa_arr(:) ! kappa (thermal cond.) + REAL(r8), ALLOCATABLE :: psi_n_arr(:) ! normalised psi + REAL(r8), ALLOCATABLE :: lu_arr(:) ! Lundquist number + REAL(r8), ALLOCATABLE :: Qconv_arr(:) ! Q-conversion factor + REAL(r8), ALLOCATABLE :: Q_e_arr(:) ! normalised Q_e + REAL(r8), ALLOCATABLE :: Q_i_arr(:) ! normalised Q_i + REAL(r8), ALLOCATABLE :: c_beta_arr(:) ! compressional beta + REAL(r8), ALLOCATABLE :: d_beta_arr(:) ! beta-related width + REAL(r8), ALLOCATABLE :: D_norm_arr(:) ! normalised D + REAL(r8), ALLOCATABLE :: tau_arr(:) ! T_i / T_e + REAL(r8), ALLOCATABLE :: P_perp_arr(:) ! perp Prandtl number + REAL(r8), ALLOCATABLE :: P_tor_arr(:) ! toroidal Prandtl + REAL(r8), ALLOCATABLE :: omegas_arr(:) ! rotation [rad/s] + REAL(r8), ALLOCATABLE :: omegas_e_arr(:) ! omega_e [rad/s] + REAL(r8), ALLOCATABLE :: omegas_i_arr(:) ! omega_i [rad/s] + REAL(r8), ALLOCATABLE :: gammafac_arr(:) ! gamma conversion + REAL(r8), ALLOCATABLE :: Re_dp_arr(:) ! Re(Deltaprime) + REAL(r8), ALLOCATABLE :: Im_dp_arr(:) ! Im(Deltaprime) + REAL(r8), ALLOCATABLE :: d_crit_arr(:) ! Delta_crit + COMPLEX(r8), ALLOCATABLE :: dp_matrix(:,:) ! full Deltaprime matrix END TYPE slayer_inputs_type +c slayer_outputs_type -- per-surface solver results TYPE slayer_outputs_type - COMPLEX(r8), ALLOCATABLE :: dels_db_arr(:),gamma_sol_arr(:), - $ gamma_est_arr(:) + COMPLEX(r8), ALLOCATABLE :: dels_db_arr(:) ! Delta from d_beta + COMPLEX(r8), ALLOCATABLE :: gamma_sol_arr(:) ! solved growth rate + COMPLEX(r8), ALLOCATABLE :: gamma_est_arr(:) ! estimated growth rate END TYPE slayer_outputs_type +c deltas_outputs_type -- scan output (Q vs Delta) TYPE deltas_outputs_type - REAL(r8), ALLOCATABLE :: inQs(:) - REAL(r8), ALLOCATABLE :: iinQs(:) - REAL(r8), ALLOCATABLE :: real_deltas(:) - REAL(r8), ALLOCATABLE :: imag_deltas(:) + REAL(r8), ALLOCATABLE :: inQs(:) ! Re(Q) values + REAL(r8), ALLOCATABLE :: iinQs(:) ! Im(Q) values + REAL(r8), ALLOCATABLE :: real_deltas(:) ! Re(Delta) + REAL(r8), ALLOCATABLE :: imag_deltas(:) ! Im(Delta) END TYPE deltas_outputs_type - ! lnLamb will be updated. - - COMPLEX(r8), PARAMETER :: ifac=(0,1) - - CHARACTER(2) :: sn,sm - END MODULE sglobal_mod diff --git a/slayer/slayer.f b/slayer/slayer.f index 37566a191..000bbf1a4 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -1,11 +1,10 @@ c----------------------------------------------------------------------- -c Slab LAYER based on linear drift MHD -c SLAYER: main program -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- -c code organization. -c----------------------------------------------------------------------- -c slayer. +c SLAYER: Slab LAYER linear drift-MHD code. +c Main driver program. +c +c Computes tearing-mode layer quantities (inner layer Delta, +c growth rates, torque balance, field thresholds) from +c slab-geometry drift-MHD matching via a Riccati integration method. c----------------------------------------------------------------------- c----------------------------------------------------------------------- c declarations. @@ -13,59 +12,185 @@ PROGRAM slayer USE sglobal_mod - USE delta_mod, ONLY: riccati,riccati_del_s,riccati_out, - $ parflow_flag,PeOhmOnly_flag + USE delta_mod, ONLY: riccati,riccati_f,riccati_del_s, + $ riccati_out,parflow_flag,PeOhmOnly_flag USE gslayer_mod USE layerinputs_mod IMPLICIT NONE - - CHARACTER(512) :: infile,ncfile - INTEGER :: i,j,k,inum,jnum,knum,inn,count, - $ Q_num,msing_max,n_k - INTEGER, DIMENSION(1) :: index - - LOGICAL :: params_flag,QPscan_flag,QPescan_flag,QPscan2_flag, - $ QDscan2_flag,Qbscan_flag,Qscan_flag, - $ onscan_flag,otscan_flag,ntscan_flag,nbtscan_flag, - $ Pe_flag,verbose,ascii_flag,bin_flag,netcdf_flag, - $ bal_flag,stability_flag,riccatiscan_flag,input_flag, - $ params_check,stabscan_flag,coupled_stabscan_flag,amr_flag, - $ read_eq,est_gamma_flag, - $ match_gamma_flag,fitz_flag,coupling_flag,br_th_flag - REAL(r8) :: n_e,t_e,t_i,omega,omega0,scan_width,l_n, - $ l_t,qval,sval,bt,rs,R0,mu_i,zeff,dr_val,dgeo_val - REAL(r8) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds,intau,inlu - REAL(r8) :: psi0,jxb,Q0,Q_sol,br_th,d_b,Residual - COMPLEX(r8) :: delta,delta_n_p,dels_db,del_s,lar_gamma, - $ tmp_gamma,ingamma,delta_prime,det_val - - REAL(r8) :: inQ_min,inQ_max,j_min,j_max,jpower,k_min,k_max, - $ kpower,ing_step,ing_coarse,iing_coarse,delta_real, - $ delta_imag,Qratio - REAL(r8) :: chis(3) - - INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns - - REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl,bal, - $ prs,n_es,t_es,t_is,omegas,l_ns,l_ts,svals,qvals, - $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,pes - REAL(r8), DIMENSION(8) :: chi_p_prof, chi_t_prof, kappa_prof - REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs - REAL(r8), DIMENSION(:,:), ALLOCATABLE :: - $ js,ks,psis,jxbs,Q_sols,br_ths - REAL(r8) :: spot, slayer_inpr +c----------------------------------------------------------------------- +c local scalars — loop indices and counters. +c----------------------------------------------------------------------- + INTEGER :: i,j,k ! general loop indices + INTEGER :: inn ! number of input-file surfaces + INTEGER :: count ! generic counter +c----------------------------------------------------------------------- +c local scalars — numerical resolution. +c----------------------------------------------------------------------- + INTEGER :: inum ! resolution for 1-D scans + INTEGER :: jnum ! resolution for 2-D scan axis 1 + INTEGER :: knum ! resolution for 2-D scan axis 2 + INTEGER :: Q_num ! resolution for stab. scan Re(Q) + INTEGER :: msing_max ! max number of singular surfaces + INTEGER :: n_k ! number of rational surfaces +c----------------------------------------------------------------------- +c local scalars — intrinsic-name collision (see BUG FLAG 1). +c----------------------------------------------------------------------- + INTEGER, DIMENSION(1) :: index ! result of MAXLOC [BUG FLAG 1] +c----------------------------------------------------------------------- +c control flags — workflow. +c----------------------------------------------------------------------- + LOGICAL :: params_flag ! compute params from kinetic data + LOGICAL :: input_flag ! read multi-surface input file + LOGICAL :: read_eq ! read equilibrium files + LOGICAL :: verbose ! enable progress messages + LOGICAL :: params_check ! print diagnostic output in params +c----------------------------------------------------------------------- +c control flags — physics modes. +c----------------------------------------------------------------------- + LOGICAL :: est_gamma_flag ! estimate growth rate + LOGICAL :: match_gamma_flag ! asymptotically matched gamma + LOGICAL :: fitz_flag ! use Fitzpatrick layer model + LOGICAL :: coupling_flag ! coupled rational surfaces + LOGICAL :: br_th_flag ! Br threshold test scan + LOGICAL :: bal_flag ! torque balance scan + LOGICAL :: stability_flag ! complex-Q delta scan + LOGICAL :: Pe_flag ! include electron pressure +c----------------------------------------------------------------------- +c control flags — parameter-space scans. +c----------------------------------------------------------------------- + LOGICAL :: QPscan_flag ! (Q,P) scan + LOGICAL :: QPescan_flag ! (Q,Pe) scan + LOGICAL :: QPscan2_flag ! (Q,P) scan variant 2 + LOGICAL :: QDscan2_flag ! (Q,D) scan variant 2 + LOGICAL :: Qbscan_flag ! (Q,beta) scan + LOGICAL :: Qscan_flag ! 1-D Q scan + LOGICAL :: onscan_flag ! (omega,n) scan + LOGICAL :: otscan_flag ! (omega,T) scan + LOGICAL :: ntscan_flag ! (n,T) scan + LOGICAL :: nbtscan_flag ! (n,Bt) scan + LOGICAL :: riccatiscan_flag ! Riccati-variable scan + LOGICAL :: stabscan_flag ! stability scan (single surface) + LOGICAL :: coupled_stabscan_flag ! stability scan (coupled) + LOGICAL :: amr_flag ! adaptive mesh refinement scan +c----------------------------------------------------------------------- +c control flags — output format. +c----------------------------------------------------------------------- + LOGICAL :: ascii_flag ! write ASCII output files + LOGICAL :: bin_flag ! write binary output files + LOGICAL :: netcdf_flag ! write NetCDF output files +c----------------------------------------------------------------------- +c local scalars — physical input quantities. +c----------------------------------------------------------------------- + REAL(r8) :: n_e ! electron density [m^-3] + REAL(r8) :: t_e ! electron temperature [eV] + REAL(r8) :: t_i ! ion temperature [eV] + REAL(r8) :: omega ! toroidal rotation [rad/s] + REAL(r8) :: omega0 ! (unused, see BUG FLAG 2) + REAL(r8) :: l_n ! density gradient scale length + REAL(r8) :: l_t ! temperature gradient scale length + REAL(r8) :: qval ! safety factor at surface + REAL(r8) :: sval ! magnetic shear at surface + REAL(r8) :: bt ! toroidal field [T] + REAL(r8) :: rs ! minor radius of surface [m] + REAL(r8) :: R0 ! major radius [m] + REAL(r8) :: mu_i ! ion mass number + REAL(r8) :: zeff ! effective charge + REAL(r8) :: dr_val ! radial derivative parameter + REAL(r8) :: dgeo_val ! geometric factor parameter + REAL(r8) :: scan_width ! half-width of complex-Q scan +c----------------------------------------------------------------------- +c local scalars — normalized layer parameters (namelist overrides). +c----------------------------------------------------------------------- + REAL(r8) :: inQ ! normalized ExB rotation freq. + REAL(r8) :: inQ_e ! normalized electron diamagnetic + REAL(r8) :: inQ_i ! normalized ion diamagnetic + REAL(r8) :: inpr ! normalized pressure gradient + REAL(r8) :: inpe ! normalized electron pressure + REAL(r8) :: inc_beta ! normalized beta + REAL(r8) :: inds ! normalized D (magnetic diffusion) + REAL(r8) :: intau ! normalized tau = T_i/T_e + REAL(r8) :: inlu ! normalized Lundquist number +c----------------------------------------------------------------------- +c local scalars — derived / scratch quantities. +c----------------------------------------------------------------------- + REAL(r8) :: psi0 ! reconnected flux (a.u.) + REAL(r8) :: jxb ! j x B torque (a.u.) + REAL(r8) :: Q0 ! unperturbed rotation frequency + REAL(r8) :: Q_sol ! solved rotation frequency + REAL(r8) :: br_th ! radial field threshold + REAL(r8) :: d_b ! (unused, see BUG FLAG 2) + REAL(r8) :: Residual ! (unused, see BUG FLAG 2) + REAL(r8) :: Qratio ! Q_e/Q ratio for scan2 variants + REAL(r8) :: spot ! (unused, see BUG FLAG 2) + REAL(r8) :: slayer_inpr ! (unused, see BUG FLAG 2) +c----------------------------------------------------------------------- +c local scalars — scan grid helpers. +c----------------------------------------------------------------------- + REAL(r8) :: inQ_min,inQ_max ! rotation scan bounds + REAL(r8) :: j_min,j_max,jpower ! 2-D scan axis 1 + REAL(r8) :: k_min,k_max,kpower ! 2-D scan axis 2 + REAL(r8) :: ing_step ! growth-rate grid step + REAL(r8) :: ing_coarse ! Re(gamma) grid value + REAL(r8) :: iing_coarse ! Im(gamma) grid value + REAL(r8) :: delta_real ! (unused, see BUG FLAG 2) + REAL(r8) :: delta_imag ! (unused, see BUG FLAG 2) +c----------------------------------------------------------------------- +c local scalars — complex quantities. +c----------------------------------------------------------------------- + COMPLEX(r8) :: delta ! layer Delta (tearing index) + COMPLEX(r8) :: delta_n_p ! Deltaprime scale factor + COMPLEX(r8) :: dels_db ! delta_s / d_beta + COMPLEX(r8) :: del_s ! delta_s + COMPLEX(r8) :: lar_gamma ! (unused, see BUG FLAG 2) + COMPLEX(r8) :: tmp_gamma ! (unused, see BUG FLAG 2) + COMPLEX(r8) :: ingamma ! initial gamma guess (namelist) + COMPLEX(r8) :: delta_prime ! external Deltaprime (namelist) + COMPLEX(r8) :: det_val ! (unused, see BUG FLAG 2) +c----------------------------------------------------------------------- +c local arrays — transport profile coefficients. +c----------------------------------------------------------------------- + REAL(r8) :: chis(3) ! chi_perp, chi_tor, kappa + REAL(r8), DIMENSION(8) :: chi_p_prof ! chi_perp radial profile + REAL(r8), DIMENSION(8) :: chi_t_prof ! chi_tor radial profile + REAL(r8), DIMENSION(8) :: kappa_prof ! kappa radial profile +c----------------------------------------------------------------------- +c local arrays — multi-surface input-file storage. +c----------------------------------------------------------------------- + INTEGER, DIMENSION(:), ALLOCATABLE :: mms,nns + REAL(r8), DIMENSION(:), ALLOCATABLE :: prs,n_es,t_es,t_is, + $ omegas,l_ns,l_ts,svals,qvals,bts,rss,R0s,mu_is,zeffs, + $ Q_soll,br_thl,pes +c----------------------------------------------------------------------- +c local arrays — scan workspace. +c----------------------------------------------------------------------- + REAL(r8), DIMENSION(:), ALLOCATABLE :: inQs,iinQs + REAL(r8), DIMENSION(:), ALLOCATABLE :: jxbl,bal + REAL(r8), DIMENSION(:,:), ALLOCATABLE :: js,ks,psis,jxbs, + $ Q_sols,br_ths REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: Q_solss,br_thss - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: deltal,outer_deltas COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: deltas - - ! AMR DECLARATIONS - INTEGER :: AMR_passes, m_AMR ! Number of refinement levels - - TYPE(slayer_inputs_type) :: sl_in +c----------------------------------------------------------------------- +c AMR (adaptive mesh refinement) growth-rate scan. +c----------------------------------------------------------------------- + INTEGER :: AMR_passes ! number of AMR refinement levels + INTEGER :: m_AMR ! effective number of surfaces +c----------------------------------------------------------------------- +c structured input/output types (defined in sglobal_mod). +c----------------------------------------------------------------------- + TYPE(slayer_inputs_type) :: sl_in TYPE(slayer_outputs_type) :: sl_out TYPE(deltas_outputs_type), ALLOCATABLE :: all_deltas_out(:) +c----------------------------------------------------------------------- +c file-path strings. +c----------------------------------------------------------------------- + CHARACTER(512) :: infile ! multi-surface input file path + CHARACTER(512) :: ncfile ! NetCDF equilibrium file path +c----------------------------------------------------------------------- +c namelist groups. +c----------------------------------------------------------------------- NAMELIST/slayer_input/input_flag,infile, $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_p_prof, @@ -84,95 +209,127 @@ PROGRAM slayer $ params_check c----------------------------------------------------------------------- c set initial values. +c defaults are overridden by namelist reads below. c----------------------------------------------------------------------- - mm=0.0 - nn=0.0 - mr = 0.0!real(mm,4) - nr = 0.0!real(nn,4) - n_e=0.0 - t_e=0.0 - t_i=0.0 - omega=0.0 - l_n=0.0 - l_t=0.0 - qval=0.0 - sval=0.0 - bt=0.0 - rs=0.0 - R0=0.0 - mu_i=0.0 - zeff=0.0 - dr_val=0.0 - dgeo_val=0.0 - inQ=0.0 - inQ_e=0.0 - inQ_i=0.0 - inpr=0.0 - chi_p_prof=0.0 - chi_t_prof=0.0 - kappa_prof=0.0 - inpe=0.0 - inc_beta=0.0 - inds=0.0 - intau=0.0 - inlu=0.0 - Q0=0.0 - chis=0.0 - gamma_fac=0.0 - dc_type="" - delta_prime=(0.0,0.0) - delta_n_p=(0.0,0.0) - ingamma=(0.0,0.0) - inum=400 ! resolution to find error field thresholds. - jnum=500 ! resolution for 2d scan along with Q,omega. - knum=100 ! resolution for 2d scan alont with the other. - Q_num=100 ! resolution for stab. scan along Re(Q) axis - scan_width = 2.0 - AMR_passes = 4 - msing_max = 2 - in_unit=1 - out_unit=2 - out2_unit=3 - out3_unit=4 - bin_unit=5 - bin_2d_unit=6 - input_unit=7 - read_eq=.FALSE. - est_gamma_flag=.FALSE. - match_gamma_flag=.FALSE. - fitz_flag=.FALSE. - coupling_flag=.FALSE. - QPscan_flag=.FALSE. ! scan (Q,P) space for delta and torque. - QPescan_flag=.FALSE. ! scan (Q,Pe) space for delta and torque. - Qbscan_flag=.FALSE. ! scan (Q,beta) space for delta and torque. - onscan_flag=.FALSE. ! scan (omega,n) space for error fields. - otscan_flag=.FALSE. ! scan (omega,t) space for error fields. - ntscan_flag=.FALSE. ! scan (n,te) space for error fields. - nbtscan_flag=.FALSE. ! scan (n,bt) space for error fields. - layfac=0.02 - Qratio=0.5 - parflow_flag=.FALSE. - PeOhmOnly_flag=.TRUE. - Pe_flag=.FALSE. - params_flag=.TRUE. - input_flag=.FALSE. - infile="" - ncfile="" - verbose=.TRUE. - ascii_flag=.TRUE. - bin_flag=.TRUE. - netcdf_flag=.FALSE. - riccati_out=.FALSE. - riccatiscan_flag=.FALSE. - params_check=.FALSE. - bal_flag=.FALSE. - stability_flag=.FALSE. - stabscan_flag=.FALSE. - coupled_stabscan_flag=.FALSE. - amr_flag=.FALSE. - br_th_flag=.FALSE. + + ! mode numbers (sglobal_mod: INTEGER mm,nn; REAL mr,nr) + mm = 0 + nn = 0 + mr = 0.0 + nr = 0.0 + + ! kinetic / equilibrium inputs + n_e = 0.0 + t_e = 0.0 + t_i = 0.0 + omega = 0.0 + l_n = 0.0 + l_t = 0.0 + qval = 0.0 + sval = 0.0 + bt = 0.0 + rs = 0.0 + R0 = 0.0 + mu_i = 0.0 + zeff = 0.0 + dr_val = 0.0 + dgeo_val= 0.0 + + ! normalized layer-parameter overrides + inQ = 0.0 + inQ_e = 0.0 + inQ_i = 0.0 + inpr = 0.0 + inpe = 0.0 + inc_beta = 0.0 + inds = 0.0 + intau = 0.0 + inlu = 0.0 + Q0 = 0.0 + + ! transport profile coefficients + chi_p_prof = 0.0 + chi_t_prof = 0.0 + kappa_prof = 0.0 + chis = 0.0 + + ! complex namelist inputs + delta_prime = (0.0,0.0) + delta_n_p = (0.0,0.0) + ingamma = (0.0,0.0) + + ! global module scalars (sglobal_mod) + gamma_fac = 0.0 + dc_type = "" + + ! scan resolution defaults + inum = 400 ! 1-D resolution (error-field threshold scans) + jnum = 500 ! 2-D scan axis-1 resolution + knum = 100 ! 2-D scan axis-2 resolution + Q_num = 100 ! stability scan Re(Q) resolution + scan_width = 2.0 ! half-width for complex-Q scans + AMR_passes = 4 ! AMR refinement levels + msing_max = 2 ! max singular surfaces to process + + ! I/O unit numbers (sglobal_mod) + in_unit = 1 + out_unit = 2 + out2_unit = 3 + out3_unit = 4 + bin_unit = 5 + bin_2d_unit= 6 + input_unit = 7 + + ! workflow flags + read_eq = .FALSE. + est_gamma_flag = .FALSE. + match_gamma_flag = .FALSE. + fitz_flag = .FALSE. + coupling_flag = .FALSE. + params_flag = .TRUE. + input_flag = .FALSE. + + ! parameter-space scan flags + QPscan_flag = .FALSE. + QPescan_flag = .FALSE. + Qbscan_flag = .FALSE. + onscan_flag = .FALSE. + otscan_flag = .FALSE. + ntscan_flag = .FALSE. + nbtscan_flag = .FALSE. + + ! physics / model flags + layfac = 0.02 + Qratio = 0.5 + parflow_flag = .FALSE. + PeOhmOnly_flag = .TRUE. + Pe_flag = .FALSE. + + ! file paths + infile = "" + ncfile = "" + + ! output control + verbose = .TRUE. + ascii_flag = .TRUE. + bin_flag = .TRUE. + netcdf_flag = .FALSE. + + ! diagnostic flags + riccati_out = .FALSE. + riccatiscan_flag = .FALSE. + params_check = .FALSE. + + ! remaining physics-mode flags + bal_flag = .FALSE. + stability_flag = .FALSE. + stabscan_flag = .FALSE. + coupled_stabscan_flag= .FALSE. + amr_flag = .FALSE. + br_th_flag = .FALSE. c----------------------------------------------------------------------- c read slayer.in. +c four namelist groups: input, control, output, diagnose. c----------------------------------------------------------------------- IF(verbose) WRITE(*,*)"" IF(verbose) WRITE(*,*)"SLAYER START" @@ -184,6 +341,7 @@ PROGRAM slayer READ(in_unit,NML=slayer_diagnose) CLOSE(UNIT=in_unit) + ! Build toroidal-mode-number string for output filenames. IF (nn<10) THEN WRITE(UNIT=sn,FMT='(I1)') nn sn=ADJUSTL(sn) @@ -191,11 +349,15 @@ PROGRAM slayer WRITE(UNIT=sn,FMT='(I2)') nn ENDIF c----------------------------------------------------------------------- -c calculate parameters as needed. +c compute normalized layer parameters from kinetic inputs. +c params() (params_mod) converts dimensional plasma profiles into +c the normalized quantities (Q, Q_e, Q_i, c_beta, ds, tau, lu) +c used by the Riccati solver. c----------------------------------------------------------------------- IF (params_flag) THEN CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + ! Copy module-level results into local working variables. inQ=Q inQ_e=Q_e inQ_i=Q_i @@ -204,21 +366,28 @@ PROGRAM slayer intau=tau Q0=Q ELSE - lu=inlu + lu=inlu ! manual Lundquist number when params not computed ENDIF c----------------------------------------------------------------------- -c calculate basic delta, torque, balance, error fields. +c baseline single-surface delta, reconnected flux, & torque. +c skipped when the matched-gamma path is active (it computes +c its own delta internally). c----------------------------------------------------------------------- IF (.NOT. (match_gamma_flag)) THEN - delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) - psi0=1.0/ABS(delta+delta_n_p) ! a.u. - jxb=-AIMAG(1.0/(delta+delta_n_p)) ! a.u. - WRITE(*,*)"delta=",delta - WRITE(*,*)"psi0=",psi0 - WRITE(*,*)"jxb=",jxb + delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) + psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] + jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] + IF (verbose) THEN + WRITE(*,*)"delta=",delta + WRITE(*,*)"psi0=",psi0 + WRITE(*,*)"jxb=",jxb + ENDIF ENDIF c----------------------------------------------------------------------- -c calculate parameters as needed. +c multi-surface input-file mode. +c reads an external file of (m,n) surfaces with per-surface kinetic +c profiles, computes delta and the error-field threshold for each. +c [BUG FLAG 3] arrays are allocated 1:inn but loops run 0:inn-1. c----------------------------------------------------------------------- IF (input_flag) THEN OPEN(UNIT=input_unit,FILE=infile,STATUS="old") @@ -238,7 +407,7 @@ PROGRAM slayer CLOSE(input_unit) DO k=0,inn-1 - WRITE(*,*)k + WRITE(*,*)k ! surface index mr=REAL(mms(k)) nr=REAL(nns(k)) inpr=prs(k) @@ -277,12 +446,13 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) ENDDO + ! [BUG FLAG 3] Q_soll/br_thl indexed 0:inn-1 but allocated 1:inn index=MAXLOC(bal) Q_soll(k)=inQs(index(1)) br_thl(k)=sqrt(MAXVAL(bal)/lu*(svals(k)**2.0/2.0))*1e4 - WRITE(*,*)"Q_sol=",Q_soll(k) - WRITE(*,*)"br_th=",br_thl(k) + IF (verbose) WRITE(*,*)"Q_sol=",Q_soll(k) + IF (verbose) WRITE(*,*)"br_th=",br_thl(k) DEALLOCATE(inQs,deltal,jxbl,bal) ENDDO OPEN(UNIT=out_unit,FILE="slayer_input_bal_n"// @@ -298,30 +468,31 @@ PROGRAM slayer $ bts,rss,R0s,mu_is,zeffs,Q_soll,br_thl,mms,nns) ENDIF c----------------------------------------------------------------------- -c LAR (cylindrical) growthrates via restive layer thickness +c estimate growth rate via resistive-layer thickness. +c Uses riccati_del_s to get delta_s/d_beta, then scales by +c d_beta to obtain the layer thickness delta_s and the estimated +c gamma. Inputs may come from equilibrium files (read_eq) or +c namelist.Subroutines: build_inputs, allocate_inputs, +c allocate_outputsare defined in gslayer_mod / layerinputs_mod. c----------------------------------------------------------------------- IF (est_gamma_flag) THEN WRITE(*,*)"------------------------------------------" WRITE(*,*)">>> Estimating growth rate" IF (read_eq) THEN - WRITE(*,*)"$^$ entered read_eq" - + ! Read equilibrium files for multi-surface inputs. + ! build_inputs (layerinputs_mod) reads STRIDE NetCDF data. sl_in%chi_p_arr = chi_p_prof sl_in%chi_t_arr = chi_t_prof sl_in%kappa_arr = kappa_prof - WRITE(*,*)"$^$ entering build_inputs" - - WRITE(*,*)"$^$ infile: ",infile - WRITE(*,*)"$^$ ncfile: ",ncfile - CALL build_inputs(infile,ncfile,sl_in) n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) ELSE + ! Single-surface mode: build inputs from namelist. n_k = 1 mr = mm nr = nn @@ -333,6 +504,7 @@ PROGRAM slayer CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + ! Override computed parameters with nonzero namelist values. IF (ABS(inQ) > 0.0) THEN Q = inQ ! NAMELIST END IF @@ -352,10 +524,8 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF - WRITE(*,*)"$^$ entering allocate_inputs" - CALL allocate_inputs(n_k,sl_in) - WRITE(*,*)"$^$ entering allocate_outputs" - CALL allocate_outputs(n_k,sl_out) + CALL allocate_inputs(n_k,sl_in) ! gslayer_mod + CALL allocate_outputs(n_k,sl_out) ! gslayer_mod sl_in%qval_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) @@ -377,32 +547,23 @@ PROGRAM slayer sl_in%Qconv_arr = (/ tauk /) END IF + ! Loop over rational surfaces to estimate growth rates. DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate '// $ 'estimate on q = ', $ sl_in%qval_arr(k),' rational surface' - WRITE(*,*)"sl_in%Q_e_arr(k): ",sl_in%Q_e_arr(k) - WRITE(*,*)"sl_in%Q_e_arr(k): ",sl_in%Q_e_arr(k) - WRITE(*,*)"sl_in%Q_i_arr(k): ",sl_in%Q_i_arr(k) - WRITE(*,*)"sl_in%P_perp_arr(k): ",sl_in%P_perp_arr(k) - WRITE(*,*)"sl_in%P_tor_arr(k): ",sl_in%P_tor_arr(k) - WRITE(*,*)"sl_in%c_beta_arr(k): ",sl_in%c_beta_arr(k) - WRITE(*,*)"sl_in%D_norm_arr(k): ",sl_in%D_norm_arr(k) - WRITE(*,*)"sl_in%tau_arr(k): ",sl_in%tau_arr(k) - WRITE(*,*)"sl_in%gammafac_arr(k): ",sl_in%gammafac_arr(k) - WRITE(*,*)"sl_in%d_beta_arr(k): ",sl_in%d_beta_arr(k) - - dels_db=riccati_del_s(sl_in%Q_e_arr(k),sl_in%Q_e_arr(k), ! NOT using Q_arr + ! [BUG FLAG 4] first argument to riccati_del_s is Q_e_arr, + ! not Q_arr. Comment "NOT using Q_arr" is original. + ! Verify this is intentional (Q_e used as ExB frequency). + dels_db=riccati_del_s(sl_in%Q_e_arr(k),sl_in%Q_e_arr(k), $ sl_in%Q_i_arr(k),sl_in%P_perp_arr(k), $ sl_in%c_beta_arr(k),sl_in%D_norm_arr(k), $ sl_in%tau_arr(k),5.0*sl_in%D_norm_arr(k)) del_s = dels_db * sl_in%d_beta_arr(k) - WRITE(*,*)"del_s: ",del_s - sl_out%gamma_est_arr(k) = sl_in%gammafac_arr(k)/del_s sl_out%dels_db_arr(k) = dels_db WRITE(*,*) @@ -418,7 +579,12 @@ PROGRAM slayer END IF ENDIF c----------------------------------------------------------------------- -c LAR (cylindrical) growthrates via restive layer thickness +c asymptotically matched growth rate. +c Matches the inner-layer Delta to the outer-region Delta' to +c find the self-consistent complex growth rate. Supports both +c single-surface and coupled multi-surface (AMR) modes. +c Subroutines: dispersion_AMR_v2, dispersion_det (gslayer_mod), +c riccati_f (delta_mod). c----------------------------------------------------------------------- IF (match_gamma_flag) THEN WRITE(*,*)"------------------------------------------" @@ -496,6 +662,9 @@ PROGRAM slayer END IF END IF +c----------------------------------------------------------------------- +c allocate output arrays for AMR delta storage. +c----------------------------------------------------------------------- IF (AMR_flag .AND. .NOT. coupling_flag) THEN ALLOCATE(all_deltas_out(n_k)) ELSEIF (AMR_flag .AND. coupling_flag) THEN @@ -509,10 +678,15 @@ PROGRAM slayer END IF WRITE(*,*),"Rational q domain: ",sl_in%qval_arr +c----------------------------------------------------------------------- +c loop over rational surfaces to find matched growth rates. +c----------------------------------------------------------------------- DO k=1,MIN(n_k,msing_max) WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', $ sl_in%qval_arr(k),' rational surface:' + + ! Load per-surface parameters into module-level scalars. Q_e = sl_in%Q_e_arr(k) Q_i = sl_in%Q_i_arr(k) P_perp = sl_in%P_perp_arr(k) @@ -534,15 +708,18 @@ PROGRAM slayer WRITE(*,*)"Delta_prime: ",sl_in%Re_dp_arr(k) WRITE(*,*)"Delta_crit: ",sl_in%d_crit_arr(k) - ! Calculate (Deltaprime - d_crit)/S^1/3 + ! Calculate (Deltaprime - D_crit)/S^1/3 delta_eff = (sl_in%Re_dp_arr(k) - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) -c delta_eff = Re_deltaprime_arr(k) pe = 0.0 -c ! Fill gamma_sol_arr with 0's, will by used by python root finding + ! Placeholder: gamma_sol_arr filled for external root-finder. sl_out%gamma_sol_arr(k) = 0.0 +c----------------------------------------------------------------------- +c uncoupled AMR scan (one surface at a time). +c dispersion_AMR_v2 (gslayer_mod) populates Q_store, D_store. +c----------------------------------------------------------------------- IF (AMR_flag .AND. .NOT. coupling_flag) THEN WRITE(*,'(A,I0,A)') 'Calling uncoupled AMR scan on q = ', @@ -550,6 +727,7 @@ PROGRAM slayer CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) + ! Re-allocate output arrays for this surface. IF (ALLOCATED(all_deltas_out(k)%inQs)) $ DEALLOCATE(all_deltas_out(k)%inQs) IF (ALLOCATED(all_deltas_out(k)%iinQs)) @@ -559,41 +737,39 @@ PROGRAM slayer IF (ALLOCATED(all_deltas_out(k)%imag_deltas)) $ DEALLOCATE(all_deltas_out(k)%imag_deltas) - ! Flatten the unique points store into 1D arrays ALLOCATE(all_deltas_out(k)%inQs(n_pts), $ all_deltas_out(k)%iinQs(n_pts)) - ! Assumes you also have real_deltas/imag_deltas declared as 1D ALLOCATE(all_deltas_out(k)%real_deltas(n_pts), $ all_deltas_out(k)%imag_deltas(n_pts)) - - WRITE(*,*)"Allocated all_deltas_out" + ! Flatten unique AMR points into 1-D output arrays. DO i = 1, n_pts all_deltas_out(k)%inQs(i) = REAL(Q_store(i)) - IF (fitz_flag) THEN - all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) - ELSE - all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) - END IF + ! [BUG FLAG 5] IF/ELSE branches are identical. + + all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) + all_deltas_out(k)%real_deltas(i) = REAL(D_store(i)) all_deltas_out(k)%imag_deltas(i) = AIMAG(D_store(i)) END DO - - WRITE(*,*)"all_deltas_out(1)%real_deltas(10): ", - $ all_deltas_out(1)%real_deltas(10) - ! Clean up temporary AMR memory - DEALLOCATE(Q_store, D_store)!, hash_head, hash_next) + ! Clean up temporary AMR memory. + DEALLOCATE(Q_store, D_store) END IF - IF ((stabscan_flag)) THEN ! was .AND. (k == 2) +c----------------------------------------------------------------------- +c single-surface stability scan on [Re(Q), Im(Q)] grid. +c Uses riccati_f() (new Fitzpatrick TJ-like formalism) or +c. riccati() (orig. SLAYER/Waelbroeck). +c----------------------------------------------------------------------- + IF ((stabscan_flag)) THEN WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// $ 'Im(Q)] scan with Q width = ', $ scan_width - ing_step = (2.0*scan_width) / (Q_num - 1) ! was (2.0 * scan_width) / (Q_num - 1) + ing_step = (2.0*scan_width) / (Q_num - 1) count = 0 ALLOCATE(inQs(1:(Q_num+1)),iinQs(1:Q_num)) @@ -652,15 +828,16 @@ PROGRAM slayer sl_out%dels_db_arr = (/ 0. /) END IF +c----------------------------------------------------------------------- +c coupled AMR scan (all surfaces simultaneously). +c dispersion_AMR_v2 (gslayer_mod) with coupling_flag = .TRUE. +c----------------------------------------------------------------------- IF (AMR_flag .AND. coupling_flag) THEN - WRITE(*,*)"Calling coupled AMR scan" - CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) - WRITE(*,*)"Successfully exited coupled AMR scan" - + ! Re-allocate output arrays. IF (ALLOCATED(all_deltas_out(1)%inQs)) $ DEALLOCATE(all_deltas_out(1)%inQs) IF (ALLOCATED(all_deltas_out(1)%iinQs)) @@ -670,32 +847,31 @@ PROGRAM slayer IF (ALLOCATED(all_deltas_out(1)%imag_deltas)) $ DEALLOCATE(all_deltas_out(1)%imag_deltas) - WRITE(*,*)"Successfully checked array allocation" - ALLOCATE(all_deltas_out(1)%inQs(n_pts), $ all_deltas_out(1)%iinQs(n_pts)) ALLOCATE(all_deltas_out(1)%real_deltas(n_pts), $ all_deltas_out(1)%imag_deltas(n_pts)) - - WRITE(*,*)"Successfully allocated all_deltas_out subarrays" + ! Flatten unique AMR points into 1-D output arrays. DO i = 1, n_pts all_deltas_out(1)%inQs(i) = REAL(Q_store(i)) - IF (fitz_flag) THEN - all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) - ELSE - all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) - END IF + + all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) ! verify this sign convention + all_deltas_out(1)%real_deltas(i) = REAL(D_store(i)) all_deltas_out(1)%imag_deltas(i) = AIMAG(D_store(i)) END DO - ! Clean up temporary AMR memory - DEALLOCATE(Q_store, D_store)!, hash_head, hash_next) - WRITE(*,*)"Successfully deallocated Q_store and D_store" + ! Clean up temporary AMR memory. + DEALLOCATE(Q_store, D_store) END IF +c----------------------------------------------------------------------- +c coupled-surface stability scan on [Re(Q), Im(Q)] grid. +c Uses dispersion_det (gslayer_mod) for the full dispersion +c determinant including inter-surface coupling. +c----------------------------------------------------------------------- IF (coupled_stabscan_flag) THEN WRITE(*,*)"------------------------------------------" WRITE(*,'(A,F0.1)')' >>> Running [Re(Q),'// @@ -744,14 +920,14 @@ PROGRAM slayer CALL output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, $ all_deltas_out) stop - ENDIF + ENDIF ! match_gamma_flag c----------------------------------------------------------------------- -c TEST ANALYTIC SCAN IN GSLAYER.F, FOR TESTING ONLY +c Br threshold test scan (analytic). +c For testing & verification only. Scans rotation to find the +c critical radial-field threshold from a simple torque balance. c----------------------------------------------------------------------- IF (br_th_flag) THEN - WRITE(*,*)"running br_th scan" - CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) inQ=Q @@ -762,14 +938,13 @@ PROGRAM slayer intau=tau Q0=Q c----------------------------------------------------------------------- -c calculate basic delta, torque, balance, error fields. +c compute baseline delta, reconnected flux, and torque. c----------------------------------------------------------------------- - WRITE(*,*)"basic delta successful" - delta_n_p=1e-2 + delta_n_p=1e-2 ! [BUG FLAG 7] hardcoded; should use namelist delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, $ inpe) - psi0=1.0/ABS(delta+delta_n_p) ! a.u. - jxb=-AIMAG(1.0/(delta+delta_n_p)) ! a.u. + psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] + jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] c----------------------------------------------------------------------- c find solutions based on simple torque balance. c----------------------------------------------------------------------- @@ -784,8 +959,13 @@ PROGRAM slayer inQ_min=1.5*MINVAL((/Q0,inQ_i/)) ENDIF ENDIF - WRITE(*,*)"rotation scan" - ! Scan of rotation +c----------------------------------------------------------------------- +c rotation scan to locate torque-balance threshold. +c [BUG FLAG 8] the IF/ELSE block above that sets inQ_min/inQ_max +c is immediately overridden by the hardcoded values below. +c The conditional block is dead code. +c----------------------------------------------------------------------- + ! Override with fixed diagnostic range. inQ_max=10.0 inQ_min=-10.0 inum=200 @@ -799,26 +979,19 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) ENDDO - ! Identify the threshold from the maximum of the balance parameter - index=MAXLOC(bal) + ! Identify the threshold from the maximum of the balance parameter. + index=MAXLOC(bal) ! [BUG FLAG 1] shadows intrinsic Q_sol=inQs(index(1)) - !omega_sol=inQs(index(1))/Qconv br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0)) DEALLOCATE(inQs,deltal,jxbl,bal) - - WRITE(*,*)"allocating" +c----------------------------------------------------------------------- +c populate sl_in structure for output. +c----------------------------------------------------------------------- sl_in%qval_arr = (/ 3 /) - inQs = (/ 1.0 /) - inQs = (/ 1.0 /) n_k = SIZE(sl_in%qval_arr) - sl_in%qval_arr = (/ 3 /) - inQs = (/ 1.0 /) - inQs = (/ 1.0 /) - sl_in%omegas_arr = (/ 0.0 /) - !sl_in%Q_arr = (/ inQ /) sl_in%Q_e_arr = (/ inQ_e /) sl_in%Q_i_arr = (/ inQ_i /) sl_in%psi_n_arr = (/ 0.0 /) @@ -826,12 +999,10 @@ PROGRAM slayer sl_in%Im_dp_arr = (/ 0.0 /) sl_in%P_perp_arr = (/ inpr /) - WRITE(*,*)"allocations successful" - c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, c $ stabscan_eq_flag,stabscan_flag,br_th_flag) stop - ENDIF + ENDIF ! br_th_flag c----------------------------------------------------------------------- c find solutions based on simple torque balance. c----------------------------------------------------------------------- diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 45fdfef89..c9ed65329 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -1,275 +1,434 @@ -c----------------------------------------------------------------------- +c======================================================================= c file slayer_netcdf.f -c writes slayer information to a netcdf file -c----------------------------------------------------------------------- -c code organization. +c Writes SLAYER solver results to a NetCDF output file. +c +c The per-surface scalar inputs (Lundquist number, Q-normalisation, +c Prandtl numbers, …) and the solver outputs (growth rates, Delta +c values) are stored in a single NetCDF-3/64-bit-offset file named +c slayer_output_n.nc. +c +c Ragged AMR scan data (variable number of evaluation points per +c surface) are zero-padded into rectangular arrays before writing. +c +c BUG FLAG 1 -- Several NetCDF variable definitions that depend on +c `qsing_dim`, `i_dim`, and `nAMR_dim` sit OUTSIDE the +c `IF (msing > 0)` guard that creates those dimensions. If the +c subroutine is ever called with msing == 0, those dimension IDs +c will be uninitialised and the nf90_def_var calls will fail or +c produce undefined behaviour. +c Suggested fix: move all remaining nf90_def_var calls inside +c the `IF (msing > 0)` block, or add an early RETURN when +c msing == 0. +c +c BUG FLAG 2 -- `fill_val` is declared (-9.99E33) but never +c used; the rectangular buffers are initialised to 0.0 instead. +c Plotters that rely on a standard _FillValue attribute will +c not distinguish padding from real zeros. +c Suggested fix: initialise buffers with `fill_val` instead +c of 0.0, and add an nf90_put_att call to set the _FillValue +c attribute on the Q_AMR and Deltas_AMR variables. +c +c BUG FLAG 3 -- `Q_id` is created by nf90_def_var("Q", …) but +c the corresponding nf90_put_var is commented out, so the +c variable exists in the file but contains only fill values. +c Suggested fix: either remove the nf90_def_var or write the +c appropriate Q array. +c +c BUG FLAG 4 -- `c_b_id` (c_beta variable ID) is declared but +c never used in any nf90_def_var or nf90_put_var call; i.e. +c c_beta_arr is not written to the output file. +c Suggested fix: if c_beta is needed in the output, add the +c definition and write calls; otherwise remove c_b_id. +c +c BUG FLAG 5 -- `run`, `run_dimid`, `point_dimid`, `varids(4)`, +c `i`, `r_id`, and `r_dim` are declared but never referenced. +c Suggested fix: remove them. +c +c BUG FLAG 6 -- The `version` string is hardcoded to a specific +c git hash ('v1.0.0-99-gc873bd6'). For a public release this +c should be generated at build time (e.g. from `git describe` +c via a preprocessor macro). +c +c BUG FLAG 7 -- The subroutine writes to the module-level global +c `sn` (from sglobal_mod) as a side-effect of building the +c output filename. This is fragile — a local CHARACTER +c variable should be used instead to avoid polluting global +c state. +c======================================================================= c----------------------------------------------------------------------- -c 0. slayer_netcdf_mod -c 1. check -c 2. stride_netcdf_out +c code organisation. c----------------------------------------------------------------------- -c subprogram 0. slayer_netcdf_mod -c module declarations. +c 0. slayer_netcdf_mod -- module declarations +c 1. sl_check -- NetCDF status checker +c 2. slayer_netcdf_out -- main output routine c----------------------------------------------------------------------- +c c----------------------------------------------------------------------- -c declarations. +c subprogram 0. slayer_netcdf_mod. +c Module wrapper — imports sglobal_mod (shared types and globals) +c and the NetCDF Fortran-90 API. c----------------------------------------------------------------------- MODULE slayer_netcdf_mod + USE sglobal_mod USE netcdf + IMPLICIT NONE + CONTAINS -c ----------------------------------------------------------------------- +c c----------------------------------------------------------------------- -c subprogram 1. check. -c Check status of netcdf file. +c subprogram 1. sl_check. +c Assert that a NetCDF operation succeeded; abort with a message +c if it did not. c----------------------------------------------------------------------- SUBROUTINE sl_check(stat) c----------------------------------------------------------------------- -c declaration. +c declarations. c----------------------------------------------------------------------- - INTEGER, INTENT (IN) :: stat + INTEGER, INTENT(IN) :: stat ! return code from any nf90_* call c----------------------------------------------------------------------- -c stop if it is an error. +c check status and abort on error. c----------------------------------------------------------------------- - IF(stat /= nf90_noerr) THEN + IF (stat /= nf90_noerr) THEN PRINT *, TRIM(nf90_strerror(stat)) STOP "ERROR: failed to write/read netcdf file" ENDIF -c----------------------------------------------------------------------- -c terminate. -c----------------------------------------------------------------------- + RETURN END SUBROUTINE sl_check -c ----------------------------------------------------------------------- -c subprogram 2. slayer_netcdf_out. -c Replicate stride.out information in netcdf format. -c ----------------------------------------------------------------------- -c ----------------------------------------------------------------------- -c declarations. -c ----------------------------------------------------------------------- - SUBROUTINE slayer_netcdf_out(msing,m_AMR,est_gamma_flag, - $ sl_in,sl_out,all_deltas_out) - - INTEGER, INTENT(IN) :: msing,m_AMR - LOGICAL, INTENT(IN) :: est_gamma_flag - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in +c +c----------------------------------------------------------------------- +c subprogram 2. slayer_netcdf_out. +c Write per-surface SLAYER inputs and solver outputs to the +c NetCDF file slayer_output_n.nc . +c +c Arguments: +c msing -- number of rational surfaces +c m_AMR -- number of AMR-scanned surfaces +c est_gamma_flag -- .TRUE. to include estimated growth rates +c sl_in -- slayer_inputs_type (per-surface inputs) +c sl_out -- slayer_outputs_type (solver results) +c all_deltas_out -- array(m_AMR) of deltas_outputs_type (AMR +c scan results, potentially ragged) +c----------------------------------------------------------------------- + SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, + $ sl_in, sl_out, all_deltas_out) +c----------------------------------------------------------------------- +c declarations -- subroutine arguments. +c----------------------------------------------------------------------- + INTEGER, INTENT(IN) :: msing ! number of rational surfaces + INTEGER, INTENT(IN) :: m_AMR ! number of AMR surfaces + LOGICAL, INTENT(IN) :: est_gamma_flag ! include estimated gammas? + + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in TYPE(slayer_outputs_type), INTENT(IN) :: sl_out TYPE(deltas_outputs_type), INTENT(IN) :: all_deltas_out(m_AMR) - INTEGER :: i,ncid,r_id,qsing_dim,i_dim,r_dim,qr_id,omegas_id, - $ Q_id,Q_e_id,Q_i_id,d_b_id,c_b_id,Dnorm_id,p_perp_id,S_id, - $ pr_id,dpp_id,dc_id,dels_db_id,gs_id,ge_id,nAMR_dim, - $ qsing_id,qc_id,p_tor_id - - INTEGER :: run, run_dimid, point_dimid, varids(4) - - ! AMR declarations - INTEGER :: max_pts_all, s, n_curr - INTEGER :: dim_pts_id - INTEGER :: var_q_id, var_d_id, var_npts_id - REAL(r8), ALLOCATABLE :: buffer_q(:,:,:), buffer_d(:,:,:) - INTEGER, ALLOCATABLE :: n_pts_arr(:) - REAL(r8) :: fill_val = -9.99E33 ! Standard NetCDF Fill Value - ! AMR declarations - - CHARACTER(64) :: ncfile - LOGICAL, PARAMETER :: debug_flag = .FALSE. - CHARACTER(len=*), PARAMETER :: version ='v1.0.0-99-gc873bd6' -c ----------------------------------------------------------------------- -c set variables -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *,"Called slayer_netcdf_out" - IF (nn<10) THEN - WRITE(UNIT=sn,FMT='(I1)')nn - sn=ADJUSTL(sn) +c----------------------------------------------------------------------- +c declarations -- NetCDF file and dimension IDs. +c----------------------------------------------------------------------- + INTEGER :: ncid ! NetCDF file ID + INTEGER :: qsing_dim ! dim: rational surfaces (msing) + INTEGER :: nAMR_dim ! dim: AMR surfaces (m_AMR) + INTEGER :: i_dim ! dim: Re/Im component (2) + INTEGER :: dim_pts_id ! dim: max AMR eval points + +c----------------------------------------------------------------------- +c declarations -- NetCDF variable IDs. +c Each *_id holds the handle returned by nf90_def_var and is +c later passed to the matching nf90_put_var call. +c----------------------------------------------------------------------- + INTEGER :: qsing_id ! "r" — surface index + INTEGER :: qr_id ! "q_rational" — safety factor + INTEGER :: omegas_id ! "omegas" — rotation freq + INTEGER :: qc_id ! "tau_k" — Q-conversion + INTEGER :: Q_id ! "Q" (BUG FLAG 3) + INTEGER :: Q_e_id ! "Q_e" — norm Q_e + INTEGER :: Q_i_id ! "Q_i" — norm Q_i + INTEGER :: S_id ! "S" — Lundquist + INTEGER :: pr_id ! "psi_n_rational" — norm psi + INTEGER :: p_perp_id ! "P_perp" + INTEGER :: p_tor_id ! "P_tor" + INTEGER :: Dnorm_id ! "D" — normalised D + INTEGER :: dpp_id ! "Delta_prime_rational" (complex) + INTEGER :: dc_id ! "Delta_crit_rational" + INTEGER :: dels_db_id ! "delta_s_d_b" (complex) + INTEGER :: d_b_id ! "d_beta" + INTEGER :: gs_id ! "growth rate" (complex) + INTEGER :: ge_id ! "est. growth rate" (complex) + INTEGER :: c_b_id ! c_beta — (BUG FLAG 4: unused) + +c AMR variable IDs + INTEGER :: var_q_id ! "Q_AMR" — scan Q-points + INTEGER :: var_d_id ! "Deltas_AMR" — scan Delta values + INTEGER :: var_npts_id ! "n_amr_pts" — points per surface + +c----------------------------------------------------------------------- +c declarations -- AMR rectangular-buffer workspace. +c The ragged per-surface scan data are padded into fixed-size +c rectangular arrays before writing to NetCDF. +c----------------------------------------------------------------------- + INTEGER :: max_pts_all ! max points across surfaces + INTEGER :: s ! surface loop index + INTEGER :: n_curr ! points on current surface + REAL(r8), ALLOCATABLE :: buffer_q(:,:,:) ! (pts, surf, Re/Im) + REAL(r8), ALLOCATABLE :: buffer_d(:,:,:) ! (pts, surf, Re/Im) + INTEGER, ALLOCATABLE :: n_pts_arr(:) ! points per surface + REAL(r8) :: fill_val = -9.99d33 ! (BUG FLAG 2: declared, unused) + +c----------------------------------------------------------------------- +c declarations -- miscellaneous locals. +c----------------------------------------------------------------------- + CHARACTER(64) :: ncfile ! output file name + LOGICAL, PARAMETER :: debug_flag = .FALSE. ! verbose trace + CHARACTER(len=*), PARAMETER :: + $ version = 'v1.0.0-99-gc873bd6' ! (BUG FLAG 6) + +c----------------------------------------------------------------------- +c build the output filename from the toroidal mode number. +c Note: writes to the module-level global `sn` (BUG FLAG 7). +c----------------------------------------------------------------------- + IF (debug_flag) PRINT *, "Called slayer_netcdf_out" + + IF (nn < 10) THEN + WRITE(UNIT=sn, FMT='(I1)') nn + sn = ADJUSTL(sn) ELSE - WRITE(UNIT=sn,FMT='(I2)')nn + WRITE(UNIT=sn, FMT='(I2)') nn ENDIF ncfile = "slayer_output_n"//TRIM(sn)//".nc" - IF(debug_flag) PRINT *, ncfile -c ----------------------------------------------------------------------- -c open files -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Creating netcdf files" + IF (debug_flag) PRINT *, ncfile + +c----------------------------------------------------------------------- +c create the NetCDF file (clobber any existing file). +c----------------------------------------------------------------------- + IF (debug_flag) PRINT *, " - Creating netcdf file" CALL sl_check( nf90_create(ncfile, - $ cmode=or(NF90_CLOBBER,NF90_64BIT_OFFSET), ncid=ncid) ) -c -c reform "ragged" AMR delta ouputs into rectangular array + $ cmode=OR(NF90_CLOBBER, NF90_64BIT_OFFSET), ncid=ncid) ) + +c----------------------------------------------------------------------- +c reform ragged AMR Delta outputs into rectangular arrays. c +c Each surface may have a different number of AMR scan points. +c We find the maximum, allocate rectangular buffers of that size, +c and copy in the per-surface data. Unused trailing slots are +c filled with 0.0 (should be fill_val — see BUG FLAG 2). +c----------------------------------------------------------------------- - ! 1. Find the Maximum AMR Grid Size across all surfaces +c step 1: find the maximum AMR grid size across all surfaces. max_pts_all = 0 IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN - DO s = 1, m_AMR - max_pts_all = MAX(max_pts_all,SIZE(all_deltas_out(s)%inQs)) - END DO + DO s = 1, m_AMR + max_pts_all = MAX(max_pts_all, + $ SIZE(all_deltas_out(s)%inQs)) + END DO END IF - ! 2. Allocate Rectangular Buffers (Points, Surfaces, Re/Im) - ! Shape: (Max_Points, Number_Surfaces, 2) +c step 2: allocate rectangular buffers (pts × surfaces × Re/Im). ALLOCATE(buffer_q(max_pts_all, m_AMR, 2)) ALLOCATE(buffer_d(max_pts_all, m_AMR, 2)) ALLOCATE(n_pts_arr(m_AMR)) - - ! Initialize with Fill Value (so unused space is ignored by plotters) - buffer_q = 0.0 - buffer_d = 0.0 + + buffer_q = 0.0d0 ! padding value (see BUG FLAG 2) + buffer_d = 0.0d0 n_pts_arr = 0 - - ! 3. Flatten the Ragged Data into the Buffers + +c step 3: flatten the ragged data into the buffers. IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN - DO s = 1, m_AMR - n_curr = SIZE(all_deltas_out(s)%inQs) - n_pts_arr(s) = n_curr - - ! --- FILL Q (Coordinate) --- - ! Real part (inQs) -> Index 1 - buffer_q(1:n_curr,s,1) = all_deltas_out(s)%inQs(1:n_curr) - ! Imag part (iinQs) -> Index 2 - buffer_q(1:n_curr,s,2) = all_deltas_out(s)%iinQs(1:n_curr) - - ! --- FILL DELTA (Result) --- - ! Real part -> Index 1 - buffer_d(1:n_curr,s,1)=all_deltas_out(s)%real_deltas(1:n_curr) - ! Imag part -> Index 2 - buffer_d(1:n_curr,s,2)=all_deltas_out(s)%imag_deltas(1:n_curr) - END DO + DO s = 1, m_AMR + n_curr = SIZE(all_deltas_out(s)%inQs) + n_pts_arr(s) = n_curr + +c Q-coordinate (Re and Im parts) + buffer_q(1:n_curr, s, 1) = + $ all_deltas_out(s)%inQs(1:n_curr) + buffer_q(1:n_curr, s, 2) = + $ all_deltas_out(s)%iinQs(1:n_curr) + +c Delta result (Re and Im parts) + buffer_d(1:n_curr, s, 1) = + $ all_deltas_out(s)%real_deltas(1:n_curr) + buffer_d(1:n_curr, s, 2) = + $ all_deltas_out(s)%imag_deltas(1:n_curr) + END DO END IF -c ----------------------------------------------------------------------- -c define global file attributes -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Defining netcdf globals" - CALL sl_check( nf90_put_att(ncid,nf90_global,"title", - $ "SLAYER outputs")) - !CALL sl_check( nf90_put_att(ncid,nf90_global,"shot", INT(shotnum)) ) - !CALL sl_check( nf90_put_att(ncid,nf90_global,"time",INT(shottime)) ) - !CALL sl_check( nf90_put_att(ncid,nf90_global,"n", nn)) - CALL sl_check( nf90_put_att(ncid,nf90_global,"version", version)) - ! define global attributes - ! define dimensions - IF(debug_flag) PRINT *," - Defining dimensions in netcdf" - - !WRITE(*,*)"netcdf qval=",qval - WRITE(*,*)">>> Writing results to NetCDF output file" - - !CALL check( nf90_def_dim(ncid,"r",msing,r_dim) ) - !CALL check( nf90_def_var(ncid,"r",nf90_int,r_dim,r_id)) - IF(msing>0)THEN - CALL sl_check( nf90_def_dim(ncid,"r",msing,qsing_dim) ) !r_dim = q_rational - CALL sl_check( nf90_def_dim(ncid,"r_AMR",m_AMR, - $ nAMR_dim) ) !r_dim = q_rational - CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) - CALL sl_check( nf90_def_var(ncid,"r",nf90_int, - $ qsing_dim,qsing_id)) - CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_int, - $ qsing_dim,qr_id)) - CALL sl_check( nf90_def_var(ncid,"omegas",nf90_double, - $ qsing_dim,omegas_id)) - CALL sl_check( nf90_def_var(ncid,"tau_k",nf90_double, - $ qsing_dim,qc_id)) - CALL sl_check( nf90_def_var(ncid,"Q",nf90_double, - $ qsing_dim,Q_id)) - CALL sl_check( nf90_def_var(ncid,"Q_e",nf90_double, - $ qsing_dim,Q_e_id)) - CALL sl_check( nf90_def_var(ncid,"Q_i",nf90_double, - $ qsing_dim,Q_i_id)) - CALL sl_check( nf90_def_var(ncid,"S",nf90_double, - $ qsing_dim,S_id)) - CALL sl_check( nf90_def_var(ncid,"psi_n_rational", - $ nf90_double,qsing_dim,pr_id) ) - CALL sl_check( nf90_def_var(ncid,"P_perp",nf90_double, - $ qsing_dim,p_perp_id) ) - CALL sl_check( nf90_def_var(ncid,"P_tor",nf90_double, - $ qsing_dim,p_tor_id) ) - !CALL sl_check( nf90_def_var(ncid,"q_rational",nf90_double, - !$ qsing_dim,qr_id) ) + +c----------------------------------------------------------------------- +c define global file attributes. +c----------------------------------------------------------------------- + IF (debug_flag) PRINT *, " - Defining netcdf globals" + CALL sl_check( nf90_put_att(ncid, nf90_global, + $ "title", "SLAYER outputs") ) + CALL sl_check( nf90_put_att(ncid, nf90_global, + $ "version", version) ) + +c----------------------------------------------------------------------- +c define dimensions and per-surface NetCDF variables. +c +c All definitions below require msing > 0 because the "r" +c dimension is sized by msing. (See BUG FLAG 1 for remaining +c def_var calls that sit outside this guard.) +c----------------------------------------------------------------------- + IF (debug_flag) PRINT *, " - Defining dimensions in netcdf" + WRITE(*,*) ">>> Writing results to NetCDF output file" + + IF (msing > 0) THEN + +c -- core dimensions -- + CALL sl_check( nf90_def_dim(ncid, "r", msing, qsing_dim) ) + CALL sl_check( nf90_def_dim(ncid, "r_AMR", m_AMR, nAMR_dim) ) + CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) + +c -- scalar per-surface variables -- + CALL sl_check( nf90_def_var(ncid, "r", nf90_int, + $ qsing_dim, qsing_id) ) + CALL sl_check( nf90_def_var(ncid, "q_rational", nf90_int, + $ qsing_dim, qr_id) ) + CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, + $ qsing_dim, omegas_id) ) + CALL sl_check( nf90_def_var(ncid, "tau_k", nf90_double, + $ qsing_dim, qc_id) ) + CALL sl_check( nf90_def_var(ncid, "Q", nf90_double, + $ qsing_dim, Q_id) ) ! BUG FLAG 3: defined but not written + CALL sl_check( nf90_def_var(ncid, "Q_e", nf90_double, + $ qsing_dim, Q_e_id) ) + CALL sl_check( nf90_def_var(ncid, "Q_i", nf90_double, + $ qsing_dim, Q_i_id) ) + CALL sl_check( nf90_def_var(ncid, "S", nf90_double, + $ qsing_dim, S_id) ) + CALL sl_check( nf90_def_var(ncid, "psi_n_rational", + $ nf90_double, qsing_dim, pr_id) ) + CALL sl_check( nf90_def_var(ncid, "P_perp", nf90_double, + $ qsing_dim, p_perp_id) ) + CALL sl_check( nf90_def_var(ncid, "P_tor", nf90_double, + $ qsing_dim, p_tor_id) ) + END IF - CALL sl_check( nf90_def_var(ncid,"D",nf90_double, - $ qsing_dim,Dnorm_id) ) - CALL sl_check( nf90_def_var(ncid,"Delta_prime_rational", - $ nf90_double,(/qsing_dim,i_dim/),dpp_id) ) - CALL sl_check( nf90_def_var(ncid,"Delta_crit_rational", - $ nf90_double,qsing_dim,dc_id) ) +c----------------------------------------------------------------------- +c define additional variables that also depend on qsing_dim / i_dim +c (BUG FLAG 1 — these will fail if msing == 0). +c----------------------------------------------------------------------- + CALL sl_check( nf90_def_var(ncid, "D", nf90_double, + $ qsing_dim, Dnorm_id) ) + CALL sl_check( nf90_def_var(ncid, "Delta_prime_rational", + $ nf90_double, (/qsing_dim, i_dim/), dpp_id) ) + CALL sl_check( nf90_def_var(ncid, "Delta_crit_rational", + $ nf90_double, qsing_dim, dc_id) ) IF (est_gamma_flag) THEN - CALL sl_check( nf90_def_var(ncid,"delta_s_d_b",nf90_double, - $ (/qsing_dim,i_dim/),dels_db_id) ) - CALL sl_check( nf90_def_var(ncid,"d_beta",nf90_double, - $ qsing_dim,d_b_id) ) - CALL sl_check( nf90_def_var(ncid,"est. growth rate", - $ nf90_double,(/qsing_dim,i_dim/),ge_id) ) + CALL sl_check( nf90_def_var(ncid, "delta_s_d_b", + $ nf90_double, (/qsing_dim, i_dim/), dels_db_id) ) + CALL sl_check( nf90_def_var(ncid, "d_beta", nf90_double, + $ qsing_dim, d_b_id) ) + CALL sl_check( nf90_def_var(ncid, "est. growth rate", + $ nf90_double, (/qsing_dim, i_dim/), ge_id) ) END IF - CALL sl_check( nf90_def_var(ncid,"growth rate", - $ nf90_double,(/qsing_dim,i_dim/),gs_id) ) - - !!! AMR - CALL sl_check(nf90_def_dim(ncid, 'amr_pts', max_pts_all, - $ dim_pts_id)) - ! Define Variables - CALL sl_check(nf90_def_var(ncid, 'n_amr_pts', NF90_INT, - $ (/qsing_dim/), var_npts_id)) - ! Note: Dimensions order is (pts, surf, cplx) - CALL sl_check(nf90_def_var(ncid, 'Q_AMR', NF90_DOUBLE, - $ (/dim_pts_id, nAMR_dim, i_dim/), var_q_id)) - CALL sl_check(nf90_def_var(ncid, 'Deltas_AMR', NF90_DOUBLE, - $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id)) - - ! end definitions + CALL sl_check( nf90_def_var(ncid, "growth rate", + $ nf90_double, (/qsing_dim, i_dim/), gs_id) ) + +c----------------------------------------------------------------------- +c define AMR scan dimensions and variables. +c (BUG FLAG 1 — also uses qsing_dim, nAMR_dim, i_dim.) +c----------------------------------------------------------------------- + CALL sl_check( nf90_def_dim(ncid, "amr_pts", + $ max_pts_all, dim_pts_id) ) + CALL sl_check( nf90_def_var(ncid, "n_amr_pts", NF90_INT, + $ (/qsing_dim/), var_npts_id) ) + CALL sl_check( nf90_def_var(ncid, "Q_AMR", NF90_DOUBLE, + $ (/dim_pts_id, nAMR_dim, i_dim/), var_q_id) ) + CALL sl_check( nf90_def_var(ncid, "Deltas_AMR", NF90_DOUBLE, + $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id) ) + +c----------------------------------------------------------------------- +c end NetCDF define mode. +c----------------------------------------------------------------------- CALL sl_check( nf90_enddef(ncid) ) -c ----------------------------------------------------------------------- -c set variables -c ----------------------------------------------------------------------- - CALL sl_check( nf90_put_var(ncid,qsing_id, sl_in%qval_arr)) - CALL sl_check( nf90_put_var(ncid,qr_id, sl_in%qval_arr)) - CALL sl_check( nf90_put_var(ncid,pr_id, sl_in%psi_n_arr)) - CALL sl_check( nf90_put_var(ncid,omegas_id, sl_in%omegas_arr)) - CALL sl_check( nf90_put_var(ncid,S_id, sl_in%lu_arr)) - CALL sl_check( nf90_put_var(ncid,qc_id, sl_in%Qconv_arr)) - !CALL sl_check( nf90_put_var(ncid,Q_id, Q_arr)) - CALL sl_check( nf90_put_var(ncid,Q_e_id, sl_in%Q_e_arr)) - CALL sl_check( nf90_put_var(ncid,Q_i_id, sl_in%Q_i_arr)) - CALL sl_check( nf90_put_var(ncid,p_perp_id, sl_in%P_perp_arr)) - CALL sl_check( nf90_put_var(ncid,p_tor_id, sl_in%P_tor_arr)) - CALL sl_check( nf90_put_var(ncid,Dnorm_id, sl_in%D_norm_arr)) - - CALL sl_check( nf90_put_var(ncid,dpp_id, - $ RESHAPE((/sl_in%Re_dp_arr,sl_in%Im_dp_arr/), - $ (/msing,2/)))) - CALL sl_check( nf90_put_var(ncid,dc_id,sl_in%d_crit_arr)) +c----------------------------------------------------------------------- +c write per-surface scalar variables. +c----------------------------------------------------------------------- + CALL sl_check( nf90_put_var(ncid, qsing_id, + $ sl_in%qval_arr) ) + CALL sl_check( nf90_put_var(ncid, qr_id, + $ sl_in%qval_arr) ) + CALL sl_check( nf90_put_var(ncid, pr_id, + $ sl_in%psi_n_arr) ) + CALL sl_check( nf90_put_var(ncid, omegas_id, + $ sl_in%omegas_arr)) + CALL sl_check( nf90_put_var(ncid, S_id, + $ sl_in%lu_arr) ) + CALL sl_check( nf90_put_var(ncid, qc_id, + $ sl_in%Qconv_arr) ) + CALL sl_check( nf90_put_var(ncid, Q_e_id, + $ sl_in%Q_e_arr) ) + CALL sl_check( nf90_put_var(ncid, Q_i_id, + $ sl_in%Q_i_arr) ) + CALL sl_check( nf90_put_var(ncid, p_perp_id, + $ sl_in%P_perp_arr)) + CALL sl_check( nf90_put_var(ncid, p_tor_id, + $ sl_in%P_tor_arr) ) + CALL sl_check( nf90_put_var(ncid, Dnorm_id, + $ sl_in%D_norm_arr)) + +c----------------------------------------------------------------------- +c write complex Delta' as a RESHAPE'd (msing, 2) real array. +c----------------------------------------------------------------------- + CALL sl_check( nf90_put_var(ncid, dpp_id, + $ RESHAPE( (/sl_in%Re_dp_arr, sl_in%Im_dp_arr/), + $ (/msing, 2/) )) ) + CALL sl_check( nf90_put_var(ncid, dc_id, + $ sl_in%d_crit_arr) ) + +c----------------------------------------------------------------------- +c write estimated growth-rate outputs (only when requested). +c----------------------------------------------------------------------- IF (est_gamma_flag) THEN - CALL sl_check( nf90_put_var(ncid,dels_db_id, - $ RESHAPE((/REAL(sl_out%dels_db_arr), - $ AIMAG(sl_out%dels_db_arr)/),(/msing,2/)))) - - CALL sl_check( nf90_put_var(ncid,d_b_id,sl_in%d_beta_arr)) - CALL sl_check( nf90_put_var(ncid,ge_id, - $ RESHAPE((/REAL(sl_out%gamma_est_arr), - $ AIMAG(sl_out%gamma_est_arr)/),(/msing,2/)))) + CALL sl_check( nf90_put_var(ncid, dels_db_id, + $ RESHAPE( (/REAL(sl_out%dels_db_arr), + $ AIMAG(sl_out%dels_db_arr)/), + $ (/msing, 2/) )) ) + + CALL sl_check( nf90_put_var(ncid, d_b_id, + $ sl_in%d_beta_arr) ) + + CALL sl_check( nf90_put_var(ncid, ge_id, + $ RESHAPE( (/REAL(sl_out%gamma_est_arr), + $ AIMAG(sl_out%gamma_est_arr)/), + $ (/msing, 2/) )) ) END IF - CALL sl_check( nf90_put_var(ncid,gs_id, - $ RESHAPE((/REAL(sl_out%gamma_sol_arr), - $ AIMAG(sl_out%gamma_sol_arr)/),(/msing,2/)))) +c----------------------------------------------------------------------- +c write solved growth rate (always present). +c----------------------------------------------------------------------- + CALL sl_check( nf90_put_var(ncid, gs_id, + $ RESHAPE( (/REAL(sl_out%gamma_sol_arr), + $ AIMAG(sl_out%gamma_sol_arr)/), + $ (/msing, 2/) )) ) - CALL sl_check(nf90_put_var(ncid, var_npts_id, n_pts_arr)) - CALL sl_check(nf90_put_var(ncid, var_q_id, buffer_q)) - CALL sl_check(nf90_put_var(ncid, var_d_id, buffer_d)) +c----------------------------------------------------------------------- +c write AMR scan arrays. +c----------------------------------------------------------------------- + CALL sl_check( nf90_put_var(ncid, var_npts_id, n_pts_arr) ) + CALL sl_check( nf90_put_var(ncid, var_q_id, buffer_q) ) + CALL sl_check( nf90_put_var(ncid, var_d_id, buffer_d) ) - ! 6. Clean Up +c----------------------------------------------------------------------- +c deallocate AMR rectangular buffers. +c----------------------------------------------------------------------- DEALLOCATE(buffer_q, buffer_d, n_pts_arr) -c ----------------------------------------------------------------------- -c close file -c ----------------------------------------------------------------------- - IF(debug_flag) PRINT *," - Closing netcdf file" +c----------------------------------------------------------------------- +c close the NetCDF file. +c----------------------------------------------------------------------- + IF (debug_flag) PRINT *, " - Closing netcdf file" CALL sl_check( nf90_close(ncid) ) -c ----------------------------------------------------------------------- -c terminate. -c ----------------------------------------------------------------------- + +c----------------------------------------------------------------------- +c terminate. +c----------------------------------------------------------------------- RETURN END SUBROUTINE slayer_netcdf_out END MODULE slayer_netcdf_mod \ No newline at end of file From e5397cb8ad744383e54eeb1e8766176e19fc2ce9 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Sat, 14 Feb 2026 00:23:28 -0500 Subject: [PATCH 056/118] WIP: fix line excursion --- slayer/layerinputs.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index c9756bce0..e0f0b2093 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -279,17 +279,20 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, ELSE IF (wegt == 1) THEN DO itheta = 0, fs-1 issurfint = issurfint - $ + inr(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + $ + inr(itheta)*jacs(itheta)*delpsi(itheta)* + $ func(itheta)/fs ENDDO ELSE IF (wegt == 2) THEN DO itheta = 0, fs-1 issurfint = issurfint - $ + jacs(itheta)*delpsi(itheta)*func(itheta)/inr(itheta)/fs + $ + jacs(itheta)*delpsi(itheta)* + $ func(itheta)/inr(itheta)/fs ENDDO ELSE IF (wegt == 3) THEN DO itheta = 0, fs-1 issurfint = issurfint - $ + ina(itheta)*jacs(itheta)*delpsi(itheta)*func(itheta)/fs + $ + ina(itheta)*jacs(itheta)*delpsi(itheta)* + $ func(itheta)/fs ENDDO ELSE STOP 'ERROR: issurfint wegt must be in [0,1,2,3]' From aca19c5dc12bb3c03137e680bc9befabe6646a50 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 00:33:11 -0500 Subject: [PATCH 057/118] WIP: bug fixes --- slayer/delta.f | 9 ++------- slayer/params.f | 1 - slayer/sglobal.f | 2 +- slayer/slayer.f | 17 ++++------------- 4 files changed, 7 insertions(+), 22 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index aff31a2c8..0c673fa74 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -172,22 +172,17 @@ END FUNCTION riccati c BUG FLAG 4: variables y, dy, xfac, xintv, ml, mu, nrpd are c declared but never used -- remove them. c----------------------------------------------------------------------- - FUNCTION riccati_del_s(inQ,inQ_e,inQ_i,inpr,inc_beta,ind_beta, - $ intau,inx,iny) + FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) c --- input arguments - REAL(r8),INTENT(IN) :: inQ ! (UNUSED -- see BUG FLAG 3) REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq REAL(r8),INTENT(IN) :: inpr ! mapped to P_perp (see below) - REAL(r8),INTENT(IN) :: inc_beta ! (UNUSED -- see BUG FLAG 3) - REAL(r8),INTENT(IN) :: ind_beta ! (UNUSED -- see BUG FLAG 3) - REAL(r8),INTENT(IN) :: intau ! (UNUSED -- see BUG FLAG 3) c --- optional arguments c BUG FLAG 5: inx is declared OPTIONAL but my_q=inx is accessed c unconditionally. If inx is ever absent, this will crash. c Either make inx required or add IF(present(inx)) guard. - REAL(r8),INTENT(IN),OPTIONAL :: inx ! starting q for integration + REAL(r8),INTENT(IN) :: inx ! starting q for integration COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W c --- function result COMPLEX(r8) :: riccati_del_s diff --git a/slayer/params.f b/slayer/params.f index c68e0032e..4cde1f332 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -180,7 +180,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c --- dead code end (BUG FLAG 3) --- c effective perpendicular and toroidal Prandtl numbers - tau_perp = (rs**2.0) / chis(1) P_perp = tau_r / tau_perp ! perp magnetic Prandtl number tau_tor = (rs**2.0) / chis(2) diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 7c94683c9..8855c00c6 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -82,7 +82,7 @@ MODULE sglobal_mod c --- normalised layer parameters REAL(r8) :: ds ! normalised ion Larmor radius REAL(r8) :: c_beta ! compressional beta parameter - REAL(r8) :: D_norm ! normalised beta-related width + REAL(r8) :: D_norm ! normalised beta-weighted ion scale REAL(r8) :: delta_n ! Delta normalisation factor REAL(r8) :: Qconv ! frequency normalisation (Cole) c --- diamagnetic and rotation frequencies diff --git a/slayer/slayer.f b/slayer/slayer.f index 000bbf1a4..af088d7a8 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -86,7 +86,7 @@ PROGRAM slayer REAL(r8) :: t_e ! electron temperature [eV] REAL(r8) :: t_i ! ion temperature [eV] REAL(r8) :: omega ! toroidal rotation [rad/s] - REAL(r8) :: omega0 ! (unused, see BUG FLAG 2) + REAL(r8) :: omega0 ! unused REAL(r8) :: l_n ! density gradient scale length REAL(r8) :: l_t ! temperature gradient scale length REAL(r8) :: qval ! safety factor at surface @@ -119,11 +119,7 @@ PROGRAM slayer REAL(r8) :: Q0 ! unperturbed rotation frequency REAL(r8) :: Q_sol ! solved rotation frequency REAL(r8) :: br_th ! radial field threshold - REAL(r8) :: d_b ! (unused, see BUG FLAG 2) - REAL(r8) :: Residual ! (unused, see BUG FLAG 2) REAL(r8) :: Qratio ! Q_e/Q ratio for scan2 variants - REAL(r8) :: spot ! (unused, see BUG FLAG 2) - REAL(r8) :: slayer_inpr ! (unused, see BUG FLAG 2) c----------------------------------------------------------------------- c local scalars — scan grid helpers. c----------------------------------------------------------------------- @@ -133,8 +129,6 @@ PROGRAM slayer REAL(r8) :: ing_step ! growth-rate grid step REAL(r8) :: ing_coarse ! Re(gamma) grid value REAL(r8) :: iing_coarse ! Im(gamma) grid value - REAL(r8) :: delta_real ! (unused, see BUG FLAG 2) - REAL(r8) :: delta_imag ! (unused, see BUG FLAG 2) c----------------------------------------------------------------------- c local scalars — complex quantities. c----------------------------------------------------------------------- @@ -142,11 +136,8 @@ PROGRAM slayer COMPLEX(r8) :: delta_n_p ! Deltaprime scale factor COMPLEX(r8) :: dels_db ! delta_s / d_beta COMPLEX(r8) :: del_s ! delta_s - COMPLEX(r8) :: lar_gamma ! (unused, see BUG FLAG 2) - COMPLEX(r8) :: tmp_gamma ! (unused, see BUG FLAG 2) COMPLEX(r8) :: ingamma ! initial gamma guess (namelist) COMPLEX(r8) :: delta_prime ! external Deltaprime (namelist) - COMPLEX(r8) :: det_val ! (unused, see BUG FLAG 2) c----------------------------------------------------------------------- c local arrays — transport profile coefficients. c----------------------------------------------------------------------- @@ -554,13 +545,13 @@ PROGRAM slayer $ 'estimate on q = ', $ sl_in%qval_arr(k),' rational surface' + D_norm = sl_in%D_norm_arr(k) ! [BUG FLAG 4] first argument to riccati_del_s is Q_e_arr, ! not Q_arr. Comment "NOT using Q_arr" is original. ! Verify this is intentional (Q_e used as ExB frequency). - dels_db=riccati_del_s(sl_in%Q_e_arr(k),sl_in%Q_e_arr(k), + dels_db=riccati_del_s(sl_in%Q_e_arr(k), $ sl_in%Q_i_arr(k),sl_in%P_perp_arr(k), - $ sl_in%c_beta_arr(k),sl_in%D_norm_arr(k), - $ sl_in%tau_arr(k),5.0*sl_in%D_norm_arr(k)) + $ 5.0*sl_in%D_norm_arr(k)) del_s = dels_db * sl_in%d_beta_arr(k) From c658f457db4c19d97194729fbdd2dc8285bc7f4d Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 00:55:07 -0500 Subject: [PATCH 058/118] WIP: fix NF90_GLOBAL integers in read_stride --- slayer/delta.f | 5 +---- slayer/layerinputs.f | 33 ++++++++++++++++++--------------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 0c673fa74..0ad68b1dc 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -179,9 +179,6 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq REAL(r8),INTENT(IN) :: inpr ! mapped to P_perp (see below) c --- optional arguments -c BUG FLAG 5: inx is declared OPTIONAL but my_q=inx is accessed -c unconditionally. If inx is ever absent, this will crash. -c Either make inx required or add IF(present(inx)) guard. REAL(r8),INTENT(IN) :: inx ! starting q for integration COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W c --- function result @@ -228,7 +225,7 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) c --- set starting integration point my_q=inx ! start backwards integration at large q xmin=1e-5 - IF(present(inx)) x=inx + x=inx xout=xmin c --- copy input arguments to module-level globals for w_der_del_s diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index e0f0b2093..5fd3702e7 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -78,9 +78,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, INTEGER(kind=nf90_int) :: r_dim_id, r_dim ! dimension id / length (unused) INTEGER(kind=nf90_int) :: dp_id, qr_id, pr_id ! variable ids INTEGER(kind=nf90_int) :: dgeo_id, shear_id ! variable ids - INTEGER(kind=nf90_int) :: ro_id, bt0_id, psio_id ! attribute ids (see BUG FLAG 1) - INTEGER(kind=nf90_int) :: mpsi_id, msing_id ! attribute ids - INTEGER(kind=nf90_int) :: nn_id, resm_id, drr_id ! variable / attribute ids + INTEGER(kind=nf90_int) :: resm_id, drr_id ! variable ids INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! NetCDF hyperslab INTEGER :: i ! loop index INTEGER :: bt0_len, ro_len, psio_len ! attribute lengths @@ -95,11 +93,11 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) c --- read msing (number of singular surfaces) from global attribute - stat = nf90_inquire_attribute(ncid, msing_id, 'msing', + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'msing', $ len = msing_len) CALL sl_check(stat) ALLOCATE(msing_arr(msing_len)) - stat = nf90_get_att(ncid, msing_id, 'msing', msing_arr) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'msing', msing_arr) CALL sl_check(stat) msing = INT(msing_arr(1)) @@ -110,15 +108,20 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, ALLOCATE(dp_mat(msing, msing, 2)) c --- read lengths of scalar / small-array global attributes - stat = nf90_inquire_attribute(ncid, ro_id, 'ro', len=ro_len) + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'ro', + $ len=ro_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid, bt0_id, 'bt0', len=bt0_len) + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'bt0', + $ len=bt0_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid, psio_id, 'psio', len=psio_len) + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'psio', + $ len=psio_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid, mpsi_id, 'mpsi', len=mpsi_len) + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'mpsi', + $ len=mpsi_len) CALL sl_check(stat) - stat = nf90_inquire_attribute(ncid, nn_id, 'n', len=nn_len) + stat = nf90_inquire_attribute(ncid, NF90_GLOBAL, 'n', + $ len=nn_len) CALL sl_check(stat) ALLOCATE(my_bt0(INT(bt0_len)), r_o(INT(ro_len)), @@ -142,15 +145,15 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) c --- read global attributes (equilibrium scalars) - stat = nf90_get_att(ncid, ro_id, 'ro', r_o) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'ro', r_o) CALL sl_check(stat) - stat = nf90_get_att(ncid, bt0_id, 'bt0', my_bt0) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'bt0', my_bt0) CALL sl_check(stat) - stat = nf90_get_att(ncid, psio_id, 'psio', my_psio) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'psio', my_psio) CALL sl_check(stat) - stat = nf90_get_att(ncid, mpsi_id, 'mpsi', mpsi) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'mpsi', mpsi) CALL sl_check(stat) - stat = nf90_get_att(ncid, nn_id, 'n', nn) + stat = nf90_get_att(ncid, NF90_GLOBAL, 'n', nn) CALL sl_check(stat) c --- read variable data: Deltaprime matrix and 1-D surface arrays From a42fc489fca86204a6d33e1308879a0a262a2fd4 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 01:06:35 -0500 Subject: [PATCH 059/118] WIP: working on params bug --- slayer/params.f | 22 ++++++++-------------- slayer/slayer.f | 4 ++++ 2 files changed, 12 insertions(+), 14 deletions(-) diff --git a/slayer/params.f b/slayer/params.f index 4cde1f332..01479c038 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -159,25 +159,19 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- c Plasma beta and Prandtl-number-like transport ratios. -c -c BUG FLAG 3 -- The K_val/Csq block (kappa-based P_perp) is -c immediately overridden by the tau_perp definition below it, -c so K_val and the IF(ABS(Csq)>0) branch are dead code. -c Either remove the dead block or delete the override. c----------------------------------------------------------------------- lbeta = (5.0/3.0)*mu0*n_e*chag*(t_e+t_i) / bt**2.0 c_beta = (lbeta / (1.0+lbeta))**0.5 -c --- dead code begin (BUG FLAG 3) --- - K_val = chis(3) / eta - Csq = c_beta**2.0 + (1.0 - c_beta**2.0)*K_val +c kappa-based P_perp (JKP's definition, to implement later if desired) +c K_val = chis(3) / eta +c Csq = c_beta**2.0 + (1.0 - c_beta**2.0)*K_val - IF (ABS(Csq) > 0.0) THEN - P_perp = Csq - ELSE - tau_perp = (rs**2.0) / chis(1) - END IF -c --- dead code end (BUG FLAG 3) --- +c IF (ABS(Csq) > 0.0) THEN +c P_perp = Csq +c ELSE +c tau_perp = (rs**2.0) / chis(1) +c END IF c effective perpendicular and toroidal Prandtl numbers P_perp = tau_r / tau_perp ! perp magnetic Prandtl number diff --git a/slayer/slayer.f b/slayer/slayer.f index af088d7a8..44833456c 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -602,6 +602,10 @@ PROGRAM slayer chis(2) = chi_t_prof(1) ! chi_tor chis(3) = kappa_prof(1) ! kappa (thermal cond.) + WRITE(*,*)"chis(1) (chi_perp): ",chis(1) + WRITE(*,*)"chis(2) (chi_tor): ",chis(2) + WRITE(*,*)"chis(3) (kappa): ",chis(3) + ! Use namelist kinetic inputs instead of equilibrium files CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) From 4f5a7d9a1356472f1b71b84fb32a0aa1e70204fc Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Thu, 19 Feb 2026 02:01:30 -0500 Subject: [PATCH 060/118] WIP: fix tau_perp bug, m_AMR bug --- slayer/params.f | 1 + slayer/slayer.f | 8 +++++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/slayer/params.f b/slayer/params.f index 01479c038..b94ea419f 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -174,6 +174,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c END IF c effective perpendicular and toroidal Prandtl numbers + tau_perp = (rs**2.0) / chis(1) P_perp = tau_r / tau_perp ! perp magnetic Prandtl number tau_tor = (rs**2.0) / chis(2) diff --git a/slayer/slayer.f b/slayer/slayer.f index 44833456c..cf7f78bb5 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -667,9 +667,11 @@ PROGRAM slayer END IF IF (AMR_flag) THEN - m_AMR = 1 - ELSE - m_AMR = MIN(n_k,msing_max) + IF (coupling_flag) THEN + m_AMR = 1 + ELSE + m_AMR = MIN(n_k,msing_max) + END IF END IF WRITE(*,*),"Rational q domain: ",sl_in%qval_arr From 7390807e43f2b490d537da7aea68aa2e4a998d36 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 02:06:39 -0500 Subject: [PATCH 061/118] WIP: delta.f speedup attempt --- slayer/delta.f | 121 +++++++++++++++++++++++++------------------------ 1 file changed, 63 insertions(+), 58 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 0ad68b1dc..e32ef078a 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -346,10 +346,11 @@ FUNCTION riccati_f(tmp_g,inx) c --- lsode solver control INTEGER :: istep ! integration step counter - INTEGER :: neq ! number of equations (=2) + INTEGER, PARAMETER :: neq = 2 ! number of equations INTEGER :: itol,itask ! lsode tolerance/task flags INTEGER :: istate,iopt,mf ! lsode state/option/method flags - INTEGER :: liw,lrw ! lsode work array sizes + INTEGER, PARAMETER :: liw = 42 ! 20*2 + neq + INTEGER, PARAMETER :: lrw = 36 ! 22 + 9*neq + neq**2 REAL(r8) :: xout ! target integration endpoint REAL(r8) :: xmin ! inner integration bound REAL(r8) :: rtol ! relative tolerance @@ -361,29 +362,25 @@ FUNCTION riccati_f(tmp_g,inx) COMPLEX(r8) :: ck ! asymptotic coefficient c_k COMPLEX(r8) :: xk ! asymptotic coefficient x_k COMPLEX(r8) :: W_bound ! boundary value for W(p_start) -c --- work arrays - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dWdp ! W and dW/dp - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work - REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work +c --- work arrays (fixed-size, stack-allocated to avoid heap overhead) + COMPLEX(r8) :: W(1), dWdp(1) ! W and dW/dp + REAL(r8) :: atol(neq) ! absolute tolerance + INTEGER :: iwork(liw) ! lsode int work + REAL(r8) :: rwork(lrw) ! lsode real work c --- configure lsode: stiff BDF method with user Jacobian (mf=21) - neq = 2 - itol = 2 - rtol = 1e-10 - ALLOCATE(atol(neq),W(1),dWdp(1)) - atol(:) = 1e-10 - itask = 2 - istate = 1 - iopt = 1 ! enable optional inputs (iwork(6)) - mf = 21 ! stiff, user-supplied Jacobian (jac_f) - liw = 20*2 - lrw = 22+9*neq+neq**2 ! stiff work array size - ALLOCATE(iwork(liw+neq),rwork(lrw)) - -c --- set maximum internal steps - iwork=0 - iwork(6)=50000 ! MXSTEP: max internal steps per call - rwork=0 + itol = 2 + rtol = 1.0d-10 + atol(:) = 1.0d-10 + itask = 2 + istate = 1 + iopt = 1 ! enable optional inputs (iwork(6)) + mf = 21 ! stiff, user-supplied Jacobian (jac_f) + +c --- set maximum internal steps (only iwork(5:6) matter for lsode) + iwork(:) = 0 + iwork(6) = 50000 ! MXSTEP: max internal steps per call + rwork(:) = 0.0d0 xmin=1e-6 xout=xmin @@ -392,36 +389,33 @@ FUNCTION riccati_f(tmp_g,inx) c Branch on asymptotic regime: D_norm^2 vs iota_e*P_perp/P_tor^(2/3) c --- branch 1: D_norm^2 > iota_e * P_perp / P_tor^(2/3) c large-D_norm regime: p scales with (P_tor*D_norm^2/(iota_e*...)) - IF ((D_norm**2.0) > ((iota_e*P_perp)/(P_tor**(2.0/3.0)))) THEN - my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25 - IF (my_p < 6.0) THEN - my_p = 6.0 - END IF + IF (D_norm**2 > iota_e*P_perp / P_tor**(2.0d0/3.0d0)) THEN + my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25d0 + my_p = MAX(my_p, 6.0d0) ak = -(g_tmp + ifac*Q_e) - bk = (iota_e*P_perp*P_tor)/(P_tor*(D_norm**2.0)) + bk = (iota_e*P_perp*P_tor)/(P_tor*D_norm**2) - ck = bk*(1+(g_tmp+ifac*Q_i)*((P_tor+P_perp)/(P_tor*P_perp))- - $ (P_perp+(g_tmp + - $ ifac*Q_i)*(D_norm**2.0) )*(iota_e/(P_tor*(D_norm**2.0)))) + ck = bk*(1 + (g_tmp+ifac*Q_i) + $ *((P_tor+P_perp)/(P_tor*P_perp)) + $ - (P_perp + (g_tmp+ifac*Q_i)*D_norm**2) + $ *(iota_e/(P_tor*D_norm**2))) - xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0*SQRT(bk)) + xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0d0*SQRT(bk)) W_bound = xk - SQRT(bk)*my_p ELSE c --- branch 2: D_norm^2 <= iota_e * P_perp / P_tor^(2/3) c small-D_norm regime: p scales with 1/P_tor^(1/6) - my_p = 1.0/(P_tor**(1.0/6.0)) - IF (my_p < 6.0) THEN - my_p = 6.0 - END IF + my_p = 1.0d0 / P_tor**(1.0d0/6.0d0) + my_p = MAX(my_p, 6.0d0) ak = -(g_tmp + ifac*Q_e) bk = P_tor ck = -ifac*(Q_e - Q_i)*(P_tor/P_perp) + (g_tmp + ifac*Q_i) - xk = (ak*bk - ck)/(2.0*SQRT(bk)) + xk = (ak*bk - ck)/(2.0d0*SQRT(bk)) - W_bound = -1 + xk*my_p - SQRT(bk)*(my_p**3.0) + W_bound = -1.0d0 + xk*my_p - SQRT(bk)*my_p**3 END IF W(1) = W_bound @@ -459,7 +453,6 @@ FUNCTION riccati_f(tmp_g,inx) c --- extract Delta from final W derivative at p_min CALL w_der_f(neq,my_p,W,dWdp) riccati_f = pi / dWdp(1) - DEALLOCATE(atol,W,dWdp,iwork,rwork) END FUNCTION riccati_f c----------------------------------------------------------------------- @@ -468,14 +461,16 @@ END FUNCTION riccati_f SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) INTEGER, INTENT(IN) :: neq, ml, mu, nrpd REAL(r8), INTENT(IN) :: my_p - COMPLEX(r8) :: fA_p + COMPLEX(r8) :: fA_p, denom + REAL(r8) :: p2 COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd - fA_p = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + - $ ifac*Q_e + (my_p**2.0)) + p2 = my_p * my_p + denom = g_tmp + ifac*Q_e + p2 + fA_p = (denom - 2.0d0*p2) / denom - pd(1,1) = (-fA_p/my_p) - (2.0*W(1))/my_p + pd(1,1) = (-fA_p/my_p) - (2.0d0*W(1))/my_p END SUBROUTINE jac_f c----------------------------------------------------------------------- c w_der_f: ODE right-hand side dW/dp for riccati_f. @@ -489,20 +484,30 @@ SUBROUTINE w_der_f(neq,my_p,W,dWdp) COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dWdp COMPLEX(r8) :: fA, fA_prime, fB, fC - - ! Evaluate coefficients at the current p - fA = (my_p**2)/(g_tmp + ifac*Q_e + (my_p**2.0)) - fA_prime = (g_tmp + ifac*Q_e - (my_p**2)) / (g_tmp + - $ ifac*Q_e + (my_p**2.0)) - fB = g_tmp*(g_tmp + ifac*Q_i) + (g_tmp + - $ ifac*Q_i)*(P_perp+P_tor)*(my_p**2.0) + - $ (P_perp*P_tor)*(my_p**4.0) - fC = g_tmp + ifac*Q_e + ( P_perp + (g_tmp + - $ ifac*Q_i)*(D_norm**2.0))*(my_p**2.0) + - $ (1.0/iota_e)*P_tor*(D_norm**2.0)*(my_p**4.0) - - dWdp(1) = -(fA_prime/my_p)*W(1) - (W(1)**2.0)/my_p + - $ (fB/(fA*fC))*(my_p**3.0) + COMPLEX(r8) :: denom ! cached g_tmp + i*Q_e + p^2 + REAL(r8) :: p2, p4 ! cached p^2, p^4 + REAL(r8) :: D2 ! cached D_norm^2 + +c cache powers and shared denominator + p2 = my_p * my_p + p4 = p2 * p2 + D2 = D_norm * D_norm + denom = g_tmp + ifac*Q_e + p2 + +c evaluate coefficients at the current p + fA = p2 / denom + fA_prime = (denom - 2.0d0*p2) / denom ! (g+iQe - p^2)/(g+iQe + p^2) + + fB = g_tmp*(g_tmp + ifac*Q_i) + $ + (g_tmp + ifac*Q_i)*(P_perp + P_tor)*p2 + $ + (P_perp*P_tor)*p4 + + fC = g_tmp + ifac*Q_e + $ + (P_perp + (g_tmp + ifac*Q_i)*D2)*p2 + $ + (1.0d0/iota_e)*P_tor*D2*p4 + + dWdp(1) = -(fA_prime/my_p)*W(1) - W(1)*W(1)/my_p + $ + (fB/(fA*fC))*(p2*my_p) RETURN END SUBROUTINE w_der_f From a072e313236b124c32e040cf7564f0557e651449 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 02:12:25 -0500 Subject: [PATCH 062/118] delta.f arithmetic error --- slayer/delta.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slayer/delta.f b/slayer/delta.f index e32ef078a..22cb399a9 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -350,7 +350,7 @@ FUNCTION riccati_f(tmp_g,inx) INTEGER :: itol,itask ! lsode tolerance/task flags INTEGER :: istate,iopt,mf ! lsode state/option/method flags INTEGER, PARAMETER :: liw = 42 ! 20*2 + neq - INTEGER, PARAMETER :: lrw = 36 ! 22 + 9*neq + neq**2 + INTEGER, PARAMETER :: lrw = 44 ! 22 + 9*neq + neq**2 REAL(r8) :: xout ! target integration endpoint REAL(r8) :: xmin ! inner integration bound REAL(r8) :: rtol ! relative tolerance From c61f15e55087035eccd7794e567c5bce9976779d Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 02:25:45 -0500 Subject: [PATCH 063/118] WIP: AMR speedup --- slayer/gslayer.f | 135 ++++++++++++++++++++++++++++++----------------- 1 file changed, 88 insertions(+), 47 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index edef6d8d9..c4707f41e 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -760,6 +760,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? c --- locals TYPE(amr_cell_type), ALLOCATABLE :: new_cells(:) + TYPE(amr_cell_type), ALLOCATABLE :: swap_tmp(:) ! for pointer swap INTEGER :: i, j, c, corner, pass ! loop counters REAL(r8) :: step ! grid spacing REAL(r8) :: x, y ! real / imag grid coords @@ -778,15 +779,6 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, ALLOCATE(amr_cells(MAX_CELLS)) ALLOCATE(new_cells(MAX_CELLS)) - DO i = 1, MAX_CELLS - amr_cells(i)%Q = (0.0d0, 0.0d0) - amr_cells(i)%D = (0.0d0, 0.0d0) - amr_cells(i)%needs_refine = .FALSE. - new_cells(i)%Q = (0.0d0, 0.0d0) - new_cells(i)%D = (0.0d0, 0.0d0) - new_cells(i)%needs_refine = .FALSE. - END DO - n_amr_cells = 0 step = (2.0d0 * scan_width) / DBLE(Q_num - 1) @@ -859,11 +851,11 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, END IF END DO -c swap arrays for next pass +c swap arrays for next pass (pointer swap, no element copy) + CALL MOVE_ALLOC(new_cells, swap_tmp) + CALL MOVE_ALLOC(amr_cells, new_cells) ! old amr_cells becomes new_cells + CALL MOVE_ALLOC(swap_tmp, amr_cells) ! filled array becomes amr_cells n_amr_cells = n_new_cells - DO c = 1, n_amr_cells - amr_cells(c) = new_cells(c) - END DO END DO @@ -1076,11 +1068,11 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) c --- arguments INTEGER, INTENT(IN) :: num_cells ! number of cells to flatten c --- locals - INTEGER :: c, corner, i, j, idx + INTEGER :: c, corner, i, idx INTEGER :: n_total_corners ! = num_cells * 4 COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! all corner Q-values COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! all corner D-values - LOGICAL, ALLOCATABLE :: is_unique(:) ! dedup mask + INTEGER, ALLOCATABLE :: sort_idx(:) ! sort permutation REAL(r8) :: tol ! duplicate tolerance tol = 1.0d-10 @@ -1095,11 +1087,7 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) c --- gather all corners from cells ALLOCATE(temp_Q(n_total_corners)) ALLOCATE(temp_D(n_total_corners)) - ALLOCATE(is_unique(n_total_corners)) - - temp_Q = (0.0d0, 0.0d0) - temp_D = (0.0d0, 0.0d0) - is_unique = .TRUE. + ALLOCATE(sort_idx(n_total_corners)) idx = 0 DO c = 1, num_cells @@ -1107,50 +1095,103 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) idx = idx + 1 temp_Q(idx) = amr_cells(c)%Q(corner) temp_D(idx) = amr_cells(c)%D(corner) + sort_idx(idx) = idx END DO END DO -c --- mark duplicates (O(n^2) pairwise comparison) - DO i = 1, n_total_corners - IF (.NOT. is_unique(i)) CYCLE - DO j = i + 1, n_total_corners - IF (is_unique(j)) THEN - IF (ABS(temp_Q(j) - temp_Q(i)) < tol) THEN - is_unique(j) = .FALSE. - END IF - END IF - END DO - END DO +c --- sort by (Re(Q), Im(Q)) via quicksort on the index array + CALL qsort_complex_idx(temp_Q, sort_idx, 1, n_total_corners) -c --- count unique points - n_pts = 0 - DO i = 1, n_total_corners - IF (is_unique(i)) n_pts = n_pts + 1 +c --- linear scan to count unique points (sorted order) + n_pts = 1 + DO i = 2, n_total_corners + IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) + $ >= tol) THEN + n_pts = n_pts + 1 + END IF END DO - IF (n_pts <= 0) THEN - WRITE(*,*) 'ERROR: No unique points found' - DEALLOCATE(temp_Q, temp_D, is_unique) - RETURN - END IF - c --- copy unique points to module-level output arrays IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) IF (ALLOCATED(D_store)) DEALLOCATE(D_store) ALLOCATE(Q_store(n_pts)) ALLOCATE(D_store(n_pts)) - idx = 0 - DO i = 1, n_total_corners - IF (is_unique(i)) THEN + idx = 1 + Q_store(1) = temp_Q(sort_idx(1)) + D_store(1) = temp_D(sort_idx(1)) + DO i = 2, n_total_corners + IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) + $ >= tol) THEN idx = idx + 1 - Q_store(idx) = temp_Q(i) - D_store(idx) = temp_D(i) + Q_store(idx) = temp_Q(sort_idx(i)) + D_store(idx) = temp_D(sort_idx(i)) END IF END DO - DEALLOCATE(temp_Q, temp_D, is_unique) + DEALLOCATE(temp_Q, temp_D, sort_idx) RETURN END SUBROUTINE flatten_cells_to_points_sub + +c----------------------------------------------------------------------- +c qsort_complex_idx: in-place quicksort of an index array by +c the complex keys (Re then Im). Operates on sort_idx so the +c Q/D data arrays remain untouched. +c----------------------------------------------------------------------- + RECURSIVE SUBROUTINE qsort_complex_idx(keys, idx, lo, hi) + + IMPLICIT NONE + + COMPLEX(r8), INTENT(IN) :: keys(:) + INTEGER, INTENT(INOUT) :: idx(:) + INTEGER, INTENT(IN) :: lo, hi + + INTEGER :: i, j, pivot_idx, tmp + REAL(r8) :: p_re, p_im, k_re, k_im + + IF (lo >= hi) RETURN + +c median-of-three pivot selection + pivot_idx = idx((lo + hi) / 2) + p_re = REAL(keys(pivot_idx), KIND=r8) + p_im = AIMAG(keys(pivot_idx)) + + i = lo + j = hi + DO WHILE (i <= j) +c advance i while keys(idx(i)) < pivot + k_re = REAL(keys(idx(i)), KIND=r8) + k_im = AIMAG(keys(idx(i))) + DO WHILE (k_re < p_re .OR. + $ (k_re == p_re .AND. k_im < p_im)) + i = i + 1 + k_re = REAL(keys(idx(i)), KIND=r8) + k_im = AIMAG(keys(idx(i))) + END DO +c retreat j while keys(idx(j)) > pivot + k_re = REAL(keys(idx(j)), KIND=r8) + k_im = AIMAG(keys(idx(j))) + DO WHILE (k_re > p_re .OR. + $ (k_re == p_re .AND. k_im > p_im)) + j = j - 1 + k_re = REAL(keys(idx(j)), KIND=r8) + k_im = AIMAG(keys(idx(j))) + END DO +c swap if pointers haven't crossed + IF (i <= j) THEN + tmp = idx(i) + idx(i) = idx(j) + idx(j) = tmp + i = i + 1 + j = j - 1 + END IF + END DO + +c recurse on partitions + IF (lo < j) CALL qsort_complex_idx(keys, idx, lo, j) + IF (i < hi) CALL qsort_complex_idx(keys, idx, i, hi) + + RETURN + END SUBROUTINE qsort_complex_idx END MODULE gslayer_mod \ No newline at end of file From 175413ffb8689cc3e6576dabec9398d576f4a13f Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 02:30:33 -0500 Subject: [PATCH 064/118] WIP: hashed midpoint computation fix --- slayer/gslayer.f | 148 +++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 123 insertions(+), 25 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index c4707f41e..21fd7093e 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -16,9 +16,9 @@ MODULE gslayer_mod c 10. dispersion_AMR_v2 - AMR scan v2 (cell-based storage) c c Helper subroutines (v1): get_or_compute -c Helper subroutines (v2): compute_delta_sub, -c check_cell_crossing_sub, subdivide_cell_sub, -c flatten_cells_to_points_sub +c Helper subroutines (v2): get_or_compute_v2, +c compute_delta_sub, check_cell_crossing_sub, +c subdivide_cell_sub, flatten_cells_to_points_sub c----------------------------------------------------------------------- USE omp_lib @@ -731,6 +731,73 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, hash_head(h) = idx_out END SUBROUTINE get_or_compute + +c----------------------------------------------------------------------- +c get_or_compute_v2: hash-cached dispersion evaluation for AMR v2. +c Identical to get_or_compute but applies the ifac (imaginary-unit) +c Wick rotation that compute_delta_sub uses: g_tmp = q_in * ifac. +c----------------------------------------------------------------------- + SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, + $ msing_max, coupling_flag) + + IMPLICIT NONE + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in + INTEGER, INTENT(OUT) :: idx_out + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + +c --- locals + INTEGER :: h, curr + COMPLEX(r8) :: delta_val + INTEGER(8) :: ix8, iy8, h8 + +c --- 1. compute hash bucket + ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) + iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) + h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), + $ INT(HASH_SZ, 8)) + 1_8 + h = INT(h8) + +c --- 2. search hash chain for existing point + curr = hash_head(h) + DO WHILE (curr /= 0) + IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN + idx_out = curr + RETURN + END IF + curr = hash_next(curr) + END DO + +c --- 3. not found: evaluate with ifac rotation and store + n_pts = n_pts + 1 + IF (n_pts > MAX_PTS) THEN + WRITE(*,*) 'ERROR: AMR v2 cache exceeded MAX_PTS' + STOP 'get_or_compute_v2: MAX_PTS exceeded' + END IF + + idx_out = n_pts + Q_store(idx_out) = q_in + + IF (coupling_flag) THEN + g_tmp = q_in * ifac + delta_val = dispersion_det(g_tmp, n_k, sl_in, + $ msing_max) + ELSE + g_tmp = q_in * ifac + delta_val = riccati_f(g_tmp) + delta_val = delta_val - delta_eff + END IF + D_store(idx_out) = delta_val + +c --- 4. insert into hash chain (prepend) + hash_next(idx_out) = hash_head(h) + hash_head(h) = idx_out + + END SUBROUTINE get_or_compute_v2 + c----------------------------------------------------------------------- c dispersion_AMR_v2: cell-based adaptive mesh refinement scanner. c Unlike v1 (hash-based point deduplication), v2 stores complete @@ -739,8 +806,11 @@ END SUBROUTINE get_or_compute c Re(D) or Im(D) and re-evaluates the dispersion relation at the c 5 new midpoints. c -c After refinement, flatten_cells_to_points_sub extracts unique -c (Q, D) points into Q_store / D_store for output. +c All dispersion evaluations go through get_or_compute_v2, which +c caches results in Q_store / D_store via a hash table. This +c eliminates redundant evaluations for shared corners (initial grid) +c and shared edge-midpoints (refinement). At completion, Q_store +c and D_store are trimmed to n_pts unique output points. c c BUG FLAG 9 – several bare stop statements should carry messages. c----------------------------------------------------------------------- @@ -764,21 +834,32 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, INTEGER :: i, j, c, corner, pass ! loop counters REAL(r8) :: step ! grid spacing REAL(r8) :: x, y ! real / imag grid coords - COMPLEX(r8) :: delta_val ! (unused – computed inside helper) LOGICAL :: cross_real, cross_imag ! zero-crossing flags INTEGER :: n_new_cells ! count during refinement INTEGER :: cells_to_refine ! cells flagged per pass INTEGER :: cells_kept ! cells kept per pass + INTEGER :: idx_tmp ! hash-cache index + COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! for trimming output + COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! for trimming output -c --- 1. initialise cell storage +c --- 1. initialise cell storage and hash cache IF (ALLOCATED(amr_cells)) DEALLOCATE(amr_cells) IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) ALLOCATE(amr_cells(MAX_CELLS)) ALLOCATE(new_cells(MAX_CELLS)) + ALLOCATE(Q_store(MAX_PTS)) + ALLOCATE(D_store(MAX_PTS)) + ALLOCATE(hash_head(HASH_SZ)) + ALLOCATE(hash_next(MAX_PTS)) + hash_head = 0 + hash_next = 0 + n_pts = 0 n_amr_cells = 0 step = (2.0d0 * scan_width) / DBLE(Q_num - 1) @@ -803,12 +884,14 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, $ KIND=r8) -c evaluate dispersion at each corner +c evaluate dispersion at each corner (hash-cached) DO corner = 1, 4 - CALL compute_delta_sub( + CALL get_or_compute_v2( $ amr_cells(n_amr_cells)%Q(corner), - $ n_k, sl_in, msing_max, coupling_flag, - $ amr_cells(n_amr_cells)%D(corner)) + $ idx_tmp, n_k, sl_in, msing_max, + $ coupling_flag) + amr_cells(n_amr_cells)%D(corner) = + $ D_store(idx_tmp) END DO amr_cells(n_amr_cells)%needs_refine = .FALSE. @@ -859,9 +942,18 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, END DO -c --- 4. flatten cells to unique (Q, D) output arrays - CALL flatten_cells_to_points_sub(n_amr_cells) +c --- 4. output: Q_store/D_store already populated by hash cache. +c Trim to exact size n_pts and deallocate hash infrastructure. + ALLOCATE(temp_Q(n_pts)) + ALLOCATE(temp_D(n_pts)) + temp_Q(1:n_pts) = Q_store(1:n_pts) + temp_D(1:n_pts) = D_store(1:n_pts) + CALL MOVE_ALLOC(temp_Q, Q_store) + CALL MOVE_ALLOC(temp_D, D_store) + + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) DEALLOCATE(new_cells) c keep amr_cells allocated for potential post-run inspection @@ -959,9 +1051,10 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, c --- corner coordinates and D-values from parent COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr -c --- midpoint coordinates and D-values (5 new evaluations) +c --- midpoint coordinates and D-values (cached via hash) COMPLEX(r8) :: q_bm, q_tm, q_lm, q_rm, q_mm COMPLEX(r8) :: d_bm, d_tm, d_lm, d_rm, d_mm + INTEGER :: idx_tmp ! hash-cache index c --- extract parent corners (BL=1, BR=2, TL=3, TR=4) q_bl = parent%Q(1) @@ -981,17 +1074,22 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, q_rm = 0.5d0 * (q_br + q_tr) q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) -c --- evaluate dispersion at new midpoints (5 calls) - CALL compute_delta_sub(q_bm, n_k, sl_in, msing_max, - $ coupling_flag, d_bm) - CALL compute_delta_sub(q_tm, n_k, sl_in, msing_max, - $ coupling_flag, d_tm) - CALL compute_delta_sub(q_lm, n_k, sl_in, msing_max, - $ coupling_flag, d_lm) - CALL compute_delta_sub(q_rm, n_k, sl_in, msing_max, - $ coupling_flag, d_rm) - CALL compute_delta_sub(q_mm, n_k, sl_in, msing_max, - $ coupling_flag, d_mm) +c --- evaluate dispersion at new midpoints (hash-cached) + CALL get_or_compute_v2(q_bm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_bm = D_store(idx_tmp) + CALL get_or_compute_v2(q_tm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_tm = D_store(idx_tmp) + CALL get_or_compute_v2(q_lm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_lm = D_store(idx_tmp) + CALL get_or_compute_v2(q_rm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_rm = D_store(idx_tmp) + CALL get_or_compute_v2(q_mm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_mm = D_store(idx_tmp) c --- check space for 4 new cells IF (n_new + 4 > max_cells) THEN From 01039e55b2e63145833c930c5d7c5641dc6b3b1f Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 13:45:05 -0500 Subject: [PATCH 065/118] WIP: ongoing diagnosing of erroneous nyquist diagrams --- slayer/gslayer.f | 5 +++++ slayer/slayer.f | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 21fd7093e..695288f32 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -958,6 +958,11 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, c keep amr_cells allocated for potential post-run inspection WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts + WRITE(*,'(A,2ES14.6)') ' D_store checksum (Re,Im):', + $ SUM(REAL(D_store(1:n_pts))), + $ SUM(AIMAG(D_store(1:n_pts))) + WRITE(*,'(A,2ES14.6)') ' D_store(1) sample:', + $ REAL(D_store(1)), AIMAG(D_store(1)) RETURN END SUBROUTINE dispersion_AMR_v2 diff --git a/slayer/slayer.f b/slayer/slayer.f index cf7f78bb5..3f43ec3e5 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -753,6 +753,13 @@ PROGRAM slayer ! Clean up temporary AMR memory. DEALLOCATE(Q_store, D_store) + WRITE(*,'(A,I2,A,I7,A,2ES14.6)') + $ ' Surface', k, ': n_pts=', + $ SIZE(all_deltas_out(k)%real_deltas), + $ ' out_chksum=', + $ SUM(all_deltas_out(k)%real_deltas), + $ SUM(all_deltas_out(k)%imag_deltas) + END IF c----------------------------------------------------------------------- From 32985ece9e0c824f7b0a3bcf54aa16e979fb7706 Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 19 Feb 2026 18:30:10 -0500 Subject: [PATCH 066/118] WIP: fix makefile ordering --- slayer/makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slayer/makefile b/slayer/makefile index 2326a9c91..39c4217ba 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -54,7 +54,8 @@ slayer: $(OBJS) sglobal.o: ../equil/local_mod.mod params.o : sglobal.o delta.o : sglobal.o -gslayer.o : sglobal.o delta.o +layerinputs.o : sglobal.o params.o slayer_netcdf.o +gslayer.o : sglobal.o params.o delta.o layerinputs.o slayer_netcdf.o slayer.o : sglobal.o params.o delta.o ../equil/spline_mod.mod slayer_netcdf.o : sglobal.o From 4fb3329ec585164046fd2c85da2cee504b0bb2b5 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Fri, 20 Feb 2026 19:43:26 -0500 Subject: [PATCH 067/118] WIP: set coupling via msing_max --- slayer/gslayer.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 695288f32..36135b0d9 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -415,7 +415,7 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) INTEGER :: k ! surface loop index c --- single-surface branch - IF (n_k < 2) THEN + IF (msing_max < 2) THEN c set module-level variables for riccati_f Q_e = sl_in%Q_e_arr(1) Q_i = sl_in%Q_i_arr(1) @@ -435,8 +435,8 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) dispersion_det = sl_in%Re_dp_arr(1) - det_val c --- coupled-surface branch (2 or 3 surfaces) - ELSEIF ((n_k == 2) .OR. (n_k == 3)) THEN - ALLOCATE(delta_Q(n_k,n_k)) + ELSEIF ((msing_max == 2) .OR. (msing_max == 3)) THEN + ALLOCATE(delta_Q(msing_max,msing_max)) delta_Q=(0.0,0.0) DO k=1,msing_max c set module-level variables for this surface From 631b9c8e59aad7ef21d6b0dd113f84a129add5d3 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 20 Feb 2026 19:52:06 -0500 Subject: [PATCH 068/118] WIP: fix determinant msing_max case --- slayer/gslayer.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 36135b0d9..78ac71187 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -458,7 +458,7 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) c compute det(dp_matrix - delta_Q) result_matrix = sl_in%dp_matrix - delta_Q - CALL calc_determinant(result_matrix, n_k, det_val) + CALL calc_determinant(result_matrix, msing_max, det_val) dispersion_det = det_val ELSE WRITE(*,*) "Error: no support for msing > 3" From b7c29363b46b5f5d61c436201d83c6da6c390a93 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 18:25:19 -0500 Subject: [PATCH 069/118] new SLAYER cleanup complete, first pass --- slayer/delta.f | 51 +++++--------- slayer/gslayer.f | 94 ++++++++++++++----------- slayer/layerinputs.f | 90 ++++-------------------- slayer/makefile | 20 +++++- slayer/params.f | 28 ++++---- slayer/sglobal.f | 31 +++------ slayer/slayer.f | 116 +++++++++++++++--------------- slayer/slayer_netcdf.f | 155 ++++++++++++++++------------------------- 8 files changed, 239 insertions(+), 346 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 22cb399a9..8ef9bff22 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -38,10 +38,8 @@ MODULE delta_mod c guard when Q is near Q_e. Returns Delta = pi / W'(x_min). c c If riccati_out = .TRUE., writes the W(x) profile to -c slayer_riccati_profile_n.{bin,out}. +c slayer_riccati_profile_n.{bin,out}. c -c BUG FLAG 1: xintv and xfac are declared but never used. -c Remove them. c----------------------------------------------------------------------- FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, $ iinQ,inx,iny) @@ -113,11 +111,11 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, rwork=0 c --- boundary condition: asymptotic W at large x -c BUG FLAG 2: inline comment said "To be updated" -- verify formula. x=20.0 xmin=1e-3 IF(present(inx)) x=inx xout=xmin +c DECISION NEEDED (Flag 2): verify this large-|x| asymptotic BC. y(1)=-c_beta/sqrt((1+tau))/ds*x**2.0 IF(present(iny)) y(1)=iny @@ -128,11 +126,11 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, istep = 1 itask = 2 OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.bin',STATUS='UNKNOWN', + $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', $ POSITION='REWIND',FORM='UNFORMATTED') OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.out',STATUS='UNKNOWN') + $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') WRITE(out2_unit,'(1x,3(a17))') "x","RE(y)","IM(y)" DO WHILE (x>xout) istep=istep+1 @@ -165,12 +163,12 @@ END FUNCTION riccati c (jac_del_s). Integrates W(q) from large q inward to q_min. c Returns Delta = -(pi / sqrt(1+1/tau)) * W'(q_min). c -c BUG FLAG 3: arguments inQ, inc_beta, ind_beta, intau are never -c used to set their module-level counterparts (Q, c_beta, d_beta, -c tau). Either add assignments (e.g. tau=intau) or remove the -c unused arguments if the caller sets them beforehand. -c BUG FLAG 4: variables y, dy, xfac, xintv, ml, mu, nrpd are -c declared but never used -- remove them. +c Module-level variables tau, D_norm, and P_tor must be valid +c before entry; callers are responsible for setting them. +c Q_e, Q_i, and P_perp are set from arguments inside this +c function. Q, c_beta, and d_beta are not referenced here. +c Note: slayer.f passes Q_e_arr (not Q_arr) as the first +c argument -- this is intentional. c----------------------------------------------------------------------- FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) @@ -233,8 +231,6 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) Q_i = inQ_i P_perp = inpr -c --- BUG FLAG 6: P_hat was computed BEFORE P_perp=inpr, so it used -c the stale module-level P_perp. Now moved after assignment. P_hat = P_perp / D_norm**6.0 c --- asymptotic boundary condition at large q @@ -248,11 +244,11 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) istep = 1 itask = 2 OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.bin',STATUS='UNKNOWN', + $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', $ POSITION='REWIND',FORM='UNFORMATTED') OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.out',STATUS='UNKNOWN') + $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" DO WHILE (my_q>xout) istep=istep+1 @@ -304,10 +300,7 @@ SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) c --- normalise physical quantities Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 P_perp_hat = P_perp / D_norm**6.0 -c BUG FLAG 7: P_tor_hat is assigned from P_perp, not P_tor. -c Benchmark values differ (P_perp_hat=0.377, P_tor_hat=1.15), -c suggesting this should be: P_tor_hat = P_tor / D_norm**6.0 - P_tor_hat = P_perp / D_norm**6.0 + P_tor_hat = P_tor / D_norm**6.0 c --- build the E and F dispersion coefficients E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) @@ -326,21 +319,9 @@ END SUBROUTINE w_der_del_s c large-p asymptotic behaviour; the branch depends on whether c D_norm^2 exceeds iota_e * P_perp / P_tor^(2/3). c -c BUG FLAG 8: argument tmp_g (COMPLEX) is never used in the -c function body. All references use the module-level variable -c g_tmp instead. The caller (slayer.f:785) passes g_tmp as -c tmp_g, so in practice the values match -- but tmp_g is -c redundant. Likely needs: g_tmp = tmp_g at the top, or -c remove the argument and rely on the module variable. -c BUG FLAG 9: variables xintv, xfac, y, dy, ck_1, ck_2, ml, mu, -c nrpd, alpha are declared but never used -- remove them. -c Optional argument inx is also never referenced in the body. c----------------------------------------------------------------------- - FUNCTION riccati_f(tmp_g,inx) + FUNCTION riccati_f() -c --- input arguments - COMPLEX(r8),INTENT(IN) :: tmp_g ! growth rate (UNUSED -- BUG FLAG 8) - REAL(r8),INTENT(IN),OPTIONAL :: inx ! (UNUSED -- BUG FLAG 9) c --- function result COMPLEX(r8) :: riccati_f @@ -426,11 +407,11 @@ FUNCTION riccati_f(tmp_g,inx) istep = 1 itask = 2 OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.bin',STATUS='UNKNOWN', + $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', $ POSITION='REWIND',FORM='UNFORMATTED') OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn)//'.out',STATUS='UNKNOWN') + $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" DO WHILE (my_p>xout) istep=istep+1 diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 78ac71187..8c272efc5 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -36,8 +36,8 @@ MODULE gslayer_mod $ MAX_CELLS, ! v2 limit $ slayer_inputs_type,slayer_outputs_type, $ deltas_outputs_type, - $ tau_r,d_crit,delta_det,dc_tmp,dc_type, - $ sn,sm + $ tau_r,dc_tmp,dc_type, + $ sn_str,sm_str USE delta_mod, ONLY: riccati,riccati_f,riccati_out, $ parflow_flag,PeOhmOnly_flag USE params_mod @@ -46,6 +46,10 @@ MODULE gslayer_mod IMPLICIT NONE +c --- reconnection regulariser used in psi0 / JxB expressions; +c expose via namelist to make user-configurable. + REAL(r8), PARAMETER :: DELTA_N_PERT = 1.0e-2_r8 + CONTAINS c----------------------------------------------------------------------- @@ -60,11 +64,10 @@ MODULE gslayer_mod c 3. Scan over a range of Q (rotation) to build a torque c balance curve, then identify the critical threshold br_th. c -c BUG FLAG 1: `index` variable shadows the Fortran intrinsic -c INDEX(). Rename to e.g. `max_idx`. -c BUG FLAG 2: `iinQs` is declared but never used. Remove it. -c BUG FLAG 3: `zeff`, `qval`, `v_a`, `inlu` are declared / -c passed in but never used. Remove or document intent. +c TODO: `zeff` and `qval` are INTENT(IN) +c arguments accepted in the interface but never referenced in +c the subroutine body. Remove from signature (breaking API +c change) or add a comment documenting their reserved intent. c----------------------------------------------------------------------- SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, $ omega_i,qval,sval,bt,rs,R0,mu_i,inpr,mms,nns,ascii_flag, @@ -75,11 +78,11 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, REAL(r8),INTENT(IN) :: t_e ! electron temperature [eV] REAL(r8),INTENT(IN) :: n_i ! ion density [m^-3] REAL(r8),INTENT(IN) :: t_i ! ion temperature [eV] - REAL(r8),INTENT(IN) :: zeff ! (UNUSED -- BUG FLAG 3) + REAL(r8),INTENT(IN) :: zeff ! (TODO: unused; see header) REAL(r8),INTENT(IN) :: omega ! plasma rotation frequency REAL(r8),INTENT(IN) :: omega_e ! electron diamagnetic freq REAL(r8),INTENT(IN) :: omega_i ! ion diamagnetic freq - REAL(r8),INTENT(IN) :: qval ! (UNUSED -- BUG FLAG 3) + REAL(r8),INTENT(IN) :: qval ! (TODO: unused; see header) REAL(r8),INTENT(IN) :: sval ! magnetic shear REAL(r8),INTENT(IN) :: bt ! toroidal field [T] REAL(r8),INTENT(IN) :: rs ! minor radius of surface [m] @@ -197,10 +200,10 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, Q0=Q c----------------------------------------------------------------------- c compute baseline Delta, reconnected flux, and JxB torque. -c BUG FLAG 4: delta_n_p = 1e-2 is hardcoded; should this come -c from the namelist or caller? +c delta_n_p uses the module-level DELTA_N_PERT constant; promote +c that constant to a namelist input to make it user-configurable. c----------------------------------------------------------------------- - delta_n_p=1e-2 + delta_n_p = DELTA_N_PERT delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux (a.u.) jxb=-AIMAG(1.0/(delta+delta_n_p)) ! JxB torque (a.u.) @@ -209,9 +212,11 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, c compute delta(Q), JxB(Q), and the balance parameter. c The threshold br_th is sqrt(max(bal)/lu * s^2/2). c -c BUG FLAG 5: scan bounds from Q0/Q_e physics (lines above) are -c immediately overridden by hardcoded inQ_max=10, inQ_min=-10. -c Either remove the dead code above or use the physics bounds. +c TODO: physics bounds from Q0/Q_e (computed +c in the IF/ELSE above) are immediately overridden by the two +c fixed assignments below. To use physics bounds, remove the +c inQ_max=10 / inQ_min=-10 lines. To keep fixed bounds, remove +c the dead IF/ELSE block above. c----------------------------------------------------------------------- IF (Q0>inQ_e) THEN inQ_max=2.0*Q0 @@ -225,7 +230,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, ENDIF ENDIF - inQ_max=10.0 ! hardcoded override (see BUG FLAG 5) + inQ_max=10.0 ! TODO: fixed bound; see header inQ_min=-10.0 inum=200 ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum),bal(0:inum)) @@ -347,11 +352,9 @@ END SUBROUTINE grow_array c subprogram 7. calc_determinant. c Compute the determinant of a 2x2 or 3x3 complex matrix. c Returns (0,0) and sets status=-1 for unsupported sizes. -c -c BUG FLAG 6: variable `status` is computed but never returned -c to the caller. Either add an INTENT(OUT) argument or remove. +c status=0 on success, -1 when nk is neither 2 nor 3. c----------------------------------------------------------------------- - SUBROUTINE calc_determinant(matk, nk, detk) + SUBROUTINE calc_determinant(matk, nk, detk, status) IMPLICIT NONE @@ -359,8 +362,7 @@ SUBROUTINE calc_determinant(matk, nk, detk) INTEGER, INTENT(IN) :: nk ! matrix rank (2 or 3) COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! input matrix COMPLEX(r8), INTENT(OUT) :: detk ! determinant result -c --- local - INTEGER :: status ! error status (unused externally) + INTEGER, INTENT(OUT) :: status ! 0=success, -1=unsupported rank status = 0 ! Initialize status as success @@ -389,20 +391,18 @@ END SUBROUTINE calc_determinant c Compute the coupled dispersion determinant for n_k surfaces. c c For n_k = 1 (single surface): -c Evaluate riccati_f(g_tmp), de-normalise by lu^(1/3), and +c Evaluate riccati_f() (uses module g_tmp), de-normalise by lu^(1/3), and c return Deltaprime - delta(Q). c c For n_k = 2 or 3 (coupled surfaces): c Build the diagonal delta(Q) matrix, subtract from dp_matrix, c and return det(dp_matrix - delta_Q). c -c BUG FLAG 7: bare `stop` on n_k > 3 -- use STOP with message -c consistently, or return a NaN sentinel. c----------------------------------------------------------------------- - FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) + FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c --- arguments - COMPLEX(r8), INTENT(IN) :: g_tmp ! complex growth rate + COMPLEX(r8), INTENT(IN) :: g_in ! complex growth rate INTEGER, INTENT(IN) :: n_k ! number of surfaces INTEGER, INTENT(IN) :: msing_max ! max surfaces to include TYPE(slayer_inputs_type), INTENT(IN) :: sl_in @@ -413,6 +413,7 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:) ! diagonal delta matrix COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! dp - delta_Q INTEGER :: k ! surface loop index + INTEGER :: det_status ! calc_determinant error status c --- single-surface branch IF (msing_max < 2) THEN @@ -427,7 +428,8 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) tauk = sl_in%Qconv_arr(1) iota_e = Q_e / (Q_e - Q_i) - tmp_delta=riccati_f(g_tmp) + g_tmp = g_in + tmp_delta=riccati_f() c de-normalise delta by lu^(1/3) det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) @@ -451,14 +453,20 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) iota_e = Q_e / (Q_e - Q_i) c evaluate riccati_f at rescaled growth rate, de-normalise - delta_Q(k,k)=riccati_f(((g_tmp*sl_in%Qconv_arr(1)) - $ /tauk)) + g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk ! sets module-level g_tmp to SCALED value + delta_Q(k,k)=riccati_f() delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) END DO c compute det(dp_matrix - delta_Q) result_matrix = sl_in%dp_matrix - delta_Q - CALL calc_determinant(result_matrix, msing_max, det_val) + CALL calc_determinant(result_matrix, msing_max, det_val, + $ det_status) + IF (det_status /= 0) THEN + WRITE(*,*) 'ERROR: calc_determinant unsupported rank=', + $ msing_max + STOP 'dispersion_det: calc_determinant failed' + END IF dispersion_det = det_val ELSE WRITE(*,*) "Error: no support for msing > 3" @@ -467,7 +475,8 @@ FUNCTION dispersion_det(g_tmp,n_k,sl_in,msing_max) END FUNCTION dispersion_det c----------------------------------------------------------------------- -c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc Scans a 2D complex-Q grid for zeros of the dispersion relation +c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc +c Scans a 2D complex-Q grid for zeros of the dispersion relation c D(Q) using adaptive refinement. A coarse grid is evaluated c first (two-pass: nodes then cells), then cells that span a zero c crossing in Re(D) or Im(D) are subdivided. @@ -475,9 +484,6 @@ END FUNCTION dispersion_det c Point deduplication uses a spatial hash table (HASH_SZ buckets, c chained) so that midpoints shared between neighbouring cells c are evaluated only once. -c -c BUG FLAG 8 \u2013 h_idx, pt_idx are declared but never referenced. -c Remove them. c----------------------------------------------------------------------- SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, $ scan_width,Q_num,AMR_passes, @@ -496,7 +502,7 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, INTEGER, ALLOCATABLE :: new_cells(:,:) ! scratch for next level c --- loop / index variables INTEGER :: n_cells, n_new_cells, i, j - INTEGER :: h_idx, pt_idx, c_idx, pass ! h_idx, pt_idx UNUSED (BUG FLAG 8) + INTEGER :: c_idx, pass INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! corner indices INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! midpoint indices c --- scan workspace @@ -721,7 +727,7 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) ELSE g_tmp = q_in - delta_val = riccati_f(g_tmp) + delta_val = riccati_f() delta_val = delta_val - delta_eff END IF D_store(idx_out) = delta_val @@ -787,7 +793,7 @@ SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, $ msing_max) ELSE g_tmp = q_in * ifac - delta_val = riccati_f(g_tmp) + delta_val = riccati_f() delta_val = delta_val - delta_eff END IF D_store(idx_out) = delta_val @@ -812,7 +818,6 @@ END SUBROUTINE get_or_compute_v2 c and shared edge-midpoints (refinement). At completion, Q_store c and D_store are trimmed to n_pts unique output points. c -c BUG FLAG 9 – several bare stop statements should carry messages. c----------------------------------------------------------------------- SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, $ scan_width, Q_num, AMR_passes, @@ -991,7 +996,7 @@ SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) ELSE g_tmp = q_in*ifac - delta_out = riccati_f(g_tmp) + delta_out = riccati_f() delta_out = delta_out - delta_eff END IF @@ -1161,8 +1166,7 @@ END SUBROUTINE subdivide_cell_sub c for moderate cell counts; could be replaced by a hash set for c very large scans. c -c BUG FLAG 10 – n_total_corners could exceed MAX_PTS for large -c grids. No guard is present. +c n_total_corners = num_cells*4; guarded against MAX_PTS overflow. c----------------------------------------------------------------------- SUBROUTINE flatten_cells_to_points_sub(num_cells) @@ -1181,6 +1185,12 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) tol = 1.0d-10 n_total_corners = num_cells * 4 + IF (n_total_corners > MAX_PTS) THEN + WRITE(*,*) 'ERROR: n_total_corners=', n_total_corners, + $ ' exceeds MAX_PTS=', MAX_PTS + STOP 'flatten_cells_to_points_sub: MAX_PTS exceeded' + END IF + IF (num_cells <= 0) THEN WRITE(*,*) 'ERROR: No cells to flatten' n_pts = 0 diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 5fd3702e7..12377493b 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -33,17 +33,8 @@ MODULE layerinputs_mod c Read the STRIDE NetCDF file and extract the Deltaprime matrix, c rational-surface geometry (q, psi_n, shear, dgeo, dr), and c equilibrium scalars (R0, B_t0, psi0, m_psi, n, resm). -c -c BUG FLAG 1 -- NetCDF variable IDs (dp_id, qr_id, ...) are -c declared but never initialised via nf90_inq_varid before -c being passed to nf90_inquire_attribute. The attribute -c reads for ro, bt0, psio, mpsi, n use *_id variables that -c are still zero at that point; the calls appear to succeed -c only because the NetCDF library treats the id argument as -c a global-attribute flag when it is NF90_GLOBAL (=0). -c Suggested fix: either replace the id arguments with -c NF90_GLOBAL explicitly, or move the nf90_inq_varid calls -c above the nf90_inquire_attribute calls. +c All global-attribute reads use NF90_GLOBAL explicitly; +c variable IDs are obtained via nf90_inq_varid before use. c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, @@ -197,15 +188,7 @@ END SUBROUTINE read_stride_netcdf_diagonal c Geometry is cached via first/fsave/psave to avoid recomputing c Jacobians when the same surface is queried repeatedly. c -c BUG FLAG 2 -- `first = .FALSE.` is commented out (line after -c `fsave = fs`). The caching logic therefore never sets -c first=.FALSE., so geometry is recomputed on every call -c even when psi and fs are unchanged. Uncomment the line -c or remove the caching branch entirely. -c -c BUG FLAG 3 -- `z` (toroidal-Z coordinate) is computed inside -c the geometry loop but never used outside it. Remove or -c document its intended purpose. + c----------------------------------------------------------------------- FUNCTION issurfint(func,fs,inpsi,wegt,ave, $ fsave,psave,jacs,delpsi,inr,ina,first) @@ -219,7 +202,7 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, REAL(r8), INTENT(IN) :: inpsi ! normalised psi of surface REAL(r8), DIMENSION(0:fs), INTENT(IN) :: func ! integrand array - LOGICAL, INTENT(INOUT) :: first ! .TRUE. on first call (see BUG FLAG 2) + LOGICAL, INTENT(INOUT) :: first ! .TRUE. on first call for caching INTEGER, INTENT(INOUT) :: fsave ! cached fs REAL(r8), INTENT(INOUT) :: psave ! cached psi REAL(r8), DIMENSION(0:), INTENT(INOUT) :: jacs ! Jacobian cache @@ -233,7 +216,6 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, INTEGER :: ix, iy ! bicube grid hints REAL(r8) :: rfac, ineta, injac, inarea ! geometry intermediates REAL(r8), DIMENSION(1,2) :: w ! gradient components - REAL(r8), DIMENSION(0:fs) :: z ! Z coords (UNUSED -- BUG FLAG 3) REAL(r8), DIMENSION(0:fs) :: thetas ! normalised theta grid REAL(r8), DIMENSION(4) :: rzphi_f, rzphi_fx, rzphi_fy ! bicube_eval_external outputs @@ -249,7 +231,7 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, IF (first .OR. inpsi /= psave .OR. fs /= fsave) THEN psave = inpsi fsave = fs - !first = .FALSE. ! BUG FLAG 2: should be uncommented + first = .FALSE. DO itheta = 0, fs thetas(itheta) = REAL(itheta, r8) / REAL(fs, r8) ENDDO @@ -260,7 +242,6 @@ FUNCTION issurfint(func,fs,inpsi,wegt,ave, ineta = twopi * (thetas(itheta) + rzphi_f(2)) ina(itheta) = rfac inr(itheta) = ro + rfac * COS(ineta) - z(itheta) = zo + rfac * SIN(ineta) injac = rzphi_f(4) jacs(itheta) = injac c gradient magnitude: |grad psi| from metric components @@ -321,32 +302,7 @@ END FUNCTION issurfint c loops over every singular surface to compute derived layer c parameters via params() and populate slayer_inputs_type. c -c BUG FLAG 4 -- many local scalars declared here (lpsi, rpsi, -c hdist, sbnosurf, spl, sr, my_inpe, tau_i, b_l, v_a, tau_h, -c rho, tau_v, Qconv, lbeta, qintb, tau_ee_num..chi_par, -c psitor, rhotor, my_rhotor, my_psitor, rfac, jac, wit) -c are never used. They appear to be left over from an earlier -c version. Remove to reduce confusion. -c -c BUG FLAG 5 -- `ising` is declared REAL(r8) but is used as a -c DO-loop index (integer context). This works in Fortran but -c is non-standard in F90+ and may fail with strict compilers. -c Declare as INTEGER. -c -c BUG FLAG 6 -- `zeff = 2.0` is hardcoded on every surface -c (the kin%f(9) alternative is commented out). If the -c kinetic file provides Z_eff, this should use it. -c -c BUG FLAG 7 -- `mrs` and `nrs` are assigned -c `real(mms,4)` / `real(nns,4)` (single precision) but are -c declared INTEGER, so the float is silently truncated. -c They are also never used afterwards. Remove or fix. -c -c BUG FLAG 8 -- the local arrays ne_arr, te_arr, ... mu_i_arr, -c nns_arr, dr_arr, omegas_e_arr, omegas_i_arr are populated -c inside the loop but never used outside it (the old -c slayer_netcdf_inputs call is commented out). Remove or -c gate behind a diagnostic flag. + c----------------------------------------------------------------------- SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- @@ -359,51 +315,33 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c --- surface-loop control LOGICAL :: firstsurf ! first-call flag for issurfint REAL(r8) :: respsi ! normalised psi at current surface - REAL(r8) :: ising ! loop index (BUG FLAG 5: should be INTEGER) -c --- unused scalars (BUG FLAG 4 -- remove) - REAL(r8) :: lpsi, rpsi, hdist, sbnosurf + INTEGER :: ising ! loop index over singular surfaces c --- kinetic profile parameters (for read_kin) INTEGER :: zi, zimp, mi, mimp ! charge/mass species ids REAL(r8) :: nfac, tfac, wefac, wpfac ! profile scale factors REAL(r8) :: e ! elementary charge [C] -c --- unused spline temporaries (BUG FLAG 4) - TYPE(spline_type) :: spl - TYPE(spline_type) :: sr c --- mode number workspace INTEGER :: mms, nns ! poloidal / toroidal mode nums - INTEGER :: mrs, nrs ! UNUSED, wrongly typed (BUG FLAG 7) INTEGER :: mpsi ! poloidal-flux index from attr c --- local plasma quantities at current surface REAL(r8) :: n_e, t_e, n_i, t_i ! densities [m^-3], temperatures [eV] REAL(r8) :: omega, omega_e, omega_i ! toroidal & diamagnetic freqs [rad/s] REAL(r8) :: my_qval, my_sval ! safety factor, magnetic shear REAL(r8) :: my_bt, my_rs, R_0 ! toroidal field, minor radius, major radius - REAL(r8) :: my_inpe ! UNUSED (BUG FLAG 4) - REAL(r8) :: zeff ! effective charge (hardcoded -- BUG FLAG 6) + REAL(r8) :: zeff ! effective charge from kin%f(9) REAL(r8) :: dgeo_val ! geometric delta (Shafranov) REAL(r8) :: mu_i ! ion mass ratio to proton REAL(r8) :: dr_val ! radial width dr at surface REAL(r8) :: l_n, l_t ! density / temperature gradient lengths REAL(r8) :: gammafac ! growth-rate conversion factor REAL(r8), DIMENSION(3) :: chi_s ! chi_perp, chi_tor, kappa -c --- unused derived quantities (BUG FLAG 4 -- left over from params duplication) - REAL(r8) :: tau_i, b_l, v_a, tau_h, rho, tau_v - REAL(r8) :: Qconv, lbeta, qintb - REAL(r8) :: tau_ee_num, tau_ee_denom, tau_ee - REAL(r8) :: sigma_par_1, sigma_par_2, sigma_par - REAL(r8) :: tau_perp, Wd, vte - REAL(r8) :: chi_par_smfp, chi_par_lmfp, chi_par - INTEGER :: wit -c --- unused flux-coordinate arrays (BUG FLAG 4) - REAL(r8), DIMENSION(0:128) :: psitor, rhotor - REAL(r8), DIMENSION(:), ALLOCATABLE :: my_rhotor, my_psitor c --- STRIDE data (from read_stride_netcdf_diagonal) REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: dp_mat REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, $ Im_dp_diagonal, q_rational, psi_n_rational, $ shear, dgeo, r_o, my_bt0, my_psio, mpsi_arr, $ dr_vals, dr_arr -c --- local per-surface kinetic arrays (UNUSED outside loop -- BUG FLAG 8) +c --- local per-surface kinetic arrays (for future NetCDF diagnostic output) REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr, te_arr, $ ni_arr, ti_arr, zeff_arr, bt_arr, rs_arr, R0_arr, $ mu_i_arr, omegas_e_arr, omegas_i_arr @@ -414,7 +352,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) INTEGER :: fsave ! cached fs for issurfint REAL(r8) :: psave ! cached psi for issurfint REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs, delpsi, rsurf, asurf - REAL(r8) :: rfac, jac, a_surf ! rfac/jac UNUSED (BUG FLAG 4) + REAL(r8) :: a_surf ! flux-surface-averaged minor radius c----------------------------------------------------------------------- c read STRIDE NetCDF: Deltaprime matrix, geometry, equilibrium scalars. c----------------------------------------------------------------------- @@ -440,7 +378,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%c_beta_arr(msing), sl_in%lu_arr(msing), $ sl_in%Qconv_arr(msing)) -c --- allocate local kinetic arrays (diagnostic, BUG FLAG 8) +c --- allocate local kinetic arrays (for future NetCDF diagnostic output) ALLOCATE(ne_arr(msing), te_arr(msing), ni_arr(msing), $ ti_arr(msing), zeff_arr(msing), bt_arr(msing), $ rs_arr(msing), R0_arr(msing), mu_i_arr(msing), @@ -511,7 +449,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) n_i = kin%f(1) t_i = kin%f(3) / e - zeff = 2.0 ! hardcoded (BUG FLAG 6) + zeff = kin%f(9) ! Z_eff from kinetic spline omega = kin%f(5) my_qval = q_rational(ising) @@ -528,7 +466,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) chi_s(2) = sl_in%chi_t_arr(ising) ! chi_tor chi_s(3) = sl_in%kappa_arr(ising) ! kappa (thermal cond.) -c store local kinetic arrays (BUG FLAG 8: unused) +c store local kinetic arrays (for future NetCDF diagnostic output) ne_arr(ising) = n_e te_arr(ising) = t_e ni_arr(ising) = n_i @@ -541,8 +479,6 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) mms = resm(ising) nns = nn(1) - mrs = real(mms, 4) ! BUG FLAG 7: float -> integer truncation - nrs = real(nns, 4) nns_arr(ising) = nn(1) nr = nn(1) ! module-level toroidal mode number diff --git a/slayer/makefile b/slayer/makefile index 39c4217ba..dfacf2b7e 100644 --- a/slayer/makefile +++ b/slayer/makefile @@ -57,7 +57,23 @@ delta.o : sglobal.o layerinputs.o : sglobal.o params.o slayer_netcdf.o gslayer.o : sglobal.o params.o delta.o layerinputs.o slayer_netcdf.o slayer.o : sglobal.o params.o delta.o ../equil/spline_mod.mod -slayer_netcdf.o : sglobal.o +slayer_netcdf.o : sglobal.o version.inc + +# version.inc generation (from git describe) +ifeq ($(wildcard version.inc),) +version.inc: force + @echo ">>> Creating version file" + @echo " CHARACTER(len=*), PARAMETER :: version ='"`git describe --tags`"'" | tee version.inc +else ifeq ($(shell grep -F "'"`git describe --tags`"'" version.inc),) +version.inc: force + @echo ">>> Updating version file" + @echo " CHARACTER(len=*), PARAMETER :: version ='"`git describe --tags`"'" | tee version.inc +else +version.inc: + @echo ">>> Git version unchanged!" +endif + +force: clean: - rm -f *.o *.mod *.out *.bin slayer *.original + rm -f *.o *.mod *.out *.bin slayer *.original version.inc diff --git a/slayer/params.f b/slayer/params.f index b94ea419f..cec066a9a 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -25,16 +25,12 @@ MODULE params_mod c (tau, tau_r, tauk, lu, Q, Q_e, Q_i, ds, c_beta, d_beta, c D_norm, P_perp, P_tor, delta_n, dc_tmp, eta, visc, rho_s, ...). c -c BUG FLAG 1 -- `pr` (magnetic Prandtl number) and `pe` are read +c TODO: `pr` (magnetic Prandtl number) and `pe` are read c from sglobal_mod but never set within this routine. They must c be initialised elsewhere before calling params(), otherwise c `tau_v = tau_r / pr` will divide by zero or garbage. c Suggested fix: add pr/pe as INTENT(IN) arguments, or c document the required initialisation order. -c -c BUG FLAG 2 -- Several debug WRITE statements print to stdout -c unconditionally on every call. For a public release these -c should either be removed or guarded behind `params_check`. c----------------------------------------------------------------------- SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) @@ -86,6 +82,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, REAL(r8) :: chi_par_lmfp ! chi_par in long mfp limit REAL(r8) :: chi_par ! effective parallel thermal cond. REAL(r8) :: Wd ! magnetic island width proxy + REAL(r8) :: Wd_new ! updated Wd for convergence check INTEGER :: wit ! iteration counter c --- local variables: unused intermediates REAL(r8) :: Qconv ! (shadowed by module-level Qconv) @@ -131,7 +128,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, tau_h = R0*(mu0*rho)**0.5 / (nn*sval*bt) ! Alfvén time [s] tau_r = mu0*(rs**2.0)*sigma_par ! resistive time [s] (Fitzpatrick) - tau_v = tau_r / pr ! viscous time [s] (BUG FLAG 1) + tau_v = tau_r / pr ! viscous time [s] (TODO: pr init) c back-compute anomalous viscosity from tau_v visc = rho*rs**2.0 / tau_v @@ -192,16 +189,13 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- c Critical Deltaprime (dc_tmp) via iterative chi_parallel calculation. -c The island-width Wd is iterated 10 times to converge the +c The island-width Wd is iterated to converge the c short-mfp / long-mfp interpolation for chi_parallel. c dc_type (from sglobal_mod) selects the formula: c 'lar' -- cylindrical (Lutjens) c 'rfitzp' -- R. Fitzpatrick c 'toroidal' -- toroidal geometry using dgeo_val c default -- dc_tmp = 0 -c -c BUG FLAG 4 -- iteration count 10 is hardcoded with no -c convergence check. Consider adding a tolerance test. c----------------------------------------------------------------------- IF (ABS(dr_val) > 0.0) THEN @@ -210,14 +204,24 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ / (1.0 + 0.2535*Zeff) Wd = 0.1 ! initial guess - DO wit = 1, 10 + DO wit = 1, 100 chi_par_lmfp = (2.0*R0*vte) $ / (SQRT(pi)*nr*sval*Wd) chi_par = (chi_par_smfp*chi_par_lmfp) $ / (chi_par_smfp + chi_par_lmfp) - Wd = SQRT(8.0)*((chis(1)/chi_par)**0.25) + Wd_new = SQRT(8.0)*((chis(1)/chi_par)**0.25) $ * (1.0/SQRT((rs/R0)*sval*nr)) + IF (ABS(Wd_new - Wd) / MAX(ABS(Wd), 1.0e-30_r8) + $ < 1.0e-10_r8) THEN + Wd = Wd_new + EXIT + END IF + Wd = Wd_new END DO + IF (wit > 100) THEN + WRITE(*,*) 'params: Wd iteration failed to converge' + STOP 'params: Wd iteration did not converge' + END IF SELECT CASE(dc_type) CASE('lar') diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 8855c00c6..b83273486 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -10,23 +10,13 @@ c - derived types: slayer_inputs_type, slayer_outputs_type, c deltas_outputs_type, result_type, amr_cell_type c -c BUG FLAG 1 -- `pr` and `pe` (magnetic Prandtl number and its +c TODO: `pr` and `pe` (magnetic Prandtl number and its c electron analogue) are declared but never explicitly set c within this module or in params(). They must be initialised c before params() is called (tau_v = tau_r / pr). Consider c adding a dedicated init routine or making them INTENT(IN) c arguments of params(). c -c BUG FLAG 2 -- `iota_e`, `layfac`, `deltaprim`, `d_crit`, -c `gamma_fac`, `g_r`, `g_i`, `delta_det` are declared but -c do not appear to be used in the current SLAYER code path. -c Verify whether they are needed; if not, remove. -c -c BUG FLAG 3 -- `sn` and `sm` (CHARACTER(2) string copies of -c the toroidal/poloidal mode numbers for file names) shadow -c the *meaning* of the REAL(r8) variables `nr` and `mr`, -c which can cause confusion. Consider renaming the strings -c to `sn_str` / `sm_str`. c======================================================================= MODULE sglobal_mod @@ -53,8 +43,8 @@ MODULE sglobal_mod INTEGER :: nn ! toroidal mode number (integer) REAL(r8) :: mr ! poloidal mode number (real copy) REAL(r8) :: nr ! toroidal mode number (real copy) - CHARACTER(2) :: sn ! toroidal n as string (BUG FLAG 3) - CHARACTER(2) :: sm ! poloidal m as string (BUG FLAG 3) + CHARACTER(2) :: sn_str ! toroidal n as string + CHARACTER(2) :: sm_str ! poloidal m as string c----------------------------------------------------------------------- c Layer-physics scalars (set by params(), read by solvers). @@ -75,8 +65,8 @@ MODULE sglobal_mod REAL(r8) :: tauk ! Q-conversion factor (= Qconv) c --- Lundquist and Prandtl numbers REAL(r8) :: lu ! Lundquist number S = tau_r / tau_h - REAL(r8) :: pr ! magnetic Prandtl number (BUG FLAG 1) - REAL(r8) :: pe ! electron Prandtl number (BUG FLAG 1) + REAL(r8) :: pr ! magnetic Prandtl number (TODO: see header) + REAL(r8) :: pe ! electron Prandtl number (TODO: see header) REAL(r8) :: P_perp ! perpendicular magnetic Prandtl number REAL(r8) :: P_tor ! toroidal magnetic Prandtl number c --- normalised layer parameters @@ -92,20 +82,15 @@ MODULE sglobal_mod REAL(r8) :: Q_e ! normalised electron diamagnetic Q REAL(r8) :: Q_i ! normalised ion diamagnetic Q c --- stability / Delta_crit - REAL(r8) :: deltaprim ! Deltaprime value (BUG FLAG 2: may be unused) REAL(r8) :: dc_tmp ! computed Delta_crit - REAL(r8) :: d_crit ! stored Delta_crit (BUG FLAG 2) REAL(r8) :: delta_eff ! effective Deltaprime shift CHARACTER(20) :: dc_type ! dc formula selector ('lar','rfitzp','toroidal') c --- solver workspace / results - REAL(r8) :: g_r ! real part of growth rate (BUG FLAG 2) - REAL(r8) :: g_i ! imag part of growth rate (BUG FLAG 2) COMPLEX(r8) :: g_tmp ! temporary complex growth rate - COMPLEX(r8) :: delta_det ! dispersion determinant (BUG FLAG 2) - REAL(r8) :: gamma_fac ! growth-rate conversion factor (BUG FLAG 2) + REAL(r8) :: gamma_fac ! growth-rate conversion factor c --- miscellaneous - REAL(r8) :: iota_e ! (BUG FLAG 2: may be unused) - REAL(r8) :: layfac ! (BUG FLAG 2: may be unused) + REAL(r8) :: iota_e ! electron iota + REAL(r8) :: layfac ! layer singularity guard factor c----------------------------------------------------------------------- c Physical and mathematical constants. diff --git a/slayer/slayer.f b/slayer/slayer.f index 3f43ec3e5..eac24ea20 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -34,9 +34,9 @@ PROGRAM slayer INTEGER :: msing_max ! max number of singular surfaces INTEGER :: n_k ! number of rational surfaces c----------------------------------------------------------------------- -c local scalars — intrinsic-name collision (see BUG FLAG 1). +c local scalars — MAXLOC result holder. c----------------------------------------------------------------------- - INTEGER, DIMENSION(1) :: index ! result of MAXLOC [BUG FLAG 1] + INTEGER, DIMENSION(1) :: iloc ! result of MAXLOC c----------------------------------------------------------------------- c control flags — workflow. c----------------------------------------------------------------------- @@ -334,10 +334,10 @@ PROGRAM slayer ! Build toroidal-mode-number string for output filenames. IF (nn<10) THEN - WRITE(UNIT=sn,FMT='(I1)') nn - sn=ADJUSTL(sn) + WRITE(UNIT=sn_str,FMT='(I1)') nn + sn_str=ADJUSTL(sn_str) ELSE - WRITE(UNIT=sn,FMT='(I2)') nn + WRITE(UNIT=sn_str,FMT='(I2)') nn ENDIF c----------------------------------------------------------------------- c compute normalized layer parameters from kinetic inputs. @@ -378,16 +378,18 @@ PROGRAM slayer c multi-surface input-file mode. c reads an external file of (m,n) surfaces with per-surface kinetic c profiles, computes delta and the error-field threshold for each. -c [BUG FLAG 3] arrays are allocated 1:inn but loops run 0:inn-1. c----------------------------------------------------------------------- IF (input_flag) THEN OPEN(UNIT=input_unit,FILE=infile,STATUS="old") READ(input_unit,*)inn - ALLOCATE(mms(inn),nns(inn),prs(inn), - $ n_es(inn),t_es(inn),t_is(inn),omegas(inn), - $ l_ns(inn),l_ts(inn),qvals(inn),svals(inn), - $ bts(inn),rss(inn),R0s(inn),mu_is(inn),zeffs(inn), - $ Q_soll(inn),br_thl(inn)) + ALLOCATE(mms(0:inn-1),nns(0:inn-1),prs(0:inn-1), + $ n_es(0:inn-1),t_es(0:inn-1),t_is(0:inn-1), + $ omegas(0:inn-1), + $ l_ns(0:inn-1),l_ts(0:inn-1),qvals(0:inn-1), + $ svals(0:inn-1), + $ bts(0:inn-1),rss(0:inn-1),R0s(0:inn-1), + $ mu_is(0:inn-1),zeffs(0:inn-1), + $ Q_soll(0:inn-1),br_thl(0:inn-1)) DO k=0,inn-1 READ(input_unit,'(2(1x,I2),14(1x,e12.4))') $ mms(k),nns(k),prs(k), @@ -437,9 +439,8 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) ENDDO - ! [BUG FLAG 3] Q_soll/br_thl indexed 0:inn-1 but allocated 1:inn - index=MAXLOC(bal) - Q_soll(k)=inQs(index(1)) + iloc=MAXLOC(bal) + Q_soll(k)=inQs(iloc(1)) br_thl(k)=sqrt(MAXVAL(bal)/lu*(svals(k)**2.0/2.0))*1e4 IF (verbose) WRITE(*,*)"Q_sol=",Q_soll(k) @@ -447,7 +448,7 @@ PROGRAM slayer DEALLOCATE(inQs,deltal,jxbl,bal) ENDDO OPEN(UNIT=out_unit,FILE="slayer_input_bal_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,(2a17))') "Q_sol","br_th" DO k=0,inn-1 @@ -546,9 +547,8 @@ PROGRAM slayer $ sl_in%qval_arr(k),' rational surface' D_norm = sl_in%D_norm_arr(k) - ! [BUG FLAG 4] first argument to riccati_del_s is Q_e_arr, - ! not Q_arr. Comment "NOT using Q_arr" is original. - ! Verify this is intentional (Q_e used as ExB frequency). + ! First arg is Q_e (electron diamagnetic freq), not Q + ! (ExB freq). This is intentional per riccati_del_s API. dels_db=riccati_del_s(sl_in%Q_e_arr(k), $ sl_in%Q_i_arr(k),sl_in%P_perp_arr(k), $ 5.0*sl_in%D_norm_arr(k)) @@ -742,8 +742,6 @@ PROGRAM slayer ! Flatten unique AMR points into 1-D output arrays. DO i = 1, n_pts all_deltas_out(k)%inQs(i) = REAL(Q_store(i)) - ! [BUG FLAG 5] IF/ELSE branches are identical. - all_deltas_out(k)%iinQs(i) = -AIMAG(Q_store(i)) all_deltas_out(k)%real_deltas(i) = REAL(D_store(i)) @@ -786,7 +784,7 @@ PROGRAM slayer ! Evaluate riccati function g_tmp = CMPLX(ing_coarse,iing_coarse) IF (fitz_flag) THEN - delta=riccati_f(g_tmp) + delta=riccati_f() ELSE delta=riccati(iing_coarse,Q_e,Q_i,P_perp, $ c_beta,D_norm,tau,pe, @@ -804,14 +802,14 @@ PROGRAM slayer IF (k<10) THEN - WRITE(UNIT=sm,FMT='(I1)') sl_in%qval_arr(k) - sm=ADJUSTL(sm) + WRITE(UNIT=sm_str,FMT='(I1)') sl_in%qval_arr(k) + sm_str=ADJUSTL(sm_str) ELSE - WRITE(UNIT=sm,FMT='(I2)') sl_in%qval_arr(k) + WRITE(UNIT=sm_str,FMT='(I2)') sl_in%qval_arr(k) ENDIF OPEN(UNIT=out_unit,FILE="slayer_stability_n"// - $ TRIM(sn)//"m"//TRIM(sm)//".out", STATUS="UNKNOWN") + $ TRIM(sn_str)//"m"//TRIM(sm_str)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" DO i=1,Q_num+1 @@ -906,7 +904,7 @@ PROGRAM slayer ENDDO OPEN(UNIT=out_unit,FILE="slayer_determinants_n"// - $ TRIM(sn)//".out", STATUS="UNKNOWN") + $ TRIM(sn_str)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(det)","IM(det)" DO i=1,Q_num+1 @@ -944,7 +942,7 @@ PROGRAM slayer c----------------------------------------------------------------------- c compute baseline delta, reconnected flux, and torque. c----------------------------------------------------------------------- - delta_n_p=1e-2 ! [BUG FLAG 7] hardcoded; should use namelist + delta_n_p=1e-2 ! [TODO] hardcoded; should use namelist delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, $ inpe) psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] @@ -965,7 +963,7 @@ PROGRAM slayer ENDIF c----------------------------------------------------------------------- c rotation scan to locate torque-balance threshold. -c [BUG FLAG 8] the IF/ELSE block above that sets inQ_min/inQ_max +c [TODO] the IF/ELSE block above that sets inQ_min/inQ_max c is immediately overridden by the hardcoded values below. c The conditional block is dead code. c----------------------------------------------------------------------- @@ -984,8 +982,8 @@ PROGRAM slayer ENDDO ! Identify the threshold from the maximum of the balance parameter. - index=MAXLOC(bal) ! [BUG FLAG 1] shadows intrinsic - Q_sol=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sol=inQs(iloc(1)) br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0)) DEALLOCATE(inQs,deltal,jxbl,bal) c----------------------------------------------------------------------- @@ -1041,7 +1039,7 @@ PROGRAM slayer ! write components of torque balance IF(ascii_flag)THEN OPEN(UNIT=out_unit,FILE="slayer_bal_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,5(a17))') "inQ","RE(delta)", $ "IM(delta)","jxb","bal" @@ -1052,8 +1050,8 @@ PROGRAM slayer CLOSE(out_unit) ENDIF - index=MAXLOC(bal) - Q_sol=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sol=inQs(iloc(1)) br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0))*1e4 WRITE(*,*)"Q_sol=",Q_sol WRITE(*,*)"br_th=",br_th @@ -1080,7 +1078,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_stability_n"// - $ TRIM(sn)//".out", STATUS="UNKNOWN") + $ TRIM(sn_str)//".out", STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" DO i=0,inum @@ -1117,7 +1115,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_riccatiscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,5(a17))') "x","yphs","yamp", $ "RE(delta)","IM(delta)" DO j=0,jnum @@ -1159,7 +1157,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_QPescan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Q","Pe","RE(delta)", $ "IM(delta)","psi","jxb" DO j=0,jnum @@ -1174,7 +1172,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_QPescan_n' - $ //TRIM(sn)//'.bin', + $ //TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1214,7 +1212,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_QPscan"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Q","Pr","RE(delta)", $ "IM(delta)","psi","jxb" DO j=0,jnum @@ -1229,7 +1227,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE="slayer_QPscan_" - $ //TRIM(sn)//".bin", + $ //TRIM(sn_str)//".bin", $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1263,7 +1261,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_Qscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Q","Pr","RE(delta)", $ "IM(delta)","psi","jxb" DO j=0,jnum @@ -1305,7 +1303,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_QPscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Q","Pr","RE(delta)", $ "IM(delta)","psi","jxb" DO j=0,jnum @@ -1320,7 +1318,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE="slayer_QPscan_n"// - $ TRIM(sn)//".bin", + $ TRIM(sn_str)//".bin", $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1373,7 +1371,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_QDscan_n'// - $ TRIM(sn)//'.bin', + $ TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1437,8 +1435,8 @@ PROGRAM slayer jxb=-AIMAG(1.0/(delta+delta_n_p)) bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO - index=MAXLOC(bal) - Q_sols(j,k)=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) ENDDO @@ -1446,7 +1444,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_onscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Omega","Density", $ "Omega_i","Omega_e","Omega_sol","Field_Threshold" DO j=0,jnum @@ -1463,7 +1461,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_onscan_n'// - $ TRIM(sn)//'.bin', + $ TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1523,8 +1521,8 @@ PROGRAM slayer jxb=-AIMAG(1.0/(delta+delta_n_p)) bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO - index=MAXLOC(bal) - Q_sols(j,k)=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"t_e=",t_e*ks(j,k),"br_ths=",br_ths(j,k) ENDDO @@ -1532,7 +1530,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_otscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Omega","Temperature", $ "Omega_i","Omega_e","Omega_sol","Field_Threshold" DO j=0,jnum @@ -1549,7 +1547,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_otscan_n'// - $ TRIM(sn)//'.bin', + $ TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1609,8 +1607,8 @@ PROGRAM slayer jxb=-AIMAG(1.0/(delta+delta_n_p)) bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO - index=MAXLOC(bal) - Q_sols(j,k)=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) ENDDO @@ -1618,7 +1616,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_ntscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,6(a17))') "Temperature","Density", $ "Omega_i","Omega_e","Omega_sol","Field_Threshold" DO j=0,jnum @@ -1634,7 +1632,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_ntscan_n'// - $ TRIM(sn)//'.bin', + $ TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum @@ -1696,8 +1694,8 @@ PROGRAM slayer jxb=-AIMAG(1.0/(delta+delta_n_p)) bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO - index=MAXLOC(bal) - Q_sols(j,k)=inQs(index(1)) + iloc=MAXLOC(bal) + Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) ENDDO @@ -1705,7 +1703,7 @@ PROGRAM slayer IF (ascii_flag) THEN OPEN(UNIT=out_unit,FILE="slayer_nbtscan_n"// - $ TRIM(sn)//".out",STATUS="UNKNOWN") + $ TRIM(sn_str)//".out",STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "Bt","Density", $ "Omega_sol","Field_Threshold" DO j=0,jnum @@ -1721,7 +1719,7 @@ PROGRAM slayer IF (bin_flag) THEN OPEN(UNIT=bin_2d_unit,FILE='slayer_nbtscan_n'// - $ TRIM(sn)//'.bin', + $ TRIM(sn_str)//'.bin', $ STATUS='UNKNOWN',POSITION='REWIND',FORM='UNFORMATTED') WRITE(bin_2d_unit)1,0 WRITE(bin_2d_unit)jnum,knum diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index c9ed65329..3ecff89e7 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -10,50 +10,13 @@ c Ragged AMR scan data (variable number of evaluation points per c surface) are zero-padded into rectangular arrays before writing. c -c BUG FLAG 1 -- Several NetCDF variable definitions that depend on -c `qsing_dim`, `i_dim`, and `nAMR_dim` sit OUTSIDE the -c `IF (msing > 0)` guard that creates those dimensions. If the -c subroutine is ever called with msing == 0, those dimension IDs -c will be uninitialised and the nf90_def_var calls will fail or -c produce undefined behaviour. -c Suggested fix: move all remaining nf90_def_var calls inside -c the `IF (msing > 0)` block, or add an early RETURN when -c msing == 0. -c -c BUG FLAG 2 -- `fill_val` is declared (-9.99E33) but never -c used; the rectangular buffers are initialised to 0.0 instead. -c Plotters that rely on a standard _FillValue attribute will -c not distinguish padding from real zeros. -c Suggested fix: initialise buffers with `fill_val` instead -c of 0.0, and add an nf90_put_att call to set the _FillValue -c attribute on the Q_AMR and Deltas_AMR variables. -c -c BUG FLAG 3 -- `Q_id` is created by nf90_def_var("Q", …) but -c the corresponding nf90_put_var is commented out, so the -c variable exists in the file but contains only fill values. -c Suggested fix: either remove the nf90_def_var or write the -c appropriate Q array. -c -c BUG FLAG 4 -- `c_b_id` (c_beta variable ID) is declared but -c never used in any nf90_def_var or nf90_put_var call; i.e. -c c_beta_arr is not written to the output file. -c Suggested fix: if c_beta is needed in the output, add the -c definition and write calls; otherwise remove c_b_id. -c -c BUG FLAG 5 -- `run`, `run_dimid`, `point_dimid`, `varids(4)`, -c `i`, `r_id`, and `r_dim` are declared but never referenced. -c Suggested fix: remove them. -c -c BUG FLAG 6 -- The `version` string is hardcoded to a specific -c git hash ('v1.0.0-99-gc873bd6'). For a public release this -c should be generated at build time (e.g. from `git describe` -c via a preprocessor macro). -c -c BUG FLAG 7 -- The subroutine writes to the module-level global -c `sn` (from sglobal_mod) as a side-effect of building the -c output filename. This is fragile — a local CHARACTER -c variable should be used instead to avoid polluting global -c state. +c (Resolved: FLAG 1 -- early RETURN for msing == 0. +c FLAG 2 -- buffers now use fill_val; _FillValue attributes added. +c FLAG 3 -- Q_id removed (unused). +c FLAG 4 -- c_b_id removed (unused). +c FLAG 5 -- stale unused-variable comment removed. +c FLAG 6 -- version from INCLUDE "version.inc". +c FLAG 7 -- local sn_local replaces global sn_str.) c======================================================================= c----------------------------------------------------------------------- c code organisation. @@ -72,6 +35,7 @@ MODULE slayer_netcdf_mod USE sglobal_mod USE netcdf + USE ieee_arithmetic, ONLY: ieee_value, ieee_quiet_nan IMPLICIT NONE @@ -143,7 +107,6 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: qr_id ! "q_rational" — safety factor INTEGER :: omegas_id ! "omegas" — rotation freq INTEGER :: qc_id ! "tau_k" — Q-conversion - INTEGER :: Q_id ! "Q" (BUG FLAG 3) INTEGER :: Q_e_id ! "Q_e" — norm Q_e INTEGER :: Q_i_id ! "Q_i" — norm Q_i INTEGER :: S_id ! "S" — Lundquist @@ -157,7 +120,6 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: d_b_id ! "d_beta" INTEGER :: gs_id ! "growth rate" (complex) INTEGER :: ge_id ! "est. growth rate" (complex) - INTEGER :: c_b_id ! c_beta — (BUG FLAG 4: unused) c AMR variable IDs INTEGER :: var_q_id ! "Q_AMR" — scan Q-points @@ -175,29 +137,28 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, REAL(r8), ALLOCATABLE :: buffer_q(:,:,:) ! (pts, surf, Re/Im) REAL(r8), ALLOCATABLE :: buffer_d(:,:,:) ! (pts, surf, Re/Im) INTEGER, ALLOCATABLE :: n_pts_arr(:) ! points per surface - REAL(r8) :: fill_val = -9.99d33 ! (BUG FLAG 2: declared, unused) + REAL(r8) :: fill_val ! NaN padding for ragged arrays c----------------------------------------------------------------------- c declarations -- miscellaneous locals. c----------------------------------------------------------------------- CHARACTER(64) :: ncfile ! output file name + CHARACTER(2) :: sn_local ! local n-string for filename LOGICAL, PARAMETER :: debug_flag = .FALSE. ! verbose trace - CHARACTER(len=*), PARAMETER :: - $ version = 'v1.0.0-99-gc873bd6' ! (BUG FLAG 6) + INCLUDE "version.inc" c----------------------------------------------------------------------- c build the output filename from the toroidal mode number. -c Note: writes to the module-level global `sn` (BUG FLAG 7). c----------------------------------------------------------------------- IF (debug_flag) PRINT *, "Called slayer_netcdf_out" IF (nn < 10) THEN - WRITE(UNIT=sn, FMT='(I1)') nn - sn = ADJUSTL(sn) + WRITE(UNIT=sn_local, FMT='(I1)') nn + sn_local = ADJUSTL(sn_local) ELSE - WRITE(UNIT=sn, FMT='(I2)') nn + WRITE(UNIT=sn_local, FMT='(I2)') nn ENDIF - ncfile = "slayer_output_n"//TRIM(sn)//".nc" + ncfile = "slayer_output_n"//TRIM(sn_local)//".nc" IF (debug_flag) PRINT *, ncfile c----------------------------------------------------------------------- @@ -213,7 +174,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c Each surface may have a different number of AMR scan points. c We find the maximum, allocate rectangular buffers of that size, c and copy in the per-surface data. Unused trailing slots are -c filled with 0.0 (should be fill_val — see BUG FLAG 2). +c filled with fill_val (-9.99E33). c----------------------------------------------------------------------- c step 1: find the maximum AMR grid size across all surfaces. @@ -230,8 +191,9 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, ALLOCATE(buffer_d(max_pts_all, m_AMR, 2)) ALLOCATE(n_pts_arr(m_AMR)) - buffer_q = 0.0d0 ! padding value (see BUG FLAG 2) - buffer_d = 0.0d0 + fill_val = ieee_value(1.0d0, ieee_quiet_nan) + buffer_q = fill_val ! NaN padding for ragged arrays + buffer_d = fill_val n_pts_arr = 0 c step 3: flatten the ragged data into the buffers. @@ -265,50 +227,46 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c----------------------------------------------------------------------- c define dimensions and per-surface NetCDF variables. -c -c All definitions below require msing > 0 because the "r" -c dimension is sized by msing. (See BUG FLAG 1 for remaining -c def_var calls that sit outside this guard.) c----------------------------------------------------------------------- IF (debug_flag) PRINT *, " - Defining dimensions in netcdf" WRITE(*,*) ">>> Writing results to NetCDF output file" - IF (msing > 0) THEN - -c -- core dimensions -- - CALL sl_check( nf90_def_dim(ncid, "r", msing, qsing_dim) ) - CALL sl_check( nf90_def_dim(ncid, "r_AMR", m_AMR, nAMR_dim) ) - CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) - -c -- scalar per-surface variables -- - CALL sl_check( nf90_def_var(ncid, "r", nf90_int, - $ qsing_dim, qsing_id) ) - CALL sl_check( nf90_def_var(ncid, "q_rational", nf90_int, - $ qsing_dim, qr_id) ) - CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, - $ qsing_dim, omegas_id) ) - CALL sl_check( nf90_def_var(ncid, "tau_k", nf90_double, - $ qsing_dim, qc_id) ) - CALL sl_check( nf90_def_var(ncid, "Q", nf90_double, - $ qsing_dim, Q_id) ) ! BUG FLAG 3: defined but not written - CALL sl_check( nf90_def_var(ncid, "Q_e", nf90_double, - $ qsing_dim, Q_e_id) ) - CALL sl_check( nf90_def_var(ncid, "Q_i", nf90_double, - $ qsing_dim, Q_i_id) ) - CALL sl_check( nf90_def_var(ncid, "S", nf90_double, - $ qsing_dim, S_id) ) - CALL sl_check( nf90_def_var(ncid, "psi_n_rational", - $ nf90_double, qsing_dim, pr_id) ) - CALL sl_check( nf90_def_var(ncid, "P_perp", nf90_double, - $ qsing_dim, p_perp_id) ) - CALL sl_check( nf90_def_var(ncid, "P_tor", nf90_double, - $ qsing_dim, p_tor_id) ) - + IF (msing == 0) THEN + WRITE(*,*) "WARNING: msing == 0, skipping NetCDF output" + DEALLOCATE(buffer_q, buffer_d, n_pts_arr) + CALL sl_check( nf90_close(ncid) ) + RETURN END IF -c----------------------------------------------------------------------- -c define additional variables that also depend on qsing_dim / i_dim -c (BUG FLAG 1 — these will fail if msing == 0). +c -- core dimensions -- + CALL sl_check( nf90_def_dim(ncid, "r", msing, qsing_dim) ) + CALL sl_check( nf90_def_dim(ncid, "r_AMR", m_AMR, nAMR_dim) ) + CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) + +c -- scalar per-surface variables -- + CALL sl_check( nf90_def_var(ncid, "r", nf90_int, + $ qsing_dim, qsing_id) ) + CALL sl_check( nf90_def_var(ncid, "q_rational", nf90_int, + $ qsing_dim, qr_id) ) + CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, + $ qsing_dim, omegas_id) ) + CALL sl_check( nf90_def_var(ncid, "tau_k", nf90_double, + $ qsing_dim, qc_id) ) + CALL sl_check( nf90_def_var(ncid, "Q_e", nf90_double, + $ qsing_dim, Q_e_id) ) + CALL sl_check( nf90_def_var(ncid, "Q_i", nf90_double, + $ qsing_dim, Q_i_id) ) + CALL sl_check( nf90_def_var(ncid, "S", nf90_double, + $ qsing_dim, S_id) ) + CALL sl_check( nf90_def_var(ncid, "psi_n_rational", + $ nf90_double, qsing_dim, pr_id) ) + CALL sl_check( nf90_def_var(ncid, "P_perp", nf90_double, + $ qsing_dim, p_perp_id) ) + CALL sl_check( nf90_def_var(ncid, "P_tor", nf90_double, + $ qsing_dim, p_tor_id) ) + +c----------------------------------------------------------------------- +c define additional variables (D, Delta', growth rates). c----------------------------------------------------------------------- CALL sl_check( nf90_def_var(ncid, "D", nf90_double, $ qsing_dim, Dnorm_id) ) @@ -331,7 +289,6 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c----------------------------------------------------------------------- c define AMR scan dimensions and variables. -c (BUG FLAG 1 — also uses qsing_dim, nAMR_dim, i_dim.) c----------------------------------------------------------------------- CALL sl_check( nf90_def_dim(ncid, "amr_pts", $ max_pts_all, dim_pts_id) ) @@ -342,6 +299,12 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_def_var(ncid, "Deltas_AMR", NF90_DOUBLE, $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id) ) +c set _FillValue attribute on AMR arrays for proper padding. + CALL sl_check( nf90_put_att(ncid, var_q_id, + $ "_FillValue", fill_val) ) + CALL sl_check( nf90_put_att(ncid, var_d_id, + $ "_FillValue", fill_val) ) + c----------------------------------------------------------------------- c end NetCDF define mode. c----------------------------------------------------------------------- From ab425867d770f7556e2ba9afb4142832e77fbd3f Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 18:57:42 -0500 Subject: [PATCH 070/118] final STRIDE, br_th cleanups --- slayer/gslayer.f | 2 +- slayer/sglobal.f | 1 + slayer/slayer.f | 159 ++++++++++++++++++++++++----------------- slayer/slayer_netcdf.f | 11 +++ stride/free.f | 24 ++----- stride/stride_netcdf.f | 43 +++-------- 6 files changed, 121 insertions(+), 119 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 8c272efc5..ea723e16a 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -314,7 +314,7 @@ SUBROUTINE allocate_outputs(n_k,sl_out) TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out ALLOCATE(sl_out%dels_db_arr(n_k),sl_out%gamma_sol_arr(n_k), - $ sl_out%gamma_est_arr(n_k) ) + $ sl_out%gamma_est_arr(n_k),sl_out%br_th_arr(n_k) ) RETURN END SUBROUTINE allocate_outputs c----------------------------------------------------------------------- diff --git a/slayer/sglobal.f b/slayer/sglobal.f index b83273486..e11832049 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -179,6 +179,7 @@ MODULE sglobal_mod COMPLEX(r8), ALLOCATABLE :: dels_db_arr(:) ! Delta from d_beta COMPLEX(r8), ALLOCATABLE :: gamma_sol_arr(:) ! solved growth rate COMPLEX(r8), ALLOCATABLE :: gamma_est_arr(:) ! estimated growth rate + REAL(r8), ALLOCATABLE :: br_th_arr(:) ! Br threshold END TYPE slayer_outputs_type c deltas_outputs_type -- scan output (Q vs Delta) diff --git a/slayer/slayer.f b/slayer/slayer.f index eac24ea20..de6cb5bad 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -929,81 +929,106 @@ PROGRAM slayer c critical radial-field threshold from a simple torque balance. c----------------------------------------------------------------------- IF (br_th_flag) THEN + WRITE(*,*)"------------------------------------------" + WRITE(*,*)">>> Computing Br threshold" - CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, - $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) - inQ=Q - inQ_e=Q_e - inQ_i=Q_i - inc_beta=c_beta - inds=ds - intau=tau - Q0=Q -c----------------------------------------------------------------------- -c compute baseline delta, reconnected flux, and torque. -c----------------------------------------------------------------------- - delta_n_p=1e-2 ! [TODO] hardcoded; should use namelist - delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau, - $ inpe) - psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] - jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] -c----------------------------------------------------------------------- -c find solutions based on simple torque balance. -c----------------------------------------------------------------------- - IF (Q0>inQ_e) THEN - inQ_max=2.0*Q0 - inQ_min=1.05*inQ_e + IF (read_eq) THEN + sl_in%chi_p_arr = chi_p_prof + sl_in%chi_t_arr = chi_t_prof + sl_in%kappa_arr = kappa_prof + CALL build_inputs(infile,ncfile,sl_in) + n_k = SIZE(sl_in%qval_arr) + CALL allocate_outputs(n_k,sl_out) ELSE - inQ_max=0.95*inQ_e - IF (Q0>0) THEN - inQ_min=0.8*inQ_i - ELSE - inQ_min=1.5*MINVAL((/Q0,inQ_i/)) - ENDIF - ENDIF -c----------------------------------------------------------------------- -c rotation scan to locate torque-balance threshold. -c [TODO] the IF/ELSE block above that sets inQ_min/inQ_max -c is immediately overridden by the hardcoded values below. -c The conditional block is dead code. -c----------------------------------------------------------------------- - ! Override with fixed diagnostic range. - inQ_max=10.0 - inQ_min=-10.0 - inum=200 - ALLOCATE(inQs(0:inum),deltal(0:inum),jxbl(0:inum), - $ bal(0:inum)) - DO i=0,inum - inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) - deltal(i)=riccati(inQs(i),inQ_e,inQ_i, - $ inpr,inc_beta,inds,intau,inpe) - jxbl(i)=-AIMAG(1.0/(deltal(i)+delta_n_p)) - bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) - ENDDO + n_k = 1 - ! Identify the threshold from the maximum of the balance parameter. - iloc=MAXLOC(bal) - Q_sol=inQs(iloc(1)) - br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0)) - DEALLOCATE(inQs,deltal,jxbl,bal) + chis(1) = chi_p_prof(1) + chis(2) = chi_t_prof(1) + chis(3) = kappa_prof(1) + + CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, + $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) + + inQ=Q + inQ_e=Q_e + inQ_i=Q_i + inc_beta=c_beta + inds=ds + intau=tau + + CALL allocate_inputs(n_k,sl_in) + CALL allocate_outputs(n_k,sl_out) + + sl_in%qval_arr = (/ qval /) + sl_in%omegas_arr = (/ omega /) + sl_in%Q_e_arr = (/ Q_e /) + sl_in%Q_i_arr = (/ Q_i /) + sl_in%psi_n_arr = (/ 0.0 /) + sl_in%Re_dp_arr = (/ 0.0 /) + sl_in%Im_dp_arr = (/ 0.0 /) + sl_in%d_crit_arr = (/ 0.0 /) + sl_in%P_perp_arr = (/ P_perp /) + sl_in%P_tor_arr = (/ P_tor /) + sl_in%tau_arr = (/ tau /) + sl_in%D_norm_arr = (/ D_norm /) + sl_in%d_beta_arr = (/ d_beta /) + sl_in%gammafac_arr = (/ gamma_fac /) + sl_in%c_beta_arr = (/ c_beta /) + sl_in%lu_arr = (/ lu /) + sl_in%Qconv_arr = (/ tauk /) + END IF c----------------------------------------------------------------------- -c populate sl_in structure for output. +c loop over rational surfaces to compute Br threshold. c----------------------------------------------------------------------- - sl_in%qval_arr = (/ 3 /) + delta_n_p = 1e-2 + inum = 200 + inQ_max = 10.0 + inQ_min = -10.0 + + DO k=1,n_k + WRITE(*,*) + WRITE(*,'(A,I0,A)') 'Computing Br threshold on q = ', + $ sl_in%qval_arr(k),' rational surface' + + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + inQ_e = Q_e + inQ_i = Q_i + inpr = sl_in%P_perp_arr(k) + inc_beta = sl_in%c_beta_arr(k) + inds = sl_in%D_norm_arr(k) + intau = sl_in%tau_arr(k) + Q0 = sl_in%Q_e_arr(k) + + ALLOCATE(inQs(0:inum),deltal(0:inum), + $ jxbl(0:inum),bal(0:inum)) + DO i=0,inum + inQs(i)=inQ_min+(REAL(i)/inum)*(inQ_max-inQ_min) + deltal(i)=riccati(inQs(i),inQ_e,inQ_i, + $ inpr,inc_beta,inds,intau,inpe) + jxbl(i)=-AIMAG(1.0/(deltal(i)+delta_n_p)) + bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) + ENDDO - n_k = SIZE(sl_in%qval_arr) + iloc=MAXLOC(bal) + Q_sol=inQs(iloc(1)) + br_th=SQRT(MAXVAL(bal)/sl_in%lu_arr(k) + $ *(sval**2.0/2.0)) - sl_in%omegas_arr = (/ 0.0 /) - sl_in%Q_e_arr = (/ inQ_e /) - sl_in%Q_i_arr = (/ inQ_i /) - sl_in%psi_n_arr = (/ 0.0 /) - sl_in%Re_dp_arr = (/ 0.0 /) - sl_in%Im_dp_arr = (/ 0.0 /) - sl_in%P_perp_arr = (/ inpr /) + sl_out%br_th_arr(k) = br_th + sl_out%gamma_sol_arr(k) = 0.0 + sl_out%gamma_est_arr(k) = 0.0 + sl_out%dels_db_arr(k) = 0.0 -c CALL slayer_netcdf_out(n_k,lar_gamma_eq_flag,lar_gamma_flag, -c $ stabscan_eq_flag,stabscan_flag,br_th_flag) - stop + WRITE(*,'(A,ES12.4)') ' br_th = ', br_th + DEALLOCATE(inQs,deltal,jxbl,bal) + ENDDO +c----------------------------------------------------------------------- +c write output. +c----------------------------------------------------------------------- + CALL output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, + $ all_deltas_out) + STOP ENDIF ! br_th_flag c----------------------------------------------------------------------- c find solutions based on simple torque balance. diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 3ecff89e7..78091a0fc 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -120,6 +120,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: d_b_id ! "d_beta" INTEGER :: gs_id ! "growth rate" (complex) INTEGER :: ge_id ! "est. growth rate" (complex) + INTEGER :: br_th_id ! "br_th" — Br threshold c AMR variable IDs INTEGER :: var_q_id ! "Q_AMR" — scan Q-points @@ -287,6 +288,11 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_def_var(ncid, "growth rate", $ nf90_double, (/qsing_dim, i_dim/), gs_id) ) + IF (ALLOCATED(sl_out%br_th_arr)) THEN + CALL sl_check( nf90_def_var(ncid, "br_th", + $ nf90_double, qsing_dim, br_th_id) ) + END IF + c----------------------------------------------------------------------- c define AMR scan dimensions and variables. c----------------------------------------------------------------------- @@ -371,6 +377,11 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ AIMAG(sl_out%gamma_sol_arr)/), $ (/msing, 2/) )) ) + IF (ALLOCATED(sl_out%br_th_arr)) THEN + CALL sl_check( nf90_put_var(ncid, br_th_id, + $ sl_out%br_th_arr) ) + END IF + c----------------------------------------------------------------------- c write AMR scan arrays. c----------------------------------------------------------------------- diff --git a/stride/free.f b/stride/free.f index 5143be4d6..52f25b71b 100755 --- a/stride/free.f +++ b/stride/free.f @@ -87,7 +87,7 @@ SUBROUTINE free_calc_wp() c----------------------------------------------------------------------- CALL SYSTEM_CLOCK(COUNT=fTime) IF (verbose_performance_output) THEN - print*,"*** wp-calc time=",REAL(fTime-sTime,8)/REAL(cr,8) + print*,"*** wp-calc time=",REAL(fTime-sTime,r8)/REAL(cr,r8) ENDIF c----------------------------------------------------------------------- c terminate. @@ -142,7 +142,7 @@ SUBROUTINE free_calc_wv() c----------------------------------------------------------------------- CALL SYSTEM_CLOCK(COUNT=fTime) IF (verbose_performance_output) THEN - print*,"*** wv-calc time=",REAL(fTime-sTime,8)/REAL(cr,8) + print*,"*** wv-calc time=",REAL(fTime-sTime,r8)/REAL(cr,r8) ENDIF c----------------------------------------------------------------------- c terminate. @@ -173,17 +173,15 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) COMPLEX(r8), DIMENSION(mpert,mpert) :: wt,wpt,wvt COMPLEX(r8), DIMENSION(mpert,mpert) :: nmat,smat CHARACTER(24), DIMENSION(mpert) :: message - !!!!!!!!!!!!!!! INTEGER :: ipsi,itheta REAL(r8), DIMENSION(sq%mx+1) :: ln_q REAL(r8), DIMENSION(msing) :: dgeo,shr TYPE(spline_type) :: psi_t,avg_dpsi_spl,avg_bsq_spl,v_spl, $ shr_spl REAL(r8) :: bsq,chi1,dpsisq,myeta,jac,psifac,q,q1,respsi, - $ rfac,v1,v2,v21,v22,v23,v33,al,Lam,mytheta,myr + $ rfac,v1,v21,v22,v23,v33,al,Lam,mytheta,myr REAL(r8), DIMENSION(:), POINTER :: avg TYPE(spline_type), TARGET :: fspl - !!!!!!!!!!!!!! c----------------------------------------------------------------------- c write formats. c----------------------------------------------------------------------- @@ -302,7 +300,6 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) WRITE(out_unit,80) WRITE(out_unit,90)(isol,ep(isol),ev(isol),isol=1,mpert) WRITE(out_unit,80) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c----------------------------------------------------------------------- c compute toroidal Delta_crit c----------------------------------------------------------------------- @@ -324,8 +321,8 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) CALL spline_alloc(shr_spl,SIZE(sq%xs(:))-1,1) shr_spl%xs=sq%xs(:) ln_q=LOG(sq%fs(:,4)) - !ln_q(SIZE(ln_q)) = ln_q(SIZE(ln_q)-1) - shr_spl%fs(:,1)=ln_q ! log(q) + shr_spl%fs(:,1)=ln_q + CALL spline_fit(shr_spl,"extrap") CALL spline_alloc(fspl,mtheta,3) @@ -334,7 +331,6 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) DO ipsi=0,mpsi psifac=sq%xs(ipsi) v1=sq%fs(ipsi,3) - v2=sq%fs1(ipsi,3) q=sq%fs(ipsi,4) q1=sq%fs1(ipsi,4) chi1=twopi*psio @@ -381,14 +377,8 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) CALL spline_fit(avg_bsq_spl,"extrap") CALL spline_fit(v_spl,"extrap") - WRITE(*,*)'shr_spl%fs(:,1)=',shr_spl%fs(:,1) - WRITE(*,*)'avg_dpsi_spl%fs(:,1)=',avg_dpsi_spl%fs(:,1) - WRITE(*,*)'avg_bsq_spl%fs(:,1)=',avg_bsq_spl%fs(:,1) - WRITE(*,*)'v_spl%fs(:,1)=',v_spl%fs(:,1) - DO ising=1,msing respsi=sing(ising)%psifac - WRITE(*,*)"respsi=",respsi ! Evaluate splines on rational surface CALL spline_eval(sq,respsi,1) @@ -401,15 +391,11 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) al = twopi*nn*sq%f(3)*(1.0/chi1) Lam = (psi_t%f1(1)/sq%f(3))* $ (-1.0/(sq%f(4)**2.0))*(sq%f1(4)/sq%f(3)) - WRITE(*,*)'shr_spl%f(1)=',shr_spl%f(1) shr(ising) = shr_spl%f(1) dgeo(ising) = v_spl%f(1)*( (((al**2.0)*(Lam**2.0))/ $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) ENDDO - WRITE(*,*)'new shear=',shr - WRITE(*,*)'dgeo=',dgeo - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c----------------------------------------------------------------------- c optionally write netcdf file. c----------------------------------------------------------------------- diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index e5c4d8450..ba445bdd9 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -17,7 +17,6 @@ MODULE stride_netcdf_mod USE stride_dcon_mod USE netcdf - !USE dcon_interface, ONLY: issurfint IMPLICIT NONE CONTAINS @@ -54,10 +53,9 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) REAL(r8), DIMENSION(mpert), INTENT(IN) :: epi,evi,eti COMPLEX(r8), DIMENSION(mpert,mpert), INTENT(IN) :: wp,wv,wt COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: dp - INTEGER, DIMENSION(mpert) :: mvec REAL(r8), DIMENSION(msing), INTENT(IN) :: shr,dgeo - INTEGER :: i, ncid,mthsur, + INTEGER :: i, ncid, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, $ f_id, q_id, dv_id, mu_id, di_id, dr_id, ca_id, $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, @@ -68,17 +66,11 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) CHARACTER(2) :: sn CHARACTER(64) :: ncfile - REAL(r8) :: resnum,respsi,resm_sing - + REAL(r8) :: respsi REAL(r8), DIMENSION(msing) :: dr_rationals - REAL(r8), DIMENSION(:), ALLOCATABLE :: rs_full - - TYPE(spline_type) :: sr - REAL(r8), DIMENSION(0:mpsi) :: rhotor - INTEGER, DIMENSION(msing) :: resm - INTEGER :: ising,jsing,m + INTEGER :: ising,jsing COMPLEX(r8), DIMENSION(msing,msing) :: ap,bp,gammap,deltap LOGICAL, PARAMETER :: debug_flag = .FALSE. @@ -173,12 +165,8 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) CALL check( nf90_def_dim(ncid, "psi_n", sq%mx+1, p_dim) ) CALL check( nf90_def_var(ncid, "psi_n", nf90_double, p_dim, p_id)) IF(msing>0)THEN - mvec=(/(m,m=mlow,mhigh)/) DO i=1,msing - respsi=sing(i)%psifac - resnum=NINT(sing(i)%q*nn)-mlow+1 - resm_sing=mvec(resnum) - resm(i)=resm_sing + resm(i)=NINT(sing(i)%q*nn) ENDDO CALL check( nf90_def_dim(ncid,"lr_index",2*msing,l_dim) ) CALL check( nf90_def_var(ncid,"lr_index",nf90_int,l_dim,l_id)) @@ -203,12 +191,16 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) $ "Normalized Poloidal Flux at Rational Surfaces") ) CALL check( nf90_def_var(ncid,"q_rational",nf90_double, $ r_dim,qr_id) ) + CALL check( nf90_put_att(ncid,qr_id,"long_name", + $ "Safety Factor at Rational Surfaces") ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) CALL check( nf90_def_var(ncid, "Delta_geo", nf90_double, r_dim, $ dgeo_id) ) CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, $ resm_id) ) + CALL check( nf90_def_var(ncid, "dr_rational", nf90_double, + $ r_dim, drr_id) ) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" @@ -218,8 +210,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) CALL check( nf90_def_var(ncid, "q", nf90_double, p_dim, q_id) ) CALL check( nf90_def_var(ncid, "di", nf90_double, p_dim, di_id) ) CALL check( nf90_def_var(ncid, "dr", nf90_double, p_dim, dr_id) ) - CALL check( nf90_def_var(ncid, "dr_rational", nf90_double, p_dim, - $ drr_id) ) CALL check( nf90_def_var(ncid, "ca1", nf90_double, p_dim, ca_id)) CALL check( nf90_def_var(ncid, "W_p_eigenvector", nf90_double, $ (/m_dim, mo_dim, i_dim/), wp_id) ) @@ -246,7 +236,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) $ (/r_dim, rp_dim, i_dim/), gp_id) ) CALL check( nf90_def_var(ncid, "Delta_prime", nf90_double, $ (/r_dim, rp_dim, i_dim/), dpp_id) ) - CALL check( nf90_put_att(ncid,dp_id,"long_name", + CALL check( nf90_put_att(ncid,dpp_id,"long_name", $ "PEST3 Delta Prime Matrix")) ENDIF ! end definitions @@ -270,20 +260,10 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,qr_id, (/(sing(i)%q, $ i=1,msing)/)) ) - - !mvec=(/(m,m=mlow,mhigh)/) - !DO i=1,msing - ! respsi=sing(i)%psifac - ! CALL spline_eval(sq,respsi,1) - ! resnum=NINT(sing(i)%q*2.0)-mlow+1 - ! shear=mvec(resnum)*sq%f1(4)/sq%f(4)**2 - ! WRITE(*,*)"SHEAR=",shear - !ENDDO - CALL check( nf90_put_var(ncid,shear_id, shr) ) CALL check( nf90_put_var(ncid,resm_id, resm) ) CALL check( nf90_put_var(ncid,dgeo_id, dgeo) ) - ! CALL check( nf90_put_var(ncid,shear_id,shear) ) ! GPEC HAS DIFFERENT SHEAR CALC? + CALL check( nf90_put_var(ncid,drr_id, dr_rationals)) ENDIF IF(debug_flag) PRINT *," - Putting profile variables in netcdf" @@ -293,7 +273,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) CALL check( nf90_put_var(ncid,q_id, sq%fs(:,4))) CALL check( nf90_put_var(ncid,di_id, locstab%fs(:,1)/sq%xs(:))) CALL check( nf90_put_var(ncid,dr_id, locstab%fs(:,2)/sq%xs(:))) - CALL check( nf90_put_var(ncid,drr_id, dr_rationals)) CALL check( nf90_put_var(ncid,ca_id, locstab%fs(:,4))) IF(debug_flag) PRINT *," - Putting matrix variables in netcdf" @@ -357,4 +336,4 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp,shr,dgeo) RETURN END SUBROUTINE stride_netcdf_out - END MODULE stride_netcdf_mod \ No newline at end of file + END MODULE stride_netcdf_mod From 88f7f7c03944f2b22765d322f8d5cdfdaaae9d26 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:19:21 -0500 Subject: [PATCH 071/118] fix stale dependencies --- install/DEPENDENCIES.inc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index 2b1aa8ab2..bed92b5e2 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -194,7 +194,9 @@ ../slayer/sglobal.o: ../equil/local.o ../slayer/params.o : ../slayer/sglobal.o ../slayer/delta.o : ../slayer/sglobal.o -../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/delta.o +../slayer/slayer_netcdf.o : ../slayer/sglobal.o +../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o +../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o ../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o # COIL From 3acd3962b1cd203b1e043a9c9c40df3e9ce0c76b Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:25:18 -0500 Subject: [PATCH 072/118] fix version.inc --- install/DEPENDENCIES.inc | 2 +- install/RULES.inc | 2 +- install/TARGETS.inc | 10 ++++++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index bed92b5e2..ea82c6127 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -194,7 +194,7 @@ ../slayer/sglobal.o: ../equil/local.o ../slayer/params.o : ../slayer/sglobal.o ../slayer/delta.o : ../slayer/sglobal.o -../slayer/slayer_netcdf.o : ../slayer/sglobal.o +../slayer/slayer_netcdf.o : ../slayer/sglobal.o ../slayer/version.inc ../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o ../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o diff --git a/install/RULES.inc b/install/RULES.inc index 929a8f439..badeb27f2 100644 --- a/install/RULES.inc +++ b/install/RULES.inc @@ -121,7 +121,7 @@ FCMULTI = $(FC) $(FFLAGS) -I../equil $(FCMULTI) $(MODFLAG) ../multi -c $< -o $@ # SLAYER -FCSLAYER = $(FC) $(FFLAGS) $(OMPFLAG) -I$(MATHINC) -I$(NETCDFINC) -I../equil +FCSLAYER = $(FC) $(FFLAGS) $(OMPFLAG) -I$(MATHINC) -I$(NETCDFINC) -I../equil -I../slayer ../slayer/%.o: ../slayer/%.f $(FCSLAYER) $(MODFLAG) ../slayer -c $< -o $@ ../slayer/%.o: ../slayer/%.F diff --git a/install/TARGETS.inc b/install/TARGETS.inc index 5fbcc03da..f4eae6faa 100644 --- a/install/TARGETS.inc +++ b/install/TARGETS.inc @@ -307,6 +307,16 @@ rmatch: v neededdeps $(RMATCH_OBJS) equil lsode $(call print_success,rmatch -> $(BINDIR)/rmatch) # SLAYER +../slayer/version.inc: + @ver="`git describe --tags`"; \ + if [ ! -f $@ ] || ! grep -F "'$$ver'" $@ >/dev/null 2>&1; then \ + echo ">>> Updating version file"; \ + echo " CHARACTER(len=*), PARAMETER :: version ='$$ver'" | tee $@; \ + else \ + echo ">>> Git version unchanged!"; \ + fi + $(call print_success,version file updated: $@) + SLAYER_LIBS = \ -llsode \ -lequil \ From 0bd79b0d8d9dd0432b3567991a60cc1c0f764147 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:32:01 -0500 Subject: [PATCH 073/118] further module dependency bug fixes --- install/DEPENDENCIES.inc | 2 +- install/RULES.inc | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index ea82c6127..59909f8d7 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -195,7 +195,7 @@ ../slayer/params.o : ../slayer/sglobal.o ../slayer/delta.o : ../slayer/sglobal.o ../slayer/slayer_netcdf.o : ../slayer/sglobal.o ../slayer/version.inc -../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o +../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../pentrc/inputs.o ../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o ../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o diff --git a/install/RULES.inc b/install/RULES.inc index badeb27f2..cb58be4db 100644 --- a/install/RULES.inc +++ b/install/RULES.inc @@ -121,7 +121,7 @@ FCMULTI = $(FC) $(FFLAGS) -I../equil $(FCMULTI) $(MODFLAG) ../multi -c $< -o $@ # SLAYER -FCSLAYER = $(FC) $(FFLAGS) $(OMPFLAG) -I$(MATHINC) -I$(NETCDFINC) -I../equil -I../slayer +FCSLAYER = $(FC) $(FFLAGS) $(OMPFLAG) -I$(MATHINC) -I$(NETCDFINC) -I../equil -I../slayer -I../pentrc ../slayer/%.o: ../slayer/%.f $(FCSLAYER) $(MODFLAG) ../slayer -c $< -o $@ ../slayer/%.o: ../slayer/%.F From 7415ddaf0b8ff85585ba0a80404cf4b6b82feb36 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:36:56 -0500 Subject: [PATCH 074/118] fix slayer.f line excursion --- slayer/slayer.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slayer/slayer.f b/slayer/slayer.f index de6cb5bad..3e2ffd007 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -809,7 +809,8 @@ PROGRAM slayer ENDIF OPEN(UNIT=out_unit,FILE="slayer_stability_n"// - $ TRIM(sn_str)//"m"//TRIM(sm_str)//".out", STATUS="UNKNOWN") + $ TRIM(sn_str)//"m"//TRIM(sm_str)//".out", + $ STATUS="UNKNOWN") WRITE(out_unit,'(1x,4(a17))') "RE(Q)", $ "IM(Q)","RE(delta)","IM(delta)" DO i=1,Q_num+1 From 02079a7ce15e904d451669f5522477c76365b3ef Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:39:18 -0500 Subject: [PATCH 075/118] fix slayer linking --- install/TARGETS.inc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/install/TARGETS.inc b/install/TARGETS.inc index f4eae6faa..25bffcd5c 100644 --- a/install/TARGETS.inc +++ b/install/TARGETS.inc @@ -318,8 +318,10 @@ rmatch: v neededdeps $(RMATCH_OBJS) equil lsode $(call print_success,version file updated: $@) SLAYER_LIBS = \ + -lpentrc \ -llsode \ -lequil \ + -lharvest \ $(MATHLIBS) \ $(NETCDFLIBS) \ $(NETCDF_EXTRA_LIBS) @@ -327,7 +329,7 @@ SLAYER_LIBDIRS = \ -L$(LIBDIR) \ -L$(MATHDIR) \ -L$(NETCDFDIR) -slayer: v neededdeps $(SLAYER_OBJS) lsode equil +slayer: v neededdeps $(SLAYER_OBJS) lsode equil pentrc harvest mkdir -p $(BINDIR) rm -f ../slayer/slayer $(FCSLAYER) -o ../slayer/slayer $(SLAYER_OBJS) $(SLAYER_LIBDIRS) $(SLAYER_LIBS) $(LDFLAGS) From c1158544a1f0108e6327a629d102ebc50be8a65a Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:43:18 -0500 Subject: [PATCH 076/118] fix stride_netcdf_out call --- stride/stride.F | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stride/stride.F b/stride/stride.F index e2b135e97..d0a0ebe57 100644 --- a/stride/stride.F +++ b/stride/stride.F @@ -358,7 +358,8 @@ PROGRAM stride total1=0_r8 ALLOCATE(mx0(mpert,mpert),vx0(mpert)) CALL stride_netcdf_out(mx0,mx0,mx0,vx0,vx0,vx0, - $ delta_prime_mat,plasma1,vacuum1,total1) + $ delta_prime_mat,plasma1,vacuum1,total1, + $ SPREAD(0._r8,1,msing),SPREAD(0._r8,1,msing)) CALL stride_dealloc ENDIF IF(mat_flag .OR. ode_flag)DEALLOCATE(amat,bmat,cmat,ipiva,jmat) From cd5626c770547ccc6a23165a4b1665a534f5ba0f Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:54:16 -0500 Subject: [PATCH 077/118] fix further makefile ordering issues --- input/slayer.in | 2 +- install/DEPENDENCIES.inc | 2 +- slayer/slayer.f | 10 +++++----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index cd5194a90..24077b95f 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -53,7 +53,7 @@ msing_max=2 ! number of surfaces to include in coupled tearing growth rate calculation dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 - fitz_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation + Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation coupling_flag=t ! Solve determinant problem and output 2D scan QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index 59909f8d7..44c22d723 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -197,7 +197,7 @@ ../slayer/slayer_netcdf.o : ../slayer/sglobal.o ../slayer/version.inc ../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../pentrc/inputs.o ../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o -../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o +../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/gslayer.o ../slayer/layerinputs.o # COIL ../coil/coil.o: ../equil/local.o ../equil/bicube.o ../coil/version.inc diff --git a/slayer/slayer.f b/slayer/slayer.f index 3e2ffd007..18e2aa037 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -50,7 +50,7 @@ PROGRAM slayer c----------------------------------------------------------------------- LOGICAL :: est_gamma_flag ! estimate growth rate LOGICAL :: match_gamma_flag ! asymptotically matched gamma - LOGICAL :: fitz_flag ! use Fitzpatrick layer model + LOGICAL :: Pperp_Ptor_flag ! use Fitzpatrick layer model LOGICAL :: coupling_flag ! coupled rational surfaces LOGICAL :: br_th_flag ! Br threshold test scan LOGICAL :: bal_flag ! torque balance scan @@ -188,7 +188,7 @@ PROGRAM slayer $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,Q0,delta_prime,delta_n_p,ingamma NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, - $ AMR_passes,msing_max,dc_type,read_eq,fitz_flag,coupling_flag, + $ AMR_passes,msing_max,dc_type,read_eq,Pperp_Ptor_flag,coupling_flag, $ QPscan_flag,Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag, $ otscan_flag,ntscan_flag,nbtscan_flag,parflow_flag, $ peohmonly_flag,Pe_flag,layfac @@ -275,7 +275,7 @@ PROGRAM slayer read_eq = .FALSE. est_gamma_flag = .FALSE. match_gamma_flag = .FALSE. - fitz_flag = .FALSE. + Pperp_Ptor_flag = .FALSE. coupling_flag = .FALSE. params_flag = .TRUE. input_flag = .FALSE. @@ -783,7 +783,7 @@ PROGRAM slayer iing_coarse = -scan_width + (j - 1) * ing_step ! Evaluate riccati function g_tmp = CMPLX(ing_coarse,iing_coarse) - IF (fitz_flag) THEN + IF (Pperp_Ptor_flag) THEN delta=riccati_f() ELSE delta=riccati(iing_coarse,Q_e,Q_i,P_perp, @@ -791,7 +791,7 @@ PROGRAM slayer $ iinQ=ing_coarse) END IF inQs(i) = ing_coarse - IF (fitz_flag) THEN + IF (Pperp_Ptor_flag) THEN iinQs(j) = iing_coarse ELSE iinQs(j) = -iing_coarse From 9cc2c66974454823bd31598e73ca0716718ee66c Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 19:58:09 -0500 Subject: [PATCH 078/118] further deps fixes --- install/DEPENDENCIES.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index 44c22d723..c77fae556 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -195,7 +195,7 @@ ../slayer/params.o : ../slayer/sglobal.o ../slayer/delta.o : ../slayer/sglobal.o ../slayer/slayer_netcdf.o : ../slayer/sglobal.o ../slayer/version.inc -../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../pentrc/inputs.o +../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../pentrc/inputs.o ../equil/equil.o ../equil/spline.o ../equil/bicube.o ../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o ../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/gslayer.o ../slayer/layerinputs.o From 11370ee2dd574140b72d90e124c641de0ab3a288 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 20:00:13 -0500 Subject: [PATCH 079/118] fix slayer line excursion --- slayer/slayer.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/slayer/slayer.f b/slayer/slayer.f index 18e2aa037..c282f7f45 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -188,10 +188,10 @@ PROGRAM slayer $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, $ inds,intau,Q0,delta_prime,delta_n_p,ingamma NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, - $ AMR_passes,msing_max,dc_type,read_eq,Pperp_Ptor_flag,coupling_flag, - $ QPscan_flag,Qscan_flag,QPescan_flag,Qbscan_flag,onscan_flag, - $ otscan_flag,ntscan_flag,nbtscan_flag,parflow_flag, - $ peohmonly_flag,Pe_flag,layfac + $ AMR_passes,msing_max,dc_type,read_eq,Pperp_Ptor_flag, + $ coupling_flag,QPscan_flag,Qscan_flag,QPescan_flag, + $ Qbscan_flag,onscan_flag,otscan_flag,ntscan_flag, + $ nbtscan_flag,parflow_flag,peohmonly_flag,Pe_flag,layfac NAMELIST/slayer_output/verbose,ascii_flag,bin_flag,netcdf_flag, $ est_gamma_flag,match_gamma_flag,stability_flag, $ stabscan_flag,coupled_stabscan_flag,amr_flag,br_th_flag, From 7de735cb34bda89b58446adce803f0685b3830f0 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 21:15:38 -0500 Subject: [PATCH 080/118] address PR review bugs and suggestions --- slayer/gslayer.f | 3 +++ slayer/layerinputs.f | 18 +++++++++++------- slayer/params.f | 21 ++++++++++----------- slayer/slayer_netcdf.f | 6 +++--- stride/free.f | 7 ++++++- 5 files changed, 33 insertions(+), 22 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index ea723e16a..85037c779 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -488,6 +488,9 @@ END FUNCTION dispersion_det SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, $ scan_width,Q_num,AMR_passes, $ coupling_flag) +c DEPRECATED: use dispersion_AMR_v2 instead. +c This v1 hash-based scanner is retained for +c backwards compatibility only. c --- arguments INTEGER, INTENT(IN) :: n_k ! number of rational surfaces diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 12377493b..5244a6bce 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -78,9 +78,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, c----------------------------------------------------------------------- c open the STRIDE NetCDF file and read dimension / attribute data. c----------------------------------------------------------------------- - WRITE(*,*) '$^$ opening netcdf file', ncfile - - stat = nf90_open(path=ncfile, mode=NF90_WRITE, ncid=ncid) + stat = nf90_open(path=ncfile, mode=NF90_NOWRITE, + $ ncid=ncid) CALL sl_check(stat) c --- read msing (number of singular surfaces) from global attribute @@ -461,10 +460,15 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) mu_i = 2.0 ! deuterium dr_val = dr_vals(ising) -c transport coefficients from caller-provided arrays - chi_s(1) = sl_in%chi_p_arr(ising) ! chi_perp - chi_s(2) = sl_in%chi_t_arr(ising) ! chi_tor - chi_s(3) = sl_in%kappa_arr(ising) ! kappa (thermal cond.) +c transport coefficients from caller-provided arrays. +c guard: arrays may be smaller than msing (e.g. from +c fixed-size namelist); reuse last element if exceeded. + i = MIN(ising, SIZE(sl_in%chi_p_arr)) + chi_s(1) = sl_in%chi_p_arr(i) + i = MIN(ising, SIZE(sl_in%chi_t_arr)) + chi_s(2) = sl_in%chi_t_arr(i) + i = MIN(ising, SIZE(sl_in%kappa_arr)) + chi_s(3) = sl_in%kappa_arr(i) c store local kinetic arrays (for future NetCDF diagnostic output) ne_arr(ising) = n_e diff --git a/slayer/params.f b/slayer/params.f index cec066a9a..220b6dbdd 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -25,12 +25,9 @@ MODULE params_mod c (tau, tau_r, tauk, lu, Q, Q_e, Q_i, ds, c_beta, d_beta, c D_norm, P_perp, P_tor, delta_n, dc_tmp, eta, visc, rho_s, ...). c -c TODO: `pr` (magnetic Prandtl number) and `pe` are read -c from sglobal_mod but never set within this routine. They must -c be initialised elsewhere before calling params(), otherwise -c `tau_v = tau_r / pr` will divide by zero or garbage. -c Suggested fix: add pr/pe as INTENT(IN) arguments, or -c document the required initialisation order. +c Note: `pr` (magnetic Prandtl number) is read from sglobal_mod +c and must be set by the caller (e.g. pr = inpr from namelist). +c If pr == 0, tau_v and visc are set to zero (no viscosity). c----------------------------------------------------------------------- SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) @@ -85,7 +82,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, REAL(r8) :: Wd_new ! updated Wd for convergence check INTEGER :: wit ! iteration counter c --- local variables: unused intermediates - REAL(r8) :: Qconv ! (shadowed by module-level Qconv) REAL(r8) :: K_val, Csq ! kappa/eta and composite quantity c----------------------------------------------------------------------- @@ -128,10 +124,13 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, tau_h = R0*(mu0*rho)**0.5 / (nn*sval*bt) ! Alfvén time [s] tau_r = mu0*(rs**2.0)*sigma_par ! resistive time [s] (Fitzpatrick) - tau_v = tau_r / pr ! viscous time [s] (TODO: pr init) - -c back-compute anomalous viscosity from tau_v - visc = rho*rs**2.0 / tau_v + IF (pr > 0.0_r8) THEN + tau_v = tau_r / pr ! viscous time [s] + visc = rho*rs**2.0_r8 / tau_v + ELSE + tau_v = 0.0_r8 + visc = 0.0_r8 + END IF c Lundquist number lu = tau_r / tau_h diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 78091a0fc..82e9bd91f 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -247,8 +247,8 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c -- scalar per-surface variables -- CALL sl_check( nf90_def_var(ncid, "r", nf90_int, $ qsing_dim, qsing_id) ) - CALL sl_check( nf90_def_var(ncid, "q_rational", nf90_int, - $ qsing_dim, qr_id) ) + CALL sl_check( nf90_def_var(ncid, "q_rational", + $ nf90_double, qsing_dim, qr_id) ) CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, $ qsing_dim, omegas_id) ) CALL sl_check( nf90_def_var(ncid, "tau_k", nf90_double, @@ -299,7 +299,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_def_dim(ncid, "amr_pts", $ max_pts_all, dim_pts_id) ) CALL sl_check( nf90_def_var(ncid, "n_amr_pts", NF90_INT, - $ (/qsing_dim/), var_npts_id) ) + $ (/nAMR_dim/), var_npts_id) ) CALL sl_check( nf90_def_var(ncid, "Q_AMR", NF90_DOUBLE, $ (/dim_pts_id, nAMR_dim, i_dim/), var_q_id) ) CALL sl_check( nf90_def_var(ncid, "Deltas_AMR", NF90_DOUBLE, diff --git a/stride/free.f b/stride/free.f index 7b68eceaf..7c4416915 100755 --- a/stride/free.f +++ b/stride/free.f @@ -392,7 +392,7 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) Lam = (psi_t%f1(1)/sq%f(3))* $ (-1.0/(sq%f(4)**2.0))*(sq%f1(4)/sq%f(3)) - shr(ising) = shr_spl%f(1) + shr(ising) = respsi * shr_spl%f1(1) dgeo(ising) = v_spl%f(1)*( (((al**2.0)*(Lam**2.0))/ $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) ENDDO @@ -406,6 +406,11 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) c----------------------------------------------------------------------- c deallocate c----------------------------------------------------------------------- + CALL spline_dealloc(psi_t) + CALL spline_dealloc(avg_dpsi_spl) + CALL spline_dealloc(avg_bsq_spl) + CALL spline_dealloc(v_spl) + CALL spline_dealloc(shr_spl) CALL stride_dealloc c----------------------------------------------------------------------- c terminate. From cb6604247ba4e0098703eef4fa30308c399d2c0e Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 22:10:37 -0500 Subject: [PATCH 081/118] WIP: STRIDE debug WRITE statements --- stride/ode.F | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++ stride/sing.F | 25 +++++++++++++++ 2 files changed, 111 insertions(+) diff --git a/stride/ode.F b/stride/ode.F index 4d9a82819..0d3072a51 100644 --- a/stride/ode.F +++ b/stride/ode.F @@ -148,6 +148,19 @@ SUBROUTINE ode_run c----------------------------------------------------------------------- axisPsi = sq%xs(0) outerPsi = psilim*(1-eps) +c----------------------------------------------------------------------- +c DEBUG: print ODE initialization parameters. +c----------------------------------------------------------------------- + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ 'DEBUG ode_run: axisPsi=',axisPsi,' outerPsi=',outerPsi + WRITE(*,'(1x,a,es12.5,a,es12.5,a,i4)') + $ ' tol_nr=',tol_nr,' psilim=',psilim,' msing=',msing + WRITE(*,'(1x,a,i4,a,i4,a,i4)') + $ ' mpert=',mpert,' mband=',mband,' neq=',neq + WRITE(*,'(1x,a,i4,a,i4,a,i4)') + $ ' nIntervalsTot=',nIntervalsTot, + $ ' nn=',nn,' mlow=',mlow + IF(tol_nr /= tol_nr) WRITE(*,*) ' *** NaN in tol_nr!' DO iS = 1,msing scalc(iS)%singEdgesLR(1) = sing(iS)%psifac - singfac_min/ $ ABS(nn*sing(iS)%q1) @@ -381,6 +394,22 @@ SUBROUTINE ode_run uFM(i+mpert,:) = ua(i,:,2) ENDDO +c----------------------------------------------------------------------- +c DEBUG: check uFM after asymptotic expansion for NaN/Inf. +c----------------------------------------------------------------------- +!$OMP CRITICAL + WRITE(*,'(1x,a,i3,a,i3,a,es12.5)') + $ 'DEBUG asymp: iInterval=',iInterval, + $ ' ising=',ising,' t0=',t0 + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ ' uFM max=',MAXVAL(ABS(uFM)), + $ ' uFM min=',MINVAL(ABS(uFM)) + IF(ANY(uFM /= uFM)) THEN + WRITE(*,*) 'DEBUG: *** NaN detected in uFM', + $ ' after sing_get_ua! ising=',ising + ENDIF +!$OMP END CRITICAL + !Invert the init. fund. matrix (/=Id), to save it. uFMInv = uFM CALL ZGETRF(2*mpert,2*mpert,uFMInv,2*mpert,ipiv, @@ -418,6 +447,30 @@ SUBROUTINE ode_run rwork(5)=axisPsi*1e-3*psiDirs(iInterval) rwork(11)=rwork(5) CALL SYSTEM_CLOCK(COUNT=sTime) +c----------------------------------------------------------------------- +c DEBUG: print pre-integration diagnostics. +c----------------------------------------------------------------------- +!$OMP CRITICAL + WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5)') + $ 'DEBUG pre-ZVODE: iInterval=',iInterval, + $ ' startPsi=',startPsi,' endPsi=',endPsi + WRITE(*,'(1x,a,es12.5,a,es12.5,a,es12.5)') + $ ' tol_nr=',tol_nr, + $ ' axisPsi=',axisPsi, + $ ' rwork5=',rwork(5) + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ ' uFM maxval=',MAXVAL(ABS(uFM)), + $ ' uFM minval=',MINVAL(ABS(uFM)) + IF(ANY(uFM /= uFM)) THEN + WRITE(*,*) 'DEBUG: *** NaN in uFM before ZVODE!', + $ ' iInterval=',iInterval + ENDIF + WRITE(*,'(1x,a,i2,a,i2,a,i2,a,i3)') + $ ' psiInters=',psiInters(iInterval,1),',', + $ psiInters(iInterval,2),',', + $ psiInters(iInterval,3), + $ ' dir=',psiDirs(iInterval) +!$OMP END CRITICAL DO WHILE(psiDirs(iInterval)*startPsi $ < psiDirs(iInterval)*endPsi) rtol(1) = tol_nr @@ -431,10 +484,43 @@ SUBROUTINE ode_run WHERE(atol == 0) atol=maxatol !CMPLX(maxatol,maxatol) ENDWHERE +c----------------------------------------------------------------------- +c DEBUG: print ZVODE inputs on each iteration. +c----------------------------------------------------------------------- +!$OMP CRITICAL + WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5,a,i2)') + $ 'DEBUG ZVODE in: iInterval=',iInterval, + $ ' rtol=',rtol(1), + $ ' maxatol=',maxatol,' istate=',istate + IF(ANY(atol /= atol)) THEN + WRITE(*,*) 'DEBUG: *** NaN in atol!', + $ ' iInterval=',iInterval + ENDIF +!$OMP END CRITICAL CALL ZVODE1(sing_derFM,neq,uFM,startPsi,endPsi, $ itol,rtol,atol,itask,istate,iopt,zwork,lzw, $ rwork,lrw,iwork,liw,ode_nojac,mf,rpar,ipar) +c----------------------------------------------------------------------- +c DEBUG: print ZVODE output state. +c----------------------------------------------------------------------- +!$OMP CRITICAL + WRITE(*,'(1x,a,i3,a,i3,a,es12.5)') + $ 'DEBUG ZVODE out: iInterval=',iInterval, + $ ' istate=',istate,' startPsi=',startPsi + IF(istate < 0) THEN + WRITE(*,*) 'DEBUG: ZVODE FAILED! istate=', + $ istate,' iInterval=',iInterval + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ ' uFM max=',MAXVAL(ABS(uFM)), + $ ' uFM min=',MINVAL(ABS(uFM)) + IF(ANY(uFM /= uFM)) THEN + WRITE(*,*) 'DEBUG: *** NaN in uFM after', + $ ' failed ZVODE!' + ENDIF + ENDIF +!$OMP END CRITICAL + IF(istate < 0) EXIT ! Break to prevent infinite loop ENDDO IF ( grid_packing == "naive" ) THEN CALL SYSTEM_CLOCK(COUNT=fTime) diff --git a/stride/sing.F b/stride/sing.F index 9aaaa4710..9198f0256 100644 --- a/stride/sing.F +++ b/stride/sing.F @@ -1002,6 +1002,7 @@ SUBROUTINE sing_derFM(neqFM,startPsi,uFM,duFM,rpar,ipar) COMPLEX(r8), DIMENSION(mpert,mpert) :: fmatb,gmatb COMPLEX(r8), DIMENSION(2*mband+1,mpert) :: kmatb COMPLEX(r8), DIMENSION(mpert,mpert) :: duTemp + LOGICAL, SAVE :: first_call = .TRUE. c----------------------------------------------------------------------- c cubic spline evaluation. c----------------------------------------------------------------------- @@ -1017,6 +1018,30 @@ SUBROUTINE sing_derFM(neqFM,startPsi,uFM,duFM,rpar,ipar) c----------------------------------------------------------------------- q=sq_s_f(4) singfac=mlow-nn*q+(/(ipert,ipert=0,mpert-1)/) +c----------------------------------------------------------------------- +c DEBUG: check for NaN in spline data and zero singfac. +c----------------------------------------------------------------------- + IF(first_call .OR. q /= q) THEN +!$OMP CRITICAL + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ 'DEBUG sing_derFM: psi=',startPsi,' q=',q + WRITE(*,'(1x,a,i4,a,i4)') + $ ' mlow=',mlow,' nn=',nn + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ ' singfac min=',MINVAL(ABS(singfac)), + $ ' singfac max=',MAXVAL(ABS(singfac)) + IF(q /= q) WRITE(*,*) ' *** NaN in q!' + IF(ANY(sq_s_f /= sq_s_f)) + $ WRITE(*,*) ' *** NaN in sq_s_f!' + IF(ANY(fmats_s_f /= fmats_s_f)) + $ WRITE(*,*) ' *** NaN in fmats_s_f!' + IF(ANY(gmats_s_f /= gmats_s_f)) + $ WRITE(*,*) ' *** NaN in gmats_s_f!' + IF(ANY(kmats_s_f /= kmats_s_f)) + $ WRITE(*,*) ' *** NaN in kmats_s_f!' + first_call = .FALSE. +!$OMP END CRITICAL + ENDIF singfac=1/singfac c----------------------------------------------------------------------- c copy Hermitian banded matrices F and G. From 912154e55481973aafe3f7ae7220ae98dd6048b9 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 22:23:22 -0500 Subject: [PATCH 082/118] WIP: more debug statements --- stride/ode.F | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/stride/ode.F b/stride/ode.F index 0d3072a51..491676f0a 100644 --- a/stride/ode.F +++ b/stride/ode.F @@ -205,6 +205,19 @@ SUBROUTINE ode_run identityMat(i,i) = 1.0_r8 ENDDO c----------------------------------------------------------------------- +c DEBUG: verify identityMat before parallel region. +c----------------------------------------------------------------------- + WRITE(*,'(1x,a,i4,a,es12.5,a,es12.5)') + $ 'DEBUG identityMat: size=',2*mpert, + $ ' max=',MAXVAL(ABS(identityMat)), + $ ' min=',MINVAL(ABS(identityMat)) + IF(ANY(identityMat /= identityMat)) THEN + WRITE(*,*) 'DEBUG: *** NaN in identityMat!' + ENDIF + IF(ABS(MAXVAL(ABS(identityMat))-1.0_r8) > 1e-10) THEN + WRITE(*,*) 'DEBUG: *** identityMat max is NOT 1.0!' + ENDIF +c----------------------------------------------------------------------- c proceed to integration. c----------------------------------------------------------------------- #ifdef _OPENMP @@ -353,6 +366,28 @@ SUBROUTINE ode_run !Initialize the state transition matrix as the Identity, !then modify it where necessary. uFM = identityMat +c----------------------------------------------------------------------- +c DEBUG: verify uFM right after identityMat assignment. +c----------------------------------------------------------------------- +!$OMP CRITICAL + IF(psiInters(iInterval,1)/=2 .AND. + $ psiInters(iInterval,3)==0 .AND. + $ iInterval <= 5) THEN + WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5)') + $ 'DEBUG post-assign: iInterval=',iInterval, + $ ' uFM max=',MAXVAL(ABS(uFM)), + $ ' uFM min=',MINVAL(ABS(uFM)) + WRITE(*,'(1x,a,es12.5,a,es12.5)') + $ ' idMat max=',MAXVAL(ABS(identityMat)), + $ ' idMat min=',MINVAL(ABS(identityMat)) + IF(ANY(uFM /= uFM)) THEN + WRITE(*,*) 'DEBUG: *** NaN in uFM after assign!' + ENDIF + IF(ANY(identityMat /= identityMat)) THEN + WRITE(*,*) 'DEBUG: *** NaN in identityMat!' + ENDIF + ENDIF +!$OMP END CRITICAL IF (psiInters(iInterval,1) == 2) THEN c----------------------------------------------------------------------- c the inner layer itself (crossing singularity): initialize. From 3ad5ef1b791ea4150269374f76802b6e5b5b5f4e Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 22:36:31 -0500 Subject: [PATCH 083/118] WIP: try changing identityMat to allocatable --- stride/ode.F | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/stride/ode.F b/stride/ode.F index 491676f0a..279711386 100644 --- a/stride/ode.F +++ b/stride/ode.F @@ -113,7 +113,7 @@ SUBROUTINE ode_run INTEGER, DIMENSION(2*mpert) :: ipiv COMPLEX(r8), DIMENSION(2*mpert,2*mpert) :: uFMInv COMPLEX(r8), DIMENSION(2*mpert) :: uwork - COMPLEX(r8), DIMENSION(2*mpert,2*mpert) :: identityMat + COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE :: identityMat !NOTE #1: INTEGER, DIMENSION(:), POINTER, PRIVATE :: iwork ! REAL(r8), DIMENSION(:), POINTER, PRIVATE :: rwork @@ -200,10 +200,16 @@ SUBROUTINE ode_run ALLOCATE(rwork(lrw), zwork(lzw), iwork(liw), $ atol(2*mpert,2*mpert)) + ALLOCATE(identityMat(2*mpert,2*mpert)) identityMat = 0.0_r8 + WRITE(*,*) 'DEBUG idMat post-zero: (1,1)=', + $ identityMat(1,1),' max=',MAXVAL(ABS(identityMat)) DO i = 1,2*mpert identityMat(i,i) = 1.0_r8 ENDDO + WRITE(*,*) 'DEBUG idMat post-loop: (1,1)=', + $ identityMat(1,1),' (2,2)=',identityMat(2,2), + $ ' (1,2)=',identityMat(1,2) c----------------------------------------------------------------------- c DEBUG: verify identityMat before parallel region. c----------------------------------------------------------------------- @@ -583,6 +589,7 @@ SUBROUTINE ode_run c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- + DEALLOCATE(identityMat) RETURN END SUBROUTINE ode_run c----------------------------------------------------------------------- From e0a209be108a5ea11861c8e1a154198eeb751d7c Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 22:55:54 -0500 Subject: [PATCH 084/118] WIP: remove STRIDE debug statements --- stride/ode.F | 129 +------------------------------------------------- stride/sing.F | 25 ---------- 2 files changed, 1 insertion(+), 153 deletions(-) diff --git a/stride/ode.F b/stride/ode.F index 279711386..36f0e7d5a 100644 --- a/stride/ode.F +++ b/stride/ode.F @@ -148,26 +148,11 @@ SUBROUTINE ode_run c----------------------------------------------------------------------- axisPsi = sq%xs(0) outerPsi = psilim*(1-eps) -c----------------------------------------------------------------------- -c DEBUG: print ODE initialization parameters. -c----------------------------------------------------------------------- - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ 'DEBUG ode_run: axisPsi=',axisPsi,' outerPsi=',outerPsi - WRITE(*,'(1x,a,es12.5,a,es12.5,a,i4)') - $ ' tol_nr=',tol_nr,' psilim=',psilim,' msing=',msing - WRITE(*,'(1x,a,i4,a,i4,a,i4)') - $ ' mpert=',mpert,' mband=',mband,' neq=',neq - WRITE(*,'(1x,a,i4,a,i4,a,i4)') - $ ' nIntervalsTot=',nIntervalsTot, - $ ' nn=',nn,' mlow=',mlow - IF(tol_nr /= tol_nr) WRITE(*,*) ' *** NaN in tol_nr!' DO iS = 1,msing scalc(iS)%singEdgesLR(1) = sing(iS)%psifac - singfac_min/ $ ABS(nn*sing(iS)%q1) scalc(iS)%singEdgesLR(2) = sing(iS)%psifac + singfac_min/ $ ABS(nn*sing(iS)%q1) - WRITE(*,'(1x,i5,2(es11.3))') iS,scalc(iS)%singEdgesLR(1), - $ scalc(iS)%singEdgesLR(2) !This finds the index of the singular column scalc(iS)%sing_col = NINT(nn*sing(iS)%q)-mlow+1 @@ -202,27 +187,9 @@ SUBROUTINE ode_run ALLOCATE(identityMat(2*mpert,2*mpert)) identityMat = 0.0_r8 - WRITE(*,*) 'DEBUG idMat post-zero: (1,1)=', - $ identityMat(1,1),' max=',MAXVAL(ABS(identityMat)) DO i = 1,2*mpert identityMat(i,i) = 1.0_r8 ENDDO - WRITE(*,*) 'DEBUG idMat post-loop: (1,1)=', - $ identityMat(1,1),' (2,2)=',identityMat(2,2), - $ ' (1,2)=',identityMat(1,2) -c----------------------------------------------------------------------- -c DEBUG: verify identityMat before parallel region. -c----------------------------------------------------------------------- - WRITE(*,'(1x,a,i4,a,es12.5,a,es12.5)') - $ 'DEBUG identityMat: size=',2*mpert, - $ ' max=',MAXVAL(ABS(identityMat)), - $ ' min=',MINVAL(ABS(identityMat)) - IF(ANY(identityMat /= identityMat)) THEN - WRITE(*,*) 'DEBUG: *** NaN in identityMat!' - ENDIF - IF(ABS(MAXVAL(ABS(identityMat))-1.0_r8) > 1e-10) THEN - WRITE(*,*) 'DEBUG: *** identityMat max is NOT 1.0!' - ENDIF c----------------------------------------------------------------------- c proceed to integration. c----------------------------------------------------------------------- @@ -372,28 +339,6 @@ SUBROUTINE ode_run !Initialize the state transition matrix as the Identity, !then modify it where necessary. uFM = identityMat -c----------------------------------------------------------------------- -c DEBUG: verify uFM right after identityMat assignment. -c----------------------------------------------------------------------- -!$OMP CRITICAL - IF(psiInters(iInterval,1)/=2 .AND. - $ psiInters(iInterval,3)==0 .AND. - $ iInterval <= 5) THEN - WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5)') - $ 'DEBUG post-assign: iInterval=',iInterval, - $ ' uFM max=',MAXVAL(ABS(uFM)), - $ ' uFM min=',MINVAL(ABS(uFM)) - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ ' idMat max=',MAXVAL(ABS(identityMat)), - $ ' idMat min=',MINVAL(ABS(identityMat)) - IF(ANY(uFM /= uFM)) THEN - WRITE(*,*) 'DEBUG: *** NaN in uFM after assign!' - ENDIF - IF(ANY(identityMat /= identityMat)) THEN - WRITE(*,*) 'DEBUG: *** NaN in identityMat!' - ENDIF - ENDIF -!$OMP END CRITICAL IF (psiInters(iInterval,1) == 2) THEN c----------------------------------------------------------------------- c the inner layer itself (crossing singularity): initialize. @@ -435,22 +380,6 @@ SUBROUTINE ode_run uFM(i+mpert,:) = ua(i,:,2) ENDDO -c----------------------------------------------------------------------- -c DEBUG: check uFM after asymptotic expansion for NaN/Inf. -c----------------------------------------------------------------------- -!$OMP CRITICAL - WRITE(*,'(1x,a,i3,a,i3,a,es12.5)') - $ 'DEBUG asymp: iInterval=',iInterval, - $ ' ising=',ising,' t0=',t0 - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ ' uFM max=',MAXVAL(ABS(uFM)), - $ ' uFM min=',MINVAL(ABS(uFM)) - IF(ANY(uFM /= uFM)) THEN - WRITE(*,*) 'DEBUG: *** NaN detected in uFM', - $ ' after sing_get_ua! ising=',ising - ENDIF -!$OMP END CRITICAL - !Invert the init. fund. matrix (/=Id), to save it. uFMInv = uFM CALL ZGETRF(2*mpert,2*mpert,uFMInv,2*mpert,ipiv, @@ -488,30 +417,6 @@ SUBROUTINE ode_run rwork(5)=axisPsi*1e-3*psiDirs(iInterval) rwork(11)=rwork(5) CALL SYSTEM_CLOCK(COUNT=sTime) -c----------------------------------------------------------------------- -c DEBUG: print pre-integration diagnostics. -c----------------------------------------------------------------------- -!$OMP CRITICAL - WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5)') - $ 'DEBUG pre-ZVODE: iInterval=',iInterval, - $ ' startPsi=',startPsi,' endPsi=',endPsi - WRITE(*,'(1x,a,es12.5,a,es12.5,a,es12.5)') - $ ' tol_nr=',tol_nr, - $ ' axisPsi=',axisPsi, - $ ' rwork5=',rwork(5) - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ ' uFM maxval=',MAXVAL(ABS(uFM)), - $ ' uFM minval=',MINVAL(ABS(uFM)) - IF(ANY(uFM /= uFM)) THEN - WRITE(*,*) 'DEBUG: *** NaN in uFM before ZVODE!', - $ ' iInterval=',iInterval - ENDIF - WRITE(*,'(1x,a,i2,a,i2,a,i2,a,i3)') - $ ' psiInters=',psiInters(iInterval,1),',', - $ psiInters(iInterval,2),',', - $ psiInters(iInterval,3), - $ ' dir=',psiDirs(iInterval) -!$OMP END CRITICAL DO WHILE(psiDirs(iInterval)*startPsi $ < psiDirs(iInterval)*endPsi) rtol(1) = tol_nr @@ -525,43 +430,11 @@ SUBROUTINE ode_run WHERE(atol == 0) atol=maxatol !CMPLX(maxatol,maxatol) ENDWHERE -c----------------------------------------------------------------------- -c DEBUG: print ZVODE inputs on each iteration. -c----------------------------------------------------------------------- -!$OMP CRITICAL - WRITE(*,'(1x,a,i3,a,es12.5,a,es12.5,a,i2)') - $ 'DEBUG ZVODE in: iInterval=',iInterval, - $ ' rtol=',rtol(1), - $ ' maxatol=',maxatol,' istate=',istate - IF(ANY(atol /= atol)) THEN - WRITE(*,*) 'DEBUG: *** NaN in atol!', - $ ' iInterval=',iInterval - ENDIF -!$OMP END CRITICAL CALL ZVODE1(sing_derFM,neq,uFM,startPsi,endPsi, $ itol,rtol,atol,itask,istate,iopt,zwork,lzw, $ rwork,lrw,iwork,liw,ode_nojac,mf,rpar,ipar) -c----------------------------------------------------------------------- -c DEBUG: print ZVODE output state. -c----------------------------------------------------------------------- -!$OMP CRITICAL - WRITE(*,'(1x,a,i3,a,i3,a,es12.5)') - $ 'DEBUG ZVODE out: iInterval=',iInterval, - $ ' istate=',istate,' startPsi=',startPsi - IF(istate < 0) THEN - WRITE(*,*) 'DEBUG: ZVODE FAILED! istate=', - $ istate,' iInterval=',iInterval - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ ' uFM max=',MAXVAL(ABS(uFM)), - $ ' uFM min=',MINVAL(ABS(uFM)) - IF(ANY(uFM /= uFM)) THEN - WRITE(*,*) 'DEBUG: *** NaN in uFM after', - $ ' failed ZVODE!' - ENDIF - ENDIF -!$OMP END CRITICAL - IF(istate < 0) EXIT ! Break to prevent infinite loop + IF(istate < 0) EXIT ENDDO IF ( grid_packing == "naive" ) THEN CALL SYSTEM_CLOCK(COUNT=fTime) diff --git a/stride/sing.F b/stride/sing.F index 9198f0256..9aaaa4710 100644 --- a/stride/sing.F +++ b/stride/sing.F @@ -1002,7 +1002,6 @@ SUBROUTINE sing_derFM(neqFM,startPsi,uFM,duFM,rpar,ipar) COMPLEX(r8), DIMENSION(mpert,mpert) :: fmatb,gmatb COMPLEX(r8), DIMENSION(2*mband+1,mpert) :: kmatb COMPLEX(r8), DIMENSION(mpert,mpert) :: duTemp - LOGICAL, SAVE :: first_call = .TRUE. c----------------------------------------------------------------------- c cubic spline evaluation. c----------------------------------------------------------------------- @@ -1018,30 +1017,6 @@ SUBROUTINE sing_derFM(neqFM,startPsi,uFM,duFM,rpar,ipar) c----------------------------------------------------------------------- q=sq_s_f(4) singfac=mlow-nn*q+(/(ipert,ipert=0,mpert-1)/) -c----------------------------------------------------------------------- -c DEBUG: check for NaN in spline data and zero singfac. -c----------------------------------------------------------------------- - IF(first_call .OR. q /= q) THEN -!$OMP CRITICAL - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ 'DEBUG sing_derFM: psi=',startPsi,' q=',q - WRITE(*,'(1x,a,i4,a,i4)') - $ ' mlow=',mlow,' nn=',nn - WRITE(*,'(1x,a,es12.5,a,es12.5)') - $ ' singfac min=',MINVAL(ABS(singfac)), - $ ' singfac max=',MAXVAL(ABS(singfac)) - IF(q /= q) WRITE(*,*) ' *** NaN in q!' - IF(ANY(sq_s_f /= sq_s_f)) - $ WRITE(*,*) ' *** NaN in sq_s_f!' - IF(ANY(fmats_s_f /= fmats_s_f)) - $ WRITE(*,*) ' *** NaN in fmats_s_f!' - IF(ANY(gmats_s_f /= gmats_s_f)) - $ WRITE(*,*) ' *** NaN in gmats_s_f!' - IF(ANY(kmats_s_f /= kmats_s_f)) - $ WRITE(*,*) ' *** NaN in kmats_s_f!' - first_call = .FALSE. -!$OMP END CRITICAL - ENDIF singfac=1/singfac c----------------------------------------------------------------------- c copy Hermitian banded matrices F and G. From 8955716bb779af633cfc790f27fe12444229d956 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 24 Feb 2026 23:01:01 -0500 Subject: [PATCH 085/118] address @Claudes comment, a10 example needs future overhaul anyways --- docs/examples/a10_ideal_example/slayer.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/examples/a10_ideal_example/slayer.in b/docs/examples/a10_ideal_example/slayer.in index 380c8dea4..bceddf8d5 100644 --- a/docs/examples/a10_ideal_example/slayer.in +++ b/docs/examples/a10_ideal_example/slayer.in @@ -56,7 +56,7 @@ bin_flag=t ! writes results to binary files netcdf_flag=f ! writes results to netcdf files stability_flag=f ! calculate delta dependence on complex Q - growthrates_flag=t ! Calculate growthrates on each rational surface + est_gamma_flag=t ! Calculate estimated growth rates on each rational surface !bal_flag=f ! calculate the resonant field penetration threshold from torque balance / &SLAYER_DIAGNOSE From 0c30074397b66da76f4ecbf4a0bf624ca4cc81e0 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 3 Mar 2026 18:30:30 -0500 Subject: [PATCH 086/118] WIP: split off growth rate functionality from gslayer.f --- install/DEPENDENCIES.inc | 3 +- slayer/growthrates.f | 1105 ++++++++++++++++++++++++++++++++++++++ slayer/gslayer.f | 1069 +----------------------------------- slayer/makefile | 79 --- slayer/slayer.f | 17 +- 5 files changed, 1124 insertions(+), 1149 deletions(-) create mode 100644 slayer/growthrates.f delete mode 100644 slayer/makefile diff --git a/install/DEPENDENCIES.inc b/install/DEPENDENCIES.inc index c77fae556..685ffff60 100644 --- a/install/DEPENDENCIES.inc +++ b/install/DEPENDENCIES.inc @@ -197,7 +197,8 @@ ../slayer/slayer_netcdf.o : ../slayer/sglobal.o ../slayer/version.inc ../slayer/layerinputs.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/slayer_netcdf.o ../pentrc/inputs.o ../equil/equil.o ../equil/spline.o ../equil/bicube.o ../slayer/gslayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o -../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/gslayer.o ../slayer/layerinputs.o +../slayer/growthrates.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/layerinputs.o ../slayer/slayer_netcdf.o +../slayer/slayer.o : ../slayer/sglobal.o ../slayer/params.o ../slayer/delta.o ../slayer/gslayer.o ../slayer/growthrates.o ../slayer/layerinputs.o # COIL ../coil/coil.o: ../equil/local.o ../equil/bicube.o ../coil/version.inc diff --git a/slayer/growthrates.f b/slayer/growthrates.f new file mode 100644 index 000000000..842bbd221 --- /dev/null +++ b/slayer/growthrates.f @@ -0,0 +1,1105 @@ + MODULE growthrates_mod +c----------------------------------------------------------------------- +c growthrates_mod: Growth-rate scanning and AMR dispersion solvers. +c +c Split from gslayer_mod, this module contains every subroutine +c after gpec_slayer that was formerly inside gslayer.f. It +c provides I/O helpers, array utilities, the dispersion +c determinant, and both AMR scanner variants used by the main +c SLAYER driver (slayer.f). +c +c Subprograms: +c 1. output_gamma - write results to netCDF via +c slayer_netcdf_mod +c 2. allocate_inputs - allocate slayer_inputs_type arrays +c 3. allocate_outputs - allocate slayer_outputs_type arrays +c 4. shrink_array - trim over-allocated scan arrays +c 5. grow_array - expand scan arrays dynamically +c 6. calc_determinant - 2x2 / 3x3 complex determinant +c 7. dispersion_det - coupled dispersion determinant +c 8. dispersion_AMR - AMR scan v1 (hash-based dedup) +c 9. dispersion_AMR_v2 - AMR scan v2 (cell-based storage) +c +c Helper subroutines (v1): get_or_compute +c Helper subroutines (v2): get_or_compute_v2, +c compute_delta_sub, check_cell_crossing_sub, +c subdivide_cell_sub, flatten_cells_to_points_sub +c----------------------------------------------------------------------- + + USE omp_lib + + USE sglobal_mod, ONLY: out_unit,r8,mu0,m_p,chag,lnLamb, + $ Q_e,Q_i,pr,pe,c_beta,ds,tau, + $ eta,visc,rho_s,lu,omega_e,omega_i, + $ delta_n,Q, + $ ifac,g_tmp,pi, ! used by AMR + $ tauk,iota_e,D_norm,P_perp,P_tor,delta_eff, ! used by det + $ amr_cell_type,amr_cells,n_amr_cells, ! v2 types + $ Q_store,D_store,n_pts, ! output arrays + $ MAX_PTS,HASH_SZ,HASH_SCALE, ! v1 constants + $ hash_head,hash_next, ! v1 hash + $ MAX_CELLS, ! v2 limit + $ slayer_inputs_type,slayer_outputs_type, + $ deltas_outputs_type, + $ tau_r,dc_tmp,dc_type, + $ sn_str,sm_str + USE delta_mod, ONLY: riccati,riccati_f,riccati_out, + $ parflow_flag,PeOhmOnly_flag + USE params_mod + USE layerinputs_mod + USE slayer_netcdf_mod + + IMPLICIT NONE + +c --- reconnection regulariser used in psi0 / JxB expressions; +c expose via namelist to make user-configurable. + REAL(r8), PARAMETER :: DELTA_N_PERT = 1.0e-2_r8 + + CONTAINS + +c----------------------------------------------------------------------- +c subprogram 1. output_gamma. +c Write growth-rate results to netCDF via slayer_netcdf_out. +c Passes the input/output structured types and AMR results +c through to the netCDF writer (slayer_netcdf_mod). +c----------------------------------------------------------------------- + SUBROUTINE output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, + $ all_deltas_out) + + LOGICAL, INTENT(IN) :: est_gamma_flag ! single-surface mode? + INTEGER, INTENT(IN) :: m_AMR ! AMR pass count + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + TYPE(slayer_outputs_type), INTENT(IN) :: sl_out + TYPE(deltas_outputs_type), INTENT(IN) :: + $ all_deltas_out(SIZE(sl_in%qval_arr)) + + CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),m_AMR,est_gamma_flag, + $ sl_in,sl_out,all_deltas_out) + + END SUBROUTINE output_gamma +c----------------------------------------------------------------------- +c subprogram 2. allocate_inputs. +c Allocate all per-surface arrays inside slayer_inputs_type. +c----------------------------------------------------------------------- + SUBROUTINE allocate_inputs(n_k,sl_in) + + INTEGER, INTENT(IN) :: n_k ! number of surfaces + TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in + + ALLOCATE(sl_in%qval_arr(n_k),sl_in%omegas_arr(n_k), + $ sl_in%Q_e_arr(n_k),sl_in%Q_i_arr(n_k),sl_in%psi_n_arr(n_k), + $ sl_in%Re_dp_arr(n_k),sl_in%Im_dp_arr(n_k), + $ sl_in%d_crit_arr(n_k),sl_in%P_tor_arr(n_k), + $ sl_in%P_perp_arr(n_k),sl_in%tau_arr(n_k), + $ sl_in%D_norm_arr(n_k), + $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), + $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k)) + RETURN + END SUBROUTINE allocate_inputs +c----------------------------------------------------------------------- +c subprogram 3. allocate_outputs. +c Allocate per-surface arrays inside slayer_outputs_type. +c----------------------------------------------------------------------- + SUBROUTINE allocate_outputs(n_k,sl_out) + + INTEGER, INTENT(IN) :: n_k ! number of surfaces + TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out + + ALLOCATE(sl_out%dels_db_arr(n_k),sl_out%gamma_sol_arr(n_k), + $ sl_out%gamma_est_arr(n_k),sl_out%br_th_arr(n_k) ) + RETURN + END SUBROUTINE allocate_outputs +c----------------------------------------------------------------------- +c subprogram 4. shrink_array. +c Trim an over-allocated REAL(r8) array down to new_size using +c MOVE_ALLOC (no copy of trailing elements). +c----------------------------------------------------------------------- + SUBROUTINE shrink_array(arr, new_size) + + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) + INTEGER, INTENT(IN) :: new_size ! target size + REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer + + ALLOCATE(temp(new_size)) + temp(1:new_size) = arr(1:new_size) + CALL move_alloc(temp, arr) + END SUBROUTINE shrink_array +c----------------------------------------------------------------------- +c subprogram 5. grow_array. +c Expand a REAL(r8) array from old_size to new_size, preserving +c existing data via MOVE_ALLOC. +c----------------------------------------------------------------------- + SUBROUTINE grow_array(arr, old_size, new_size) + + REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) + INTEGER, INTENT(IN) :: old_size ! current valid element count + INTEGER, INTENT(IN) :: new_size ! target allocation size + REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer + + ALLOCATE(temp(new_size)) + temp(1:old_size) = arr(1:old_size) + CALL move_alloc(temp, arr) + END SUBROUTINE grow_array +c----------------------------------------------------------------------- +c subprogram 6. calc_determinant. +c Compute the determinant of a 2x2 or 3x3 complex matrix. +c Returns (0,0) and sets status=-1 for unsupported sizes. +c status=0 on success, -1 when nk is neither 2 nor 3. +c----------------------------------------------------------------------- + SUBROUTINE calc_determinant(matk, nk, detk, status) + + IMPLICIT NONE + +c --- arguments + INTEGER, INTENT(IN) :: nk ! matrix rank (2 or 3) + COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! input matrix + COMPLEX(r8), INTENT(OUT) :: detk ! determinant result + INTEGER, INTENT(OUT) :: status ! 0=success, -1=unsupported rank + + status = 0 ! Initialize status as success + + SELECT CASE (nk) + CASE (2) + ! 2x2 determinant: ad - bc + detk = matk(1,1) * matk(2,2) - matk(1,2) * matk(2,1) + + CASE (3) + ! 3x3 determinant using cofactor expansion along first row + detk = matk(1,1)*(matk(2,2)*matk(3,3)-matk(2,3) + $ *matk(3,2))-matk(1,2)*(matk(2,1)*matk(3,3) + $ -matk(2,3)*matk(3,1))+matk(1,3)*(matk(2,1) + $ *matk(3,2)-matk(2,2)*matk(3,1)) + + CASE default + ! Unsupported matrix size + detk = (0.0, 0.0) + status = -1 + + END SELECT + RETURN + END SUBROUTINE calc_determinant +c----------------------------------------------------------------------- +c subprogram 7. dispersion_det. +c Compute the coupled dispersion determinant for n_k surfaces. +c +c For n_k = 1 (single surface): +c Evaluate riccati_f() (uses module g_tmp), de-normalise by lu^(1/3), and +c return Deltaprime - delta(Q). +c +c For n_k = 2 or 3 (coupled surfaces): +c Build the diagonal delta(Q) matrix, subtract from dp_matrix, +c and return det(dp_matrix - delta_Q). +c +c----------------------------------------------------------------------- + FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) + +c --- arguments + COMPLEX(r8), INTENT(IN) :: g_in ! complex growth rate + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces to include + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in +c --- function result and locals + COMPLEX(r8) :: dispersion_det ! returned determinant + COMPLEX(r8) :: det_val ! intermediate determinant + COMPLEX(r8) :: tmp_delta ! single-surface delta + COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:) ! diagonal delta matrix + COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! dp - delta_Q + INTEGER :: k ! surface loop index + INTEGER :: det_status ! calc_determinant error status + +c --- single-surface branch + IF (msing_max < 2) THEN +c set module-level variables for riccati_f + Q_e = sl_in%Q_e_arr(1) + Q_i = sl_in%Q_i_arr(1) + P_perp = sl_in%P_perp_arr(1) + P_tor = sl_in%P_tor_arr(1) + tau = sl_in%tau_arr(1) + D_norm = sl_in%D_norm_arr(1) + c_beta = sl_in%c_beta_arr(1) + tauk = sl_in%Qconv_arr(1) + iota_e = Q_e / (Q_e - Q_i) + + g_tmp = g_in + tmp_delta=riccati_f() +c de-normalise delta by lu^(1/3) + det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) + +c return Deltaprime - delta(Q) + dispersion_det = sl_in%Re_dp_arr(1) - det_val + +c --- coupled-surface branch (2 or 3 surfaces) + ELSEIF ((msing_max == 2) .OR. (msing_max == 3)) THEN + ALLOCATE(delta_Q(msing_max,msing_max)) + delta_Q=(0.0,0.0) + DO k=1,msing_max +c set module-level variables for this surface + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + P_perp = sl_in%P_perp_arr(k) + P_tor = sl_in%P_tor_arr(k) + tau = sl_in%tau_arr(k) + D_norm = sl_in%D_norm_arr(k) + c_beta = sl_in%c_beta_arr(k) + tauk = sl_in%Qconv_arr(k) + iota_e = Q_e / (Q_e - Q_i) + +c evaluate riccati_f at rescaled growth rate, de-normalise + g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk ! sets module-level g_tmp to SCALED value + delta_Q(k,k)=riccati_f() + delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) + END DO + +c compute det(dp_matrix - delta_Q) + result_matrix = sl_in%dp_matrix - delta_Q + CALL calc_determinant(result_matrix, msing_max, det_val, + $ det_status) + IF (det_status /= 0) THEN + WRITE(*,*) 'ERROR: calc_determinant unsupported rank=', + $ msing_max + STOP 'dispersion_det: calc_determinant failed' + END IF + dispersion_det = det_val + ELSE + WRITE(*,*) "Error: no support for msing > 3" + STOP "dispersion_det: unsupported n_k" + END IF + END FUNCTION dispersion_det + +c----------------------------------------------------------------------- +c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc +c Scans a 2D complex-Q grid for zeros of the dispersion relation +c D(Q) using adaptive refinement. A coarse grid is evaluated +c first (two-pass: nodes then cells), then cells that span a zero +c crossing in Re(D) or Im(D) are subdivided. +c +c Point deduplication uses a spatial hash table (HASH_SZ buckets, +c chained) so that midpoints shared between neighbouring cells +c are evaluated only once. +c----------------------------------------------------------------------- + SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, + $ scan_width,Q_num,AMR_passes, + $ coupling_flag) +c DEPRECATED: use dispersion_AMR_v2 instead. +c This v1 hash-based scanner is retained for +c backwards compatibility only. + +c --- arguments + INTEGER, INTENT(IN) :: n_k ! number of rational surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling + INTEGER, INTENT(IN) :: Q_num ! grid points per axis + INTEGER, INTENT(IN) :: AMR_passes ! refinement passes + REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? +c --- cell storage + INTEGER, ALLOCATABLE :: cells(:,:) ! (4, max) corner indices per cell + INTEGER, ALLOCATABLE :: new_cells(:,:) ! scratch for next level +c --- loop / index variables + INTEGER :: n_cells, n_new_cells, i, j + INTEGER :: c_idx, pass + INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! corner indices + INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! midpoint indices +c --- scan workspace + REAL(r8) :: r_min, r_max, i_min, i_max ! min/max Re/Im across corners + REAL(r8) :: ing_step ! coarse grid spacing + REAL(r8) :: ing_coarse, iing_coarse ! Re/Im coords for coarse node + LOGICAL :: cross_real, cross_imag ! zero-crossing flags + COMPLEX(r8) :: q_curr ! current evaluation point + INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Q_num,Q_num) node index map + +c --- 1. initialise hash table and point/cell storage + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) + + ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) + ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) + ALLOCATE(cells(4, 200000), new_cells(4, 200000)) + + hash_head = 0 + hash_next = 0 + n_pts = 0 + n_cells = 0 + +c --- 2. build initial coarse grid (two-pass method) +c Pass 1 computes and hashes every node; Pass 2 stitches cells +c from the stored indices -- no floating-point comparison needed. + ALLOCATE(coarse_indices(Q_num, Q_num)) + ing_step = (2.0*scan_width) / (Q_num - 1) + +c Pass 1: compute all grid nodes and store their hash indices + DO i = 1, Q_num + DO j = 1, Q_num + ing_coarse = -scan_width + (i - 1) * ing_step + iing_coarse = -scan_width + (j - 1) * ing_step + q_curr = CMPLX(ing_coarse, iing_coarse) + + CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, + $ sl_in, msing_max, coupling_flag) + END DO + END DO + +c Pass 2: stitch cells from the stored integer indices + DO i = 1, Q_num - 1 + DO j = 1, Q_num - 1 + n_cells = n_cells + 1 + cells(1, n_cells) = coarse_indices(i, j) ! TL + cells(2, n_cells) = coarse_indices(i+1, j) ! TR + cells(3, n_cells) = coarse_indices(i, j+1) ! BL + cells(4, n_cells) = coarse_indices(i+1, j+1) ! BR + END DO + END DO + DEALLOCATE(coarse_indices) + +c --- 3. refinement passes: subdivide cells with zero crossings + DO pass = 1, AMR_PASSES + WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, + $ ': Checking ', n_cells, ' cells...' + n_new_cells = 0 + + DO c_idx = 1, n_cells + idx_TL = cells(1, c_idx) + idx_TR = cells(2, c_idx) + idx_BL = cells(3, c_idx) + idx_BR = cells(4, c_idx) + +c check for sign change in Re(D) across cell corners + r_min = MIN(REAL(D_store(idx_TL)), + $ REAL(D_store(idx_TR)), + $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BR))) + r_max = MAX(REAL(D_store(idx_TL)), + $ REAL(D_store(idx_TR)), + $ REAL(D_store(idx_BL)), + $ REAL(D_store(idx_BR))) + cross_real = (r_min * r_max <= 0.0d0) + +c check for sign change in Im(D) across cell corners + i_min = MIN(AIMAG(D_store(idx_TL)), + $ AIMAG(D_store(idx_TR)), + $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BR))) + i_max = MAX(AIMAG(D_store(idx_TL)), + $ AIMAG(D_store(idx_TR)), + $ AIMAG(D_store(idx_BL)), + $ AIMAG(D_store(idx_BR))) + cross_imag = (i_min * i_max <= 0.0d0) + + IF (cross_real .OR. cross_imag) THEN +c refine: compute 5 midpoints, create 4 sub-cells + + ! Top-Mid + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_TR)) + CALL get_or_compute(q_curr, idx_TM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Bot-Mid + q_curr = 0.5d0*(Q_store(idx_BL)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_BM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Left-Mid + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BL)) + CALL get_or_compute(q_curr, idx_LM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Right-Mid + q_curr = 0.5d0*(Q_store(idx_TR)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_RM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Center + q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BR)) + CALL get_or_compute(q_curr, idx_MM,n_k, + $ sl_in,msing_max,coupling_flag) + + ! Create 4 sub-cells (TL, TR, BL, BR quadrants) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_TL + new_cells(2, n_new_cells) = idx_TM + new_cells(3, n_new_cells) = idx_LM + new_cells(4, n_new_cells) = idx_MM + + ! Sub 2 (Top-Right) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_TM + new_cells(2, n_new_cells) = idx_TR + new_cells(3, n_new_cells) = idx_MM + new_cells(4, n_new_cells) = idx_RM + + ! Sub 3 (Bot-Left) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_LM + new_cells(2, n_new_cells) = idx_MM + new_cells(3, n_new_cells) = idx_BL + new_cells(4, n_new_cells) = idx_BM + + ! Sub 4 (Bot-Right) + n_new_cells = n_new_cells + 1 + new_cells(1, n_new_cells) = idx_MM + new_cells(2, n_new_cells) = idx_RM + new_cells(3, n_new_cells) = idx_BM + new_cells(4, n_new_cells) = idx_BR + + ELSE + ! No refinement needed, keep original cell + n_new_cells = n_new_cells + 1 + new_cells(:, n_new_cells) = cells(:, c_idx) + END IF + END DO + +c --- swap arrays for next refinement pass + n_cells = n_new_cells + cells(:, 1:n_cells) = new_cells(:, 1:n_cells) + + END DO + DEALLOCATE(cells, new_cells) + WRITE(*,*) "AMR Scan Complete. Total Points:", n_pts + RETURN + END SUBROUTINE dispersion_AMR + +c----------------------------------------------------------------------- +c get_or_compute: hash-based point lookup for dispersion_AMR v1. +c If q_in is already in the hash table, return its index. +c Otherwise, evaluate the dispersion relation at q_in, store +c the result, and insert into the hash table. +c +c Uses 64-bit arithmetic internally to avoid integer overflow +c in the hash function. +c----------------------------------------------------------------------- + SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, + $ coupling_flag) + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point + INTEGER, INTENT(OUT) :: idx_out ! returned point index + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces to include + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag ! use coupled dispersion_det? +c --- locals + INTEGER :: h ! hash bucket index + INTEGER :: curr ! linked-list traversal index + COMPLEX(r8) :: delta_val ! computed dispersion result + INTEGER(8) :: ix8, iy8, h8 ! 64-bit intermediates for hash + +c --- 1. compute hash from quantised Re/Im coordinates (64-bit safe) + ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) + iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) + h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), + $ INT(HASH_SZ, 8)) + 1_8 + h = INT(h8) + + IF (h < 1 .OR. h > HASH_SZ) THEN + WRITE(*,*) "HASH ERROR: h=", h, " q_in=", q_in + STOP "get_or_compute: hash out of bounds" + END IF + +c --- 2. search hash chain for existing point + curr = hash_head(h) + DO WHILE (curr /= 0) + IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN + idx_out = curr + RETURN + END IF + curr = hash_next(curr) + END DO + +c --- 3. point not found: evaluate dispersion relation and store + n_pts = n_pts + 1 + IF (n_pts > MAX_PTS) THEN + WRITE(*,*) "ERROR: AMR exceeded MAX_PTS" + STOP "get_or_compute: MAX_PTS exceeded" + END IF + + idx_out = n_pts + Q_store(idx_out) = q_in + + IF (coupling_flag) THEN + g_tmp = q_in + delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) + ELSE + g_tmp = q_in + delta_val = riccati_f() + delta_val = delta_val - delta_eff + END IF + D_store(idx_out) = delta_val + +c --- 4. insert into hash chain (prepend) + hash_next(idx_out) = hash_head(h) + hash_head(h) = idx_out + + END SUBROUTINE get_or_compute + +c----------------------------------------------------------------------- +c get_or_compute_v2: hash-cached dispersion evaluation for AMR v2. +c Identical to get_or_compute but applies the ifac (imaginary-unit) +c Wick rotation that compute_delta_sub uses: g_tmp = q_in * ifac. +c----------------------------------------------------------------------- + SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, + $ msing_max, coupling_flag) + + IMPLICIT NONE + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in + INTEGER, INTENT(OUT) :: idx_out + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + +c --- locals + INTEGER :: h, curr + COMPLEX(r8) :: delta_val + INTEGER(8) :: ix8, iy8, h8 + +c --- 1. compute hash bucket + ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) + iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) + h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), + $ INT(HASH_SZ, 8)) + 1_8 + h = INT(h8) + +c --- 2. search hash chain for existing point + curr = hash_head(h) + DO WHILE (curr /= 0) + IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN + idx_out = curr + RETURN + END IF + curr = hash_next(curr) + END DO + +c --- 3. not found: evaluate with ifac rotation and store + n_pts = n_pts + 1 + IF (n_pts > MAX_PTS) THEN + WRITE(*,*) 'ERROR: AMR v2 cache exceeded MAX_PTS' + STOP 'get_or_compute_v2: MAX_PTS exceeded' + END IF + + idx_out = n_pts + Q_store(idx_out) = q_in + + IF (coupling_flag) THEN + g_tmp = q_in * ifac + delta_val = dispersion_det(g_tmp, n_k, sl_in, + $ msing_max) + ELSE + g_tmp = q_in * ifac + delta_val = riccati_f() + delta_val = delta_val - delta_eff + END IF + D_store(idx_out) = delta_val + +c --- 4. insert into hash chain (prepend) + hash_next(idx_out) = hash_head(h) + hash_head(h) = idx_out + + END SUBROUTINE get_or_compute_v2 + +c----------------------------------------------------------------------- +c dispersion_AMR_v2: cell-based adaptive mesh refinement scanner. +c Unlike v1 (hash-based point deduplication), v2 stores complete +c cells (TYPE amr_cell_type), each carrying 4 corner Q- and D- +c values. Refinement subdivides cells that contain a zero in +c Re(D) or Im(D) and re-evaluates the dispersion relation at the +c 5 new midpoints. +c +c All dispersion evaluations go through get_or_compute_v2, which +c caches results in Q_store / D_store via a hash table. This +c eliminates redundant evaluations for shared corners (initial grid) +c and shared edge-midpoints (refinement). At completion, Q_store +c and D_store are trimmed to n_pts unique output points. +c +c----------------------------------------------------------------------- + SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, + $ scan_width, Q_num, AMR_passes, + $ coupling_flag) + + IMPLICIT NONE + +c --- arguments + INTEGER, INTENT(IN) :: n_k ! number of rational surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling + INTEGER, INTENT(IN) :: Q_num ! grid points per axis + INTEGER, INTENT(IN) :: AMR_passes ! refinement passes + REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? +c --- locals + TYPE(amr_cell_type), ALLOCATABLE :: new_cells(:) + TYPE(amr_cell_type), ALLOCATABLE :: swap_tmp(:) ! for pointer swap + INTEGER :: i, j, c, corner, pass ! loop counters + REAL(r8) :: step ! grid spacing + REAL(r8) :: x, y ! real / imag grid coords + LOGICAL :: cross_real, cross_imag ! zero-crossing flags + INTEGER :: n_new_cells ! count during refinement + INTEGER :: cells_to_refine ! cells flagged per pass + INTEGER :: cells_kept ! cells kept per pass + INTEGER :: idx_tmp ! hash-cache index + COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! for trimming output + COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! for trimming output + +c --- 1. initialise cell storage and hash cache + + IF (ALLOCATED(amr_cells)) DEALLOCATE(amr_cells) + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) + + ALLOCATE(amr_cells(MAX_CELLS)) + ALLOCATE(new_cells(MAX_CELLS)) + ALLOCATE(Q_store(MAX_PTS)) + ALLOCATE(D_store(MAX_PTS)) + ALLOCATE(hash_head(HASH_SZ)) + ALLOCATE(hash_next(MAX_PTS)) + + hash_head = 0 + hash_next = 0 + n_pts = 0 + n_amr_cells = 0 + step = (2.0d0 * scan_width) / DBLE(Q_num - 1) + +c --- 2. build initial coarse grid of (Q_num-1)^2 cells + + DO i = 1, Q_num - 1 + DO j = 1, Q_num - 1 + x = -scan_width + DBLE(i-1) * step + y = -scan_width + DBLE(j-1) * step + + n_amr_cells = n_amr_cells + 1 + + IF (n_amr_cells > MAX_CELLS) THEN + WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in init' + STOP 'dispersion_AMR_v2: MAX_CELLS in init' + END IF + +c corner order: BL=1, BR=2, TL=3, TR=4 + amr_cells(n_amr_cells)%Q(1) = CMPLX(x, y, KIND=r8) + amr_cells(n_amr_cells)%Q(2) = CMPLX(x+step, y, KIND=r8) + amr_cells(n_amr_cells)%Q(3) = CMPLX(x, y+step, KIND=r8) + amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, + $ KIND=r8) + +c evaluate dispersion at each corner (hash-cached) + DO corner = 1, 4 + CALL get_or_compute_v2( + $ amr_cells(n_amr_cells)%Q(corner), + $ idx_tmp, n_k, sl_in, msing_max, + $ coupling_flag) + amr_cells(n_amr_cells)%D(corner) = + $ D_store(idx_tmp) + END DO + + amr_cells(n_amr_cells)%needs_refine = .FALSE. + END DO + END DO + +c --- 3. refinement passes: subdivide cells with zero crossings + DO pass = 1, AMR_passes + WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, + $ ': Processing ', n_amr_cells, ' cells' + +c flag cells that span a zero in Re(D) or Im(D) + cells_to_refine = 0 + DO c = 1, n_amr_cells + CALL check_cell_crossing_sub(amr_cells(c), + $ cross_real, cross_imag) + amr_cells(c)%needs_refine = (cross_real .OR. cross_imag) + IF (amr_cells(c)%needs_refine) THEN + cells_to_refine = cells_to_refine + 1 + END IF + END DO + +c build new cell list: subdivide flagged, keep the rest + n_new_cells = 0 + cells_kept = 0 + + DO c = 1, n_amr_cells + IF (amr_cells(c)%needs_refine) THEN + CALL subdivide_cell_sub(amr_cells(c), + $ new_cells, n_new_cells, MAX_CELLS, + $ n_k, sl_in, msing_max, coupling_flag) + ELSE + n_new_cells = n_new_cells + 1 + IF (n_new_cells > MAX_CELLS) THEN + WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in refine' + STOP 'dispersion_AMR_v2: MAX_CELLS in refine' + END IF + new_cells(n_new_cells) = amr_cells(c) + cells_kept = cells_kept + 1 + END IF + END DO + +c swap arrays for next pass (pointer swap, no element copy) + CALL MOVE_ALLOC(new_cells, swap_tmp) + CALL MOVE_ALLOC(amr_cells, new_cells) ! old amr_cells becomes new_cells + CALL MOVE_ALLOC(swap_tmp, amr_cells) ! filled array becomes amr_cells + n_amr_cells = n_new_cells + + END DO + +c --- 4. output: Q_store/D_store already populated by hash cache. +c Trim to exact size n_pts and deallocate hash infrastructure. + + ALLOCATE(temp_Q(n_pts)) + ALLOCATE(temp_D(n_pts)) + temp_Q(1:n_pts) = Q_store(1:n_pts) + temp_D(1:n_pts) = D_store(1:n_pts) + CALL MOVE_ALLOC(temp_Q, Q_store) + CALL MOVE_ALLOC(temp_D, D_store) + + IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) + IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) + DEALLOCATE(new_cells) +c keep amr_cells allocated for potential post-run inspection + + WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts + WRITE(*,'(A,2ES14.6)') ' D_store checksum (Re,Im):', + $ SUM(REAL(D_store(1:n_pts))), + $ SUM(AIMAG(D_store(1:n_pts))) + WRITE(*,'(A,2ES14.6)') ' D_store(1) sample:', + $ REAL(D_store(1)), AIMAG(D_store(1)) + + RETURN + END SUBROUTINE dispersion_AMR_v2 + +c----------------------------------------------------------------------- +c compute_delta_sub: evaluate the dispersion relation at a single +c complex-Q point for dispersion_AMR_v2. Multiplies q_in by ifac +c before passing to the Riccati solver or coupled-surface +c determinant routine. +c----------------------------------------------------------------------- + SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, + $ coupling_flag, delta_out) + + IMPLICIT NONE + +c --- arguments + COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point + INTEGER, INTENT(IN) :: n_k ! number of surfaces + INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag ! use coupled det? + COMPLEX(r8), INTENT(OUT) :: delta_out ! dispersion result + + IF (coupling_flag) THEN + g_tmp = q_in*ifac + delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) + ELSE + g_tmp = q_in*ifac + delta_out = riccati_f() + delta_out = delta_out - delta_eff + END IF + + RETURN + END SUBROUTINE compute_delta_sub + + +c----------------------------------------------------------------------- +c check_cell_crossing_sub: test whether a cell’s 4 corner D-values +c span a zero crossing in Re(D) and/or Im(D). Used by +c dispersion_AMR_v2 to decide which cells to refine. +c----------------------------------------------------------------------- + SUBROUTINE check_cell_crossing_sub(cell, cross_real, cross_imag) + + IMPLICIT NONE + + TYPE(amr_cell_type), INTENT(IN) :: cell + LOGICAL, INTENT(OUT) :: cross_real, cross_imag + + REAL(r8) :: r_vals(4), i_vals(4) ! corner Re/Im values + REAL(r8) :: r_min, r_max, i_min, i_max + INTEGER :: k + + DO k = 1, 4 + r_vals(k) = REAL(cell%D(k), KIND=r8) + i_vals(k) = AIMAG(cell%D(k)) + END DO + + r_min = MINVAL(r_vals) + r_max = MAXVAL(r_vals) + cross_real = (r_min * r_max <= 0.0d0) + + i_min = MINVAL(i_vals) + i_max = MAXVAL(i_vals) + cross_imag = (i_min * i_max <= 0.0d0) + + RETURN + END SUBROUTINE check_cell_crossing_sub + + +c----------------------------------------------------------------------- +c subdivide_cell_sub: split a parent cell into 4 child cells by +c computing 5 midpoints (bottom-mid, top-mid, left-mid, right-mid, +c centre) and evaluating the dispersion relation at each. The 4 +c resulting child cells are appended to new_cells. +c----------------------------------------------------------------------- + SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, + $ max_cells, n_k, sl_in, + $ msing_max, coupling_flag) + + IMPLICIT NONE + +c --- arguments + TYPE(amr_cell_type), INTENT(IN) :: parent + TYPE(amr_cell_type), INTENT(INOUT) :: new_cells(*) + INTEGER, INTENT(INOUT) :: n_new ! running count of new cells + INTEGER, INTENT(IN) :: max_cells ! capacity of new_cells + INTEGER, INTENT(IN) :: n_k + INTEGER, INTENT(IN) :: msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag +c --- corner coordinates and D-values from parent + COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr + COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr +c --- midpoint coordinates and D-values (cached via hash) + COMPLEX(r8) :: q_bm, q_tm, q_lm, q_rm, q_mm + COMPLEX(r8) :: d_bm, d_tm, d_lm, d_rm, d_mm + INTEGER :: idx_tmp ! hash-cache index + +c --- extract parent corners (BL=1, BR=2, TL=3, TR=4) + q_bl = parent%Q(1) + q_br = parent%Q(2) + q_tl = parent%Q(3) + q_tr = parent%Q(4) + + d_bl = parent%D(1) + d_br = parent%D(2) + d_tl = parent%D(3) + d_tr = parent%D(4) + +c --- compute 5 midpoint coordinates + q_bm = 0.5d0 * (q_bl + q_br) + q_tm = 0.5d0 * (q_tl + q_tr) + q_lm = 0.5d0 * (q_bl + q_tl) + q_rm = 0.5d0 * (q_br + q_tr) + q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) + +c --- evaluate dispersion at new midpoints (hash-cached) + CALL get_or_compute_v2(q_bm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_bm = D_store(idx_tmp) + CALL get_or_compute_v2(q_tm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_tm = D_store(idx_tmp) + CALL get_or_compute_v2(q_lm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_lm = D_store(idx_tmp) + CALL get_or_compute_v2(q_rm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_rm = D_store(idx_tmp) + CALL get_or_compute_v2(q_mm, idx_tmp, + $ n_k, sl_in, msing_max, coupling_flag) + d_mm = D_store(idx_tmp) + +c --- check space for 4 new cells + IF (n_new + 4 > max_cells) THEN + WRITE(*,*) 'ERROR: Would exceed MAX_CELLS in subdivide' + STOP 'subdivide_cell_sub: MAX_CELLS exceeded' + END IF + +c --- child 1: bottom-left quadrant (BL, BM, LM, MM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_bl + new_cells(n_new)%Q(2) = q_bm + new_cells(n_new)%Q(3) = q_lm + new_cells(n_new)%Q(4) = q_mm + new_cells(n_new)%D(1) = d_bl + new_cells(n_new)%D(2) = d_bm + new_cells(n_new)%D(3) = d_lm + new_cells(n_new)%D(4) = d_mm + new_cells(n_new)%needs_refine = .FALSE. + +c --- child 2: bottom-right quadrant (BM, BR, MM, RM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_bm + new_cells(n_new)%Q(2) = q_br + new_cells(n_new)%Q(3) = q_mm + new_cells(n_new)%Q(4) = q_rm + new_cells(n_new)%D(1) = d_bm + new_cells(n_new)%D(2) = d_br + new_cells(n_new)%D(3) = d_mm + new_cells(n_new)%D(4) = d_rm + new_cells(n_new)%needs_refine = .FALSE. + +c --- child 3: top-left quadrant (LM, MM, TL, TM) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_lm + new_cells(n_new)%Q(2) = q_mm + new_cells(n_new)%Q(3) = q_tl + new_cells(n_new)%Q(4) = q_tm + new_cells(n_new)%D(1) = d_lm + new_cells(n_new)%D(2) = d_mm + new_cells(n_new)%D(3) = d_tl + new_cells(n_new)%D(4) = d_tm + new_cells(n_new)%needs_refine = .FALSE. + +c --- child 4: top-right quadrant (MM, RM, TM, TR) + n_new = n_new + 1 + new_cells(n_new)%Q(1) = q_mm + new_cells(n_new)%Q(2) = q_rm + new_cells(n_new)%Q(3) = q_tm + new_cells(n_new)%Q(4) = q_tr + new_cells(n_new)%D(1) = d_mm + new_cells(n_new)%D(2) = d_rm + new_cells(n_new)%D(3) = d_tm + new_cells(n_new)%D(4) = d_tr + new_cells(n_new)%needs_refine = .FALSE. + + RETURN + END SUBROUTINE subdivide_cell_sub + + +c----------------------------------------------------------------------- +c flatten_cells_to_points_sub: extract unique (Q, D) points from +c the cell array into the module-level Q_store / D_store arrays. +c Uses a brute-force O(n^2) duplicate check which is acceptable +c for moderate cell counts; could be replaced by a hash set for +c very large scans. +c +c n_total_corners = num_cells*4; guarded against MAX_PTS overflow. +c----------------------------------------------------------------------- + SUBROUTINE flatten_cells_to_points_sub(num_cells) + + IMPLICIT NONE + +c --- arguments + INTEGER, INTENT(IN) :: num_cells ! number of cells to flatten +c --- locals + INTEGER :: c, corner, i, idx + INTEGER :: n_total_corners ! = num_cells * 4 + COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! all corner Q-values + COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! all corner D-values + INTEGER, ALLOCATABLE :: sort_idx(:) ! sort permutation + REAL(r8) :: tol ! duplicate tolerance + + tol = 1.0d-10 + n_total_corners = num_cells * 4 + + IF (n_total_corners > MAX_PTS) THEN + WRITE(*,*) 'ERROR: n_total_corners=', n_total_corners, + $ ' exceeds MAX_PTS=', MAX_PTS + STOP 'flatten_cells_to_points_sub: MAX_PTS exceeded' + END IF + + IF (num_cells <= 0) THEN + WRITE(*,*) 'ERROR: No cells to flatten' + n_pts = 0 + RETURN + END IF + +c --- gather all corners from cells + ALLOCATE(temp_Q(n_total_corners)) + ALLOCATE(temp_D(n_total_corners)) + ALLOCATE(sort_idx(n_total_corners)) + + idx = 0 + DO c = 1, num_cells + DO corner = 1, 4 + idx = idx + 1 + temp_Q(idx) = amr_cells(c)%Q(corner) + temp_D(idx) = amr_cells(c)%D(corner) + sort_idx(idx) = idx + END DO + END DO + +c --- sort by (Re(Q), Im(Q)) via quicksort on the index array + CALL qsort_complex_idx(temp_Q, sort_idx, 1, n_total_corners) + +c --- linear scan to count unique points (sorted order) + n_pts = 1 + DO i = 2, n_total_corners + IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) + $ >= tol) THEN + n_pts = n_pts + 1 + END IF + END DO + +c --- copy unique points to module-level output arrays + IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) + IF (ALLOCATED(D_store)) DEALLOCATE(D_store) + ALLOCATE(Q_store(n_pts)) + ALLOCATE(D_store(n_pts)) + + idx = 1 + Q_store(1) = temp_Q(sort_idx(1)) + D_store(1) = temp_D(sort_idx(1)) + DO i = 2, n_total_corners + IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) + $ >= tol) THEN + idx = idx + 1 + Q_store(idx) = temp_Q(sort_idx(i)) + D_store(idx) = temp_D(sort_idx(i)) + END IF + END DO + + DEALLOCATE(temp_Q, temp_D, sort_idx) + + RETURN + END SUBROUTINE flatten_cells_to_points_sub + +c----------------------------------------------------------------------- +c qsort_complex_idx: in-place quicksort of an index array by +c the complex keys (Re then Im). Operates on sort_idx so the +c Q/D data arrays remain untouched. +c----------------------------------------------------------------------- + RECURSIVE SUBROUTINE qsort_complex_idx(keys, idx, lo, hi) + + IMPLICIT NONE + + COMPLEX(r8), INTENT(IN) :: keys(:) + INTEGER, INTENT(INOUT) :: idx(:) + INTEGER, INTENT(IN) :: lo, hi + + INTEGER :: i, j, pivot_idx, tmp + REAL(r8) :: p_re, p_im, k_re, k_im + + IF (lo >= hi) RETURN + +c median-of-three pivot selection + pivot_idx = idx((lo + hi) / 2) + p_re = REAL(keys(pivot_idx), KIND=r8) + p_im = AIMAG(keys(pivot_idx)) + + i = lo + j = hi + DO WHILE (i <= j) +c advance i while keys(idx(i)) < pivot + k_re = REAL(keys(idx(i)), KIND=r8) + k_im = AIMAG(keys(idx(i))) + DO WHILE (k_re < p_re .OR. + $ (k_re == p_re .AND. k_im < p_im)) + i = i + 1 + k_re = REAL(keys(idx(i)), KIND=r8) + k_im = AIMAG(keys(idx(i))) + END DO +c retreat j while keys(idx(j)) > pivot + k_re = REAL(keys(idx(j)), KIND=r8) + k_im = AIMAG(keys(idx(j))) + DO WHILE (k_re > p_re .OR. + $ (k_re == p_re .AND. k_im > p_im)) + j = j - 1 + k_re = REAL(keys(idx(j)), KIND=r8) + k_im = AIMAG(keys(idx(j))) + END DO +c swap if pointers haven't crossed + IF (i <= j) THEN + tmp = idx(i) + idx(i) = idx(j) + idx(j) = tmp + i = i + 1 + j = j - 1 + END IF + END DO + +c recurse on partitions + IF (lo < j) CALL qsort_complex_idx(keys, idx, lo, j) + IF (i < hi) CALL qsort_complex_idx(keys, idx, i, hi) + + RETURN + END SUBROUTINE qsort_complex_idx + END MODULE growthrates_mod \ No newline at end of file diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 85037c779..1275af917 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -1,24 +1,16 @@ MODULE gslayer_mod c----------------------------------------------------------------------- -c gslayer_mod: SLAYER driver routines and AMR dispersion scanners. +c gslayer_mod: Single-surface SLAYER driver called by GPEC. +c +c This module contains the gpec_slayer subroutine, which computes +c Delta, torque, and critical field threshold for one rational +c surface. It is the primary interface used by gpec/gpout.f. +c +c Growth-rate scanning, AMR dispersion solvers, and I/O helpers +c have been split out into growthrates_mod (growthrates.f). c c Subprograms: c 1. gpec_slayer - single-surface delta/torque driver -c 2. output_gamma - write results to netCDF via -c slayer_netcdf_mod -c 3. allocate_inputs - allocate slayer_inputs_type arrays -c 4. allocate_outputs - allocate slayer_outputs_type arrays -c 5. shrink_array - trim over-allocated scan arrays -c 6. grow_array - expand scan arrays dynamically -c 7. calc_determinant - 2x2 / 3x3 complex determinant -c 8. dispersion_det - coupled dispersion determinant -c 9. dispersion_AMR - AMR scan v1 (hash-based dedup) -c 10. dispersion_AMR_v2 - AMR scan v2 (cell-based storage) -c -c Helper subroutines (v1): get_or_compute -c Helper subroutines (v2): get_or_compute_v2, -c compute_delta_sub, check_cell_crossing_sub, -c subdivide_cell_sub, flatten_cells_to_points_sub c----------------------------------------------------------------------- USE omp_lib @@ -265,1049 +257,4 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, RETURN END SUBROUTINE gpec_slayer -c----------------------------------------------------------------------- -c subprogram 2. output_gamma. -c Write growth-rate results to netCDF via slayer_netcdf_out. -c Passes the input/output structured types and AMR results -c through to the netCDF writer (slayer_netcdf_mod). -c----------------------------------------------------------------------- - SUBROUTINE output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, - $ all_deltas_out) - - LOGICAL, INTENT(IN) :: est_gamma_flag ! single-surface mode? - INTEGER, INTENT(IN) :: m_AMR ! AMR pass count - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - TYPE(slayer_outputs_type), INTENT(IN) :: sl_out - TYPE(deltas_outputs_type), INTENT(IN) :: - $ all_deltas_out(SIZE(sl_in%qval_arr)) - - CALL slayer_netcdf_out(SIZE(sl_in%qval_arr),m_AMR,est_gamma_flag, - $ sl_in,sl_out,all_deltas_out) - - END SUBROUTINE output_gamma -c----------------------------------------------------------------------- -c subprogram 3. allocate_inputs. -c Allocate all per-surface arrays inside slayer_inputs_type. -c----------------------------------------------------------------------- - SUBROUTINE allocate_inputs(n_k,sl_in) - - INTEGER, INTENT(IN) :: n_k ! number of surfaces - TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in - - ALLOCATE(sl_in%qval_arr(n_k),sl_in%omegas_arr(n_k), - $ sl_in%Q_e_arr(n_k),sl_in%Q_i_arr(n_k),sl_in%psi_n_arr(n_k), - $ sl_in%Re_dp_arr(n_k),sl_in%Im_dp_arr(n_k), - $ sl_in%d_crit_arr(n_k),sl_in%P_tor_arr(n_k), - $ sl_in%P_perp_arr(n_k),sl_in%tau_arr(n_k), - $ sl_in%D_norm_arr(n_k), - $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), - $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k)) - RETURN - END SUBROUTINE allocate_inputs -c----------------------------------------------------------------------- -c subprogram 4. allocate_outputs. -c Allocate per-surface arrays inside slayer_outputs_type. -c----------------------------------------------------------------------- - SUBROUTINE allocate_outputs(n_k,sl_out) - - INTEGER, INTENT(IN) :: n_k ! number of surfaces - TYPE(slayer_outputs_type), INTENT(INOUT) :: sl_out - - ALLOCATE(sl_out%dels_db_arr(n_k),sl_out%gamma_sol_arr(n_k), - $ sl_out%gamma_est_arr(n_k),sl_out%br_th_arr(n_k) ) - RETURN - END SUBROUTINE allocate_outputs -c----------------------------------------------------------------------- -c subprogram 5. shrink_array. -c Trim an over-allocated REAL(r8) array down to new_size using -c MOVE_ALLOC (no copy of trailing elements). -c----------------------------------------------------------------------- - SUBROUTINE shrink_array(arr, new_size) - - REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) - INTEGER, INTENT(IN) :: new_size ! target size - REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer - - ALLOCATE(temp(new_size)) - temp(1:new_size) = arr(1:new_size) - CALL move_alloc(temp, arr) - END SUBROUTINE shrink_array -c----------------------------------------------------------------------- -c subprogram 6. grow_array. -c Expand a REAL(r8) array from old_size to new_size, preserving -c existing data via MOVE_ALLOC. -c----------------------------------------------------------------------- - SUBROUTINE grow_array(arr, old_size, new_size) - - REAL(r8), ALLOCATABLE, INTENT(INOUT) :: arr(:) - INTEGER, INTENT(IN) :: old_size ! current valid element count - INTEGER, INTENT(IN) :: new_size ! target allocation size - REAL(r8), ALLOCATABLE :: temp(:) ! temporary buffer - - ALLOCATE(temp(new_size)) - temp(1:old_size) = arr(1:old_size) - CALL move_alloc(temp, arr) - END SUBROUTINE grow_array -c----------------------------------------------------------------------- -c subprogram 7. calc_determinant. -c Compute the determinant of a 2x2 or 3x3 complex matrix. -c Returns (0,0) and sets status=-1 for unsupported sizes. -c status=0 on success, -1 when nk is neither 2 nor 3. -c----------------------------------------------------------------------- - SUBROUTINE calc_determinant(matk, nk, detk, status) - - IMPLICIT NONE - -c --- arguments - INTEGER, INTENT(IN) :: nk ! matrix rank (2 or 3) - COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! input matrix - COMPLEX(r8), INTENT(OUT) :: detk ! determinant result - INTEGER, INTENT(OUT) :: status ! 0=success, -1=unsupported rank - - status = 0 ! Initialize status as success - - SELECT CASE (nk) - CASE (2) - ! 2x2 determinant: ad - bc - detk = matk(1,1) * matk(2,2) - matk(1,2) * matk(2,1) - - CASE (3) - ! 3x3 determinant using cofactor expansion along first row - detk = matk(1,1)*(matk(2,2)*matk(3,3)-matk(2,3) - $ *matk(3,2))-matk(1,2)*(matk(2,1)*matk(3,3) - $ -matk(2,3)*matk(3,1))+matk(1,3)*(matk(2,1) - $ *matk(3,2)-matk(2,2)*matk(3,1)) - - CASE default - ! Unsupported matrix size - detk = (0.0, 0.0) - status = -1 - - END SELECT - RETURN - END SUBROUTINE calc_determinant -c----------------------------------------------------------------------- -c subprogram 8. dispersion_det. -c Compute the coupled dispersion determinant for n_k surfaces. -c -c For n_k = 1 (single surface): -c Evaluate riccati_f() (uses module g_tmp), de-normalise by lu^(1/3), and -c return Deltaprime - delta(Q). -c -c For n_k = 2 or 3 (coupled surfaces): -c Build the diagonal delta(Q) matrix, subtract from dp_matrix, -c and return det(dp_matrix - delta_Q). -c -c----------------------------------------------------------------------- - FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) - -c --- arguments - COMPLEX(r8), INTENT(IN) :: g_in ! complex growth rate - INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces to include - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in -c --- function result and locals - COMPLEX(r8) :: dispersion_det ! returned determinant - COMPLEX(r8) :: det_val ! intermediate determinant - COMPLEX(r8) :: tmp_delta ! single-surface delta - COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:) ! diagonal delta matrix - COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! dp - delta_Q - INTEGER :: k ! surface loop index - INTEGER :: det_status ! calc_determinant error status - -c --- single-surface branch - IF (msing_max < 2) THEN -c set module-level variables for riccati_f - Q_e = sl_in%Q_e_arr(1) - Q_i = sl_in%Q_i_arr(1) - P_perp = sl_in%P_perp_arr(1) - P_tor = sl_in%P_tor_arr(1) - tau = sl_in%tau_arr(1) - D_norm = sl_in%D_norm_arr(1) - c_beta = sl_in%c_beta_arr(1) - tauk = sl_in%Qconv_arr(1) - iota_e = Q_e / (Q_e - Q_i) - - g_tmp = g_in - tmp_delta=riccati_f() -c de-normalise delta by lu^(1/3) - det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) - -c return Deltaprime - delta(Q) - dispersion_det = sl_in%Re_dp_arr(1) - det_val - -c --- coupled-surface branch (2 or 3 surfaces) - ELSEIF ((msing_max == 2) .OR. (msing_max == 3)) THEN - ALLOCATE(delta_Q(msing_max,msing_max)) - delta_Q=(0.0,0.0) - DO k=1,msing_max -c set module-level variables for this surface - Q_e = sl_in%Q_e_arr(k) - Q_i = sl_in%Q_i_arr(k) - P_perp = sl_in%P_perp_arr(k) - P_tor = sl_in%P_tor_arr(k) - tau = sl_in%tau_arr(k) - D_norm = sl_in%D_norm_arr(k) - c_beta = sl_in%c_beta_arr(k) - tauk = sl_in%Qconv_arr(k) - iota_e = Q_e / (Q_e - Q_i) - -c evaluate riccati_f at rescaled growth rate, de-normalise - g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk ! sets module-level g_tmp to SCALED value - delta_Q(k,k)=riccati_f() - delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) - END DO - -c compute det(dp_matrix - delta_Q) - result_matrix = sl_in%dp_matrix - delta_Q - CALL calc_determinant(result_matrix, msing_max, det_val, - $ det_status) - IF (det_status /= 0) THEN - WRITE(*,*) 'ERROR: calc_determinant unsupported rank=', - $ msing_max - STOP 'dispersion_det: calc_determinant failed' - END IF - dispersion_det = det_val - ELSE - WRITE(*,*) "Error: no support for msing > 3" - STOP "dispersion_det: unsupported n_k" - END IF - END FUNCTION dispersion_det - -c----------------------------------------------------------------------- -c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc -c Scans a 2D complex-Q grid for zeros of the dispersion relation -c D(Q) using adaptive refinement. A coarse grid is evaluated -c first (two-pass: nodes then cells), then cells that span a zero -c crossing in Re(D) or Im(D) are subdivided. -c -c Point deduplication uses a spatial hash table (HASH_SZ buckets, -c chained) so that midpoints shared between neighbouring cells -c are evaluated only once. -c----------------------------------------------------------------------- - SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, - $ scan_width,Q_num,AMR_passes, - $ coupling_flag) -c DEPRECATED: use dispersion_AMR_v2 instead. -c This v1 hash-based scanner is retained for -c backwards compatibility only. - -c --- arguments - INTEGER, INTENT(IN) :: n_k ! number of rational surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling - INTEGER, INTENT(IN) :: Q_num ! grid points per axis - INTEGER, INTENT(IN) :: AMR_passes ! refinement passes - REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? -c --- cell storage - INTEGER, ALLOCATABLE :: cells(:,:) ! (4, max) corner indices per cell - INTEGER, ALLOCATABLE :: new_cells(:,:) ! scratch for next level -c --- loop / index variables - INTEGER :: n_cells, n_new_cells, i, j - INTEGER :: c_idx, pass - INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! corner indices - INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! midpoint indices -c --- scan workspace - REAL(r8) :: r_min, r_max, i_min, i_max ! min/max Re/Im across corners - REAL(r8) :: ing_step ! coarse grid spacing - REAL(r8) :: ing_coarse, iing_coarse ! Re/Im coords for coarse node - LOGICAL :: cross_real, cross_imag ! zero-crossing flags - COMPLEX(r8) :: q_curr ! current evaluation point - INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Q_num,Q_num) node index map - -c --- 1. initialise hash table and point/cell storage - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) - IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - - ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) - ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) - ALLOCATE(cells(4, 200000), new_cells(4, 200000)) - - hash_head = 0 - hash_next = 0 - n_pts = 0 - n_cells = 0 - -c --- 2. build initial coarse grid (two-pass method) -c Pass 1 computes and hashes every node; Pass 2 stitches cells -c from the stored indices -- no floating-point comparison needed. - ALLOCATE(coarse_indices(Q_num, Q_num)) - ing_step = (2.0*scan_width) / (Q_num - 1) - -c Pass 1: compute all grid nodes and store their hash indices - DO i = 1, Q_num - DO j = 1, Q_num - ing_coarse = -scan_width + (i - 1) * ing_step - iing_coarse = -scan_width + (j - 1) * ing_step - q_curr = CMPLX(ing_coarse, iing_coarse) - - CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, - $ sl_in, msing_max, coupling_flag) - END DO - END DO - -c Pass 2: stitch cells from the stored integer indices - DO i = 1, Q_num - 1 - DO j = 1, Q_num - 1 - n_cells = n_cells + 1 - cells(1, n_cells) = coarse_indices(i, j) ! TL - cells(2, n_cells) = coarse_indices(i+1, j) ! TR - cells(3, n_cells) = coarse_indices(i, j+1) ! BL - cells(4, n_cells) = coarse_indices(i+1, j+1) ! BR - END DO - END DO - DEALLOCATE(coarse_indices) - -c --- 3. refinement passes: subdivide cells with zero crossings - DO pass = 1, AMR_PASSES - WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, - $ ': Checking ', n_cells, ' cells...' - n_new_cells = 0 - - DO c_idx = 1, n_cells - idx_TL = cells(1, c_idx) - idx_TR = cells(2, c_idx) - idx_BL = cells(3, c_idx) - idx_BR = cells(4, c_idx) - -c check for sign change in Re(D) across cell corners - r_min = MIN(REAL(D_store(idx_TL)), - $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), - $ REAL(D_store(idx_BR))) - r_max = MAX(REAL(D_store(idx_TL)), - $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), - $ REAL(D_store(idx_BR))) - cross_real = (r_min * r_max <= 0.0d0) - -c check for sign change in Im(D) across cell corners - i_min = MIN(AIMAG(D_store(idx_TL)), - $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), - $ AIMAG(D_store(idx_BR))) - i_max = MAX(AIMAG(D_store(idx_TL)), - $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), - $ AIMAG(D_store(idx_BR))) - cross_imag = (i_min * i_max <= 0.0d0) - - IF (cross_real .OR. cross_imag) THEN -c refine: compute 5 midpoints, create 4 sub-cells - - ! Top-Mid - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_TR)) - CALL get_or_compute(q_curr, idx_TM,n_k, - $ sl_in,msing_max,coupling_flag) - - ! Bot-Mid - q_curr = 0.5d0*(Q_store(idx_BL)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_BM,n_k, - $ sl_in,msing_max,coupling_flag) - - ! Left-Mid - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BL)) - CALL get_or_compute(q_curr, idx_LM,n_k, - $ sl_in,msing_max,coupling_flag) - - ! Right-Mid - q_curr = 0.5d0*(Q_store(idx_TR)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_RM,n_k, - $ sl_in,msing_max,coupling_flag) - - ! Center - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_MM,n_k, - $ sl_in,msing_max,coupling_flag) - - ! Create 4 sub-cells (TL, TR, BL, BR quadrants) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_TL - new_cells(2, n_new_cells) = idx_TM - new_cells(3, n_new_cells) = idx_LM - new_cells(4, n_new_cells) = idx_MM - - ! Sub 2 (Top-Right) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_TM - new_cells(2, n_new_cells) = idx_TR - new_cells(3, n_new_cells) = idx_MM - new_cells(4, n_new_cells) = idx_RM - - ! Sub 3 (Bot-Left) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_LM - new_cells(2, n_new_cells) = idx_MM - new_cells(3, n_new_cells) = idx_BL - new_cells(4, n_new_cells) = idx_BM - - ! Sub 4 (Bot-Right) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_MM - new_cells(2, n_new_cells) = idx_RM - new_cells(3, n_new_cells) = idx_BM - new_cells(4, n_new_cells) = idx_BR - - ELSE - ! No refinement needed, keep original cell - n_new_cells = n_new_cells + 1 - new_cells(:, n_new_cells) = cells(:, c_idx) - END IF - END DO - -c --- swap arrays for next refinement pass - n_cells = n_new_cells - cells(:, 1:n_cells) = new_cells(:, 1:n_cells) - - END DO - DEALLOCATE(cells, new_cells) - WRITE(*,*) "AMR Scan Complete. Total Points:", n_pts - RETURN - END SUBROUTINE dispersion_AMR - -c----------------------------------------------------------------------- -c get_or_compute: hash-based point lookup for dispersion_AMR v1. -c If q_in is already in the hash table, return its index. -c Otherwise, evaluate the dispersion relation at q_in, store -c the result, and insert into the hash table. -c -c Uses 64-bit arithmetic internally to avoid integer overflow -c in the hash function. -c----------------------------------------------------------------------- - SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, - $ coupling_flag) - -c --- arguments - COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point - INTEGER, INTENT(OUT) :: idx_out ! returned point index - INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces to include - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! use coupled dispersion_det? -c --- locals - INTEGER :: h ! hash bucket index - INTEGER :: curr ! linked-list traversal index - COMPLEX(r8) :: delta_val ! computed dispersion result - INTEGER(8) :: ix8, iy8, h8 ! 64-bit intermediates for hash - -c --- 1. compute hash from quantised Re/Im coordinates (64-bit safe) - ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) - iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) - h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), - $ INT(HASH_SZ, 8)) + 1_8 - h = INT(h8) - - IF (h < 1 .OR. h > HASH_SZ) THEN - WRITE(*,*) "HASH ERROR: h=", h, " q_in=", q_in - STOP "get_or_compute: hash out of bounds" - END IF - -c --- 2. search hash chain for existing point - curr = hash_head(h) - DO WHILE (curr /= 0) - IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN - idx_out = curr - RETURN - END IF - curr = hash_next(curr) - END DO - -c --- 3. point not found: evaluate dispersion relation and store - n_pts = n_pts + 1 - IF (n_pts > MAX_PTS) THEN - WRITE(*,*) "ERROR: AMR exceeded MAX_PTS" - STOP "get_or_compute: MAX_PTS exceeded" - END IF - - idx_out = n_pts - Q_store(idx_out) = q_in - - IF (coupling_flag) THEN - g_tmp = q_in - delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) - ELSE - g_tmp = q_in - delta_val = riccati_f() - delta_val = delta_val - delta_eff - END IF - D_store(idx_out) = delta_val - -c --- 4. insert into hash chain (prepend) - hash_next(idx_out) = hash_head(h) - hash_head(h) = idx_out - - END SUBROUTINE get_or_compute - -c----------------------------------------------------------------------- -c get_or_compute_v2: hash-cached dispersion evaluation for AMR v2. -c Identical to get_or_compute but applies the ifac (imaginary-unit) -c Wick rotation that compute_delta_sub uses: g_tmp = q_in * ifac. -c----------------------------------------------------------------------- - SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, - $ msing_max, coupling_flag) - - IMPLICIT NONE - -c --- arguments - COMPLEX(r8), INTENT(IN) :: q_in - INTEGER, INTENT(OUT) :: idx_out - INTEGER, INTENT(IN) :: n_k, msing_max - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag - -c --- locals - INTEGER :: h, curr - COMPLEX(r8) :: delta_val - INTEGER(8) :: ix8, iy8, h8 - -c --- 1. compute hash bucket - ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) - iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) - h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), - $ INT(HASH_SZ, 8)) + 1_8 - h = INT(h8) - -c --- 2. search hash chain for existing point - curr = hash_head(h) - DO WHILE (curr /= 0) - IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN - idx_out = curr - RETURN - END IF - curr = hash_next(curr) - END DO - -c --- 3. not found: evaluate with ifac rotation and store - n_pts = n_pts + 1 - IF (n_pts > MAX_PTS) THEN - WRITE(*,*) 'ERROR: AMR v2 cache exceeded MAX_PTS' - STOP 'get_or_compute_v2: MAX_PTS exceeded' - END IF - - idx_out = n_pts - Q_store(idx_out) = q_in - - IF (coupling_flag) THEN - g_tmp = q_in * ifac - delta_val = dispersion_det(g_tmp, n_k, sl_in, - $ msing_max) - ELSE - g_tmp = q_in * ifac - delta_val = riccati_f() - delta_val = delta_val - delta_eff - END IF - D_store(idx_out) = delta_val - -c --- 4. insert into hash chain (prepend) - hash_next(idx_out) = hash_head(h) - hash_head(h) = idx_out - - END SUBROUTINE get_or_compute_v2 - -c----------------------------------------------------------------------- -c dispersion_AMR_v2: cell-based adaptive mesh refinement scanner. -c Unlike v1 (hash-based point deduplication), v2 stores complete -c cells (TYPE amr_cell_type), each carrying 4 corner Q- and D- -c values. Refinement subdivides cells that contain a zero in -c Re(D) or Im(D) and re-evaluates the dispersion relation at the -c 5 new midpoints. -c -c All dispersion evaluations go through get_or_compute_v2, which -c caches results in Q_store / D_store via a hash table. This -c eliminates redundant evaluations for shared corners (initial grid) -c and shared edge-midpoints (refinement). At completion, Q_store -c and D_store are trimmed to n_pts unique output points. -c -c----------------------------------------------------------------------- - SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, - $ scan_width, Q_num, AMR_passes, - $ coupling_flag) - - IMPLICIT NONE - -c --- arguments - INTEGER, INTENT(IN) :: n_k ! number of rational surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling - INTEGER, INTENT(IN) :: Q_num ! grid points per axis - INTEGER, INTENT(IN) :: AMR_passes ! refinement passes - REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? -c --- locals - TYPE(amr_cell_type), ALLOCATABLE :: new_cells(:) - TYPE(amr_cell_type), ALLOCATABLE :: swap_tmp(:) ! for pointer swap - INTEGER :: i, j, c, corner, pass ! loop counters - REAL(r8) :: step ! grid spacing - REAL(r8) :: x, y ! real / imag grid coords - LOGICAL :: cross_real, cross_imag ! zero-crossing flags - INTEGER :: n_new_cells ! count during refinement - INTEGER :: cells_to_refine ! cells flagged per pass - INTEGER :: cells_kept ! cells kept per pass - INTEGER :: idx_tmp ! hash-cache index - COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! for trimming output - COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! for trimming output - -c --- 1. initialise cell storage and hash cache - - IF (ALLOCATED(amr_cells)) DEALLOCATE(amr_cells) - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) - IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - - ALLOCATE(amr_cells(MAX_CELLS)) - ALLOCATE(new_cells(MAX_CELLS)) - ALLOCATE(Q_store(MAX_PTS)) - ALLOCATE(D_store(MAX_PTS)) - ALLOCATE(hash_head(HASH_SZ)) - ALLOCATE(hash_next(MAX_PTS)) - - hash_head = 0 - hash_next = 0 - n_pts = 0 - n_amr_cells = 0 - step = (2.0d0 * scan_width) / DBLE(Q_num - 1) - -c --- 2. build initial coarse grid of (Q_num-1)^2 cells - - DO i = 1, Q_num - 1 - DO j = 1, Q_num - 1 - x = -scan_width + DBLE(i-1) * step - y = -scan_width + DBLE(j-1) * step - - n_amr_cells = n_amr_cells + 1 - - IF (n_amr_cells > MAX_CELLS) THEN - WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in init' - STOP 'dispersion_AMR_v2: MAX_CELLS in init' - END IF - -c corner order: BL=1, BR=2, TL=3, TR=4 - amr_cells(n_amr_cells)%Q(1) = CMPLX(x, y, KIND=r8) - amr_cells(n_amr_cells)%Q(2) = CMPLX(x+step, y, KIND=r8) - amr_cells(n_amr_cells)%Q(3) = CMPLX(x, y+step, KIND=r8) - amr_cells(n_amr_cells)%Q(4) = CMPLX(x+step, y+step, - $ KIND=r8) - -c evaluate dispersion at each corner (hash-cached) - DO corner = 1, 4 - CALL get_or_compute_v2( - $ amr_cells(n_amr_cells)%Q(corner), - $ idx_tmp, n_k, sl_in, msing_max, - $ coupling_flag) - amr_cells(n_amr_cells)%D(corner) = - $ D_store(idx_tmp) - END DO - - amr_cells(n_amr_cells)%needs_refine = .FALSE. - END DO - END DO - -c --- 3. refinement passes: subdivide cells with zero crossings - DO pass = 1, AMR_passes - WRITE(*,'(A,I2,A,I7,A)') ' Pass ', pass, - $ ': Processing ', n_amr_cells, ' cells' - -c flag cells that span a zero in Re(D) or Im(D) - cells_to_refine = 0 - DO c = 1, n_amr_cells - CALL check_cell_crossing_sub(amr_cells(c), - $ cross_real, cross_imag) - amr_cells(c)%needs_refine = (cross_real .OR. cross_imag) - IF (amr_cells(c)%needs_refine) THEN - cells_to_refine = cells_to_refine + 1 - END IF - END DO - -c build new cell list: subdivide flagged, keep the rest - n_new_cells = 0 - cells_kept = 0 - - DO c = 1, n_amr_cells - IF (amr_cells(c)%needs_refine) THEN - CALL subdivide_cell_sub(amr_cells(c), - $ new_cells, n_new_cells, MAX_CELLS, - $ n_k, sl_in, msing_max, coupling_flag) - ELSE - n_new_cells = n_new_cells + 1 - IF (n_new_cells > MAX_CELLS) THEN - WRITE(*,*) 'ERROR: Exceeded MAX_CELLS in refine' - STOP 'dispersion_AMR_v2: MAX_CELLS in refine' - END IF - new_cells(n_new_cells) = amr_cells(c) - cells_kept = cells_kept + 1 - END IF - END DO - -c swap arrays for next pass (pointer swap, no element copy) - CALL MOVE_ALLOC(new_cells, swap_tmp) - CALL MOVE_ALLOC(amr_cells, new_cells) ! old amr_cells becomes new_cells - CALL MOVE_ALLOC(swap_tmp, amr_cells) ! filled array becomes amr_cells - n_amr_cells = n_new_cells - - END DO - -c --- 4. output: Q_store/D_store already populated by hash cache. -c Trim to exact size n_pts and deallocate hash infrastructure. - - ALLOCATE(temp_Q(n_pts)) - ALLOCATE(temp_D(n_pts)) - temp_Q(1:n_pts) = Q_store(1:n_pts) - temp_D(1:n_pts) = D_store(1:n_pts) - CALL MOVE_ALLOC(temp_Q, Q_store) - CALL MOVE_ALLOC(temp_D, D_store) - - IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) - IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - DEALLOCATE(new_cells) -c keep amr_cells allocated for potential post-run inspection - - WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts - WRITE(*,'(A,2ES14.6)') ' D_store checksum (Re,Im):', - $ SUM(REAL(D_store(1:n_pts))), - $ SUM(AIMAG(D_store(1:n_pts))) - WRITE(*,'(A,2ES14.6)') ' D_store(1) sample:', - $ REAL(D_store(1)), AIMAG(D_store(1)) - - RETURN - END SUBROUTINE dispersion_AMR_v2 - -c----------------------------------------------------------------------- -c compute_delta_sub: evaluate the dispersion relation at a single -c complex-Q point for dispersion_AMR_v2. Multiplies q_in by ifac -c before passing to the Riccati solver or coupled-surface -c determinant routine. -c----------------------------------------------------------------------- - SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, - $ coupling_flag, delta_out) - - IMPLICIT NONE - -c --- arguments - COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point - INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! use coupled det? - COMPLEX(r8), INTENT(OUT) :: delta_out ! dispersion result - - IF (coupling_flag) THEN - g_tmp = q_in*ifac - delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) - ELSE - g_tmp = q_in*ifac - delta_out = riccati_f() - delta_out = delta_out - delta_eff - END IF - - RETURN - END SUBROUTINE compute_delta_sub - - -c----------------------------------------------------------------------- -c check_cell_crossing_sub: test whether a cell’s 4 corner D-values -c span a zero crossing in Re(D) and/or Im(D). Used by -c dispersion_AMR_v2 to decide which cells to refine. -c----------------------------------------------------------------------- - SUBROUTINE check_cell_crossing_sub(cell, cross_real, cross_imag) - - IMPLICIT NONE - - TYPE(amr_cell_type), INTENT(IN) :: cell - LOGICAL, INTENT(OUT) :: cross_real, cross_imag - - REAL(r8) :: r_vals(4), i_vals(4) ! corner Re/Im values - REAL(r8) :: r_min, r_max, i_min, i_max - INTEGER :: k - - DO k = 1, 4 - r_vals(k) = REAL(cell%D(k), KIND=r8) - i_vals(k) = AIMAG(cell%D(k)) - END DO - - r_min = MINVAL(r_vals) - r_max = MAXVAL(r_vals) - cross_real = (r_min * r_max <= 0.0d0) - - i_min = MINVAL(i_vals) - i_max = MAXVAL(i_vals) - cross_imag = (i_min * i_max <= 0.0d0) - - RETURN - END SUBROUTINE check_cell_crossing_sub - - -c----------------------------------------------------------------------- -c subdivide_cell_sub: split a parent cell into 4 child cells by -c computing 5 midpoints (bottom-mid, top-mid, left-mid, right-mid, -c centre) and evaluating the dispersion relation at each. The 4 -c resulting child cells are appended to new_cells. -c----------------------------------------------------------------------- - SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, - $ max_cells, n_k, sl_in, - $ msing_max, coupling_flag) - - IMPLICIT NONE - -c --- arguments - TYPE(amr_cell_type), INTENT(IN) :: parent - TYPE(amr_cell_type), INTENT(INOUT) :: new_cells(*) - INTEGER, INTENT(INOUT) :: n_new ! running count of new cells - INTEGER, INTENT(IN) :: max_cells ! capacity of new_cells - INTEGER, INTENT(IN) :: n_k - INTEGER, INTENT(IN) :: msing_max - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag -c --- corner coordinates and D-values from parent - COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr - COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr -c --- midpoint coordinates and D-values (cached via hash) - COMPLEX(r8) :: q_bm, q_tm, q_lm, q_rm, q_mm - COMPLEX(r8) :: d_bm, d_tm, d_lm, d_rm, d_mm - INTEGER :: idx_tmp ! hash-cache index - -c --- extract parent corners (BL=1, BR=2, TL=3, TR=4) - q_bl = parent%Q(1) - q_br = parent%Q(2) - q_tl = parent%Q(3) - q_tr = parent%Q(4) - - d_bl = parent%D(1) - d_br = parent%D(2) - d_tl = parent%D(3) - d_tr = parent%D(4) - -c --- compute 5 midpoint coordinates - q_bm = 0.5d0 * (q_bl + q_br) - q_tm = 0.5d0 * (q_tl + q_tr) - q_lm = 0.5d0 * (q_bl + q_tl) - q_rm = 0.5d0 * (q_br + q_tr) - q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) - -c --- evaluate dispersion at new midpoints (hash-cached) - CALL get_or_compute_v2(q_bm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) - d_bm = D_store(idx_tmp) - CALL get_or_compute_v2(q_tm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) - d_tm = D_store(idx_tmp) - CALL get_or_compute_v2(q_lm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) - d_lm = D_store(idx_tmp) - CALL get_or_compute_v2(q_rm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) - d_rm = D_store(idx_tmp) - CALL get_or_compute_v2(q_mm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) - d_mm = D_store(idx_tmp) - -c --- check space for 4 new cells - IF (n_new + 4 > max_cells) THEN - WRITE(*,*) 'ERROR: Would exceed MAX_CELLS in subdivide' - STOP 'subdivide_cell_sub: MAX_CELLS exceeded' - END IF - -c --- child 1: bottom-left quadrant (BL, BM, LM, MM) - n_new = n_new + 1 - new_cells(n_new)%Q(1) = q_bl - new_cells(n_new)%Q(2) = q_bm - new_cells(n_new)%Q(3) = q_lm - new_cells(n_new)%Q(4) = q_mm - new_cells(n_new)%D(1) = d_bl - new_cells(n_new)%D(2) = d_bm - new_cells(n_new)%D(3) = d_lm - new_cells(n_new)%D(4) = d_mm - new_cells(n_new)%needs_refine = .FALSE. - -c --- child 2: bottom-right quadrant (BM, BR, MM, RM) - n_new = n_new + 1 - new_cells(n_new)%Q(1) = q_bm - new_cells(n_new)%Q(2) = q_br - new_cells(n_new)%Q(3) = q_mm - new_cells(n_new)%Q(4) = q_rm - new_cells(n_new)%D(1) = d_bm - new_cells(n_new)%D(2) = d_br - new_cells(n_new)%D(3) = d_mm - new_cells(n_new)%D(4) = d_rm - new_cells(n_new)%needs_refine = .FALSE. - -c --- child 3: top-left quadrant (LM, MM, TL, TM) - n_new = n_new + 1 - new_cells(n_new)%Q(1) = q_lm - new_cells(n_new)%Q(2) = q_mm - new_cells(n_new)%Q(3) = q_tl - new_cells(n_new)%Q(4) = q_tm - new_cells(n_new)%D(1) = d_lm - new_cells(n_new)%D(2) = d_mm - new_cells(n_new)%D(3) = d_tl - new_cells(n_new)%D(4) = d_tm - new_cells(n_new)%needs_refine = .FALSE. - -c --- child 4: top-right quadrant (MM, RM, TM, TR) - n_new = n_new + 1 - new_cells(n_new)%Q(1) = q_mm - new_cells(n_new)%Q(2) = q_rm - new_cells(n_new)%Q(3) = q_tm - new_cells(n_new)%Q(4) = q_tr - new_cells(n_new)%D(1) = d_mm - new_cells(n_new)%D(2) = d_rm - new_cells(n_new)%D(3) = d_tm - new_cells(n_new)%D(4) = d_tr - new_cells(n_new)%needs_refine = .FALSE. - - RETURN - END SUBROUTINE subdivide_cell_sub - - -c----------------------------------------------------------------------- -c flatten_cells_to_points_sub: extract unique (Q, D) points from -c the cell array into the module-level Q_store / D_store arrays. -c Uses a brute-force O(n^2) duplicate check which is acceptable -c for moderate cell counts; could be replaced by a hash set for -c very large scans. -c -c n_total_corners = num_cells*4; guarded against MAX_PTS overflow. -c----------------------------------------------------------------------- - SUBROUTINE flatten_cells_to_points_sub(num_cells) - - IMPLICIT NONE - -c --- arguments - INTEGER, INTENT(IN) :: num_cells ! number of cells to flatten -c --- locals - INTEGER :: c, corner, i, idx - INTEGER :: n_total_corners ! = num_cells * 4 - COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! all corner Q-values - COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! all corner D-values - INTEGER, ALLOCATABLE :: sort_idx(:) ! sort permutation - REAL(r8) :: tol ! duplicate tolerance - - tol = 1.0d-10 - n_total_corners = num_cells * 4 - - IF (n_total_corners > MAX_PTS) THEN - WRITE(*,*) 'ERROR: n_total_corners=', n_total_corners, - $ ' exceeds MAX_PTS=', MAX_PTS - STOP 'flatten_cells_to_points_sub: MAX_PTS exceeded' - END IF - - IF (num_cells <= 0) THEN - WRITE(*,*) 'ERROR: No cells to flatten' - n_pts = 0 - RETURN - END IF - -c --- gather all corners from cells - ALLOCATE(temp_Q(n_total_corners)) - ALLOCATE(temp_D(n_total_corners)) - ALLOCATE(sort_idx(n_total_corners)) - - idx = 0 - DO c = 1, num_cells - DO corner = 1, 4 - idx = idx + 1 - temp_Q(idx) = amr_cells(c)%Q(corner) - temp_D(idx) = amr_cells(c)%D(corner) - sort_idx(idx) = idx - END DO - END DO - -c --- sort by (Re(Q), Im(Q)) via quicksort on the index array - CALL qsort_complex_idx(temp_Q, sort_idx, 1, n_total_corners) - -c --- linear scan to count unique points (sorted order) - n_pts = 1 - DO i = 2, n_total_corners - IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) - $ >= tol) THEN - n_pts = n_pts + 1 - END IF - END DO - -c --- copy unique points to module-level output arrays - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - ALLOCATE(Q_store(n_pts)) - ALLOCATE(D_store(n_pts)) - - idx = 1 - Q_store(1) = temp_Q(sort_idx(1)) - D_store(1) = temp_D(sort_idx(1)) - DO i = 2, n_total_corners - IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) - $ >= tol) THEN - idx = idx + 1 - Q_store(idx) = temp_Q(sort_idx(i)) - D_store(idx) = temp_D(sort_idx(i)) - END IF - END DO - - DEALLOCATE(temp_Q, temp_D, sort_idx) - - RETURN - END SUBROUTINE flatten_cells_to_points_sub - -c----------------------------------------------------------------------- -c qsort_complex_idx: in-place quicksort of an index array by -c the complex keys (Re then Im). Operates on sort_idx so the -c Q/D data arrays remain untouched. -c----------------------------------------------------------------------- - RECURSIVE SUBROUTINE qsort_complex_idx(keys, idx, lo, hi) - - IMPLICIT NONE - - COMPLEX(r8), INTENT(IN) :: keys(:) - INTEGER, INTENT(INOUT) :: idx(:) - INTEGER, INTENT(IN) :: lo, hi - - INTEGER :: i, j, pivot_idx, tmp - REAL(r8) :: p_re, p_im, k_re, k_im - - IF (lo >= hi) RETURN - -c median-of-three pivot selection - pivot_idx = idx((lo + hi) / 2) - p_re = REAL(keys(pivot_idx), KIND=r8) - p_im = AIMAG(keys(pivot_idx)) - - i = lo - j = hi - DO WHILE (i <= j) -c advance i while keys(idx(i)) < pivot - k_re = REAL(keys(idx(i)), KIND=r8) - k_im = AIMAG(keys(idx(i))) - DO WHILE (k_re < p_re .OR. - $ (k_re == p_re .AND. k_im < p_im)) - i = i + 1 - k_re = REAL(keys(idx(i)), KIND=r8) - k_im = AIMAG(keys(idx(i))) - END DO -c retreat j while keys(idx(j)) > pivot - k_re = REAL(keys(idx(j)), KIND=r8) - k_im = AIMAG(keys(idx(j))) - DO WHILE (k_re > p_re .OR. - $ (k_re == p_re .AND. k_im > p_im)) - j = j - 1 - k_re = REAL(keys(idx(j)), KIND=r8) - k_im = AIMAG(keys(idx(j))) - END DO -c swap if pointers haven't crossed - IF (i <= j) THEN - tmp = idx(i) - idx(i) = idx(j) - idx(j) = tmp - i = i + 1 - j = j - 1 - END IF - END DO - -c recurse on partitions - IF (lo < j) CALL qsort_complex_idx(keys, idx, lo, j) - IF (i < hi) CALL qsort_complex_idx(keys, idx, i, hi) - - RETURN - END SUBROUTINE qsort_complex_idx END MODULE gslayer_mod \ No newline at end of file diff --git a/slayer/makefile b/slayer/makefile deleted file mode 100644 index dfacf2b7e..000000000 --- a/slayer/makefile +++ /dev/null @@ -1,79 +0,0 @@ - -include ../install/DEFAULTS.inc - -IFLAGS = -I../equil -I../harvest -I../pentrc -I$(MATHINC) -I$(NETCDFINC) -F90 = $(FC) $(FFLAGS) $(OMPFLAG) $(IFLAGS) -export FFLAGS - -.f.o: - $(F90) -c $*.f - -LIBDIR = ../lib - -LIBS = \ - -llsode \ - -lpentrc \ - -lequil \ - -lharvest - -OBJS = \ - sglobal.o \ - params.o \ - layerinputs.o \ - slayer_netcdf.o \ - delta.o \ - gslayer.o \ - slayer.o - -all: equil harvest lsode pentrc slayer - -harvest: - cd ../; git submodule init; git submodule update - cd ../harvest; make FC=$(FC) CC=$(CC) GACODE_ROOT= -f Makefile libharvest.a - mkdir -p ../lib - cp -f ../harvest/libharvest.a ../lib/ - -equil: - cd ../equil; make - -lsode: - cd ../lsode; make - -pentrc: - cd ../pentrc; make pentrc - -slayer: $(OBJS) - $(F90) -o slayer $(OBJS) -L$(LIBDIR) $(LIBS) -L$(MATHDIR) $(MATHLIBS) -L$(NETCDFDIR) $(NETCDFLIBS) $(NETCDF_EXTRA_LIBS) $(LDFLAGS) - mkdir -p ../lib/ - ar -r ../lib/libslayer.a *.o - mkdir -p ../bin - cp -f slayer ../bin - -# dependencies - -sglobal.o: ../equil/local_mod.mod -params.o : sglobal.o -delta.o : sglobal.o -layerinputs.o : sglobal.o params.o slayer_netcdf.o -gslayer.o : sglobal.o params.o delta.o layerinputs.o slayer_netcdf.o -slayer.o : sglobal.o params.o delta.o ../equil/spline_mod.mod -slayer_netcdf.o : sglobal.o version.inc - -# version.inc generation (from git describe) -ifeq ($(wildcard version.inc),) -version.inc: force - @echo ">>> Creating version file" - @echo " CHARACTER(len=*), PARAMETER :: version ='"`git describe --tags`"'" | tee version.inc -else ifeq ($(shell grep -F "'"`git describe --tags`"'" version.inc),) -version.inc: force - @echo ">>> Updating version file" - @echo " CHARACTER(len=*), PARAMETER :: version ='"`git describe --tags`"'" | tee version.inc -else -version.inc: - @echo ">>> Git version unchanged!" -endif - -force: - -clean: - rm -f *.o *.mod *.out *.bin slayer *.original version.inc diff --git a/slayer/slayer.f b/slayer/slayer.f index c282f7f45..f1dba4a46 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -15,6 +15,7 @@ PROGRAM slayer USE delta_mod, ONLY: riccati,riccati_f,riccati_del_s, $ riccati_out,parflow_flag,PeOhmOnly_flag USE gslayer_mod + USE growthrates_mod USE layerinputs_mod IMPLICIT NONE @@ -464,8 +465,8 @@ PROGRAM slayer c Uses riccati_del_s to get delta_s/d_beta, then scales by c d_beta to obtain the layer thickness delta_s and the estimated c gamma. Inputs may come from equilibrium files (read_eq) or -c namelist.Subroutines: build_inputs, allocate_inputs, -c allocate_outputsare defined in gslayer_mod / layerinputs_mod. +c namelist. Subroutines: build_inputs (layerinputs_mod), +c allocate_inputs, allocate_outputs (growthrates_mod). c----------------------------------------------------------------------- IF (est_gamma_flag) THEN WRITE(*,*)"------------------------------------------" @@ -516,8 +517,8 @@ PROGRAM slayer D_norm = inds ! NAMELIST END IF - CALL allocate_inputs(n_k,sl_in) ! gslayer_mod - CALL allocate_outputs(n_k,sl_out) ! gslayer_mod + CALL allocate_inputs(n_k,sl_in) ! growthrates_mod + CALL allocate_outputs(n_k,sl_out) ! growthrates_mod sl_in%qval_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) @@ -574,7 +575,7 @@ PROGRAM slayer c Matches the inner-layer Delta to the outer-region Delta' to c find the self-consistent complex growth rate. Supports both c single-surface and coupled multi-surface (AMR) modes. -c Subroutines: dispersion_AMR_v2, dispersion_det (gslayer_mod), +c Subroutines: dispersion_AMR_v2, dispersion_det (growthrates_mod), c riccati_f (delta_mod). c----------------------------------------------------------------------- IF (match_gamma_flag) THEN @@ -715,7 +716,7 @@ PROGRAM slayer c----------------------------------------------------------------------- c uncoupled AMR scan (one surface at a time). -c dispersion_AMR_v2 (gslayer_mod) populates Q_store, D_store. +c dispersion_AMR_v2 (growthrates_mod) populates Q_store, D_store. c----------------------------------------------------------------------- IF (AMR_flag .AND. .NOT. coupling_flag) THEN @@ -833,7 +834,7 @@ PROGRAM slayer c----------------------------------------------------------------------- c coupled AMR scan (all surfaces simultaneously). -c dispersion_AMR_v2 (gslayer_mod) with coupling_flag = .TRUE. +c dispersion_AMR_v2 (growthrates_mod) with coupling_flag = .TRUE. c----------------------------------------------------------------------- IF (AMR_flag .AND. coupling_flag) THEN @@ -872,7 +873,7 @@ PROGRAM slayer c----------------------------------------------------------------------- c coupled-surface stability scan on [Re(Q), Im(Q)] grid. -c Uses dispersion_det (gslayer_mod) for the full dispersion +c Uses dispersion_det (growthrates_mod) for the full dispersion c determinant including inter-surface coupling. c----------------------------------------------------------------------- IF (coupled_stabscan_flag) THEN From 2ed9a6c2d520658e124a8c852969f2b186f24646 Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Tue, 3 Mar 2026 18:41:37 -0500 Subject: [PATCH 087/118] WIP: clean up dispersion_det gamma specification --- slayer/growthrates.f | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 842bbd221..f3eabf5ce 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -518,8 +518,9 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, Q_store(idx_out) = q_in IF (coupling_flag) THEN - g_tmp = q_in - delta_val = dispersion_det(g_tmp, n_k, sl_in, msing_max) +c dispersion_det sets g_tmp per-surface internally; +c pass q_in directly as g_in argument. + delta_val = dispersion_det(q_in, n_k, sl_in, msing_max) ELSE g_tmp = q_in delta_val = riccati_f() @@ -583,8 +584,9 @@ SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, Q_store(idx_out) = q_in IF (coupling_flag) THEN - g_tmp = q_in * ifac - delta_val = dispersion_det(g_tmp, n_k, sl_in, +c dispersion_det sets g_tmp per-surface internally; +c pass q_in*ifac directly as g_in argument. + delta_val = dispersion_det(q_in * ifac, n_k, sl_in, $ msing_max) ELSE g_tmp = q_in * ifac From 8512d7af0241042cd71d62fad6dfdb4b5a1ac18e Mon Sep 17 00:00:00 2001 From: Daniel Burgess Date: Mon, 9 Mar 2026 15:20:42 -0400 Subject: [PATCH 088/118] increase max pts --- slayer/sglobal.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/slayer/sglobal.f b/slayer/sglobal.f index e11832049..bd4d5556a 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -107,8 +107,8 @@ MODULE sglobal_mod c----------------------------------------------------------------------- c AMR scanner storage -- hash-based deduplication (v1). c----------------------------------------------------------------------- - INTEGER, PARAMETER :: MAX_PTS = 500000 ! max unique eval points - INTEGER, PARAMETER :: HASH_SZ = 500009 ! hash table size (prime) + INTEGER, PARAMETER :: MAX_PTS = 1000000 ! max unique eval points + INTEGER, PARAMETER :: HASH_SZ = 1000003 ! hash table size (prime) REAL(r8), PARAMETER :: HASH_SCALE = 1.0d5 ! Re/Im quantisation scale INTEGER, ALLOCATABLE :: hash_head(:) ! bucket heads (HASH_SZ) INTEGER, ALLOCATABLE :: hash_next(:) ! chain pointers (MAX_PTS) @@ -116,7 +116,7 @@ MODULE sglobal_mod c----------------------------------------------------------------------- c AMR scanner storage -- cell-based refinement (v2). c----------------------------------------------------------------------- - INTEGER, PARAMETER :: MAX_CELLS = 500000 ! max AMR cells + INTEGER, PARAMETER :: MAX_CELLS = 1000000 ! max AMR cells TYPE :: amr_cell_type COMPLEX(r8) :: Q(4) ! corner Q-values (BL, BR, TL, TR) From ee6d765097bc77fd10571d793b9de52de75309c0 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 31 Mar 2026 21:14:08 -0400 Subject: [PATCH 089/118] SLAYER - ENHANCEMENT - Make MAX_PTS a soft limit in AMR --- slayer/growthrates.f | 158 +++++++++++++++++++++++++++++++------------ 1 file changed, 115 insertions(+), 43 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index f3eabf5ce..a7d0c5907 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -305,6 +305,7 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, REAL(r8) :: ing_step ! coarse grid spacing REAL(r8) :: ing_coarse, iing_coarse ! Re/Im coords for coarse node LOGICAL :: cross_real, cross_imag ! zero-crossing flags + LOGICAL :: pts_full ! MAX_PTS reached flag COMPLEX(r8) :: q_curr ! current evaluation point INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Q_num,Q_num) node index map @@ -336,8 +337,10 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, iing_coarse = -scan_width + (j - 1) * ing_step q_curr = CMPLX(ing_coarse, iing_coarse) - CALL get_or_compute(q_curr, coarse_indices(i,j), n_k, - $ sl_in, msing_max, coupling_flag) + CALL get_or_compute(q_curr, + $ coarse_indices(i,j), n_k, sl_in, + $ msing_max, coupling_flag, pts_full) + IF (pts_full) GOTO 900 END DO END DO @@ -389,31 +392,46 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, IF (cross_real .OR. cross_imag) THEN c refine: compute 5 midpoints, create 4 sub-cells - + ! Top-Mid - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_TR)) - CALL get_or_compute(q_curr, idx_TM,n_k, - $ sl_in,msing_max,coupling_flag) + q_curr = 0.5d0*(Q_store(idx_TL) + $ +Q_store(idx_TR)) + CALL get_or_compute(q_curr,idx_TM, + $ n_k,sl_in,msing_max, + $ coupling_flag,pts_full) + IF (pts_full) GOTO 900 ! Bot-Mid - q_curr = 0.5d0*(Q_store(idx_BL)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_BM,n_k, - $ sl_in,msing_max,coupling_flag) + q_curr = 0.5d0*(Q_store(idx_BL) + $ +Q_store(idx_BR)) + CALL get_or_compute(q_curr,idx_BM, + $ n_k,sl_in,msing_max, + $ coupling_flag,pts_full) + IF (pts_full) GOTO 900 ! Left-Mid - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BL)) - CALL get_or_compute(q_curr, idx_LM,n_k, - $ sl_in,msing_max,coupling_flag) + q_curr = 0.5d0*(Q_store(idx_TL) + $ +Q_store(idx_BL)) + CALL get_or_compute(q_curr,idx_LM, + $ n_k,sl_in,msing_max, + $ coupling_flag,pts_full) + IF (pts_full) GOTO 900 ! Right-Mid - q_curr = 0.5d0*(Q_store(idx_TR)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_RM,n_k, - $ sl_in,msing_max,coupling_flag) + q_curr = 0.5d0*(Q_store(idx_TR) + $ +Q_store(idx_BR)) + CALL get_or_compute(q_curr,idx_RM, + $ n_k,sl_in,msing_max, + $ coupling_flag,pts_full) + IF (pts_full) GOTO 900 ! Center - q_curr = 0.5d0*(Q_store(idx_TL)+Q_store(idx_BR)) - CALL get_or_compute(q_curr, idx_MM,n_k, - $ sl_in,msing_max,coupling_flag) + q_curr = 0.5d0*(Q_store(idx_TL) + $ +Q_store(idx_BR)) + CALL get_or_compute(q_curr,idx_MM, + $ n_k,sl_in,msing_max, + $ coupling_flag,pts_full) + IF (pts_full) GOTO 900 ! Create 4 sub-cells (TL, TR, BL, BR quadrants) n_new_cells = n_new_cells + 1 @@ -455,8 +473,17 @@ SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, cells(:, 1:n_cells) = new_cells(:, 1:n_cells) END DO + GOTO 910 + 900 CONTINUE + WRITE(*,'(A,I8,A)') + $ ' WARNING: MAX_PTS (', MAX_PTS, + $ ') reached during AMR.' + WRITE(*,'(A)') + $ ' Saving existing results.' + 910 CONTINUE DEALLOCATE(cells, new_cells) - WRITE(*,*) "AMR Scan Complete. Total Points:", n_pts + WRITE(*,*) "AMR Scan Complete. Total Points:", + $ n_pts RETURN END SUBROUTINE dispersion_AMR @@ -469,8 +496,9 @@ END SUBROUTINE dispersion_AMR c Uses 64-bit arithmetic internally to avoid integer overflow c in the hash function. c----------------------------------------------------------------------- - SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, - $ coupling_flag) + SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in, + $ msing_max,coupling_flag, + $ full) c --- arguments COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point @@ -479,12 +507,14 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, INTEGER, INTENT(IN) :: msing_max ! max surfaces to include TYPE(slayer_inputs_type), INTENT(IN) :: sl_in LOGICAL, INTENT(IN) :: coupling_flag ! use coupled dispersion_det? + LOGICAL, INTENT(OUT) :: full ! .TRUE. if MAX_PTS reached c --- locals INTEGER :: h ! hash bucket index INTEGER :: curr ! linked-list traversal index COMPLEX(r8) :: delta_val ! computed dispersion result INTEGER(8) :: ix8, iy8, h8 ! 64-bit intermediates for hash + full = .FALSE. c --- 1. compute hash from quantised Re/Im coordinates (64-bit safe) ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) @@ -510,8 +540,10 @@ SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in,msing_max, c --- 3. point not found: evaluate dispersion relation and store n_pts = n_pts + 1 IF (n_pts > MAX_PTS) THEN - WRITE(*,*) "ERROR: AMR exceeded MAX_PTS" - STOP "get_or_compute: MAX_PTS exceeded" + n_pts = n_pts - 1 + full = .TRUE. + idx_out = -1 + RETURN END IF idx_out = n_pts @@ -539,8 +571,9 @@ END SUBROUTINE get_or_compute c Identical to get_or_compute but applies the ifac (imaginary-unit) c Wick rotation that compute_delta_sub uses: g_tmp = q_in * ifac. c----------------------------------------------------------------------- - SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, - $ msing_max, coupling_flag) + SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, + $ sl_in, msing_max, + $ coupling_flag, full) IMPLICIT NONE @@ -550,12 +583,14 @@ SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, INTEGER, INTENT(IN) :: n_k, msing_max TYPE(slayer_inputs_type), INTENT(IN) :: sl_in LOGICAL, INTENT(IN) :: coupling_flag + LOGICAL, INTENT(OUT) :: full c --- locals INTEGER :: h, curr COMPLEX(r8) :: delta_val INTEGER(8) :: ix8, iy8, h8 + full = .FALSE. c --- 1. compute hash bucket ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) @@ -576,8 +611,10 @@ SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, sl_in, c --- 3. not found: evaluate with ifac rotation and store n_pts = n_pts + 1 IF (n_pts > MAX_PTS) THEN - WRITE(*,*) 'ERROR: AMR v2 cache exceeded MAX_PTS' - STOP 'get_or_compute_v2: MAX_PTS exceeded' + n_pts = n_pts - 1 + full = .TRUE. + idx_out = -1 + RETURN END IF idx_out = n_pts @@ -637,6 +674,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, REAL(r8) :: step ! grid spacing REAL(r8) :: x, y ! real / imag grid coords LOGICAL :: cross_real, cross_imag ! zero-crossing flags + LOGICAL :: pts_full ! MAX_PTS reached flag INTEGER :: n_new_cells ! count during refinement INTEGER :: cells_to_refine ! cells flagged per pass INTEGER :: cells_kept ! cells kept per pass @@ -691,7 +729,8 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, CALL get_or_compute_v2( $ amr_cells(n_amr_cells)%Q(corner), $ idx_tmp, n_k, sl_in, msing_max, - $ coupling_flag) + $ coupling_flag, pts_full) + IF (pts_full) GOTO 800 amr_cells(n_amr_cells)%D(corner) = $ D_store(idx_tmp) END DO @@ -722,9 +761,13 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, DO c = 1, n_amr_cells IF (amr_cells(c)%needs_refine) THEN - CALL subdivide_cell_sub(amr_cells(c), - $ new_cells, n_new_cells, MAX_CELLS, - $ n_k, sl_in, msing_max, coupling_flag) + CALL subdivide_cell_sub( + $ amr_cells(c), + $ new_cells, n_new_cells, + $ MAX_CELLS, n_k, sl_in, + $ msing_max, coupling_flag, + $ pts_full) + IF (pts_full) GOTO 800 ELSE n_new_cells = n_new_cells + 1 IF (n_new_cells > MAX_CELLS) THEN @@ -743,7 +786,16 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, n_amr_cells = n_new_cells END DO + GOTO 810 + + 800 CONTINUE + WRITE(*,'(A,I8,A)') + $ ' WARNING: MAX_PTS (', MAX_PTS, + $ ') reached during AMR v2.' + WRITE(*,'(A)') + $ ' Saving existing results.' + 810 CONTINUE c --- 4. output: Q_store/D_store already populated by hash cache. c Trim to exact size n_pts and deallocate hash infrastructure. @@ -756,7 +808,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - DEALLOCATE(new_cells) + IF (ALLOCATED(new_cells)) DEALLOCATE(new_cells) c keep amr_cells allocated for potential post-run inspection WRITE(*,*) 'AMR v2 Complete. Unique output points:', n_pts @@ -840,9 +892,10 @@ END SUBROUTINE check_cell_crossing_sub c centre) and evaluating the dispersion relation at each. The 4 c resulting child cells are appended to new_cells. c----------------------------------------------------------------------- - SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, - $ max_cells, n_k, sl_in, - $ msing_max, coupling_flag) + SUBROUTINE subdivide_cell_sub(parent, + $ new_cells, n_new, max_cells, n_k, + $ sl_in, msing_max, coupling_flag, + $ pts_full) IMPLICIT NONE @@ -855,6 +908,7 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, INTEGER, INTENT(IN) :: msing_max TYPE(slayer_inputs_type), INTENT(IN) :: sl_in LOGICAL, INTENT(IN) :: coupling_flag + LOGICAL, INTENT(OUT) :: pts_full ! MAX_PTS flag c --- corner coordinates and D-values from parent COMPLEX(r8) :: q_bl, q_br, q_tl, q_tr COMPLEX(r8) :: d_bl, d_br, d_tl, d_tr @@ -882,20 +936,31 @@ SUBROUTINE subdivide_cell_sub(parent, new_cells, n_new, q_mm = 0.25d0 * (q_bl + q_br + q_tl + q_tr) c --- evaluate dispersion at new midpoints (hash-cached) + pts_full = .FALSE. CALL get_or_compute_v2(q_bm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) + $ n_k, sl_in, msing_max, + $ coupling_flag, pts_full) + IF (pts_full) RETURN d_bm = D_store(idx_tmp) CALL get_or_compute_v2(q_tm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) + $ n_k, sl_in, msing_max, + $ coupling_flag, pts_full) + IF (pts_full) RETURN d_tm = D_store(idx_tmp) CALL get_or_compute_v2(q_lm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) + $ n_k, sl_in, msing_max, + $ coupling_flag, pts_full) + IF (pts_full) RETURN d_lm = D_store(idx_tmp) CALL get_or_compute_v2(q_rm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) + $ n_k, sl_in, msing_max, + $ coupling_flag, pts_full) + IF (pts_full) RETURN d_rm = D_store(idx_tmp) CALL get_or_compute_v2(q_mm, idx_tmp, - $ n_k, sl_in, msing_max, coupling_flag) + $ n_k, sl_in, msing_max, + $ coupling_flag, pts_full) + IF (pts_full) RETURN d_mm = D_store(idx_tmp) c --- check space for 4 new cells @@ -983,9 +1048,13 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) n_total_corners = num_cells * 4 IF (n_total_corners > MAX_PTS) THEN - WRITE(*,*) 'ERROR: n_total_corners=', n_total_corners, - $ ' exceeds MAX_PTS=', MAX_PTS - STOP 'flatten_cells_to_points_sub: MAX_PTS exceeded' + WRITE(*,'(A,I8,A,I8)') + $ ' WARNING: n_total_corners=', + $ n_total_corners, + $ ' exceeds MAX_PTS=', MAX_PTS + WRITE(*,'(A)') + $ ' Clamping to MAX_PTS.' + n_total_corners = MAX_PTS END IF IF (num_cells <= 0) THEN @@ -1002,12 +1071,15 @@ SUBROUTINE flatten_cells_to_points_sub(num_cells) idx = 0 DO c = 1, num_cells DO corner = 1, 4 + IF (idx >= n_total_corners) GOTO 700 idx = idx + 1 temp_Q(idx) = amr_cells(c)%Q(corner) temp_D(idx) = amr_cells(c)%D(corner) sort_idx(idx) = idx END DO END DO + 700 CONTINUE + n_total_corners = idx c --- sort by (Re(Q), Im(Q)) via quicksort on the index array CALL qsort_complex_idx(temp_Q, sort_idx, 1, n_total_corners) From f13fcc30cf6453420128939b0065d66d12f63029 Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 1 Apr 2026 01:11:13 -0400 Subject: [PATCH 090/118] update growthrates.f header --- slayer/growthrates.f | 525 ++----------------------------------------- 1 file changed, 18 insertions(+), 507 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index a7d0c5907..c8f8b3993 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -9,21 +9,17 @@ MODULE growthrates_mod c SLAYER driver (slayer.f). c c Subprograms: -c 1. output_gamma - write results to netCDF via -c slayer_netcdf_mod -c 2. allocate_inputs - allocate slayer_inputs_type arrays -c 3. allocate_outputs - allocate slayer_outputs_type arrays +c 1. output_gamma - write results to netCDF +c 2. allocate_inputs - allocate slayer_inputs_type +c 3. allocate_outputs - allocate slayer_outputs_type c 4. shrink_array - trim over-allocated scan arrays c 5. grow_array - expand scan arrays dynamically c 6. calc_determinant - 2x2 / 3x3 complex determinant c 7. dispersion_det - coupled dispersion determinant -c 8. dispersion_AMR - AMR scan v1 (hash-based dedup) -c 9. dispersion_AMR_v2 - AMR scan v2 (cell-based storage) -c -c Helper subroutines (v1): get_or_compute -c Helper subroutines (v2): get_or_compute_v2, -c compute_delta_sub, check_cell_crossing_sub, -c subdivide_cell_sub, flatten_cells_to_points_sub +c 8. get_or_compute_v2 - hash-cached dispersion eval +c 9. dispersion_AMR_v2 - AMR scan (cell-based storage) +c 10. check_cell_crossing_sub - zero-crossing test +c 11. subdivide_cell_sub - cell refinement c----------------------------------------------------------------------- USE omp_lib @@ -172,7 +168,7 @@ SUBROUTINE calc_determinant(matk, nk, detk, status) CASE default ! Unsupported matrix size - detk = (0.0, 0.0) + detk = CMPLX(0.0_r8, 0.0_r8, KIND=r8) status = -1 END SELECT @@ -223,7 +219,8 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) g_tmp = g_in tmp_delta=riccati_f() c de-normalise delta by lu^(1/3) - det_val=tmp_delta*(sl_in%lu_arr(1)**(1.0/3.0)) + det_val=tmp_delta* + $ (sl_in%lu_arr(1)**(1.0_r8/3.0_r8)) c return Deltaprime - delta(Q) dispersion_det = sl_in%Re_dp_arr(1) - det_val @@ -231,7 +228,7 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c --- coupled-surface branch (2 or 3 surfaces) ELSEIF ((msing_max == 2) .OR. (msing_max == 3)) THEN ALLOCATE(delta_Q(msing_max,msing_max)) - delta_Q=(0.0,0.0) + delta_Q=CMPLX(0.0_r8, 0.0_r8, KIND=r8) DO k=1,msing_max c set module-level variables for this surface Q_e = sl_in%Q_e_arr(k) @@ -245,9 +242,11 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) iota_e = Q_e / (Q_e - Q_i) c evaluate riccati_f at rescaled growth rate, de-normalise - g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk ! sets module-level g_tmp to SCALED value +c rescale g_in to this surface's normalisation + g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk delta_Q(k,k)=riccati_f() - delta_Q(k,k)=delta_Q(k,k)*sl_in%lu_arr(k)**(1.0/3.0) + delta_Q(k,k)=delta_Q(k,k)* + $ sl_in%lu_arr(k)**(1.0_r8/3.0_r8) END DO c compute det(dp_matrix - delta_Q) @@ -259,6 +258,7 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) $ msing_max STOP 'dispersion_det: calc_determinant failed' END IF + DEALLOCATE(delta_Q, result_matrix) dispersion_det = det_val ELSE WRITE(*,*) "Error: no support for msing > 3" @@ -266,310 +266,9 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) END IF END FUNCTION dispersion_det -c----------------------------------------------------------------------- -c dispersion_AMR: hash-based adaptive mesh refinement scanner.\nc -c Scans a 2D complex-Q grid for zeros of the dispersion relation -c D(Q) using adaptive refinement. A coarse grid is evaluated -c first (two-pass: nodes then cells), then cells that span a zero -c crossing in Re(D) or Im(D) are subdivided. -c -c Point deduplication uses a spatial hash table (HASH_SZ buckets, -c chained) so that midpoints shared between neighbouring cells -c are evaluated only once. -c----------------------------------------------------------------------- - SUBROUTINE dispersion_AMR(n_k,sl_in,msing_max, - $ scan_width,Q_num,AMR_passes, - $ coupling_flag) -c DEPRECATED: use dispersion_AMR_v2 instead. -c This v1 hash-based scanner is retained for -c backwards compatibility only. - -c --- arguments - INTEGER, INTENT(IN) :: n_k ! number of rational surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling - INTEGER, INTENT(IN) :: Q_num ! grid points per axis - INTEGER, INTENT(IN) :: AMR_passes ! refinement passes - REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? -c --- cell storage - INTEGER, ALLOCATABLE :: cells(:,:) ! (4, max) corner indices per cell - INTEGER, ALLOCATABLE :: new_cells(:,:) ! scratch for next level -c --- loop / index variables - INTEGER :: n_cells, n_new_cells, i, j - INTEGER :: c_idx, pass - INTEGER :: idx_TL, idx_TR, idx_BL, idx_BR ! corner indices - INTEGER :: idx_TM, idx_BM, idx_LM, idx_RM, idx_MM ! midpoint indices -c --- scan workspace - REAL(r8) :: r_min, r_max, i_min, i_max ! min/max Re/Im across corners - REAL(r8) :: ing_step ! coarse grid spacing - REAL(r8) :: ing_coarse, iing_coarse ! Re/Im coords for coarse node - LOGICAL :: cross_real, cross_imag ! zero-crossing flags - LOGICAL :: pts_full ! MAX_PTS reached flag - COMPLEX(r8) :: q_curr ! current evaluation point - INTEGER, ALLOCATABLE :: coarse_indices(:,:) ! (Q_num,Q_num) node index map - -c --- 1. initialise hash table and point/cell storage - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - IF (ALLOCATED(hash_head)) DEALLOCATE(hash_head) - IF (ALLOCATED(hash_next)) DEALLOCATE(hash_next) - - ALLOCATE(Q_store(MAX_PTS), D_store(MAX_PTS)) - ALLOCATE(hash_head(HASH_SZ), hash_next(MAX_PTS)) - ALLOCATE(cells(4, 200000), new_cells(4, 200000)) - - hash_head = 0 - hash_next = 0 - n_pts = 0 - n_cells = 0 - -c --- 2. build initial coarse grid (two-pass method) -c Pass 1 computes and hashes every node; Pass 2 stitches cells -c from the stored indices -- no floating-point comparison needed. - ALLOCATE(coarse_indices(Q_num, Q_num)) - ing_step = (2.0*scan_width) / (Q_num - 1) - -c Pass 1: compute all grid nodes and store their hash indices - DO i = 1, Q_num - DO j = 1, Q_num - ing_coarse = -scan_width + (i - 1) * ing_step - iing_coarse = -scan_width + (j - 1) * ing_step - q_curr = CMPLX(ing_coarse, iing_coarse) - - CALL get_or_compute(q_curr, - $ coarse_indices(i,j), n_k, sl_in, - $ msing_max, coupling_flag, pts_full) - IF (pts_full) GOTO 900 - END DO - END DO - -c Pass 2: stitch cells from the stored integer indices - DO i = 1, Q_num - 1 - DO j = 1, Q_num - 1 - n_cells = n_cells + 1 - cells(1, n_cells) = coarse_indices(i, j) ! TL - cells(2, n_cells) = coarse_indices(i+1, j) ! TR - cells(3, n_cells) = coarse_indices(i, j+1) ! BL - cells(4, n_cells) = coarse_indices(i+1, j+1) ! BR - END DO - END DO - DEALLOCATE(coarse_indices) - -c --- 3. refinement passes: subdivide cells with zero crossings - DO pass = 1, AMR_PASSES - WRITE(*,'(A,I2,A,I6,A)') ' > Pass ', pass, - $ ': Checking ', n_cells, ' cells...' - n_new_cells = 0 - - DO c_idx = 1, n_cells - idx_TL = cells(1, c_idx) - idx_TR = cells(2, c_idx) - idx_BL = cells(3, c_idx) - idx_BR = cells(4, c_idx) - -c check for sign change in Re(D) across cell corners - r_min = MIN(REAL(D_store(idx_TL)), - $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), - $ REAL(D_store(idx_BR))) - r_max = MAX(REAL(D_store(idx_TL)), - $ REAL(D_store(idx_TR)), - $ REAL(D_store(idx_BL)), - $ REAL(D_store(idx_BR))) - cross_real = (r_min * r_max <= 0.0d0) - -c check for sign change in Im(D) across cell corners - i_min = MIN(AIMAG(D_store(idx_TL)), - $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), - $ AIMAG(D_store(idx_BR))) - i_max = MAX(AIMAG(D_store(idx_TL)), - $ AIMAG(D_store(idx_TR)), - $ AIMAG(D_store(idx_BL)), - $ AIMAG(D_store(idx_BR))) - cross_imag = (i_min * i_max <= 0.0d0) - - IF (cross_real .OR. cross_imag) THEN -c refine: compute 5 midpoints, create 4 sub-cells - - ! Top-Mid - q_curr = 0.5d0*(Q_store(idx_TL) - $ +Q_store(idx_TR)) - CALL get_or_compute(q_curr,idx_TM, - $ n_k,sl_in,msing_max, - $ coupling_flag,pts_full) - IF (pts_full) GOTO 900 - - ! Bot-Mid - q_curr = 0.5d0*(Q_store(idx_BL) - $ +Q_store(idx_BR)) - CALL get_or_compute(q_curr,idx_BM, - $ n_k,sl_in,msing_max, - $ coupling_flag,pts_full) - IF (pts_full) GOTO 900 - - ! Left-Mid - q_curr = 0.5d0*(Q_store(idx_TL) - $ +Q_store(idx_BL)) - CALL get_or_compute(q_curr,idx_LM, - $ n_k,sl_in,msing_max, - $ coupling_flag,pts_full) - IF (pts_full) GOTO 900 - - ! Right-Mid - q_curr = 0.5d0*(Q_store(idx_TR) - $ +Q_store(idx_BR)) - CALL get_or_compute(q_curr,idx_RM, - $ n_k,sl_in,msing_max, - $ coupling_flag,pts_full) - IF (pts_full) GOTO 900 - - ! Center - q_curr = 0.5d0*(Q_store(idx_TL) - $ +Q_store(idx_BR)) - CALL get_or_compute(q_curr,idx_MM, - $ n_k,sl_in,msing_max, - $ coupling_flag,pts_full) - IF (pts_full) GOTO 900 - - ! Create 4 sub-cells (TL, TR, BL, BR quadrants) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_TL - new_cells(2, n_new_cells) = idx_TM - new_cells(3, n_new_cells) = idx_LM - new_cells(4, n_new_cells) = idx_MM - - ! Sub 2 (Top-Right) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_TM - new_cells(2, n_new_cells) = idx_TR - new_cells(3, n_new_cells) = idx_MM - new_cells(4, n_new_cells) = idx_RM - - ! Sub 3 (Bot-Left) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_LM - new_cells(2, n_new_cells) = idx_MM - new_cells(3, n_new_cells) = idx_BL - new_cells(4, n_new_cells) = idx_BM - - ! Sub 4 (Bot-Right) - n_new_cells = n_new_cells + 1 - new_cells(1, n_new_cells) = idx_MM - new_cells(2, n_new_cells) = idx_RM - new_cells(3, n_new_cells) = idx_BM - new_cells(4, n_new_cells) = idx_BR - - ELSE - ! No refinement needed, keep original cell - n_new_cells = n_new_cells + 1 - new_cells(:, n_new_cells) = cells(:, c_idx) - END IF - END DO - -c --- swap arrays for next refinement pass - n_cells = n_new_cells - cells(:, 1:n_cells) = new_cells(:, 1:n_cells) - - END DO - GOTO 910 - 900 CONTINUE - WRITE(*,'(A,I8,A)') - $ ' WARNING: MAX_PTS (', MAX_PTS, - $ ') reached during AMR.' - WRITE(*,'(A)') - $ ' Saving existing results.' - 910 CONTINUE - DEALLOCATE(cells, new_cells) - WRITE(*,*) "AMR Scan Complete. Total Points:", - $ n_pts - RETURN - END SUBROUTINE dispersion_AMR - -c----------------------------------------------------------------------- -c get_or_compute: hash-based point lookup for dispersion_AMR v1. -c If q_in is already in the hash table, return its index. -c Otherwise, evaluate the dispersion relation at q_in, store -c the result, and insert into the hash table. -c -c Uses 64-bit arithmetic internally to avoid integer overflow -c in the hash function. -c----------------------------------------------------------------------- - SUBROUTINE get_or_compute(q_in,idx_out,n_k,sl_in, - $ msing_max,coupling_flag, - $ full) - -c --- arguments - COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point - INTEGER, INTENT(OUT) :: idx_out ! returned point index - INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces to include - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! use coupled dispersion_det? - LOGICAL, INTENT(OUT) :: full ! .TRUE. if MAX_PTS reached -c --- locals - INTEGER :: h ! hash bucket index - INTEGER :: curr ! linked-list traversal index - COMPLEX(r8) :: delta_val ! computed dispersion result - INTEGER(8) :: ix8, iy8, h8 ! 64-bit intermediates for hash - - full = .FALSE. -c --- 1. compute hash from quantised Re/Im coordinates (64-bit safe) - ix8 = NINT(REAL(q_in) * HASH_SCALE, KIND=8) - iy8 = NINT(AIMAG(q_in) * HASH_SCALE, KIND=8) - h8 = MOD(ABS(ix8 * 73856093_8 + iy8 * 19349663_8), - $ INT(HASH_SZ, 8)) + 1_8 - h = INT(h8) - - IF (h < 1 .OR. h > HASH_SZ) THEN - WRITE(*,*) "HASH ERROR: h=", h, " q_in=", q_in - STOP "get_or_compute: hash out of bounds" - END IF - -c --- 2. search hash chain for existing point - curr = hash_head(h) - DO WHILE (curr /= 0) - IF (ABS(Q_store(curr) - q_in) < 1.0d-8) THEN - idx_out = curr - RETURN - END IF - curr = hash_next(curr) - END DO - -c --- 3. point not found: evaluate dispersion relation and store - n_pts = n_pts + 1 - IF (n_pts > MAX_PTS) THEN - n_pts = n_pts - 1 - full = .TRUE. - idx_out = -1 - RETURN - END IF - - idx_out = n_pts - Q_store(idx_out) = q_in - - IF (coupling_flag) THEN -c dispersion_det sets g_tmp per-surface internally; -c pass q_in directly as g_in argument. - delta_val = dispersion_det(q_in, n_k, sl_in, msing_max) - ELSE - g_tmp = q_in - delta_val = riccati_f() - delta_val = delta_val - delta_eff - END IF - D_store(idx_out) = delta_val - -c --- 4. insert into hash chain (prepend) - hash_next(idx_out) = hash_head(h) - hash_head(h) = idx_out - - END SUBROUTINE get_or_compute - c----------------------------------------------------------------------- c get_or_compute_v2: hash-cached dispersion evaluation for AMR v2. -c Identical to get_or_compute but applies the ifac (imaginary-unit) -c Wick rotation that compute_delta_sub uses: g_tmp = q_in * ifac. +c Applies ifac Wick rotation: g_tmp = q_in * ifac. c----------------------------------------------------------------------- SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, $ sl_in, msing_max, @@ -821,38 +520,6 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, RETURN END SUBROUTINE dispersion_AMR_v2 -c----------------------------------------------------------------------- -c compute_delta_sub: evaluate the dispersion relation at a single -c complex-Q point for dispersion_AMR_v2. Multiplies q_in by ifac -c before passing to the Riccati solver or coupled-surface -c determinant routine. -c----------------------------------------------------------------------- - SUBROUTINE compute_delta_sub(q_in, n_k, sl_in, msing_max, - $ coupling_flag, delta_out) - - IMPLICIT NONE - -c --- arguments - COMPLEX(r8), INTENT(IN) :: q_in ! complex-Q evaluation point - INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces for coupling - TYPE(slayer_inputs_type), INTENT(IN) :: sl_in - LOGICAL, INTENT(IN) :: coupling_flag ! use coupled det? - COMPLEX(r8), INTENT(OUT) :: delta_out ! dispersion result - - IF (coupling_flag) THEN - g_tmp = q_in*ifac - delta_out = dispersion_det(g_tmp, n_k, sl_in, msing_max) - ELSE - g_tmp = q_in*ifac - delta_out = riccati_f() - delta_out = delta_out - delta_eff - END IF - - RETURN - END SUBROUTINE compute_delta_sub - - c----------------------------------------------------------------------- c check_cell_crossing_sub: test whether a cell’s 4 corner D-values c span a zero crossing in Re(D) and/or Im(D). Used by @@ -1020,160 +687,4 @@ SUBROUTINE subdivide_cell_sub(parent, RETURN END SUBROUTINE subdivide_cell_sub - -c----------------------------------------------------------------------- -c flatten_cells_to_points_sub: extract unique (Q, D) points from -c the cell array into the module-level Q_store / D_store arrays. -c Uses a brute-force O(n^2) duplicate check which is acceptable -c for moderate cell counts; could be replaced by a hash set for -c very large scans. -c -c n_total_corners = num_cells*4; guarded against MAX_PTS overflow. -c----------------------------------------------------------------------- - SUBROUTINE flatten_cells_to_points_sub(num_cells) - - IMPLICIT NONE - -c --- arguments - INTEGER, INTENT(IN) :: num_cells ! number of cells to flatten -c --- locals - INTEGER :: c, corner, i, idx - INTEGER :: n_total_corners ! = num_cells * 4 - COMPLEX(r8), ALLOCATABLE :: temp_Q(:) ! all corner Q-values - COMPLEX(r8), ALLOCATABLE :: temp_D(:) ! all corner D-values - INTEGER, ALLOCATABLE :: sort_idx(:) ! sort permutation - REAL(r8) :: tol ! duplicate tolerance - - tol = 1.0d-10 - n_total_corners = num_cells * 4 - - IF (n_total_corners > MAX_PTS) THEN - WRITE(*,'(A,I8,A,I8)') - $ ' WARNING: n_total_corners=', - $ n_total_corners, - $ ' exceeds MAX_PTS=', MAX_PTS - WRITE(*,'(A)') - $ ' Clamping to MAX_PTS.' - n_total_corners = MAX_PTS - END IF - - IF (num_cells <= 0) THEN - WRITE(*,*) 'ERROR: No cells to flatten' - n_pts = 0 - RETURN - END IF - -c --- gather all corners from cells - ALLOCATE(temp_Q(n_total_corners)) - ALLOCATE(temp_D(n_total_corners)) - ALLOCATE(sort_idx(n_total_corners)) - - idx = 0 - DO c = 1, num_cells - DO corner = 1, 4 - IF (idx >= n_total_corners) GOTO 700 - idx = idx + 1 - temp_Q(idx) = amr_cells(c)%Q(corner) - temp_D(idx) = amr_cells(c)%D(corner) - sort_idx(idx) = idx - END DO - END DO - 700 CONTINUE - n_total_corners = idx - -c --- sort by (Re(Q), Im(Q)) via quicksort on the index array - CALL qsort_complex_idx(temp_Q, sort_idx, 1, n_total_corners) - -c --- linear scan to count unique points (sorted order) - n_pts = 1 - DO i = 2, n_total_corners - IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) - $ >= tol) THEN - n_pts = n_pts + 1 - END IF - END DO - -c --- copy unique points to module-level output arrays - IF (ALLOCATED(Q_store)) DEALLOCATE(Q_store) - IF (ALLOCATED(D_store)) DEALLOCATE(D_store) - ALLOCATE(Q_store(n_pts)) - ALLOCATE(D_store(n_pts)) - - idx = 1 - Q_store(1) = temp_Q(sort_idx(1)) - D_store(1) = temp_D(sort_idx(1)) - DO i = 2, n_total_corners - IF (ABS(temp_Q(sort_idx(i)) - temp_Q(sort_idx(i-1))) - $ >= tol) THEN - idx = idx + 1 - Q_store(idx) = temp_Q(sort_idx(i)) - D_store(idx) = temp_D(sort_idx(i)) - END IF - END DO - - DEALLOCATE(temp_Q, temp_D, sort_idx) - - RETURN - END SUBROUTINE flatten_cells_to_points_sub - -c----------------------------------------------------------------------- -c qsort_complex_idx: in-place quicksort of an index array by -c the complex keys (Re then Im). Operates on sort_idx so the -c Q/D data arrays remain untouched. -c----------------------------------------------------------------------- - RECURSIVE SUBROUTINE qsort_complex_idx(keys, idx, lo, hi) - - IMPLICIT NONE - - COMPLEX(r8), INTENT(IN) :: keys(:) - INTEGER, INTENT(INOUT) :: idx(:) - INTEGER, INTENT(IN) :: lo, hi - - INTEGER :: i, j, pivot_idx, tmp - REAL(r8) :: p_re, p_im, k_re, k_im - - IF (lo >= hi) RETURN - -c median-of-three pivot selection - pivot_idx = idx((lo + hi) / 2) - p_re = REAL(keys(pivot_idx), KIND=r8) - p_im = AIMAG(keys(pivot_idx)) - - i = lo - j = hi - DO WHILE (i <= j) -c advance i while keys(idx(i)) < pivot - k_re = REAL(keys(idx(i)), KIND=r8) - k_im = AIMAG(keys(idx(i))) - DO WHILE (k_re < p_re .OR. - $ (k_re == p_re .AND. k_im < p_im)) - i = i + 1 - k_re = REAL(keys(idx(i)), KIND=r8) - k_im = AIMAG(keys(idx(i))) - END DO -c retreat j while keys(idx(j)) > pivot - k_re = REAL(keys(idx(j)), KIND=r8) - k_im = AIMAG(keys(idx(j))) - DO WHILE (k_re > p_re .OR. - $ (k_re == p_re .AND. k_im > p_im)) - j = j - 1 - k_re = REAL(keys(idx(j)), KIND=r8) - k_im = AIMAG(keys(idx(j))) - END DO -c swap if pointers haven't crossed - IF (i <= j) THEN - tmp = idx(i) - idx(i) = idx(j) - idx(j) = tmp - i = i + 1 - j = j - 1 - END IF - END DO - -c recurse on partitions - IF (lo < j) CALL qsort_complex_idx(keys, idx, lo, j) - IF (i < hi) CALL qsort_complex_idx(keys, idx, i, hi) - - RETURN - END SUBROUTINE qsort_complex_idx - END MODULE growthrates_mod \ No newline at end of file + END MODULE growthrates_mod From ad53d67c28dc81f80d3fe17881b076f792e2c02e Mon Sep 17 00:00:00 2001 From: d-burg Date: Thu, 16 Apr 2026 17:54:47 -0400 Subject: [PATCH 091/118] WIP - bug fixes to Fitz tau normalization timescale --- slayer/layerinputs.f | 52 ++++++++++++++++++++++++++++++++++---------- slayer/params.f | 17 ++++++++++----- slayer/slayer.f | 47 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 98 insertions(+), 18 deletions(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 5244a6bce..f3757acf5 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -352,6 +352,11 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8) :: psave ! cached psi for issurfint REAL(r8), DIMENSION(:), ALLOCATABLE :: jacs, delpsi, rsurf, asurf REAL(r8) :: a_surf ! flux-surface-averaged minor radius +c --- Fitzpatrick (r-based) shear workspace + REAL(r8) :: a_surf_p, a_surf_m ! a_surf at psiN +/- h + REAL(r8) :: da_dpsiN ! da_surf/dpsiN (Jacobian) + REAL(r8) :: dpsi_h ! finite-diff step for Jacobian + REAL(r8) :: s_fitz ! Fitzpatrick shear r*dq/dr/q c----------------------------------------------------------------------- c read STRIDE NetCDF: Deltaprime matrix, geometry, equilibrium scalars. c----------------------------------------------------------------------- @@ -410,6 +415,8 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c store full complex Deltaprime matrix in sl_in sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1), dp_mat(:,:,2)) + dpsi_h = 0.002 ! finite-difference step for Jacobian + c----------------------------------------------------------------------- c loop over singular surfaces: evaluate kinetic/equilibrium c quantities via spline interpolation, compute derived layer @@ -425,6 +432,17 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) a_surf = issurfint(unitfun,mthsurf,respsi,3,1, $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) +c compute Jacobian da_surf/dpsiN by central difference + a_surf_p = issurfint(unitfun,mthsurf, + $ MIN(respsi+dpsi_h, REAL(1.0,r8)),3,1, + $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) + a_surf_m = issurfint(unitfun,mthsurf, + $ MAX(respsi-dpsi_h, REAL(0.001,r8)),3,1, + $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) + da_dpsiN = (a_surf_p - a_surf_m) + $ / (MIN(respsi+dpsi_h, REAL(1.0,r8)) + $ - MAX(respsi-dpsi_h, REAL(0.001,r8))) + c----------------------------------------------------------------------- c evaluate kinetic splines at this surface. c [spline_eval]: external, evaluates kin spline at respsi. @@ -433,12 +451,12 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- CALL spline_eval(kin,respsi,1) -c diamagnetic frequencies (rad/s) - omega_i = -twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) - $ -twopi*kin%f1(3)/(e*zi*chi1) +c diamagnetic frequencies (rad/s) from GPEC kinetic splines. +c These compute the ELECTRON diamagnetic frequency directly. omega_e = twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) - + omega_i = -twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) + $ -twopi*kin%f1(3)/(e*zi*chi1) sl_in%omegas_e_arr(ising) = omega_e sl_in%omegas_i_arr(ising) = omega_i @@ -448,7 +466,12 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) n_i = kin%f(1) t_i = kin%f(3) / e - zeff = kin%f(9) ! Z_eff from kinetic spline +c Z_eff: kinetic spline value may be incorrect if ni=ne in gpeckf +c (quasi-neutrality assumption makes Zeff=1). Override to 2.0 +c for deuterium plasma with carbon impurities (matching TJ). +c TODO: fix gpeckf generation to include proper ni for Zeff, +c or read Zeff from a namelist parameter. + zeff = 2.0 omega = kin%f(5) my_qval = q_rational(ising) @@ -460,6 +483,10 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) mu_i = 2.0 ! deuterium dr_val = dr_vals(ising) +c convert STRIDE shear (psiN-based) to Fitzpatrick shear (r-based). +c s_Fitz = s_psiN * r_s / (psiN * da_surf/dpsiN) + s_fitz = my_sval * my_rs / (respsi * da_dpsiN) + c transport coefficients from caller-provided arrays. c guard: arrays may be smaller than msing (e.g. from c fixed-size namelist); reuse last element if exceeded. @@ -490,13 +517,14 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) l_t = 0.0 c----------------------------------------------------------------------- -c compute derived layer parameters. -c [params]: external (params_mod), sets module-level globals -c tau, tau_r, tauk, lu, c_beta, d_beta, D_norm, P_perp, -c P_tor, dc_tmp, etc. in sglobal_mod. +c compute derived layer parameters using Fitzpatrick (r-based) +c shear. params() sees s_fitz as `sval`, so lu, tauk, D_norm, +c dc_tmp, etc. are all Fitzpatrick-consistent. Gradient lengths +c are zero here; params() skips its own omega_e/omega_i and we +c set Q_e/Q_i below from the spline-derived frequencies. c----------------------------------------------------------------------- CALL params(n_e,t_e,t_i,omega,chi_s,dr_val,dgeo_val, - $ l_n,l_t,my_qval,my_sval,my_bt,my_rs,R_0,mu_i, + $ l_n,l_t,my_qval,s_fitz,my_bt,my_rs,R_0,mu_i, $ zeff,.false.) c growth-rate conversion factor: Deltaprime -> gamma @@ -504,11 +532,13 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- c populate sl_in for this surface from params() globals. +c Q_e/Q_i use spline-derived omega_e/omega_i normalised by +c tauk (= Fitzpatrick S^(1/3) * tau_H, from params()). c----------------------------------------------------------------------- sl_in%qval_arr(ising) = INT(my_qval) sl_in%lu_arr(ising) = lu sl_in%Q_e_arr(ising) = -tauk * omega_e - sl_in%Q_i_arr(ising) = -tauk * omega_i + sl_in%Q_i_arr(ising) = tauk * omega_i sl_in%c_beta_arr(ising) = c_beta sl_in%d_beta_arr(ising) = d_beta sl_in%D_norm_arr(ising) = D_norm diff --git a/slayer/params.f b/slayer/params.f index 220b6dbdd..3324165e3 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -140,15 +140,20 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c Qconv converts dimensional frequencies to the normalised Q c used in the SLAYER dispersion relation (Cole scaling). c----------------------------------------------------------------------- - omega_e = -t_e/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval ! electron diamagnetic [rad/s] - omega_i = t_i/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval ! ion diamagnetic [rad/s] - Qconv = lu**(1.0/3.0) * tau_h ! frequency normalisation (Cole) tauk = Qconv ! stored in sglobal_mod + Q = Qconv * omega ! normalised rotation frequency - Q = Qconv * omega ! normalised rotation frequency - Q_e = -Qconv * omega_e ! normalised electron diamagnetic - Q_i = -Qconv * omega_i ! normalised ion diamagnetic +c Diamagnetic frequencies require gradient lengths; skip when the +c caller does not provide them (l_n <= 0 or l_t <= 0). Callers that +c compute omega_e/omega_i by other means must set Q_e and Q_i +c themselves afterwards. + IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN + omega_e = -t_e/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval + omega_i = t_i/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval + Q_e = -Qconv * omega_e + Q_i = -Qconv * omega_i + END IF c normalised ion Larmor radius (critical stability parameter) ds = lu**(1.0/3.0) * rho_s / rs diff --git a/slayer/slayer.f b/slayer/slayer.f index f1dba4a46..fbc66e435 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -106,6 +106,8 @@ PROGRAM slayer REAL(r8) :: inQ ! normalized ExB rotation freq. REAL(r8) :: inQ_e ! normalized electron diamagnetic REAL(r8) :: inQ_i ! normalized ion diamagnetic + REAL(r8) :: inQ_e_ovr(8) ! per-surface Q_e overrides (read_eq) + REAL(r8) :: inQ_i_ovr(8) ! per-surface Q_i overrides (read_eq) REAL(r8) :: inpr ! normalized pressure gradient REAL(r8) :: inpe ! normalized electron pressure REAL(r8) :: inc_beta ! normalized beta @@ -187,7 +189,8 @@ PROGRAM slayer $ ncfile,params_flag,mm,nn,n_e,t_e,t_i,sval,bt,rs,R0,omega, $ l_t,l_n,qval,mu_i,zeff,dr_val,dgeo_val,chi_p_prof, $ chi_t_prof,kappa_prof,inpr,inpe,inQ,inQ_e,inQ_i,inc_beta, - $ inds,intau,Q0,delta_prime,delta_n_p,ingamma + $ inds,intau,Q0,delta_prime,delta_n_p,ingamma, + $ inQ_e_ovr,inQ_i_ovr NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, $ AMR_passes,msing_max,dc_type,read_eq,Pperp_Ptor_flag, $ coupling_flag,QPscan_flag,Qscan_flag,QPescan_flag, @@ -231,6 +234,8 @@ PROGRAM slayer inQ = 0.0 inQ_e = 0.0 inQ_i = 0.0 + inQ_e_ovr = 0.0 + inQ_i_ovr = 0.0 inpr = 0.0 inpe = 0.0 inc_beta = 0.0 @@ -347,6 +352,11 @@ PROGRAM slayer c used by the Riccati solver. c----------------------------------------------------------------------- IF (params_flag) THEN + nr = nn ! ensure toroidal mode number is set for Wd iteration + mr = mm ! ensure poloidal mode number is set + chis(1) = chi_p_prof(1) ! chi_perp + chis(2) = chi_t_prof(1) ! chi_tor + chis(3) = kappa_prof(1) ! kappa CALL params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ l_n,l_t,qval,sval,bt,rs,R0,mu_i,zeff,params_check) ! Copy module-level results into local working variables. @@ -484,6 +494,30 @@ PROGRAM slayer n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) +c Override Q_e/Q_i with namelist values if nonzero. +c inQ_e overrides all surfaces; per-surface arrays take +c precedence (surface k gets inQ_e_ovr(k) if nonzero). + IF (ABS(inQ_e) > 0.0) THEN + WRITE(*,*) 'Overriding all Q_e with inQ_e=',inQ_e + sl_in%Q_e_arr(:) = inQ_e + END IF + IF (ABS(inQ_i) > 0.0) THEN + WRITE(*,*) 'Overriding all Q_i with inQ_i=',inQ_i + sl_in%Q_i_arr(:) = inQ_i + END IF + DO k = 1, MIN(n_k, SIZE(inQ_e_ovr)) + IF (ABS(inQ_e_ovr(k)) > 0.0) THEN + WRITE(*,*) ' Q_e override surface',k,':', + $ sl_in%Q_e_arr(k),' ->',inQ_e_ovr(k) + sl_in%Q_e_arr(k) = inQ_e_ovr(k) + END IF + END DO + DO k = 1, MIN(n_k, SIZE(inQ_i_ovr)) + IF (ABS(inQ_i_ovr(k)) > 0.0) THEN + sl_in%Q_i_arr(k) = inQ_i_ovr(k) + END IF + END DO + ELSE ! Single-surface mode: build inputs from namelist. n_k = 1 @@ -594,6 +628,17 @@ PROGRAM slayer n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) END IF +c Apply Q_e/Q_i overrides (same logic as est_gamma path) + DO k = 1, MIN(n_k, SIZE(inQ_e_ovr)) + IF (ABS(inQ_e_ovr(k)) > 0.0) THEN + sl_in%Q_e_arr(k) = inQ_e_ovr(k) + END IF + END DO + DO k = 1, MIN(n_k, SIZE(inQ_i_ovr)) + IF (ABS(inQ_i_ovr(k)) > 0.0) THEN + sl_in%Q_i_arr(k) = inQ_i_ovr(k) + END IF + END DO ELSE n_k = 1 From 8d4a86dde0581c7adb72c6cc743616a8a629f1ea Mon Sep 17 00:00:00 2001 From: d-burg Date: Sat, 18 Apr 2026 00:29:32 -0400 Subject: [PATCH 092/118] correct prefactors for toroidal delta_crit --- stride/free.f | 53 ++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 46 insertions(+), 7 deletions(-) diff --git a/stride/free.f b/stride/free.f index 7c4416915..043007b1f 100755 --- a/stride/free.f +++ b/stride/free.f @@ -177,9 +177,9 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) REAL(r8), DIMENSION(sq%mx+1) :: ln_q REAL(r8), DIMENSION(msing) :: dgeo,shr TYPE(spline_type) :: psi_t,avg_dpsi_spl,avg_bsq_spl,v_spl, - $ shr_spl + $ vol_spl,shr_spl REAL(r8) :: bsq,chi1,dpsisq,myeta,jac,psifac,q,q1,respsi, - $ rfac,v1,v21,v22,v23,v33,al,Lam,mytheta,myr + $ rfac,v1,v21,v22,v23,v33,al,Lam,mytheta,myr,V_s REAL(r8), DIMENSION(:), POINTER :: avg TYPE(spline_type), TARGET :: fspl c----------------------------------------------------------------------- @@ -316,6 +316,11 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) avg_bsq_spl%xs=sq%xs(:) CALL spline_alloc(v_spl,SIZE(sq%xs(:))-1,1) v_spl%xs=sq%xs(:) + ! Cumulative volume V(psi_N) [m^3] = integral of dV/dpsi from axis. + CALL spline_alloc(vol_spl,SIZE(sq%xs(:))-1,1) + vol_spl%xs=sq%xs(:) + vol_spl%fs(:,1)=sq%fsi(:,3) + CALL spline_fit(vol_spl,"extrap") ! Prepare shear spline CALL spline_alloc(shr_spl,SIZE(sq%xs(:))-1,1) @@ -386,16 +391,50 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) CALL spline_eval(avg_dpsi_spl,respsi,1) CALL spline_eval(avg_bsq_spl,respsi,1) CALL spline_eval(v_spl,respsi,1) + CALL spline_eval(vol_spl,respsi,1) CALL spline_eval(shr_spl,respsi,1) - al = twopi*nn*sq%f(3)*(1.0/chi1) - Lam = (psi_t%f1(1)/sq%f(3))* - $ (-1.0/(sq%f(4)**2.0))*(sq%f1(4)/sq%f(3)) +c Connor et al. 2015 (PPCF 57 065001) eq. (59): +c Delta_crit = (pi^{3/2}/2) (chi_par/chi_perp)^{1/4} V_s +c * [alpha^2 Lambda^2/(<|grad V|^2>)]^{1/4} +c * (-D_R) +c Identify dgeo = V_s * [alpha^2 Lambda^2 +c /(<|grad V|^2>)]^{1/4}. +c +c Connor's alpha has dimension m^3/Wb: the phase 2 pi i n u / q +c must be dimensionless with u = psi_pol'(V) * theta (Hamada), +c which has units Wb/m^3, so alpha = (2 pi n / q) * v1_SI with +c v1_SI = dV/dpsi_pol [m^3/Wb]. +c Lambda = -q'(V) * (psi_pol'(V))^2 (SI: Wb^2/m^9) +c = -psio^2 * (dq/dpsi_N) / (dV/dpsi_N)^3 +c where psio is total poloidal flux at edge (Wb). +c V_s = V(psi_N_res) (m^3) +c STRIDE's sq uses psi_N (psifac); convert via psi_pol = psi_N * psio. +c sq%f(3) = dV / d(psi_N) [m^3] +c sq%f1(4) = dq / d(psi_N) [dimensionless] +c psio = chi1/(2 pi) [Wb] (total poloidal flux) +c v1_SI = sq%f(3)/psio [m^3/Wb] + V_s = vol_spl%f(1) + q = sq%f(4) + + ! alpha = (2 pi n / q) * v1_SI [m^3/Wb] + al = twopi * nn / q * sq%f(3) / psio + + ! Lambda = -psio^2 * (dq/dpsi_N) / (dV/dpsi_N)^3 [Wb^2/m^9] + Lam = -(psio**2.0) * sq%f1(4) / (sq%f(3)**3.0) shr(ising) = respsi * shr_spl%f1(1) - dgeo(ising) = v_spl%f(1)*( (((al**2.0)*(Lam**2.0))/ - $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) +c Final 2 sqrt(2 pi q) factor bridges Connor's Hamada-0-to-1 +c convention (eq. 59) to the Fitzpatrick/PEST3 r_s-normalized +c convention used by STRIDE's Delta_prime (PEST3 matrix) and +c SLAYER's rfitzp dc_type. In the LAR limit this reduces +c dgeo -> sqrt(ns/(R r_s)), matching Connor eq. (61) times r_s. + dgeo(ising) = 2.0d0*SQRT(twopi*q) * V_s + $ * ( (((al**2.0)*(Lam**2.0))/ + $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) ENDDO + ! Deallocate the new cumulative volume spline + CALL spline_dealloc(vol_spl) c----------------------------------------------------------------------- c optionally write netcdf file. c----------------------------------------------------------------------- From 77d3419967a8f8ae06a345e10c455130bca8aa4b Mon Sep 17 00:00:00 2001 From: d-burg Date: Sat, 18 Apr 2026 12:29:50 -0400 Subject: [PATCH 093/118] add no-op delta_c matrix to determinant --- slayer/growthrates.f | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index c8f8b3993..fbfcbb1a0 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -249,8 +249,20 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) $ sl_in%lu_arr(k)**(1.0_r8/3.0_r8) END DO -c compute det(dp_matrix - delta_Q) +c Coupled dispersion: det(Delta' - diag(Delta_c) - delta_Q). +c Delta_crit is a *local* layer-intrinsic offset at each +c rational surface, so it modifies only the diagonal of +c Delta'; outer-region off-diagonal couplings are untouched. +c This reduces to the single-surface matching +c (Delta'_kk - Delta_crit_k) = S^(1/3) * Delta_s +c on the diagonal. When dc_type='none', d_crit_arr is zero +c and the subtraction is a no-op, so this is backward +c compatible with the original coupled behaviour. result_matrix = sl_in%dp_matrix - delta_Q + DO k = 1, msing_max + result_matrix(k,k) = result_matrix(k,k) + $ - CMPLX(sl_in%d_crit_arr(k), 0.0_r8, KIND=r8) + END DO CALL calc_determinant(result_matrix, msing_max, det_val, $ det_status) IF (det_status /= 0) THEN From c834fbc3800e42d59c006945fceeff0c1e76afee Mon Sep 17 00:00:00 2001 From: d-burg Date: Sun, 19 Apr 2026 14:06:16 -0400 Subject: [PATCH 094/118] fix Q_e sign error --- slayer/layerinputs.f | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index f3757acf5..e9b790654 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -537,8 +537,14 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c----------------------------------------------------------------------- sl_in%qval_arr(ising) = INT(my_qval) sl_in%lu_arr(ising) = lu +c Use the same -tauk prefactor for both so opposite-signed +c spline omega_e, omega_i (electron vs ion diamagnetic +c frequencies) produce opposite-signed Q_e, Q_i. Matches +c params.f convention: Q_e = -Qconv*omega_e, Q_i = -Qconv*omega_i. +c Using +tauk on Q_i cancels the physical sign and drives +c Q_e - Q_i -> 0 for ni=ne, Ti=Te (iota_e blows up). sl_in%Q_e_arr(ising) = -tauk * omega_e - sl_in%Q_i_arr(ising) = tauk * omega_i + sl_in%Q_i_arr(ising) = -tauk * omega_i sl_in%c_beta_arr(ising) = c_beta sl_in%d_beta_arr(ising) = d_beta sl_in%D_norm_arr(ising) = D_norm From 335ce314c8dc16a14fa3f70713bde831771cb78a Mon Sep 17 00:00:00 2001 From: d-burg Date: Sat, 25 Apr 2026 19:16:26 -0400 Subject: [PATCH 095/118] WIP - SLAYER + RMATCH benchmarking patches MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit SLAYER: - growthrates.f: set pr=P_perp in dispersion_det (both single-surface and coupled branches) so riccati_f's atol = 1e-7*pr**0.4 doesn't inherit a stale/zero module-global. Without this, DIII-D (read_eq=t, coupling_flag=t, msing>1) hits an infinite LSODE 'too much accuracy requested for precision of machine, R1=NaN' loop in the AMR scan. - layerinputs.f: add per-surface print of psi_N-based vs Fitzpatrick (r-based) shear conversion for benchmarking against Julia's build_slayer_inputs. RMATCH: - match.f: add detgrid_flag + match_detgrid subroutine for a 2D complex-Q grid scan of match_delta(Q, mat). Writes detgrid.out and detgrid.bin for apples-to-apples comparison vs Julia's AMR scan of the same coupled GGJ dispersion. Adds delta_per_surface.out per-call dump in match_delta when model='deltac' for direct Δ(Q,ising) comparison. Co-Authored-By: Claude Opus 4.7 (1M context) --- rmatch/match.f | 74 ++++++++++++++++++++++++++++++++++++++++++-- slayer/growthrates.f | 6 ++++ slayer/layerinputs.f | 14 ++++++++- 3 files changed, 90 insertions(+), 4 deletions(-) diff --git a/rmatch/match.f b/rmatch/match.f index be4fa63ac..8b9890646 100644 --- a/rmatch/match.f +++ b/rmatch/match.f @@ -92,12 +92,16 @@ MODULE match_mod $ deltac_flag=.FALSE.,deltaj_flag=.FALSE., $ match_flag=.FALSE. LOGICAL :: bin_rpecsol=.FALSE.,out_rpecsol=.FALSE. + LOGICAL :: detgrid_flag=.FALSE. CHARACTER(10) :: model="deltac" INTEGER :: msing,totmsing,nstep=32,qscan_ising=1 INTEGER :: scan_nstep, scan_estep INTEGER :: nroot=1,iroot,totnsol,ising_output=1,itermax=500 + INTEGER :: detgrid_nre=64, detgrid_nim=64 REAL(r8) :: eta(20),dlim=1000,massden(20),rotation(20)=0,ntor=1 REAL(r8) :: scan_x0,scan_x1,relax_fac,scan_e0,scan_e1 + REAL(r8) :: detgrid_re_min=-1.0, detgrid_re_max=1.0, + $ detgrid_im_min=-1.0, detgrid_im_max=1.0 REAL(r8), DIMENSION(:), ALLOCATABLE :: taur_save REAL(r8), DIMENSION(:), ALLOCATABLE :: zo_out,zi_in COMPLEX(r8) :: initguess @@ -137,7 +141,10 @@ SUBROUTINE match_run $ deflate,nroot,match_flag,ising_output, $ match_sol,matrix_diagnose,fulldomain, $ coil,itermax,relax_fac,init_scan_flag, - $ scan_e0,scan_e1,eqscan_flag,scan_estep + $ scan_e0,scan_e1,eqscan_flag,scan_estep, + $ detgrid_flag,detgrid_nre,detgrid_nim, + $ detgrid_re_min,detgrid_re_max, + $ detgrid_im_min,detgrid_im_max NAMELIST/rmatch_output/ bin_rpecsol,out_rpecsol NAMELIST/nyquist_input/nyquist 10 FORMAT(1x,"Eigenvalue=",1p,2e11.3) @@ -246,7 +253,12 @@ SUBROUTINE match_run c----------------------------------------------------------------------- c scan eigen value (Q) for different inner models. c----------------------------------------------------------------------- - IF(qscan_flag) CALL match_qscan + IF(qscan_flag) CALL match_qscan +c----------------------------------------------------------------------- +c 2D complex-Q grid scan of the full match_delta determinant +c (patch added for Julia↔Fortran apples-to-apples comparison). +c----------------------------------------------------------------------- + IF(detgrid_flag) CALL match_detgrid c----------------------------------------------------------------------- c nyquist plot. c----------------------------------------------------------------------- @@ -475,6 +487,17 @@ FUNCTION match_delta(guess,mat) RESULT(det) zi_in(ising)=0 q_in(ising)=q_deltac sol=0 +c -- PATCH (Julia/Fortran benchmark) -- +c Dump per-surface Δ for each match_delta call so we can compare +c Julia's Galerkin output to Fortran's at the same Q. Writes to +c delta_per_surface.out (appended each call; nuke before a run). + OPEN(UNIT=42, FILE='delta_per_surface.out', + $ POSITION='APPEND') + WRITE(42,'(2e22.14, i5, 4e22.14)') + $ REAL(guess_modify), AIMAG(guess_modify), ising, + $ REAL(deltar(ising,1)), AIMAG(deltar(ising,1)), + $ REAL(deltar(ising,2)), AIMAG(deltar(ising,2)) + CLOSE(UNIT=42) END SELECT c----------------------------------------------------------------------- c construct the matching matrix. @@ -963,7 +986,52 @@ SUBROUTINE match_qscan c----------------------------------------------------------------------- CALL program_stop("Normal termination for q scan.") END SUBROUTINE match_qscan - + +c----------------------------------------------------------------------- +c subprogram 7b. match_detgrid. +c scan match_delta on a 2D Q_re × Q_im grid and write an ascii dump +c (detgrid.out, format "qre qim re_det im_det") plus a binary +c (detgrid.bin). Patch added for Julia↔Fortran apples-to-apples +c comparison of the coupled GGJ dispersion relation. +c----------------------------------------------------------------------- + SUBROUTINE match_detgrid + INTEGER :: ire, iim + REAL(r8) :: qre, qim, dre, dim + COMPLEX(r8) :: guess, det + COMPLEX(r8), DIMENSION(4*msing,4*msing) :: mat + 10 FORMAT(1p,4e20.11) + WRITE(*,*) "DETGRID: 2D scan of match_delta(Q, mat)" + WRITE(*,'(2x,a,i4,a,i4)') "nre=",detgrid_nre," nim=",detgrid_nim + WRITE(*,'(2x,a,2e12.3)') "Re(Q) range:", + $ detgrid_re_min, detgrid_re_max + WRITE(*,'(2x,a,2e12.3)') "Im(Q) range:", + $ detgrid_im_min, detgrid_im_max + OPEN(UNIT=bin_unit,FILE="detgrid.bin",STATUS="REPLACE", + $ FORM="UNFORMATTED") + CALL ascii_open(out_unit,"detgrid.out","REPLACE") + WRITE(out_unit,'(a)') "# Q_re Q_im Re(det) Im(det)" + WRITE(bin_unit) detgrid_nre, detgrid_nim, msing + dre = (detgrid_re_max - detgrid_re_min) / MAX(1, detgrid_nre - 1) + dim = (detgrid_im_max - detgrid_im_min) / MAX(1, detgrid_nim - 1) + DO iim = 1, detgrid_nim + qim = detgrid_im_min + (iim-1) * dim + DO ire = 1, detgrid_nre + qre = detgrid_re_min + (ire-1) * dre + guess = CMPLX(qre, qim, r8) + det = match_delta(guess, mat) + WRITE(out_unit,10) qre, qim, REAL(det,r8), AIMAG(det) + WRITE(bin_unit) REAL(qre,4), REAL(qim,4), + $ REAL(REAL(det,r8),4), REAL(AIMAG(det),4) + ENDDO + IF (MOD(iim, MAX(1,detgrid_nim/10)) == 0) + $ WRITE(*,'(4x,a,i4,a,i4)') "row ",iim," /",detgrid_nim + ENDDO + CALL ascii_close(out_unit) + WRITE(bin_unit) + CLOSE(UNIT=bin_unit) + WRITE(*,*) "DETGRID: wrote detgrid.out and detgrid.bin" + CALL program_stop("Normal termination for detgrid scan.") + END SUBROUTINE match_detgrid c----------------------------------------------------------------------- c subprogram 8. match_delta_jardin. c finite differential method of GGJ. diff --git a/slayer/growthrates.f b/slayer/growthrates.f index fbfcbb1a0..469541046 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -215,6 +215,9 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c_beta = sl_in%c_beta_arr(1) tauk = sl_in%Qconv_arr(1) iota_e = Q_e / (Q_e - Q_i) +c BENCHMARK PATCH: ensure pr is set so riccati_f's +c atol = 1e-7*pr**0.4 does not inherit a stale/zero module value. + pr = P_perp g_tmp = g_in tmp_delta=riccati_f() @@ -240,6 +243,9 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c_beta = sl_in%c_beta_arr(k) tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) +c BENCHMARK PATCH: ensure pr is set so riccati_f's +c atol = 1e-7*pr**0.4 does not inherit a stale/zero module value. + pr = P_perp c evaluate riccati_f at rescaled growth rate, de-normalise c rescale g_in to this surface's normalisation diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index e9b790654..ffedd8191 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -484,8 +484,20 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) dr_val = dr_vals(ising) c convert STRIDE shear (psiN-based) to Fitzpatrick shear (r-based). -c s_Fitz = s_psiN * r_s / (psiN * da_surf/dpsiN) +c STRIDE's shear(ising) = psi_N * d(ln q)/d(psi_N) (psi_N-based). +c Fitzpatrick's rfitzp formula needs s = (r/q) * dq/dr (r-based). +c Chain-rule: s_Fitz = s_psiN * r_s / (psi_N * da/dpsi_N). +c Typical magnitudes: s_psiN ~ 0.3-0.5 mid-plasma, while s_Fitz +c ~ 0.7-1.5 -- r-based shear is usually LARGER than psi_N-based +c because (r/psi_N) > (dr/dpsi_N) inside the mid-radius region. s_fitz = my_sval * my_rs / (respsi * da_dpsiN) + WRITE(*,'(A,I2,A,F7.4,A,F6.3,A,F8.4,A,F8.4,A,F7.3,A,F7.3)') + $ ' [layerinputs] q=', resm(ising), + $ ' psiN=', respsi, + $ ' r_s=', my_rs, + $ ' da/dpsiN=', da_dpsiN, + $ ' s_psiN=', my_sval, + $ ' -> s_Fitz=', s_fitz c transport coefficients from caller-provided arrays. c guard: arrays may be smaller than msing (e.g. from From 9ea6367b1a56694de1d2c14c5965f156cade0125 Mon Sep 17 00:00:00 2001 From: d-burg Date: Sun, 26 Apr 2026 03:47:48 -0400 Subject: [PATCH 096/118] SLAYER - NEW FEATURE - Allow STRIDE msing > coupled-dispersion msing_max MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Patch growthrates.f::dispersion_det to take only the (1:msing_max, 1:msing_max) sub-block of sl_in%dp_matrix before forming the coupled dispersion residual. Required for the DIII-D 147131 case where sas_flag=t, dmlim=0.2, qhigh=1e3 makes STRIDE produce a 4×4 Δ' matrix (q=2,3,4,5) but the SLAYER coupled-dispersion code only supports msing_max ≤ 3 (calc_determinant is hard-coded for 2x2 / 3x3). Coupled Δ_crit (dc_type=rfitzp) now works end-to-end across STRIDE, SLAYER, rdcon, and rmatch on the DIII-D benchmark. The dc_type='rfitzp' case visibly damps the coupled growth rate vs dc_type='none' on both Julia and Fortran SLAYER panels (different pole arrangement between the codes, traced to STRIDE's misnamed `dr_rational` variable storing the Mercier index D_I instead of the resistive interchange D_R = E + F + H² that the rfitzp formula expects — flagged for a separate fix). Verified at: CTM-processing/julia_vs_fortran/rmatch_eigenvalue_benchmark/cases/diiid/ --- slayer/growthrates.f | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 469541046..502fffae7 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -264,7 +264,15 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c on the diagonal. When dc_type='none', d_crit_arr is zero c and the subtraction is a no-op, so this is backward c compatible with the original coupled behaviour. - result_matrix = sl_in%dp_matrix - delta_Q +c +c BENCHMARK PATCH: take only the (1:msing_max, 1:msing_max) +c sub-block of dp_matrix so callers can compute the coupled +c dispersion on a subset of the rational surfaces that STRIDE +c actually found. This is needed when STRIDE finds 4+ surfaces +c (e.g. DIII-D 147131 with sas_flag=t, qhigh=1e3) but the +c coupled-dispersion code only supports msing_max ≤ 3. + result_matrix = sl_in%dp_matrix(1:msing_max,1:msing_max) + $ - delta_Q DO k = 1, msing_max result_matrix(k,k) = result_matrix(k,k) $ - CMPLX(sl_in%d_crit_arr(k), 0.0_r8, KIND=r8) From c0988c61c73443530fc55b6e418168626f65baa4 Mon Sep 17 00:00:00 2001 From: d-burg Date: Mon, 1 Jun 2026 14:46:43 -0400 Subject: [PATCH 097/118] fix dr_rationals to use locstab%f(2) index Co-Authored-By: Claude Opus 4.8 (1M context) --- stride/stride_netcdf.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index a7ea49168..0d7d8781d 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -97,7 +97,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, DO i=1,msing respsi = sing(i)%psifac CALL spline_eval(locstab,respsi,0) - dr_rationals(i)=locstab%f(1)/respsi + dr_rationals(i)=locstab%f(2)/respsi END DO c----------------------------------------------------------------------- c open files From 8ec2df3b174c0d8a9fbb2051a8e0854761959b14 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:18:49 -0400 Subject: [PATCH 098/118] SLAYER - BUGFIX - Pass a dummy Jacobian subroutine to LSODE in the non-stiff Riccati calls riccati() and directred() passed a REAL placeholder in LSODE's JAC position while riccati_del_s() and riccati_f() pass a subroutine. gfortran 15 rejects the mixed use within one file ("Invalid procedure argument"), so delta.f did not compile. All calls now pass a subroutine; mf=10 never calls it, so results are unchanged. Co-Authored-By: Claude Opus 5.5 --- slayer/delta.f | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index a05ec4f6e..67a2947cf 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -69,7 +69,6 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, REAL(r8) :: x,xout ! current and target x REAL(r8) :: xmin ! inner integration bound REAL(r8) :: rtol ! relative tolerance - REAL(r8) :: jac ! dummy Jacobian (unused for mf=10) c --- work arrays COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy ! W and dW INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work @@ -135,7 +134,7 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, DO WHILE (x>xout) istep=istep+1 CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) WRITE(out2_unit,'(1x,3(es17.8e3))') x,REAL(y),AIMAG(y) ENDDO @@ -146,7 +145,7 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, istep = 1 itask = 1 CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) ENDIF c --- extract Delta from final W derivative at x_min @@ -192,7 +191,6 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) REAL(r8) :: xout ! target integration endpoint REAL(r8) :: xmin ! inner integration bound REAL(r8) :: rtol ! relative tolerance - REAL(r8) :: jac ! dummy (overridden by jac_del_s) REAL(r8) :: my_q ! integration variable (large -> small) REAL(r8) :: P_hat ! normalized P_perp REAL(r8) :: alpha ! boundary condition coefficient @@ -274,6 +272,18 @@ FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) END FUNCTION riccati_del_s c----------------------------------------------------------------------- +c jac_dummy: placeholder Jacobian for lsode calls whose method flag +c does not use a user-supplied Jacobian (mf=10, mf=22). lsode never +c calls it; it exists so that every lsode call in this module passes +c a subroutine in the JAC position. +c----------------------------------------------------------------------- + SUBROUTINE jac_dummy(neq, x, y, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: x + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + END SUBROUTINE jac_dummy +c----------------------------------------------------------------------- c jacobian for riccati_del_s(): pd = dF/dW for stiff lsode. c----------------------------------------------------------------------- SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) @@ -335,7 +345,6 @@ FUNCTION riccati_f() REAL(r8) :: xout ! target integration endpoint REAL(r8) :: xmin ! inner integration bound REAL(r8) :: rtol ! relative tolerance - REAL(r8) :: jac ! dummy (overridden by jac_f) REAL(r8) :: my_p ! integration variable p (large -> small) REAL(r8) :: bk ! asymptotic coefficient b_k c --- boundary-condition intermediates @@ -1002,7 +1011,7 @@ FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - REAL(r8) :: xintv,x,xout,rtol,jac,xmax + REAL(r8) :: xintv,x,xout,rtol,xmax COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy INTEGER, DIMENSION(:), ALLOCATABLE :: iwork @@ -1042,7 +1051,7 @@ FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) DO istep=istep+1 CALL lsode(phi_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac,mf) + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) xout=xout+xintv IF (xmax-xout Date: Fri, 9 Oct 2026 19:24:36 -0400 Subject: [PATCH 099/118] SLAYER - NEW FEATURE - Extract dispersion roots from the AMR scan The matched growth-rate path wrote only the AMR scan cloud; gamma_sol_arr was a placeholder zero left for an external root finder. extract_roots now locates the zeros and poles of the dispersion function from the final AMR cells: the phase of D winds by +2*pi around a cell holding a zero and by -2*pi around a pole. Each zero is refined by a secant iteration confined to the neighbourhood of its cell. The most unstable root is reported per surface as gamma_sol (gamma in 1/s, omega in rad/s), and all roots and poles of each scan are written to the NetCDF file (Q_roots, Q_poles, gamma_roots, omega_roots, n_roots, n_poles, root_polished). Surfaces with no root get NaN rather than zero. No physical filtering of roots is applied. Co-Authored-By: Claude Opus 5.5 --- slayer/growthrates.f | 217 +++++++++++++++++++++++++++++++++++++++-- slayer/sglobal.f | 18 ++++ slayer/slayer.f | 30 +++++- slayer/slayer_netcdf.f | 99 +++++++++++++++++++ 4 files changed, 351 insertions(+), 13 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 502fffae7..0704b1bd6 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -20,6 +20,8 @@ MODULE growthrates_mod c 9. dispersion_AMR_v2 - AMR scan (cell-based storage) c 10. check_cell_crossing_sub - zero-crossing test c 11. subdivide_cell_sub - cell refinement +c 12. eval_dispersion - dispersion function at one Q +c 13. extract_roots - zeros and poles from the AMR cells c----------------------------------------------------------------------- USE omp_lib @@ -35,6 +37,7 @@ MODULE growthrates_mod $ MAX_PTS,HASH_SZ,HASH_SCALE, ! v1 constants $ hash_head,hash_next, ! v1 hash $ MAX_CELLS, ! v2 limit + $ MAX_ROOTS,roots_outputs_type, ! root output $ slayer_inputs_type,slayer_outputs_type, $ deltas_outputs_type, $ tau_r,dc_tmp,dc_type, @@ -44,6 +47,7 @@ MODULE growthrates_mod USE params_mod USE layerinputs_mod USE slayer_netcdf_mod + USE ieee_arithmetic, ONLY: ieee_value, ieee_quiet_nan IMPLICIT NONE @@ -345,16 +349,8 @@ SUBROUTINE get_or_compute_v2(q_in, idx_out, n_k, idx_out = n_pts Q_store(idx_out) = q_in - IF (coupling_flag) THEN -c dispersion_det sets g_tmp per-surface internally; -c pass q_in*ifac directly as g_in argument. - delta_val = dispersion_det(q_in * ifac, n_k, sl_in, - $ msing_max) - ELSE - g_tmp = q_in * ifac - delta_val = riccati_f() - delta_val = delta_val - delta_eff - END IF + delta_val = eval_dispersion(q_in, n_k, sl_in, msing_max, + $ coupling_flag) D_store(idx_out) = delta_val c --- 4. insert into hash chain (prepend) @@ -713,4 +709,205 @@ SUBROUTINE subdivide_cell_sub(parent, RETURN END SUBROUTINE subdivide_cell_sub +c----------------------------------------------------------------------- +c subprogram 12. eval_dispersion. +c Dispersion function at one scan-plane point q_in, with the ifac +c rotation g = i*q_in applied. Uncoupled: riccati_f() - delta_eff +c using the module-level layer parameters of the current surface. +c Coupled: the determinant from dispersion_det. +c----------------------------------------------------------------------- + FUNCTION eval_dispersion(q_in, n_k, sl_in, msing_max, + $ coupling_flag) + + IMPLICIT NONE + + COMPLEX(r8), INTENT(IN) :: q_in + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + COMPLEX(r8) :: eval_dispersion + + IF (coupling_flag) THEN +c dispersion_det sets g_tmp per-surface internally; +c pass q_in*ifac directly as g_in argument. + eval_dispersion = dispersion_det(q_in * ifac, n_k, sl_in, + $ msing_max) + ELSE + g_tmp = q_in * ifac + eval_dispersion = riccati_f() - delta_eff + END IF + + END FUNCTION eval_dispersion + +c----------------------------------------------------------------------- +c subprogram 13. extract_roots. +c Locate the zeros and poles of the dispersion function from the +c leaf cells left in amr_cells by dispersion_AMR_v2. +c +c The dispersion function is analytic in the scan variable, so the +c phase of D winds by +2*pi counter-clockwise around a cell that +c holds a simple zero and by -2*pi around one that holds a simple +c pole. The winding number is taken from the four corner values. +c Each zero is then refined by a secant iteration confined to the +c neighbourhood of its cell; if that leaves the neighbourhood or +c does not converge, the best point evaluated is kept and the root +c is marked unpolished. +c +c Roots are returned in the scan plane (q = omega_hat - i*gamma_hat) +c sorted by descending growth rate. No physical filtering of the +c roots is attempted here. +c----------------------------------------------------------------------- + SUBROUTINE extract_roots(n_k, sl_in, msing_max, coupling_flag, + $ tauk_ref, roots) + + IMPLICIT NONE + +c --- arguments + INTEGER, INTENT(IN) :: n_k, msing_max + TYPE(slayer_inputs_type), INTENT(IN) :: sl_in + LOGICAL, INTENT(IN) :: coupling_flag + REAL(r8), INTENT(IN) :: tauk_ref ! tau_k of the scanned Q + TYPE(roots_outputs_type), INTENT(OUT) :: roots +c --- parameters + INTEGER, PARAMETER :: ccw(5) = (/1,2,4,3,1/) ! BL,BR,TR,TL,BL + INTEGER, PARAMETER :: MAXIT_POLISH = 30 + REAL(r8), PARAMETER :: POLISH_TOL = 1.0e-9_r8 +c --- locals + INTEGER :: c, j, it, nw, i, ins + REAL(r8) :: wsum, h, nan + COMPLEX(r8) :: d(4), z, q_c, d_c, slope + COMPLEX(r8) :: qa, qb, qn, da, db, dn, q_best, d_best + LOGICAL :: conv, dup + + nan = ieee_value(1.0_r8, ieee_quiet_nan) + roots%n_root = 0 + roots%n_pole = 0 + roots%q_root = CMPLX(nan, nan, KIND=r8) + roots%q_pole = CMPLX(nan, nan, KIND=r8) + roots%polished = .FALSE. + roots%tauk = tauk_ref + + IF (.NOT. ALLOCATED(amr_cells)) RETURN + + DO c = 1, n_amr_cells + d = amr_cells(c)%D +c skip cells with a failed (non-finite) or exactly zero corner + IF (ANY(d /= d) .OR. ANY(ABS(d) > HUGE(1.0_r8)) + $ .OR. ANY(ABS(d) == 0.0_r8)) CYCLE + +c winding number of D around the cell, counter-clockwise + wsum = 0.0_r8 + DO j = 1, 4 + z = (d(ccw(j+1))/ABS(d(ccw(j+1)))) + $ * CONJG(d(ccw(j))/ABS(d(ccw(j)))) + wsum = wsum + ATAN2(AIMAG(z), REAL(z)) + END DO + nw = NINT(wsum / (2.0_r8*pi)) + IF (nw == 0) CYCLE + + q_c = 0.25_r8 * SUM(amr_cells(c)%Q) + h = REAL(amr_cells(c)%Q(2) - amr_cells(c)%Q(1)) + +c pole: record the cell centre + IF (nw < 0) THEN + IF (roots%n_pole < MAX_ROOTS) THEN + roots%n_pole = roots%n_pole + 1 + roots%q_pole(roots%n_pole) = q_c + END IF + CYCLE + END IF + +c zero: linear estimate from the corner values, then secant + d_c = 0.25_r8 * SUM(d) + slope = ((d(2) - d(1)) + (d(4) - d(3))) / (2.0_r8*h) + qa = q_c + da = eval_dispersion(qa, n_k, sl_in, msing_max, + $ coupling_flag) + qb = q_c + 0.25_r8*h + IF (ABS(slope) > 0.0_r8) THEN + qn = q_c - d_c/slope + IF (ABS(REAL(qn - q_c)) <= 0.5_r8*h .AND. + $ ABS(AIMAG(qn - q_c)) <= 0.5_r8*h .AND. + $ ABS(qn - q_c) > 0.0_r8) qb = qn + END IF + db = eval_dispersion(qb, n_k, sl_in, msing_max, + $ coupling_flag) + IF (ABS(db) < ABS(da) .OR. da /= da) THEN + q_best = qb + d_best = db + ELSE + q_best = qa + d_best = da + END IF + conv = .FALSE. + DO it = 1, MAXIT_POLISH + IF (da /= da .OR. db /= db) EXIT + IF (ABS(db - da) == 0.0_r8) EXIT + qn = qb - db*(qb - qa)/(db - da) + IF (qn /= qn) EXIT +c stay within 1.5 cell widths of the cell centre + IF (ABS(REAL(qn - q_c)) > 1.5_r8*h .OR. + $ ABS(AIMAG(qn - q_c)) > 1.5_r8*h) EXIT + dn = eval_dispersion(qn, n_k, sl_in, msing_max, + $ coupling_flag) + IF (dn /= dn) EXIT + qa = qb + da = db + qb = qn + db = dn + IF (ABS(db) < ABS(d_best)) THEN + q_best = qb + d_best = db + END IF + IF (ABS(qb - qa) <= + $ POLISH_TOL*MAX(1.0_r8, ABS(qb))) THEN + conv = .TRUE. + q_best = qb + d_best = db + EXIT + END IF + END DO + +c drop a root already found from a neighbouring cell + dup = .FALSE. + DO i = 1, roots%n_root + IF (ABS(roots%q_root(i) - q_best) < 0.5_r8*ABS(h)) + $ dup = .TRUE. + END DO + IF (dup .OR. roots%n_root >= MAX_ROOTS) CYCLE + +c insert, keeping descending growth rate (ascending AIMAG(q)) + ins = roots%n_root + 1 + DO i = 1, roots%n_root + IF (AIMAG(q_best) < AIMAG(roots%q_root(i))) THEN + ins = i + EXIT + END IF + END DO + DO i = roots%n_root, ins, -1 + roots%q_root(i+1) = roots%q_root(i) + roots%polished(i+1) = roots%polished(i) + END DO + roots%q_root(ins) = q_best + roots%polished(ins) = conv + roots%n_root = roots%n_root + 1 + END DO + +c --- report + WRITE(*,'(A,I0,A,I0)') ' Dispersion roots found: ', + $ roots%n_root, ', poles: ', roots%n_pole + DO i = 1, roots%n_root + WRITE(*,'(A,I2,A,2ES14.6,A,ES14.6,A,ES14.6,A,L1)') + $ ' root', i, ': Q=', REAL(roots%q_root(i)), + $ -AIMAG(roots%q_root(i)), + $ ' omega[rad/s]=', REAL(roots%q_root(i))/tauk_ref, + $ ' gamma[1/s]=', -AIMAG(roots%q_root(i))/tauk_ref, + $ ' polished=', roots%polished(i) + END DO + IF (roots%n_root == 0) WRITE(*,'(A)') + $ ' WARNING: no dispersion root in the scan window.' + + RETURN + END SUBROUTINE extract_roots + END MODULE growthrates_mod diff --git a/slayer/sglobal.f b/slayer/sglobal.f index bd4d5556a..63bc85b63 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -190,4 +190,22 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: imag_deltas(:) ! Im(Delta) END TYPE deltas_outputs_type +c roots_outputs_type -- zeros and poles of the dispersion function +c located in one AMR scan. Q values are stored in the scan plane, +c q = omega_hat - i*gamma_hat (so gamma = -AIMAG(q)/tauk and +c omega = REAL(q)/tauk), sorted by descending growth rate. + INTEGER, PARAMETER :: MAX_ROOTS = 32 ! max stored per scan + TYPE roots_outputs_type + INTEGER :: n_root = 0 ! zeros found + INTEGER :: n_pole = 0 ! poles found + COMPLEX(r8) :: q_root(MAX_ROOTS) ! zeros (scan plane) + COMPLEX(r8) :: q_pole(MAX_ROOTS) ! poles (scan plane) + LOGICAL :: polished(MAX_ROOTS) ! secant converged? + REAL(r8) :: tauk = 0.0_r8 ! Q -> [1/s] factor + END TYPE roots_outputs_type + +c per-scan roots, filled by extract_roots (growthrates_mod) and +c written by slayer_netcdf_out + TYPE(roots_outputs_type), ALLOCATABLE :: roots_out(:) + END MODULE sglobal_mod diff --git a/slayer/slayer.f b/slayer/slayer.f index 15b4e6674..f61b90779 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -17,6 +17,7 @@ PROGRAM slayer USE gslayer_mod USE growthrates_mod USE layerinputs_mod + USE ieee_arithmetic, ONLY: ieee_value, ieee_quiet_nan IMPLICIT NONE c----------------------------------------------------------------------- @@ -708,10 +709,17 @@ PROGRAM slayer c----------------------------------------------------------------------- IF (AMR_flag .AND. .NOT. coupling_flag) THEN ALLOCATE(all_deltas_out(n_k)) + ALLOCATE(roots_out(n_k)) ELSEIF (AMR_flag .AND. coupling_flag) THEN ALLOCATE(all_deltas_out(1)) + ALLOCATE(roots_out(1)) END IF +c growth rates stay NaN on surfaces where no root is extracted + sl_out%gamma_sol_arr = CMPLX( + $ ieee_value(1.0_r8, ieee_quiet_nan), + $ ieee_value(1.0_r8, ieee_quiet_nan), KIND=r8) + IF (AMR_flag) THEN IF (coupling_flag) THEN m_AMR = 1 @@ -756,9 +764,6 @@ PROGRAM slayer $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) pe = 0.0 - ! Placeholder: gamma_sol_arr filled for external root-finder. - sl_out%gamma_sol_arr(k) = 0.0 - c----------------------------------------------------------------------- c uncoupled AMR scan (one surface at a time). c dispersion_AMR_v2 (growthrates_mod) populates Q_store, D_store. @@ -770,6 +775,18 @@ PROGRAM slayer CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) + ! Zeros of the dispersion function in this surface's + ! own ExB frame; the most unstable one is reported as + ! gamma_sol = gamma [1/s] + i*omega [rad/s]. + CALL extract_roots(n_k,sl_in,msing_max,coupling_flag, + $ sl_in%Qconv_arr(k),roots_out(k)) + IF (roots_out(k)%n_root > 0) THEN + sl_out%gamma_sol_arr(k) = CMPLX( + $ -AIMAG(roots_out(k)%q_root(1)), + $ REAL(roots_out(k)%q_root(1)), KIND=r8) + $ / sl_in%Qconv_arr(k) + END IF + ! Re-allocate output arrays for this surface. IF (ALLOCATED(all_deltas_out(k)%inQs)) $ DEALLOCATE(all_deltas_out(k)%inQs) @@ -886,6 +903,13 @@ PROGRAM slayer CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag) + ! Zeros of the coupled determinant. Q is normalised by + ! the first surface's tau_k. The coupled eigenvalue is + ! global, so it is reported through roots_out only and + ! the per-surface gamma_sol_arr is left as NaN. + CALL extract_roots(n_k,sl_in,msing_max,coupling_flag, + $ sl_in%Qconv_arr(1),roots_out(1)) + ! Re-allocate output arrays. IF (ALLOCATED(all_deltas_out(1)%inQs)) $ DEALLOCATE(all_deltas_out(1)%inQs) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 82e9bd91f..015ca78bb 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -127,6 +127,22 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: var_d_id ! "Deltas_AMR" — scan Delta values INTEGER :: var_npts_id ! "n_amr_pts" — points per surface +c root variable IDs (zeros and poles of the dispersion function) + INTEGER :: root_dim ! dim: stored roots per scan + INTEGER :: nroot_id ! "n_roots" + INTEGER :: npole_id ! "n_poles" + INTEGER :: qroot_id ! "Q_roots" + INTEGER :: qpole_id ! "Q_poles" + INTEGER :: groot_id ! "gamma_roots" + INTEGER :: oroot_id ! "omega_roots" + INTEGER :: proot_id ! "root_polished" + LOGICAL :: have_roots ! roots_out holds this run's roots + REAL(r8), ALLOCATABLE :: buffer_r(:,:,:) ! (root, surf, Re/Im) + REAL(r8), ALLOCATABLE :: buffer_p(:,:,:) ! (root, surf, Re/Im) + REAL(r8), ALLOCATABLE :: buffer_g(:,:) ! gamma (root, surf) + REAL(r8), ALLOCATABLE :: buffer_o(:,:) ! omega (root, surf) + INTEGER, ALLOCATABLE :: buffer_f(:,:) ! polished (root, surf) + c----------------------------------------------------------------------- c declarations -- AMR rectangular-buffer workspace. c The ragged per-surface scan data are padded into fixed-size @@ -217,6 +233,33 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, END DO END IF +c step 4: roots and poles, in the same (omega_hat, gamma_hat) +c convention as Q_AMR. + have_roots = .FALSE. + IF (ALLOCATED(roots_out)) have_roots = SIZE(roots_out) >= m_AMR + $ .AND. m_AMR > 0 + IF (have_roots) THEN + ALLOCATE(buffer_r(MAX_ROOTS, m_AMR, 2)) + ALLOCATE(buffer_p(MAX_ROOTS, m_AMR, 2)) + ALLOCATE(buffer_g(MAX_ROOTS, m_AMR)) + ALLOCATE(buffer_o(MAX_ROOTS, m_AMR)) + ALLOCATE(buffer_f(MAX_ROOTS, m_AMR)) + buffer_f = 0 + DO s = 1, m_AMR + buffer_r(:, s, 1) = REAL(roots_out(s)%q_root) + buffer_r(:, s, 2) = -AIMAG(roots_out(s)%q_root) + buffer_p(:, s, 1) = REAL(roots_out(s)%q_pole) + buffer_p(:, s, 2) = -AIMAG(roots_out(s)%q_pole) + buffer_g(:, s) = fill_val + buffer_o(:, s) = fill_val + IF (roots_out(s)%tauk > 0.0_r8) THEN + buffer_g(:, s) = buffer_r(:, s, 2)/roots_out(s)%tauk + buffer_o(:, s) = buffer_r(:, s, 1)/roots_out(s)%tauk + END IF + WHERE (roots_out(s)%polished) buffer_f(:, s) = 1 + END DO + END IF + c----------------------------------------------------------------------- c define global file attributes. c----------------------------------------------------------------------- @@ -287,6 +330,10 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_def_var(ncid, "growth rate", $ nf90_double, (/qsing_dim, i_dim/), gs_id) ) + CALL sl_check( nf90_put_att(ncid, gs_id, "long_name", + $ "Most unstable matched root on each surface: gamma [1/s] "// + $ "(i=1) and omega [rad/s] (i=2), in that surface's ExB "// + $ "frame; NaN where no root was extracted") ) IF (ALLOCATED(sl_out%br_th_arr)) THEN CALL sl_check( nf90_def_var(ncid, "br_th", @@ -305,6 +352,45 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_def_var(ncid, "Deltas_AMR", NF90_DOUBLE, $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id) ) +c roots and poles of the dispersion function from each AMR scan. + IF (have_roots) THEN + CALL sl_check( nf90_def_dim(ncid, "root", MAX_ROOTS, + $ root_dim) ) + CALL sl_check( nf90_def_var(ncid, "n_roots", NF90_INT, + $ (/nAMR_dim/), nroot_id) ) + CALL sl_check( nf90_def_var(ncid, "n_poles", NF90_INT, + $ (/nAMR_dim/), npole_id) ) + CALL sl_check( nf90_def_var(ncid, "Q_roots", NF90_DOUBLE, + $ (/root_dim, nAMR_dim, i_dim/), qroot_id) ) + CALL sl_check( nf90_put_att(ncid, qroot_id, "long_name", + $ "Zeros of the dispersion function, (omega, gamma)*"// + $ "tau_k, sorted by descending gamma") ) + CALL sl_check( nf90_def_var(ncid, "Q_poles", NF90_DOUBLE, + $ (/root_dim, nAMR_dim, i_dim/), qpole_id) ) + CALL sl_check( nf90_put_att(ncid, qpole_id, "long_name", + $ "Poles of the dispersion function, (omega, gamma)*"// + $ "tau_k, AMR cell centres") ) + CALL sl_check( nf90_def_var(ncid, "gamma_roots", + $ NF90_DOUBLE, (/root_dim, nAMR_dim/), groot_id) ) + CALL sl_check( nf90_put_att(ncid, groot_id, "units", "1/s") ) + CALL sl_check( nf90_def_var(ncid, "omega_roots", + $ NF90_DOUBLE, (/root_dim, nAMR_dim/), oroot_id) ) + CALL sl_check( nf90_put_att(ncid, oroot_id, "units", + $ "rad/s") ) + CALL sl_check( nf90_def_var(ncid, "root_polished", NF90_INT, + $ (/root_dim, nAMR_dim/), proot_id) ) + CALL sl_check( nf90_put_att(ncid, proot_id, "long_name", + $ "1 if the secant refinement of the root converged") ) + CALL sl_check( nf90_put_att(ncid, qroot_id, + $ "_FillValue", fill_val) ) + CALL sl_check( nf90_put_att(ncid, qpole_id, + $ "_FillValue", fill_val) ) + CALL sl_check( nf90_put_att(ncid, groot_id, + $ "_FillValue", fill_val) ) + CALL sl_check( nf90_put_att(ncid, oroot_id, + $ "_FillValue", fill_val) ) + END IF + c set _FillValue attribute on AMR arrays for proper padding. CALL sl_check( nf90_put_att(ncid, var_q_id, $ "_FillValue", fill_val) ) @@ -389,6 +475,19 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_put_var(ncid, var_q_id, buffer_q) ) CALL sl_check( nf90_put_var(ncid, var_d_id, buffer_d) ) + IF (have_roots) THEN + CALL sl_check( nf90_put_var(ncid, nroot_id, + $ roots_out(1:m_AMR)%n_root) ) + CALL sl_check( nf90_put_var(ncid, npole_id, + $ roots_out(1:m_AMR)%n_pole) ) + CALL sl_check( nf90_put_var(ncid, qroot_id, buffer_r) ) + CALL sl_check( nf90_put_var(ncid, qpole_id, buffer_p) ) + CALL sl_check( nf90_put_var(ncid, groot_id, buffer_g) ) + CALL sl_check( nf90_put_var(ncid, oroot_id, buffer_o) ) + CALL sl_check( nf90_put_var(ncid, proot_id, buffer_f) ) + DEALLOCATE(buffer_r, buffer_p, buffer_g, buffer_o, buffer_f) + END IF + c----------------------------------------------------------------------- c deallocate AMR rectangular buffers. c----------------------------------------------------------------------- From c4d129abf73cb0724d4ebb34aa91b145b3b3fe6f Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:26:30 -0400 Subject: [PATCH 100/118] SLAYER - BUGFIX - Correct the inter-surface Q rescaling in the coupled determinant dispersion_det evaluated surface k's layer at g*tau_1/tau_k. With g = tau_1*(gamma + i*omega) the same physical eigenvalue reaches surface k as g*tau_k/tau_1, which is the normalisation its Q_e and Q_i carry. The old direction got only the reference surface right, so every other surface's branch of the coupled determinant sat at the wrong frequency and growth rate. Check on the DIII-D-like example with a real, diagonal Delta' (where the coupled roots must equal the uncoupled ones): the 3/1 and 4/1 roots now land on Q_k*tau_1/tau_k to 7 digits. Before, the 3/1 branch sat at Re(Q) = -0.514 instead of -1.062. Same defect and fix as OpenFUSIONToolkit/GPEC#463. Co-Authored-By: Claude Opus 5.5 --- slayer/growthrates.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 0704b1bd6..ef69b1237 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -251,9 +251,12 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c atol = 1e-7*pr**0.4 does not inherit a stale/zero module value. pr = P_perp -c evaluate riccati_f at rescaled growth rate, de-normalise -c rescale g_in to this surface's normalisation - g_tmp = (g_in*sl_in%Qconv_arr(1))/tauk +c evaluate riccati_f at rescaled growth rate, de-normalise. +c g_in is normalised by the first surface's tau_k, i.e. +c g_in = tau_1*(gamma + i*omega). The same physical +c eigenvalue reaches surface k as tau_k*(gamma + i*omega) +c = g_in*tau_k/tau_1, the normalisation its Q_e and Q_i use. + g_tmp = g_in*(tauk/sl_in%Qconv_arr(1)) delta_Q(k,k)=riccati_f() delta_Q(k,k)=delta_Q(k,k)* $ sl_in%lu_arr(k)**(1.0_r8/3.0_r8) From 6ebfdb400fecd8496d8da8daecb20e4e9afc53e9 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:28:44 -0400 Subject: [PATCH 101/118] SLAYER, STRIDE - BUGFIX - Convert Delta' to the r_s reference length before layer matching The dispersion relation Delta' - Delta_crit = S^(1/3)*Delta(Q) compared STRIDE's Delta', which is referenced to unit normalised poloidal flux, with layer quantities that are all referenced to x = (r - r_s)/r_s. build_inputs now converts the matrix with the Mercier-exponent transform Dp_rs(i,j) = K_i^(1/2+alpha_i) * Dp(i,j) * K_j^(alpha_j-1/2) K = r_s*dpsi_N/dr, alpha = sqrt(-D_I) whose diagonal factor K^(2*alpha) reduces to r_s*Delta' at the slab point D_I = -1/4. The growth-rate estimate uses the converted diagonal too. Mercier-unstable surfaces are left unconverted. STRIDE writes the Mercier index at the rational surfaces (di_rational) for this. The SLAYER NetCDF keeps the STRIDE value in Delta_prime_rational and adds Delta_prime_rs_rational, k_ref and alpha_mercier. Namelist-driven runs (read_eq=f) are unchanged: the input delta_prime is taken as already r_s-referenced. DIII-D-like example, uncoupled, dc_type none: K^(2*alpha) = 0.80 at the 2/1 and its growth rate moves from 107.1 to 86.0 1/s. Same defect and fix as OpenFUSIONToolkit/GPEC#403. Co-Authored-By: Claude Opus 5.5 --- slayer/growthrates.f | 8 +++- slayer/layerinputs.f | 86 ++++++++++++++++++++++++++++++++++++++---- slayer/sglobal.f | 14 +++++-- slayer/slayer.f | 6 +++ slayer/slayer_netcdf.f | 27 +++++++++++++ stride/stride_netcdf.f | 15 ++++++-- 6 files changed, 141 insertions(+), 15 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index ef69b1237..5f06f8b64 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -93,7 +93,13 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%P_perp_arr(n_k),sl_in%tau_arr(n_k), $ sl_in%D_norm_arr(n_k), $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), - $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k)) + $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k), + $ sl_in%Re_dp_psi_arr(n_k),sl_in%Im_dp_psi_arr(n_k), + $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k)) +c namelist inputs are taken as already r_s-referenced: identity +c reference-length conversion (K = 1). + sl_in%k_ref_arr = 1.0_r8 + sl_in%alpha_arr = 0.5_r8 RETURN END SUBROUTINE allocate_inputs c----------------------------------------------------------------------- diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index ffedd8191..0e4914a99 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -38,7 +38,7 @@ MODULE layerinputs_mod c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, - $ shear,r_o,my_bt0,my_psio,dr_vals,mpsi,nn,resm) + $ shear,r_o,my_bt0,my_psio,dr_vals,di_vals,mpsi,nn,resm) c --- arguments (all INTENT(OUT) except ncfile) CHARACTER(512), INTENT(IN) :: ncfile ! path to STRIDE NetCDF @@ -58,7 +58,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ my_bt0, ! toroidal field B_t0 $ my_psio, ! poloidal flux psi_0 $ mpsi, ! poloidal mode number array - $ dr_vals ! radial width dr at each surface + $ dr_vals, ! resistive interchange index D_R + $ di_vals ! Mercier index D_I INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ nn, ! toroidal mode number(s) $ resm ! resonant poloidal mode numbers @@ -70,6 +71,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, INTEGER(kind=nf90_int) :: dp_id, qr_id, pr_id ! variable ids INTEGER(kind=nf90_int) :: dgeo_id, shear_id ! variable ids INTEGER(kind=nf90_int) :: resm_id, drr_id ! variable ids + INTEGER(kind=nf90_int) :: dir_id ! variable id INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! NetCDF hyperslab INTEGER :: i ! loop index INTEGER :: bt0_len, ro_len, psio_len ! attribute lengths @@ -94,7 +96,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, c --- allocate output arrays sized by msing ALLOCATE(Re_dp_diagonal(msing), q_rational(msing), $ psi_n_rational(msing), shear(msing), dgeo(msing), - $ resm(msing), Im_dp_diagonal(msing), dr_vals(msing)) + $ resm(msing), Im_dp_diagonal(msing), dr_vals(msing), + $ di_vals(msing)) ALLOCATE(dp_mat(msing, msing, 2)) c --- read lengths of scalar / small-array global attributes @@ -133,6 +136,14 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) stat = nf90_inq_varid(ncid, 'dr_rational', drr_id) CALL sl_check(stat) + stat = nf90_inq_varid(ncid, 'di_rational', dir_id) + IF (stat /= nf90_noerr) THEN + WRITE(*,*) 'ERROR: di_rational is missing from ',TRIM(ncfile) + WRITE(*,*) ' Rerun STRIDE from this GPEC version; SLAYER' + WRITE(*,*) ' needs D_I to convert Delta_prime to the r_s' + WRITE(*,*) ' reference length.' + END IF + CALL sl_check(stat) c --- read global attributes (equilibrium scalars) stat = nf90_get_att(ncid, NF90_GLOBAL, 'ro', r_o) @@ -161,6 +172,8 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) stat = nf90_get_var(ncid, drr_id, dr_vals) CALL sl_check(stat) + stat = nf90_get_var(ncid, dir_id, di_vals) + CALL sl_check(stat) c --- extract diagonal of the complex Deltaprime matrix DO i = 1, msing @@ -339,7 +352,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, $ Im_dp_diagonal, q_rational, psi_n_rational, $ shear, dgeo, r_o, my_bt0, my_psio, mpsi_arr, - $ dr_vals, dr_arr + $ dr_vals, di_vals, dr_arr c --- local per-surface kinetic arrays (for future NetCDF diagnostic output) REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr, te_arr, $ ni_arr, ti_arr, zeff_arr, bt_arr, rs_arr, R0_arr, @@ -357,13 +370,17 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8) :: da_dpsiN ! da_surf/dpsiN (Jacobian) REAL(r8) :: dpsi_h ! finite-diff step for Jacobian REAL(r8) :: s_fitz ! Fitzpatrick shear r*dq/dr/q +c --- Deltaprime reference-length conversion (psi_N -> r_s) + REAL(r8) :: k_ref ! K = r_s*dpsi_N/dr + REAL(r8) :: alpha_m ! Mercier exponent sqrt(-D_I) + INTEGER :: jsing ! second surface index c----------------------------------------------------------------------- c read STRIDE NetCDF: Deltaprime matrix, geometry, equilibrium scalars. c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational, $ psi_n_rational,dgeo,shear,r_o,my_bt0,my_psio,dr_vals, - $ mpsi_arr,nn,resm) + $ di_vals,mpsi_arr,nn,resm) mpsi = INT(mpsi_arr(1)) mthsurf = 512 ! poloidal segments for surface integral @@ -380,7 +397,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%D_norm_arr(msing), $ sl_in%d_beta_arr(msing), sl_in%gammafac_arr(msing), $ sl_in%c_beta_arr(msing), sl_in%lu_arr(msing), - $ sl_in%Qconv_arr(msing)) + $ sl_in%Qconv_arr(msing), + $ sl_in%Re_dp_psi_arr(msing), sl_in%Im_dp_psi_arr(msing), + $ sl_in%k_ref_arr(msing), sl_in%alpha_arr(msing)) c --- allocate local kinetic arrays (for future NetCDF diagnostic output) ALLOCATE(ne_arr(msing), te_arr(msing), ni_arr(msing), @@ -412,8 +431,10 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) CALL equil_read(out_unit) -c store full complex Deltaprime matrix in sl_in - sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1), dp_mat(:,:,2)) +c store full complex Deltaprime matrix in sl_in. It is converted +c to the r_s reference length after the surface loop below. + sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1), dp_mat(:,:,2), + $ KIND=r8) dpsi_h = 0.002 ! finite-difference step for Jacobian @@ -539,6 +560,43 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ l_n,l_t,my_qval,s_fitz,my_bt,my_rs,R_0,mu_i, $ zeff,.false.) +c----------------------------------------------------------------------- +c reference-length conversion of the outer Deltaprime. +c STRIDE's Deltaprime is referenced to unit normalised poloidal +c flux, while the layer response S^(1/3)*Delta(Q), S and the +c critical Delta are all referenced to x = (r - r_s)/r_s. +c Near the surface the outer solution scales as +c |x|^(1/2 -+ alpha) with the Mercier exponent +c alpha = sqrt(-D_I) (Glasser, Greene & Johnson 1975), so +c rescaling x_psi = K*x with K = r_s*dpsi_N/dr gives +c Dp_rs(i,j) = K_i^(1/2+alpha_i) * Dp(i,j) * K_j^(alpha_j-1/2) +c whose diagonal factor is K^(2*alpha), reducing to the slab +c r_s*Deltaprime at D_I = -1/4. Mercier-unstable surfaces +c (D_I >= 0) are left unconverted through alpha = 0, and K = 1 +c is used if da/dpsi_N is not a usable positive number. +c----------------------------------------------------------------------- + IF (da_dpsiN > 0.0_r8 .AND. da_dpsiN < HUGE(da_dpsiN)) THEN + k_ref = my_rs / da_dpsiN + ELSE + k_ref = 1.0_r8 + WRITE(*,*) 'WARNING: da/dpsi_N =',da_dpsiN,' at psi_N =', + $ respsi,' is not usable;' + WRITE(*,*) ' Delta_prime is left unconverted there.' + END IF + IF (di_vals(ising) < 0.0_r8) THEN + alpha_m = SQRT(-di_vals(ising)) + ELSE + alpha_m = 0.0_r8 + END IF + sl_in%k_ref_arr(ising) = k_ref + sl_in%alpha_arr(ising) = alpha_m + sl_in%Re_dp_psi_arr(ising) = Re_dp_diagonal(ising) + sl_in%Im_dp_psi_arr(ising) = Im_dp_diagonal(ising) + Re_dp_diagonal(ising) = Re_dp_diagonal(ising) + $ * k_ref**(2.0_r8*alpha_m) + Im_dp_diagonal(ising) = Im_dp_diagonal(ising) + $ * k_ref**(2.0_r8*alpha_m) + c growth-rate conversion factor: Deltaprime -> gamma gammafac = (my_rs * Re_dp_diagonal(ising)) / tau_r @@ -571,6 +629,18 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) sl_in%P_tor_arr(ising) = P_tor sl_in%Qconv_arr(ising) = tauk ENDDO + +c convert the full Deltaprime matrix to the r_s reference length + DO jsing = 1, msing + DO ising = 1, msing + sl_in%dp_matrix(ising,jsing) = + $ sl_in%k_ref_arr(ising) + $ **(0.5_r8 + sl_in%alpha_arr(ising)) + $ * sl_in%dp_matrix(ising,jsing) + $ * sl_in%k_ref_arr(jsing) + $ **(sl_in%alpha_arr(jsing) - 0.5_r8) + END DO + END DO c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 63bc85b63..88de29ba9 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -168,10 +168,18 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: omegas_e_arr(:) ! omega_e [rad/s] REAL(r8), ALLOCATABLE :: omegas_i_arr(:) ! omega_i [rad/s] REAL(r8), ALLOCATABLE :: gammafac_arr(:) ! gamma conversion - REAL(r8), ALLOCATABLE :: Re_dp_arr(:) ! Re(Deltaprime) - REAL(r8), ALLOCATABLE :: Im_dp_arr(:) ! Im(Deltaprime) +c Deltaprime used in the layer matching is referenced to the +c minor radius r_s (unit x = (r - r_s)/r_s), like every layer +c quantity. The *_psi arrays keep the outer-region value as +c STRIDE writes it, referenced to unit normalised poloidal flux. + REAL(r8), ALLOCATABLE :: Re_dp_arr(:) ! Re(Deltaprime), r_s ref. + REAL(r8), ALLOCATABLE :: Im_dp_arr(:) ! Im(Deltaprime), r_s ref. + REAL(r8), ALLOCATABLE :: Re_dp_psi_arr(:) ! Re(Deltaprime), psi_N ref. + REAL(r8), ALLOCATABLE :: Im_dp_psi_arr(:) ! Im(Deltaprime), psi_N ref. + REAL(r8), ALLOCATABLE :: k_ref_arr(:) ! K = r_s*dpsi_N/dr + REAL(r8), ALLOCATABLE :: alpha_arr(:) ! Mercier exponent sqrt(-D_I) REAL(r8), ALLOCATABLE :: d_crit_arr(:) ! Delta_crit - COMPLEX(r8), ALLOCATABLE :: dp_matrix(:,:) ! full Deltaprime matrix + COMPLEX(r8), ALLOCATABLE :: dp_matrix(:,:) ! full Deltaprime matrix, r_s ref. END TYPE slayer_inputs_type c slayer_outputs_type -- per-surface solver results diff --git a/slayer/slayer.f b/slayer/slayer.f index f61b90779..b4f0347ee 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -563,6 +563,8 @@ PROGRAM slayer sl_in%psi_n_arr = (/ 0.0 /) sl_in%Re_dp_arr = (/ REAL(delta_prime) /) sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) + sl_in%Re_dp_psi_arr = (/ REAL(delta_prime) /) + sl_in%Im_dp_psi_arr = (/ AIMAG(delta_prime) /) sl_in%d_crit_arr = (/ dc_tmp /) sl_in%P_perp_arr = (/ P_perp /) sl_in%P_tor_arr = (/ P_tor /) @@ -690,6 +692,8 @@ PROGRAM slayer sl_in%psi_n_arr = (/ 0.0 /) sl_in%Re_dp_arr = (/ REAL(delta_prime) /) sl_in%Im_dp_arr = (/ AIMAG(delta_prime) /) + sl_in%Re_dp_psi_arr = (/ REAL(delta_prime) /) + sl_in%Im_dp_psi_arr = (/ AIMAG(delta_prime) /) sl_in%d_crit_arr = (/ dc_tmp /) sl_in%P_perp_arr = (/ P_perp /) sl_in%P_tor_arr = (/ P_tor /) @@ -1037,6 +1041,8 @@ PROGRAM slayer sl_in%psi_n_arr = (/ 0.0 /) sl_in%Re_dp_arr = (/ 0.0 /) sl_in%Im_dp_arr = (/ 0.0 /) + sl_in%Re_dp_psi_arr = (/ 0.0 /) + sl_in%Im_dp_psi_arr = (/ 0.0 /) sl_in%d_crit_arr = (/ 0.0 /) sl_in%P_perp_arr = (/ P_perp /) sl_in%P_tor_arr = (/ P_tor /) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 015ca78bb..85fd44231 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -115,6 +115,9 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: p_tor_id ! "P_tor" INTEGER :: Dnorm_id ! "D" — normalised D INTEGER :: dpp_id ! "Delta_prime_rational" (complex) + INTEGER :: dprs_id ! "Delta_prime_rs_rational" (complex) + INTEGER :: kref_id ! "k_ref" + INTEGER :: alpha_id ! "alpha_mercier" INTEGER :: dc_id ! "Delta_crit_rational" INTEGER :: dels_db_id ! "delta_s_d_b" (complex) INTEGER :: d_b_id ! "d_beta" @@ -316,6 +319,23 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ qsing_dim, Dnorm_id) ) CALL sl_check( nf90_def_var(ncid, "Delta_prime_rational", $ nf90_double, (/qsing_dim, i_dim/), dpp_id) ) + CALL sl_check( nf90_put_att(ncid, dpp_id, "long_name", + $ "Outer-region Delta_prime diagonal, referenced to unit "// + $ "normalised poloidal flux (as written by STRIDE)") ) + CALL sl_check( nf90_def_var(ncid, "Delta_prime_rs_rational", + $ nf90_double, (/qsing_dim, i_dim/), dprs_id) ) + CALL sl_check( nf90_put_att(ncid, dprs_id, "long_name", + $ "Delta_prime diagonal referenced to the minor radius "// + $ "r_s, K^(2*alpha)*Delta_prime; the value used in the "// + $ "layer matching") ) + CALL sl_check( nf90_def_var(ncid, "k_ref", nf90_double, + $ qsing_dim, kref_id) ) + CALL sl_check( nf90_put_att(ncid, kref_id, "long_name", + $ "Reference-length factor K = r_s*dpsi_N/dr") ) + CALL sl_check( nf90_def_var(ncid, "alpha_mercier", nf90_double, + $ qsing_dim, alpha_id) ) + CALL sl_check( nf90_put_att(ncid, alpha_id, "long_name", + $ "Mercier exponent sqrt(-D_I)") ) CALL sl_check( nf90_def_var(ncid, "Delta_crit_rational", $ nf90_double, qsing_dim, dc_id) ) @@ -432,8 +452,15 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c write complex Delta' as a RESHAPE'd (msing, 2) real array. c----------------------------------------------------------------------- CALL sl_check( nf90_put_var(ncid, dpp_id, + $ RESHAPE( (/sl_in%Re_dp_psi_arr, sl_in%Im_dp_psi_arr/), + $ (/msing, 2/) )) ) + CALL sl_check( nf90_put_var(ncid, dprs_id, $ RESHAPE( (/sl_in%Re_dp_arr, sl_in%Im_dp_arr/), $ (/msing, 2/) )) ) + CALL sl_check( nf90_put_var(ncid, kref_id, + $ sl_in%k_ref_arr) ) + CALL sl_check( nf90_put_var(ncid, alpha_id, + $ sl_in%alpha_arr) ) CALL sl_check( nf90_put_var(ncid, dc_id, $ sl_in%d_crit_arr) ) diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index 304fb5e41..d30087b6f 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -63,13 +63,13 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id,drr_id,dgeo_id + $ shear_id,resm_id,drr_id,dgeo_id,dir_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile REAL(r8) :: respsi - REAL(r8), DIMENSION(msing) :: dr_rationals + REAL(r8), DIMENSION(msing) :: dr_rationals,di_rationals INTEGER, DIMENSION(msing) :: resm INTEGER :: ising,jsing @@ -93,10 +93,12 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, ev = CMPLX(evi, 0.0) et = CMPLX(eti, 0.0) - ! evaluate resistive interchange parameter on rational surfaces + ! evaluate the Mercier (D_I) and resistive interchange (D_R) + ! indices on rational surfaces DO i=1,msing respsi = sing(i)%psifac CALL spline_eval(locstab,respsi,0) + di_rationals(i)=locstab%f(1)/respsi dr_rationals(i)=locstab%f(2)/respsi END DO c----------------------------------------------------------------------- @@ -209,6 +211,12 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, $ resm_id) ) CALL check( nf90_def_var(ncid, "dr_rational", nf90_double, $ r_dim, drr_id) ) + CALL check( nf90_put_att(ncid,drr_id,"long_name", + $ "Resistive Interchange Index D_R at Rational Surfaces") ) + CALL check( nf90_def_var(ncid, "di_rational", nf90_double, + $ r_dim, dir_id) ) + CALL check( nf90_put_att(ncid,dir_id,"long_name", + $ "Mercier Index D_I at Rational Surfaces") ) ENDIF ! define variables IF(debug_flag) PRINT *," - Defining variables in netcdf" @@ -276,6 +284,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, CALL check( nf90_put_var(ncid,resm_id, resm) ) CALL check( nf90_put_var(ncid,dgeo_id, dgeo) ) CALL check( nf90_put_var(ncid,drr_id, dr_rationals)) + CALL check( nf90_put_var(ncid,dir_id, di_rationals)) ENDIF IF(debug_flag) PRINT *," - Putting profile variables in netcdf" From af715b72698076b0f2ad0766a62221acce40cd0b Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:30:15 -0400 Subject: [PATCH 102/118] SLAYER - BUGFIX - Normalize D by the electron diamagnetic share, not the temperature ratio D_norm used sqrt(tau/(1+tau)) with tau = T_i/T_e. Fitzpatrick's definition is D = S^(1/3) * iota_e^(1/2) * d_beta/r_s with iota_e = Q_e/(Q_e - Q_i), which reduces to 1/(1+tau) = T_e/(T_e+T_i) for equal electron and ion gradient ratios: the old form had the two temperatures transposed, and the two agree only at T_i = T_e. D_norm is now built from the iota_e the code already computes, through slayer_d_norm, and is recomputed after any namelist override of Q_e or Q_i. A non-positive iota_e (same-sign diamagnetic frequencies) stops with a message instead of producing a NaN. DIII-D-like example, 2/1 surface (T_i/T_e = 1.20, iota_e = 0.39): D_norm 3.24 -> 2.75, uncoupled growth rate 86.0 -> 79.5 1/s. Same defect and fix as OpenFUSIONToolkit/GPEC#434. Co-Authored-By: Claude Opus 5.5 --- slayer/growthrates.f | 3 ++- slayer/layerinputs.f | 7 ++++-- slayer/params.f | 52 +++++++++++++++++++++++++++++++++++++++++--- slayer/sglobal.f | 2 ++ slayer/slayer.f | 21 ++++++++++++++++++ 5 files changed, 79 insertions(+), 6 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 5f06f8b64..5324c1b1b 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -95,7 +95,8 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%d_beta_arr(n_k),sl_in%gammafac_arr(n_k), $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k), $ sl_in%Re_dp_psi_arr(n_k),sl_in%Im_dp_psi_arr(n_k), - $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k)) + $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k), + $ sl_in%D_fac_arr(n_k)) c namelist inputs are taken as already r_s-referenced: identity c reference-length conversion (K = 1). sl_in%k_ref_arr = 1.0_r8 diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 0e4914a99..7b4a2da11 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -394,7 +394,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%Re_dp_arr(msing), sl_in%Im_dp_arr(msing), $ sl_in%d_crit_arr(msing), sl_in%P_tor_arr(msing), $ sl_in%P_perp_arr(msing), sl_in%tau_arr(msing), - $ sl_in%D_norm_arr(msing), + $ sl_in%D_norm_arr(msing), sl_in%D_fac_arr(msing), $ sl_in%d_beta_arr(msing), sl_in%gammafac_arr(msing), $ sl_in%c_beta_arr(msing), sl_in%lu_arr(msing), $ sl_in%Qconv_arr(msing), @@ -617,7 +617,10 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) sl_in%Q_i_arr(ising) = -tauk * omega_i sl_in%c_beta_arr(ising) = c_beta sl_in%d_beta_arr(ising) = d_beta - sl_in%D_norm_arr(ising) = D_norm +c D_norm uses iota_e from the Q_e, Q_i just set above + sl_in%D_fac_arr(ising) = D_fac + sl_in%D_norm_arr(ising) = slayer_d_norm(D_fac, + $ sl_in%Q_e_arr(ising),sl_in%Q_i_arr(ising)) sl_in%tau_arr(ising) = tau sl_in%omegas_arr(ising) = omega sl_in%psi_n_arr(ising) = respsi diff --git a/slayer/params.f b/slayer/params.f index 0f366e68f..8e7254e3f 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -9,6 +9,8 @@ c 1. params -- derive all normalised quantities (Q, ds, c_beta, c D_norm, P_perp, P_tor, lu, delta_crit, ...) for a c single rational surface and store them in sglobal_mod. +c 2. slayer_d_norm -- D_norm from D_fac and the diamagnetic +c frequencies. c======================================================================= MODULE params_mod @@ -184,10 +186,20 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- c Normalised beta-related width and Delta norm factor. c----------------------------------------------------------------------- -c d_beta uses Fitzpatrick's definition (tau' form) +c d_beta uses Fitzpatrick's definition (tau' form). +c D = S^(1/3) * iota_e^(1/2) * d_beta/r_s with +c iota_e = Q_e/(Q_e - Q_i), the electron share of the diamagnetic +c frequency (see slayer_d_norm). When this call does not set Q_e +c and Q_i, the equal-gradient-ratio value iota_e = T_e/(T_e + T_i) +c = 1/(1 + tau) is used provisionally; callers that set Q_e and Q_i +c afterwards must reset D_norm = slayer_d_norm(D_fac,Q_e,Q_i). d_beta = c_beta * d_i - D_norm = (d_beta/rs) * lu**(1.0/3.0) - $ * (tau/(1+tau))**(0.5) + D_fac = (d_beta/rs) * lu**(1.0/3.0) + IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN + D_norm = slayer_d_norm(D_fac,Q_e,Q_i) + ELSE + D_norm = D_fac * SQRT(1.0_r8/(1.0_r8+tau)) + END IF delta_n = lu**(1.0/3.0) / rs ! normalisation for Delta values @@ -262,5 +274,39 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- RETURN END SUBROUTINE params +c----------------------------------------------------------------------- +c subprogram 2. slayer_d_norm. +c Normalised ion-sound-radius parameter of the Fitzpatrick layer +c equations, D = S^(1/3) * iota_e^(1/2) * d_beta/r_s, from +c D_fac = S^(1/3)*d_beta/r_s and iota_e = Q_e/(Q_e - Q_i). +c iota_e must be positive, which holds when the electron and ion +c diamagnetic frequencies have opposite signs. +c----------------------------------------------------------------------- + FUNCTION slayer_d_norm(D_fac_in,Q_e_in,Q_i_in) + + REAL(r8), INTENT(IN) :: D_fac_in ! S^(1/3)*d_beta/r_s + REAL(r8), INTENT(IN) :: Q_e_in ! normalised electron diamag. + REAL(r8), INTENT(IN) :: Q_i_in ! normalised ion diamag. + REAL(r8) :: slayer_d_norm + REAL(r8) :: iota ! Q_e/(Q_e - Q_i) + + IF (Q_e_in == Q_i_in) THEN + WRITE(*,*) 'ERROR: Q_e = Q_i =',Q_e_in, + $ ', so iota_e = Q_e/(Q_e - Q_i) is undefined.' + STOP 'slayer_d_norm: Q_e equals Q_i' + END IF + iota = Q_e_in / (Q_e_in - Q_i_in) + IF (.NOT. (iota > 0.0_r8)) THEN + WRITE(*,*) 'ERROR: iota_e = Q_e/(Q_e - Q_i) =',iota, + $ ' is not positive (Q_e =',Q_e_in,', Q_i =',Q_i_in,').' + WRITE(*,*) ' D_norm = S^(1/3)*sqrt(iota_e)*d_beta/r_s is' + WRITE(*,*) ' undefined. The electron and ion diamagnetic' + WRITE(*,*) ' frequencies are expected to have opposite signs.' + STOP 'slayer_d_norm: iota_e is not positive' + END IF + slayer_d_norm = D_fac_in * SQRT(iota) + + RETURN + END FUNCTION slayer_d_norm END MODULE params_mod \ No newline at end of file diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 88de29ba9..ed8f03566 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -73,6 +73,7 @@ MODULE sglobal_mod REAL(r8) :: ds ! normalised ion Larmor radius REAL(r8) :: c_beta ! compressional beta parameter REAL(r8) :: D_norm ! normalised beta-weighted ion scale + REAL(r8) :: D_fac ! D_norm / sqrt(iota_e) REAL(r8) :: delta_n ! Delta normalisation factor REAL(r8) :: Qconv ! frequency normalisation (Cole) c --- diamagnetic and rotation frequencies @@ -161,6 +162,7 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: c_beta_arr(:) ! compressional beta REAL(r8), ALLOCATABLE :: d_beta_arr(:) ! beta-related width REAL(r8), ALLOCATABLE :: D_norm_arr(:) ! normalised D + REAL(r8), ALLOCATABLE :: D_fac_arr(:) ! D / sqrt(iota_e) REAL(r8), ALLOCATABLE :: tau_arr(:) ! T_i / T_e REAL(r8), ALLOCATABLE :: P_perp_arr(:) ! perp Prandtl number REAL(r8), ALLOCATABLE :: P_tor_arr(:) ! toroidal Prandtl diff --git a/slayer/slayer.f b/slayer/slayer.f index b4f0347ee..2a90cc4f6 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -518,6 +518,13 @@ PROGRAM slayer sl_in%Q_i_arr(k) = inQ_i_ovr(k) END IF END DO +c D_norm carries sqrt(iota_e): keep it consistent with the +c overridden Q_e, Q_i. + DO k = 1, n_k + sl_in%D_norm_arr(k) = slayer_d_norm( + $ sl_in%D_fac_arr(k),sl_in%Q_e_arr(k), + $ sl_in%Q_i_arr(k)) + END DO ELSE ! Single-surface mode: build inputs from namelist. @@ -550,6 +557,8 @@ PROGRAM slayer END IF IF (inds > 0.0) THEN D_norm = inds ! NAMELIST + ELSE + D_norm = slayer_d_norm(D_fac,Q_e,Q_i) END IF CALL allocate_inputs(n_k,sl_in) ! growthrates_mod @@ -570,6 +579,7 @@ PROGRAM slayer sl_in%P_tor_arr = (/ P_tor /) sl_in%tau_arr = (/ tau /) sl_in%D_norm_arr = (/ D_norm /) + sl_in%D_fac_arr = (/ D_fac /) sl_in%d_beta_arr = (/ d_beta /) sl_in%gammafac_arr = (/ gamma_fac /) sl_in%c_beta_arr = (/ c_beta /) @@ -642,6 +652,13 @@ PROGRAM slayer sl_in%Q_i_arr(k) = inQ_i_ovr(k) END IF END DO +c D_norm carries sqrt(iota_e): keep it consistent with the +c overridden Q_e, Q_i. + DO k = 1, n_k + sl_in%D_norm_arr(k) = slayer_d_norm( + $ sl_in%D_fac_arr(k),sl_in%Q_e_arr(k), + $ sl_in%Q_i_arr(k)) + END DO ELSE n_k = 1 @@ -677,6 +694,8 @@ PROGRAM slayer END IF IF (inds > 0.0) THEN D_norm = inds ! NAMELIST + ELSE + D_norm = slayer_d_norm(D_fac,Q_e,Q_i) END IF IF (.NOT. est_gamma_flag) THEN @@ -699,6 +718,7 @@ PROGRAM slayer sl_in%P_tor_arr = (/ P_tor /) sl_in%tau_arr = (/ tau /) sl_in%D_norm_arr = (/ D_norm /) + sl_in%D_fac_arr = (/ D_fac /) sl_in%d_beta_arr = (/ d_beta /) sl_in%gammafac_arr = (/ gamma_fac /) sl_in%c_beta_arr = (/ c_beta /) @@ -1048,6 +1068,7 @@ PROGRAM slayer sl_in%P_tor_arr = (/ P_tor /) sl_in%tau_arr = (/ tau /) sl_in%D_norm_arr = (/ D_norm /) + sl_in%D_fac_arr = (/ D_fac /) sl_in%d_beta_arr = (/ d_beta /) sl_in%gammafac_arr = (/ gamma_fac /) sl_in%c_beta_arr = (/ c_beta /) From ffa95f13ad492bb74097f4af3298617a8c8b982a Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:32:32 -0400 Subject: [PATCH 103/118] SLAYER - BUGFIX - Use the shear magnitude in the layer timescales and widths params() used the signed shear in the Alfven time, the long-mean-free- path parallel diffusivity, the island-width proxy W_d and the 'lar' critical Delta. On a reverse-shear surface that made the Alfven time and Lundquist number negative, so S^(1/3) and every quantity built on it was NaN. These are magnitudes and now use ABS(sval). No change for positive shear. Namelist-driven check at sval = -1.5: NaN before; now the same root as sval = +1.5. Same defect and fix as OpenFUSIONToolkit/GPEC#431. Co-Authored-By: Claude Opus 5.5 --- slayer/params.f | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/slayer/params.f b/slayer/params.f index 8e7254e3f..b8b93083a 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -124,7 +124,10 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, d_i = ( (mu_i*m_p) / (n_e*(chag**2)*mu0) )**0.5 ! ion skin depth [m] - tau_h = R0*(mu0*rho)**0.5 / (nn*sval*bt) ! Alfvén time [s] +c The layer timescales and widths below depend on the magnitude of +c the shear, not its sign: ABS(sval) keeps them positive on a +c reverse-shear surface. + tau_h = R0*(mu0*rho)**0.5 / (nn*ABS(sval)*bt) ! Alfvén time [s] tau_r = mu0*(rs**2.0)*sigma_par ! resistive time [s] (Fitzpatrick) IF (pr > 0.0_r8) THEN tau_v = tau_r / pr ! viscous time [s] @@ -222,11 +225,11 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, Wd = 0.1 ! initial guess DO wit = 1, 100 chi_par_lmfp = (2.0*R0*vte) - $ / (SQRT(pi)*nr*sval*Wd) + $ / (SQRT(pi)*nr*ABS(sval)*Wd) chi_par = (chi_par_smfp*chi_par_lmfp) $ / (chi_par_smfp + chi_par_lmfp) Wd_new = SQRT(8.0)*((chis(1)/chi_par)**0.25) - $ * (1.0/SQRT((rs/R0)*sval*nr)) + $ * (1.0/SQRT((rs/R0)*ABS(sval)*nr)) IF (ABS(Wd_new - Wd) / MAX(ABS(Wd), 1.0e-30_r8) $ < 1.0e-10_r8) THEN Wd = Wd_new @@ -243,7 +246,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, CASE('lar') dc_tmp = 0.5*(-dr_val)*(pi**1.5) $ *((chi_par/chis(1))**0.25) - $ *( (nr*sval)/(R0*rs) )**0.5 + $ *( (nr*ABS(sval))/(R0*rs) )**0.5 CASE('rfitzp') dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val) / Wd CASE('toroidal') From d43cfb53b1681d157757f9493dbaab11f2f9f839 Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:32:32 -0400 Subject: [PATCH 104/118] SLAYER - BUGFIX - Carry the toroidal mode number into the diamagnetic frequencies and layer parameters Three places lost the toroidal mode number n: - build_inputs computed omega_*e and omega_*i as (dp/dpsi)/(e n_e), the n = 1 value. omega_* = k_theta v_* = n (dp/dpsi)/(e n_e), so Q_e and Q_i were low by a factor n. Same defect and fix as OpenFUSIONToolkit/GPEC#433. - build_inputs declared a local array named nn, hiding the module-level nn that params() uses for the Alfven time. The layer parameters therefore used the slayer.in value of nn (zero if unset) while W_d used STRIDE's n. The module-level nn, nr, mr and the output file-name suffix are now set from the STRIDE run, with a warning if slayer.in disagrees. - The real copies mr, nr were only set in the est_gamma and params_flag branches, so a namelist-driven match_gamma run without est_gamma hit nr = 0 and stopped in the W_d iteration. They are now set once after the namelist read. No change at n = 1. Check at n = 2 on the DIII-D-like example: Q_e/tau_k at the q = 2 surface is 21074 rad/s against 10537 rad/s at n = 1. Co-Authored-By: Claude Opus 5.5 --- slayer/layerinputs.f | 35 +++++++++++++++++++++++++++++------ slayer/slayer.f | 6 ++++++ 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 7b4a2da11..70b20b256 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -357,7 +357,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr, te_arr, $ ni_arr, ti_arr, zeff_arr, bt_arr, rs_arr, R0_arr, $ mu_i_arr, omegas_e_arr, omegas_i_arr - INTEGER, DIMENSION(:), ALLOCATABLE :: nn, resm, nns_arr +c nn_arr is STRIDE's toroidal mode number. It must not be named nn: +c that would hide the module-level nn that params() reads. + INTEGER, DIMENSION(:), ALLOCATABLE :: nn_arr, resm, nns_arr c --- surface-integral workspace INTEGER :: msing, i, mthsurf ! surface count, loop idx, theta pts REAL(r8), DIMENSION(0:512) :: unitfun ! unit function for area integral @@ -380,7 +382,22 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) CALL read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational, $ psi_n_rational,dgeo,shear,r_o,my_bt0,my_psio,dr_vals, - $ di_vals,mpsi_arr,nn,resm) + $ di_vals,mpsi_arr,nn_arr,resm) + +c The toroidal mode number of the STRIDE run defines the layer +c problem: it sets the module-level nn used by params() (Alfven +c time) and by the output file names, whatever slayer.in holds. + IF (nn /= nn_arr(1) .AND. nn /= 0) THEN + WRITE(*,'(1x,a,i0,a,i0)') 'WARNING: slayer.in nn = ',nn, + $ ' replaced by the STRIDE toroidal mode number ',nn_arr(1) + END IF + nn = nn_arr(1) + IF (nn < 10) THEN + WRITE(UNIT=sn_str,FMT='(I1)') nn + sn_str = ADJUSTL(sn_str) + ELSE + WRITE(UNIT=sn_str,FMT='(I2)') nn + ENDIF mpsi = INT(mpsi_arr(1)) mthsurf = 512 ! poloidal segments for surface integral @@ -473,11 +490,16 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) CALL spline_eval(kin,respsi,1) c diamagnetic frequencies (rad/s) from GPEC kinetic splines. -c These compute the ELECTRON diamagnetic frequency directly. +c omega_* = k_theta*v_* = (m/r)*(dp/dr)/(e*n*B). In flux +c coordinates dpsi/dr = r*B_phi/q absorbs the q of m = n*q and +c leaves omega_* = n*(dp/dpsi)/(e*n_e): the toroidal mode +c number multiplies the n = 1 expression. omega_e = twopi*kin%f(4)*kin%f1(2)/(e*chi1*kin%f(2)) $ +twopi*kin%f1(4)/(e*chi1) omega_i = -twopi*kin%f(3)*kin%f1(1)/(e*zi*chi1*kin%f(1)) $ -twopi*kin%f1(3)/(e*zi*chi1) + omega_e = REAL(nn,r8)*omega_e + omega_i = REAL(nn,r8)*omega_i sl_in%omegas_e_arr(ising) = omega_e sl_in%omegas_i_arr(ising) = omega_i @@ -542,9 +564,10 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) mu_i_arr(ising) = mu_i mms = resm(ising) - nns = nn(1) - nns_arr(ising) = nn(1) - nr = nn(1) ! module-level toroidal mode number + nns = nn + nns_arr(ising) = nn + nr = REAL(nn,r8) ! module-level mode numbers (real) + mr = REAL(mms,r8) l_n = 0.0 l_t = 0.0 diff --git a/slayer/slayer.f b/slayer/slayer.f index 2a90cc4f6..38326c932 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -339,6 +339,12 @@ PROGRAM slayer READ(in_unit,NML=slayer_diagnose) CLOSE(UNIT=in_unit) + ! Real copies of the mode numbers, read by params() in every + ! namelist-driven branch below. build_inputs resets them from + ! the STRIDE run when read_eq is set. + mr = mm + nr = nn + ! Build toroidal-mode-number string for output filenames. IF (nn<10) THEN WRITE(UNIT=sn_str,FMT='(I1)') nn From 8e59462715e249b9e2fa7a286830b66e8482004f Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 9 Oct 2026 19:35:38 -0400 Subject: [PATCH 105/118] SLAYER - NEW FEATURE - Doppler-shift the coupled determinant by the ExB rotation The coupled determinant evaluated every surface's layer at the same frame frequency, as if the surfaces rotated together. The layer's Q is the mode frequency in the local ExB frame, so with one lab-frame eigenvalue surface k is evaluated at Q_k = Q*tau_k/tau_1 - tau_k*n*Omega_E,k using the ExB rotation already read from the kinetic file. Applied in coupled mode only (rotation_flag, default true): an uncoupled layer is solved in its own frame, where the shift only relabels the frequency. The coupled root is therefore reported in the lab frame. The scan window gets a Re(Q) centre (scan_center). Left unset, a coupled scan with rotation is centred on the Doppler-shifted branches, and a warning is printed when they do not all fit in the window. The uncoupled scan warns when -Q_e lies outside the window. Q_shift is written to the NetCDF file. Check with a real, diagonal Delta' on the DIII-D-like example: the coupled roots equal the uncoupled roots shifted by tau_1*n*Omega_E,k to 6 digits. With the full matrix the 2/1 root moves from -10.52 to +31.00 krad/s, with the growth rate unchanged at 79.5 1/s. Follows OpenFUSIONToolkit/GPEC#463. Co-Authored-By: Claude Opus 5.5 --- slayer/growthrates.f | 14 ++++++-- slayer/layerinputs.f | 4 ++- slayer/sglobal.f | 3 +- slayer/slayer.f | 75 ++++++++++++++++++++++++++++++++++++++++-- slayer/slayer_netcdf.f | 10 ++++++ 5 files changed, 98 insertions(+), 8 deletions(-) diff --git a/slayer/growthrates.f b/slayer/growthrates.f index 5324c1b1b..ddcb19731 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -96,7 +96,8 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k), $ sl_in%Re_dp_psi_arr(n_k),sl_in%Im_dp_psi_arr(n_k), $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k), - $ sl_in%D_fac_arr(n_k)) + $ sl_in%D_fac_arr(n_k),sl_in%q_shift_arr(n_k)) + sl_in%q_shift_arr = 0.0_r8 c namelist inputs are taken as already r_s-referenced: identity c reference-length conversion (K = 1). sl_in%k_ref_arr = 1.0_r8 @@ -264,6 +265,12 @@ FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c eigenvalue reaches surface k as tau_k*(gamma + i*omega) c = g_in*tau_k/tau_1, the normalisation its Q_e and Q_i use. g_tmp = g_in*(tauk/sl_in%Qconv_arr(1)) +c The layer's Q is the mode frequency in the local ExB +c frame, while the coupled scan runs in the lab frame: +c Q_layer = tau_k*omega_lab - tau_k*n*Omega_E. q_shift_arr +c holds that real offset (zero unless the driver sets it), +c and g = i*Q. + g_tmp = g_tmp + ifac*sl_in%q_shift_arr(k) delta_Q(k,k)=riccati_f() delta_Q(k,k)=delta_Q(k,k)* $ sl_in%lu_arr(k)**(1.0_r8/3.0_r8) @@ -386,7 +393,7 @@ END SUBROUTINE get_or_compute_v2 c----------------------------------------------------------------------- SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, $ scan_width, Q_num, AMR_passes, - $ coupling_flag) + $ coupling_flag, scan_center) IMPLICIT NONE @@ -396,6 +403,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, INTEGER, INTENT(IN) :: Q_num ! grid points per axis INTEGER, INTENT(IN) :: AMR_passes ! refinement passes REAL(r8), INTENT(IN) :: scan_width ! half-width of Re/Im scan window + REAL(r8), INTENT(IN) :: scan_center ! Re(Q) centre of the window TYPE(slayer_inputs_type), INTENT(IN) :: sl_in LOGICAL, INTENT(IN) :: coupling_flag ! coupled dispersion_det? c --- locals @@ -438,7 +446,7 @@ SUBROUTINE dispersion_AMR_v2(n_k, sl_in, msing_max, DO i = 1, Q_num - 1 DO j = 1, Q_num - 1 - x = -scan_width + DBLE(i-1) * step + x = scan_center - scan_width + DBLE(i-1) * step y = -scan_width + DBLE(j-1) * step n_amr_cells = n_amr_cells + 1 diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 70b20b256..91081f19b 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -416,7 +416,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%c_beta_arr(msing), sl_in%lu_arr(msing), $ sl_in%Qconv_arr(msing), $ sl_in%Re_dp_psi_arr(msing), sl_in%Im_dp_psi_arr(msing), - $ sl_in%k_ref_arr(msing), sl_in%alpha_arr(msing)) + $ sl_in%k_ref_arr(msing), sl_in%alpha_arr(msing), + $ sl_in%q_shift_arr(msing)) + sl_in%q_shift_arr = 0.0_r8 c --- allocate local kinetic arrays (for future NetCDF diagnostic output) ALLOCATE(ne_arr(msing), te_arr(msing), ni_arr(msing), diff --git a/slayer/sglobal.f b/slayer/sglobal.f index ed8f03566..7454aa930 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -166,7 +166,8 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: tau_arr(:) ! T_i / T_e REAL(r8), ALLOCATABLE :: P_perp_arr(:) ! perp Prandtl number REAL(r8), ALLOCATABLE :: P_tor_arr(:) ! toroidal Prandtl - REAL(r8), ALLOCATABLE :: omegas_arr(:) ! rotation [rad/s] + REAL(r8), ALLOCATABLE :: omegas_arr(:) ! ExB rotation per unit n [rad/s] + REAL(r8), ALLOCATABLE :: q_shift_arr(:) ! ExB Doppler shift of Q REAL(r8), ALLOCATABLE :: omegas_e_arr(:) ! omega_e [rad/s] REAL(r8), ALLOCATABLE :: omegas_i_arr(:) ! omega_i [rad/s] REAL(r8), ALLOCATABLE :: gammafac_arr(:) ! gamma conversion diff --git a/slayer/slayer.f b/slayer/slayer.f index 38326c932..03f1d075a 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -54,6 +54,7 @@ PROGRAM slayer LOGICAL :: match_gamma_flag ! asymptotically matched gamma LOGICAL :: Pperp_Ptor_flag ! use Fitzpatrick layer model LOGICAL :: coupling_flag ! coupled rational surfaces + LOGICAL :: rotation_flag ! ExB Doppler shift when coupled LOGICAL :: br_th_flag ! Br threshold test scan LOGICAL :: bal_flag ! torque balance scan LOGICAL :: stability_flag ! complex-Q delta scan @@ -101,6 +102,8 @@ PROGRAM slayer REAL(r8) :: dr_val ! radial derivative parameter REAL(r8) :: dgeo_val ! geometric factor parameter REAL(r8) :: scan_width ! half-width of complex-Q scan + REAL(r8) :: scan_center ! Re(Q) centre of complex-Q scan + REAL(r8) :: q_lo,q_hi,q_br ! expected coupled-branch Re(Q) c----------------------------------------------------------------------- c local scalars — normalized layer parameters (namelist overrides). c----------------------------------------------------------------------- @@ -193,6 +196,7 @@ PROGRAM slayer $ inds,intau,Q0,delta_prime,delta_n_p,ingamma, $ inQ_e_ovr,inQ_i_ovr NAMELIST/slayer_control/inum,jnum,knum,Q_num,scan_width, + $ scan_center,rotation_flag, $ AMR_passes,msing_max,dc_type,read_eq,Pperp_Ptor_flag, $ coupling_flag,QPscan_flag,Qscan_flag,QPescan_flag, $ Qbscan_flag,onscan_flag,otscan_flag,ntscan_flag, @@ -266,6 +270,10 @@ PROGRAM slayer knum = 100 ! 2-D scan axis-2 resolution Q_num = 100 ! stability scan Re(Q) resolution scan_width = 2.0 ! half-width for complex-Q scans + ! Re(Q) centre of the scans. Left at HUGE, it is chosen by the + ! code: zero, or the middle of the Doppler-shifted branches in + ! a coupled scan with rotation. + scan_center = HUGE(scan_center) AMR_passes = 4 ! AMR refinement levels msing_max = 2 ! max singular surfaces to process @@ -284,6 +292,7 @@ PROGRAM slayer match_gamma_flag = .FALSE. Pperp_Ptor_flag = .FALSE. coupling_flag = .FALSE. + rotation_flag = .TRUE. params_flag = .TRUE. input_flag = .FALSE. @@ -734,6 +743,53 @@ PROGRAM slayer END IF END IF +c----------------------------------------------------------------------- +c ExB Doppler shift and scan-window centre. +c Each uncoupled layer is solved in its own ExB frame, where a +c rotation only relabels the frequency, so no shift is applied. +c In the coupled determinant the surfaces share one lab-frame +c eigenvalue and surface k sees it Doppler-shifted by +c n*Omega_E,k: q_shift = -tau_k*n*Omega_E,k. In the scanned Q +c (normalised by tau_1) branch k then sits near +c tau_1*(n*Omega_E,k - Q_e,k/tau_k), taking the electron-drift +c frequency as the estimate of its own-frame root. +c----------------------------------------------------------------------- + sl_in%q_shift_arr = 0.0_r8 + IF (coupling_flag .AND. rotation_flag .AND. read_eq) THEN + q_lo = HUGE(q_lo) + q_hi = -HUGE(q_hi) + DO k = 1, MIN(n_k,msing_max) + sl_in%q_shift_arr(k) = -sl_in%Qconv_arr(k) + $ * REAL(nn,r8) * sl_in%omegas_arr(k) + q_br = sl_in%Qconv_arr(1)*( REAL(nn,r8) + $ * sl_in%omegas_arr(k) + $ - sl_in%Q_e_arr(k)/sl_in%Qconv_arr(k) ) + q_lo = MIN(q_lo,q_br) + q_hi = MAX(q_hi,q_br) + WRITE(*,'(A,I0,A,ES11.4,A,ES11.4)') + $ ' ExB rotation, surface ',k,': n*Omega_E [rad/s] =', + $ REAL(nn,r8)*sl_in%omegas_arr(k), + $ ', branch expected near Re(Q) =',q_br + END DO + IF (scan_center >= HUGE(scan_center)) + $ scan_center = 0.5_r8*(q_lo + q_hi) + IF (q_lo < scan_center - scan_width .OR. + $ q_hi > scan_center + scan_width) THEN + WRITE(*,'(A)') ' WARNING: the Doppler-shifted branches' + $ //' do not all fit in the scan window' + WRITE(*,'(A,2ES11.3,A,2ES11.3,A)') + $ ' Re(Q) = [',scan_center-scan_width, + $ scan_center+scan_width,'], branches span [', + $ q_lo,q_hi,'].' + WRITE(*,'(A)') ' Increase scan_width or set ' + $ //'scan_center, or a coupled root may be missed.' + END IF + END IF + IF (scan_center >= HUGE(scan_center)) scan_center = 0.0_r8 + WRITE(*,'(A,ES11.4,A,ES11.4)') + $ ' Scan window: Re(Q) centre =',scan_center, + $ ', half-width =',scan_width + c----------------------------------------------------------------------- c allocate output arrays for AMR delta storage. c----------------------------------------------------------------------- @@ -802,8 +858,17 @@ PROGRAM slayer WRITE(*,'(A,I0,A)') 'Calling uncoupled AMR scan on q = ', $ sl_in%qval_arr(k),' rational surface:' + ! The tearing root usually sits near the electron + ! drift frequency, Re(Q) = -Q_e. + IF (ABS(-Q_e - scan_center) > scan_width) THEN + WRITE(*,'(A,ES10.3,A)') + $ ' WARNING: Re(Q) = -Q_e =',-Q_e, + $ ' is outside the scan window.' + WRITE(*,'(A)') ' Increase scan_width or set ' + $ //'scan_center, or the root may be missed.' + END IF CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, - $ Q_num,AMR_passes,coupling_flag) + $ Q_num,AMR_passes,coupling_flag,scan_center) ! Zeros of the dispersion function in this surface's ! own ExB frame; the most unstable one is reported as @@ -931,7 +996,7 @@ PROGRAM slayer IF (AMR_flag .AND. coupling_flag) THEN CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, - $ Q_num,AMR_passes,coupling_flag) + $ Q_num,AMR_passes,coupling_flag,scan_center) ! Zeros of the coupled determinant. Q is normalised by ! the first surface's tau_k. The coupled eigenvalue is @@ -993,8 +1058,12 @@ PROGRAM slayer DO i = 1, (Q_num+1) DO j = 1, Q_num + ! This scan passes g = gamma_hat + i*omega_hat + ! directly, so its imaginary axis is the frequency + ! and carries the scan-window centre. ing_coarse = -scan_width + (i - 1) * ing_step - iing_coarse = -scan_width + (j - 1) * ing_step + iing_coarse = scan_center - scan_width + $ + (j - 1) * ing_step inQs(i) = ing_coarse iinQs(j) = iing_coarse diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 85fd44231..d45e20af7 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -117,6 +117,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: dpp_id ! "Delta_prime_rational" (complex) INTEGER :: dprs_id ! "Delta_prime_rs_rational" (complex) INTEGER :: kref_id ! "k_ref" + INTEGER :: qsh_id ! "Q_shift" INTEGER :: alpha_id ! "alpha_mercier" INTEGER :: dc_id ! "Delta_crit_rational" INTEGER :: dels_db_id ! "delta_s_d_b" (complex) @@ -297,6 +298,13 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ nf90_double, qsing_dim, qr_id) ) CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, $ qsing_dim, omegas_id) ) + CALL sl_check( nf90_put_att(ncid, omegas_id, "long_name", + $ "ExB rotation frequency per unit n [rad/s]") ) + CALL sl_check( nf90_def_var(ncid, "Q_shift", nf90_double, + $ qsing_dim, qsh_id) ) + CALL sl_check( nf90_put_att(ncid, qsh_id, "long_name", + $ "ExB Doppler shift -tau_k*n*Omega_E applied to Q in "// + $ "the coupled determinant (zero when not applied)") ) CALL sl_check( nf90_def_var(ncid, "tau_k", nf90_double, $ qsing_dim, qc_id) ) CALL sl_check( nf90_def_var(ncid, "Q_e", nf90_double, @@ -435,6 +443,8 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ sl_in%omegas_arr)) CALL sl_check( nf90_put_var(ncid, S_id, $ sl_in%lu_arr) ) + CALL sl_check( nf90_put_var(ncid, qsh_id, + $ sl_in%q_shift_arr) ) CALL sl_check( nf90_put_var(ncid, qc_id, $ sl_in%Qconv_arr) ) CALL sl_check( nf90_put_var(ncid, Q_e_id, From 6445606f0f926905c3867993e5e220a9dccbaaac Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 14 Oct 2026 15:38:43 -0400 Subject: [PATCH 106/118] SLAYER - MINOR - Give every real literal in params.f the r8 kind Exponents such as lu**(1.0/3.0), constants such as SQRT(2.0) and LOG(10.0), and the empirical coefficients were evaluated in single precision before promotion. Results move at the 1e-7 relative level. Co-Authored-By: Claude Opus 5.5 --- slayer/params.f | 80 ++++++++++++++++++++++++------------------------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/slayer/params.f b/slayer/params.f index b8b93083a..b21bc564e 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -90,26 +90,26 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c Coulomb logarithm, basic plasma quantities, and Spitzer c resistivity. c----------------------------------------------------------------------- - lnLamb = 24 + 3.0*LOG(10.0) - 0.5*LOG(n_e) + LOG(t_e) + lnLamb = 24 + 3.0_r8*LOG(10.0_r8) - 0.5_r8*LOG(n_e) + LOG(t_e) tau = t_i / t_e ! T_i / T_e - tau_i = 6.6e17*mu_i**0.5*(t_i/1e3)**1.5 + tau_i = 6.6e17_r8*mu_i**0.5_r8*(t_i/1e3_r8)**1.5_r8 $ / (n_e*lnLamb) ! ion collision time [s] - eta = 1.65e-9*lnLamb / (t_e/1e3)**1.5 ! Spitzer resistivity (Wesson) + eta = 1.65e-9_r8*lnLamb / (t_e/1e3_r8)**1.5_r8 ! Spitzer resistivity (Wesson) rho = (mu_i*m_p)*n_e ! mass density [kg/m^3] c----------------------------------------------------------------------- c Electron-electron collision time (Braginskii) and Spitzer-Härm c parallel conductivity. c----------------------------------------------------------------------- - tau_ee_num = 6.0*SQRT(2.0)*(pi**1.5) - $ *(eps0**2.0)*(m_e**0.5)*(t_e**1.5) - tau_ee_denom = lnLamb*(chag**2.5)*n_e + tau_ee_num = 6.0_r8*SQRT(2.0_r8)*(pi**1.5_r8) + $ *(eps0**2.0_r8)*(m_e**0.5_r8)*(t_e**1.5_r8) + tau_ee_denom = lnLamb*(chag**2.5_r8)*n_e tau_ee = tau_ee_num / tau_ee_denom - sigma_par_1 = ( SQRT(2.0) + 13.0*(Zeff/4.0) ) - $ / (Zeff*(SQRT(2.0) + Zeff)) - sigma_par_2 = (n_e * (chag**2.0) * tau_ee) / m_e + sigma_par_1 = ( SQRT(2.0_r8) + 13.0_r8*(Zeff/4.0_r8) ) + $ / (Zeff*(SQRT(2.0_r8) + Zeff)) + sigma_par_2 = (n_e * (chag**2.0_r8) * tau_ee) / m_e sigma_par = sigma_par_1 * sigma_par_2 c----------------------------------------------------------------------- @@ -119,16 +119,16 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c module-level variables set before calling params(). c----------------------------------------------------------------------- b_l = (nr/mr)*rs*sval*bt/R0 ! characteristic B [T] - v_a = b_l / (mu0*rho)**0.5 ! Alfvén velocity [m/s] - rho_s = 1.02e-4*(mu_i*t_e)**0.5 / bt ! ion Larmor at T_e [m] - d_i = ( (mu_i*m_p) / (n_e*(chag**2)*mu0) )**0.5 + v_a = b_l / (mu0*rho)**0.5_r8 ! Alfvén velocity [m/s] + rho_s = 1.02e-4_r8*(mu_i*t_e)**0.5_r8 / bt ! ion Larmor at T_e [m] + d_i = ( (mu_i*m_p) / (n_e*(chag**2)*mu0) )**0.5_r8 ! ion skin depth [m] c The layer timescales and widths below depend on the magnitude of c the shear, not its sign: ABS(sval) keeps them positive on a c reverse-shear surface. - tau_h = R0*(mu0*rho)**0.5 / (nn*ABS(sval)*bt) ! Alfvén time [s] - tau_r = mu0*(rs**2.0)*sigma_par ! resistive time [s] (Fitzpatrick) + tau_h = R0*(mu0*rho)**0.5_r8 / (nn*ABS(sval)*bt) ! Alfvén time [s] + tau_r = mu0*(rs**2.0_r8)*sigma_par ! resistive time [s] (Fitzpatrick) IF (pr > 0.0_r8) THEN tau_v = tau_r / pr ! viscous time [s] visc = rho*rs**2.0_r8 / tau_v @@ -145,7 +145,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c Qconv converts dimensional frequencies to the normalised Q c used in the SLAYER dispersion relation (Cole scaling). c----------------------------------------------------------------------- - Qconv = lu**(1.0/3.0) * tau_h ! frequency normalisation (Cole) + Qconv = lu**(1.0_r8/3.0_r8) * tau_h ! frequency normalisation (Cole) tauk = Qconv ! stored in sglobal_mod Q = Qconv * omega ! normalised rotation frequency @@ -154,20 +154,20 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c compute omega_e/omega_i by other means must set Q_e and Q_i c themselves afterwards. IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN - omega_e = -t_e/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval - omega_i = t_i/(bt*R0)*(1.0/l_n + 1.0/l_t)*qval + omega_e = -t_e/(bt*R0)*(1.0_r8/l_n + 1.0_r8/l_t)*qval + omega_i = t_i/(bt*R0)*(1.0_r8/l_n + 1.0_r8/l_t)*qval Q_e = -Qconv * omega_e Q_i = -Qconv * omega_i END IF c normalised ion Larmor radius (critical stability parameter) - ds = lu**(1.0/3.0) * rho_s / rs + ds = lu**(1.0_r8/3.0_r8) * rho_s / rs c----------------------------------------------------------------------- c Plasma beta and Prandtl-number-like transport ratios. c----------------------------------------------------------------------- - lbeta = (5.0/3.0)*mu0*n_e*chag*(t_e+t_i) / bt**2.0 - c_beta = (lbeta / (1.0+lbeta))**0.5 + lbeta = (5.0_r8/3.0_r8)*mu0*n_e*chag*(t_e+t_i) / bt**2.0_r8 + c_beta = (lbeta / (1.0_r8+lbeta))**0.5_r8 c kappa-based P_perp (JKP's definition, to implement later if desired) c K_val = chis(3) / eta @@ -180,10 +180,10 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c END IF c effective perpendicular and toroidal Prandtl numbers - tau_perp = (rs**2.0) / chis(1) + tau_perp = (rs**2.0_r8) / chis(1) P_perp = tau_r / tau_perp ! perp magnetic Prandtl number - tau_tor = (rs**2.0) / chis(2) + tau_tor = (rs**2.0_r8) / chis(2) P_tor = tau_r / tau_tor ! toroidal magnetic Prandtl number c----------------------------------------------------------------------- @@ -197,14 +197,14 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c = 1/(1 + tau) is used provisionally; callers that set Q_e and Q_i c afterwards must reset D_norm = slayer_d_norm(D_fac,Q_e,Q_i). d_beta = c_beta * d_i - D_fac = (d_beta/rs) * lu**(1.0/3.0) + D_fac = (d_beta/rs) * lu**(1.0_r8/3.0_r8) IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN D_norm = slayer_d_norm(D_fac,Q_e,Q_i) ELSE D_norm = D_fac * SQRT(1.0_r8/(1.0_r8+tau)) END IF - delta_n = lu**(1.0/3.0) / rs ! normalisation for Delta values + delta_n = lu**(1.0_r8/3.0_r8) / rs ! normalisation for Delta values c----------------------------------------------------------------------- c Critical Deltaprime (dc_tmp) via iterative chi_parallel calculation. @@ -216,20 +216,20 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c 'toroidal' -- toroidal geometry using dgeo_val c default -- dc_tmp = 0 c----------------------------------------------------------------------- - IF (ABS(dr_val) > 0.0) THEN + IF (ABS(dr_val) > 0.0_r8) THEN - vte = SQRT((2.0*(t_e*chag)) / m_e) - chi_par_smfp = (1.581*tau_ee*(vte**2.0)) - $ / (1.0 + 0.2535*Zeff) + vte = SQRT((2.0_r8*(t_e*chag)) / m_e) + chi_par_smfp = (1.581_r8*tau_ee*(vte**2.0_r8)) + $ / (1.0_r8 + 0.2535_r8*Zeff) - Wd = 0.1 ! initial guess + Wd = 0.1_r8 ! initial guess DO wit = 1, 100 - chi_par_lmfp = (2.0*R0*vte) + chi_par_lmfp = (2.0_r8*R0*vte) $ / (SQRT(pi)*nr*ABS(sval)*Wd) chi_par = (chi_par_smfp*chi_par_lmfp) $ / (chi_par_smfp + chi_par_lmfp) - Wd_new = SQRT(8.0)*((chis(1)/chi_par)**0.25) - $ * (1.0/SQRT((rs/R0)*ABS(sval)*nr)) + Wd_new = SQRT(8.0_r8)*((chis(1)/chi_par)**0.25_r8) + $ * (1.0_r8/SQRT((rs/R0)*ABS(sval)*nr)) IF (ABS(Wd_new - Wd) / MAX(ABS(Wd), 1.0e-30_r8) $ < 1.0e-10_r8) THEN Wd = Wd_new @@ -244,20 +244,20 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, SELECT CASE(dc_type) CASE('lar') - dc_tmp = 0.5*(-dr_val)*(pi**1.5) - $ *((chi_par/chis(1))**0.25) - $ *( (nr*ABS(sval))/(R0*rs) )**0.5 + dc_tmp = 0.5_r8*(-dr_val)*(pi**1.5_r8) + $ *((chi_par/chis(1))**0.25_r8) + $ *( (nr*ABS(sval))/(R0*rs) )**0.5_r8 CASE('rfitzp') - dc_tmp = -(SQRT(2.0)*(pi**(1.5))*dr_val) / Wd + dc_tmp = -(SQRT(2.0_r8)*(pi**(1.5_r8))*dr_val) / Wd CASE('toroidal') - dc_tmp = 0.5*(-dr_val)*(pi**1.5) - $ *((chi_par/chis(1))**0.25)*dgeo_val + dc_tmp = 0.5_r8*(-dr_val)*(pi**1.5_r8) + $ *((chi_par/chis(1))**0.25_r8)*dgeo_val CASE default - dc_tmp = 0.0 + dc_tmp = 0.0_r8 END SELECT ELSE - dc_tmp = 0.0 + dc_tmp = 0.0_r8 END IF c----------------------------------------------------------------------- From 70fec274356343d870f51311b05c94f06356269d Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 14 Oct 2026 15:38:52 -0400 Subject: [PATCH 107/118] SLAYER - BUGFIX - Keep the imaginary part of the Delta' diagonal in the uncoupled matching The uncoupled dispersion used Re(Delta'_kk) only, while the coupled determinant uses the complex matrix, so the uncoupled result was not the diagonal limit of the coupled one. delta_eff is now complex, as in the Julia GPEC surface coupling. DIII-D-like example, dc_type none: 2/1 growth rate 79.55 -> 79.64 1/s; the 4/1, whose STRIDE Delta' has a large imaginary part, moves -306.6 -> -336.1 1/s. Co-Authored-By: Claude Opus 5.5 --- slayer/sglobal.f | 4 ++-- slayer/slayer.f | 12 ++++++++---- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 7454aa930..5df0b5026 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -84,8 +84,8 @@ MODULE sglobal_mod REAL(r8) :: Q_i ! normalised ion diamagnetic Q c --- stability / Delta_crit REAL(r8) :: dc_tmp ! computed Delta_crit - REAL(r8) :: delta_eff ! effective Deltaprime shift - CHARACTER(20) :: dc_type ! dc formula selector ('lar','rfitzp','toroidal') + COMPLEX(r8) :: delta_eff ! (Deltaprime - Delta_crit)/S^(1/3) + CHARACTER(20) :: dc_type ! dc formula: 'rfitzp','lar','toroidal','none' c --- solver workspace / results COMPLEX(r8) :: g_tmp ! temporary complex growth rate REAL(r8) :: gamma_fac ! growth-rate conversion factor diff --git a/slayer/slayer.f b/slayer/slayer.f index 03f1d075a..be50cbb89 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -842,12 +842,16 @@ PROGRAM slayer WRITE(*,*)"D_norm: ",D_norm WRITE(*,*)"tauk: ",tauk WRITE(*,*)"iota_e: ",iota_e - WRITE(*,*)"Delta_prime: ",sl_in%Re_dp_arr(k) + WRITE(*,*)"Delta_prime (r_s ref.): ",sl_in%Re_dp_arr(k), + $ sl_in%Im_dp_arr(k) WRITE(*,*)"Delta_crit: ",sl_in%d_crit_arr(k) - ! Calculate (Deltaprime - D_crit)/S^1/3 - delta_eff = (sl_in%Re_dp_arr(k) - - $ sl_in%d_crit_arr(k))/(sl_in%lu_arr(k)**(1.0/3.0)) + ! (Deltaprime - Delta_crit)/S^(1/3), with the complex + ! Deltaprime diagonal so that the uncoupled matching is + ! the diagonal limit of the coupled determinant. + delta_eff = (CMPLX(sl_in%Re_dp_arr(k),sl_in%Im_dp_arr(k), + $ KIND=r8) - sl_in%d_crit_arr(k)) + $ /(sl_in%lu_arr(k)**(1.0_r8/3.0_r8)) pe = 0.0 c----------------------------------------------------------------------- From 6b6b73a9f0c1976f725bf7f9e4e50a028e2f9ea0 Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 14 Oct 2026 15:38:52 -0400 Subject: [PATCH 108/118] SLAYER - BUGFIX - Harden the matched growth-rate path and default to the rfitzp critical Delta - dc_type defaults to 'rfitzp' (here and in input/slayer.in). A misspelt dc_type stops the run instead of silently dropping the critical Delta, and 'toroidal' warns that it is experimental. - The coupled determinant takes any number of surfaces (LU via LAPACK above rank 3) instead of stopping above 3, and msing_max = 1 goes through the same matrix path. msing_max is clipped to the number of surfaces, and coupling_flag without read_eq stops with a message instead of reading an unallocated Delta' matrix. - riccati_f returns NaN when LSODE fails, so the scan and the root search skip the point instead of using an unconverged Delta. - zeff and mu_i come from slayer.in in read_eq mode; they were hard-coded to 2. - Surfaces are labelled by their resonant m; INT(q) mislabelled n > 1 surfaces. The NetCDF q_rational holds the real q. - An estimate-only run (est_gamma_flag without match_gamma_flag) crashed in the unused baseline Riccati call and resized per-surface outputs to length 1. Both fixed, and the NetCDF writer no longer touches AMR data that a run did not produce. - input/slayer.in: uncoupled by default, new options documented (rotation_flag, scan_center), comments corrected (omega in rad/s, delta_prime in the r_s reference). Co-Authored-By: Claude Opus 5.5 --- input/slayer.in | 36 +++---- slayer/delta.f | 7 ++ slayer/growthrates.f | 218 +++++++++++++++++++---------------------- slayer/layerinputs.f | 44 +++++---- slayer/sglobal.f | 3 +- slayer/slayer.f | 81 +++++++++++---- slayer/slayer_netcdf.f | 36 +++++-- 7 files changed, 246 insertions(+), 179 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index 24077b95f..d2a37879b 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -1,6 +1,6 @@ &SLAYER_INPUT input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table - infile='' ! Path to ascii table of profile quantities read when using input_flag + infile='' ! Path to the kinetic profile file (read_eq=t), or to an ascii table of surface quantities (input_flag=t) ncfile='' ! Path to netCDF file of STRIDE outputs params_flag=f ! calculates normalized parameters from profile quantities ! >>> @@ -15,14 +15,14 @@ bt=2.0 ! toroidal field [T] rs=0.5 ! minor radius of resonant surface [m] R0=1.67 ! major radius of magnetic axis [m] - omega=5.00E+03 ! ExB frequency [Hz] + omega=5.00E+03 ! ExB rotation frequency [rad/s] l_t=0.11 ! temperature gradient scale length l_n=0.25 ! density gradient scale length qval=2.0 ! q of resonant surface - mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma - zeff=2.0 ! plasma Z_effective - dr_val=-0.1 ! GGJ resistive interchange criterion D_R - dgeo_val=10.0 ! J.W. Connor geometric prefactor for Delta_crit + mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma. Also used when read_eq=t + zeff=2.0 ! plasma Z_effective. Also used when read_eq=t (the kinetic file's Z_eff is not used) + dr_val=-0.1 ! GGJ resistive interchange index D_R (taken from STRIDE when read_eq=t) + dgeo_val=10.0 ! J.W. Connor geometric prefactor for the experimental dc_type="toroidal" (taken from STRIDE when read_eq=t) chi_p_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular energy diffusivity profile chi_t_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular ion momentum diffusivity profile kappa_prof=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 ! Rational surface thermal conductivity profile (NOTE: set > 0 to override chi_p_prof) @@ -38,7 +38,7 @@ inds=0.0 ! normalized ion sound radius, or normalized ion skin depth. Set /= 0.0 to override internal calculation intau=1.0 ! ratio of ion to electron temperature Q0=1.0 ! unnecessary placeholder variable for inQ? - delta_prime=(0.0,0.0) ! input Delta' or (Delta' - Delta_crit) for growth rate calculation, set /= 0.0 to override internal calculation + delta_prime=(0.0,0.0) ! input Delta' for the growth rate calculation when read_eq=f, referenced to the minor radius (r_s*Delta') delta_n_p=(0.01,0.01) ! delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). ingamma=(0.0,0.0) ! input (Re(Q),Im(Q)) to calculate inner layer Delta. Set /= 0.0 to override internal root finding / @@ -47,14 +47,16 @@ inum=400 ! resolution to find error field thresholds. jnum=100 ! resolution for 2d scan along with Q,omega. knum=100 ! resolution for 2d scan along with the other. - Q_num=100 ! resolution for stability scan along Re(Q),Im(Q) axes - scan_width=1.5 ! stability scan width for Re(Q),Im(Q) scan - AMR_passes=4 - msing_max=2 ! number of surfaces to include in coupled tearing growth rate calculation - dc_type="toroidal" ! Delta_crit type, options are "toroidal", "lar", and "rfitzp" - read_eq=f ! read in equilibrium quantities from STRIDE and kinetic file. Set all normalized params to 0.0 + Q_num=100 ! number of points per axis of the initial Re(Q),Im(Q) scan grid + scan_width=1.5 ! half-width of the Re(Q),Im(Q) scan window, in normalized Q + AMR_passes=4 ! number of adaptive refinement passes of the scan grid + !scan_center=0.0 ! Re(Q) centre of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan + msing_max=2 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t + dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", "none", or "toroidal" (experimental) + read_eq=f ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation - coupling_flag=t ! Solve determinant problem and output 2D scan + coupling_flag=f ! solve the coupled multi-surface determinant instead of each surface separately. Requires read_eq=t + rotation_flag=t ! Doppler-shift each surface by its ExB rotation in the coupled determinant (root reported in the lab frame) QPscan_flag=f ! scan (Q,P) space for delta and torque. Qscan_flag=f ! scan Q space QPescan_flag=f ! scan (Q,Pe) space for delta and torque. @@ -75,11 +77,11 @@ bin_flag=f ! writes results to binary files netcdf_flag=f ! writes results to netcdf files est_gamma_flag=t ! Calculate and output growth rate estimate - match_gamma_flag=t ! Find Delta_hat = Delta_prime match to solve for growth rate + match_gamma_flag=t ! match the layer Delta to Delta' and solve for the growth rate stability_flag=f ! calculate delta dependence on complex Q stabscan_flag=f ! Generate Re(Q),Im(Q) scan and output as ASCII - coupled_stabscan_flag=f ! Generate Re(Q),Im(Q) scan and output as ASCII - amr_flag=t ! Generate Re(Q),Im(Q) scan and output as ASCII + coupled_stabscan_flag=f ! uniform-grid scan of the coupled determinant, output as ASCII + amr_flag=t ! adaptive Re(Q),Im(Q) scan and root extraction for match_gamma_flag (results in the netcdf file) br_th_flag=f ! Calculate br_th bal_flag=f ! calculate the resonant field penetration threshold from torque balance / diff --git a/slayer/delta.f b/slayer/delta.f index 67a2947cf..38da8630b 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -21,6 +21,7 @@ MODULE delta_mod c----------------------------------------------------------------------- USE sglobal_mod + USE ieee_arithmetic, ONLY: ieee_value, ieee_quiet_nan IMPLICIT NONE @@ -443,6 +444,12 @@ FUNCTION riccati_f() c --- extract Delta from final W derivative at p_min CALL w_der_f(neq,my_p,W,dWdp) riccati_f = pi / dWdp(1) +c A failed integration (istate < 0) leaves W short of p_min. Return +c NaN so that scans and the root search skip the point instead of +c using a Delta built from an unconverged W. + IF (istate < 0) riccati_f = CMPLX( + $ ieee_value(1.0_r8, ieee_quiet_nan), + $ ieee_value(1.0_r8, ieee_quiet_nan), KIND=r8) END FUNCTION riccati_f c----------------------------------------------------------------------- diff --git a/slayer/growthrates.f b/slayer/growthrates.f index ddcb19731..e76de684c 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -14,7 +14,7 @@ MODULE growthrates_mod c 3. allocate_outputs - allocate slayer_outputs_type c 4. shrink_array - trim over-allocated scan arrays c 5. grow_array - expand scan arrays dynamically -c 6. calc_determinant - 2x2 / 3x3 complex determinant +c 6. calc_determinant - complex determinant c 7. dispersion_det - coupled dispersion determinant c 8. get_or_compute_v2 - hash-cached dispersion eval c 9. dispersion_AMR_v2 - AMR scan (cell-based storage) @@ -96,7 +96,8 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%c_beta_arr(n_k),sl_in%lu_arr(n_k),sl_in%Qconv_arr(n_k), $ sl_in%Re_dp_psi_arr(n_k),sl_in%Im_dp_psi_arr(n_k), $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k), - $ sl_in%D_fac_arr(n_k),sl_in%q_shift_arr(n_k)) + $ sl_in%D_fac_arr(n_k),sl_in%q_shift_arr(n_k), + $ sl_in%q_arr(n_k)) sl_in%q_shift_arr = 0.0_r8 c namelist inputs are taken as already r_s-referenced: identity c reference-length conversion (K = 1). @@ -150,167 +151,148 @@ SUBROUTINE grow_array(arr, old_size, new_size) END SUBROUTINE grow_array c----------------------------------------------------------------------- c subprogram 6. calc_determinant. -c Compute the determinant of a 2x2 or 3x3 complex matrix. -c Returns (0,0) and sets status=-1 for unsupported sizes. -c status=0 on success, -1 when nk is neither 2 nor 3. +c Determinant of an nk x nk complex matrix: closed forms for +c nk <= 3, LU factorisation (LAPACK zgetrf) above that. +c status=0 on success, -1 for nk < 1 or a failed factorisation. c----------------------------------------------------------------------- SUBROUTINE calc_determinant(matk, nk, detk, status) IMPLICIT NONE c --- arguments - INTEGER, INTENT(IN) :: nk ! matrix rank (2 or 3) + INTEGER, INTENT(IN) :: nk ! matrix rank COMPLEX(r8), DIMENSION(nk,nk), INTENT(IN) :: matk ! input matrix COMPLEX(r8), INTENT(OUT) :: detk ! determinant result - INTEGER, INTENT(OUT) :: status ! 0=success, -1=unsupported rank - + INTEGER, INTENT(OUT) :: status ! 0=success, -1=failure +c --- locals (LU path) + COMPLEX(r8), DIMENSION(nk,nk) :: lu_mat + INTEGER, DIMENSION(nk) :: ipiv + INTEGER :: info, i + status = 0 ! Initialize status as success - + SELECT CASE (nk) + CASE (1) + detk = matk(1,1) + CASE (2) ! 2x2 determinant: ad - bc detk = matk(1,1) * matk(2,2) - matk(1,2) * matk(2,1) - + CASE (3) ! 3x3 determinant using cofactor expansion along first row detk = matk(1,1)*(matk(2,2)*matk(3,3)-matk(2,3) $ *matk(3,2))-matk(1,2)*(matk(2,1)*matk(3,3) $ -matk(2,3)*matk(3,1))+matk(1,3)*(matk(2,1) $ *matk(3,2)-matk(2,2)*matk(3,1)) - + CASE default - ! Unsupported matrix size + IF (nk < 1) THEN detk = CMPLX(0.0_r8, 0.0_r8, KIND=r8) status = -1 - + ELSE + ! product of the LU diagonal, sign from the row exchanges. + ! info > 0 flags an exactly singular matrix, whose zero + ! pivot already makes the product zero. + lu_mat = matk + CALL zgetrf(nk, nk, lu_mat, nk, ipiv, info) + IF (info < 0) THEN + detk = CMPLX(0.0_r8, 0.0_r8, KIND=r8) + status = -1 + ELSE + detk = CMPLX(1.0_r8, 0.0_r8, KIND=r8) + DO i = 1, nk + detk = detk * lu_mat(i,i) + IF (ipiv(i) /= i) detk = -detk + END DO + END IF + END IF + END SELECT RETURN END SUBROUTINE calc_determinant c----------------------------------------------------------------------- c subprogram 7. dispersion_det. -c Compute the coupled dispersion determinant for n_k surfaces. +c Coupled dispersion determinant for the first msing_max rational +c surfaces: c -c For n_k = 1 (single surface): -c Evaluate riccati_f() (uses module g_tmp), de-normalise by lu^(1/3), and -c return Deltaprime - delta(Q). -c -c For n_k = 2 or 3 (coupled surfaces): -c Build the diagonal delta(Q) matrix, subtract from dp_matrix, -c and return det(dp_matrix - delta_Q). +c det( Dp - diag(Delta_crit_k) - diag(S_k^(1/3)*Delta_k(g_k)) ) c +c Dp is the r_s-referenced Deltaprime matrix (complex), of which +c the leading msing_max x msing_max block is used, so a subset of +c the surfaces STRIDE found can be coupled. Delta_crit is a local +c layer offset and enters the diagonal only. Each layer response +c is evaluated at that surface's own normalised eigenvalue g_k. +c For msing_max = 1 this is the single-surface matching condition. c----------------------------------------------------------------------- FUNCTION dispersion_det(g_in,n_k,sl_in,msing_max) c --- arguments COMPLEX(r8), INTENT(IN) :: g_in ! complex growth rate INTEGER, INTENT(IN) :: n_k ! number of surfaces - INTEGER, INTENT(IN) :: msing_max ! max surfaces to include + INTEGER, INTENT(IN) :: msing_max ! surfaces to include TYPE(slayer_inputs_type), INTENT(IN) :: sl_in c --- function result and locals COMPLEX(r8) :: dispersion_det ! returned determinant COMPLEX(r8) :: det_val ! intermediate determinant - COMPLEX(r8) :: tmp_delta ! single-surface delta - COMPLEX(r8), ALLOCATABLE :: delta_Q(:,:) ! diagonal delta matrix - COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! dp - delta_Q + COMPLEX(r8), ALLOCATABLE :: result_matrix(:,:) ! Dp - layer terms INTEGER :: k ! surface loop index INTEGER :: det_status ! calc_determinant error status -c --- single-surface branch - IF (msing_max < 2) THEN -c set module-level variables for riccati_f - Q_e = sl_in%Q_e_arr(1) - Q_i = sl_in%Q_i_arr(1) - P_perp = sl_in%P_perp_arr(1) - P_tor = sl_in%P_tor_arr(1) - tau = sl_in%tau_arr(1) - D_norm = sl_in%D_norm_arr(1) - c_beta = sl_in%c_beta_arr(1) - tauk = sl_in%Qconv_arr(1) + IF (msing_max < 1 .OR. msing_max > n_k) THEN + WRITE(*,*) 'ERROR: dispersion_det needs 1 <= msing_max <= ', + $ 'number of surfaces; got msing_max=',msing_max, + $ ' with',n_k,' surfaces' + STOP 'dispersion_det: msing_max out of range' + END IF + IF (.NOT. ALLOCATED(sl_in%dp_matrix)) THEN + WRITE(*,*) 'ERROR: the coupled determinant needs the STRIDE' + WRITE(*,*) ' Deltaprime matrix; run with read_eq=t.' + STOP 'dispersion_det: no Deltaprime matrix' + END IF + + ALLOCATE(result_matrix(msing_max,msing_max)) + result_matrix = sl_in%dp_matrix(1:msing_max,1:msing_max) + + DO k=1,msing_max +c set module-level variables for this surface + Q_e = sl_in%Q_e_arr(k) + Q_i = sl_in%Q_i_arr(k) + P_perp = sl_in%P_perp_arr(k) + P_tor = sl_in%P_tor_arr(k) + tau = sl_in%tau_arr(k) + D_norm = sl_in%D_norm_arr(k) + c_beta = sl_in%c_beta_arr(k) + tauk = sl_in%Qconv_arr(k) iota_e = Q_e / (Q_e - Q_i) -c BENCHMARK PATCH: ensure pr is set so riccati_f's -c atol = 1e-7*pr**0.4 does not inherit a stale/zero module value. - pr = P_perp - - g_tmp = g_in - tmp_delta=riccati_f() -c de-normalise delta by lu^(1/3) - det_val=tmp_delta* - $ (sl_in%lu_arr(1)**(1.0_r8/3.0_r8)) - -c return Deltaprime - delta(Q) - dispersion_det = sl_in%Re_dp_arr(1) - det_val - -c --- coupled-surface branch (2 or 3 surfaces) - ELSEIF ((msing_max == 2) .OR. (msing_max == 3)) THEN - ALLOCATE(delta_Q(msing_max,msing_max)) - delta_Q=CMPLX(0.0_r8, 0.0_r8, KIND=r8) - DO k=1,msing_max -c set module-level variables for this surface - Q_e = sl_in%Q_e_arr(k) - Q_i = sl_in%Q_i_arr(k) - P_perp = sl_in%P_perp_arr(k) - P_tor = sl_in%P_tor_arr(k) - tau = sl_in%tau_arr(k) - D_norm = sl_in%D_norm_arr(k) - c_beta = sl_in%c_beta_arr(k) - tauk = sl_in%Qconv_arr(k) - iota_e = Q_e / (Q_e - Q_i) -c BENCHMARK PATCH: ensure pr is set so riccati_f's -c atol = 1e-7*pr**0.4 does not inherit a stale/zero module value. - pr = P_perp - -c evaluate riccati_f at rescaled growth rate, de-normalise. -c g_in is normalised by the first surface's tau_k, i.e. -c g_in = tau_1*(gamma + i*omega). The same physical -c eigenvalue reaches surface k as tau_k*(gamma + i*omega) -c = g_in*tau_k/tau_1, the normalisation its Q_e and Q_i use. - g_tmp = g_in*(tauk/sl_in%Qconv_arr(1)) -c The layer's Q is the mode frequency in the local ExB -c frame, while the coupled scan runs in the lab frame: -c Q_layer = tau_k*omega_lab - tau_k*n*Omega_E. q_shift_arr -c holds that real offset (zero unless the driver sets it), -c and g = i*Q. - g_tmp = g_tmp + ifac*sl_in%q_shift_arr(k) - delta_Q(k,k)=riccati_f() - delta_Q(k,k)=delta_Q(k,k)* - $ sl_in%lu_arr(k)**(1.0_r8/3.0_r8) - END DO -c Coupled dispersion: det(Delta' - diag(Delta_c) - delta_Q). -c Delta_crit is a *local* layer-intrinsic offset at each -c rational surface, so it modifies only the diagonal of -c Delta'; outer-region off-diagonal couplings are untouched. -c This reduces to the single-surface matching -c (Delta'_kk - Delta_crit_k) = S^(1/3) * Delta_s -c on the diagonal. When dc_type='none', d_crit_arr is zero -c and the subtraction is a no-op, so this is backward -c compatible with the original coupled behaviour. -c -c BENCHMARK PATCH: take only the (1:msing_max, 1:msing_max) -c sub-block of dp_matrix so callers can compute the coupled -c dispersion on a subset of the rational surfaces that STRIDE -c actually found. This is needed when STRIDE finds 4+ surfaces -c (e.g. DIII-D 147131 with sas_flag=t, qhigh=1e3) but the -c coupled-dispersion code only supports msing_max ≤ 3. - result_matrix = sl_in%dp_matrix(1:msing_max,1:msing_max) - $ - delta_Q - DO k = 1, msing_max - result_matrix(k,k) = result_matrix(k,k) - $ - CMPLX(sl_in%d_crit_arr(k), 0.0_r8, KIND=r8) - END DO - CALL calc_determinant(result_matrix, msing_max, det_val, - $ det_status) - IF (det_status /= 0) THEN - WRITE(*,*) 'ERROR: calc_determinant unsupported rank=', - $ msing_max - STOP 'dispersion_det: calc_determinant failed' - END IF - DEALLOCATE(delta_Q, result_matrix) - dispersion_det = det_val - ELSE - WRITE(*,*) "Error: no support for msing > 3" - STOP "dispersion_det: unsupported n_k" +c g_in is normalised by the first surface's tau_k, i.e. +c g_in = tau_1*(gamma + i*omega). The same physical +c eigenvalue reaches surface k as tau_k*(gamma + i*omega) +c = g_in*tau_k/tau_1, the normalisation its Q_e and Q_i use. + g_tmp = g_in*(tauk/sl_in%Qconv_arr(1)) +c The layer's Q is the mode frequency in the local ExB +c frame, while the coupled scan runs in the lab frame: +c Q_layer = tau_k*omega_lab - tau_k*n*Omega_E. q_shift_arr +c holds that real offset (zero unless the driver sets it), +c and g = i*Q. + g_tmp = g_tmp + ifac*sl_in%q_shift_arr(k) + +c layer response, de-normalised by S^(1/3), and Delta_crit + result_matrix(k,k) = result_matrix(k,k) + $ - riccati_f()*sl_in%lu_arr(k)**(1.0_r8/3.0_r8) + $ - CMPLX(sl_in%d_crit_arr(k), 0.0_r8, KIND=r8) + END DO + + CALL calc_determinant(result_matrix, msing_max, det_val, + $ det_status) + IF (det_status /= 0) THEN + WRITE(*,*) 'ERROR: calc_determinant failed for rank=', + $ msing_max + STOP 'dispersion_det: calc_determinant failed' END IF + DEALLOCATE(result_matrix) + dispersion_det = det_val END FUNCTION dispersion_det c----------------------------------------------------------------------- diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index 91081f19b..d32f16d4b 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -316,7 +316,7 @@ END FUNCTION issurfint c c----------------------------------------------------------------------- - SUBROUTINE build_inputs(infile,ncfile,sl_in) + SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) c----------------------------------------------------------------------- c declarations. c----------------------------------------------------------------------- @@ -324,6 +324,8 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) CHARACTER(512), INTENT(IN) :: infile ! kinetic input file path CHARACTER(512), INTENT(IN) :: ncfile ! STRIDE NetCDF file path TYPE(slayer_inputs_type), INTENT(INOUT) :: sl_in + REAL(r8), INTENT(IN) :: zeff_in ! Z_eff from slayer.in + REAL(r8), INTENT(IN) :: mu_i_in ! ion mass / proton mass c --- surface-loop control LOGICAL :: firstsurf ! first-call flag for issurfint REAL(r8) :: respsi ! normalised psi at current surface @@ -417,7 +419,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) $ sl_in%Qconv_arr(msing), $ sl_in%Re_dp_psi_arr(msing), sl_in%Im_dp_psi_arr(msing), $ sl_in%k_ref_arr(msing), sl_in%alpha_arr(msing), - $ sl_in%q_shift_arr(msing)) + $ sl_in%q_shift_arr(msing), sl_in%q_arr(msing)) sl_in%q_shift_arr = 0.0_r8 c --- allocate local kinetic arrays (for future NetCDF diagnostic output) @@ -442,7 +444,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) tfac = 1.0 wefac = 1.0 wpfac = 1.0 - e = 1.6021917e-19 ! elementary charge [C] + e = chag ! elementary charge [C] chi1 = twopi * my_psio(1) ! total poloidal flux (module-level) CALL read_kin(infile,zi,zimp,mi,mimp,nfac, @@ -455,7 +457,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) sl_in%dp_matrix(:,:) = CMPLX(dp_mat(:,:,1), dp_mat(:,:,2), $ KIND=r8) - dpsi_h = 0.002 ! finite-difference step for Jacobian + dpsi_h = 0.002_r8 ! finite-difference step for Jacobian c----------------------------------------------------------------------- c loop over singular surfaces: evaluate kinetic/equilibrium @@ -474,14 +476,14 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c compute Jacobian da_surf/dpsiN by central difference a_surf_p = issurfint(unitfun,mthsurf, - $ MIN(respsi+dpsi_h, REAL(1.0,r8)),3,1, + $ MIN(respsi+dpsi_h, 1.0_r8),3,1, $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) a_surf_m = issurfint(unitfun,mthsurf, - $ MAX(respsi-dpsi_h, REAL(0.001,r8)),3,1, + $ MAX(respsi-dpsi_h, 0.001_r8),3,1, $ fsave,psave,jacs,delpsi,rsurf,asurf,firstsurf) da_dpsiN = (a_surf_p - a_surf_m) - $ / (MIN(respsi+dpsi_h, REAL(1.0,r8)) - $ - MAX(respsi-dpsi_h, REAL(0.001,r8))) + $ / (MIN(respsi+dpsi_h, 1.0_r8) + $ - MAX(respsi-dpsi_h, 0.001_r8)) c----------------------------------------------------------------------- c evaluate kinetic splines at this surface. @@ -511,12 +513,15 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) n_i = kin%f(1) t_i = kin%f(3) / e -c Z_eff: kinetic spline value may be incorrect if ni=ne in gpeckf -c (quasi-neutrality assumption makes Zeff=1). Override to 2.0 -c for deuterium plasma with carbon impurities (matching TJ). -c TODO: fix gpeckf generation to include proper ni for Zeff, -c or read Zeff from a namelist parameter. - zeff = 2.0 +c Z_eff and the ion mass ratio come from slayer.in (zeff, mu_i), +c not from the kinetic file: its n_i/n_e ratio is often not a +c usable Z_eff. Unset (non-positive) values fall back to 2, a +c deuterium plasma with carbon impurities. + IF (zeff_in > 0.0_r8) THEN + zeff = zeff_in + ELSE + zeff = 2.0_r8 + END IF omega = kin%f(5) my_qval = q_rational(ising) @@ -525,7 +530,11 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) my_bt = my_bt0(1) my_rs = a_surf R_0 = r_o(1) - mu_i = 2.0 ! deuterium + IF (mu_i_in > 0.0_r8) THEN + mu_i = mu_i_in + ELSE + mu_i = 2.0_r8 ! deuterium + END IF dr_val = dr_vals(ising) c convert STRIDE shear (psiN-based) to Fitzpatrick shear (r-based). @@ -537,7 +546,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c because (r/psi_N) > (dr/dpsi_N) inside the mid-radius region. s_fitz = my_sval * my_rs / (respsi * da_dpsiN) WRITE(*,'(A,I2,A,F7.4,A,F6.3,A,F8.4,A,F8.4,A,F7.3,A,F7.3)') - $ ' [layerinputs] q=', resm(ising), + $ ' [layerinputs] m=', resm(ising), $ ' psiN=', respsi, $ ' r_s=', my_rs, $ ' da/dpsiN=', da_dpsiN, @@ -630,7 +639,8 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in) c Q_e/Q_i use spline-derived omega_e/omega_i normalised by c tauk (= Fitzpatrick S^(1/3) * tau_H, from params()). c----------------------------------------------------------------------- - sl_in%qval_arr(ising) = INT(my_qval) + sl_in%qval_arr(ising) = resm(ising) + sl_in%q_arr(ising) = my_qval sl_in%lu_arr(ising) = lu c Use the same -tauk prefactor for both so opposite-signed c spline omega_e, omega_i (electron vs ion diamagnetic diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 5df0b5026..2203f83d5 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -150,7 +150,8 @@ MODULE sglobal_mod c slayer_inputs_type -- per-surface input arrays for SLAYER TYPE slayer_inputs_type - INTEGER, ALLOCATABLE :: qval_arr(:) ! safety-factor integers + INTEGER, ALLOCATABLE :: qval_arr(:) ! resonant poloidal m (labels) + REAL(r8), ALLOCATABLE :: q_arr(:) ! safety factor m/n REAL(r8), ALLOCATABLE :: chi_p_arr(:) ! chi_perp [m^2/s] REAL(r8), ALLOCATABLE :: chi_t_arr(:) ! chi_tor [m^2/s] REAL(r8), ALLOCATABLE :: kappa_arr(:) ! kappa (thermal cond.) diff --git a/slayer/slayer.f b/slayer/slayer.f index be50cbb89..353c46712 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -262,7 +262,7 @@ PROGRAM slayer ! global module scalars (sglobal_mod) gamma_fac = 0.0 - dc_type = "" + dc_type = "rfitzp" ! scan resolution defaults inum = 400 ! 1-D resolution (error-field threshold scans) @@ -275,6 +275,7 @@ PROGRAM slayer ! a coupled scan with rotation. scan_center = HUGE(scan_center) AMR_passes = 4 ! AMR refinement levels + m_AMR = 0 ! no AMR scan stored yet msing_max = 2 ! max singular surfaces to process ! I/O unit numbers (sglobal_mod) @@ -348,6 +349,21 @@ PROGRAM slayer READ(in_unit,NML=slayer_diagnose) CLOSE(UNIT=in_unit) + ! Critical-Delta model: fail on a misspelt name rather than + ! silently running without the stabilising offset. + SELECT CASE (TRIM(dc_type)) + CASE ('rfitzp','lar','none','') + CASE ('toroidal') + WRITE(*,*) "WARNING: dc_type='toroidal' is experimental." + WRITE(*,*) " Its geometric factor (STRIDE Delta_geo) has" + WRITE(*,*) " not been verified in the r_s reference" + WRITE(*,*) " length; prefer dc_type='rfitzp'." + CASE DEFAULT + WRITE(*,*) "ERROR: unknown dc_type='",TRIM(dc_type),"'." + WRITE(*,*) " Use 'rfitzp', 'lar', 'toroidal' or 'none'." + STOP 'slayer: unknown dc_type' + END SELECT + ! Real copies of the mode numbers, read by params() in every ! namelist-driven branch below. build_inputs resets them from ! the STRIDE run when read_eq is set. @@ -391,7 +407,9 @@ PROGRAM slayer c skipped when the matched-gamma path is active (it computes c its own delta internally). c----------------------------------------------------------------------- - IF (.NOT. (match_gamma_flag)) THEN +c Also skipped for the growth-rate estimate, which does not use +c it and is usually run with these namelist inputs unset. + IF (.NOT. (match_gamma_flag .OR. est_gamma_flag)) THEN delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] @@ -505,7 +523,7 @@ PROGRAM slayer sl_in%chi_t_arr = chi_t_prof sl_in%kappa_arr = kappa_prof - CALL build_inputs(infile,ncfile,sl_in) + CALL build_inputs(infile,ncfile,sl_in,zeff,mu_i) n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) @@ -579,7 +597,8 @@ PROGRAM slayer CALL allocate_inputs(n_k,sl_in) ! growthrates_mod CALL allocate_outputs(n_k,sl_out) ! growthrates_mod - sl_in%qval_arr = (/ qval /) + sl_in%qval_arr = (/ mm /) + sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) !sl_in%Q_arr = (/ Q /) sl_in%Q_e_arr = (/ Q_e /) @@ -606,7 +625,7 @@ PROGRAM slayer DO k=1,n_k WRITE(*,*) WRITE(*,'(A,I0,A)') 'Calculating growth rate '// - $ 'estimate on q = ', + $ 'estimate on m = ', $ sl_in%qval_arr(k),' rational surface' D_norm = sl_in%D_norm_arr(k) @@ -627,7 +646,10 @@ PROGRAM slayer ENDDO IF (.NOT. (match_gamma_flag)) THEN - sl_out%gamma_sol_arr = (/0./) + ! no matched solve in this run + sl_out%gamma_sol_arr = CMPLX( + $ ieee_value(1.0_r8, ieee_quiet_nan), + $ ieee_value(1.0_r8, ieee_quiet_nan), KIND=r8) CALL output_gamma(est_gamma_flag,m_AMR,sl_in,sl_out, $ all_deltas_out) END IF @@ -651,7 +673,7 @@ PROGRAM slayer sl_in%chi_t_arr = chi_t_prof sl_in%kappa_arr = kappa_prof - CALL build_inputs(infile,ncfile,sl_in) + CALL build_inputs(infile,ncfile,sl_in,zeff,mu_i) n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) @@ -718,7 +740,8 @@ PROGRAM slayer CALL allocate_outputs(n_k,sl_out) END IF - sl_in%qval_arr = (/ qval /) + sl_in%qval_arr = (/ mm /) + sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) !sl_in%Q_arr = (/ Q /) sl_in%Q_e_arr = (/ Q_e /) @@ -743,6 +766,26 @@ PROGRAM slayer END IF END IF +c----------------------------------------------------------------------- +c sanity checks on the surface count and the coupling request. +c----------------------------------------------------------------------- + IF (msing_max < 1) THEN + WRITE(*,*) 'WARNING: msing_max < 1; using msing_max = 1' + msing_max = 1 + END IF + IF (msing_max > n_k) THEN + WRITE(*,'(A,I0,A,I0,A)') ' NOTE: msing_max = ',msing_max, + $ ' exceeds the ',n_k,' rational surfaces available;' + $ //' using all of them.' + msing_max = n_k + END IF + IF (coupling_flag .AND. .NOT. read_eq) THEN + WRITE(*,*) 'ERROR: coupling_flag=t needs the STRIDE' + WRITE(*,*) ' Deltaprime matrix; set read_eq=t, infile' + WRITE(*,*) ' and ncfile, or set coupling_flag=f.' + STOP 'slayer: coupling_flag requires read_eq' + END IF + c----------------------------------------------------------------------- c ExB Doppler shift and scan-window centre. c Each uncoupled layer is solved in its own ExB frame, where a @@ -814,13 +857,13 @@ PROGRAM slayer END IF END IF - WRITE(*,*),"Rational q domain: ",sl_in%qval_arr + WRITE(*,*) "Resonant m of the surfaces: ",sl_in%qval_arr c----------------------------------------------------------------------- c loop over rational surfaces to find matched growth rates. c----------------------------------------------------------------------- DO k=1,MIN(n_k,msing_max) WRITE(*,*) - WRITE(*,'(A,I0,A)') 'Calculating growth rate on q = ', + WRITE(*,'(A,I0,A)') 'Calculating growth rate on m = ', $ sl_in%qval_arr(k),' rational surface:' ! Load per-surface parameters into module-level scalars. @@ -860,7 +903,7 @@ PROGRAM slayer c----------------------------------------------------------------------- IF (AMR_flag .AND. .NOT. coupling_flag) THEN - WRITE(*,'(A,I0,A)') 'Calling uncoupled AMR scan on q = ', + WRITE(*,'(A,I0,A)') 'Calling uncoupled AMR scan on m = ', $ sl_in%qval_arr(k),' rational surface:' ! The tearing root usually sits near the electron ! drift frequency, Re(Q) = -Q_e. @@ -989,8 +1032,8 @@ PROGRAM slayer ENDDO IF (.NOT. (est_gamma_flag)) THEN - sl_in%d_beta_arr = (/ 0. /) - sl_out%dels_db_arr = (/ 0. /) + sl_in%d_beta_arr = 0.0_r8 + sl_out%dels_db_arr = CMPLX(0.0_r8, 0.0_r8, KIND=r8) END IF c----------------------------------------------------------------------- @@ -1028,7 +1071,10 @@ PROGRAM slayer DO i = 1, n_pts all_deltas_out(1)%inQs(i) = REAL(Q_store(i)) - all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) ! verify this sign convention + ! scan plane q = omega_hat - i*gamma_hat: store the + ! growth-rate axis as +gamma_hat, as in the uncoupled + ! output above. + all_deltas_out(1)%iinQs(i) = -AIMAG(Q_store(i)) all_deltas_out(1)%real_deltas(i) = REAL(D_store(i)) all_deltas_out(1)%imag_deltas(i) = AIMAG(D_store(i)) @@ -1110,7 +1156,7 @@ PROGRAM slayer sl_in%chi_p_arr = chi_p_prof sl_in%chi_t_arr = chi_t_prof sl_in%kappa_arr = kappa_prof - CALL build_inputs(infile,ncfile,sl_in) + CALL build_inputs(infile,ncfile,sl_in,zeff,mu_i) n_k = SIZE(sl_in%qval_arr) CALL allocate_outputs(n_k,sl_out) ELSE @@ -1133,7 +1179,8 @@ PROGRAM slayer CALL allocate_inputs(n_k,sl_in) CALL allocate_outputs(n_k,sl_out) - sl_in%qval_arr = (/ qval /) + sl_in%qval_arr = (/ mm /) + sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) sl_in%Q_e_arr = (/ Q_e /) sl_in%Q_i_arr = (/ Q_i /) @@ -1164,7 +1211,7 @@ PROGRAM slayer DO k=1,n_k WRITE(*,*) - WRITE(*,'(A,I0,A)') 'Computing Br threshold on q = ', + WRITE(*,'(A,I0,A)') 'Computing Br threshold on m = ', $ sl_in%qval_arr(k),' rational surface' Q_e = sl_in%Q_e_arr(k) diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index d45e20af7..99942fb50 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -141,6 +141,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, INTEGER :: oroot_id ! "omega_roots" INTEGER :: proot_id ! "root_polished" LOGICAL :: have_roots ! roots_out holds this run's roots + LOGICAL :: have_amr ! AMR scan data are present REAL(r8), ALLOCATABLE :: buffer_r(:,:,:) ! (root, surf, Re/Im) REAL(r8), ALLOCATABLE :: buffer_p(:,:,:) ! (root, surf, Re/Im) REAL(r8), ALLOCATABLE :: buffer_g(:,:) ! gamma (root, surf) @@ -200,7 +201,11 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c step 1: find the maximum AMR grid size across all surfaces. max_pts_all = 0 - IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN + have_amr = .FALSE. + IF (m_AMR > 0) THEN + have_amr = ALLOCATED(all_deltas_out(1)%inQs) + END IF + IF (have_amr) THEN DO s = 1, m_AMR max_pts_all = MAX(max_pts_all, $ SIZE(all_deltas_out(s)%inQs)) @@ -218,7 +223,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, n_pts_arr = 0 c step 3: flatten the ragged data into the buffers. - IF (ALLOCATED(all_deltas_out(1)%inQs)) THEN + IF (have_amr) THEN DO s = 1, m_AMR n_curr = SIZE(all_deltas_out(s)%inQs) n_pts_arr(s) = n_curr @@ -240,8 +245,8 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c step 4: roots and poles, in the same (omega_hat, gamma_hat) c convention as Q_AMR. have_roots = .FALSE. - IF (ALLOCATED(roots_out)) have_roots = SIZE(roots_out) >= m_AMR - $ .AND. m_AMR > 0 + IF (ALLOCATED(roots_out) .AND. have_amr) + $ have_roots = SIZE(roots_out) >= m_AMR IF (have_roots) THEN ALLOCATE(buffer_r(MAX_ROOTS, m_AMR, 2)) ALLOCATE(buffer_p(MAX_ROOTS, m_AMR, 2)) @@ -288,12 +293,17 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c -- core dimensions -- CALL sl_check( nf90_def_dim(ncid, "r", msing, qsing_dim) ) - CALL sl_check( nf90_def_dim(ncid, "r_AMR", m_AMR, nAMR_dim) ) + IF (have_amr) THEN + CALL sl_check( nf90_def_dim(ncid, "r_AMR", m_AMR, + $ nAMR_dim) ) + END IF CALL sl_check( nf90_def_dim(ncid, "i", 2, i_dim) ) c -- scalar per-surface variables -- CALL sl_check( nf90_def_var(ncid, "r", nf90_int, $ qsing_dim, qsing_id) ) + CALL sl_check( nf90_put_att(ncid, qsing_id, "long_name", + $ "Resonant poloidal mode number m of each surface") ) CALL sl_check( nf90_def_var(ncid, "q_rational", $ nf90_double, qsing_dim, qr_id) ) CALL sl_check( nf90_def_var(ncid, "omegas", nf90_double, @@ -371,14 +381,19 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c----------------------------------------------------------------------- c define AMR scan dimensions and variables. c----------------------------------------------------------------------- + IF (have_amr) THEN CALL sl_check( nf90_def_dim(ncid, "amr_pts", $ max_pts_all, dim_pts_id) ) CALL sl_check( nf90_def_var(ncid, "n_amr_pts", NF90_INT, $ (/nAMR_dim/), var_npts_id) ) CALL sl_check( nf90_def_var(ncid, "Q_AMR", NF90_DOUBLE, $ (/dim_pts_id, nAMR_dim, i_dim/), var_q_id) ) + CALL sl_check( nf90_put_att(ncid, var_q_id, "long_name", + $ "AMR scan points, (omega, gamma)*tau_k") ) CALL sl_check( nf90_def_var(ncid, "Deltas_AMR", NF90_DOUBLE, $ (/dim_pts_id, nAMR_dim, i_dim/), var_d_id) ) + CALL sl_check( nf90_put_att(ncid, var_d_id, "long_name", + $ "Dispersion function at the AMR scan points") ) c roots and poles of the dispersion function from each AMR scan. IF (have_roots) THEN @@ -424,6 +439,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ "_FillValue", fill_val) ) CALL sl_check( nf90_put_att(ncid, var_d_id, $ "_FillValue", fill_val) ) + END IF c----------------------------------------------------------------------- c end NetCDF define mode. @@ -436,7 +452,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, CALL sl_check( nf90_put_var(ncid, qsing_id, $ sl_in%qval_arr) ) CALL sl_check( nf90_put_var(ncid, qr_id, - $ sl_in%qval_arr) ) + $ sl_in%q_arr) ) CALL sl_check( nf90_put_var(ncid, pr_id, $ sl_in%psi_n_arr) ) CALL sl_check( nf90_put_var(ncid, omegas_id, @@ -508,9 +524,11 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, c----------------------------------------------------------------------- c write AMR scan arrays. c----------------------------------------------------------------------- - CALL sl_check( nf90_put_var(ncid, var_npts_id, n_pts_arr) ) - CALL sl_check( nf90_put_var(ncid, var_q_id, buffer_q) ) - CALL sl_check( nf90_put_var(ncid, var_d_id, buffer_d) ) + IF (have_amr) THEN + CALL sl_check( nf90_put_var(ncid, var_npts_id, n_pts_arr) ) + CALL sl_check( nf90_put_var(ncid, var_q_id, buffer_q) ) + CALL sl_check( nf90_put_var(ncid, var_d_id, buffer_d) ) + END IF IF (have_roots) THEN CALL sl_check( nf90_put_var(ncid, nroot_id, From 445d07c8d03f54dea31440260a02ae945cd92c5a Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 14 Oct 2026 15:40:40 -0400 Subject: [PATCH 109/118] SLAYER, STRIDE - BUGFIX - Remove the toroidal critical-Delta option dc_type='toroidal' used a geometric factor (STRIDE Delta_geo) that was not correct in the r_s reference length the layer matching now uses. On the DIII-D-like example it came out within 1% of 'rfitzp', while the validated derivation (Connor et al. 2015 Eq. 59 in the r_s reference, with a toroidal parallel-conduction closure; OpenFUSIONToolkit/GPEC#441) puts it 22-60% above. The option now stops with a message pointing to 'rfitzp'. STRIDE no longer computes or writes Delta_geo and keeps only the shear output SLAYER reads. dgeo_val stays in the namelist, unused, so older inputs still read. A port of the Julia derivation can follow once it is merged there. Co-Authored-By: Claude Opus 5.5 --- input/slayer.in | 4 +- slayer/layerinputs.f | 23 +++---- slayer/params.f | 6 +- slayer/sglobal.f | 2 +- slayer/slayer.f | 13 ++-- stride/free.f | 144 ++--------------------------------------- stride/stride.F | 2 +- stride/stride_netcdf.f | 9 +-- 8 files changed, 31 insertions(+), 172 deletions(-) diff --git a/input/slayer.in b/input/slayer.in index d2a37879b..ec62d0815 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -22,7 +22,7 @@ mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma. Also used when read_eq=t zeff=2.0 ! plasma Z_effective. Also used when read_eq=t (the kinetic file's Z_eff is not used) dr_val=-0.1 ! GGJ resistive interchange index D_R (taken from STRIDE when read_eq=t) - dgeo_val=10.0 ! J.W. Connor geometric prefactor for the experimental dc_type="toroidal" (taken from STRIDE when read_eq=t) + dgeo_val=0.0 ! unused (the toroidal critical Delta was removed); accepted so older inputs still read chi_p_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular energy diffusivity profile chi_t_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular ion momentum diffusivity profile kappa_prof=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 ! Rational surface thermal conductivity profile (NOTE: set > 0 to override chi_p_prof) @@ -52,7 +52,7 @@ AMR_passes=4 ! number of adaptive refinement passes of the scan grid !scan_center=0.0 ! Re(Q) centre of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan msing_max=2 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t - dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", "none", or "toroidal" (experimental) + dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" read_eq=f ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation coupling_flag=f ! solve the coupled multi-surface determinant instead of each surface separately. Requires read_eq=t diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index d32f16d4b..a5532ea55 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -31,13 +31,13 @@ MODULE layerinputs_mod c----------------------------------------------------------------------- c subprogram 1. read_stride_netcdf_diagonal. c Read the STRIDE NetCDF file and extract the Deltaprime matrix, -c rational-surface geometry (q, psi_n, shear, dgeo, dr), and +c rational-surface geometry (q, psi_n, shear, D_R, D_I), and c equilibrium scalars (R0, B_t0, psi0, m_psi, n, resm). c All global-attribute reads use NF90_GLOBAL explicitly; c variable IDs are obtained via nf90_inq_varid before use. c----------------------------------------------------------------------- SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, - $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational,dgeo, + $ Re_dp_diagonal,Im_dp_diagonal,q_rational,psi_n_rational, $ shear,r_o,my_bt0,my_psio,dr_vals,di_vals,mpsi,nn,resm) c --- arguments (all INTENT(OUT) except ncfile) @@ -51,8 +51,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ q_rational, ! rational-surface q values $ psi_n_rational, ! normalised psi at each surface - $ shear, ! magnetic shear - $ dgeo ! geometric delta (Shafranov shift) + $ shear ! magnetic shear REAL(r8), DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: $ r_o, ! major radius R0 $ my_bt0, ! toroidal field B_t0 @@ -69,7 +68,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, INTEGER(kind=nf90_int) :: ncid, stat ! NetCDF file id / return status INTEGER(kind=nf90_int) :: r_dim_id, r_dim ! dimension id / length (unused) INTEGER(kind=nf90_int) :: dp_id, qr_id, pr_id ! variable ids - INTEGER(kind=nf90_int) :: dgeo_id, shear_id ! variable ids + INTEGER(kind=nf90_int) :: shear_id ! variable id INTEGER(kind=nf90_int) :: resm_id, drr_id ! variable ids INTEGER(kind=nf90_int) :: dir_id ! variable id INTEGER(kind=nf90_int), DIMENSION(1) :: start, count ! NetCDF hyperslab @@ -95,7 +94,7 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, c --- allocate output arrays sized by msing ALLOCATE(Re_dp_diagonal(msing), q_rational(msing), - $ psi_n_rational(msing), shear(msing), dgeo(msing), + $ psi_n_rational(msing), shear(msing), $ resm(msing), Im_dp_diagonal(msing), dr_vals(msing), $ di_vals(msing)) ALLOCATE(dp_mat(msing, msing, 2)) @@ -128,8 +127,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) stat = nf90_inq_varid(ncid, 'psi_n_rational', pr_id) CALL sl_check(stat) - stat = nf90_inq_varid(ncid, 'Delta_geo', dgeo_id) - CALL sl_check(stat) stat = nf90_inq_varid(ncid, 'shear', shear_id) CALL sl_check(stat) stat = nf90_inq_varid(ncid, 'resm', resm_id) @@ -164,8 +161,6 @@ SUBROUTINE read_stride_netcdf_diagonal(ncfile,msing,dp_mat, CALL sl_check(stat) stat = nf90_get_var(ncid, pr_id, psi_n_rational) CALL sl_check(stat) - stat = nf90_get_var(ncid, dgeo_id, dgeo) - CALL sl_check(stat) stat = nf90_get_var(ncid, shear_id, shear) CALL sl_check(stat) stat = nf90_get_var(ncid, resm_id, resm) @@ -343,7 +338,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) REAL(r8) :: my_qval, my_sval ! safety factor, magnetic shear REAL(r8) :: my_bt, my_rs, R_0 ! toroidal field, minor radius, major radius REAL(r8) :: zeff ! effective charge from kin%f(9) - REAL(r8) :: dgeo_val ! geometric delta (Shafranov) + REAL(r8) :: dgeo_val ! unused params() argument REAL(r8) :: mu_i ! ion mass ratio to proton REAL(r8) :: dr_val ! radial width dr at surface REAL(r8) :: l_n, l_t ! density / temperature gradient lengths @@ -353,7 +348,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) REAL(r8), DIMENSION(:,:,:), ALLOCATABLE :: dp_mat REAL(r8), DIMENSION(:), ALLOCATABLE :: Re_dp_diagonal, $ Im_dp_diagonal, q_rational, psi_n_rational, - $ shear, dgeo, r_o, my_bt0, my_psio, mpsi_arr, + $ shear, r_o, my_bt0, my_psio, mpsi_arr, $ dr_vals, di_vals, dr_arr c --- local per-surface kinetic arrays (for future NetCDF diagnostic output) REAL(r8), DIMENSION(:), ALLOCATABLE :: ne_arr, te_arr, @@ -383,7 +378,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) c----------------------------------------------------------------------- CALL read_stride_netcdf_diagonal(ncfile,msing,dp_mat, $ Re_dp_diagonal,Im_dp_diagonal,q_rational, - $ psi_n_rational,dgeo,shear,r_o,my_bt0,my_psio,dr_vals, + $ psi_n_rational,shear,r_o,my_bt0,my_psio,dr_vals, $ di_vals,mpsi_arr,nn_arr,resm) c The toroidal mode number of the STRIDE run defines the layer @@ -526,7 +521,7 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) omega = kin%f(5) my_qval = q_rational(ising) my_sval = shear(ising) - dgeo_val = dgeo(ising) + dgeo_val = 0.0_r8 my_bt = my_bt0(1) my_rs = a_surf R_0 = r_o(1) diff --git a/slayer/params.f b/slayer/params.f index b21bc564e..459d9b3a5 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -40,7 +40,7 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, REAL(r8), INTENT(IN) :: t_i ! ion temperature [eV] REAL(r8), INTENT(IN) :: omega ! toroidal rotation [rad/s] REAL(r8), INTENT(IN) :: dr_val ! radial width dr at surface - REAL(r8), INTENT(IN) :: dgeo_val ! geometric delta (Shafranov shift factor) + REAL(r8), INTENT(IN) :: dgeo_val ! unused; kept for the interface REAL(r8), INTENT(IN) :: l_n ! density gradient length REAL(r8), INTENT(IN) :: l_t ! temperature gradient length REAL(r8), INTENT(IN) :: qval ! safety factor @@ -213,7 +213,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c dc_type (from sglobal_mod) selects the formula: c 'lar' -- cylindrical (Lutjens) c 'rfitzp' -- R. Fitzpatrick -c 'toroidal' -- toroidal geometry using dgeo_val c default -- dc_tmp = 0 c----------------------------------------------------------------------- IF (ABS(dr_val) > 0.0_r8) THEN @@ -249,9 +248,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, $ *( (nr*ABS(sval))/(R0*rs) )**0.5_r8 CASE('rfitzp') dc_tmp = -(SQRT(2.0_r8)*(pi**(1.5_r8))*dr_val) / Wd - CASE('toroidal') - dc_tmp = 0.5_r8*(-dr_val)*(pi**1.5_r8) - $ *((chi_par/chis(1))**0.25_r8)*dgeo_val CASE default dc_tmp = 0.0_r8 END SELECT diff --git a/slayer/sglobal.f b/slayer/sglobal.f index 2203f83d5..cc93fa52c 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -85,7 +85,7 @@ MODULE sglobal_mod c --- stability / Delta_crit REAL(r8) :: dc_tmp ! computed Delta_crit COMPLEX(r8) :: delta_eff ! (Deltaprime - Delta_crit)/S^(1/3) - CHARACTER(20) :: dc_type ! dc formula: 'rfitzp','lar','toroidal','none' + CHARACTER(20) :: dc_type ! dc formula: 'rfitzp','lar','none' c --- solver workspace / results COMPLEX(r8) :: g_tmp ! temporary complex growth rate REAL(r8) :: gamma_fac ! growth-rate conversion factor diff --git a/slayer/slayer.f b/slayer/slayer.f index 353c46712..f1abce011 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -100,7 +100,7 @@ PROGRAM slayer REAL(r8) :: mu_i ! ion mass number REAL(r8) :: zeff ! effective charge REAL(r8) :: dr_val ! radial derivative parameter - REAL(r8) :: dgeo_val ! geometric factor parameter + REAL(r8) :: dgeo_val ! unused; still read so old inputs parse REAL(r8) :: scan_width ! half-width of complex-Q scan REAL(r8) :: scan_center ! Re(Q) centre of complex-Q scan REAL(r8) :: q_lo,q_hi,q_br ! expected coupled-branch Re(Q) @@ -354,13 +354,14 @@ PROGRAM slayer SELECT CASE (TRIM(dc_type)) CASE ('rfitzp','lar','none','') CASE ('toroidal') - WRITE(*,*) "WARNING: dc_type='toroidal' is experimental." - WRITE(*,*) " Its geometric factor (STRIDE Delta_geo) has" - WRITE(*,*) " not been verified in the r_s reference" - WRITE(*,*) " length; prefer dc_type='rfitzp'." + WRITE(*,*) "ERROR: dc_type='toroidal' is not available." + WRITE(*,*) " Its geometric factor was not correct in the" + WRITE(*,*) " r_s reference length and has been removed." + WRITE(*,*) " Use dc_type='rfitzp'." + STOP 'slayer: dc_type toroidal removed' CASE DEFAULT WRITE(*,*) "ERROR: unknown dc_type='",TRIM(dc_type),"'." - WRITE(*,*) " Use 'rfitzp', 'lar', 'toroidal' or 'none'." + WRITE(*,*) " Use 'rfitzp', 'lar' or 'none'." STOP 'slayer: unknown dc_type' END SELECT diff --git a/stride/free.f b/stride/free.f index 034e943cd..f9d0ee2df 100755 --- a/stride/free.f +++ b/stride/free.f @@ -173,15 +173,10 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) COMPLEX(r8), DIMENSION(mpert,mpert) :: wt,wpt,wvt COMPLEX(r8), DIMENSION(mpert,mpert) :: nmat,smat CHARACTER(24), DIMENSION(mpert) :: message - INTEGER :: ipsi,itheta REAL(r8), DIMENSION(sq%mx+1) :: ln_q - REAL(r8), DIMENSION(msing) :: dgeo,shr - TYPE(spline_type) :: psi_t,avg_dpsi_spl,avg_bsq_spl,v_spl, - $ vol_spl,shr_spl - REAL(r8) :: bsq,chi1,dpsisq,myeta,jac,psifac,q,q1,respsi, - $ rfac,v1,v21,v22,v23,v33,al,Lam,mytheta,myr,V_s - REAL(r8), DIMENSION(:), POINTER :: avg - TYPE(spline_type), TARGET :: fspl + REAL(r8), DIMENSION(msing) :: shr + TYPE(spline_type) :: shr_spl + REAL(r8) :: v1,respsi c----------------------------------------------------------------------- c write formats. c----------------------------------------------------------------------- @@ -301,155 +296,30 @@ SUBROUTINE free_run(plasma1,vacuum1,total1,op_netcdf_out) WRITE(out_unit,90)(isol,ep(isol),ev(isol),isol=1,mpert) WRITE(out_unit,80) c----------------------------------------------------------------------- -c compute toroidal Delta_crit +c magnetic shear s = psi_N*d(ln q)/d(psi_N) at the rational surfaces +c (written to the netcdf file for SLAYER). c----------------------------------------------------------------------- - ! Prepare toroidal flux spline - CALL spline_alloc(psi_t,SIZE(sq%fsi(:, 4))-1,1) - psi_t%xs=sq%xs(:) - psi_t%fs(:,1)=sq%fsi(:,4)*twopi*psio ! Un-normalize toroidal flux - CALL spline_fit(psi_t,"extrap") - - ! Prepare geometric splines - CALL spline_alloc(avg_dpsi_spl,SIZE(sq%xs(:))-1,1) - avg_dpsi_spl%xs=sq%xs(:) - CALL spline_alloc(avg_bsq_spl,SIZE(sq%xs(:))-1,1) - avg_bsq_spl%xs=sq%xs(:) - CALL spline_alloc(v_spl,SIZE(sq%xs(:))-1,1) - v_spl%xs=sq%xs(:) - ! Cumulative volume V(psi_N) [m^3] = integral of dV/dpsi from axis. - CALL spline_alloc(vol_spl,SIZE(sq%xs(:))-1,1) - vol_spl%xs=sq%xs(:) - vol_spl%fs(:,1)=sq%fsi(:,3) - CALL spline_fit(vol_spl,"extrap") - - ! Prepare shear spline CALL spline_alloc(shr_spl,SIZE(sq%xs(:))-1,1) shr_spl%xs=sq%xs(:) ln_q=LOG(sq%fs(:,4)) shr_spl%fs(:,1)=ln_q - CALL spline_fit(shr_spl,"extrap") - - CALL spline_alloc(fspl,mtheta,3) - fspl%xs=rzphi%ys - - DO ipsi=0,mpsi - psifac=sq%xs(ipsi) - v1=sq%fs(ipsi,3) - q=sq%fs(ipsi,4) - q1=sq%fs1(ipsi,4) - chi1=twopi*psio -c----------------------------------------------------------------------- -c evaluate coordinates and jacobian. -c----------------------------------------------------------------------- - DO itheta=0,mtheta - CALL bicube_eval(rzphi,rzphi%xs(ipsi),rzphi%ys(itheta),1) - mytheta=rzphi%ys(itheta) - rfac=SQRT(rzphi%f(1)) - myeta=twopi*(mytheta+rzphi%f(2)) - myr=ro+rfac*COS(myeta) - jac=rzphi%f(4) -c----------------------------------------------------------------------- -c evaluate other local quantities. -c----------------------------------------------------------------------- - v21=rzphi%fy(1)/(2*rfac*jac) - v22=(1+rzphi%fy(2))*twopi*rfac/jac - v23=rzphi%fy(3)*myr/jac - v33=twopi*myr/jac - bsq=chi1**2*(v21**2+v22**2+(v23+q*v33)**2) - dpsisq=(twopi*myr)**2*(v21**2+v22**2) -c----------------------------------------------------------------------- -c evaluate integrands. -c----------------------------------------------------------------------- - fspl%fs(itheta,1)=dpsisq*(v1**2) ! Converting to \nabla V - fspl%fs(itheta,2)=bsq - fspl%fs(itheta,3)=v1 - fspl%fs(itheta,:)=fspl%fs(itheta,:)*(jac/v1) - ENDDO -c----------------------------------------------------------------------- -c integrate quantities with respect to theta. -c----------------------------------------------------------------------- - CALL spline_fit(fspl,"periodic") - CALL spline_int(fspl) - avg => fspl%fsi(mtheta,:) - avg_dpsi_spl%fs(ipsi,1)=avg(1) - avg_bsq_spl%fs(ipsi,1)=avg(2) - v_spl%fs(ipsi,1)=avg(3) - ENDDO - CALL spline_dealloc(fspl) - - CALL spline_fit(avg_dpsi_spl,"extrap") - CALL spline_fit(avg_bsq_spl,"extrap") - CALL spline_fit(v_spl,"extrap") - DO ising=1,msing respsi=sing(ising)%psifac - - ! Evaluate splines on rational surface - CALL spline_eval(sq,respsi,1) - CALL spline_eval(psi_t,respsi,1) - CALL spline_eval(avg_dpsi_spl,respsi,1) - CALL spline_eval(avg_bsq_spl,respsi,1) - CALL spline_eval(v_spl,respsi,1) - CALL spline_eval(vol_spl,respsi,1) CALL spline_eval(shr_spl,respsi,1) - -c Connor et al. 2015 (PPCF 57 065001) eq. (59): -c Delta_crit = (pi^{3/2}/2) (chi_par/chi_perp)^{1/4} V_s -c * [alpha^2 Lambda^2/(<|grad V|^2>)]^{1/4} -c * (-D_R) -c Identify dgeo = V_s * [alpha^2 Lambda^2 -c /(<|grad V|^2>)]^{1/4}. -c -c Connor's alpha has dimension m^3/Wb: the phase 2 pi i n u / q -c must be dimensionless with u = psi_pol'(V) * theta (Hamada), -c which has units Wb/m^3, so alpha = (2 pi n / q) * v1_SI with -c v1_SI = dV/dpsi_pol [m^3/Wb]. -c Lambda = -q'(V) * (psi_pol'(V))^2 (SI: Wb^2/m^9) -c = -psio^2 * (dq/dpsi_N) / (dV/dpsi_N)^3 -c where psio is total poloidal flux at edge (Wb). -c V_s = V(psi_N_res) (m^3) -c STRIDE's sq uses psi_N (psifac); convert via psi_pol = psi_N * psio. -c sq%f(3) = dV / d(psi_N) [m^3] -c sq%f1(4) = dq / d(psi_N) [dimensionless] -c psio = chi1/(2 pi) [Wb] (total poloidal flux) -c v1_SI = sq%f(3)/psio [m^3/Wb] - V_s = vol_spl%f(1) - q = sq%f(4) - - ! alpha = (2 pi n / q) * v1_SI [m^3/Wb] - al = twopi * nn / q * sq%f(3) / psio - - ! Lambda = -psio^2 * (dq/dpsi_N) / (dV/dpsi_N)^3 [Wb^2/m^9] - Lam = -(psio**2.0) * sq%f1(4) / (sq%f(3)**3.0) - shr(ising) = respsi * shr_spl%f1(1) -c Final 2 sqrt(2 pi q) factor bridges Connor's Hamada-0-to-1 -c convention (eq. 59) to the Fitzpatrick/PEST3 r_s-normalized -c convention used by STRIDE's Delta_prime (PEST3 matrix) and -c SLAYER's rfitzp dc_type. In the LAR limit this reduces -c dgeo -> sqrt(ns/(R r_s)), matching Connor eq. (61) times r_s. - dgeo(ising) = 2.0d0*SQRT(twopi*q) * V_s - $ * ( (((al**2.0)*(Lam**2.0))/ - $ (avg_bsq_spl%f(1)*avg_dpsi_spl%f(1)))**0.25 ) ENDDO - ! Deallocate the new cumulative volume spline - CALL spline_dealloc(vol_spl) + CALL spline_dealloc(shr_spl) c----------------------------------------------------------------------- c optionally write netcdf file. c----------------------------------------------------------------------- IF(present(op_netcdf_out))THEN IF(op_netcdf_out) CALL stride_netcdf_out(wp,wv,wt,ep,ev,et, - $ delta_prime_mat,plasma1,vacuum1,total1,shr,dgeo) + $ delta_prime_mat,plasma1,vacuum1,total1,shr) ENDIF c----------------------------------------------------------------------- c deallocate c----------------------------------------------------------------------- - CALL spline_dealloc(psi_t) - CALL spline_dealloc(avg_dpsi_spl) - CALL spline_dealloc(avg_bsq_spl) - CALL spline_dealloc(v_spl) - CALL spline_dealloc(shr_spl) CALL stride_dealloc c----------------------------------------------------------------------- c terminate. diff --git a/stride/stride.F b/stride/stride.F index 6ae14ece8..10cd23f45 100644 --- a/stride/stride.F +++ b/stride/stride.F @@ -350,7 +350,7 @@ PROGRAM stride ALLOCATE(mx0(mpert,mpert),vx0(mpert)) CALL stride_netcdf_out(mx0,mx0,mx0,vx0,vx0,vx0, $ delta_prime_mat,plasma1,vacuum1,total1, - $ SPREAD(0._r8,1,msing),SPREAD(0._r8,1,msing)) + $ SPREAD(0._r8,1,msing)) CALL stride_dealloc ENDIF IF(mat_flag .OR. ode_flag)DEALLOCATE(amat,bmat,cmat,ipiva,jmat) diff --git a/stride/stride_netcdf.f b/stride/stride_netcdf.f index d30087b6f..939ebf075 100644 --- a/stride/stride_netcdf.f +++ b/stride/stride_netcdf.f @@ -49,13 +49,13 @@ END SUBROUTINE check c declarations. c----------------------------------------------------------------------- SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, - $ pl1,va1,to1,shr,dgeo) + $ pl1,va1,to1,shr) REAL(r8), DIMENSION(mpert), INTENT(IN) :: epi,evi,eti COMPLEX(r8), DIMENSION(mpert,mpert), INTENT(IN) :: wp,wv,wt COMPLEX(r8), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: dp REAL(r8), INTENT(IN) :: pl1,va1,to1 - REAL(r8), DIMENSION(msing), INTENT(IN) :: shr,dgeo + REAL(r8), DIMENSION(msing), INTENT(IN) :: shr INTEGER :: i, ncid, $ i_dim, m_dim, mo_dim, p_dim, i_id, m_id, mo_id, p_id, @@ -63,7 +63,7 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, $ wp_id, wpv_id, wv_id, wvv_id, wt_id, wtv_id, $ r_dim, rp_dim, l_dim, lp_dim, r_id, rp_id, l_id, lp_id, $ pr_id, qr_id, dp_id, ap_id, bp_id, gp_id, dpp_id, - $ shear_id,resm_id,drr_id,dgeo_id,dir_id + $ shear_id,resm_id,drr_id,dir_id COMPLEX(r8), DIMENSION(mpert) :: ep,ev,et CHARACTER(2) :: sn CHARACTER(64) :: ncfile @@ -205,8 +205,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, $ "Safety Factor at Rational Surfaces") ) CALL check( nf90_def_var(ncid, "shear", nf90_double, r_dim, $ shear_id) ) - CALL check( nf90_def_var(ncid, "Delta_geo", nf90_double, r_dim, - $ dgeo_id) ) CALL check( nf90_def_var(ncid, "resm", nf90_int, r_dim, $ resm_id) ) CALL check( nf90_def_var(ncid, "dr_rational", nf90_double, @@ -282,7 +280,6 @@ SUBROUTINE stride_netcdf_out(wp,wv,wt,epi,evi,eti,dp, $ i=1,msing)/)) ) CALL check( nf90_put_var(ncid,shear_id, shr) ) CALL check( nf90_put_var(ncid,resm_id, resm) ) - CALL check( nf90_put_var(ncid,dgeo_id, dgeo) ) CALL check( nf90_put_var(ncid,drr_id, dr_rationals)) CALL check( nf90_put_var(ncid,dir_id, di_rationals)) ENDIF From c540e7b04d7d271c93d6f572e2b1133eeb20276e Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 14 Oct 2026 15:45:47 -0400 Subject: [PATCH 110/118] DOCS - EXAMPLES - Add a SLAYER growth-rate run to the DIII-D example and fix the a10 SLAYER input - DIIID_ideal_example gains a slayer.in that reads STRIDE's output and the kinetic file (read_eq=t), and a README section describing the run and its result: with the rfitzp critical Delta the 2/1, 3/1 and 4/1 tearing modes are damped; without it the 2/1 grows at about 80 /s. - a10_ideal_example/slayer.in is restored to develop's version, with two fixes that let gfortran read it: delta_n_p is a complex value, and the file ends in a newline. Co-Authored-By: Claude Opus 5.5 --- docs/examples/DIIID_ideal_example/README | 14 ++++ docs/examples/DIIID_ideal_example/slayer.in | 93 +++++++++++++++++++++ docs/examples/a10_ideal_example/slayer.in | 17 ++-- 3 files changed, 115 insertions(+), 9 deletions(-) create mode 100644 docs/examples/DIIID_ideal_example/slayer.in diff --git a/docs/examples/DIIID_ideal_example/README b/docs/examples/DIIID_ideal_example/README index bc4e65dcb..f699a00f0 100644 --- a/docs/examples/DIIID_ideal_example/README +++ b/docs/examples/DIIID_ideal_example/README @@ -23,6 +23,20 @@ A ``stride.in`` is also included, allowing STRIDE to be run as an alternative st .. note:: STRIDE does not write ``euler.bin`` (its ``bin_euler`` flag is a dummy variable), so DCON must be run when GPEC will be executed in subsequent steps. +STRIDE also writes ``stride_output_n1.nc``, which holds the outer-region tearing stability matrix Delta' and the rational-surface data that SLAYER needs to compute resistive-layer tearing growth rates. With ``read_eq=t``, the included ``slayer.in`` reads that file together with the kinetic profiles in ``TkMkr_D3Dlike_Hmode.gpeckf``. It then matches each layer response to Delta' on the first three rational surfaces:: + + slayer + + Calculating growth rate on m = 2 rational surface: + Delta_prime (r_s ref.): 5.93 ... + Delta_crit: 33.3 + Dispersion roots found: 1, poles: 1 + root 1: Q= -1.162346E+00 -4.163883E-02 omega[rad/s]= -1.059332E+04 gamma[1/s]= -3.794858E+02 polished=T + +Delta' is converted from STRIDE's normalized-flux reference length to the minor-radius reference that the layer quantities use before matching. With the default ``dc_type="rfitzp"`` critical Delta, the 2/1, 3/1 and 4/1 tearing modes are all damped here, because Delta_crit exceeds Delta' on each surface. Setting ``dc_type="none"`` drops this stabilization and leaves the 2/1 weakly unstable (gamma of about 80 /s). Each root is reported in its surface's ExB frame. The results, including every root and pole found in the scan, are written to ``slayer_output_n1.nc``. + +Setting ``coupling_flag=t`` instead solves the coupled multi-surface dispersion relation for the first ``msing_max`` surfaces. Each surface is then Doppler-shifted by its ExB rotation from the kinetic file, so the root is reported in the lab frame. + Satisfied with the DCON result, we run GPEC, which computes the ideal plasma response to the external 3D field from the coils defined in ``coil.in``:: gpec diff --git a/docs/examples/DIIID_ideal_example/slayer.in b/docs/examples/DIIID_ideal_example/slayer.in new file mode 100644 index 000000000..74d6a001f --- /dev/null +++ b/docs/examples/DIIID_ideal_example/slayer.in @@ -0,0 +1,93 @@ +&SLAYER_INPUT + input_flag=f ! reads profile quantities (n_e, t_e, etc.) from an ascii table + infile='TkMkr_D3Dlike_Hmode.gpeckf' ! Path to the kinetic profile file (read_eq=t), or to an ascii table of surface quantities (input_flag=t) + ncfile='stride_output_n1.nc' ! Path to netCDF file of STRIDE outputs + params_flag=f ! calculates normalized parameters from profile quantities + ! >>> + ! >>> Input rational surface quantities + ! >>> + mm=2 ! poloidal mode number + nn=1 ! toroidal mode number + n_e=5.50E+19 ! electron density [m^-3] + t_e=1000.0 ! electron temperature [eV] + t_i=1000.0 ! ion temperature [eV] + sval=1.5 ! magnetic shear at the layer + bt=2.0 ! toroidal field [T] + rs=0.5 ! minor radius of resonant surface [m] + R0=1.67 ! major radius of magnetic axis [m] + omega=5.00E+03 ! ExB rotation frequency [rad/s] + l_t=0.11 ! temperature gradient scale length + l_n=0.25 ! density gradient scale length + qval=2.0 ! q of resonant surface + mu_i=2.0 ! ion mass ratio to proton mass, 2 for deuterium plasma. Also used when read_eq=t + zeff=2.0 ! plasma Z_effective. Also used when read_eq=t (the kinetic file's Z_eff is not used) + dr_val=-0.1 ! GGJ resistive interchange index D_R (taken from STRIDE when read_eq=t) + dgeo_val=0.0 ! unused (the toroidal critical Delta was removed); accepted so older inputs still read + chi_p_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular energy diffusivity profile + chi_t_prof=0.2,0.2,0.2,0.2,0.2,0.2,0.2,0.2 ! Rational surface anomalous perpendicular ion momentum diffusivity profile + kappa_prof=0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 ! Rational surface thermal conductivity profile (NOTE: set > 0 to override chi_p_prof) + ! >>> + ! >>> Input normalized layer parameters. If read_eq=f, each will individually override internal calcuation using above inputs + ! >>> + inpr=0.0 ! Prantdl number. Set /= 0.0 to override internal calculation + inpe=0.0 ! electron viscosity + inQ=1.0 ! normalized ExB frequency. TO DO: update for mode rotation frequency calculation! + inQ_e=0.0 ! normalized electron diamagnetic frequency. Set /= 0.0 to override internal calculation + inQ_i=0.0 ! normalized ion diamagnetic frequency. Set /= 0.0 to override internal calculation + inc_beta=0.0 ! dimensionless measure of the plasma pressure. Set /= 0.0 to override internal calculation + inds=0.0 ! normalized ion sound radius, or normalized ion skin depth. Set /= 0.0 to override internal calculation + intau=1.0 ! ratio of ion to electron temperature + Q0=1.0 ! unnecessary placeholder variable for inQ? + delta_prime=(0.0,0.0) ! input Delta' for the growth rate calculation when read_eq=f, referenced to the minor radius (r_s*Delta') + delta_n_p=(0.01,0.01) ! delta offset used for jxb calculations. Default for latter is (1e-2,1e-2). + ingamma=(0.0,0.0) ! input (Re(Q),Im(Q)) to calculate inner layer Delta. Set /= 0.0 to override internal root finding +/ + +&SLAYER_CONTROL + inum=400 ! resolution to find error field thresholds. + jnum=100 ! resolution for 2d scan along with Q,omega. + knum=100 ! resolution for 2d scan along with the other. + Q_num=100 ! number of points per axis of the initial Re(Q),Im(Q) scan grid + scan_width=1.5 ! half-width of the Re(Q),Im(Q) scan window, in normalized Q + AMR_passes=4 ! number of adaptive refinement passes of the scan grid + !scan_center=0.0 ! Re(Q) centre of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan + msing_max=3 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t + dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" + read_eq=t ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) + Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation + coupling_flag=f ! solve the coupled multi-surface determinant instead of each surface separately. Requires read_eq=t + rotation_flag=t ! Doppler-shift each surface by its ExB rotation in the coupled determinant (root reported in the lab frame) + QPscan_flag=f ! scan (Q,P) space for delta and torque. + Qscan_flag=f ! scan Q space + QPescan_flag=f ! scan (Q,Pe) space for delta and torque. + Qbscan_flag=f ! scan (Q,beta) space for delta and torque. + onscan_flag=f ! scan (omega,n) space for error fields. + otscan_flag=f ! scan (omega,t) space for error fields. + ntscan_flag=f ! scan (n,te) space for error fields. + nbtscan_flag=f ! scan (n,bt) space for error fields. + parflow_flag=f ! set parallel flow on + PeOhmOnly_flag=t ! only include Pe from Ohm's law + Pe_flag=f ! if true, calculate classical inpe value from inpr and include in SLAYER run + layfac=0.02 ! layfac*EXP(ifac*ATAN2(AIMAG(Q-Q_e),REAL(Q-Q_e)) is added to Q_e if ABS(Q-Q_e) Date: Wed, 14 Oct 2026 15:46:37 -0400 Subject: [PATCH 111/118] SLAYER - MINOR - Restore CRLF line endings in delta.f develop stores delta.f with CRLF line endings. The merge converted it to LF, which made every line of the file show as changed. Content is unchanged. Co-Authored-By: Claude Opus 5.5 --- slayer/delta.f | 2178 ++++++++++++++++++++++++------------------------ 1 file changed, 1089 insertions(+), 1089 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 38da8630b..739dc74d1 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -1,1090 +1,1090 @@ - MODULE delta_mod -c----------------------------------------------------------------------- -c delta_mod: Riccati-based tearing-mode layer Delta solvers. -c -c Contains three Riccati formulations: -c riccati - standard formulation (non-stiff, lsode mf=10) -c riccati_del_s - del_s formulation (stiff, lsode mf=21) -c riccati_f - Fitzpatrick P_perp/P_tor formulation (mf=21) -c -c Each solver integrates a Riccati ODE for W(x) from a large-|x| -c asymptotic boundary condition inward to x ~ 0, then extracts -c Delta = pi / W'(0). -c -c Associated ODE subroutines (w_der, w_der_del_s, w_der_f) and -c Jacobian subroutines (jac_del_s, jac_f) follow below. -c -c Module-level flags: -c riccati_out - write W(x) profile to binary + text file -c parflow_flag - include parallel electron flow terms in w_der -c PeOhmOnly_flag - retain only Pe-Ohm coupling in w_der -c----------------------------------------------------------------------- - - USE sglobal_mod - USE ieee_arithmetic, ONLY: ieee_value, ieee_quiet_nan - - IMPLICIT NONE - -c --- module-level control flags - LOGICAL :: riccati_out ! write W(x) profile to binary + text - LOGICAL :: parflow_flag ! enable parallel-flow terms in w_der - LOGICAL :: PeOhmOnly_flag ! Pe-Ohm-only coupling in w_der - - CONTAINS -c----------------------------------------------------------------------- -c riccati: compute Delta via Riccati integration of w_der. -c -c Integrates W(x) from x_start inward to x_min using lsode -c (non-stiff, mf=10). Optionally applies the layfac singularity -c guard when Q is near Q_e. Returns Delta = pi / W'(x_min). -c -c If riccati_out = .TRUE., writes the W(x) profile to -c slayer_riccati_profile_n.{bin,out}. -c -c----------------------------------------------------------------------- - FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, - $ iinQ,inx,iny) - -c --- input arguments: physical parameters for this surface - REAL(r8),INTENT(IN) :: inQ ! real part of Q - REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq - REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq - REAL(r8),INTENT(IN) :: inpr ! Prandtl number - REAL(r8),INTENT(IN) :: inpe ! electron Prandtl number - REAL(r8),INTENT(IN) :: inc_beta ! c_beta parameter - REAL(r8),INTENT(IN) :: inds ! magnetic shear ds - REAL(r8),INTENT(IN) :: intau ! ion-to-electron temp ratio -c --- optional arguments - REAL(r8),INTENT(IN),OPTIONAL :: iinQ ! imaginary part of Q - REAL(r8),INTENT(IN),OPTIONAL :: inx ! override starting x - COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W -c --- function result - COMPLEX(r8) :: riccati - -c --- lsode solver control - INTEGER :: istep ! integration step counter - INTEGER :: neq ! number of equations (=2) - INTEGER :: itol,itask ! lsode tolerance/task flags - INTEGER :: istate,iopt,mf ! lsode state/option/method flags - INTEGER :: liw,lrw ! lsode work array sizes - REAL(r8) :: x,xout ! current and target x - REAL(r8) :: xmin ! inner integration bound - REAL(r8) :: rtol ! relative tolerance -c --- work arrays - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy ! W and dW - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work - REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work - -c --- copy input arguments to module-level globals for w_der - Q=inQ - IF(present(iinQ)) Q=inQ+ifac*iinQ - Q_e=inQ_e - Q_i=inQ_i - pr=inpr - pe=inpe - c_beta=inc_beta - ds=inds - tau=intau - -c --- singularity guard: displace Q away from Q_e when too close - IF ((layfac>0).AND.(ABS(Q-Q_e)xout) - istep=istep+1 - CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) - WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) - WRITE(out2_unit,'(1x,3(es17.8e3))') x,REAL(y),AIMAG(y) - ENDDO - CLOSE(bin_unit) - CLOSE(out2_unit) - ELSE -c single-shot integration to x_min - istep = 1 - itask = 1 - CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) - ENDIF - -c --- extract Delta from final W derivative at x_min -c NOTE: W -> 0 when Q -> Q_e (see layfac guard above). - CALL w_der(neq,x,y,dy) - riccati=pi/dy(1) - DEALLOCATE(atol,y,dy,iwork,rwork) - - END FUNCTION riccati -c----------------------------------------------------------------------- -c riccati_del_s: compute Delta via the del_s Riccati formulation. -c -c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian -c (jac_del_s). Integrates W(q) from large q inward to q_min. -c Returns Delta = -(pi / sqrt(1+1/tau)) * W'(q_min). -c -c Module-level variables tau, D_norm, and P_tor must be valid -c before entry; callers are responsible for setting them. -c Q_e, Q_i, and P_perp are set from arguments inside this -c function. Q, c_beta, and d_beta are not referenced here. -c Note: slayer.f passes Q_e_arr (not Q_arr) as the first -c argument -- this is intentional. -c----------------------------------------------------------------------- - FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) - -c --- input arguments - REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq - REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq - REAL(r8),INTENT(IN) :: inpr ! mapped to P_perp (see below) -c --- optional arguments - REAL(r8),INTENT(IN) :: inx ! starting q for integration - COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W -c --- function result - COMPLEX(r8) :: riccati_del_s - -c --- lsode solver control - INTEGER :: istep ! integration step counter - INTEGER :: neq ! number of equations (=2) - INTEGER :: itol,itask ! lsode tolerance/task flags - INTEGER :: istate,iopt,mf ! lsode state/option/method flags - INTEGER :: liw,lrw ! lsode work array sizes - REAL(r8) :: x ! secondary x variable (set from inx) - REAL(r8) :: xout ! target integration endpoint - REAL(r8) :: xmin ! inner integration bound - REAL(r8) :: rtol ! relative tolerance - REAL(r8) :: my_q ! integration variable (large -> small) - REAL(r8) :: P_hat ! normalized P_perp - REAL(r8) :: alpha ! boundary condition coefficient -c --- work arrays - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq ! W and dW/dq - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work - REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work - -c --- configure lsode: stiff BDF method with user Jacobian (mf=21) - neq = 2 - itol = 2 - rtol = 1e-10 - ALLOCATE(atol(neq),W(1),dW_dq(1)) - atol(:) = 1e-10 - itask = 2 - istate = 1 - iopt = 1 ! enable optional inputs (iwork(6)) - mf = 21 ! stiff, user-supplied Jacobian (jac_del_s) - liw = 20*2 - lrw = 22+9*neq+neq**2 ! stiff work array size - ALLOCATE(iwork(liw+neq),rwork(lrw)) - -c --- set maximum internal steps - iwork=0 - iwork(6)=50000 ! MXSTEP: max internal steps per call - rwork=0 - -c --- set starting integration point - my_q=inx ! start backwards integration at large q - xmin=1e-5 - x=inx - xout=xmin - -c --- copy input arguments to module-level globals for w_der_del_s - Q_e = inQ_e - Q_i = inQ_i - P_perp = inpr - - P_hat = P_perp / D_norm**6.0 - -c --- asymptotic boundary condition at large q - alpha = (P_hat/(1+1/tau))**0.5 - W(1) = -alpha*my_q**2 - 0.5 - IF(present(iny)) W(1)=iny - -c --- integrate W(q) from q_start inward to q_min via lsode - IF (riccati_out) THEN -c profile output: step-by-step integration with file writes - istep = 1 - itask = 2 - OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', - $ POSITION='REWIND',FORM='UNFORMATTED') - - OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') - WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" - DO WHILE (my_q>xout) - istep=istep+1 - CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) - WRITE(bin_unit)REAL(my_q,4),REAL(REAL(W),4),REAL(AIMAG(W),4) - WRITE(out2_unit,'(1x,3(es17.8e3))')my_q,REAL(W),AIMAG(W) - ENDDO - CLOSE(bin_unit) - CLOSE(out2_unit) - ELSE -c single-shot integration to q_min - istep = 1 - itask = 1 - CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) - ENDIF - -c --- extract Delta from final W derivative at q_min - CALL w_der_del_s(neq,my_q,W,dW_dq) - riccati_del_s=-( pi/((1+1/tau)**0.5) )*dW_dq(1) - DEALLOCATE(atol,W,dW_dq,iwork,rwork) - - END FUNCTION riccati_del_s -c----------------------------------------------------------------------- -c jac_dummy: placeholder Jacobian for lsode calls whose method flag -c does not use a user-supplied Jacobian (mf=10, mf=22). lsode never -c calls it; it exists so that every lsode call in this module passes -c a subroutine in the JAC position. -c----------------------------------------------------------------------- - SUBROUTINE jac_dummy(neq, x, y, ml, mu, pd, nrpd) - INTEGER, INTENT(IN) :: neq, ml, mu, nrpd - REAL(r8), INTENT(IN) :: x - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y - COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd - END SUBROUTINE jac_dummy -c----------------------------------------------------------------------- -c jacobian for riccati_del_s(): pd = dF/dW for stiff lsode. -c----------------------------------------------------------------------- - SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) - INTEGER, INTENT(IN) :: neq, ml, mu, nrpd - REAL(r8), INTENT(IN) :: my_q - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W - COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd - pd(1,1) = 1.0/my_q - 2.0d0*W(1)/my_q - END SUBROUTINE jac_del_s -c----------------------------------------------------------------------- -c w_der_del_s: ODE right-hand side dW/dq for riccati_del_s. -c Implements the del_s dispersion relation using normalised -c quantities Q_hat, P_perp_hat, P_tor_hat. -c----------------------------------------------------------------------- - SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) - - INTEGER, INTENT(IN) :: neq - REAL(r8), INTENT(IN) :: my_q - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W - COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dW_dq - REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat - COMPLEX(r8) :: E,F - -c --- normalise physical quantities - Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 - P_perp_hat = P_perp / D_norm**6.0 - P_tor_hat = P_tor / D_norm**6.0 -c --- build the E and F dispersion coefficients - E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ - $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) - F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 - -c --- Riccati ODE: dW/dq = W/q - W^2/q + q*E/F - dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F - RETURN - END SUBROUTINE w_der_del_s -c----------------------------------------------------------------------- -c riccati_f: compute Delta via Fitzpatrick P_perp / P_tor -c Riccati formulation. -c -c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian -c (jac_f). Boundary conditions are set analytically from the -c large-p asymptotic behaviour; the branch depends on whether -c D_norm^2 exceeds iota_e * P_perp / P_tor^(2/3). -c -c----------------------------------------------------------------------- - FUNCTION riccati_f() - -c --- function result - COMPLEX(r8) :: riccati_f - -c --- lsode solver control - INTEGER :: istep ! integration step counter - INTEGER, PARAMETER :: neq = 2 ! number of equations - INTEGER :: itol,itask ! lsode tolerance/task flags - INTEGER :: istate,iopt,mf ! lsode state/option/method flags - INTEGER, PARAMETER :: liw = 42 ! 20*2 + neq - INTEGER, PARAMETER :: lrw = 44 ! 22 + 9*neq + neq**2 - REAL(r8) :: xout ! target integration endpoint - REAL(r8) :: xmin ! inner integration bound - REAL(r8) :: rtol ! relative tolerance - REAL(r8) :: my_p ! integration variable p (large -> small) - REAL(r8) :: bk ! asymptotic coefficient b_k -c --- boundary-condition intermediates - COMPLEX(r8) :: ak ! asymptotic coefficient a_k - COMPLEX(r8) :: ck ! asymptotic coefficient c_k - COMPLEX(r8) :: xk ! asymptotic coefficient x_k - COMPLEX(r8) :: W_bound ! boundary value for W(p_start) -c --- work arrays (fixed-size, stack-allocated to avoid heap overhead) - COMPLEX(r8) :: W(1), dWdp(1) ! W and dW/dp - REAL(r8) :: atol(neq) ! absolute tolerance - INTEGER :: iwork(liw) ! lsode int work - REAL(r8) :: rwork(lrw) ! lsode real work - -c --- configure lsode: stiff BDF method with user Jacobian (mf=21) - itol = 2 - rtol = 1.0d-10 - atol(:) = 1.0d-10 - itask = 2 - istate = 1 - iopt = 1 ! enable optional inputs (iwork(6)) - mf = 21 ! stiff, user-supplied Jacobian (jac_f) - -c --- set maximum internal steps (only iwork(5:6) matter for lsode) - iwork(:) = 0 - iwork(6) = 50000 ! MXSTEP: max internal steps per call - rwork(:) = 0.0d0 - - xmin=1e-6 - xout=xmin - -c --- compute starting p and W boundary condition -c Branch on asymptotic regime: D_norm^2 vs iota_e*P_perp/P_tor^(2/3) -c --- branch 1: D_norm^2 > iota_e * P_perp / P_tor^(2/3) -c large-D_norm regime: p scales with (P_tor*D_norm^2/(iota_e*...)) - IF (D_norm**2 > iota_e*P_perp / P_tor**(2.0d0/3.0d0)) THEN - my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25d0 - my_p = MAX(my_p, 6.0d0) - - ak = -(g_tmp + ifac*Q_e) - bk = (iota_e*P_perp*P_tor)/(P_tor*D_norm**2) - - ck = bk*(1 + (g_tmp+ifac*Q_i) - $ *((P_tor+P_perp)/(P_tor*P_perp)) - $ - (P_perp + (g_tmp+ifac*Q_i)*D_norm**2) - $ *(iota_e/(P_tor*D_norm**2))) - - xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0d0*SQRT(bk)) - - W_bound = xk - SQRT(bk)*my_p - ELSE -c --- branch 2: D_norm^2 <= iota_e * P_perp / P_tor^(2/3) -c small-D_norm regime: p scales with 1/P_tor^(1/6) - my_p = 1.0d0 / P_tor**(1.0d0/6.0d0) - my_p = MAX(my_p, 6.0d0) - - ak = -(g_tmp + ifac*Q_e) - bk = P_tor - ck = -ifac*(Q_e - Q_i)*(P_tor/P_perp) + (g_tmp + ifac*Q_i) - xk = (ak*bk - ck)/(2.0d0*SQRT(bk)) - - W_bound = -1.0d0 + xk*my_p - SQRT(bk)*my_p**3 - END IF - - W(1) = W_bound - -c --- integrate W(p) from p_start inward to p_min via lsode - IF (riccati_out) THEN -c profile output: step-by-step integration with file writes - istep = 1 - itask = 2 - OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', - $ POSITION='REWIND',FORM='UNFORMATTED') - - OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// - $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') - WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" - DO WHILE (my_p>xout) - istep=istep+1 - CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) - WRITE(bin_unit)REAL(my_p,4),REAL(REAL(W),4), - $ REAL(AIMAG(W),4) - WRITE(out2_unit,'(1x,3(es17.8e3))')my_p,REAL(W),AIMAG(W) - ENDDO - CLOSE(bin_unit) - CLOSE(out2_unit) - ELSE -c single-shot integration to p_min - istep = 1 - itask = 1 - CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) - ENDIF - -c --- extract Delta from final W derivative at p_min - CALL w_der_f(neq,my_p,W,dWdp) - riccati_f = pi / dWdp(1) -c A failed integration (istate < 0) leaves W short of p_min. Return -c NaN so that scans and the root search skip the point instead of -c using a Delta built from an unconverged W. - IF (istate < 0) riccati_f = CMPLX( - $ ieee_value(1.0_r8, ieee_quiet_nan), - $ ieee_value(1.0_r8, ieee_quiet_nan), KIND=r8) - - END FUNCTION riccati_f -c----------------------------------------------------------------------- -c jacobian for riccati_f(): pd = dF/dW for stiff lsode. -c----------------------------------------------------------------------- - SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) - INTEGER, INTENT(IN) :: neq, ml, mu, nrpd - REAL(r8), INTENT(IN) :: my_p - COMPLEX(r8) :: fA_p, denom - REAL(r8) :: p2 - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W - COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd - - p2 = my_p * my_p - denom = g_tmp + ifac*Q_e + p2 - fA_p = (denom - 2.0d0*p2) / denom - - pd(1,1) = (-fA_p/my_p) - (2.0d0*W(1))/my_p - END SUBROUTINE jac_f -c----------------------------------------------------------------------- -c w_der_f: ODE right-hand side dW/dp for riccati_f. -c Implements the Fitzpatrick P_perp / P_tor dispersion relation. -c Coefficients fA, fB, fC are evaluated at the current p. -c----------------------------------------------------------------------- - SUBROUTINE w_der_f(neq,my_p,W,dWdp) - - INTEGER, INTENT(IN) :: neq - REAL(r8), INTENT(IN) :: my_p - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W - COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dWdp - COMPLEX(r8) :: fA, fA_prime, fB, fC - COMPLEX(r8) :: denom ! cached g_tmp + i*Q_e + p^2 - REAL(r8) :: p2, p4 ! cached p^2, p^4 - REAL(r8) :: D2 ! cached D_norm^2 - -c cache powers and shared denominator - p2 = my_p * my_p - p4 = p2 * p2 - D2 = D_norm * D_norm - denom = g_tmp + ifac*Q_e + p2 - -c evaluate coefficients at the current p - fA = p2 / denom - fA_prime = (denom - 2.0d0*p2) / denom ! (g+iQe - p^2)/(g+iQe + p^2) - - fB = g_tmp*(g_tmp + ifac*Q_i) - $ + (g_tmp + ifac*Q_i)*(P_perp + P_tor)*p2 - $ + (P_perp*P_tor)*p4 - - fC = g_tmp + ifac*Q_e - $ + (P_perp + (g_tmp + ifac*Q_i)*D2)*p2 - $ + (1.0d0/iota_e)*P_tor*D2*p4 - - dWdp(1) = -(fA_prime/my_p)*W(1) - W(1)*W(1)/my_p - $ + (fB/(fA*fC))*(p2*my_p) - - RETURN - END SUBROUTINE w_der_f -c----------------------------------------------------------------------- -c W derivative for riccati() -c----------------------------------------------------------------------- - SUBROUTINE w_der(neq,x,y,dy) - - INTEGER, INTENT(IN) :: neq - REAL(r8), INTENT(IN) :: x - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y - COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy - COMPLEX(r8) :: G - COMPLEX(r8) :: C1 - COMPLEX(r8) :: C1p - COMPLEX(r8) :: C2 - COMPLEX(r8) :: C3 - COMPLEX(r8) :: C3p - COMPLEX(r8) :: C2p - COMPLEX(r8) :: A1 - COMPLEX(r8) :: A2 - !COMPLEX(r8), PARAMETER :: ifac=(0,1) - - IF (parflow_flag) THEN - C1=((1 + tau)*x**2*pe* - $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i)))) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - - C1p=((1 + tau)*x**2*pe* - $ ((2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ **2)/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** - $ 3 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (12*ds**2*pr*(1 + tau)*x**2 + - $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** - $ 2 - (2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** - $ 2 - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** - $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((12*ds**2*pr*(1 + tau)*x**2 + - $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) - $ + (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2 - $ - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)**2* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**3 - $ + ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ - ((1 + tau)*x**2*pe* - $ (2*pr*x + 2*x*pe + - $ (ds**2*(1 + tau)*x**6*pe**2* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2))/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2) - - $ (6*ds**2*(1 + tau)*x**5*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e) - $ )) - (ifac*(1 + tau)*x**2*pe* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2)*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ **2 + (2*ifac*(1 + tau)*x*pe* - $ Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ *(-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ ) + (ifac*(1 + tau)*x**2*pe* - $ Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ **2 + (2*(1 + tau)*x*pe* - $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - - C2=((1 + tau)*x**2*pe* - $ ((ds**2*x**4*pe)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ ) - (ifac*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - - C2p=((1 + tau)*x**2*pe* - $ (-((ds**2*x**4*pe* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2))/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2)) + - $ (4*ds**2*x**3*pe)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e) - $ )) + (ifac* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2)*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ **2 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* - $ (4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** - $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (-((4*ds**2*pr*(1 + tau)*x**3 + - $ 2*x* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2* - $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) - $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) - $ /(ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + - $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ - ((1 + tau)*x**2*pe* - $ (2*pr*x + 2*x*pe + - $ (ds**2*(1 + tau)*x**6*pe**2* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2))/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + - $ ifac*(Q - Q_e))**2) - - $ (6*ds**2*(1 + tau)*x**5*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e) - $ )) - (ifac*(1 + tau)*x**2*pe* - $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2)*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ **2 + (2*ifac*(1 + tau)*x*pe* - $ Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ *((ds**2*x**4*pe)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e) - $ )) - (ifac*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ ) + (ifac*(1 + tau)*x**2*pe* - $ Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ **2 + (2*(1 + tau)*x*pe* - $ ((ds**2*x**4*pe)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e) - $ )) - (ifac*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* - $ (1 - (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + - $ ifac*ds**2*(Q - Q_i)))/ - $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ - $ (ds**2*pr*(1 + tau)*x**4 + - $ ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ - $ (ifac*Q + pr*x**2 + x**2*pe - - $ (ds**2*(1 + tau)*x**6*pe**2)/ - $ (c_beta**2* - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e))) - ELSE - C1=0 - C1p=0 - C2=0 - C2p=0 - ENDIF - - IF (PeOhmOnly_flag) THEN - G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + - $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) - ELSE - G=(x**2*pe + - $ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + - $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ - $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + - $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) - ENDIF - - C3=x**2/(x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + ifac*(Q - Q_e)) - - C3p=-((x**2*(2*x + (4*ds**2*(1 + tau)*x**3*pe)/ - $ c_beta**2))/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + (0,1)*(Q - Q_e))**2 - $ ) + (2*x)/ - $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ - $ c_beta**2 + (0,1)*(Q - Q_e)) - - A1=(C1 + (C3p/C3)*(C2 + 1) + C2p)/(C2 + 1) - - A2=(C1p + C1*(C3p/C3) - G/C3)/(C2 + 1) - - dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x - - RETURN - END SUBROUTINE w_der -c----------------------------------------------------------------------- -c riccati integration with simplified version for test. -c----------------------------------------------------------------------- - SUBROUTINE w_der_temp(neq,x,y,dy) - - INTEGER, INTENT(IN) :: neq - REAL(r8), INTENT(IN) :: x - COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y - COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy - !COMPLEX(r8), PARAMETER :: ifac=(0,1) - - dy(1)=(2.0*x/(ifac*(Q-Q_e)+x**2.0)-1.0/x)*y(1)-y(1)*y(1)/x - $ +x*(ifac*(Q-Q_e)+x**2.0) - $ *(-Q*(Q-Q_i)+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 - $ +pr*c_beta**2.0*x**4.0)/(ifac*(Q-Q_e) - $ +(c_beta**2.0+ifac*(Q-Q_i)*ds**2.0)*x**2.0 - $ +(1+tau)*pr*ds**2.0*x**4.0) - -c dy(1)=-y(1)/x-y(1)*y(1)/x+x*(ifac*(Q-Q_e)) -c $ *(-Q*(Q-Q_i)+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 -c $ +pr*c_beta**2.0*x**4.0)/(ifac*(Q-Q_e) -c $ +(c_beta**2.0+ifac*(Q-Q_i)*ds**2.0)*x**2.0 -c $ +(1+tau)*pr*ds**2.0*x**4.0) - - RETURN - END SUBROUTINE w_der_temp -c----------------------------------------------------------------------- -c calculate delta based on direct phi_der (obsolete). -c----------------------------------------------------------------------- - FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) - - REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds - REAL(r8),INTENT(IN) :: intau - COMPLEX(r8) :: directred - - INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf - - REAL(r8) :: xintv,x,xout,rtol,xmax - COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy - - INTEGER, DIMENSION(:), ALLOCATABLE :: iwork - REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork - - Q=inQ - Q_e=inQ_e - Q_i=inQ_i - pr=inpr - pe=inpe - c_beta=inc_beta - ds=inds - tau=intau - - neq = 4 - itol = 2 - rtol = 1e-3 - ALLOCATE(atol(neq),y(2),dy(2)) - atol(:) = 1e-4 - itask = 1 - istate = 1 - iopt = 0 - mf = 10 - liw = 20 - lrw = 22+16*neq - ALLOCATE(iwork(liw),rwork(lrw)) - - xintv = 0.1 - x=0.1 - istep=1 - xout=x+xintv - xmax=1e3 - - y(1)=1e-10 - y(2)=y(1)/(c_beta/(sqrt(1+tau)*ds)*(1+ifac*(Q-Q_e)*x**2.0)*x) - - DO - istep=istep+1 - CALL lsode(phi_der,neq,y,x,xout,itol,rtol,atol, - $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) - xout=xout+xintv - IF (xmax-xout.{bin,out}. +c +c----------------------------------------------------------------------- + FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, + $ iinQ,inx,iny) + +c --- input arguments: physical parameters for this surface + REAL(r8),INTENT(IN) :: inQ ! real part of Q + REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq + REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq + REAL(r8),INTENT(IN) :: inpr ! Prandtl number + REAL(r8),INTENT(IN) :: inpe ! electron Prandtl number + REAL(r8),INTENT(IN) :: inc_beta ! c_beta parameter + REAL(r8),INTENT(IN) :: inds ! magnetic shear ds + REAL(r8),INTENT(IN) :: intau ! ion-to-electron temp ratio +c --- optional arguments + REAL(r8),INTENT(IN),OPTIONAL :: iinQ ! imaginary part of Q + REAL(r8),INTENT(IN),OPTIONAL :: inx ! override starting x + COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W +c --- function result + COMPLEX(r8) :: riccati + +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER :: neq ! number of equations (=2) + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER :: liw,lrw ! lsode work array sizes + REAL(r8) :: x,xout ! current and target x + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance +c --- work arrays + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy ! W and dW + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work + REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work + +c --- copy input arguments to module-level globals for w_der + Q=inQ + IF(present(iinQ)) Q=inQ+ifac*iinQ + Q_e=inQ_e + Q_i=inQ_i + pr=inpr + pe=inpe + c_beta=inc_beta + ds=inds + tau=intau + +c --- singularity guard: displace Q away from Q_e when too close + IF ((layfac>0).AND.(ABS(Q-Q_e)xout) + istep=istep+1 + CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) + WRITE(bin_unit)REAL(x,4),REAL(REAL(y),4),REAL(AIMAG(y),4) + WRITE(out2_unit,'(1x,3(es17.8e3))') x,REAL(y),AIMAG(y) + ENDDO + CLOSE(bin_unit) + CLOSE(out2_unit) + ELSE +c single-shot integration to x_min + istep = 1 + itask = 1 + CALL lsode(w_der,neq,y,x,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) + ENDIF + +c --- extract Delta from final W derivative at x_min +c NOTE: W -> 0 when Q -> Q_e (see layfac guard above). + CALL w_der(neq,x,y,dy) + riccati=pi/dy(1) + DEALLOCATE(atol,y,dy,iwork,rwork) + + END FUNCTION riccati +c----------------------------------------------------------------------- +c riccati_del_s: compute Delta via the del_s Riccati formulation. +c +c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian +c (jac_del_s). Integrates W(q) from large q inward to q_min. +c Returns Delta = -(pi / sqrt(1+1/tau)) * W'(q_min). +c +c Module-level variables tau, D_norm, and P_tor must be valid +c before entry; callers are responsible for setting them. +c Q_e, Q_i, and P_perp are set from arguments inside this +c function. Q, c_beta, and d_beta are not referenced here. +c Note: slayer.f passes Q_e_arr (not Q_arr) as the first +c argument -- this is intentional. +c----------------------------------------------------------------------- + FUNCTION riccati_del_s(inQ_e,inQ_i,inpr,inx,iny) + +c --- input arguments + REAL(r8),INTENT(IN) :: inQ_e ! electron diamagnetic freq + REAL(r8),INTENT(IN) :: inQ_i ! ion diamagnetic freq + REAL(r8),INTENT(IN) :: inpr ! mapped to P_perp (see below) +c --- optional arguments + REAL(r8),INTENT(IN) :: inx ! starting q for integration + COMPLEX(r8),INTENT(IN),OPTIONAL :: iny ! override starting W +c --- function result + COMPLEX(r8) :: riccati_del_s + +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER :: neq ! number of equations (=2) + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER :: liw,lrw ! lsode work array sizes + REAL(r8) :: x ! secondary x variable (set from inx) + REAL(r8) :: xout ! target integration endpoint + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance + REAL(r8) :: my_q ! integration variable (large -> small) + REAL(r8) :: P_hat ! normalized P_perp + REAL(r8) :: alpha ! boundary condition coefficient +c --- work arrays + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: W,dW_dq ! W and dW/dq + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork ! lsode int work + REAL(r8), DIMENSION(:), ALLOCATABLE :: atol,rwork ! lsode real work + +c --- configure lsode: stiff BDF method with user Jacobian (mf=21) + neq = 2 + itol = 2 + rtol = 1e-10 + ALLOCATE(atol(neq),W(1),dW_dq(1)) + atol(:) = 1e-10 + itask = 2 + istate = 1 + iopt = 1 ! enable optional inputs (iwork(6)) + mf = 21 ! stiff, user-supplied Jacobian (jac_del_s) + liw = 20*2 + lrw = 22+9*neq+neq**2 ! stiff work array size + ALLOCATE(iwork(liw+neq),rwork(lrw)) + +c --- set maximum internal steps + iwork=0 + iwork(6)=50000 ! MXSTEP: max internal steps per call + rwork=0 + +c --- set starting integration point + my_q=inx ! start backwards integration at large q + xmin=1e-5 + x=inx + xout=xmin + +c --- copy input arguments to module-level globals for w_der_del_s + Q_e = inQ_e + Q_i = inQ_i + P_perp = inpr + + P_hat = P_perp / D_norm**6.0 + +c --- asymptotic boundary condition at large q + alpha = (P_hat/(1+1/tau))**0.5 + W(1) = -alpha*my_q**2 - 0.5 + IF(present(iny)) W(1)=iny + +c --- integrate W(q) from q_start inward to q_min via lsode + IF (riccati_out) THEN +c profile output: step-by-step integration with file writes + istep = 1 + itask = 2 + OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', + $ POSITION='REWIND',FORM='UNFORMATTED') + + OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') + WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" + DO WHILE (my_q>xout) + istep=istep+1 + CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) + WRITE(bin_unit)REAL(my_q,4),REAL(REAL(W),4),REAL(AIMAG(W),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')my_q,REAL(W),AIMAG(W) + ENDDO + CLOSE(bin_unit) + CLOSE(out2_unit) + ELSE +c single-shot integration to q_min + istep = 1 + itask = 1 + CALL lsode(w_der_del_s,neq,W,my_q,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_del_s,mf) + ENDIF + +c --- extract Delta from final W derivative at q_min + CALL w_der_del_s(neq,my_q,W,dW_dq) + riccati_del_s=-( pi/((1+1/tau)**0.5) )*dW_dq(1) + DEALLOCATE(atol,W,dW_dq,iwork,rwork) + + END FUNCTION riccati_del_s +c----------------------------------------------------------------------- +c jac_dummy: placeholder Jacobian for lsode calls whose method flag +c does not use a user-supplied Jacobian (mf=10, mf=22). lsode never +c calls it; it exists so that every lsode call in this module passes +c a subroutine in the JAC position. +c----------------------------------------------------------------------- + SUBROUTINE jac_dummy(neq, x, y, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: x + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + END SUBROUTINE jac_dummy +c----------------------------------------------------------------------- +c jacobian for riccati_del_s(): pd = dF/dW for stiff lsode. +c----------------------------------------------------------------------- + SUBROUTINE jac_del_s(neq, my_q, W, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: my_q + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + pd(1,1) = 1.0/my_q - 2.0d0*W(1)/my_q + END SUBROUTINE jac_del_s +c----------------------------------------------------------------------- +c w_der_del_s: ODE right-hand side dW/dq for riccati_del_s. +c Implements the del_s dispersion relation using normalised +c quantities Q_hat, P_perp_hat, P_tor_hat. +c----------------------------------------------------------------------- + SUBROUTINE w_der_del_s(neq,my_q,W,dW_dq) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: my_q + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dW_dq + REAL(r8) :: Q_hat, P_tor_hat, P_perp_hat + COMPLEX(r8) :: E,F + +c --- normalise physical quantities + Q_hat = (Q_e*(1+tau)/tau) / D_norm**4.0 + P_perp_hat = P_perp / D_norm**6.0 + P_tor_hat = P_tor / D_norm**6.0 +c --- build the E and F dispersion coefficients + E = (-(Q_hat**2)/(1+1/tau)) - ifac*Q_hat*(P_perp_hat+ + $ P_tor_hat)*(my_q**2) + P_perp_hat*P_tor_hat*(my_q**4) + F = P_perp_hat - ifac*Q_hat + (1+1/tau)*P_tor_hat*my_q**2 + +c --- Riccati ODE: dW/dq = W/q - W^2/q + q*E/F + dW_dq(1)=W(1)/my_q - (W(1)**2)/my_q + (my_q*E)/F + RETURN + END SUBROUTINE w_der_del_s +c----------------------------------------------------------------------- +c riccati_f: compute Delta via Fitzpatrick P_perp / P_tor +c Riccati formulation. +c +c Uses a stiff solver (lsode mf=21) with user-supplied Jacobian +c (jac_f). Boundary conditions are set analytically from the +c large-p asymptotic behaviour; the branch depends on whether +c D_norm^2 exceeds iota_e * P_perp / P_tor^(2/3). +c +c----------------------------------------------------------------------- + FUNCTION riccati_f() + +c --- function result + COMPLEX(r8) :: riccati_f + +c --- lsode solver control + INTEGER :: istep ! integration step counter + INTEGER, PARAMETER :: neq = 2 ! number of equations + INTEGER :: itol,itask ! lsode tolerance/task flags + INTEGER :: istate,iopt,mf ! lsode state/option/method flags + INTEGER, PARAMETER :: liw = 42 ! 20*2 + neq + INTEGER, PARAMETER :: lrw = 44 ! 22 + 9*neq + neq**2 + REAL(r8) :: xout ! target integration endpoint + REAL(r8) :: xmin ! inner integration bound + REAL(r8) :: rtol ! relative tolerance + REAL(r8) :: my_p ! integration variable p (large -> small) + REAL(r8) :: bk ! asymptotic coefficient b_k +c --- boundary-condition intermediates + COMPLEX(r8) :: ak ! asymptotic coefficient a_k + COMPLEX(r8) :: ck ! asymptotic coefficient c_k + COMPLEX(r8) :: xk ! asymptotic coefficient x_k + COMPLEX(r8) :: W_bound ! boundary value for W(p_start) +c --- work arrays (fixed-size, stack-allocated to avoid heap overhead) + COMPLEX(r8) :: W(1), dWdp(1) ! W and dW/dp + REAL(r8) :: atol(neq) ! absolute tolerance + INTEGER :: iwork(liw) ! lsode int work + REAL(r8) :: rwork(lrw) ! lsode real work + +c --- configure lsode: stiff BDF method with user Jacobian (mf=21) + itol = 2 + rtol = 1.0d-10 + atol(:) = 1.0d-10 + itask = 2 + istate = 1 + iopt = 1 ! enable optional inputs (iwork(6)) + mf = 21 ! stiff, user-supplied Jacobian (jac_f) + +c --- set maximum internal steps (only iwork(5:6) matter for lsode) + iwork(:) = 0 + iwork(6) = 50000 ! MXSTEP: max internal steps per call + rwork(:) = 0.0d0 + + xmin=1e-6 + xout=xmin + +c --- compute starting p and W boundary condition +c Branch on asymptotic regime: D_norm^2 vs iota_e*P_perp/P_tor^(2/3) +c --- branch 1: D_norm^2 > iota_e * P_perp / P_tor^(2/3) +c large-D_norm regime: p scales with (P_tor*D_norm^2/(iota_e*...)) + IF (D_norm**2 > iota_e*P_perp / P_tor**(2.0d0/3.0d0)) THEN + my_p = ( (P_tor*D_norm**2)/(iota_e*P_tor*P_perp) )**0.25d0 + my_p = MAX(my_p, 6.0d0) + + ak = -(g_tmp + ifac*Q_e) + bk = (iota_e*P_perp*P_tor)/(P_tor*D_norm**2) + + ck = bk*(1 + (g_tmp+ifac*Q_i) + $ *((P_tor+P_perp)/(P_tor*P_perp)) + $ - (P_perp + (g_tmp+ifac*Q_i)*D_norm**2) + $ *(iota_e/(P_tor*D_norm**2))) + + xk = (ck - SQRT(bk)*(1 - SQRT(bk)*ak)) / (2.0d0*SQRT(bk)) + + W_bound = xk - SQRT(bk)*my_p + ELSE +c --- branch 2: D_norm^2 <= iota_e * P_perp / P_tor^(2/3) +c small-D_norm regime: p scales with 1/P_tor^(1/6) + my_p = 1.0d0 / P_tor**(1.0d0/6.0d0) + my_p = MAX(my_p, 6.0d0) + + ak = -(g_tmp + ifac*Q_e) + bk = P_tor + ck = -ifac*(Q_e - Q_i)*(P_tor/P_perp) + (g_tmp + ifac*Q_i) + xk = (ak*bk - ck)/(2.0d0*SQRT(bk)) + + W_bound = -1.0d0 + xk*my_p - SQRT(bk)*my_p**3 + END IF + + W(1) = W_bound + +c --- integrate W(p) from p_start inward to p_min via lsode + IF (riccati_out) THEN +c profile output: step-by-step integration with file writes + istep = 1 + itask = 2 + OPEN(UNIT=bin_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn_str)//'.bin',STATUS='UNKNOWN', + $ POSITION='REWIND',FORM='UNFORMATTED') + + OPEN(UNIT=out2_unit,FILE='slayer_riccati_profile_n'// + $ TRIM(sn_str)//'.out',STATUS='UNKNOWN') + WRITE(out2_unit,'(1x,3(a17))'),"x","RE(y)","IM(y)" + DO WHILE (my_p>xout) + istep=istep+1 + CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) + WRITE(bin_unit)REAL(my_p,4),REAL(REAL(W),4), + $ REAL(AIMAG(W),4) + WRITE(out2_unit,'(1x,3(es17.8e3))')my_p,REAL(W),AIMAG(W) + ENDDO + CLOSE(bin_unit) + CLOSE(out2_unit) + ELSE +c single-shot integration to p_min + istep = 1 + itask = 1 + CALL lsode(w_der_f,neq,W,my_p,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_f,mf) + ENDIF + +c --- extract Delta from final W derivative at p_min + CALL w_der_f(neq,my_p,W,dWdp) + riccati_f = pi / dWdp(1) +c A failed integration (istate < 0) leaves W short of p_min. Return +c NaN so that scans and the root search skip the point instead of +c using a Delta built from an unconverged W. + IF (istate < 0) riccati_f = CMPLX( + $ ieee_value(1.0_r8, ieee_quiet_nan), + $ ieee_value(1.0_r8, ieee_quiet_nan), KIND=r8) + + END FUNCTION riccati_f +c----------------------------------------------------------------------- +c jacobian for riccati_f(): pd = dF/dW for stiff lsode. +c----------------------------------------------------------------------- + SUBROUTINE jac_f(neq, my_p, W, ml, mu, pd, nrpd) + INTEGER, INTENT(IN) :: neq, ml, mu, nrpd + REAL(r8), INTENT(IN) :: my_p + COMPLEX(r8) :: fA_p, denom + REAL(r8) :: p2 + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(nrpd,neq), INTENT(INOUT) :: pd + + p2 = my_p * my_p + denom = g_tmp + ifac*Q_e + p2 + fA_p = (denom - 2.0d0*p2) / denom + + pd(1,1) = (-fA_p/my_p) - (2.0d0*W(1))/my_p + END SUBROUTINE jac_f +c----------------------------------------------------------------------- +c w_der_f: ODE right-hand side dW/dp for riccati_f. +c Implements the Fitzpatrick P_perp / P_tor dispersion relation. +c Coefficients fA, fB, fC are evaluated at the current p. +c----------------------------------------------------------------------- + SUBROUTINE w_der_f(neq,my_p,W,dWdp) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: my_p + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: W + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dWdp + COMPLEX(r8) :: fA, fA_prime, fB, fC + COMPLEX(r8) :: denom ! cached g_tmp + i*Q_e + p^2 + REAL(r8) :: p2, p4 ! cached p^2, p^4 + REAL(r8) :: D2 ! cached D_norm^2 + +c cache powers and shared denominator + p2 = my_p * my_p + p4 = p2 * p2 + D2 = D_norm * D_norm + denom = g_tmp + ifac*Q_e + p2 + +c evaluate coefficients at the current p + fA = p2 / denom + fA_prime = (denom - 2.0d0*p2) / denom ! (g+iQe - p^2)/(g+iQe + p^2) + + fB = g_tmp*(g_tmp + ifac*Q_i) + $ + (g_tmp + ifac*Q_i)*(P_perp + P_tor)*p2 + $ + (P_perp*P_tor)*p4 + + fC = g_tmp + ifac*Q_e + $ + (P_perp + (g_tmp + ifac*Q_i)*D2)*p2 + $ + (1.0d0/iota_e)*P_tor*D2*p4 + + dWdp(1) = -(fA_prime/my_p)*W(1) - W(1)*W(1)/my_p + $ + (fB/(fA*fC))*(p2*my_p) + + RETURN + END SUBROUTINE w_der_f +c----------------------------------------------------------------------- +c W derivative for riccati() +c----------------------------------------------------------------------- + SUBROUTINE w_der(neq,x,y,dy) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: x + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy + COMPLEX(r8) :: G + COMPLEX(r8) :: C1 + COMPLEX(r8) :: C1p + COMPLEX(r8) :: C2 + COMPLEX(r8) :: C3 + COMPLEX(r8) :: C3p + COMPLEX(r8) :: C2p + COMPLEX(r8) :: A1 + COMPLEX(r8) :: A2 + !COMPLEX(r8), PARAMETER :: ifac=(0,1) + + IF (parflow_flag) THEN + C1=((1 + tau)*x**2*pe* + $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i)))) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i)))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2))/ + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + + C1p=((1 + tau)*x**2*pe* + $ ((2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ **2)/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** + $ 3 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (12*ds**2*pr*(1 + tau)*x**2 + + $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** + $ 2 - (2*(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** + $ 2 - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** + $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((12*ds**2*pr*(1 + tau)*x**2 + + $ 2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + $ + (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2 + $ - (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)**2* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**3 + $ + ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ (2*(2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ ((2*c_beta**2 + 12*ds**2*pr*tau*x**2)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ - ((1 + tau)*x**2*pe* + $ (2*pr*x + 2*x*pe + + $ (ds**2*(1 + tau)*x**6*pe**2* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2))/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + + $ ifac*(Q - Q_e))**2) - + $ (6*ds**2*(1 + tau)*x**5*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e) + $ )) - (ifac*(1 + tau)*x**2*pe* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2)*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ **2 + (2*ifac*(1 + tau)*x*pe* + $ Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ *(-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ ) + (ifac*(1 + tau)*x**2*pe* + $ Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ **2 + (2*(1 + tau)*x*pe* + $ (-(((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ **2) + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))+ + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + + C2=((1 + tau)*x**2*pe* + $ ((ds**2*x**4*pe)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ ) - (ifac*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + + C2p=((1 + tau)*x**2*pe* + $ (-((ds**2*x**4*pe* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2))/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + + $ ifac*(Q - Q_e))**2)) + + $ (4*ds**2*x**3*pe)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e) + $ )) + (ifac* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2)*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ **2 - ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4))* + $ (4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x*(c_beta**2 + ifac*ds**2*(Q - Q_i))))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))** + $ 2 + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (-((4*ds**2*pr*(1 + tau)*x**3 + + $ 2*x* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ /(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2* + $ (c_beta**2 + ifac*ds**2*(Q - Q_i))) + $ )/(ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)**2)) + $ /(ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))) + + $ ((2*c_beta**2*x + 4*ds**2*pr*tau*x**3)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ - ((1 + tau)*x**2*pe* + $ (2*pr*x + 2*x*pe + + $ (ds**2*(1 + tau)*x**6*pe**2* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2))/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + + $ ifac*(Q - Q_e))**2) - + $ (6*ds**2*(1 + tau)*x**5*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e) + $ )) - (ifac*(1 + tau)*x**2*pe* + $ (2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2)*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ **2 + (2*ifac*(1 + tau)*x*pe* + $ Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ *((ds**2*x**4*pe)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e) + $ )) - (ifac*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ ) + (ifac*(1 + tau)*x**2*pe* + $ Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ **2 + (2*(1 + tau)*x*pe* + $ ((ds**2*x**4*pe)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e) + $ )) - (ifac*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + $ + ((ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)* + $ (1 - (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + + $ ifac*ds**2*(Q - Q_i)))/ + $ (ifac*Q + c_beta**2*x**2 + ds**2*pr*tau*x**4)))/ + $ (ds**2*pr*(1 + tau)*x**4 + + $ ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i)))))/ + $ (ifac*Q + pr*x**2 + x**2*pe - + $ (ds**2*(1 + tau)*x**6*pe**2)/ + $ (c_beta**2* + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + $ + (ifac*(1 + tau)*x**2*pe*Q_e)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e))) + ELSE + C1=0 + C1p=0 + C2=0 + C2p=0 + ENDIF + + IF (PeOhmOnly_flag) THEN + G=((c_beta**2*pr*x**4 - Q*(Q - Q_i) + + $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) + ELSE + G=(x**2*pe + + $ (c_beta**2*pr*x**4 - Q*(Q - Q_i) + + $ ifac*(c_beta**2 + pr)*x**2*(Q - Q_i))/ + $ (ds**2*pr*(1 + tau)*x**4 + ifac*(Q - Q_e) + + $ x**2*(c_beta**2 + ifac*ds**2*(Q - Q_i))))*(x**2.0) + ENDIF + + C3=x**2/(x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + ifac*(Q - Q_e)) + + C3p=-((x**2*(2*x + (4*ds**2*(1 + tau)*x**3*pe)/ + $ c_beta**2))/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + (0,1)*(Q - Q_e))**2 + $ ) + (2*x)/ + $ (x**2 + (ds**2*(1 + tau)*x**4*pe)/ + $ c_beta**2 + (0,1)*(Q - Q_e)) + + A1=(C1 + (C3p/C3)*(C2 + 1) + C2p)/(C2 + 1) + + A2=(C1p + C1*(C3p/C3) - G/C3)/(C2 + 1) + + dy(1)=(-A1 + 1/x)*y(1) - y(1)*y(1)/x - A2*x + + RETURN + END SUBROUTINE w_der +c----------------------------------------------------------------------- +c riccati integration with simplified version for test. +c----------------------------------------------------------------------- + SUBROUTINE w_der_temp(neq,x,y,dy) + + INTEGER, INTENT(IN) :: neq + REAL(r8), INTENT(IN) :: x + COMPLEX(r8), DIMENSION(neq), INTENT(IN) :: y + COMPLEX(r8), DIMENSION(neq), INTENT(OUT) :: dy + !COMPLEX(r8), PARAMETER :: ifac=(0,1) + + dy(1)=(2.0*x/(ifac*(Q-Q_e)+x**2.0)-1.0/x)*y(1)-y(1)*y(1)/x + $ +x*(ifac*(Q-Q_e)+x**2.0) + $ *(-Q*(Q-Q_i)+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 + $ +pr*c_beta**2.0*x**4.0)/(ifac*(Q-Q_e) + $ +(c_beta**2.0+ifac*(Q-Q_i)*ds**2.0)*x**2.0 + $ +(1+tau)*pr*ds**2.0*x**4.0) + +c dy(1)=-y(1)/x-y(1)*y(1)/x+x*(ifac*(Q-Q_e)) +c $ *(-Q*(Q-Q_i)+ifac*(Q-Q_i)*(pr+c_beta**2.0)*x**2.0 +c $ +pr*c_beta**2.0*x**4.0)/(ifac*(Q-Q_e) +c $ +(c_beta**2.0+ifac*(Q-Q_i)*ds**2.0)*x**2.0 +c $ +(1+tau)*pr*ds**2.0*x**4.0) + + RETURN + END SUBROUTINE w_der_temp +c----------------------------------------------------------------------- +c calculate delta based on direct phi_der (obsolete). +c----------------------------------------------------------------------- + FUNCTION directred(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) + + REAL(r8),INTENT(IN) :: inQ,inQ_e,inQ_i,inpr,inpe,inc_beta,inds + REAL(r8),INTENT(IN) :: intau + COMPLEX(r8) :: directred + + INTEGER :: istep,neq,itol,itask,istate,liw,lrw,iopt,mf + + REAL(r8) :: xintv,x,xout,rtol,xmax + COMPLEX(r8), DIMENSION(:), ALLOCATABLE :: y,dy + + INTEGER, DIMENSION(:), ALLOCATABLE :: iwork + REAL(r8), DIMENSION(:), ALLOCATABLE :: xfac,atol,rwork + + Q=inQ + Q_e=inQ_e + Q_i=inQ_i + pr=inpr + pe=inpe + c_beta=inc_beta + ds=inds + tau=intau + + neq = 4 + itol = 2 + rtol = 1e-3 + ALLOCATE(atol(neq),y(2),dy(2)) + atol(:) = 1e-4 + itask = 1 + istate = 1 + iopt = 0 + mf = 10 + liw = 20 + lrw = 22+16*neq + ALLOCATE(iwork(liw),rwork(lrw)) + + xintv = 0.1 + x=0.1 + istep=1 + xout=x+xintv + xmax=1e3 + + y(1)=1e-10 + y(2)=y(1)/(c_beta/(sqrt(1+tau)*ds)*(1+ifac*(Q-Q_e)*x**2.0)*x) + + DO + istep=istep+1 + CALL lsode(phi_der,neq,y,x,xout,itol,rtol,atol, + $ itask,istate,iopt,rwork,lrw,iwork,liw,jac_dummy,mf) + xout=xout+xintv + IF (xmax-xout Date: Fri, 23 Oct 2026 11:01:12 -0400 Subject: [PATCH 112/118] SLAYER - MINOR - American spelling in screen output, NetCDF long_names and template comments Co-Authored-By: Claude Opus 5.5 --- docs/examples/DIIID_ideal_example/slayer.in | 2 +- input/slayer.in | 2 +- slayer/slayer.f | 8 ++++---- slayer/slayer_netcdf.f | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/docs/examples/DIIID_ideal_example/slayer.in b/docs/examples/DIIID_ideal_example/slayer.in index 74d6a001f..ea0424c63 100644 --- a/docs/examples/DIIID_ideal_example/slayer.in +++ b/docs/examples/DIIID_ideal_example/slayer.in @@ -50,7 +50,7 @@ Q_num=100 ! number of points per axis of the initial Re(Q),Im(Q) scan grid scan_width=1.5 ! half-width of the Re(Q),Im(Q) scan window, in normalized Q AMR_passes=4 ! number of adaptive refinement passes of the scan grid - !scan_center=0.0 ! Re(Q) centre of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan + !scan_center=0.0 ! Re(Q) center of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan msing_max=3 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" read_eq=t ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) diff --git a/input/slayer.in b/input/slayer.in index ec62d0815..8c420c247 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -50,7 +50,7 @@ Q_num=100 ! number of points per axis of the initial Re(Q),Im(Q) scan grid scan_width=1.5 ! half-width of the Re(Q),Im(Q) scan window, in normalized Q AMR_passes=4 ! number of adaptive refinement passes of the scan grid - !scan_center=0.0 ! Re(Q) centre of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan + !scan_center=0.0 ! Re(Q) center of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan msing_max=2 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" read_eq=f ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) diff --git a/slayer/slayer.f b/slayer/slayer.f index f1abce011..c35f22f70 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -270,7 +270,7 @@ PROGRAM slayer knum = 100 ! 2-D scan axis-2 resolution Q_num = 100 ! stability scan Re(Q) resolution scan_width = 2.0 ! half-width for complex-Q scans - ! Re(Q) centre of the scans. Left at HUGE, it is chosen by the + ! Re(Q) center of the scans. Left at HUGE, it is chosen by the ! code: zero, or the middle of the Doppler-shifted branches in ! a coupled scan with rotation. scan_center = HUGE(scan_center) @@ -831,7 +831,7 @@ PROGRAM slayer END IF IF (scan_center >= HUGE(scan_center)) scan_center = 0.0_r8 WRITE(*,'(A,ES11.4,A,ES11.4)') - $ ' Scan window: Re(Q) centre =',scan_center, + $ ' Scan window: Re(Q) center =',scan_center, $ ', half-width =',scan_width c----------------------------------------------------------------------- @@ -1046,7 +1046,7 @@ PROGRAM slayer CALL dispersion_AMR_v2(n_k,sl_in,msing_max,scan_width, $ Q_num,AMR_passes,coupling_flag,scan_center) - ! Zeros of the coupled determinant. Q is normalised by + ! Zeros of the coupled determinant. Q is normalized by ! the first surface's tau_k. The coupled eigenvalue is ! global, so it is reported through roots_out only and ! the per-surface gamma_sol_arr is left as NaN. @@ -1111,7 +1111,7 @@ PROGRAM slayer DO j = 1, Q_num ! This scan passes g = gamma_hat + i*omega_hat ! directly, so its imaginary axis is the frequency - ! and carries the scan-window centre. + ! and carries the scan-window center. ing_coarse = -scan_width + (i - 1) * ing_step iing_coarse = scan_center - scan_width $ + (j - 1) * ing_step diff --git a/slayer/slayer_netcdf.f b/slayer/slayer_netcdf.f index 99942fb50..e2ce42a98 100644 --- a/slayer/slayer_netcdf.f +++ b/slayer/slayer_netcdf.f @@ -339,7 +339,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ nf90_double, (/qsing_dim, i_dim/), dpp_id) ) CALL sl_check( nf90_put_att(ncid, dpp_id, "long_name", $ "Outer-region Delta_prime diagonal, referenced to unit "// - $ "normalised poloidal flux (as written by STRIDE)") ) + $ "normalized poloidal flux (as written by STRIDE)") ) CALL sl_check( nf90_def_var(ncid, "Delta_prime_rs_rational", $ nf90_double, (/qsing_dim, i_dim/), dprs_id) ) CALL sl_check( nf90_put_att(ncid, dprs_id, "long_name", @@ -412,7 +412,7 @@ SUBROUTINE slayer_netcdf_out(msing, m_AMR, est_gamma_flag, $ (/root_dim, nAMR_dim, i_dim/), qpole_id) ) CALL sl_check( nf90_put_att(ncid, qpole_id, "long_name", $ "Poles of the dispersion function, (omega, gamma)*"// - $ "tau_k, AMR cell centres") ) + $ "tau_k, AMR cell centers") ) CALL sl_check( nf90_def_var(ncid, "gamma_roots", $ NF90_DOUBLE, (/root_dim, nAMR_dim/), groot_id) ) CALL sl_check( nf90_put_att(ncid, groot_id, "units", "1/s") ) From ac23400023a7f066d8f507543df20471b014a59c Mon Sep 17 00:00:00 2001 From: d-burg Date: Fri, 23 Oct 2026 11:06:49 -0400 Subject: [PATCH 113/118] DOCS - MINOR - Refresh DIII-D SLAYER sample output after the develop equilibrium fixes Co-Authored-By: Claude Opus 5.5 --- docs/examples/DIIID_ideal_example/README | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/examples/DIIID_ideal_example/README b/docs/examples/DIIID_ideal_example/README index f699a00f0..c2af43b10 100644 --- a/docs/examples/DIIID_ideal_example/README +++ b/docs/examples/DIIID_ideal_example/README @@ -28,10 +28,10 @@ STRIDE also writes ``stride_output_n1.nc``, which holds the outer-region tearing slayer Calculating growth rate on m = 2 rational surface: - Delta_prime (r_s ref.): 5.93 ... + Delta_prime (r_s ref.): 5.94 ... Delta_crit: 33.3 Dispersion roots found: 1, poles: 1 - root 1: Q= -1.162346E+00 -4.163883E-02 omega[rad/s]= -1.059332E+04 gamma[1/s]= -3.794858E+02 polished=T + root 1: Q= -1.162293E+00 -4.163214E-02 omega[rad/s]= -1.059284E+04 gamma[1/s]= -3.794248E+02 polished=T Delta' is converted from STRIDE's normalized-flux reference length to the minor-radius reference that the layer quantities use before matching. With the default ``dc_type="rfitzp"`` critical Delta, the 2/1, 3/1 and 4/1 tearing modes are all damped here, because Delta_crit exceeds Delta' on each surface. Setting ``dc_type="none"`` drops this stabilization and leaves the 2/1 weakly unstable (gamma of about 80 /s). Each root is reported in its surface's ExB frame. The results, including every root and pole found in the scan, are written to ``slayer_output_n1.nc``. From 3aabb99795b78b7433770303f3594d722fb0924d Mon Sep 17 00:00:00 2001 From: logan-nc Date: Sat, 24 Oct 2026 10:25:38 -0400 Subject: [PATCH 114/118] SLAYER - BUG FIX - Initialize lnLamb, use per-surface tau and P_tor in the estimate, and stop on bad layer inputs - sglobal.f: lnLamb was an uninitialized variable set only in params(), so gpec_slayer (which never calls params) ran with lnLamb = 0 and produced infinite S and Q. Initialize it to 17, the old PARAMETER value. - slayer.f: the growth-rate estimate loop set only D_norm per surface; w_der_del_s also reads tau and P_tor, which still held the last surface's values. Set them per surface as the matching loop does. On the DIII-D example the 2/1-5/1 estimates change by 12-25%. - params.f: stop with a message naming the bad value and the surface when n_e, t_e or t_i is not positive, when the shear is zero, or when chi_perp is not positive where the critical Delta-prime needs it. These previously gave NaN or Inf, or an unexplained non-convergence stop. - TARGETS.inc: match only v* tags in the slayer version rule, as the other codes do. On a full clone the tps-pin-* tags gave a version string past column 72, and slayer_netcdf.f failed to compile. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01VMDGyfQKRZQMdk3NJXsKQE --- install/TARGETS.inc | 2 +- slayer/params.f | 24 ++++++++++++++++++++++++ slayer/sglobal.f | 2 +- slayer/slayer.f | 2 ++ 4 files changed, 28 insertions(+), 2 deletions(-) diff --git a/install/TARGETS.inc b/install/TARGETS.inc index 09b715202..8c9a5f1d0 100644 --- a/install/TARGETS.inc +++ b/install/TARGETS.inc @@ -299,7 +299,7 @@ rmatch: v neededdeps $(RMATCH_OBJS) equil lsode # SLAYER ../slayer/version.inc: - @ver="`git describe --tags`"; \ + @ver="`git describe --tags --match 'v[0-9]*'`"; \ if [ ! -f $@ ] || ! grep -F "'$$ver'" $@ >/dev/null 2>&1; then \ echo ">>> Updating version file"; \ echo " CHARACTER(len=*), PARAMETER :: version ='$$ver'" | tee $@; \ diff --git a/slayer/params.f b/slayer/params.f index 459d9b3a5..709cf640e 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -87,6 +87,23 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, REAL(r8) :: K_val, Csq ! kappa/eta and composite quantity c----------------------------------------------------------------------- +c stop on inputs that would give NaN or Inf below. +c----------------------------------------------------------------------- + IF (.NOT. (n_e > 0.0_r8 .AND. t_e > 0.0_r8 .AND. + $ t_i > 0.0_r8)) THEN + WRITE(*,*) 'ERROR: params needs positive n_e, t_e and t_i,' + WRITE(*,*) ' got n_e =',n_e,' [m^-3], t_e =',t_e, + $ ' [eV], t_i =',t_i,' [eV]' + WRITE(*,*) ' at q =',qval,'. Check the kinetic profiles.' + STOP 'params: non-positive density or temperature' + END IF + IF (sval == 0.0_r8) THEN + WRITE(*,*) 'ERROR: params needs a nonzero magnetic shear,' + WRITE(*,*) ' got sval = 0 at q =',qval,'. The Alfven time' + WRITE(*,*) ' and the layer widths are undefined.' + STOP 'params: zero magnetic shear' + END IF +c----------------------------------------------------------------------- c Coulomb logarithm, basic plasma quantities, and Spitzer c resistivity. c----------------------------------------------------------------------- @@ -217,6 +234,13 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- IF (ABS(dr_val) > 0.0_r8) THEN + IF (.NOT. (chis(1) > 0.0_r8)) THEN + WRITE(*,*) 'ERROR: the critical Delta-prime needs' + WRITE(*,*) ' chi_perp > 0, got chi_perp =',chis(1), + $ ' [m^2/s] at q =',qval,'.' + WRITE(*,*) ' Set chi_p_prof in slayer.in.' + STOP 'params: chi_perp must be positive' + END IF vte = SQRT((2.0_r8*(t_e*chag)) / m_e) chi_par_smfp = (1.581_r8*tau_ee*(vte**2.0_r8)) $ / (1.0_r8 + 0.2535_r8*Zeff) diff --git a/slayer/sglobal.f b/slayer/sglobal.f index cc93fa52c..cc7f68613 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -55,7 +55,7 @@ MODULE sglobal_mod REAL(r8) :: tau ! T_i / T_e REAL(r8) :: eta ! Spitzer resistivity [Ohm*m] REAL(r8) :: visc ! anomalous viscosity [m^2/s] - REAL(r8) :: lnLamb ! Coulomb logarithm (updated at runtime) + REAL(r8) :: lnLamb = 17.0_r8 ! Coulomb log, set by params() c --- length scales REAL(r8) :: rho_s ! ion Larmor radius at T_e [m] REAL(r8) :: d_i ! ion skin depth [m] diff --git a/slayer/slayer.f b/slayer/slayer.f index 2678b4b5b..f9bc89c44 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -637,6 +637,8 @@ PROGRAM slayer $ sl_in%qval_arr(k),' rational surface' D_norm = sl_in%D_norm_arr(k) + tau = sl_in%tau_arr(k) + P_tor = sl_in%P_tor_arr(k) ! First arg is Q_e (electron diamagnetic freq), not Q ! (ExB freq). This is intentional per riccati_del_s API. dels_db=riccati_del_s(sl_in%Q_e_arr(k), From 2100323c4a03cfd183ebb42153d327fce793f170 Mon Sep 17 00:00:00 2001 From: logan-nc Date: Sun, 25 Oct 2026 00:57:22 +0900 Subject: [PATCH 115/118] SLAYER - BUG FIX - Report unset namelist inputs, set gamma_fac in namelist mode, use per-surface shear, ds and Q in the Br threshold, drop dc_type lar, and carry |s| and n into every path Closes the six items left open in the review of #173. - slayer.f: the namelist has no silent defaults since this branch (zero means unset, or "compute" for inQ, inQ_e, inQ_i). A run that needs an unset input now stops with the variable, the value read and its v1.5 default, instead of running on zeros (inpr=0 gave LSODE atol=0, inds=0 gave 0/0 in the Riccati boundary condition). The dimensional inputs are checked when params() runs on the namelist, the Cole inputs when the single-surface riccati() block runs. That block is now also skipped for br_th_flag, which computes its own deltas per surface like the growth-rate modes. - slayer.f: gamma_fac was never set in namelist mode, so the estimate was 0. It is now rs*Re(delta_prime)/tau_r after params(), as build_inputs forms it from the r_s-referenced Delta_prime. The template with delta_prime=(5,0) estimates 102.7 Hz. - sglobal.f, growthrates.f, layerinputs.f, slayer.f: slayer_inputs_type carries shear_arr, ds_arr and Qexb_arr. The Br threshold loop used the namelist sval on every surface, Q0 = Q_e where the torque balance needs the ExB Q, and the Fitzpatrick D_norm in the Cole ds slot of riccati(). It now uses each surface's shear, ds and Q, as the other riccati() call sites do. On the DIII-D example with read_eq=t it gives finite thresholds on all five surfaces. - params.f, slayer.f: dc_type='lar' is removed. It was the rfitzp formula without the r_s normalization (lar = rfitzp/r_s), so it was dimensionally inconsistent and, corrected, a duplicate. It stops with a message like 'toroidal'. - gslayer.f: the GPEC path uses ABS(sval) in the Alfven time and n in Q_e, Q_i (GPEC passes the n = 1 diamagnetic frequencies), the same fixes ffa95f13 and d43cfb53 made in params.f and build_inputs. params.f: the namelist omega_e, omega_i carry n too. No change at n = 1 with positive shear. - DIIID README: the coupled scan needs msing_max=2 or a wider scan_width, since the Doppler shifts put the 2/1 outside the shipped window. With msing_max=2 the coupled root is omega = 30.93 krad/s, gamma = -379.6 /s. The DIII-D uncoupled run, a10 and the develop template give identical screen output and NetCDF before and after. Co-Authored-By: Claude Fable 5.1 --- docs/examples/DIIID_ideal_example/README | 2 +- docs/examples/DIIID_ideal_example/slayer.in | 2 +- input/slayer.in | 2 +- slayer/growthrates.f | 3 +- slayer/gslayer.f | 10 +- slayer/layerinputs.f | 9 +- slayer/params.f | 14 +-- slayer/sglobal.f | 5 +- slayer/slayer.f | 128 ++++++++++++++++++-- 9 files changed, 148 insertions(+), 27 deletions(-) diff --git a/docs/examples/DIIID_ideal_example/README b/docs/examples/DIIID_ideal_example/README index 59c6638b0..d27014464 100644 --- a/docs/examples/DIIID_ideal_example/README +++ b/docs/examples/DIIID_ideal_example/README @@ -35,7 +35,7 @@ STRIDE also writes ``stride_output_n1.nc``, which holds the outer-region tearing Delta' is converted from STRIDE's normalized-flux reference length to the minor-radius reference that the layer quantities use before matching. With the default ``dc_type="rfitzp"`` critical Delta, the 2/1, 3/1 and 4/1 tearing modes are all damped here, because Delta_crit exceeds Delta' on each surface. Setting ``dc_type="none"`` drops this stabilization and leaves the 2/1 weakly unstable (gamma of about 80 /s). Each root is reported in its surface's ExB frame. The results, including every root and pole found in the scan, are written to ``slayer_output_n1.nc``. -Setting ``coupling_flag=t`` instead solves the coupled multi-surface dispersion relation for the first ``msing_max`` surfaces. Each surface is then Doppler-shifted by its ExB rotation from the kinetic file, so the root is reported in the lab frame. +Setting ``coupling_flag=t`` instead solves the coupled multi-surface dispersion relation for the first ``msing_max`` surfaces. Each surface is then Doppler-shifted by its ExB rotation from the kinetic file, so the root is reported in the lab frame. The Doppler shifts spread the branches apart in Re(Q): with the shipped ``msing_max=3`` and ``scan_width=1.5`` the 2/1 branch falls outside the scan window (SLAYER prints a warning), so for the coupled run set ``msing_max=2`` or widen ``scan_width``. Satisfied with the DCON result, we run GPEC, which computes the ideal plasma response to the external 3D field from the coils defined in ``coil.in``:: diff --git a/docs/examples/DIIID_ideal_example/slayer.in b/docs/examples/DIIID_ideal_example/slayer.in index b7580351f..418990132 100644 --- a/docs/examples/DIIID_ideal_example/slayer.in +++ b/docs/examples/DIIID_ideal_example/slayer.in @@ -52,7 +52,7 @@ AMR_passes=4 ! number of adaptive refinement passes of the scan grid !scan_center=0.0 ! Re(Q) center of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan msing_max=3 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t - dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" + dc_type="rfitzp" ! critical Delta model: "rfitzp" (default) or "none" read_eq=t ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation coupling_flag=f ! solve the coupled multi-surface determinant instead of each surface separately. Requires read_eq=t diff --git a/input/slayer.in b/input/slayer.in index 09ae33cd4..6e03c57a9 100644 --- a/input/slayer.in +++ b/input/slayer.in @@ -52,7 +52,7 @@ AMR_passes=4 ! number of adaptive refinement passes of the scan grid !scan_center=0.0 ! Re(Q) center of the scan window. Unset: 0, or the middle of the Doppler-shifted branches of a coupled scan msing_max=2 ! number of rational surfaces (counted from the core) to scan, and to couple when coupling_flag=t - dc_type="rfitzp" ! critical Delta model: "rfitzp" (default), "lar", or "none" + dc_type="rfitzp" ! critical Delta model: "rfitzp" (default) or "none" read_eq=f ! read the equilibrium and Delta' from STRIDE (ncfile) and profiles from the kinetic file (infile) Pperp_Ptor_flag=t ! Use R. Fitzpatrick formalism (inc. anomalous diffusion) for growth rate calculation coupling_flag=f ! solve the coupled multi-surface determinant instead of each surface separately. Requires read_eq=t diff --git a/slayer/growthrates.f b/slayer/growthrates.f index e76de684c..667e26294 100644 --- a/slayer/growthrates.f +++ b/slayer/growthrates.f @@ -97,7 +97,8 @@ SUBROUTINE allocate_inputs(n_k,sl_in) $ sl_in%Re_dp_psi_arr(n_k),sl_in%Im_dp_psi_arr(n_k), $ sl_in%k_ref_arr(n_k),sl_in%alpha_arr(n_k), $ sl_in%D_fac_arr(n_k),sl_in%q_shift_arr(n_k), - $ sl_in%q_arr(n_k)) + $ sl_in%q_arr(n_k),sl_in%Qexb_arr(n_k),sl_in%shear_arr(n_k), + $ sl_in%ds_arr(n_k)) sl_in%q_shift_arr = 0.0_r8 c namelist inputs are taken as already r_s-referenced: identity c reference-length conversion (K = 1). diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 265316b11..7b097962c 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -169,7 +169,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, b_l=(nrs/mrs)*nrs*sval*bt/R0 ! characteristic magnetic field rho_s=1.02e-4*(mu_i*t_e)**0.5/bt ! ion Larmor radius at T_e - tau_h=R0*(mu0*rho)**0.5/(nns*sval*bt) ! Alfven transit time + tau_h=R0*(mu0*rho)**0.5/(nns*ABS(sval)*bt) ! Alfven time, |s| tau_r=mu0*rs**2.0/eta ! resistive diffusion time tau_v=tau_r/inpr ! viscous diffusion time visc= rho*rs**2.0/tau_v ! back-calculated viscosity @@ -177,10 +177,12 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, lu=tau_r/tau_h ! Lundquist number Qconv=lu**(1.0/3.0)*tau_h ! Q normalisation factor -c --- normalised frequencies +c --- normalised frequencies. GPEC passes the n = 1 diamagnetic +c frequencies (gpout.f); omega_* = n*(dp/dpsi)/(e*n_e), as in +c build_inputs (layerinputs.f). Q=Qconv*omega - Q_e=-Qconv*omega_e - Q_i=-Qconv*omega_i + Q_e=-Qconv*nns*omega_e + Q_i=-Qconv*nns*omega_i ds=lu**(1.0/3.0)*rho_s/rs ! normalised ion sound radius diff --git a/slayer/layerinputs.f b/slayer/layerinputs.f index a5532ea55..84759b5e9 100644 --- a/slayer/layerinputs.f +++ b/slayer/layerinputs.f @@ -414,7 +414,9 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) $ sl_in%Qconv_arr(msing), $ sl_in%Re_dp_psi_arr(msing), sl_in%Im_dp_psi_arr(msing), $ sl_in%k_ref_arr(msing), sl_in%alpha_arr(msing), - $ sl_in%q_shift_arr(msing), sl_in%q_arr(msing)) + $ sl_in%q_shift_arr(msing), sl_in%q_arr(msing), + $ sl_in%Qexb_arr(msing), sl_in%shear_arr(msing), + $ sl_in%ds_arr(msing)) sl_in%q_shift_arr = 0.0_r8 c --- allocate local kinetic arrays (for future NetCDF diagnostic output) @@ -661,6 +663,11 @@ SUBROUTINE build_inputs(infile,ncfile,sl_in,zeff_in,mu_i_in) sl_in%P_perp_arr(ising) = P_perp sl_in%P_tor_arr(ising) = P_tor sl_in%Qconv_arr(ising) = tauk +c the shear, Cole ds and unperturbed ExB Q as params() formed +c them, for the torque-balance (br_th_flag) path + sl_in%shear_arr(ising) = s_fitz + sl_in%ds_arr(ising) = ds + sl_in%Qexb_arr(ising) = REAL(Q,r8) ENDDO c convert the full Deltaprime matrix to the r_s reference length diff --git a/slayer/params.f b/slayer/params.f index 709cf640e..3ee8d8753 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -170,9 +170,14 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c caller does not provide them (l_n <= 0 or l_t <= 0). Callers that c compute omega_e/omega_i by other means must set Q_e and Q_i c themselves afterwards. +c omega_* = k_theta*v_* carries the toroidal mode number through +c m = n*q: the n = 1 expression is multiplied by n, as in +c build_inputs (layerinputs.f). IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN - omega_e = -t_e/(bt*R0)*(1.0_r8/l_n + 1.0_r8/l_t)*qval - omega_i = t_i/(bt*R0)*(1.0_r8/l_n + 1.0_r8/l_t)*qval + omega_e = -REAL(nn,r8)*t_e/(bt*R0) + $ *(1.0_r8/l_n + 1.0_r8/l_t)*qval + omega_i = REAL(nn,r8)*t_i/(bt*R0) + $ *(1.0_r8/l_n + 1.0_r8/l_t)*qval Q_e = -Qconv * omega_e Q_i = -Qconv * omega_i END IF @@ -228,7 +233,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c The island-width Wd is iterated to converge the c short-mfp / long-mfp interpolation for chi_parallel. c dc_type (from sglobal_mod) selects the formula: -c 'lar' -- cylindrical (Lutjens) c 'rfitzp' -- R. Fitzpatrick c default -- dc_tmp = 0 c----------------------------------------------------------------------- @@ -266,10 +270,6 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, END IF SELECT CASE(dc_type) - CASE('lar') - dc_tmp = 0.5_r8*(-dr_val)*(pi**1.5_r8) - $ *((chi_par/chis(1))**0.25_r8) - $ *( (nr*ABS(sval))/(R0*rs) )**0.5_r8 CASE('rfitzp') dc_tmp = -(SQRT(2.0_r8)*(pi**(1.5_r8))*dr_val) / Wd CASE default diff --git a/slayer/sglobal.f b/slayer/sglobal.f index cc7f68613..1abd62098 100644 --- a/slayer/sglobal.f +++ b/slayer/sglobal.f @@ -85,7 +85,7 @@ MODULE sglobal_mod c --- stability / Delta_crit REAL(r8) :: dc_tmp ! computed Delta_crit COMPLEX(r8) :: delta_eff ! (Deltaprime - Delta_crit)/S^(1/3) - CHARACTER(20) :: dc_type ! dc formula: 'rfitzp','lar','none' + CHARACTER(20) :: dc_type ! dc formula: 'rfitzp','none' c --- solver workspace / results COMPLEX(r8) :: g_tmp ! temporary complex growth rate REAL(r8) :: gamma_fac ! growth-rate conversion factor @@ -168,6 +168,9 @@ MODULE sglobal_mod REAL(r8), ALLOCATABLE :: P_perp_arr(:) ! perp Prandtl number REAL(r8), ALLOCATABLE :: P_tor_arr(:) ! toroidal Prandtl REAL(r8), ALLOCATABLE :: omegas_arr(:) ! ExB rotation per unit n [rad/s] + REAL(r8), ALLOCATABLE :: Qexb_arr(:) ! normalised ExB Q + REAL(r8), ALLOCATABLE :: shear_arr(:) ! shear for params() + REAL(r8), ALLOCATABLE :: ds_arr(:) ! Cole normalised rho_s REAL(r8), ALLOCATABLE :: q_shift_arr(:) ! ExB Doppler shift of Q REAL(r8), ALLOCATABLE :: omegas_e_arr(:) ! omega_e [rad/s] REAL(r8), ALLOCATABLE :: omegas_i_arr(:) ! omega_i [rad/s] diff --git a/slayer/slayer.f b/slayer/slayer.f index f9bc89c44..ae809ae21 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -26,6 +26,7 @@ PROGRAM slayer INTEGER :: i,j,k ! general loop indices INTEGER :: inn ! number of input-file surfaces INTEGER :: count ! generic counter + INTEGER :: nbad ! namelist inputs left unset c----------------------------------------------------------------------- c local scalars — numerical resolution. c----------------------------------------------------------------------- @@ -359,19 +360,87 @@ PROGRAM slayer ! Critical-Delta model: fail on a misspelt name rather than ! silently running without the stabilising offset. SELECT CASE (TRIM(dc_type)) - CASE ('rfitzp','lar','none','') + CASE ('rfitzp','none','') CASE ('toroidal') WRITE(*,*) "ERROR: dc_type='toroidal' is not available." WRITE(*,*) " Its geometric factor was not correct in the" WRITE(*,*) " r_s reference length and has been removed." WRITE(*,*) " Use dc_type='rfitzp'." STOP 'slayer: dc_type toroidal removed' + CASE ('lar') + WRITE(*,*) "ERROR: dc_type='lar' is not available." + WRITE(*,*) " It was the rfitzp formula without its r_s" + WRITE(*,*) " normalization (rfitzp/r_s) and has been" + WRITE(*,*) " removed. Use dc_type='rfitzp' or 'none'." + STOP 'slayer: dc_type lar removed' CASE DEFAULT WRITE(*,*) "ERROR: unknown dc_type='",TRIM(dc_type),"'." - WRITE(*,*) " Use 'rfitzp', 'lar' or 'none'." + WRITE(*,*) " Use 'rfitzp' or 'none'." STOP 'slayer: unknown dc_type' END SELECT +c----------------------------------------------------------------------- +c check that the inputs this run needs were set. Since v1.6 the +c namelist has no silent defaults: zero means "not set", or for +c inQ, inQ_e and inQ_i "compute from the profiles". A v1.5 input +c that omitted a variable is reported with the old default. +c----------------------------------------------------------------------- + nbad = 0 + ! dimensional inputs: needed when params() runs on the namelist + IF (.NOT. read_eq .AND. (params_flag .OR. est_gamma_flag .OR. + $ match_gamma_flag .OR. br_th_flag .OR. onscan_flag .OR. + $ otscan_flag .OR. ntscan_flag .OR. nbtscan_flag)) THEN + IF (mm <= 0) CALL slayer_unset('mm',REAL(mm,r8),'2',nbad) + IF (nn <= 0) CALL slayer_unset('nn',REAL(nn,r8),'1',nbad) + IF (.NOT. n_e > 0.0_r8) + $ CALL slayer_unset('n_e',n_e,'1e19 [m^-3]',nbad) + IF (.NOT. t_e > 0.0_r8) + $ CALL slayer_unset('t_e',t_e,'1e3 [eV]',nbad) + IF (.NOT. t_i > 0.0_r8) + $ CALL slayer_unset('t_i',t_i,'1e3 [eV]',nbad) + IF (sval == 0.0_r8) CALL slayer_unset('sval',sval,'2.0',nbad) + IF (.NOT. bt > 0.0_r8) CALL slayer_unset('bt',bt,'1.0',nbad) + IF (.NOT. rs > 0.0_r8) CALL slayer_unset('rs',rs,'0.5',nbad) + IF (.NOT. R0 > 0.0_r8) CALL slayer_unset('R0',R0,'1.0',nbad) + IF (.NOT. mu_i > 0.0_r8) + $ CALL slayer_unset('mu_i',mu_i,'2.0',nbad) + IF (.NOT. zeff > 0.0_r8) + $ CALL slayer_unset('zeff',zeff,'2.0',nbad) + ! the gradient lengths give omega_e, omega_i unless a + ! growth-rate run overrides both Q_e and Q_i + IF (.NOT. ((est_gamma_flag .OR. match_gamma_flag) .AND. + $ inQ_e /= 0.0_r8 .AND. inQ_i /= 0.0_r8)) THEN + IF (.NOT. l_n > 0.0_r8) + $ CALL slayer_unset('l_n',l_n,'0.2 [m]',nbad) + IF (.NOT. l_t > 0.0_r8) + $ CALL slayer_unset('l_t',l_t,'0.2 [m]',nbad) + END IF + END IF + ! Cole-model inputs: needed by the single-surface riccati() call + ! below and the legacy scans, which run unless a growth-rate or + ! Br-threshold mode is on. inpr is a namelist input there. + IF (.NOT. (est_gamma_flag .OR. match_gamma_flag .OR. + $ br_th_flag)) THEN + IF (.NOT. inpr > 0.0_r8) + $ CALL slayer_unset('inpr',inpr,'1.0',nbad) + IF (.NOT. params_flag) THEN + IF (.NOT. inds > 0.0_r8) + $ CALL slayer_unset('inds',inds,'6.0',nbad) + IF (.NOT. intau > 0.0_r8) + $ CALL slayer_unset('intau',intau,'1.0',nbad) + END IF + END IF + IF (nbad > 0) THEN + WRITE(*,*) ' Since v1.6 SLAYER sets none of these silently.' + WRITE(*,*) ' Set them in slayer.in, or set read_eq=t to take' + WRITE(*,*) ' them from STRIDE and the kinetic profile file.' + WRITE(*,*) ' Other v1.5 defaults, for reference: inQ=20,' + WRITE(*,*) ' inQ_e=2, inQ_i=-2.6, inc_beta=0.7, Q0=4,' + WRITE(*,*) ' delta_n_p=(1e-2,1e-2). Zero is a valid choice' + WRITE(*,*) ' for those (no rotation or drift).' + STOP 'slayer: required inputs unset' + END IF + ! Real copies of the mode numbers, read by params() in every ! namelist-driven branch below. build_inputs resets them from ! the STRIDE run when read_eq is set. @@ -415,9 +484,11 @@ PROGRAM slayer c skipped when the matched-gamma path is active (it computes c its own delta internally). c----------------------------------------------------------------------- -c Also skipped for the growth-rate estimate, which does not use -c it and is usually run with these namelist inputs unset. - IF (.NOT. (match_gamma_flag .OR. est_gamma_flag)) THEN +c Also skipped for the growth-rate estimate and the Br threshold, +c which do not use it and are usually run with these namelist +c inputs unset. + IF (.NOT. (match_gamma_flag .OR. est_gamma_flag .OR. + $ br_th_flag)) THEN delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] @@ -601,6 +672,9 @@ PROGRAM slayer ELSE D_norm = slayer_d_norm(D_fac,Q_e,Q_i) END IF + ! Deltaprime -> gamma conversion, formed as in build_inputs + ! from the r_s-referenced Deltaprime and the resistive time + gamma_fac = rs*REAL(delta_prime)/tau_r CALL allocate_inputs(n_k,sl_in) ! growthrates_mod CALL allocate_outputs(n_k,sl_out) ! growthrates_mod @@ -608,7 +682,9 @@ PROGRAM slayer sl_in%qval_arr = (/ mm /) sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) - !sl_in%Q_arr = (/ Q /) + sl_in%Qexb_arr = (/ REAL(Q,r8) /) + sl_in%shear_arr = (/ sval /) + sl_in%ds_arr = (/ ds /) sl_in%Q_e_arr = (/ Q_e /) sl_in%Q_i_arr = (/ Q_i /) sl_in%psi_n_arr = (/ 0.0 /) @@ -744,6 +820,9 @@ PROGRAM slayer ELSE D_norm = slayer_d_norm(D_fac,Q_e,Q_i) END IF + ! Deltaprime -> gamma conversion, formed as in build_inputs + ! from the r_s-referenced Deltaprime and the resistive time + gamma_fac = rs*REAL(delta_prime)/tau_r IF (.NOT. est_gamma_flag) THEN CALL allocate_inputs(n_k,sl_in) @@ -753,7 +832,9 @@ PROGRAM slayer sl_in%qval_arr = (/ mm /) sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) - !sl_in%Q_arr = (/ Q /) + sl_in%Qexb_arr = (/ REAL(Q,r8) /) + sl_in%shear_arr = (/ sval /) + sl_in%ds_arr = (/ ds /) sl_in%Q_e_arr = (/ Q_e /) sl_in%Q_i_arr = (/ Q_i /) sl_in%psi_n_arr = (/ 0.0 /) @@ -1192,6 +1273,9 @@ PROGRAM slayer sl_in%qval_arr = (/ mm /) sl_in%q_arr = (/ qval /) sl_in%omegas_arr = (/ omega /) + sl_in%Qexb_arr = (/ REAL(Q,r8) /) + sl_in%shear_arr = (/ sval /) + sl_in%ds_arr = (/ ds /) sl_in%Q_e_arr = (/ Q_e /) sl_in%Q_i_arr = (/ Q_i /) sl_in%psi_n_arr = (/ 0.0 /) @@ -1230,9 +1314,11 @@ PROGRAM slayer inQ_i = Q_i inpr = sl_in%P_perp_arr(k) inc_beta = sl_in%c_beta_arr(k) - inds = sl_in%D_norm_arr(k) + ! riccati() takes the Cole ds and the torque balance the + ! unperturbed ExB Q, as at the other call sites above + inds = sl_in%ds_arr(k) intau = sl_in%tau_arr(k) - Q0 = sl_in%Q_e_arr(k) + Q0 = sl_in%Qexb_arr(k) ALLOCATE(inQs(0:inum),deltal(0:inum), $ jxbl(0:inum),bal(0:inum)) @@ -1247,7 +1333,7 @@ PROGRAM slayer iloc=MAXLOC(bal) Q_sol=inQs(iloc(1)) br_th=SQRT(MAXVAL(bal)/sl_in%lu_arr(k) - $ *(sval**2.0/2.0)) + $ *(sl_in%shear_arr(k)**2.0/2.0)) sl_out%br_th_arr(k) = br_th sl_out%gamma_sol_arr(k) = 0.0 @@ -1990,5 +2076,27 @@ PROGRAM slayer DEALLOCATE(inQs,bal,js,ks,Q_sols,br_ths) ENDIF + CONTAINS +c----------------------------------------------------------------------- +c report a namelist input that this run needs but was left unset, +c with the default v1.5 used silently in its place. +c----------------------------------------------------------------------- + SUBROUTINE slayer_unset(name,val,v15,nbad) + + CHARACTER(*), INTENT(IN) :: name ! namelist variable + REAL(r8), INTENT(IN) :: val ! value read + CHARACTER(*), INTENT(IN) :: v15 ! v1.5 default + INTEGER, INTENT(INOUT) :: nbad ! running count + + IF (nbad == 0) THEN + WRITE(*,*) 'ERROR: slayer.in leaves required inputs unset:' + END IF + WRITE(*,'(4x,a,a,es10.3,a,a,a)') name,' = ',val, + $ ' (v1.5 default: ',v15,')' + nbad = nbad+1 + + RETURN + END SUBROUTINE slayer_unset + END PROGRAM slayer From b7fb8a497e42e150570380be1761f65eeae780d1 Mon Sep 17 00:00:00 2001 From: logan-nc Date: Sun, 25 Oct 2026 02:11:45 +0900 Subject: [PATCH 116/118] SLAYER - BUG FIX - Check qval and the params_flag path in the unset-input report, and say plainly where GPEC's n enters Follow-ups from an independent review of 2100323c: - qval is needed with l_n and l_t for the namelist omega_e, omega_i; without it params() stopped in slayer_d_norm with a Q_e = Q_i message instead of naming qval. It is now in the report (v1.5 default 2.0). - The IF (params_flag) block calls params() on the namelist values whatever read_eq is, and params_flag defaults to true, so the dimensional inputs are now checked whenever params_flag is set, not only when read_eq is false. read_eq=t with params_flag=t and no density now reports n_e instead of failing inside params(). - The report's hint about read_eq applies to the dimensional inputs only; reworded. The Cole-input comment no longer says the legacy scans are skipped by est_gamma_flag (they are not). - gslayer.f, params.f comments: GPEC hands gpec_slayer the bare diamagnetic frequencies with no toroidal mode number attached, and GPEC's own nn multiplies them there; slayer.in is not read by GPEC. The DIII-D run, a10 and the develop template are unchanged. Co-Authored-By: Claude Fable 5.1 --- slayer/gslayer.f | 8 +++++--- slayer/params.f | 4 ++-- slayer/slayer.f | 20 ++++++++++++-------- 3 files changed, 19 insertions(+), 13 deletions(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 7b097962c..3ce664472 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -177,9 +177,11 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, lu=tau_r/tau_h ! Lundquist number Qconv=lu**(1.0/3.0)*tau_h ! Q normalisation factor -c --- normalised frequencies. GPEC passes the n = 1 diamagnetic -c frequencies (gpout.f); omega_* = n*(dp/dpsi)/(e*n_e), as in -c build_inputs (layerinputs.f). +c --- normalised frequencies. GPEC passes the bare diamagnetic +c frequencies (dp/dpsi)/(e*n_e) with no toroidal mode number +c attached (gpout.f); omega_* = k_theta*v_* = n*(dp/dpsi)/(e*n_e), +c so GPEC's n (nns) multiplies them here, as in build_inputs +c (layerinputs.f). Q=Qconv*omega Q_e=-Qconv*nns*omega_e Q_i=-Qconv*nns*omega_i diff --git a/slayer/params.f b/slayer/params.f index 3ee8d8753..d503f66cd 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -171,8 +171,8 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c compute omega_e/omega_i by other means must set Q_e and Q_i c themselves afterwards. c omega_* = k_theta*v_* carries the toroidal mode number through -c m = n*q: the n = 1 expression is multiplied by n, as in -c build_inputs (layerinputs.f). +c m = n*q: the bare gradient-length expression is multiplied by +c n, as in build_inputs (layerinputs.f). IF (l_n > 0.0_r8 .AND. l_t > 0.0_r8) THEN omega_e = -REAL(nn,r8)*t_e/(bt*R0) $ *(1.0_r8/l_n + 1.0_r8/l_t)*qval diff --git a/slayer/slayer.f b/slayer/slayer.f index ae809ae21..941e94292 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -387,9 +387,10 @@ PROGRAM slayer c----------------------------------------------------------------------- nbad = 0 ! dimensional inputs: needed when params() runs on the namelist - IF (.NOT. read_eq .AND. (params_flag .OR. est_gamma_flag .OR. + ! (params_flag does so even with read_eq) + IF (params_flag .OR. (.NOT. read_eq .AND. (est_gamma_flag .OR. $ match_gamma_flag .OR. br_th_flag .OR. onscan_flag .OR. - $ otscan_flag .OR. ntscan_flag .OR. nbtscan_flag)) THEN + $ otscan_flag .OR. ntscan_flag .OR. nbtscan_flag))) THEN IF (mm <= 0) CALL slayer_unset('mm',REAL(mm,r8),'2',nbad) IF (nn <= 0) CALL slayer_unset('nn',REAL(nn,r8),'1',nbad) IF (.NOT. n_e > 0.0_r8) @@ -406,7 +407,7 @@ PROGRAM slayer $ CALL slayer_unset('mu_i',mu_i,'2.0',nbad) IF (.NOT. zeff > 0.0_r8) $ CALL slayer_unset('zeff',zeff,'2.0',nbad) - ! the gradient lengths give omega_e, omega_i unless a + ! the gradient lengths and q give omega_e, omega_i unless a ! growth-rate run overrides both Q_e and Q_i IF (.NOT. ((est_gamma_flag .OR. match_gamma_flag) .AND. $ inQ_e /= 0.0_r8 .AND. inQ_i /= 0.0_r8)) THEN @@ -414,11 +415,13 @@ PROGRAM slayer $ CALL slayer_unset('l_n',l_n,'0.2 [m]',nbad) IF (.NOT. l_t > 0.0_r8) $ CALL slayer_unset('l_t',l_t,'0.2 [m]',nbad) + IF (.NOT. qval > 0.0_r8) + $ CALL slayer_unset('qval',qval,'2.0',nbad) END IF END IF ! Cole-model inputs: needed by the single-surface riccati() call - ! below and the legacy scans, which run unless a growth-rate or - ! Br-threshold mode is on. inpr is a namelist input there. + ! below, which runs unless a growth-rate or Br-threshold mode is + ! on, and by the legacy scans. inpr is a namelist input there. IF (.NOT. (est_gamma_flag .OR. match_gamma_flag .OR. $ br_th_flag)) THEN IF (.NOT. inpr > 0.0_r8) @@ -431,9 +434,10 @@ PROGRAM slayer END IF END IF IF (nbad > 0) THEN - WRITE(*,*) ' Since v1.6 SLAYER sets none of these silently.' - WRITE(*,*) ' Set them in slayer.in, or set read_eq=t to take' - WRITE(*,*) ' them from STRIDE and the kinetic profile file.' + WRITE(*,*) ' Since v1.6 SLAYER sets none of these silently;' + WRITE(*,*) ' set them in slayer.in. (With read_eq=t and' + WRITE(*,*) ' params_flag=f the dimensional inputs come from' + WRITE(*,*) ' STRIDE and the kinetic profile file instead.)' WRITE(*,*) ' Other v1.5 defaults, for reference: inQ=20,' WRITE(*,*) ' inQ_e=2, inQ_i=-2.6, inc_beta=0.7, Q0=4,' WRITE(*,*) ' delta_n_p=(1e-2,1e-2). Zero is a valid choice' From ba7a17f922a74b46d446cb3c60fe4e96a6f644c9 Mon Sep 17 00:00:00 2001 From: logan-nc Date: Sun, 25 Oct 2026 02:55:43 +0900 Subject: [PATCH 117/118] SLAYER - BUG FIX - Carry n into the ExB Q, pass ds to the Cole stabscan, guard the Br threshold against NaN, and report Q_sol at the right grid point Closes the remaining points from the independent review of #173 so that 1.6.0 leaves no SLAYER follow-ups behind. - gslayer.f, params.f: the normalised ExB Q now carries the toroidal mode number like Q_e and Q_i already did (Q = Qconv*n*omega_E), the Doppler frequency the layer sees and the convention of the coupled determinant's shift. Before, the torque balance 2*pr*(Q0 - Q) compared an n-free Q0 with n-scaled Q_e for n >= 2. gpec_slayer's omega_sol is divided by n again so it stays a fluid rotation frequency. GPEC passes the bare frequencies and its own nn; slayer.in is never read by GPEC. No change at n = 1. - slayer.f: the stability scan with Pperp_Ptor_flag=f passed the Fitzpatrick D_norm in riccati()'s Cole ds slot; it now gets the surface's ds, as the Br threshold does since 2100323c. - slayer.f: the single-surface baseline riccati() is also skipped for input_flag, whose per-surface results never used it, and the Cole inputs are required whenever a legacy scan will run. - slayer.f: the Br threshold (bal_flag and br_th_flag) ignores non-finite torque-balance entries and reports 0 with a warning when the balance has no positive maximum, as gpec_slayer does, instead of NaN. The a10 example now prints br_th = 0 with the warning. - slayer.f: MAXLOC counts from 1 while the scan arrays start at 0, so every reported Q_sol was one grid step above the maximum. Fixed at all seven sites. gpec_slayer uses the same point only as the centre of its refinement bracket, so it is left as is and GPEC's output is unchanged. - delta.f: riccati()'s inds argument is ds, the normalised ion sound radius, not a shear. The DIII-D run and the develop template are unchanged; the a10 example's Q_sol moves from 0.05 to 0.0 and its br_th from NaN to 0. Co-Authored-By: Claude Fable 5.1 --- slayer/delta.f | 2 +- slayer/gslayer.f | 15 ++++++------ slayer/params.f | 4 +++- slayer/slayer.f | 62 ++++++++++++++++++++++++++++++++++++------------ 4 files changed, 59 insertions(+), 24 deletions(-) diff --git a/slayer/delta.f b/slayer/delta.f index 739dc74d1..7eb4500a3 100644 --- a/slayer/delta.f +++ b/slayer/delta.f @@ -52,7 +52,7 @@ FUNCTION riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe, REAL(r8),INTENT(IN) :: inpr ! Prandtl number REAL(r8),INTENT(IN) :: inpe ! electron Prandtl number REAL(r8),INTENT(IN) :: inc_beta ! c_beta parameter - REAL(r8),INTENT(IN) :: inds ! magnetic shear ds + REAL(r8),INTENT(IN) :: inds ! ds, normalised rho_s REAL(r8),INTENT(IN) :: intau ! ion-to-electron temp ratio c --- optional arguments REAL(r8),INTENT(IN),OPTIONAL :: iinQ ! imaginary part of Q diff --git a/slayer/gslayer.f b/slayer/gslayer.f index 3ce664472..fce07358e 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -177,12 +177,13 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, lu=tau_r/tau_h ! Lundquist number Qconv=lu**(1.0/3.0)*tau_h ! Q normalisation factor -c --- normalised frequencies. GPEC passes the bare diamagnetic -c frequencies (dp/dpsi)/(e*n_e) with no toroidal mode number -c attached (gpout.f); omega_* = k_theta*v_* = n*(dp/dpsi)/(e*n_e), -c so GPEC's n (nns) multiplies them here, as in build_inputs -c (layerinputs.f). - Q=Qconv*omega +c --- normalised frequencies. GPEC passes the bare ExB and +c diamagnetic frequencies with no toroidal mode number attached +c (gpout.f). The layer sees the mode at the Doppler frequency +c n*omega_E, and omega_* = k_theta*v_* = n*(dp/dpsi)/(e*n_e), so +c GPEC's n (nns) multiplies all three here, as in build_inputs +c and the coupled determinant's Doppler shift (slayer.f). + Q=Qconv*nns*omega Q_e=-Qconv*nns*omega_e Q_i=-Qconv*nns*omega_i @@ -291,7 +292,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, rhi=xpk+2.0*rdq ENDDO Q_sol=xpk - omega_sol=xpk/Qconv + omega_sol=xpk/(Qconv*nns) ! back to a fluid rotation frequency ! If even the refined nose is non-positive the surface has no ! finite penetration threshold; floor at zero and warn rather ! than propagating a NaN into b_crit/Phi_res_crit downstream. diff --git a/slayer/params.f b/slayer/params.f index d503f66cd..140bcf093 100644 --- a/slayer/params.f +++ b/slayer/params.f @@ -164,7 +164,9 @@ SUBROUTINE params(n_e,t_e,t_i,omega,chis,dr_val,dgeo_val, c----------------------------------------------------------------------- Qconv = lu**(1.0_r8/3.0_r8) * tau_h ! frequency normalisation (Cole) tauk = Qconv ! stored in sglobal_mod - Q = Qconv * omega ! normalised rotation frequency +c the layer sees the mode at the Doppler frequency n*omega_E, as in +c the coupled determinant's shift (slayer.f) and gpec_slayer + Q = Qconv * REAL(nn,r8) * omega ! normalised ExB frequency c Diamagnetic frequencies require gradient lengths; skip when the c caller does not provide them (l_n <= 0 or l_t <= 0). Callers that diff --git a/slayer/slayer.f b/slayer/slayer.f index 941e94292..9d199a3a3 100644 --- a/slayer/slayer.f +++ b/slayer/slayer.f @@ -420,10 +420,16 @@ PROGRAM slayer END IF END IF ! Cole-model inputs: needed by the single-surface riccati() call - ! below, which runs unless a growth-rate or Br-threshold mode is - ! on, and by the legacy scans. inpr is a namelist input there. + ! below, which runs unless a per-surface mode is on, and by the + ! legacy scans, which run unless a mode that stops first is on. + ! inpr is a namelist input in all of them. IF (.NOT. (est_gamma_flag .OR. match_gamma_flag .OR. - $ br_th_flag)) THEN + $ br_th_flag .OR. input_flag) .OR. + $ (.NOT. (match_gamma_flag .OR. br_th_flag) .AND. + $ (bal_flag .OR. stability_flag .OR. riccatiscan_flag .OR. + $ QPscan_flag .OR. QPescan_flag .OR. QPscan2_flag .OR. + $ QDscan2_flag .OR. Qscan_flag .OR. onscan_flag .OR. + $ otscan_flag .OR. ntscan_flag .OR. nbtscan_flag))) THEN IF (.NOT. inpr > 0.0_r8) $ CALL slayer_unset('inpr',inpr,'1.0',nbad) IF (.NOT. params_flag) THEN @@ -488,11 +494,11 @@ PROGRAM slayer c skipped when the matched-gamma path is active (it computes c its own delta internally). c----------------------------------------------------------------------- -c Also skipped for the growth-rate estimate and the Br threshold, -c which do not use it and are usually run with these namelist -c inputs unset. +c Also skipped for the growth-rate estimate, the Br threshold and +c the multi-surface input file, which compute their own deltas per +c surface and are usually run with these namelist inputs unset. IF (.NOT. (match_gamma_flag .OR. est_gamma_flag .OR. - $ br_th_flag)) THEN + $ br_th_flag .OR. input_flag)) THEN delta=riccati(inQ,inQ_e,inQ_i,inpr,inc_beta,inds,intau,inpe) psi0=1.0/ABS(delta+delta_n_p) ! reconnected flux [a.u.] jxb=-AIMAG(1.0/(delta+delta_n_p)) ! j x B torque [a.u.] @@ -568,6 +574,7 @@ PROGRAM slayer ENDDO iloc=MAXLOC(bal) + iloc(1)=iloc(1)-1 ! MAXLOC counts from 1, inQs from 0 Q_soll(k)=inQs(iloc(1)) br_thl(k)=sqrt(MAXVAL(bal)/lu*(svals(k)**2.0/2.0))*1e4 @@ -1086,8 +1093,9 @@ PROGRAM slayer IF (Pperp_Ptor_flag) THEN delta=riccati_f() ELSE + ! the Cole riccati() takes ds, not D_norm delta=riccati(iing_coarse,Q_e,Q_i,P_perp, - $ c_beta,D_norm,tau,pe, + $ c_beta,sl_in%ds_arr(k),tau,pe, $ iinQ=ing_coarse) END IF inQs(i) = ing_coarse @@ -1334,10 +1342,21 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxbl(i) ENDDO - iloc=MAXLOC(bal) - Q_sol=inQs(iloc(1)) - br_th=SQRT(MAXVAL(bal)/sl_in%lu_arr(k) - $ *(sl_in%shear_arr(k)**2.0/2.0)) + ! as in gpec_slayer: ignore non-finite entries (0/0, or a + ! near-zero jxb) and floor at zero with a warning when the + ! balance has no positive maximum, rather than a NaN + iloc=MAXLOC(bal,MASK=(bal==bal .AND. ABS(bal)= 0 .AND. bal(MAX(iloc(1),0))>0.0_r8) THEN + br_th=SQRT(bal(iloc(1))/sl_in%lu_arr(k) + $ *(sl_in%shear_arr(k)**2.0/2.0)) + ELSE + br_th=0.0_r8 + WRITE(*,'(1x,a,i0,a)') "!! WARNING: torque balance "// + $ "has no positive maximum at m=",sl_in%qval_arr(k), + $ "; br_th set to 0" + ENDIF sl_out%br_th_arr(k) = br_th sl_out%gamma_sol_arr(k) = 0.0 @@ -1399,9 +1418,18 @@ PROGRAM slayer CLOSE(out_unit) ENDIF - iloc=MAXLOC(bal) - Q_sol=inQs(iloc(1)) - br_th=sqrt(MAXVAL(bal)/lu*(sval**2.0/2.0))*1e4 + ! as in gpec_slayer: ignore non-finite entries and floor at + ! zero with a warning when the balance has no positive maximum + iloc=MAXLOC(bal,MASK=(bal==bal .AND. ABS(bal)= 0 .AND. bal(MAX(iloc(1),0))>0.0_r8) THEN + br_th=sqrt(bal(iloc(1))/lu*(sval**2.0/2.0))*1e4 + ELSE + br_th=0.0_r8 + WRITE(*,*)"!! WARNING: torque balance has no positive "// + $ "maximum; br_th set to 0" + ENDIF WRITE(*,*)"Q_sol=",Q_sol WRITE(*,*)"br_th=",br_th DEALLOCATE(inQs,deltal,jxbl,bal) @@ -1785,6 +1813,7 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO iloc=MAXLOC(bal) + iloc(1)=iloc(1)-1 ! MAXLOC counts from 1, inQs from 0 Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) @@ -1871,6 +1900,7 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO iloc=MAXLOC(bal) + iloc(1)=iloc(1)-1 ! MAXLOC counts from 1, inQs from 0 Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"t_e=",t_e*ks(j,k),"br_ths=",br_ths(j,k) @@ -1957,6 +1987,7 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO iloc=MAXLOC(bal) + iloc(1)=iloc(1)-1 ! MAXLOC counts from 1, inQs from 0 Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) @@ -2044,6 +2075,7 @@ PROGRAM slayer bal(i)=2.0*inpr*(Q0-inQs(i))/jxb ENDDO iloc=MAXLOC(bal) + iloc(1)=iloc(1)-1 ! MAXLOC counts from 1, inQs from 0 Q_sols(j,k)=inQs(iloc(1)) br_ths(j,k)=sqrt(MAXVAL(bal)/lu)*1e4 WRITE(*,*)"br_ths=",br_ths(j,k) From 076a1e66f330eb22a0e3e6310c92328640fd1b7b Mon Sep 17 00:00:00 2001 From: Matthew Pharr Date: Sat, 24 Oct 2026 21:37:35 +0200 Subject: [PATCH 118/118] SLAYER - MINOR - rename output file extension to match .out convention --- slayer/gslayer.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/slayer/gslayer.f b/slayer/gslayer.f index fce07358e..76653d162 100644 --- a/slayer/gslayer.f +++ b/slayer/gslayer.f @@ -249,7 +249,7 @@ SUBROUTINE gpec_slayer(n_e,t_e,n_i,t_i,zeff,omega,omega_e, c --- optionally write torque balance curve to ASCII file IF(ascii_flag)THEN OPEN(UNIT=out_unit,FILE="gpec_slayer_torque_balance_m"// - $ TRIM(l_sm)//"_n"//TRIM(l_sn)//".OUT", + $ TRIM(l_sm)//"_n"//TRIM(l_sn)//".out", $ STATUS="UNKNOWN") WRITE(out_unit,'(1x,5(a17))') "inQ","RE(delta)", $ "IM(delta)","jxb","bal"