From e6d78d7957729a714e5e2ac7f0ec24ed5ecfa9d5 Mon Sep 17 00:00:00 2001 From: d-burg Date: Wed, 1 May 2024 10:22:58 -0700 Subject: [PATCH 01/98] 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 65f531be..50e86ba9 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 81281dc0..2ef56160 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 02/98] 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 f5cfe4eb..289ad129 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 dab71080..43343bf6 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 2ef56160..f21441bf 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 03/98] 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 289ad129..a81c8ecd 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 f21441bf..315b963d 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 04/98] 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 a81c8ecd..2182c57c 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 00000000..1642104e --- /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 50e86ba9..aace6bf9 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 315b963d..1f5e7d42 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 05/98] 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 2182c57c..d488a333 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 1642104e..6a9fac93 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 aace6bf9..b4c676d9 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 1f5e7d42..5dccc3af 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 08199da2..4d3c26e9 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 06/98] 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 d488a333..1ed32a72 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 6a9fac93..b8b8825b 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 b4c676d9..29a36dfd 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 5dccc3af..126f7f30 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 00000000..33d92c59 --- /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 4d3c26e9..9eb8ec58 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 07/98] 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 8d2d5ba0..380c8dea 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 8d2d5ba0..380c8dea 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 7ed7527e..99e342bc 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 b8b8825b..8a68f23c 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 126f7f30..0ad1047b 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 9eb8ec58..2b5c4936 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 08/98] 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 380c8dea..ec585847 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 1ed32a72..8238a731 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 8a68f23c..cf3b0d67 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 29a36dfd..f6dcca4a 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 43343bf6..403b3b6f 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 0ad1047b..092cf549 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 33d92c59..b2125d76 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 09/98] 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 cf3b0d67..3628358f 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 092cf549..15357935 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 2b5c4936..6345c8ab 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 10/98] 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 ec585847..3490aab2 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 8238a731..5178eccf 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 3628358f..92333c39 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 15357935..671466cf 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 b2125d76..217504ae 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 11/98] 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 5178eccf..9c89d6c8 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 92333c39..9b1bf2cc 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 403b3b6f..ae6356f2 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 671466cf..dca43a3a 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 217504ae..31b6f17f 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 12/98] 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 9c89d6c8..a731041f 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 dca43a3a..b40460b4 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 13/98] 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 3490aab2..35a904ae 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 a731041f..3bd9b47b 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 31b6f17f..f4fbdbb4 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 14/98] 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 3bd9b47b..9c8a37ac 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 15/98] 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 767a80da..99463b58 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 9b1bf2cc..7b4fdcd7 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 b40460b4..57f6f755 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 16/98] 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 9c8a37ac..3dce4f86 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 17/98] 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 3dce4f86..e0c41aa4 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 18/98] 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 35a904ae..83ac2f91 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 19/98] 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 83ac2f91..35a904ae 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 20/98] 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 35a904ae..83ac2f91 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 21/98] 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 99463b58..dc40a679 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 22/98] 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 83ac2f91..3f2713c4 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 dc40a679..02c43cc3 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 069cc99e..eafff752 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 23/98] 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 3f2713c4..50748255 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 e0c41aa4..d5c2e69c 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 f6dcca4a..2e3212cb 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 fcf98871..c8651932 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 ae6356f2..6a68621e 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 eafff752..b5ee3cd3 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 f4fbdbb4..267c0ba0 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 24/98] 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 6d02e2c1..9a0b2aea 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 25/98] 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 d5c2e69c..74a85245 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 cdada7ea..6a8b5789 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 6a68621e..00b751f3 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 b5ee3cd3..4193aa9d 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 267c0ba0..1bee4081 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 26/98] 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 9a0b2aea..53053def 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 74a85245..1072bab9 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 6a8b5789..0b9655ef 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 4193aa9d..9d216799 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 1bee4081..62991adf 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 27/98] 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 1072bab9..9b721dc3 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 9d216799..19356bca 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 28/98] 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 53053def..9a0b2aea 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 9b721dc3..ce356504 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 0b9655ef..6a8b5789 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 19356bca..437c3310 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 62991adf..1bee4081 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 29/98] 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 59f882ce..c73657a2 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 437c3310..3ea016ba 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 30/98] 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 53994eef..103e69a0 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 0fffd182..06332f1a 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 fdc782e2..9346fbdc 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 6a8b5789..dfa924f9 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 3c159e3c..b8e093bd 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 1bee4081..152a0093 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 31/98] 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 b8e093bd..b79564e3 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 6345c8ab..4f89c8e5 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 32/98] 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 06332f1a..50ac741a 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 b79564e3..03b54b73 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 4f89c8e5..5be759f9 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 33/98] 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 103e69a0..b1de1d75 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 50ac741a..30d3e6b9 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 9346fbdc..13a84384 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 00b751f3..74e8a958 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 03b54b73..00353156 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 152a0093..589e66fc 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 34/98] 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 30d3e6b9..1989a5c6 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 13a84384..7d6b047e 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 00353156..8a819608 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 589e66fc..1b61d38f 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 35/98] 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 b1de1d75..1d8df39d 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 1989a5c6..cd29ead9 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 7d6b047e..7d5e62a7 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 dfa924f9..eb8b3e56 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 c8651932..2e2cf113 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 74e8a958..f3ccca6c 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 8a819608..5eca1a8f 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 1b61d38f..5f299c9f 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 5be759f9..edd055cc 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 36/98] 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 1d8df39d..23eb8a29 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 7d5e62a7..1863a4c0 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 eb8b3e56..d5f13d5d 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 2e2cf113..ef79e028 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 5eca1a8f..6d7bc108 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 5f299c9f..eb2ed6a0 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 37/98] 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 1863a4c0..aaf280c1 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 6d7bc108..e20e575b 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 eb2ed6a0..4b45df4c 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 38/98] 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 aaf280c1..07a4282e 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 ef79e028..2e2cf113 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 e20e575b..438b5a2d 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 39/98] 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 07a4282e..a663ce3b 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 d5f13d5d..50cb5306 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 6a6d3375..2326a9c9 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 c0f6d919..527e069c 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 438b5a2d..ea062c8d 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 40/98] 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 23eb8a29..8a5b514d 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 a663ce3b..0b03f8dc 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 50cb5306..af68ed92 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 2e2cf113..ce70a8a2 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 527e069c..45b703aa 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 ea062c8d..ee575887 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 4b45df4c..614f7054 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 b2ddcc62..5143be4d 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 27e3fd5c..e5c4d845 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 41/98] 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 0b03f8dc..9eaa11a6 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 af68ed92..ceee31f4 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 45b703aa..77a8699a 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 ee575887..bcb0aadd 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 614f7054..8f09f793 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 42/98] 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 cd29ead9..970b7752 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 ceee31f4..cb275145 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 ce70a8a2..c648c370 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 bcb0aadd..28341a85 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 8f09f793..1f06295d 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 43/98] 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 970b7752..ce8dc2d4 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 9eaa11a6..93c016c2 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 cb275145..7fb55ba8 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 c648c370..c935c729 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 77a8699a..81738560 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 28341a85..08f32306 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 1f06295d..df20f48c 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 44/98] 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 8a5b514d..dd0230d6 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 93c016c2..ccf5dbba 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 7fb55ba8..dd2adeec 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 c935c729..088c29b7 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 81738560..a91bf55a 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 08f32306..c969e3fb 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 45/98] 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 dd2adeec..be8f64e8 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 088c29b7..dcf06978 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 c969e3fb..70372205 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 df20f48c..f665e327 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 46/98] 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 70372205..9997ff63 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 47/98] 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 ccf5dbba..2fb525e2 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 a91bf55a..b4b98291 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 48/98] 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 9997ff63..70372205 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 49/98] 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 2fb525e2..39ca4a76 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 b4b98291..a91bf55a 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 70372205..565ed93c 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 50/98] 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 39ca4a76..d10d3280 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 a91bf55a..eafcd438 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 565ed93c..08971bee 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 51/98] 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 dd0230d6..ef9e225d 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 ce8dc2d4..de3041d4 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 d10d3280..d79f9bfc 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 be8f64e8..7dabfbae 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 08971bee..773a6cdf 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 52/98] 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 ef9e225d..1889bca8 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 d79f9bfc..3bf09124 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 eafcd438..334ebc53 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 773a6cdf..3f398681 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 f665e327..c597c731 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 53/98] 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 3bf09124..06dfae53 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 334ebc53..3711e695 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 3f398681..e21065ec 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 54/98] 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 1889bca8..cd5194a9 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 06dfae53..d9ebff46 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 e21065ec..37566a19 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 c597c731..45fdfef8 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 55/98] 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 de3041d4..aff31a2c 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 d9ebff46..edef6d8d 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 7dabfbae..c9756bce 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 dcf06978..c68e0032 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 3711e695..7c94683c 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 37566a19..000bbf1a 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 45fdfef8..c9ed6532 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 56/98] 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 c9756bce..e0f0b209 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 57/98] 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 aff31a2c..0c673fa7 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 c68e0032..4cde1f33 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 7c94683c..8855c00c 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 000bbf1a..af088d7a 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 58/98] 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 0c673fa7..0ad68b1d 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 e0f0b209..5fd3702e 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 59/98] 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 4cde1f33..01479c03 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 af088d7a..44833456 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 60/98] 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 01479c03..b94ea419 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 44833456..cf7f78bb 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 61/98] 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 0ad68b1d..e32ef078 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 62/98] 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 e32ef078..22cb399a 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 63/98] 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 edef6d8d..c4707f41 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 64/98] 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 c4707f41..21fd7093 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 65/98] 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 21fd7093..695288f3 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 cf7f78bb..3f43ec3e 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 66/98] WIP: fix makefile ordering --- slayer/makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/slayer/makefile b/slayer/makefile index 2326a9c9..39c4217b 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 67/98] 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 695288f3..36135b0d 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 68/98] 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 36135b0d..78ac7118 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 69/98] 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 22cb399a..8ef9bff2 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 78ac7118..8c272efc 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 5fd3702e..12377493 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 39c4217b..dfacf2b7 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 b94ea419..cec066a9 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 8855c00c..b8327348 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 3f43ec3e..eac24ea2 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 c9ed6532..3ecff89e 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 70/98] 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 8c272efc..ea723e16 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 b8327348..e1183204 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 eac24ea2..de6cb5ba 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 3ecff89e..78091a0f 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 5143be4d..52f25b71 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 e5c4d845..ba445bdd 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 71/98] 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 2b1aa8ab..bed92b5e 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 72/98] 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 bed92b5e..ea82c612 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 929a8f43..badeb27f 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 5fbcc03d..f4eae6fa 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 73/98] 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 ea82c612..59909f8d 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 badeb27f..cb58be4d 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 74/98] 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 de6cb5ba..3e2ffd00 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 75/98] 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 f4eae6fa..25bffcd5 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 76/98] 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 e2b135e9..d0a0ebe5 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 77/98] 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 cd5194a9..24077b95 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 59909f8d..44c22d72 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 3e2ffd00..18e2aa03 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 78/98] 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 44c22d72..c77fae55 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 79/98] 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 18e2aa03..c282f7f4 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 80/98] 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 ea723e16..85037c77 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 12377493..5244a6bc 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 cec066a9..220b6dbd 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 78091a0f..82e9bd91 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 7b68ecea..7c441691 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 81/98] 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 4d9a8281..0d3072a5 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 9aaaa471..9198f025 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 82/98] WIP: more debug statements --- stride/ode.F | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/stride/ode.F b/stride/ode.F index 0d3072a5..491676f0 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 83/98] 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 491676f0..27971138 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 84/98] 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 27971138..36f0e7d5 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 9198f025..9aaaa471 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 85/98] 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 380c8dea..bceddf8d 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 86/98] 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 c77fae55..685ffff6 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 00000000..842bbd22 --- /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 85037c77..1275af91 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 dfacf2b7..00000000 --- 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 c282f7f4..f1dba4a4 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 87/98] 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 842bbd22..f3eabf5c 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 88/98] 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 e1183204..bd4d5556 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 e2f5df67ec41366ca3e0b2c124003c713db95e14 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 31 Mar 2026 21:02:21 -0400 Subject: [PATCH 89/98] STRIDE - BUGFIX - Move identityMat to heap allocation and harden ZVODE loop identityMat in ode_run was declared as a fixed-size automatic (stack-allocated) array of dimension (2*mpert, 2*mpert) COMPLEX(r8). For large mpert, this array could exceed the default stack size, causing silent memory corruption or segfaults -- particularly inside OpenMP parallel regions where each thread gets a reduced stack. Changing identityMat to ALLOCATABLE moves it to the heap, making STRIDE robust to arbitrarily large mpert without requiring users to raise ulimit -s or OMP_STACKSIZE. Also: - Add IF(istate < 0) EXIT after ZVODE call to break out of the integration loop on solver failure instead of looping indefinitely. - Remove a stray WRITE statement that printed singEdgesLR every run. --- stride/ode.F | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/stride/ode.F b/stride/ode.F index 4d9a8281..36f0e7d5 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 @@ -153,8 +153,6 @@ SUBROUTINE ode_run $ 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 @@ -187,6 +185,7 @@ 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 DO i = 1,2*mpert identityMat(i,i) = 1.0_r8 @@ -435,6 +434,7 @@ SUBROUTINE ode_run 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) + IF(istate < 0) EXIT ENDDO IF ( grid_packing == "naive" ) THEN CALL SYSTEM_CLOCK(COUNT=fTime) @@ -462,6 +462,7 @@ SUBROUTINE ode_run c----------------------------------------------------------------------- c terminate. c----------------------------------------------------------------------- + DEALLOCATE(identityMat) RETURN END SUBROUTINE ode_run c----------------------------------------------------------------------- From ee6d765097bc77fd10571d793b9de52de75309c0 Mon Sep 17 00:00:00 2001 From: d-burg Date: Tue, 31 Mar 2026 21:14:08 -0400 Subject: [PATCH 90/98] 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 f3eabf5c..a7d0c590 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 91/98] 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 a7d0c590..c8f8b399 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 92/98] 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 5244a6bc..f3757acf 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 220b6dbd..3324165e 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 f1dba4a4..fbc66e43 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 93/98] 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 7c441691..043007b1 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 94/98] 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 c8f8b399..fbfcbb1a 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 95/98] 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 f3757acf..e9b79065 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 96/98] 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 be4fa63a..8b989064 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 fbfcbb1a..46954104 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 e9b79065..ffedd819 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 97/98] 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 46954104..502fffae 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 98/98] 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 a7ea4916..0d7d8781 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