diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..f7e36a1 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,28 @@ +cmake_minimum_required (VERSION 3.14) + +project (parvmec C CXX Fortran) +set (CMAKE_CXX_STANDARD 11) + +add_library (vmec) +add_dependencies (vmec stell) + +target_link_libraries (vmec stell) +target_include_directories (vmec PUBLIC $) + +add_executable (xvmec) +add_dependencies (xvmec vmec) +target_link_libraries (xvmec vmec) + +add_subdirectory (Sources) + +################################################################################ +# Testing # +################################################################################ + +# Build test utilities. +add_executable (xwout_diff) +add_dependencies (xwout_diff stell) + +target_link_libraries (xwout_diff stell) + +add_subdirectory (Testing) diff --git a/README.md b/README.md new file mode 100644 index 0000000..c834253 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# VMEC +3D Equilibrium solver with nested flux surfaces. diff --git a/Sources/CMakeLists.txt b/Sources/CMakeLists.txt new file mode 100644 index 0000000..10f60b7 --- /dev/null +++ b/Sources/CMakeLists.txt @@ -0,0 +1,8 @@ +# Add subdirectories for all the sources. +add_subdirectory (General) +add_subdirectory (Hessian) +add_subdirectory (Initialization_Cleanup) +add_subdirectory (Input_Output) +add_subdirectory (NESTOR_vacuum) +add_subdirectory (Splines) +add_subdirectory (TimeStep) diff --git a/Sources/General/CMakeLists.txt b/Sources/General/CMakeLists.txt new file mode 100644 index 0000000..22e196b --- /dev/null +++ b/Sources/General/CMakeLists.txt @@ -0,0 +1,34 @@ +target_sources(vmec + PRIVATE + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ +) diff --git a/Sources/General/add_fluxes.f90 b/Sources/General/add_fluxes.f90 new file mode 100644 index 0000000..4f396f1 --- /dev/null +++ b/Sources/General/add_fluxes.f90 @@ -0,0 +1,175 @@ + SUBROUTINE add_fluxes_par(overg, bsupu, bsupv, lcurrent) + USE vmec_main + USE realspace, ONLY: pwint, pguu, pguv, pchip, pphip + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ntheta3 + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(nznt,ns), INTENT(in) :: overg + REAL(rprec), DIMENSION(nznt,ns), INTENT(inout) :: bsupu, bsupv + LOGICAL, INTENT(in) :: lcurrent +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(rprec), PARAMETER :: p5=0.5_dp, c1p5=1.5_dp + REAL(rprec), PARAMETER :: iotaped = 0.10 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, l + REAL(rprec) :: top, bot + + INTEGER :: i, j, k, nsmin, nsmax, lnsnum, istat +!----------------------------------------------- +! +! ADD MAGNETIC FLUX (CHIP, PHIP) TERMS TO BSUPU=-OVERG*LAM_V, BSUPV=OVERG*LAM_U +! COMPUTE FLUX FROM ITOR = , ITOR(s) = integrated toroidal current (icurv) +! IF ncurr == 1, AND ictrl_prec2d != 0, COMPUTE FORCE IN TOMNSP TO UPDATE chips +! + + IF (.NOT.lcurrent .OR. ncurr.EQ.0) GOTO 100 + + nsmin=MAX(2,t1lglob); nsmax=t1rglob + DO js = nsmin, nsmax + top = icurv(js) + bot = 0 + DO j=1,nznt + top = top - pwint(j,js)*(pguu(j,js)*bsupu(j,js) & + + pguv(j,js)*bsupv(j,js)) + bot = bot + pwint(j,js)*overg(j,js)*pguu(j,js) + END DO + IF (bot.ne.zero) chips(js) = top/bot + IF (phips(js).ne.zero) iotas(js) = chips(js)/phips(js) + END DO + + 100 CONTINUE + + nsmin=MAX(2,t1lglob); nsmax=t1rglob +! CHANGE THIS FOR lRFP = T (solve for phips?) + IF (ncurr .EQ. 0) THEN + chips(nsmin:nsmax) = iotas(nsmin:nsmax)*phips(nsmin:nsmax) + ELSE IF (.NOT.lcurrent) THEN + WHERE (phips(nsmin:nsmax) .NE. zero) & + iotas(nsmin:nsmax) = chips(nsmin:nsmax)/phips(nsmin:nsmax) + END IF + + DO js = nsmin, nsmax + pchip(:,js) = chips(js) + END DO + + nsmin=MAX(2,t1lglob); nsmax=MIN(ns-1,trglob) + IF (t1lglob .eq. 1 .and. trglob .gt. 2) THEN + chipf(1) = c1p5*chips(2) - p5*chips(3) + ELSE IF (t1lglob .eq. 1) THEN + chipf(1) = chips(2) + END IF + chipf(nsmin:nsmax) = (chips(nsmin:nsmax) + chips(nsmin+1:nsmax+1))/2 + IF (nsmax.EQ.ns) chipf(ns) = c1p5*chips(ns)- p5*chips(ns-1) + +! Do not compute iota too near origin + IF(trglob_arr(1).LE.2) THEN +#if defined(MPI_OPT) + CALL MPI_Bcast(iotas(3),1,MPI_REAL8,1,NS_COMM,MPI_ERR) +#endif + END IF + IF (lrfp) THEN + IF (nsmin.EQ.1) iotaf(1) = one/(c1p5/iotas(2) - p5/iotas(3)) + IF (nsmax.EQ.ns) iotaf(ns)=one/(c1p5/iotas(ns)-p5/iotas(ns-1)) + DO js = MAX(2,t1lglob), MIN(ns-1,t1rglob) + iotaf(js) = 2.0_dp/(one/iotas(js) + one/iotas(js+1)) + END DO + ELSE + IF (nsmin.EQ.1) iotaf(1) = c1p5*iotas(2) - p5*iotas(3) + IF (nsmax.EQ.ns) iotaf(ns)=c1p5*iotas(ns) - p5*iotas(ns-1) + DO js = MAX(2,t1lglob), MIN(ns-1,trglob) + iotaf(js) = p5*(iotas(js) + iotas(js+1)) + END DO + END IF + + nsmin=MAX(1,t1lglob); nsmax=MIN(ns,t1rglob) + bsupu(:,nsmin:nsmax) = bsupu(:,nsmin:nsmax)+pchip(:,nsmin:nsmax)*overg(:,nsmin:nsmax) + + END SUBROUTINE add_fluxes_par + + SUBROUTINE add_fluxes(overg, bsupu, bsupv, lcurrent) + USE vmec_main + USE realspace, ONLY: wint, guu, guv, chip, phip + + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(nrzt), INTENT(in) :: overg + REAL(rprec), DIMENSION(nrzt), INTENT(inout) :: bsupu, bsupv + LOGICAL, INTENT(in) :: lcurrent +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(rprec), PARAMETER :: p5=0.5_dp, c1p5=1.5_dp + REAL(rprec), PARAMETER :: iotaped = 0.10_dp +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, l + REAL(rprec) :: top, bot + +!----------------------------------------------- +! +! ADD MAGNETIC FLUX (CHIP, PHIP) TERMS TO BSUPU=-OVERG*LAM_V, BSUPV=OVERG*LAM_U +! COMPUTE FLUX FROM ITOR = , ITOR(s) = integrated toroidal current (icurv) +! IF ncurr == 1 +! + IF (.not.lcurrent .or. ncurr.eq.0) GOTO 100 + +! nsmin=MAX(2,tlglob); nsmax=trglob + + DO js = 2, ns + top = icurv(js) + bot = 0 + DO l = js, nrzt, ns + top = top - wint(l)*(guu(l)*bsupu(l) + guv(l)*bsupv(l)) + bot = bot + wint(l)*overg(l)*guu(l) + END DO + IF (bot .ne. zero) chips(js) = top/bot + IF (phips(js) .ne. zero) iotas(js) = chips(js)/phips(js) + END DO + + 100 CONTINUE + +! CHANGE THIS FOR lRFP = T (solve for phips?) + IF (ncurr .eq. 0) THEN + chips = iotas*phips + ELSE IF (.not.lcurrent) THEN + WHERE (phips .ne. zero) iotas = chips/phips + END IF + + DO js = 2, ns + chip(js:nrzt:ns) = chips(js) + END DO + + chipf(1) = c1p5*chips(2) - p5*chips(3) !SPH ADDED THIS 4-8-16 + chipf(2:ns1) = (chips(2:ns1) + chips(3:ns1+1))/2 + chipf(ns) = c1p5*chips(ns)- p5*chips(ns1) !SPH FIXED THIS 4-8-16 + +! Do not compute iota too near origin + IF (lrfp) THEN + iotaf(1) = one/(c1p5/iotas(2) - p5/iotas(3)) + iotaf(ns) = one/(c1p5/iotas(ns) - p5/iotas(ns1)) + DO js = 2, ns-1 + iotaf(js) = 2.0_dp/(one/iotas(js) + one/iotas(js+1)) + END DO + + ELSE + iotaf(1) = c1p5*iotas(2) - p5*iotas(3) !zero gradient near axis + iotaf(ns) = c1p5*iotas(ns) - p5*iotas(ns-1) + DO js = 2, ns-1 + iotaf(js) = p5*(iotas(js) + iotas(js+1)) + END DO + END IF + + bsupu(:nrzt) = bsupu(:nrzt)+chip(:nrzt)*overg(:nrzt) + + END SUBROUTINE add_fluxes diff --git a/Sources/General/alias.f b/Sources/General/alias.f new file mode 100644 index 0000000..abfb7d7 --- /dev/null +++ b/Sources/General/alias.f @@ -0,0 +1,260 @@ + SUBROUTINE alias_par(gcons, ztemp, gcs, gsc, gcc, gss) + USE vmec_main + USE realspace, ONLY:ireflect_par, psqrts + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp + REAL(dp), DIMENSION(nzeta,ntheta3,ns), INTENT(out) :: gcons + REAL(dp), DIMENSION(nzeta,ntheta3,ns), INTENT(in) :: ztemp + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns) :: gcs, gsc, gcc, gss +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: m, i, ir, jk, jka, n, k, js, l, j + INTEGER :: nsmin, nsmax + INTEGER :: jcount, kk + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: work + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: gcona + REAL(dp) :: talon, taloff +C----------------------------------------------- + CALL second0(talon) + + nsmin=tlglob; nsmax=t1rglob + + ALLOCATE (work(4,nzeta,ns), gcona(nzeta,ntheta3,ns)) + + gcons(:,:,nsmin:nsmax) = 0 + gcona(:,:,nsmin:nsmax) = 0 + + gcs(:ntor,:mpol1,nsmin:nsmax) = 0 + gsc(:ntor,:mpol1,nsmin:nsmax) = 0 + gcc(:ntor,:mpol1,nsmin:nsmax) = 0 + gss(:ntor,:mpol1,nsmin:nsmax) = 0 + + !BEGIN M-LOOP + DO js = nsmin, nsmax + DO m = 1, mpol1 - 1 + + work(:,:,js) = 0 + DO i = 1, ntheta2 + DO k = 1, nzeta + work(1,k,js) = work(1,k,js) + ztemp(k,i,js)*cosmui(i,m) + work(2,k,js) = work(2,k,js) + ztemp(k,i,js)*sinmui(i,m) + END DO + + IF (.not.lasym) CYCLE + ir = ntheta1 + 2 - i + IF (i .eq. 1) ir = 1 + DO k = 1, nzeta + kk=ireflect_par(k) + work(3,k,js) = work(3,k,js) + + 1 ztemp(kk,ir,js)*cosmui(i,m) + work(4,k,js) = work(4,k,js) + + 1 ztemp(kk,ir,js)*sinmui(i,m) + END DO + END DO + + IF(js.GT.1) THEN + DO n = 0, ntor + DO k = 1, nzeta + IF (.not.lasym) THEN + gcs(n,m,js) = gcs(n,m, js) + tcon(js)*work(1,k,js)* + 1 sinnv(k,n) + gsc(n,m,js) = gsc(n,m,js) + tcon(js)*work(2,k,js)* + 1 cosnv(k,n) + ELSE + gcs(n,m,js) = gcs(n,m,js) + p5*tcon(js)*sinnv(k,n)* + 1 (work(1,k,js)-work(3,k,js)) + gsc(n,m,js) = gsc(n,m,js) + p5*tcon(js)*cosnv(k,n)* + 1 (work(2,k,js)-work(4,k,js)) + gss(n,m,js) = gss(n,m,js) + p5*tcon(js)*sinnv(k,n)* + 1 (work(2,k,js)+work(4,k,js)) + gcc(n,m,js) = gcc(n,m,js) + p5*tcon(js)*cosnv(k,n)* + 1 (work(1,k,js)+work(3,k,js)) + END IF + END DO + END DO + END IF +! +! INVERSE FOURIER TRANSFORM DE-ALIASED GCON +! + work(:,:,js) = 0 + + IF(js.GT.1) THEN + DO n = 0, ntor + DO k = 1, nzeta + work(3,k,js) = work(3,k,js) + gcs(n,m,js)*sinnv(k,n) + work(4,k,js) = work(4,k,js) + gsc(n,m,js)*cosnv(k,n) + IF (.not.lasym) CYCLE + work(1,k,js) = work(1,k,js) + gcc(n,m,js)*cosnv(k,n) + work(2,k,js) = work(2,k,js) + gss(n,m,js)*sinnv(k,n) + END DO + END DO + END IF + + nsmin=tlglob; nsmax=t1rglob + DO i = 1, ntheta2 + DO k = 1, nzeta + gcons(k,i,js) = gcons(k,i,js) + (work(3,k,js)*cosmu(i,m) + 1 + work(4,k,js)*sinmu(i,m))*faccon(m) + END DO + IF (.not.lasym) CYCLE + DO k = 1, nzeta + gcona(k,i,js) = gcona(k,i,js) + (work(1,k,js)*cosmu(i,m) + 1 + work(2,k,js)*sinmu(i,m))*faccon(m) + END DO + END DO + + END DO + END DO + !END M-LOOP + + IF (lasym) THEN + + !EXTEND GCON INTO THETA = PI,2*PI DOMAIN + DO js = nsmin, nsmax + DO i = 1 + ntheta2, ntheta1 + ir = ntheta1 + 2 - i + DO k = 1, nzeta + kk=ireflect_par(k) + gcons(k,i,js) = -gcons(kk,ir,js) + gcona(kk,ir,js) + END DO + END DO + END DO + + !ADD SYMMETRIC, ANTI-SYMMETRIC PIECES IN THETA = 0,PI DOMAIN + gcons(:,:ntheta2,nsmin:nsmax) = gcons(:,:ntheta2,nsmin:nsmax) + 1 + gcona(:,:ntheta2,nsmin:nsmax) + + END IF + + DEALLOCATE (work, gcona) + + CALL second0(taloff) + alias_time = alias_time + (taloff-talon) + + END SUBROUTINE alias_par + + SUBROUTINE alias(gcons, ztemp, gcs, gsc, gcc, gss) + USE vmec_main + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(out) :: gcons + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(in) :: ztemp + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1) :: gcs, gsc, gcc, gss +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: m, i, ir, jk, jka, n, k, js, l, j + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: work, gcona + +C----------------------------------------------- + ALLOCATE (work(ns*nzeta,4), gcona(ns*nzeta,ntheta3)) + + gcons = 0 + gcona = 0 + + gcs(:,:ntor,:mpol1) = 0; gsc(:,:ntor,:mpol1) = 0 + gcc(:,:ntor,:mpol1) = 0; gss(:,:ntor,:mpol1) = 0 + + DO m = 1, mpol1 - 1 + work = 0 + DO i = 1, ntheta2 + DO jk = 1, ns*nzeta + work(jk,1) = work(jk,1) + ztemp(jk,i)*cosmui(i,m) + work(jk,2) = work(jk,2) + ztemp(jk,i)*sinmui(i,m) + END DO + IF (.not.lasym) CYCLE + !STOP 'CHECK ireflect_par before executing' + ir = ntheta1 + 2 - i + IF (i .eq. 1) ir = 1 + DO jk = 1, ns*nzeta + jka = ireflect(jk) + work(jk,3) = work(jk,3) + ztemp(jka,ir)*cosmui(i,m) + work(jk,4) = work(jk,4) + ztemp(jka,ir)*sinmui(i,m) + END DO + END DO + + DO n = 0, ntor + DO k = 1, nzeta + l = ns*(k-1) + IF (.not.lasym) THEN + DO js = 2,ns + gcs(js,n,m) = gcs(js,n,m) + tcon(js)*work(js+l,1)* + 1 sinnv(k,n) + gsc(js,n,m) = gsc(js,n,m) + tcon(js)*work(js+l,2)* + 1 cosnv(k,n) + END DO + ELSE + DO js = 2,ns + gcs(js,n,m) = gcs(js,n,m) + p5*tcon(js)*sinnv(k,n)* + 1 (work(js+l,1)-work(js+l,3)) + gsc(js,n,m) = gsc(js,n,m) + p5*tcon(js)*cosnv(k,n)* + 1 (work(js+l,2)-work(js+l,4)) + gss(js,n,m) = gss(js,n,m) + p5*tcon(js)*sinnv(k,n)* + 1 (work(js+l,2)+work(js+l,4)) + gcc(js,n,m) = gcc(js,n,m) + p5*tcon(js)*cosnv(k,n)* + 1 (work(js+l,1)+work(js+l,3)) + END DO + END IF + END DO + END DO +! +! INVERSE FOURIER TRANSFORM DE-ALIASED GCON +! + work = 0 + + DO n = 0, ntor + DO k = 1, nzeta + l = ns*(k-1) + DO js = 2, ns + work(js+l,3) = work(js+l,3) + gcs(js,n,m)*sinnv(k,n) + work(js+l,4) = work(js+l,4) + gsc(js,n,m)*cosnv(k,n) + END DO + IF (.not.lasym) CYCLE + DO js = 2, ns + work(js+l,1) = work(js+l,1) + gcc(js,n,m)*cosnv(k,n) + work(js+l,2) = work(js+l,2) + gss(js,n,m)*sinnv(k,n) + END DO + END DO + END DO + + DO i = 1, ntheta2 + DO jk = 1, ns*nzeta + gcons(jk,i) = gcons(jk,i) + (work(jk,3)*cosmu(i,m) + 1 + work(jk,4)*sinmu(i,m))*faccon(m) + END DO + IF (.not.lasym) CYCLE + DO jk = 1, ns*nzeta + gcona(jk,i) = gcona(jk,i) + (work(jk,1)*cosmu(i,m) + 1 + work(jk,2)*sinmu(i,m))*faccon(m) + END DO + END DO + END DO + + IF (lasym) THEN + +! EXTEND GCON INTO THETA = PI,2*PI DOMAIN + DO i = 1 + ntheta2, ntheta1 + ir = ntheta1 + 2 - i + DO jk = 1, ns*nzeta + jka = ireflect(jk) + gcons(jk,i) = -gcons(jka,ir) + gcona(jka,ir) + END DO + END DO + +! ADD SYMMETRIC, ANTI-SYMMETRIC PIECES IN THETA = 0,PI DOMAIN + gcons(:,:ntheta2) = gcons(:,:ntheta2) + gcona(:,:ntheta2) + + END IF + + DEALLOCATE (work, gcona) + + END SUBROUTINE alias diff --git a/Sources/General/angle_constraints.f90 b/Sources/General/angle_constraints.f90 new file mode 100755 index 0000000..27f9adc --- /dev/null +++ b/Sources/General/angle_constraints.f90 @@ -0,0 +1,699 @@ + MODULE angle_constraints + USE vmec_main, ONLY: ns, mpol, ntor, dp, mpol1, lthreed, lasym + USE vmec_params, ONLY: signgs, ntmax, rcc, rss, zsc, zcs, rsc, rcs, zss, zcc + USE precon2d, ONLY: ictrl_prec2d + IMPLICIT NONE + INTEGER, PARAMETER :: pexp=4, m0=0, m1=1, m2=2, m3=3 + LOGICAL, PARAMETER :: lorigin=.FALSE. + INTEGER :: mrho, m, istat + REAL(dp), PARAMETER :: p5=0.5_dp, zero=0 + REAL(dp), ALLOCATABLE :: t1m(:), t2m(:), cos_HB(:), sin_HB(:) + REAL(dp), ALLOCATABLE :: rz_array0(:,:,:), xtempa(:) + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: arhod, arhom, brhod, brhom, & + ard2, arm2, azd2, azm2, arhod2, arhom2, & + brd2, brm2, bzd2, bzm2, brhod2, brhom2 + REAL(dp), DIMENSION(:), ALLOCATABLE :: crhod, sin2u, cos2u, sfact + REAL(dp) :: sqp5 +#ifdef _HBANGLE + CONTAINS + +! CALLED FROM FIXARAY + SUBROUTINE init_multipliers + IMPLICIT NONE + REAL(dp) :: dnorm, t0 +! NOTE: rho = SUM(m) rhomn*max(m,1)**pexp cos(mu-nv), etc +! the extra m**pexp factor is to give good scaling + + IF (ALLOCATED(t1m)) RETURN + + sqp5 = SQRT(p5) + mrho = mpol1 +!HB Angle constraint +! mrho = mpol1-1 + + ALLOCATE(t1m(0:mpol), t2m(0:mpol), cos_HB(0:mpol1), sin_HB(0:mpol1), stat=istat) + IF (istat .NE. 0) STOP 'Allocation error in init_multipliers!' + +! +! REF: Hirshman/Breslau paper +! + t1m(m0) = 0; t2m(m0) = 0 + DO m = 1, mpol1+1 + t0 = MAX(1,m-1) + t1m(m) = t0/m + t0 = m+1 + t2m(m) = t0/m + t1m(m) = t1m(m)**pexp + t2m(m) = t2m(m)**pexp + END DO + +! t1m(3) = 0 +!SPH-TEST (IMPROVES CONDITION #?) +! t1m(m2) = t2m(m2) + +!HB Constraint +! t2m(mpol1) = 0; t2m(mpol) = 0 + +! dnorm = MAXVAL(t1m); dnorm = MAX(dnorm,MAXVAL(t2m)) +! t1m = t1m/dnorm; t2m = t2m/dnorm + + cos_HB(m0) = 1; sin_HB(m0) = 0 + + DO m = 1, mrho + dnorm = SQRT(t1m(m+1)**2 + t2m(m-1)**2) + IF (dnorm .EQ. zero) CYCLE + cos_HB(m) = t1m(m+1)/dnorm + sin_HB(m) = t2m(m-1)/dnorm + END DO + + IF (mrho .NE. mpol1) THEN + cos_HB(mpol1) = 0; sin_HB(mpol1) = 1 + END IF + +!DOESN'T CONVERGE IF THIS GOES BEFORE cos,sin_HB calculations (F_0 too larger???) +! t2m(m0) = t1m(m2) + + END SUBROUTINE init_multipliers + + SUBROUTINE free_multipliers + IF (ALLOCATED(t1m)) DEALLOCATE (t1m, t2m, cos_HB, sin_HB) + IF (ALLOCATED(rz_array0)) DEALLOCATE (rz_array0) + IF (ALLOCATED(xtempa)) DEALLOCATE (xtempa) + IF (ALLOCATED(arhod)) DEALLOCATE(arhod, arhom, brhod, brhom, crhod, & + ard2, arm2, azd2, azm2, arhod2, arhom2, & + brd2, brm2, bzd2, bzm2, brhod2, brhom2) + IF (ALLOCATED(cos2u)) DEALLOCATE(cos2u, sin2u) + IF (ALLOCATED(sfact)) DEALLOCATE(sfact) + + END SUBROUTINE free_multipliers + + SUBROUTINE store_init_array(rzl_array) + USE vmec_main, ONLY: neqs2, nznt, nzeta, cosmui, sinmui, cosmu, sinmu, & + nzeta, ntheta2, ntheta3, hs + REAL(dp), DIMENSION(ns*(1+ntor),0:mpol1,3*ntmax), INTENT(inout) :: rzl_array + INTEGER :: nsp1, l, js + + IF (ALLOCATED(rz_array0)) DEALLOCATE (rz_array0) + ALLOCATE(rz_array0(ns*(1+ntor),0:mpol1,2*ntmax)) + rz_array0 = rzl_array(:,:,1:2*ntmax) + rzl_array(:,:,1:2*ntmax) = 0 + + CALL init_multipliers + CALL get_rep_mismatch(rz_array0, rzl_array) + + IF (ALLOCATED(xtempa)) DEALLOCATE (xtempa) + ALLOCATE (xtempa(neqs2)) !Used as temp storage of xc in funct3d + + nsp1=ns+1 + IF (ALLOCATED(arhod)) DEALLOCATE(arhod, arhom, brhod, brhom, crhod, & + ard2, arm2, azd2, azm2, arhod2, arhom2, & + brd2, brm2, bzd2, bzm2, brhod2, brhom2) + ALLOCATE(arhod(nsp1,2),arhom(nsp1,2),brhod(nsp1,2),brhom(nsp1,2), & + ard2(nsp1,2), arm2(nsp1,2), arhod2(nsp1,2), arhom2(nsp1,2),& + azd2(nsp1,2), azm2(nsp1,2), & + brd2(nsp1,2), brm2(nsp1,2), brhod2(nsp1,2), brhom2(nsp1,2),& + bzd2(nsp1,2), bzm2(nsp1,2), crhod(nsp1)) + IF (ALLOCATED(cos2u)) DEALLOCATE(cos2u, sin2u) + ALLOCATE (cos2u(nznt), sin2u(nznt)) + DO l=1,nzeta + cos2u(l:nznt:nzeta) = cosmui(:,m2) + sin2u(l:nznt:nzeta) = sinmui(:,m2) + END DO + + IF (ALLOCATED(sfact)) DEALLOCATE(sfact) + ALLOCATE(sfact(ns)) + DO js=1,ns + sfact(js) = hs*(js-1) + END DO + + END SUBROUTINE store_init_array + + SUBROUTINE getrz (rz_array) +! USE vmec_main, ONLY: iter2 +! USE xstuff, ONLY: xc, xstore + IMPLICIT NONE + REAL(dp), DIMENSION(ns*(1+ntor),0:mpol1,2*ntmax), INTENT(inout) :: rz_array + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: rhocc, rhoss, rhocs, rhosc + REAL(dp), DIMENSION(:), ALLOCATABLE :: r0c, r0s, z0c, z0s + INTEGER :: nsnt, mrho1, istat + +! INPUT: rho quasi-polar components (Fourier modes) stored in R +! R,Z(m=0) centroid components stored in Z(m=0) +! OUTPUT: Cylindrical component Fourier modes of R, Z +! REF: HB Paper, Eq 32 +! +! FOR STELLARATOR SYMMETRY, rho = cos(mu-nv), R' = sum(m^pexp Rmn cos(mu-nv)), Z' = sum(m^pexp Zmn sin(mu-nv) +! R' = (rhocc + rhoss) cosu +! Z' = (rhocc + rhoss) sinu +! +! FOR ASYMMETRY, ADD rho = sin(mu-nv) TERMS +! R' = (rhosc + rhocs) cosu +! Z' = (rhosc + rhocs) sinu +! + + nsnt = ns*(1+ntor) + mrho1 = mrho+1 +! IF (mrho .NE. mpol1) STOP 'mrho != mpol1' + +! Enforce asymptotic behavior near axis (HB paper after Eq (34)) + IF (lorigin) THEN + rz_array(2:nsnt:ns,m2,1:ntmax) = sqp5*rz_array(3:nsnt:ns,m2,1:ntmax) + IF (mpol1 .GE. m3) THEN + rz_array(2:nsnt:ns,m1:m3:2,1:ntmax) = p5*rz_array(3:nsnt:ns,m1:m3:2,1:ntmax) + rz_array(2:nsnt:ns,m3+1:,1:ntmax) = 0 + END IF + END IF + + ALLOCATE (rhocc(nsnt,0:mpol1+1), rhoss(nsnt,0:mpol1+1), & + r0c(nsnt), z0s(nsnt),stat=istat) + IF (istat .NE. 0) STOP 'Allocation Error #1 in GETRZ' + rhocc(:,0:mrho) = rz_array(:,0:mrho,rcc) + r0c = rz_array(:,m0,zsc+ntmax) !Used for temp storage + rhocc(:,mrho1) = 0; rhocc(:,mpol1+1) = 0 + + IF (lthreed) THEN + rhoss(:,1:mrho) = rz_array(:,1:mrho,rss) + rhoss(:,m0) = 0 + rhoss(:,mrho1) = 0; rhoss(:,0) = 0 + z0s = rz_array(:,m0,zcs+ntmax) + END IF + + MODES: DO m = 0, mpol1 + IF (m .EQ. m0) THEN + rz_array(:,m0,rcc) = r0c + t2m(m0)*rhocc(:,m1) + rz_array(:,m0,zsc+ntmax) = 0 + IF (lthreed) THEN + rz_array(:,m0,zcs+ntmax) = z0s - t2m(m0)*rhoss(:,m1)*signgs + rz_array(:,m0,rss) = 0 + END IF + ELSE + rz_array(:,m,rcc) = (t1m(m)*rhocc(:,m-1) + t2m(m)*rhocc(:,m+1)) + rz_array(:,m,zsc+ntmax) =-(t1m(m)*rhocc(:,m-1) - t2m(m)*rhocc(:,m+1))*signgs + IF (lthreed) THEN + rz_array(:,m,rss) = (t1m(m)*rhoss(:,m-1) + t2m(m)*rhoss(:,m+1)) + rz_array(:,m,zcs+ntmax) = (t1m(m)*rhoss(:,m-1) - t2m(m)*rhoss(:,m+1))*signgs + END IF + ENDIF + END DO MODES + + DEALLOCATE (rhocc, rhoss, r0c, z0s) + + IF (.NOT.lasym) GOTO 1002 + + ALLOCATE (rhosc(nsnt,0:mrho1), rhocs(nsnt,0:mrho1), & + r0s(nsnt), z0c(nsnt), stat=istat) + IF (istat .NE. 0) STOP 'Allocation Error #2 in GETRZ' + + rhosc(:,0:mrho) = rz_array(:,0:mrho,rsc) + rhosc(:,mrho1) = 0 + z0c = rz_array(:,m0,zcc+ntmax) + IF (lthreed) THEN + rhocs(:,0:mrho) = rz_array(:,0:mrho,rcs) + rhocs(:,mrho1) = 0; rhocs(:,0) = 0 + r0s = rz_array(:,m0,zss+ntmax) + END IF + + MODEA: DO m = 0, mpol1 + IF (m .EQ. 0) THEN + rz_array(:,m0,zcc+ntmax) = z0c - t2m(m0)*rhosc(:,m1)*signgs + rz_array(:,m0,rsc) = 0 + IF (lthreed) THEN + rz_array(:,m0,rcs) = r0s + t2m(m0)*rhocs(:,m1) + rz_array(:,m0,zss+ntmax) = 0 + END IF + ELSE + rz_array(:,m,rsc) = (t1m(m)*rhosc(:,m-1) + t2m(m)*rhosc(:,m+1)) + rz_array(:,m,zcc+ntmax) = (t1m(m)*rhosc(:,m-1) - t2m(m)*rhosc(:,m+1))*signgs + IF (lthreed) THEN + rz_array(:,m,rcs) = (t1m(m)*rhocs(:,m-1) + t2m(m)*rhocs(:,m+1)) + rz_array(:,m,zss+ntmax) =-(t1m(m)*rhocs(:,m-1) - t2m(m)*rhocs(:,m+1))*signgs + END IF + ENDIF + END DO MODEA + + DEALLOCATE (rhosc, rhocs, r0s, z0c) + + 1002 CONTINUE + + !Add initial (scaled) boundary values if needed + IF (ictrl_prec2d .NE. 3) rz_array = rz_array + rz_array0 + + END SUBROUTINE getrz + + SUBROUTINE getfrho (frho_array) + USE vmec_main, ONLY: iter2, fnorm, hs + REAL(dp), DIMENSION(ns*(1+ntor),0:mpol1,2*ntmax), INTENT(inout) :: & + frho_array + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: frcc, frss, fzcs, fzsc, & + frsc, frcs, fzcc, fzss + INTEGER :: nsnt, mrho1, istat + +! INPUT: Frho contains cylindrical components of FR, FZ +! OUTPUT: Frho(1:ntmax) contains Quasi-polar components the MHD forces +! Frho(ntmax+1:2*ntmax) contains centroid (m=0) forces + nsnt = ns*(1+ntor) + mrho1 = mrho+1 + + ALLOCATE (frcc(nsnt,0:mrho1), frss(nsnt,0:mrho1), & + fzsc(nsnt,0:mrho1), fzcs(nsnt,0:mrho1), stat=istat) + IF (istat .NE. 0) STOP 'Allocation error #1 in getfrho!' + + frcc(:,0:mrho) = frho_array(:,0:mrho,rcc); frcc(:,mrho1)=0 + frho_array(:,:,rcc)=0 + + fzsc(:,0:mrho) = frho_array(:,0:mrho,zsc+ntmax); fzsc(:,mrho1) = 0 + frho_array(:,:,zsc+ntmax)=0 + + IF (lthreed) THEN + frss(:,0:mrho) = frho_array(:,0:mrho,rss); frss(:,mrho1) = 0 + frho_array(:,:,rss)=0 + fzcs(:,0:mrho) = frho_array(:,0:mrho,zcs+ntmax); fzcs(:,mrho1) = 0 + frho_array(:,:,zcs+ntmax)=0 + END IF + + MODES: DO m = 0, mrho + IF (m .EQ. m0) THEN + frho_array(:,m0,zsc+ntmax) = frcc(:,m0) !storage + frho_array(:,m0,rcc) = cos_HB(m0)*(frcc(:,m1) - signgs*fzsc(:,m1)) + IF (.NOT.lthreed) CYCLE + frho_array(:,m0,zcs+ntmax) = fzcs(:,m0) + ELSE + frho_array(:,m,rcc) = cos_HB(m)*(frcc(:,m+1) - signgs*fzsc(:,m+1)) & + + sin_HB(m)*(frcc(:,m-1) + signgs*fzsc(:,m-1)) + IF (.NOT.lthreed) CYCLE + frho_array(:,m,rss) = cos_HB(m)*(frss(:,m+1) + signgs*fzcs(:,m+1)) & + + sin_HB(m)*(frss(:,m-1) - signgs*fzcs(:,m-1)) + ENDIF + END DO MODES + + DEALLOCATE (frcc, frss, fzsc, fzcs) + IF (lthreed) THEN + IF (ANY(frho_array(:,m0,rss) .NE. zero)) STOP 'FRHO(m0,rss) != 0' + END IF + + IF (.NOT. lasym) GOTO 1000 + + ALLOCATE (frsc(nsnt,0:mrho1), frcs(nsnt,0:mrho1), & + fzcc(nsnt,0:mrho1), fzss(nsnt,0:mrho1), stat=istat) + IF (istat .NE. 0) STOP 'Allocation error #2 in getfrho!' + + frsc(:,0:mrho) = frho_array(:,0:mrho,rsc); frsc(:,mrho1) = 0 + frho_array(:,:,rsc) = 0 + fzcc(:,0:mrho) = frho_array(:,0:mrho,zcc+ntmax); fzcc(:,mrho1) = 0 + frho_array(:,:,zcc+ntmax) = 0 + IF (lthreed) THEN + frcs(:,0:mrho) = frho_array(:,0:mrho,rcs); frcs(:,mrho1) = 0 + frho_array(:,:,rcs)=0 + fzss(:,0:mrho) = frho_array(:,0:mrho,zss+ntmax); fzss(:,mrho1) = 0 + frho_array(:,:,zss+ntmax)=0 + END IF + + MODEA: DO m = 0, mrho + IF (m .EQ. m0) THEN + frho_array(:,m0,zcc+ntmax) = fzcc(:,m0) + IF (.NOT.lthreed) CYCLE + frho_array(:,m0,zss+ntmax) = frcs(:,m0) + frho_array(:,m0,rcs) =cos_HB(m0)*(frcs(:,m1) - signgs*fzss(:,m1)) + ELSE + frho_array(:,m,rsc) = cos_HB(m)*(frsc(:,m+1) + signgs*fzcc(:,m+1)) & + + sin_HB(m)*(frsc(:,m-1) - signgs*fzcc(:,m-1)) + IF (.NOT.lthreed) CYCLE + frho_array(:,m,rcs) = cos_HB(m)*(frcs(:,m+1) - signgs*fzss(:,m+1)) & + + sin_HB(m)*(frcs(:,m-1) + signgs*fzss(:,m-1)) + ENDIF + END DO MODEA + + DEALLOCATE (frsc, frcs, fzcc, fzss) + + IF (lasym) THEN + IF (ANY(frho_array(:,m0,rsc) .NE. zero)) STOP 'FRHO(m=0,rsc) != 0' + END IF + + 1000 CONTINUE + +! Use asymptotic behavior near axis, rather than evolution (SPH010214) + IF (lorigin) THEN + frho_array(2:nsnt:ns,m1:,1:ntmax) = 0 + END IF + +!ADD UNIQUE POLAR AXIS "CONSTRAINT" + frho_array(:,m1,1:ntmax) = 0 !Unique angle + + + END SUBROUTINE getfrho + + + SUBROUTINE scalfor_rho(gcr, gcz) + USE vmec_main + USE vmec_params + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntmax), INTENT(inout) :: & + gcr, gcz +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + REAL(dp), PARAMETER :: edge_pedestal=0.05_dp + INTEGER :: m , mp, n, js, jmax, jmin4(0:mnsize-1) + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: arho, brho, drho, & + arho2,brho2,drho2 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: acen, bcen, dcen + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: gcen + REAL(dp) :: tar, taz, tc, tc1 +!----------------------------------------------- + jmax = ns + IF (ivac .lt. 1) jmax = ns1 + + ALLOCATE (acen(ns,0:ntor), bcen(ns,0:ntor), dcen(ns,0:ntor), & + gcen(ns,0:ntor,4)) +! +! FIRST, SCALE m=0 R,Z COMPONENTS +! + gcen=0 + gcen(:,:,1) = gcz(:,:,m0,zsc) !used for r0n storage + IF (lasym) gcen(:,:,3) = gcz(:,:,m0,zcc) + IF (lthreed) THEN + gcen(:,:,2) = gcz(:,:,m0,zcs) + IF (lasym) gcen(:,:,4) = gcz(:,:,m0,zss) + END IF + + IF (SUM(gcz*gcz) .NE. SUM(gcen*gcen)) STOP 'ERROR #1 IN SCALFOR_RHO' + + CALL scalaxis(arm, ard, crd, acen, bcen, dcen, jmax, gcen(:,:,1), 0) + IF (lasym) CALL scalaxis(azm, azd, crd, acen, bcen, dcen, jmax, gcen(:,:,3), 0) + IF (lthreed) THEN + CALL scalaxis(azm, azd, crd, acen, bcen, dcen, jmax, gcen(:,:,2), 1) + IF (lasym) CALL scalaxis(arm, ard, crd, acen, bcen, dcen, jmax, gcen(:,:,4), 1) + END IF + + gcz = 0 +! +! RESTORE SCALED CENTROID VALUES +! + gcz(:,:,m0,zsc) = gcen(:,:,1) !R0n-cc + IF (lasym) gcz(:,:,m0,zcc) = gcen(:,:,3) !Z0n-cc + IF (lthreed) THEN + gcz(:,:,m0,zcs) = gcen(:,:,2) !Z0n-cs + IF (lasym) gcz(:,:,m0,zss) = gcen(:,:,4) !R0n-cs + END IF + +! +! NEXT, SCALE QUASI-POLAR COMPONENTS +! + ALLOCATE (arho(ns,0:ntor,0:mpol1), brho(ns,0:ntor,0:mpol1), & + drho(ns,0:ntor,0:mpol1), arho2(ns,0:ntor,0:mpol1), & + brho2(ns,0:ntor,0:mpol1),drho2(ns,0:ntor,0:mpol1)) + + DO m = 0, mpol1 + mp = MOD(m,2)+1 + DO n = 0, ntor + DO js = 1, ns + arho(js,n,m) = -(arhom(js+1,mp) + brhom(js+1,mp)*m**2) + brho(js,n,m) = -(arhom(js,mp) + brhom(js,mp) *m**2) + drho(js,n,m) = -(arhod(js,mp) + brhod(js,mp) *m**2 & + + crhod(js)*(n*nfp)**2) + arho2(js,n,m)= -p5*(arhom2(js+1,mp)+ brhom2(js+1,mp)*m**2) + brho2(js,n,m)= -p5*(arhom2(js,mp) + brhom2(js,mp) *m**2) + drho2(js,n,m)= -p5*(arhod2(js,mp) + brhod2(js,mp) *m**2) + END DO + END DO + END DO + + CALL avg_rho(arho, arho2) + CALL avg_rho(brho, brho2) + CALL avg_rho(drho, drho2) + + IF (jmax .ge. ns) THEN +! +! SMALL EDGE PEDESTAL NEEDED TO IMPROVE CONVERGENCE +! IN PARTICULAR, NEEDED TO ACCOUNT FOR POTENTIAL ZERO +! EIGENVALUE DUE TO NEUMANN (GRADIENT) CONDITION AT EDGE +! + drho(ns,:,:) = (1+edge_pedestal)*drho(ns,:,:) +! drho(ns,:,3:) = (1+2*edge_pedestal)*drho(ns,:,3:) + END IF + + jmin4 = 2 + CALL tridslv (arho,drho,brho,gcr(:,:,:,rcc),jmin4,jmax, & + mnsize-1,ns,1) + IF (lthreed) CALL tridslv (arho,drho,brho,gcr(:,:,:,rss), & + jmin4,jmax,mnsize-1,ns,1) + IF (lasym) THEN + CALL tridslv (arho,drho,brho,gcr(:,:,:,rsc),jmin4,jmax, & + mnsize-1,ns,1) + IF (lthreed) CALL tridslv (arho,drho,brho,gcr(:,:,:,rcs), & + jmin4,jmax,mnsize-1,ns,1) + END IF + + DEALLOCATE (arho, brho, drho, arho2, brho2, drho2, gcen) + + END SUBROUTINE scalfor_rho + + SUBROUTINE scalaxis(axm, axd, cxd, acen, bcen, dcen, jmax, gcen, iflag) + USE vmec_main + USE vmec_params + REAL(dp), PARAMETER :: edge_pedestal=0.15_dp, fac=0.25_dp +! REAL(dp), PARAMETER :: edge_pedestal=0.05_dp, fac=0.25_dp + REAL(dp), INTENT(IN), DIMENSION(ns+1,2) :: axm, axd + REAL(dp), INTENT(IN), DIMENSION(ns+1) :: cxd + REAL(dp), DIMENSION(ns,0:ntor) :: acen, bcen, dcen + REAL(dp), INTENT(INOUT) :: gcen(ns,0:ntor) + REAL(dp) :: mult_fac + INTEGER, INTENT(IN) :: jmax, iflag + INTEGER :: mp, n, js, mnsize0, jmin4(0:mnsize-1) + + mp=1 + DO n = 0, ntor + DO js = 1, jmax + acen(js,n) = -axm(js+1,mp) + bcen(js,n) = -axm(js,mp) + dcen(js,n) = -(axd(js,mp)+cxd(js)*(n*nfp)**2) + END DO + END DO + + IF (jmax .ge. ns) THEN +! +! SMALL EDGE PEDESTAL NEEDED TO IMPROVE CONVERGENCE +! IN PARTICULAR, NEEDED TO ACCOUNT FOR POTENTIAL ZERO +! EIGENVALUE DUE TO NEUMANN (GRADIENT) CONDITION AT EDGE +! + dcen(ns,:) = (1+edge_pedestal)*dcen(ns,:) +! +! STABILIZATION ALGORITHM FOR ZC_00(NS) +! FOR UNSTABLE CASE, HAVE TO FLIP SIGN OF -FAC -> +FAC FOR CONVERGENCE +! COEFFICIENT OF < Ru (R Pvac)> ~ -fac*(z-zeq) WHERE fac (EIGENVALUE, OR +! FIELD INDEX) DEPENDS ON THE EQUILIBRIUM MAGNETIC FIELD AND CURRENT, +! AND zeq IS THE EQUILIBRIUM EDGE VALUE OF Z00 + IF (iflag .eq. 1) THEN +! +! METHOD 1: SUBTRACT (INSTABILITY) Pedge ~ fac*z/hs FROM PRECONDITIONER AT EDGE +! + mult_fac = MIN(fac, fac*hs*15) + dcen(ns,0) = dcen(ns,0)*(1-mult_fac)/(1+edge_pedestal) + END IF + + ENDIF + + + mnsize0 = 1+ntor + jmin4 = jmin3 + IF (iresidue.GE.0 .AND. iresidue.LT.3) jmin4(0)=2 + + CALL tridslv(acen,dcen,bcen,gcen,jmin4,jmax,mnsize0-1,ns,1) + + END SUBROUTINE scalaxis + + SUBROUTINE avg_rho(ax, ax2) + USE vmec_main + IMPLICIT NONE + REAL(dp), INTENT(inout), DIMENSION(ns*(1+ntor), 0:mpol1) :: ax, ax2 + REAL(dp), ALLOCATABLE :: ax1(:,:) + INTEGER :: m + + ALLOCATE (ax1(ns*(1+ntor),0:mpol1)) + + ax1(:,m0) = cos_HB(m0)*t1m(m1)*(ax(:,m1)+ax2(:,m1)) + DO m=1,mpol1-1 + ax1(:,m) = cos_HB(m)*(t1m(m+1)*ax(:,m+1)+t2m(m-1)*ax2(:,m-1)) & + + sin_HB(m)*(t2m(m-1)*ax(:,m-1)+t1m(m+1)*ax2(:,m+1)) + END DO +! ax1(:,m2) = ax1(:,m2)+sin_HB(m2)*t2m(m1)*ax2(:,m2-1) + ax1(:,mpol1) = sin_HB(mpol1)*t2m(mpol1-1)*ax(:,mpol1-1) & + + cos_HB(mpol1)*t2m(mpol1-1)*ax2(:,mpol1-1) + ax = ax1 + + DEALLOCATE (ax1) + + END SUBROUTINE avg_rho + + SUBROUTINE precondn_rho + USE vmec_main, ONLY: ard, arm, brd, brm, azd, azm, bzd, bzm, crd + USE fbal, ONLY: rzu_fac, rru_fac, frcc_fac, fzsc_fac + REAL(dp), PARAMETER :: one=1 + + arhod = ard + azd + arhom = arm + azm + brhod = brd + bzd + brhom = brm + bzm + crhod = crd + crd + + arhod2 = ard2-azd2; brhod2 = (brd2-bzd2) + arhom2 = arm2-azm2; brhom2 = (brm2-bzm2) + + rzu_fac = (rzu_fac+rru_fac); rru_fac=rzu_fac + frcc_fac(2:ns-1) = one/rzu_fac(2:ns-1) + fzsc_fac(2:ns-1) = -frcc_fac(2:ns-1) + + END SUBROUTINE precondn_rho + + SUBROUTINE get_rep_mismatch(rz0_array, rho_array) + USE vmec_main, ONLY: irst, hs + IMPLICIT NONE + REAL(dp), PARAMETER :: p5=0.5_dp, p25=p5*p5 + REAL(dp), DIMENSION(ns*(1+ntor),0:mpol1,2*ntmax), INTENT(in) :: rz0_array + REAL(dp), DIMENSION(ns*(1+ntor),0:mpol1,2*ntmax), INTENT(out) :: rho_array + INTEGER :: m, nsnt, mrho1, js, n, ntc + REAL(dp) :: match, delta, t1(ns*(1+ntor)), t2(ns*(1+ntor)), & + temp1(ns*(1+ntor)), temp2(ns*(1+ntor)), es +! +! COMPUTES mismatch BETWEEN INITIAL R-Z REPRESENTATION AND QPOLAR FORM +! + nsnt = SIZE(rz0_array,1) + mrho1 = MAX(mrho+1,mpol1) + temp1 = 0; temp2 = 0 + +! +! STORE m=0 AXIS data +! + rho_array(:,m0,zsc+ntmax) = rz0_array(:,m0,rcc) + IF (lthreed) THEN + rho_array(:,m0,zcs+ntmax) = rz0_array(:,m0,zcs+ntmax) + END IF + + DO m = 0, mrho + IF (m .LT. mpol1-1) THEN + t1 = (rz0_array(:,m+1,rcc) - signgs*rz0_array(:,m+1,zsc+ntmax))/t1m(m+1) + IF (m .LE. 1) THEN + t2 = t1 + ELSE + t2 = (rz0_array(:,m-1,rcc) + signgs*rz0_array(:,m-1,zsc+ntmax))/t2m(m-1) + END IF + ELSE IF (m .GT. 1) THEN + t2 = (rz0_array(:,m-1,rcc) + signgs*rz0_array(:,m-1,zsc+ntmax))/t2m(m-1) + t1 = t2 + END IF + rho_array(:,m,rcc) = p25*(t1 + t2) + temp1 = temp1 + (t1 - t2)**2 + temp2 = temp2 + (t1 + t2)**2 + + IF (.NOT.lthreed) CYCLE + + IF (m .LT. mpol1-1) THEN + t1 = (rz0_array(:,m+1,rss) + signgs*rz0_array(:,m+1,zcs+ntmax))/t1m(m+1) + IF (m .LE. 1) THEN + t2 = t1 + ELSE + t2 = (rz0_array(:,m-1,rss) - signgs*rz0_array(:,m-1,zcs+ntmax))/t2m(m-1) + END IF + ELSE + t2 = (rz0_array(:,m-1,rss) - rz0_array(:,m-1,rcs+ntmax))/t2m(m-1) + t1 = t2 + END IF + rho_array(:,m,rss) = p25*(t1 + t2) + temp1 = temp1 + (t1 - t2)**2 + temp2 = temp2 + (t1 + t2)**2 + END DO + + rho_array(:,m0,zsc+ntmax) = rho_array(:,m0,zsc+ntmax) - t2m(m0)*rho_array(:,m1,rcc) + IF (lthreed) THEN + rho_array(:,m0,zcs+ntmax) = rho_array(:,m0,zcs+ntmax) + t2m(m0)*rho_array(:,m1,rss)*signgs + END IF + +! +! NON-SYMMETRIC CONTRIBUTIONS +! + IF (.NOT.lasym) GOTO 1000 + + rho_array(:,m0,zcc+ntmax) = rz0_array(:,m0,zcc+ntmax) + IF (lthreed) THEN + rho_array(:,m0,zss+ntmax) = rz0_array(:,m0,rcs) + END IF + + DO m = 0, mrho + IF (m .LT. mpol1-1) THEN + t1 = (rz0_array(:,m+1,rsc) + signgs*rz0_array(:,m+1,zcc+ntmax))/t1m(m+1) + IF (m .LE. 1) THEN + t2 = t1 + ELSE + t2 = (rz0_array(:,m-1,rsc) - signgs*rz0_array(:,m-1,zcc+ntmax))/t2m(m-1) + END IF + ELSE + t2 = (rz0_array(:,m-1,rsc) - signgs*rz0_array(:,m-1,zcc+ntmax))/t2m(m-1) + t1 = t2 + END IF + rho_array(:,m,rsc) = p25*(t1 + t2) + temp1 = temp1 + (t1 - t2)**2 + temp2 = temp2 + (t1 + t2)**2 + + IF (.not.lthreed) CYCLE + + IF (m .LT. mpol1-1) THEN + t1 = (rz0_array(:,m+1,rcs) - signgs*rz0_array(:,m+1,zss+ntmax))/t1m(m+1) + IF (m .LE. 1) THEN + t2 = t1 + ELSE + t2 = (rz0_array(:,m-1,rcs) + signgs*rz0_array(:,m-1,zss+ntmax))/t2m(m-1) + END IF + ELSE + t2 = (rz0_array(:,m-1,rcs) + signgs*rz0_array(:,m-1,zss+ntmax))/t2m(m-1) + t1 = t2 + END IF + rho_array(:,m,rcs) = p25*(t1 + t2) + temp1 = temp1 + (t1 - t2)**2 + temp2 = temp2 + (t1 + t2)**2 + END DO + + rho_array(:,m0,zcc+ntmax) = rho_array(:,m0,zcc+ntmax) + t2m(m0)*rho_array(:,m1,rsc) + IF (lthreed) THEN + rho_array(:,m0,zss+ntmax) = rho_array(:,m0,zss+ntmax) - t2m(m0)*rho_array(:,m1,rcs)*signgs + END IF + + 1000 CONTINUE + + IF (irst .EQ. 1) GOTO 2000 + + DO js = 2, ns-1 + es = (js-1)*hs + DO n = 0, ntor + ntc = js+ns*ntor + DO m = 0, mrho + IF (MOD(m,2) .EQ. 0) THEN + rho_array(ntc, m, 1:ntmax) = SQRT(es)*rho_array(ns*(1+ntor), m, 1:ntmax) + ELSE + rho_array(ntc, m, 1:ntmax) = es*rho_array(ns*(1+ntor), m, 1:ntmax) + END IF + END DO + END DO + END DO + + 2000 CONTINUE + + WRITE (*, '(a)') ' Quasi-polar representation mismatch vs radius' + DO js=2,ns,ns-2 + delta = SUM(temp1(js:nsnt:ns)) + match = SUM(temp2(js:nsnt:ns)) + IF (match .NE. 0._dp) WRITE (*, '(1x,i4,1p,e10.2)')js,delta/match + END DO + +! rho_array=0 !Use this if delta at the edge is not good + rz_array0=0 !Initial jacobian can change sign: check + +! IF (ALLOCATED(rho1)) DEALLOCATE(rho1) +! ALLOCATE (rho1(nsnt,ntmax)) +! rho1 = rho_array(:,m1,1:ntmax) + + END SUBROUTINE get_rep_mismatch +#endif + END MODULE angle_constraints diff --git a/Sources/General/aspectratio.f b/Sources/General/aspectratio.f new file mode 100644 index 0000000..e6d047e --- /dev/null +++ b/Sources/General/aspectratio.f @@ -0,0 +1,45 @@ + FUNCTION aspectratio() + USE vmec_main + USE realspace + USE vmec_io + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: lk, l + REAL(rprec) :: rb, zub, pi, t1, aspectratio +C----------------------------------------------- +! +! routine for computing aspect-ratio (independent of elongation): +! A = /**.5 +! +! WHERE pi **2 = Area (toroidally averaged) +! 2*pi * * Area = Volume +! Use integration by parts to compute as surface integral (Stoke''s theorem) +! + + pi = 4*ATAN(one) + +! +! Compute Volume and Mean (toroidally averaged) Cross Section Area +! + volume_p = 0 + cross_area_p = 0 + DO lk = 1, nznt + l = ns*lk + rb = r1(l,0) + r1(l,1) + zub = zu(l,0) + zu(l,1) + t1 = rb*zub*wint(l) + volume_p = volume_p + rb*t1 + cross_area_p = cross_area_p + t1 + END DO + + volume_p = 2*pi*pi*ABS(volume_p) + cross_area_p = 2*pi*ABS(cross_area_p) + + Rmajor_p = volume_p/(2*pi*cross_area_p) + Aminor_p = SQRT(cross_area_p/pi) + + aspectratio = Rmajor_p/Aminor_p + + END FUNCTION aspectratio diff --git a/Sources/General/bcovar.f b/Sources/General/bcovar.f new file mode 100644 index 0000000..9d18858 --- /dev/null +++ b/Sources/General/bcovar.f @@ -0,0 +1,933 @@ + SUBROUTINE bcovar_par(lu, lv, tpxc, ier_flag) + USE vmec_main, fpsi => bvco, p5 => cp5 + USE vmec_params, ONLY: ns4, signgs, pdamp, lamscale, ntmax, + & bsub_bad_js1_flag, arz_bad_value_flag, + & norm_term_flag + USE realspace, ONLY: pextra1, pextra2, pextra3, pextra4, + & pguu, pguv, pgvv, pru, pzu, + & pr1, prv, pzv, pshalf, pwint, pz1, + & pru0, pzu0, psqrts + USE vforces, r12 => parmn_o, ru12 => pazmn_e, gsqrt => pazmn_o, + & rs => pbzmn_e, zs => pbrmn_e, zu12 => parmn_e, + & bsubu_e => pclmn_e, bsubv_e => pblmn_e, + & bsubu_o => pclmn_o, bsubv_o => pblmn_o, + & bsq => pbzmn_o, phipog => pbrmn_o + USE xstuff, ONLY: pxc + USE precon2d, ONLY: ictrl_prec2d, lHess_exact, + & ctor_prec2d + USE fbal + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ntheta3 + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(nznt,ns,0:1), INTENT(INOUT) :: lu, lv + REAL(dp), DIMENSION((1+ntor)*(1+mpol1),1:ns,1:2*ntmax), + & INTENT(IN) :: tpxc + INTEGER, INTENT(inout) :: ier_flag +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- +! GENERALLY, IF TEMPORAL CONVERGENCE IS POOR, TRY TO INCREASE PDAMP (< 1) +! (STORED IN VMEC_PARAMS) + REAL(dp), PARAMETER :: c1p5 = (one + p5) +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: l, js, ndim + REAL(dp) :: r2, volume, curpol_temp +#ifndef _HBANGLE + REAL(dp) :: arnorm, aznorm, tcon_mul +#endif + REAL(dp) :: bcastton, bcasttoff + REAL(dp), POINTER, DIMENSION(:,:) :: luu, luv, lvv, tau + REAL(dp), DIMENSION(:,:), POINTER :: bsupu, bsubuh, + & bsupv, bsubvh, r12sq + LOGICAL :: lctor + INTEGER :: i, j, k, nsmin, nsmax, istat + REAL(dp) :: wblocal(ns), wbtotal + REAL(dp) :: wplocal(ns), wptotal + REAL(dp) :: vptotal + REAL(dp) :: fnlocal(ns), fntotal + REAL(dp) :: fn1local(ns), fn1total + REAL(dp) :: fnLlocal(ns), fnLtotal +!----------------------------------------------- + IF (irst.EQ.2 .AND. iequi.EQ.0) RETURN + +! +! POINTER ALIAS ASSIGNMENTS + + tau => pextra1(:,:,1) + luu => pextra2(:,:,1) + luv => pextra3(:,:,1) + lvv => pextra4(:,:,1) + + bsupu => luu + bsubuh => bsubu_o + bsupv => luv + bsubvh => bsubv_o + r12sq => bsq + +! +! FOR OPTIMIZATION ON CRAY, MUST USE COMPILER DIRECTIVES TO +! GET VECTORIZATION OF LOOPS INVOLVING (MORE THAN ONE) POINTER! +! + nsmin=t1lglob; nsmax=t1rglob + pguu(:,nsmin:nsmax) = 0 + pguv(:,nsmin:nsmax) = 0 + pgvv(:,nsmin:nsmax) = 0 + +! +! COMPUTE METRIC ELEMENTS GIJ ON HALF MESH +! FIRST, GIJ = EVEN PART (ON FULL MESH), LIJ = ODD PART (ON FULL MESH) +! THEN, GIJ(HALF) = < GIJ(even)> + SHALF < GIJ(odd) > + + DO l = nsmin, nsmax + r12sq(:,l) = psqrts(:,l)*psqrts(:,l) + pguu(:,l) = pru(:,l,0)*pru(:,l,0) + pzu(:,l,0)*pzu(:,l,0) + & + r12sq(:,l)*(pru(:,l,1)*pru(:,l,1) + & + pzu(:,l,1)*pzu(:,l,1)) + luu(:,l) = (pru(:,l,0)*pru(:,l,1) + pzu(:,l,0)*pzu(:,l,1))*2 + phipog(:,l) = 2*pr1(:,l,0)*pr1(:,l,1) + END DO + + IF (lthreed) THEN + DO l = nsmin, nsmax + pguv(:,l) = pru(:,l,0) * prv(:,l,0) + pzu(:,l,0)*pzv(:,l,0) + & + r12sq(:,l) * (pru(:,l,1)*prv(:,l,1) + & + pzu(:,l,1)*pzv(:,l,1)) + luv(:,l) = pru(:,l,0) * prv(:,l,1) + pru(:,l,1)*prv(:,l,0) + & + pzu(:,l,0)*pzv(:,l,1) + pzu(:,l,1)*pzv(:,l,0) + pgvv(:,l) = prv(:,l,0) * prv(:,l,0) + pzv(:,l,0)*pzv(:,l,0) + & + r12sq(:,l) * (prv(:,l,1)*prv(:,l,1) + & + pzv(:,l,1)*pzv(:,l,1) ) + lvv(:,l) = (prv(:,l,0) * prv(:,l,1) + + & pzv(:,l,0)*pzv(:,l,1))*2 + END DO + END IF + + r12sq(:,nsmin:nsmax) = pr1(:,nsmin:nsmax,0)*pr1(:,nsmin:nsmax,0) + & + r12sq(:,nsmin:nsmax)*pr1(:,nsmin:nsmax,1)* + & pr1(:,nsmin:nsmax,1) + + DO l = t1rglob, MAX(t1lglob,2), -1 + pguu(:,l) = p5*(pguu(:,l) + pguu(:,l-1) + + & + pshalf(:,l)*(luu(:,l) + luu(:,l-1))) + r12sq(:,l) = p5*(r12sq(:,l)+r12sq(:,l-1)+pshalf(:,l)* !Comment: r12sq = r12**2 + & (phipog(:,l) + phipog(:,l-1))) + END DO + + IF (lthreed) THEN + DO l = t1rglob, MAX(t1lglob,2), -1 + pguv(:,l) = p5*(pguv(:,l) + pguv(:,l-1) + + & pshalf(:,l)*(luv(:,l) + luv(:,l-1))) + pgvv(:,l) = p5*(pgvv(:,l) + pgvv(:,l-1) + + & pshalf(:,l)*(lvv(:,l) + lvv(:,l-1))) + END DO + END IF + + pguv(:,1)=0 + pgvv(:,1)=0 + + nsmin = tlglob; nsmax = t1rglob + DO l = nsmin, nsmax + tau(:,l) = gsqrt(:,l) + gsqrt(:,l) = r12(:,l)*tau(:,l) + END DO + gsqrt(:,1) = gsqrt(:,2) + + nsmin = MAX(2,tlglob); nsmax = t1rglob + pgvv(:,nsmin:nsmax) = pgvv(:,nsmin:nsmax) + & + r12sq(:,nsmin:nsmax) + pgvv(:,1) = 0 + +!CATCH THIS AFTER WHERE LINE BELOW phipog = 0 + nsmin = MAX(2,tlglob); nsmax = t1rglob + WHERE (gsqrt(:,nsmin:nsmax) .ne. zero) + phipog(:,nsmin:nsmax) = one/gsqrt(:,nsmin:nsmax) + END WHERE + phipog(:,1) = 0 + + vp(1) = 0 + vp(ns+1) = 0 + DO js = nsmin, nsmax + vp(js) = signgs*SUM(gsqrt(:,js)*pwint(:,js)) + END DO + +! +! COMPUTE CONTRA-VARIANT COMPONENTS OF B (Bsupu,v) ON RADIAL HALF-MESH +! TO ACCOMODATE LRFP=T CASES, THE OVERALL PHIP FACTOR (PRIOR TO v8.46) +! HAS BEEN REMOVED FROM PHIPOG, SO NOW PHIPOG == 1/GSQRT! +! +! NOTE: LU = LAMU == d(LAM)/du, LV = -LAMV == -d(LAM)/dv COMING INTO THIS ROUTINE +! WILL ADD CHIP IN CALL TO ADD_FLUXES. THE NET BSUPU, BSUPV ARE (PHIPOG=1/GSQRT AS NOTED ABOVE): +! +! BSUPU = PHIPOG*(chip + LAMV*LAMSCALE), +! BSUPV = PHIPOG*(phip + LAMU*LAMSCALE) +! + + nsmin = t1lglob + nsmax = t1rglob + + DO l = nsmin, nsmax + lu(:,l,:) = lu(:,l,:)*lamscale + lv(:,l,:) = lv(:,l,:)*lamscale + lu(:,l,0) = lu(:,l,0) + phipf(l) + END DO + + nsmin = MAX(2,t1lglob) + nsmax = t1rglob + DO l = nsmin, nsmax + bsupu(:,l) = p5*phipog(:,l) * (lv(:,l,0) + lv(:,l-1,0) + & + pshalf(:,l)*(lv(:,l,1) + lv(:,l-1,1))) + bsupv(:,l) = p5*phipog(:,l) * (lu(:,l,0) + lu(:,l-1,0) + & + pshalf(:,l)*(lu(:,l,1) + lu(:,l-1,1))) + END DO + +!v8.49: add ndim points + IF (rank .EQ. 0) THEN + bsupu(:,1) =0; ! bsupu(ndim) = 0 + bsupv(:,1) =0; ! bsupv(ndim) = 0 + END IF + +! +! UPDATE IOTA EITHER OF TWO WAYS: +! 1) FOR ictrl_prec2d = 0, SOLVE THE LINEAR ALGEBRAIC EQUATION = icurv +! FOR iotas (after testing, this is preferred way) +! 2) FOR ictrl_prec2d > 0, EVOLVE IOTAS IN TIME, USING Force-iota = - icurv. +! IOTAS IS "STORED" AT LOCATION LAMBDA-SC(0,0) IN XC-ARRAY +! + +! COMPUTE (IF NEEDED) AND ADD CHIP TO BSUPU +#if defined(CHI_FORCE) + CALL add_fluxes_par(phipog, bsupu, bsupv, ictrl_prec2d.EQ.0) +#else + CALL add_fluxes_par(phipog, bsupu, bsupv, .TRUE.) +#endif + +! +! COMPUTE LAMBDA FORCE KERNELS (COVARIANT B COMPONENT bsubu,v) ON RADIAL HALF-MESH +! + nsmin = t1lglob + nsmax = t1rglob + DO l = nsmin, nsmax + bsubuh(:,l) = pguu(:,l)*bsupu(:,l) + pguv(:,l)*bsupv(:,l) + bsubvh(:,l) = pguv(:,l)*bsupu(:,l) + pgvv(:,l)*bsupv(:,l) + END DO + +!v8.49 +! +! COMPUTE MAGNETIC AND KINETIC PRESSURE ON RADIAL HALF-MESH +! + nsmin = t1lglob + nsmax = t1rglob + DO l = nsmin, nsmax + bsq(:,l) = p5*(bsupu(:,l)*bsubuh(:,l) + bsupv(:,l)*bsubvh(:,l)) + END DO + + nsmin = MAX(2,tlglob) + nsmax = MIN(ns,t1rglob) + pres(nsmin:nsmax) = mass(nsmin:nsmax)/vp(nsmin:nsmax)**gamma + pres(1)=0 + + IF (ictrl_prec2d .LE. 1) THEN + DO l = tlglob, trglob + wblocal(l) = SUM(pwint(:,l)*gsqrt(:,l) * bsq(:,l)) + wplocal(l) = vp(l)*pres(l) + END DO + + CALL Gather1XArray(wblocal) + wbtotal = SUM(wblocal(2:ns)) + CALL Gather1XArray(wplocal) + wptotal = SUM(wplocal(2:ns)) + wb = hs*ABS(wbtotal) + wp = hs*wptotal + END IF + +! ADD KINETIC PRESSURE TO MAGNETIC PRESSURE + nsmin = tlglob + nsmax = t1rglob + DO l=nsmin, nsmax + bsq(:,l) = bsq(:,l) + pres(l) + lvv(:,l) = phipog(:,l)*pgvv(:,l) + END DO + +!SPH122407-MOVED HERE: COMPUTE LAMBDA FULL MESH FORCES +! NOTE: bsubu_e is used here ONLY as a temporary array + + nsmin = tlglob + nsmax = MIN(ns - 1, trglob) + bsubv_e(:,nsmin:nsmax) = p5*(lvv(:,nsmin:nsmax)+ + & lvv(:,nsmin+1:nsmax+1)) + & * lu(:,nsmin:nsmax,0) + bsubv_e(:,ns) = p5*lvv(:,ns)*lu(:,ns,0) + + nsmin = tlglob + nsmax = t1rglob + DO l = nsmin, nsmax + lvv(:,l) = lvv(:,l)*pshalf(:,l) + bsubu_e(:,l) = pguv(:,l)*bsupu(:,l) !*sigma_an(:nrzt) !sigma_an=1 isotropic + END DO + + nsmin = tlglob + nsmax = MIN(ns - 1, trglob) + DO l = nsmin, nsmax + bsubv_e(:,l) = bsubv_e(:,l) + & + p5*((lvv(:,l)+lvv(:,l+1))*lu(:,l,1) + + & bsubu_e(:,l) + bsubu_e(:,l+1)) + END DO + bsubv_e(:,ns) = bsubv_e(:,ns) + & + p5*(lvv(:,ns)*lu(:,ns,1) + bsubu_e(:,ns)) + +! +! COMPUTE AVERAGE FORCE BALANCE AND TOROIDAL/POLOIDAL CURRENTS +! +!WAC: UPDATE buco, bvco AFTER pressure called (Gather buco, bvco in calc_fbal_par + CALL calc_fbal_par(bsubuh, bsubvh) + rbtor0= c1p5*fpsi(2) - p5*fpsi(3) + rbtor = c1p5*fpsi(ns) - p5*fpsi(ns-1) +! +! (SPH:08/19/04) +! MUST AVOID BREAKING TRI-DIAGONAL RADIAL COUPLING AT EDGE WHEN USING PRECONDITIONER +! CTOR IS PASSED TO VACUUM TO COMPUTE EDGE BSQVAC, SO IT CAN ONLY DEPEND ON NS, NS-1 +! THUS, CTOR ~ buco(ns) WORKS, WITH REMAINDER A FIXED CONSTANT. +! +! ALSO, IF USING FAST SWEEP IN COMPUTE_BLOCKS, MUST MAKE CTOR CONSTANT +! TO AVOID BREAKING SYMMETRY OF A+(ns-1) AND B-(ns) HESSIAN ELEMENTS +! +! TO GET CORRECT HESSIAN, USE THE CTOR=ctor_prec2d +... ASSIGNMENT +! FOR ictrl_prec2d.ne.0 (replace ictrl_prec2d.gt.1 with ictrl_prec2d.ne.0 in IF test below) +! +! + +! NEXT COMPUTE COVARIANT BSUBV COMPONENT ~ lvv ON FULL RADIAL MESH BY AVERAGING HALF-MESH METRICS +! NOTE: EDGE VALUES AT JS=NS DOWN BY 1/2 +! THIS IS NEEDED FOR NUMERICAL STABILITY + + IF (lHess_exact) THEN + lctor = lfreeb .AND. ictrl_prec2d.NE.0 !Yields correct hessian near edge + ELSE + lctor = lfreeb .AND. ictrl_prec2d.GT.1 !Yields better accuracy in solution + END IF + + IF (lctor) THEN + IF (ictrl_prec2d .EQ. 2) THEN + ctor_prec2d = p5*(buco(ns) - buco(ns1)) + END IF + ctor = signgs*twopi*(buco(ns)+ctor_prec2d) + ELSE + ctor = signgs*twopi*(c1p5*buco(ns) - p5*buco(ns1)) + END IF + +! +! AVERAGE LAMBDA FORCES ONTO FULL RADIAL MESH +! USE BLENDING FOR bsubv_e FOR NUMERICAL STABILITY NEAR AXIS +! + nsmin = tlglob + nsmax = t1rglob + DO l = nsmin, nsmax + lvv(:,l) = bdamp(l) + END DO + + IF (rank.EQ.0) THEN + IF (ANY(bsubvh(:,1) .ne. zero)) ier_flag = bsub_bad_js1_flag + IF (ANY(bsubuh(:,1) .ne. zero)) ier_flag = bsub_bad_js1_flag + END IF + + nsmin = tlglob + nsmax = MIN(trglob,ns - 1) + bsubu_e(:,nsmin:nsmax) = p5*(bsubuh(:,nsmin:nsmax) + + & bsubuh(:,nsmin+1:nsmax+1)) + IF (trglob .EQ. ns) bsubu_e(:,ns) = p5*bsubuh(:,ns) + + nsmin = tlglob + nsmax = MIN(ns - 1,trglob) + bsubv_e(:,nsmin:nsmax) = + & bsubv_e(:,nsmin:nsmax)*lvv(:,nsmin:nsmax) + + & p5*(1 - lvv(:,nsmin:nsmax))*(bsubvh(:,nsmin:nsmax) + + & bsubvh(:,nsmin+1:nsmax+1)) + IF (trglob .EQ. ns) THEN + bsubv_e(:,ns) = bsubv_e(:,ns)*lvv(:,ns) + & + p5*(1-lvv(:,ns))*bsubvh(:,ns) + END IF + +! +! COMPUTE R,Z AND LAMBDA PRE-CONDITIONING MATRIX +! ELEMENTS AND FORCE NORMS: NOTE THAT lu=>czmn, lv=>crmn externally +! SO THIS STORES bsupv in czmn_e, bsupu in crmn_e +! + nsmin = tlglob + nsmax = t1rglob + IF (iequi .EQ. 1) THEN + lu(:,nsmin:nsmax,0) = bsupv(:,nsmin:nsmax) + lv(:,nsmin:nsmax,0) = bsupu(:,nsmin:nsmax) + END IF + +! +! COMPUTE PRECONDITIONING (1D) AND SCALING PARAMETERS +! NO NEED TO RECOMPUTE WHEN 2D-PRECONDITIONER ON +! + + IF ((MOD(iter2-iter1,ns4).EQ.0 .AND. iequi.EQ.0) .AND. + & ictrl_prec2d.EQ.0) THEN + nsmin = tlglob + nsmax = t1rglob + phipog(:,nsmin:nsmax) = phipog(:,nsmin:nsmax) + & * pwint (:,nsmin:nsmax) + + CALL lamcal_par(phipog, pguu, pguv, pgvv) + + CALL precondn_par(bsupv, bsq, gsqrt, r12, zs, zu12, + & pzu(:,:,0), pzu(:,:,1), pz1(:,:,1), arm, + & ard, brm, brd, crd, rzu_fac, cos01) + + CALL precondn_par(bsupv, bsq, gsqrt, r12, rs, ru12, + & pru(:,:,0), pru(:,:,1), pr1(:,:,1), azm, + & azd, bzm, bzd, crd, rru_fac, sin01) + + nsmin = MAX(2,tlglob) + nsmax = MIN(trglob,ns - 1) + rzu_fac(nsmin:nsmax) = psqrts(1,nsmin:nsmax) + & * rzu_fac(nsmin:nsmax) + rru_fac(nsmin:nsmax) = psqrts(1,nsmin:nsmax) + & * rru_fac(nsmin:nsmax) + frcc_fac(nsmin:nsmax) = one/rzu_fac(nsmin:nsmax) + rzu_fac(nsmin:nsmax) = rzu_fac(nsmin:nsmax)/2 + fzsc_fac(nsmin:nsmax) =-one/rru_fac(nsmin:nsmax) + rru_fac(nsmin:nsmax) = rru_fac(nsmin:nsmax)/2 + + nsmin = tlglob + nsmax = t1rglob + pguu(:,nsmin:nsmax) = pguu(:,nsmin:nsmax) + & * r12(:,nsmin:nsmax)**2 + + DO l = MAX(2,tlglob), trglob + fnlocal(l) = SUM(pguu(:,l)*pwint(:,l)) + fn1local(l) = SUM(tpxc(2:,l,1:ntmax)**2) + & + SUM(tpxc(1:,l,ntmax+1:2*ntmax)**2) + fnLlocal(l) = SUM((bsubuh(:,l)**2 + bsubvh(:,l)**2) + & * pwint(:,l))*lamscale**2 + END DO + + CALL Gather1XArray(vp); vptotal = SUM(vp(2:ns)) + CALL Gather1XArray(fnlocal); fntotal = SUM(fnlocal(2:ns)) + CALL Gather1XArray(fn1local); fn1total= SUM(fn1local(2:ns)) + CALL Gather1XArray(fnLlocal); fnLtotal= SUM(fnLlocal(2:ns)) + + volume = hs*vptotal + r2 = MAX(wb,wp)/volume + fnorm = one/(fntotal*(r2*r2)) + fnorm1=one/fn1total + fnormL = one/fnLtotal +! +! COMPUTE CONSTRAINT FORCE SCALING FACTOR (TCON) +! OVERRIDE USER INPUT VALUE HERE +! +#ifndef _HBANGLE + r2 = ns + tcon0 = MIN(ABS(tcon0), one) !!ignore large tcon0 from old-style files + tcon_mul = tcon0*(1 + r2*(one/60 + r2/(200*120))) + + tcon_mul = tcon_mul/((4*r0scale**2)**2) !!Scaling of ard, azd (2*r0scale**2); + !!Scaling of cos**2 in alias (4*r0scale**2) + tcon = tcon0 + DO js = MAX(2,tlglob), MIN(ns-1,trglob) + arnorm = SUM(pwint(:,js)*pru0(:,js)**2) + aznorm = SUM(pwint(:,js)*pzu0(:,js)**2) +! IF (arnorm .eq. zero .or. aznorm .eq. zero) THEN +! STOP 'arnorm or aznorm=0 in bcovar' +! END IF + IF (arnorm .eq. zero .or. aznorm .eq. zero) THEN !SAL 070719 + ier_flag = arz_bad_value_flag + END IF + + tcon(js) = MIN(ABS(ard(js,1)/arnorm), + 1 ABS(azd(js,1)/aznorm))*tcon_mul*(32*hs)**2 + END DO + tcon(ns) = p5*tcon(ns - 1) + IF (lasym) THEN + tcon = p5*tcon + END IF +#endif + ENDIF + + CALL MPI_ALLREDUCE(MPI_IN_PLACE,ier_flag,1,MPI_INTEGER, + 1 MPI_MAX,NS_COMM,MPI_ERR) + IF (ier_flag .ne. norm_term_flag) RETURN +! +! COMPUTE COVARIANT BSUBU,V (EVEN, ODD) ON HALF RADIAL MESH +! FOR FORCE BALANCE AND RETURN (IEQUI=1) +! +! +! COMPUTE COVARIANT BSUBU,V (EVEN, ODD) ON HALF RADIAL MESH +! FOR FORCE BALANCE AND RETURN (IEQUI=1) +! + + IF (iequi .EQ. 1) THEN + nsmin = MAX(tlglob,2) + nsmax = MIN(trglob,ns - 1) + DO js = nsmax, nsmin, -1 + bsubvh(:,js) = 2*bsubv_e(:,js) - bsubvh(:,js+1) + END DO + + +! ADJUST AFTER MESH-BLENDING + nsmin=MAX(tlglob,2); nsmax=MIN(trglob,ns) + DO js = nsmin, nsmax + curpol_temp = fpsi(js) - SUM(bsubvh(:,js)*pwint(:,js)) + bsubvh(:,js) = bsubvh(:,js) + curpol_temp + END DO + + bsubu_e(:,nsmin:nsmax) = bsubuh(:,nsmin:nsmax) + bsubv_e(:,nsmin:nsmax) = bsubvh(:,nsmin:nsmax) + + bsubu_o(:,nsmin:nsmax) = pshalf(:,nsmin:nsmax) + & * bsubu_e(:,nsmin:nsmax) + bsubv_o(:,nsmin:nsmax) = pshalf(:,nsmin:nsmax) + & * bsubv_e(:,nsmin:nsmax) + RETURN + END IF + +! MINUS SIGN => HESSIAN DIAGONALS ARE POSITIVE + nsmin = MAX(tlglob,2) + nsmax = trglob + bsubu_e(:,nsmin:nsmax) = -lamscale*bsubu_e(:,nsmin:nsmax) + bsubv_e(:,nsmin:nsmax) = -lamscale*bsubv_e(:,nsmin:nsmax) + bsubu_o(:,nsmin:nsmax) = psqrts(:,nsmin:nsmax) + & * bsubu_e(:,nsmin:nsmax) + bsubv_o(:,nsmin:nsmax) = psqrts(:,nsmin:nsmax) + & * bsubv_e(:,nsmin:nsmax) + +! +! STORE LU * LV COMBINATIONS USED IN FORCES +! + + nsmin = MAX(tlglob,2) + nsmax = t1rglob + DO l = nsmin, nsmax + lvv(:,l) = gsqrt(:,l) !*sigma_an(:,l) + pguu(:,l) = bsupu(:,l)*bsupu(:,l)*lvv(:,l) + pguv(:,l) = bsupu(:,l)*bsupv(:,l)*lvv(:,l) + pgvv(:,l) = bsupv(:,l)*bsupv(:,l)*lvv(:,l) + lv(:,l,0) = bsq(:,l)*tau(:,l) + lu(:,l,0) = bsq(:,l)*r12(:,l) + END DO + + END SUBROUTINE bcovar_par + + SUBROUTINE bcovar (lu, lv) + USE vmec_main, fpsi => bvco, p5 => cp5 + USE vmec_params, ONLY: ns4, signgs, pdamp, lamscale + USE realspace + USE vforces, r12 => armn_o, ru12 => azmn_e, gsqrt => azmn_o, + & rs => bzmn_e, zs => brmn_e, zu12 => armn_e, + & bsubu_e => clmn_e, bsubv_e => blmn_e, + & bsubu_o => clmn_o, bsubv_o => blmn_o, + & bsq => bzmn_o, phipog => brmn_o + USE xstuff, ONLY: xc + USE precon2d, ONLY: ictrl_prec2d, lHess_exact, + & ctor_prec2d +#ifdef _HBANGLE + USE angle_constraints, ONLY: precondn_rho, ard2, arm2, + & azd2, azm2, brd2, brm2, bzd2, bzm2 +#endif + USE fbal + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(nrzt,0:1), INTENT(inout) :: lu, lv +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- +! GENERALLY, IF TEMPORAL CONVERGENCE IS POOR, TRY TO INCREASE PDAMP (< 1) +! (STORED IN VMEC_PARAMS) + REAL(dp), PARAMETER :: c1p5 = (one + p5) +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: l, js, ndim + REAL(dp) :: r2, volume, curpol_temp +#ifndef _HBANGLE + REAL(dp) :: arnorm, aznorm, tcon_mul +#endif + REAL(dp), POINTER, DIMENSION(:) :: luu, luv, lvv, tau + REAL(dp), DIMENSION(:), POINTER :: bsupu, bsubuh, + & bsupv, bsubvh, r12sq + LOGICAL :: lctor +!----------------------------------------------- + ndim = 1 + nrzt + +! +! POINTER ALIAS ASSIGNMENTS +! + tau => extra1(:,1); luu => extra2(:,1); + luv => extra3(:,1); lvv => extra4(:,1) + + bsupu => luu; bsubuh => bsubu_o + bsupv => luv; bsubvh => bsubv_o + r12sq => bsq + + +! +! FOR OPTIMIZATION ON CRAY, MUST USE COMPILER DIRECTIVES TO +! GET VECTORIZATION OF LOOPS INVOLVING (MORE THAN ONE) POINTER! +! + guu(ndim) = 0; guv = 0; gvv = 0 + +! +! COMPUTE METRIC ELEMENTS GIJ ON HALF MESH +! FIRST, GIJ = EVEN PART (ON FULL MESH), LIJ = ODD PART (ON FULL MESH) +! THEN, GIJ(HALF) = < GIJ(even)> + SHALF < GIJ(odd) > +! + + r12sq(1:nrzt) = sqrts(1:nrzt)*sqrts(1:nrzt) + guu(1:nrzt) = ru(1:nrzt,0)*ru(1:nrzt,0) + & + zu(1:nrzt,0)*zu(1:nrzt,0) + r12sq(1:nrzt)* + & ( ru(1:nrzt,1)*ru(1:nrzt,1) + & + zu(1:nrzt,1)*zu(1:nrzt,1)) + + luu(1:nrzt) = (ru(1:nrzt,0)*ru(1:nrzt,1) + & + zu(1:nrzt,0)*zu(1:nrzt,1))*2 + phipog(1:nrzt) = 2*r1(1:nrzt,0)*r1(1:nrzt,1) + + IF (lthreed) THEN + guv(1:nrzt) = ru(1:nrzt,0)*rv(1:nrzt,0) + & + zu(1:nrzt,0)*zv(1:nrzt,0) + & + r12sq(1:nrzt)*(ru(1:nrzt,1)*rv(1:nrzt,1) + + & zu(1:nrzt,1)*zv(1:nrzt,1)) + luv(1:nrzt) = ru(1:nrzt,0)*rv(1:nrzt,1) + & + ru(1:nrzt,1)*rv(1:nrzt,0) + & + zu(1:nrzt,0)*zv(1:nrzt,1) + & + zu(1:nrzt,1)*zv(1:nrzt,0) + gvv(1:nrzt) = rv(1:nrzt,0)*rv(1:nrzt,0) + & + zv(1:nrzt,0)*zv(1:nrzt,0) + & + r12sq(1:nrzt)*(rv(1:nrzt,1)*rv(1:nrzt,1) + + & zv(1:nrzt,1)*zv(1:nrzt,1)) + lvv(1:nrzt) =(rv(1:nrzt,0)*rv(1:nrzt,1) + + & zv(1:nrzt,0)*zv(1:nrzt,1))*2 + END IF + + r12sq(1:nrzt) = r1(1:nrzt,0)*r1(1:nrzt,0) + & + r12sq(1:nrzt)*r1(1:nrzt,1)*r1(1:nrzt,1) + +!DIR$ IVDEP + DO l = nrzt, 2, -1 + guu(l) = p5*(guu(l) + guu(l-1) + shalf(l)*(luu(l) + luu(l-1))) + r12sq(l) = p5*(r12sq(l) + r12sq(l-1) + !Comment: r12sq = r12**2 + & shalf(l)*(phipog(l) + phipog(l-1))) + END DO + + IF (lthreed) THEN +!DIR$ IVDEP + DO l = nrzt, 2, -1 + guv(l) = p5*(guv(l) + guv(l-1) + + & shalf(l)*(luv(l) + luv(l-1))) + gvv(l) = p5*(gvv(l) + gvv(l-1) + + & shalf(l)*(lvv(l) + lvv(l-1))) + END DO + END IF + + tau(1:nrzt) = gsqrt(1:nrzt) + gsqrt(1:nrzt) = r12(1:nrzt)*tau(1:nrzt) + gsqrt(1:nrzt:ns) = gsqrt(2:nrzt:ns) + + gvv(2:nrzt) = gvv(2:nrzt) + r12sq(2:nrzt) + +!CATCH THIS AFTER WHERE LINE BELOW phipog = 0 + WHERE (gsqrt(2:ndim) .ne. zero) + phipog(2:ndim) = one/gsqrt(2:ndim) + END WHERE + phipog(1:ndim:ns) = 0 + + vp(1) = 0; vp(ns+1) = 0 + DO js = 2, ns + vp(js) = signgs*SUM(gsqrt(js:nrzt:ns)*wint(js:nrzt:ns)) + END DO + IF (iter2 .eq. 1) THEN + voli = twopi*twopi*hs*SUM(vp(2:ns)) + END IF + +! +! COMPUTE CONTRA-VARIANT COMPONENTS OF B (Bsupu,v) ON RADIAL HALF-MESH +! TO ACCOMODATE LRFP=T CASES, THE OVERALL PHIP FACTOR (PRIOR TO v8.46) +! HAS BEEN REMOVED FROM PHIPOG, SO NOW PHIPOG == 1/GSQRT! +! +! NOTE: LU = LAMU == d(LAM)/du, LV = -LAMV == -d(LAM)/dv COMING INTO THIS ROUTINE +! WILL ADD CHIP IN CALL TO ADD_FLUXES. THE NET BSUPU, BSUPV ARE (PHIPOG=1/GSQRT AS NOTED ABOVE): +! +! BSUPU = PHIPOG*(chip - LAMV*LAMSCALE), +! BSUPV = PHIPOG*(phip + LAMU*LAMSCALE) +! + lu = lu*lamscale + lv = lv*lamscale + + DO js = 1, ns + lu(js:nrzt:ns,0) = lu(js:nrzt:ns,0) + phipf(js) + END DO + + bsupu(2:nrzt) = p5*phipog(2:nrzt)*(lv(2:nrzt,0) + lv(1:nrzt-1,0) + & + shalf(2:nrzt)*(lv(2:nrzt,1) + lv(1:nrzt-1,1))) + bsupv(2:nrzt) = p5*phipog(2:nrzt)*(lu(2:nrzt,0) + lu(1:nrzt-1,0) + & + shalf(2:nrzt)*(lu(2:nrzt,1) + lu(1:nrzt-1,1))) +!v8.49: add ndim points + bsupu(1)=0; bsupu(ndim)=0 + bsupv(1)=0; bsupv(ndim)=0 + +! +! UPDATE IOTA EITHER OF TWO WAYS: +! 1) FOR ictrl_prec2d = 0, SOLVE THE LINEAR ALGEBRAIC EQUATION = icurv +! FOR iotas +! 2) FOR ictrl_prec2d > 0, EVOLVE IOTAS IN TIME, USING Force-iota = - icurv IN TOMNSP. +! +! NEED TO DO IT WAY (#2) TO EASILY COMPUTE THE HESSIAN ELEMENTS DUE TO LAMBDA-VARIATIONS. +! IOTAS IS "STORED" AT LOCATION LAMBDA-SC(0,0) IN XC-ARRAY [USE THIS COMPONENT SO IT +! WILL WORK EVEN FOR 2D PLASMA], ALTHOUGH ITS VARIATION IS LIKE THAT OF LV-CS(0,0), +! WITH N -> 1 IN THE HESSIAN CALCULATION ROUTINES (Compute_Hessian_Flam_lam, etc.) +! + +! COMPUTE (IF NEEDED) AND ADD CHIP TO BSUPU +#if defined(CHI_FORCE) + CALL add_fluxes(phipog, bsupu, bsupv, ictrl_prec2d.EQ.0) +#else + CALL add_fluxes(phipog, bsupu, bsupv, .TRUE.) +#endif + +! +! COMPUTE LAMBDA FORCE KERNELS (COVARIANT B COMPONENT bsubu,v) ON RADIAL HALF-MESH +! + bsubuh(1:nrzt) = guu(1:nrzt)*bsupu(1:nrzt) + & + guv(1:nrzt)*bsupv(1:nrzt) + bsubvh(1:nrzt) = guv(1:nrzt)*bsupu(1:nrzt) + & + gvv(1:nrzt)*bsupv(1:nrzt) +!v8.49 + bsubuh(ndim) = 0; bsubvh(ndim) = 0 + +! +! COMPUTE MAGNETIC AND KINETIC PRESSURE ON RADIAL HALF-MESH +! + bsq(:nrzt) = p5*(bsupu(:nrzt)*bsubuh(:nrzt) + & + bsupv(:nrzt)*bsubvh(:nrzt)) + + wb = hs*ABS(SUM(wint(:nrzt)*gsqrt(:nrzt)*bsq(:nrzt))) + +#ifdef _ANIMEC +!SPH: MAKE CALL HERE (bsubX_e are used for scratch arrays) + CALL an_pressure(bsubu_e, bsubv_e) + +! ADD KINETIC PRESSURE TO MAGNETIC PRESSURE + bsq(2:nrzt) = bsq(2:nrzt) + pperp(2:nrzt) + +!WAC-SPH: MODIFY EFFECTIVE CURRENT K = curl(sigma_an*B) + phipog(1:nrzt) = phipog(1:nrzt)*sigma_an(1:nrzt) + bsubuh(1:nrzt) = bsubuh(1:nrzt)*sigma_an(1:nrzt) + bsubvh(1:nrzt) = bsubvh(1:nrzt)*sigma_an(1:nrzt) + +#else + pres(2:ns) = mass(2:ns)/vp(2:ns)**gamma + wp = hs*SUM(vp(2:ns)*pres(2:ns)) + +! ADD KINETIC PRESSURE TO MAGNETIC PRESSURE + DO js = 2, ns + bsq(js:nrzt:ns) = bsq(js:nrzt:ns) + pres(js) + END DO +#endif + +!SPH122407-MOVED HERE: COMPUTE LAMBDA FULL MESH FORCES +! NOTE: bsubu_e is used here ONLY as a temporary array + lvv = phipog(:ndim)*gvv + bsubv_e(1:nrzt) = p5*(lvv(1:nrzt)+lvv(2:ndim))*lu(1:nrzt,0) + + lvv = lvv*shalf + bsubu_e(:nrzt) = guv(:nrzt)*bsupu(:nrzt)*sigma_an(:nrzt) !sigma_an=1 isotropic + bsubu_e(ndim) = 0 + bsubv_e(1:nrzt) = bsubv_e(1:nrzt) + & + p5*((lvv(1:nrzt) + lvv(2:ndim))*lu(1:nrzt,1) + + & bsubu_e(1:nrzt) + bsubu_e(2:ndim)) + +! +! COMPUTE AVERAGE FORCE BALANCE AND TOROIDAL/POLOIDAL CURRENTS +! +!WAC: UPDATE buco, bvco AFTER pressure called +#ifdef _ANIMEC + IF (iequi .EQ. 1) papr = pmap*pres/vp +#endif + CALL calc_fbal(bsubuh, bsubvh) + + rbtor0= c1p5*fpsi(2) - p5*fpsi(3) + rbtor = c1p5*fpsi(ns) - p5*fpsi(ns-1) +! +! (SPH:08/19/04) +! MUST AVOID BREAKING TRI-DIAGONAL RADIAL COUPLING AT EDGE WHEN USING PRECONDITIONER +! CTOR IS PASSED TO VACUUM TO COMPUTE EDGE BSQVAC, SO IT CAN ONLY DEPEND ON NS, NS-1 +! THUS, CTOR ~ buco(ns) WORKS, WITH REMAINDER A FIXED CONSTANT. +! +! ALSO, IF USING FAST SWEEP IN COMPUTE_BLOCKS, MUST MAKE CTOR CONSTANT +! TO AVOID BREAKING SYMMETRY OF A+(ns-1) AND B-(ns) HESSIAN ELEMENTS +! +! TO GET CORRECT HESSIAN, USE THE CTOR=ctor_prec2d +... ASSIGNMENT +! FOR ictrl_prec2d.ne.0 (replace ictrl_prec2d.gt.1 with ictrl_prec2d.ne.0 in IF test below) +! +! + +! NEXT COMPUTE COVARIANT BSUBV COMPONENT ~ lvv ON FULL RADIAL MESH BY AVERAGING HALF-MESH METRICS +! NOTE: EDGE VALUES AT JS=NS DOWN BY 1/2 +! THIS IS NEEDED FOR NUMERICAL STABILITY + + IF (lHess_exact) THEN + lctor = lfreeb .and. ictrl_prec2d.ne.0 !Yields correct hessian near edge + ELSE + lctor = lfreeb .and. ictrl_prec2d.gt.1 !Yields better accuracy in solution + END IF + IF (lctor) THEN + IF (ictrl_prec2d .eq. 2) THEN + ctor_prec2d = signgs*twopi*p5*(buco(ns) - buco(ns1)) + END IF + ctor = ctor_prec2d + signgs*twopi*buco(ns) + ELSE + ctor = signgs*twopi*(c1p5*buco(ns) - p5*buco(ns1)) + END IF + +! +! AVERAGE LAMBDA FORCES ONTO FULL RADIAL MESH +! USE BLENDING FOR bsubv_e FOR NUMERICAL STABILITY NEAR AXIS +! + DO l = 1, ns + lvv(l:nrzt:ns) = bdamp(l) + END DO + + IF (ANY(bsubuh(1:ndim:ns) .ne. zero)) STOP 'BSUBUH != 0 AT JS=1' + IF (ANY(bsubvh(1:ndim:ns) .ne. zero)) STOP 'BSUBVH != 0 AT JS=1' + + bsubu_e(1:nrzt) = p5*(bsubuh(1:nrzt) + bsubuh(2:ndim)) + bsubv_e(1:nrzt) = bsubv_e(1:nrzt)*lvv(1:nrzt) + & + p5*(1 - lvv(1:nrzt))*(bsubvh(1:nrzt) + & + bsubvh(2:ndim)) + +! +! COMPUTE R,Z AND LAMBDA PRE-CONDITIONING MATRIX +! ELEMENTS AND FORCE NORMS: NOTE THAT lu=>czmn, lv=>crmn externally +! SO THIS STORES bsupv in czmn_e, bsupu in crmn_e +! + IF (iequi .EQ. 1) THEN + lu(:nrzt,0) = bsupv(:nrzt) + lv(:nrzt,0) = bsupu(:nrzt) + END IF + +! +! COMPUTE PRECONDITIONING (1D) AND SCALING PARAMETERS +! NO NEED TO RECOMPUTE WHEN 2D-PRECONDITIONER ON +! + IF ((MOD(iter2-iter1,ns4) .eq. 0 .and. iequi .eq. 0) .and. + & ictrl_prec2d.eq.0) THEN + phipog(:nrzt) = phipog(:nrzt)*wint(:nrzt) + CALL lamcal(phipog, guu, guv, gvv) + CALL precondn(bsupv, bsq, gsqrt, r12, zs, zu12, zu,z u(1,1), + & z1(1,1), arm, ard, brm, brd, +#ifdef _HBANGLE + & arm2, ard2, brm2, brd2, +#endif + & crd, rzu_fac, cos01) + CALL precondn(bsupv, bsq, gsqrt, r12, rs, ru12, ru, ru(1,1), + & r1(1,1), azm, azd, bzm, bzd, +#ifdef _HBANGLE + & azm2, azd2, bzm2, bzd2, +#endif + & crd, rru_fac, sin01) + + rzu_fac(2:ns-1) = sqrts(2:ns-1)*rzu_fac(2:ns-1) + rru_fac(2:ns-1) = sqrts(2:ns-1)*rru_fac(2:ns-1) + frcc_fac(2:ns-1) = one/rzu_fac(2:ns-1); rzu_fac = rzu_fac/2 + fzsc_fac(2:ns-1) =-one/rru_fac(2:ns-1); rru_fac = rru_fac/2 +#ifdef _HBANGLE + CALL precondn_rho +#endif + + volume = hs*SUM(vp(2:ns)) + r2 = MAX(wb,wp)/volume + guu(:nrzt) = guu(:nrzt)*r12(:nrzt)**2 !R12 from RP in force + fnorm = one/(SUM(guu(1:nrzt)*wint(1:nrzt))*(r2*r2)) !Norm, unpreconditioned R,Z forces + fnorm1 = one/SUM(xc(1+ns:2*irzloff)**2) !Norm for preconditioned R,Z forces + fnormL = one/(SUM((bsubuh(1:nrzt)**2 + bsubvh(1:nrzt)**2) * + & wint(1:nrzt))*lamscale**2) !Norm for unpreconditioned Lambda force +! r3 = one/(2*r0scale)**2 +! fnorm2 = one/MAX(SUM(xc(2*irzloff+1:3*irzloff)**2),r3/4) !Norm for preconditioned Lambda force + +! +! COMPUTE CONSTRAINT FORCE SCALING FACTOR (TCON) +! OVERRIDE USER INPUT VALUE HERE +! +#ifndef _HBANGLE + r2 = ns + tcon0 = MIN(ABS(tcon0), one) !!ignore large tcon0 from old-style files + tcon_mul = tcon0*(1 + r2*(one/60 + r2/(200*120))) + + tcon_mul = tcon_mul/((4*r0scale**2)**2) !!Scaling of ard, azd (2*r0scale**2); + !!Scaling of cos**2 in alias (4*r0scale**2) + + DO js = 2, ns - 1 + arnorm = SUM(wint(js:nrzt:ns)*ru0(js:nrzt:ns)**2) + aznorm = SUM(wint(js:nrzt:ns)*zu0(js:nrzt:ns)**2) + IF (arnorm.eq.zero .or. aznorm.eq.zero) THEN + STOP 'arnorm or aznorm=0 in bcovar' + END IF + + tcon(js) = MIN(ABS(ard(js,1)/arnorm), + & ABS(azd(js,1)/aznorm))*tcon_mul*(32*hs)**2 + END DO + tcon(ns) = p5*tcon(ns-1) + IF (lasym) tcon = p5*tcon +#endif + ENDIF + +! +! COMPUTE COVARIANT BSUBU,V (EVEN, ODD) ON HALF RADIAL MESH +! FOR FORCE BALANCE AND RETURN (IEQUI=1) +! + IF (iequi .eq. 1) THEN + + DO js = ns - 1, 2, -1 + DO l = js, nrzt, ns + bsubvh(l) = 2*bsubv_e(l) - bsubvh(l + 1) + END DO + END DO + +! ADJUST AFTER MESH-BLENDING + DO js = 2, ns + curpol_temp = fpsi(js) + & - SUM(bsubvh(js:nrzt:ns)*wint(js:nrzt:ns)) + DO l = js, nrzt, ns + bsubvh(l) = bsubvh(l) + curpol_temp + END DO + END DO + + bsubu_e(:nrzt) = bsubuh(:nrzt) + bsubv_e(:nrzt) = bsubvh(:nrzt) + + bsubu_o(:nrzt) = shalf(:nrzt)*bsubu_e(:nrzt) + bsubv_o(:nrzt) = shalf(:nrzt)*bsubv_e(:nrzt) + + RETURN + + END IF + +! MINUS SIGN => HESSIAN DIAGONALS ARE POSITIVE + bsubu_e = -lamscale*bsubu_e + bsubv_e = -lamscale*bsubv_e + bsubu_o(:nrzt) = sqrts(:nrzt)*bsubu_e(:nrzt) + bsubv_o(:nrzt) = sqrts(:nrzt)*bsubv_e(:nrzt) + +! +! STORE LU * LV COMBINATIONS USED IN FORCES +! +!WAC, SPH122407: sigma_an (=1 for isotropic case) + lvv(2:nrzt) = gsqrt(2:nrzt)*sigma_an(2:nrzt) + guu(2:nrzt) = bsupu(2:nrzt)*bsupu(2:nrzt)*lvv(2:nrzt) + guv(2:nrzt) = bsupu(2:nrzt)*bsupv(2:nrzt)*lvv(2:nrzt) + gvv(2:nrzt) = bsupv(2:nrzt)*bsupv(2:nrzt)*lvv(2:nrzt) + lv(2:nrzt,0) = bsq(2:nrzt)*tau(2:nrzt) + lu(2:nrzt,0) = bsq(2:nrzt)*r12(2:nrzt) + + END SUBROUTINE bcovar diff --git a/Sources/General/blocktridiagonalsolver.f90 b/Sources/General/blocktridiagonalsolver.f90 new file mode 100644 index 0000000..e1a1f47 --- /dev/null +++ b/Sources/General/blocktridiagonalsolver.f90 @@ -0,0 +1,5381 @@ +!------------------------------------------------------------------------------- +!> +!!Solver for block tri-diagonal matrices. [Kalyan S. Perumalla, ORNL, 2009-2011] +!< +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +MODULE blocktridiagonalsolver +USE mpi_inc +USE parallel_include_module, ONLY: STOPMPI +USE parallel_include_module, ONLY: TOFU +USE parallel_include_module, ONLY: NS_COMM +USE parallel_include_module, ONLY: grank, gnranks +USE parallel_include_module, ONLY: rank, nranks +USE parallel_include_module, ONLY: NS_RESLTN +IMPLICIT NONE + +!------------------------------------------------------------------------------- +! Precision settings +!------------------------------------------------------------------------------- +INTEGER, PARAMETER :: rprec = SELECTED_REAL_KIND(15,300) +INTEGER, PARAMETER :: iprec = SELECTED_INT_KIND(8) +INTEGER, PARAMETER :: cprec = KIND((1.0_rprec,1.0_rprec)) +INTEGER, PARAMETER :: dp = rprec + +!------------------------------------------------------------------------------- +!> +!! Data associated with each row at each level +!< +!------------------------------------------------------------------------------- +TYPE LevelElement + REAL(dp), ALLOCATABLE :: L(:,:), D(:,:), U(:,:), b(:,:) + INTEGER, ALLOCATABLE :: pivot(:) +END TYPE LevelElement + +!------------------------------------------------------------------------------- +!> +!! Solution of selected rows of interest to this rank +!< +!------------------------------------------------------------------------------- +TYPE SolutionElement + REAL(dp), ALLOCATABLE :: x(:) !Vector of size M +END TYPE SolutionElement + +!------------------------------------------------------------------------------- +!> +!! Data for each row at each level on this rank +!! The first dimension is the level number [1..L], L=#levels of forward solve +!! The 2nd dimension is the row number [1..K+g], K=#rows at level 1 on this rank +!! The +g is for incoming results from neighbors, 0<=g<=2 +!< +!------------------------------------------------------------------------------- +TYPE (LevelElement), ALLOCATABLE :: lelement(:,:) + +!------------------------------------------------------------------------------- +!> +!! Initial problem specification saved for verification at end of solution +!! The dimension is the row number [1..K], K=#rows at level 1 on this rank +!< +!------------------------------------------------------------------------------- +TYPE (LevelElement), ALLOCATABLE :: orig(:) + +!------------------------------------------------------------------------------- +!> +!! The solution +!! The dimension is the global (level 1) row number [1..N] +!< +!------------------------------------------------------------------------------- +TYPE (SolutionElement), ALLOCATABLE :: selement(:) + +!------------------------------------------------------------------------------- +!INTEGER :: rank ! +!! Unmodified diagonal element : SKS +!< +!------------------------------------------------------------------------------- +REAL(dp), ALLOCATABLE :: OrigDiagElement(:) +REAL(dp), ALLOCATABLE :: TopScaleFac(:), BotScaleFac(:) +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +!> +!! BLACS/PBLAS options +!< +!------------------------------------------------------------------------------- +LOGICAL :: doblasonly +LOGICAL :: doblacscomm + +!------------------------------------------------------------------------------- +!> +!! BLACS/PBLAS process grid information +!< +!------------------------------------------------------------------------------- +TYPE BlacsProcessGrid + INTEGER :: myrow, mycol + INTEGER :: nrows, ncols + INTEGER :: blockszrows, blockszcols + INTEGER, ALLOCATABLE :: map(:,:) ! +!! BLACS/PBLAS information +!< +!------------------------------------------------------------------------------- +TYPE BlacsParameters + INTEGER :: iam + INTEGER :: nprocs + INTEGER :: maincontext + INTEGER :: levelcontext + TYPE(BlacsProcessGrid) :: pgrid + INTEGER :: nbpp ! +!! Master-to-slave mapping +!< +!------------------------------------------------------------------------------- +TYPE MasterToSlaveMapping + INTEGER :: masterrank + INTEGER :: nslaves + INTEGER, ALLOCATABLE :: slaveranks(:) +END TYPE MasterToSlaveMapping + +!------------------------------------------------------------------------------- +!> +!! Level-specific PBLAS information +!< +!------------------------------------------------------------------------------- +TYPE PBLASLevelParameters + LOGICAL :: ammaster + TYPE(MasterToSlaveMapping) :: msmap + + INTEGER :: mpicomm, mpitag, mpierr +#if defined(MPI_OPT) + INTEGER :: mpistatus(MPI_STATUS_SIZE) +#endif + +END TYPE PBLASLevelParameters + +TYPE(PBLASLevelParameters) :: pblas + +!------------------------------------------------------------------------------- +!> +!! Master-to-slave commands +!< +!------------------------------------------------------------------------------- +INTEGER, PARAMETER :: OP_NONE = 0 +INTEGER, PARAMETER :: OP_DONE = 1 +INTEGER, PARAMETER :: OP_DGEMM = 2 +INTEGER, PARAMETER :: OP_DGEMV = 3 +INTEGER, PARAMETER :: OP_DGETRF = 4 +INTEGER, PARAMETER :: OP_DGETRS = 5 + +!------------------------------------------------------------------------------- +!> +!! Statistics (timing, etc.) +!< +!------------------------------------------------------------------------------- +TYPE TimeCount + DOUBLE PRECISION :: tm + INTEGER :: cnt + DOUBLE PRECISION :: t1, t2 ! +!! A convenience function to be able to change clock routine(s) easily +!< +!------------------------------------------------------------------------------- +SUBROUTINE BClockInit() + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: tempint + + IF ( use_mpiwtime ) THEN + timerfreq = 1.0 + ELSE + CALL SYSTEM_CLOCK(COUNT_RATE=tempint) + timerfreq = tempint + END IF +END SUBROUTINE BClockInit + +!------------------------------------------------------------------------------- +!> +!! A convenience function to be able to change clock routine easily +!< +!------------------------------------------------------------------------------- +SUBROUTINE BSystemClock( ts ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + DOUBLE PRECISION, INTENT(INOUT) :: ts ! +!! Is given integer odd? +!< +!------------------------------------------------------------------------------- +LOGICAL FUNCTION ISODD( num ) + INTEGER, INTENT(IN) :: num ! +!!Determines the global row number of a given local row number at a given level +!< +!------------------------------------------------------------------------------- +FUNCTION LR2GR( locrow, level ) result ( globrow ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!Determines the local row number of "globrow" global row number when globrow +!!participates at a given level; returns zero if this globrow does not operate +!!at the given level +!< +!------------------------------------------------------------------------------- +FUNCTION GR2LR( globrow, level ) result ( locrow ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: globrow ! +!!Determines the rank of the task holding the given global row (at level 1) +!< +!------------------------------------------------------------------------------- +FUNCTION GR2Rank( globrow ) result ( outrank ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: globrow ! +!!Determines the rank of the task holding the given local row (at a given level) +!< +!------------------------------------------------------------------------------- +FUNCTION LR2Rank( locrow, level ) result ( outrank ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!Compute the matrix multiplications in the forward solve at some/any level +!!The row should be odd at the level, +!!The locrow should obey startlocrow <= locrow <= endlocrow +!< +!------------------------------------------------------------------------------- +#if defined(MPI_OPT) +SUBROUTINE ComputeForwardOddRowHats(locrow, level, startlocrow, endlocrow,bonly) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!BCYCLIC forward phase; to be called after Initialize +!< +!------------------------------------------------------------------------------- +SUBROUTINE ForwardSolve + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!BCYCLIC forward phase to deal with a new b; to be called after a SetRHS that +!!may have been invoked after a ForwardSolve, before BackwardSolve. +!< +!------------------------------------------------------------------------------- +SUBROUTINE ForwardUpdateb + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!BCYCLIC backward phase; to be called after ForwardSolve +!< +!------------------------------------------------------------------------------- +SUBROUTINE BackwardSolve + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!Verify the RMS error of solution after backward solve +!< +!------------------------------------------------------------------------------- +SUBROUTINE VerifySolution + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: i, k, globrow, globrowoff + REAL(dp) :: term, totrmserr + INTEGER :: nbrrank ! +!! Data associated with each row at each level +!< +!------------------------------------------------------------------------------- +TYPE LevelElement + REAL(dp), ALLOCATABLE :: L(:,:), D(:,:), U(:,:), b(:,:) + INTEGER, ALLOCATABLE :: pivot(:) +END TYPE LevelElement + +!------------------------------------------------------------------------------- +!> +!! Solution of selected rows of interest to this rank +!< +!------------------------------------------------------------------------------- +TYPE SolutionElement + REAL(dp), ALLOCATABLE :: x(:) !Vector of size M +END TYPE SolutionElement + +!------------------------------------------------------------------------------- +!> +!! Data for each row at each level on this rank +!! The first dimension is the level number [1..L], L=#levels of forward solve +!! The 2nd dimension is the row number [1..K+g], K=#rows at level 1 on this rank +!! The +g is for incoming results from neighbors, 0<=g<=2 +!< +!------------------------------------------------------------------------------- +TYPE (LevelElement), ALLOCATABLE :: lelement(:,:) + +!------------------------------------------------------------------------------- +!> +!! Initial problem specification saved for verification at end of solution +!! The dimension is the row number [1..K], K=#rows at level 1 on this rank +!< +!------------------------------------------------------------------------------- +TYPE (LevelElement), ALLOCATABLE :: orig(:) + +!------------------------------------------------------------------------------- +!> +!! The solution +!! The dimension is the global (level 1) row number [1..N] +!< +!------------------------------------------------------------------------------- +TYPE (SolutionElement), ALLOCATABLE :: selement(:) + +!------------------------------------------------------------------------------- +!INTEGER :: rank ! +!! BLACS/PBLAS options +!< +!------------------------------------------------------------------------------- +LOGICAL :: doblasonly +LOGICAL :: doblacscomm + +!------------------------------------------------------------------------------- +!> +!! BLACS/PBLAS process grid information +!< +!------------------------------------------------------------------------------- +TYPE BlacsProcessGrid + INTEGER :: myrow, mycol + INTEGER :: nrows, ncols + INTEGER :: blockszrows, blockszcols + INTEGER, ALLOCATABLE :: map(:,:) ! +!! BLACS/PBLAS information +!< +!------------------------------------------------------------------------------- +TYPE BlacsParameters + INTEGER :: iam + INTEGER :: nprocs + INTEGER :: maincontext + INTEGER :: levelcontext + TYPE(BlacsProcessGrid) :: pgrid + INTEGER :: nbpp ! +!! Master-to-slave mapping +!< +!------------------------------------------------------------------------------- +TYPE MasterToSlaveMapping + INTEGER :: masterrank + INTEGER :: nslaves + INTEGER, ALLOCATABLE :: slaveranks(:) +END TYPE MasterToSlaveMapping + +!------------------------------------------------------------------------------- +!> +!! Level-specific PBLAS information +!< +!------------------------------------------------------------------------------- +TYPE PBLASLevelParameters + LOGICAL :: ammaster + TYPE(MasterToSlaveMapping) :: msmap + + INTEGER :: mpicomm, mpitag, mpierr +#if defined(MPI_OPT) + INTEGER :: mpistatus(MPI_STATUS_SIZE) +#endif + +END TYPE PBLASLevelParameters + +TYPE(PBLASLevelParameters) :: pblas + +!------------------------------------------------------------------------------- +!> +!! Master-to-slave commands +!< +!------------------------------------------------------------------------------- +INTEGER, PARAMETER :: OP_NONE = 0 +INTEGER, PARAMETER :: OP_DONE = 1 +INTEGER, PARAMETER :: OP_DGEMM = 2 +INTEGER, PARAMETER :: OP_DGEMV = 3 +INTEGER, PARAMETER :: OP_DGETRF = 4 +INTEGER, PARAMETER :: OP_DGETRS = 5 + +!------------------------------------------------------------------------------- +!> +!! Statistics (timing, etc.) +!< +!------------------------------------------------------------------------------- +TYPE TimeCount + DOUBLE PRECISION :: tm + INTEGER :: cnt + DOUBLE PRECISION :: t1, t2 ! +!! A convenience function to be able to change clock routine(s) easily +!< +!------------------------------------------------------------------------------- +SUBROUTINE BClockInit() + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: tempint + + IF ( use_mpiwtime ) THEN + timerfreq = 1.0 + ELSE + CALL SYSTEM_CLOCK(COUNT_RATE=tempint) + timerfreq = tempint + END IF +END SUBROUTINE BClockInit + +!------------------------------------------------------------------------------- +!> +!! A convenience function to be able to change clock routine easily +!< +!------------------------------------------------------------------------------- +SUBROUTINE BSystemClock( ts ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + DOUBLE PRECISION, INTENT(INOUT) :: ts ! +!! Is given integer odd? +!< +!------------------------------------------------------------------------------- +LOGICAL FUNCTION ISODD( num ) + INTEGER, INTENT(IN) :: num ! +!!Determines the global row number of a given local row number at a given level +!< +!------------------------------------------------------------------------------- +FUNCTION LR2GR( locrow, level ) result ( globrow ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!Determines the local row number of "globrow" global row number when globrow +!!participates at a given level; returns zero if this globrow does not operate +!!at the given level +!< +!------------------------------------------------------------------------------- +FUNCTION GR2LR( globrow, level ) result ( locrow ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: globrow ! +!!Determines the rank of the task holding the given global row (at level 1) +!< +!------------------------------------------------------------------------------- +FUNCTION GR2Rank( globrow ) result ( outrank ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: globrow ! +!!Determines the rank of the task holding the given local row (at a given level) +!< +!------------------------------------------------------------------------------- +FUNCTION LR2Rank( locrow, level ) result ( outrank ) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!Compute the matrix multiplications in the forward solve at some/any level +!!The row should be odd at the level, +!!The locrow should obey startlocrow <= locrow <= endlocrow +!< +!------------------------------------------------------------------------------- +#if defined(MPI_OPT) +SUBROUTINE ComputeForwardOddRowHats(locrow, level, startlocrow, endlocrow,bonly) + !----------------------------------------------------------------------------- + ! Formal arguments + !----------------------------------------------------------------------------- + INTEGER, INTENT(IN) :: locrow ! +!!BCYCLIC forward phase; to be called after Initialize +!< +!------------------------------------------------------------------------------- +SUBROUTINE ForwardSolve_bst + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!BCYCLIC forward phase to deal with a new b; to be called after a SetRHS that +!!may have been invoked after a ForwardSolve, before BackwardSolve. +!< +!------------------------------------------------------------------------------- +SUBROUTINE ForwardUpdateb + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!BCYCLIC backward phase; to be called after ForwardSolve +!< +!------------------------------------------------------------------------------- +SUBROUTINE BackwardSolve_bst + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: level ! +!!Verify the RMS error of solution after backward solve +!< +!------------------------------------------------------------------------------- +SUBROUTINE VerifySolution + !----------------------------------------------------------------------------- + ! Local variables + !----------------------------------------------------------------------------- + INTEGER :: i, k, globrow, globrowoff + REAL(dp) :: term, totrmserr + INTEGER :: nbrrank ! @brief Convert Amn* quantities from internal representation. +!> +!> The external representation matches the values in the wout file. External +!> representated quantites are for a single surface only. +!> +!> @param[out] rmnc R Fourier amplitudes with external representation +!> for symmetric parity. +!> @param[out] zmns Z Fourier amplitudes with external representation +!> for symmetric parity. +!> @param[out] lmns Lambda Fourier amplitudes with external +!> representation for symmetric parity. +!> @param[out] rmnc R Fourier amplitudes with external representation +!> for asymmetric parity. +!> @param[out] zmns Z Fourier amplitudes with external representation +!> for asymmetric parity. +!> @param[out] lmns Lambda Fourier amplitudes with external +!> representation for asymmetric parity. +!> @param[inout] rzl_array Fourier amplitudes of R, Z, and lambda with internal +!> representation. +!------------------------------------------------------------------------------- + SUBROUTINE convert_par(rmnc, zmns, lmns, + & rmns, zmnc, lmnc, + & rzl_array) + USE vmec_main + USE vmec_params + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(mnmax), INTENT(OUT) :: + & rmnc, zmns, lmns, rmns, zmnc, lmnc + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), + & INTENT(INOUT) :: rzl_array +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: rmncc, rmnss, rmncs, rmnsc, zmncs, zmnsc, + & zmncc, zmnss, lmncs, lmnsc, lmncc, lmnss + INTEGER :: mn, m, n, n1, bufsize, js + REAL(dp) :: t1, sign0, mul1, tbroadon, tbroadoff + REAL(dp), ALLOCATABLE, DIMENSION(:) :: bcastbuf +C----------------------------------------------- +! +! FOR EDGE (js=ns) ONLY: +! CONVERTS INTERNAL MODE REPRESENTATION TO STANDARD +! FORM FOR OUTPUT (COEFFICIENTS OF COS(mu-nv), SIN(mu-nv) WITHOUT mscale,nscale norms) +! + js = ns +#if defined(MPI_OPT) + bufsize = (ntor+1)*(mpol1+1)*3*ntmax + ALLOCATE(bcastbuf(bufsize)) + mn=0 + DO n1 = 1, 3*ntmax + DO m = 0, mpol1 + DO n = 0, ntor + mn = mn + 1 + bcastbuf(mn) = rzl_array(n,m,js,n1) + END DO + END DO + END DO + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf, bufsize, MPI_REAL8, nranks - 1, + & NS_COMM, MPI_ERR) + IF(vlactive) THEN + CALL MPI_Bcast(bcastbuf, bufsize, MPI_REAL8, 0, + & VAC_COMM, MPI_ERR) + END IF + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff -tbroadon) + + mn=0 + DO n1 = 1, 3*ntmax + DO m = 0, mpol1 + DO n = 0, ntor + mn = mn + 1 + rzl_array(n,m,js,n1) = bcastbuf(mn) + END DO + END DO + END DO + DEALLOCATE(bcastbuf) +#endif + + rmncc = rcc + rmnss = rss + rmnsc = rsc + rmncs = rcs + zmnsc = zsc + ntmax + zmncc = zcc + ntmax + zmncs = zcs + ntmax + zmnss = zss + ntmax + lmnsc = zsc + 2*ntmax + lmncc = zcc + 2*ntmax + lmncs = zcs + 2*ntmax + lmnss = zss + 2*ntmax + +! +! DO M = 0 MODES SEPARATELY (ONLY KEEP N >= 0 HERE: COS(-NV), SIN(-NV)) +! + mn = 0; m = 0 + zmns(1:ntor+1) = 0; lmns(1:ntor+1) = 0 + DO n = 0, ntor + t1 = mscale(m)*nscale(n) + mn = mn + 1 + rmnc(mn) = t1*rzl_array(n,m,js,rmncc) + IF (.not. lthreed) CYCLE + zmns(mn) =-t1*rzl_array(n,m,js,zmncs) + lmns(mn) =-t1*rzl_array(n,m,js,lmncs) + END DO + + lmns(1) = 0 !may have been used for storing iota variation... + + DO m = 1, mpol1 + DO n = -ntor, ntor + n1 = ABS(n) + t1 = mscale(m)*nscale(n1) + mn = mn + 1 + IF (n .eq. 0) THEN + rmnc(mn) = t1*rzl_array(n,m,js,rmncc) + zmns(mn) = t1*rzl_array(n,m,js,zmnsc) + lmns(mn) = t1*rzl_array(n,m,js,lmnsc) + ELSE IF (js .gt. 1) THEN + sign0 = n/n1 + IF (.not.lthreed) sign0 = 0 + rmnc(mn) = p5*t1*(rzl_array(n1,m,js,rmncc) + + & sign0*rzl_array(n1,m,js,rmnss)) + zmns(mn) = p5*t1*(rzl_array(n1,m,js,zmnsc) - + & sign0*rzl_array(n1,m,js,zmncs)) + lmns(mn) = p5*t1*(rzl_array(n1,m,js,lmnsc) - + & sign0*rzl_array(n1,m,js,lmncs)) + ELSE IF (js .eq. 1) THEN + rmnc(mn) = 0 + zmns(mn) = 0 + lmns(mn) = 0 + END IF + END DO + END DO + + IF (mn .ne. mnmax) STOP 'Error in Convert!' + + IF (.not.lasym) THEN + rmns = 0 + zmnc = 0 + lmnc = 0 + RETURN + END IF + + mn = 0; m = 0 + rmns(1:ntor+1) = 0 + DO n = 0, ntor + t1 = mscale(m)*nscale(n) + mn = mn + 1 + zmnc(mn) = t1*rzl_array(n,m,js,zmncc) + lmnc(mn) = t1*rzl_array(n,m,js,lmncc) + IF (.not.lthreed) CYCLE + rmns(mn) =-t1*rzl_array(n,m,js,rmncs) !ers-fixed sign + END DO + + mul1 = 1 + IF (.not.lthreed) mul1 = 0 + DO m = 1, mpol1 + DO n = -ntor, ntor + n1 = ABS(n) + t1 = mscale(m)*nscale(n1) + mn = mn + 1 + IF (n .eq. 0) THEN + rmns(mn) = t1*rzl_array(n,m,js,rmnsc) + zmnc(mn) = t1*rzl_array(n,m,js,zmncc) + lmnc(mn) = t1*rzl_array(n,m,js,lmncc) + ELSE IF (js .gt. 1) THEN + sign0 = n/n1 + rmns(mn) = p5*t1*(mul1*rzl_array(n1,m,js,rmnsc) - + & sign0*rzl_array(n1,m,js,rmncs)) + zmnc(mn) = p5*t1*(mul1*rzl_array(n1,m,js,zmncc) + + & sign0*rzl_array(n1,m,js,zmnss)) + lmnc(mn) = p5*t1*(mul1*rzl_array(n1,m,js,lmncc) + + & sign0*rzl_array(n1,m,js,lmnss)) + ELSE IF (js .eq. 1) THEN + rmns(mn) = 0 + zmnc(mn) = 0 + lmnc(mn) = 0 + END IF + END DO + END DO + + END SUBROUTINE convert_par + +!------------------------------------------------------------------------------- +!> @brief Convert Amn* quantities from internal representation. +!> +!> The external representation matches the values in the wout file. +!> +!> @param[out] rmnc R Fourier amplitudes with external representation +!> for symmetric parity. +!> @param[out] zmns Z Fourier amplitudes with external representation +!> for symmetric parity. +!> @param[out] lmns Lambda Fourier amplitudes with external +!> representation for symmetric parity. +!> @param[out] rmnc R Fourier amplitudes with external representation +!> for asymmetric parity. +!> @param[out] zmns Z Fourier amplitudes with external representation +!> for asymmetric parity. +!> @param[out] lmns Lambda Fourier amplitudes with external +!> representation for asymmetric parity. +!> @param[inout] rzl_array Fourier amplitudes of R, Z, and lambda with internal +!> representation. +!> @param[in] js Radial surface to convert quantities on. +!------------------------------------------------------------------------------- + SUBROUTINE convert(rmnc, zmns, lmns, + & rmns, zmnc, lmnc, + & rzl_array, js) + USE vmec_main + USE vmec_params + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: js + REAL(dp), DIMENSION(mnmax), INTENT(out) :: + & rmnc, zmns, lmns, rmns, zmnc, lmnc + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + & INTENT(in) :: rzl_array +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: rmncc, rmnss, rmncs, rmnsc, zmncs, zmnsc, + & zmncc, zmnss, lmncs, lmnsc, lmncc, lmnss + INTEGER :: mn, m, n, n1 + REAL(dp) :: t1, sign0, mul1 +C----------------------------------------------- +! +! CONVERTS INTERNAL MODE REPRESENTATION TO STANDARD +! FORM FOR OUTPUT (COEFFICIENTS OF COS(mu-nv), SIN(mu-nv) WITHOUT mscale,nscale norms) +! + rmncc = rcc + rmnss = rss + rmnsc = rsc + rmncs = rcs + zmnsc = zsc + ntmax + zmncc = zcc + ntmax + zmncs = zcs + ntmax + zmnss = zss + ntmax + lmnsc = zsc + 2*ntmax + lmncc = zcc + 2*ntmax + lmncs = zcs + 2*ntmax + lmnss = zss + 2*ntmax + +! +! DO M = 0 MODES SEPARATELY (ONLY KEEP N >= 0 HERE: COS(-NV), SIN(-NV)) +! + mn = 0; m = 0 + zmns(1:ntor+1) = 0; lmns(1:ntor+1) = 0 + DO n = 0, ntor + t1 = mscale(m)*nscale(n) + mn = mn + 1 + rmnc(mn) = t1*rzl_array(js,n,m,rmncc) + IF (.not. lthreed) CYCLE + zmns(mn) =-t1*rzl_array(js,n,m,zmncs) + lmns(mn) =-t1*rzl_array(js,n,m,lmncs) + END DO + + IF (lthreed .and. js.eq.1) THEN + mn = 0 + DO n = 0, ntor + t1 = mscale(m)*nscale(n) + mn = mn + 1 + lmns(mn) =-t1*(2*rzl_array(2,n,m,lmncs) + & - rzl_array(3,n,m,lmncs)) + END DO + END IF + + lmns(1) = 0 !may have been used for storing iota variation... + + DO m = 1, mpol1 + DO n = -ntor, ntor + n1 = ABS(n) + t1 = mscale(m)*nscale(n1) + mn = mn + 1 + IF (n .eq. 0) THEN + rmnc(mn) = t1*rzl_array(js,n,m,rmncc) + zmns(mn) = t1*rzl_array(js,n,m,zmnsc) + lmns(mn) = t1*rzl_array(js,n,m,lmnsc) + ELSE IF (js .gt. 1) THEN + sign0 = n/n1 + IF (.not.lthreed) sign0 = 0 + rmnc(mn) = p5*t1*(rzl_array(js,n1,m,rmncc) + + & sign0*rzl_array(js,n1,m,rmnss)) + zmns(mn) = p5*t1*(rzl_array(js,n1,m,zmnsc) - + & sign0*rzl_array(js,n1,m,zmncs)) + lmns(mn) = p5*t1*(rzl_array(js,n1,m,lmnsc) - + & sign0*rzl_array(js,n1,m,lmncs)) + ELSE IF (js .eq. 1) THEN + rmnc(mn) = 0 + zmns(mn) = 0 + lmns(mn) = 0 + END IF + END DO + END DO + + IF (mn .ne. mnmax) STOP 'Error in Convert!' + + IF (.not.lasym) THEN + rmns = 0 + zmnc = 0 + lmnc = 0 + RETURN + END IF + + mn = 0; m = 0 + rmns(1:ntor+1) = 0 + DO n = 0, ntor + t1 = mscale(m)*nscale(n) + mn = mn + 1 + zmnc(mn) = t1*rzl_array(js,n,m,zmncc) + lmnc(mn) = t1*rzl_array(js,n,m,lmncc) + IF (.not.lthreed) CYCLE + rmns(mn) =-t1*rzl_array(js,n,m,rmncs) !ers-fixed sign + END DO + + mul1 = 1 + IF (.not.lthreed) mul1 = 0 + DO m = 1, mpol1 + DO n = -ntor, ntor + n1 = ABS(n) + t1 = mscale(m)*nscale(n1) + mn = mn + 1 + IF (n .eq. 0) THEN + rmns(mn) = t1*rzl_array(js,n,m,rmnsc) + zmnc(mn) = t1*rzl_array(js,n,m,zmncc) + lmnc(mn) = t1*rzl_array(js,n,m,lmncc) + ELSE IF (js .gt. 1) THEN + sign0 = n/n1 + rmns(mn) = p5*t1*(mul1*rzl_array(js,n1,m,rmnsc) - + & sign0*rzl_array(js,n1,m,rmncs)) + zmnc(mn) = p5*t1*(mul1*rzl_array(js,n1,m,zmncc) + + & sign0*rzl_array(js,n1,m,zmnss)) + lmnc(mn) = p5*t1*(mul1*rzl_array(js,n1,m,lmncc) + + & sign0*rzl_array(js,n1,m,lmnss)) + ELSE IF (js .eq. 1) THEN + rmns(mn) = 0 + zmnc(mn) = 0 + lmnc(mn) = 0 + END IF + END DO + END DO + + END SUBROUTINE convert diff --git a/Sources/General/csplinx.f b/Sources/General/csplinx.f new file mode 100644 index 0000000..5d7cccf --- /dev/null +++ b/Sources/General/csplinx.f @@ -0,0 +1,11 @@ + MODULE csplinx + USE stel_kinds + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: nptsx + REAL(rprec), DIMENSION(:), ALLOCATABLE :: rmidx,hmidx, + 1 wmidx,qmidx,tenmidx,ymidx,y2midx +c----------------------------------------------- + END MODULE csplinx diff --git a/Sources/General/directaccess.f90 b/Sources/General/directaccess.f90 new file mode 100644 index 0000000..4cb3148 --- /dev/null +++ b/Sources/General/directaccess.f90 @@ -0,0 +1,283 @@ + MODULE DirectAccess + USE safe_open_mod + USE stel_kinds, ONLY: dp + +! DIRECT ACCESS FILE HANDLING ROUTINES + INTEGER :: rec_length, data_size, block_size, num_rows + INTEGER :: iunit_da=0, blocks_per_row, recs_per_block + INTEGER :: irec_pos, byte_size_rec, byte_size_dp + CHARACTER(LEN=256) :: filename + + CONTAINS + + SUBROUTINE OpenDAFile(datasize, blksize, blocksperrow, & + & filename_in, iunit, iflag) + INTEGER, INTENT(in) :: datasize, blksize, blocksperrow, & + & iflag + INTEGER, INTENT(inout) :: iunit + CHARACTER*(*), INTENT(in) :: filename_in + INTEGER, PARAMETER :: CreateNew=0, OpenExisting=1, Scratch=2 + INTEGER :: ierr + REAL(dp) :: dummy + CHARACTER(LEN=10) :: Status + +!GET EFFECTIVE "byte_size" OF UNFORMATTED dp VARIABLE (machine dependent!) +!ON Compaq, rec length size is in units of 4 byte chunks, so byte_size_rec = 4 +!ON lf95, byte_size_rec = 1 + INQUIRE(iolength=byte_size_rec) dummy + byte_size_dp = KIND(dummy) + + data_size = datasize + rec_length = byte_size_rec*datasize + block_size = byte_size_dp*blksize + blocks_per_row = blocksperrow + filename = filename_in +!skip this distance to next block, if datasize different from blksize + recs_per_block = MAX(1,blksize/datasize) + irec_pos = 0 + +! create disk file for doing direct access i/o. + + IF (iflag .eq. CreateNew) THEN + Status = "replace" + ELSE IF (iflag .eq. OpenExisting) THEN + Status = "old" + ELSE + Status = "scratch" + END IF + + + CALL safe_open(iunit, ierr, filename, Status, 'unformatted', & + & rec_length, 'DIRECT') + + iunit_da = iunit + + IF (ierr .ne. 0) THEN + WRITE (6, '(a7,i4)') 'Status code: ', Status, ' Error stat: ', ierr + STOP 'Error creating Direct Access file!' + END IF + + END SUBROUTINE OpenDAFile + + + SUBROUTINE ChangeDAFileParams(datasize, blksize, & + & blocksperrow, new_filename, nrows) + INTEGER, INTENT(in) :: datasize, blksize, blocksperrow, nrows + INTEGER :: ierr, new_data_size, new_block_size, new_rec_length, & + & new_blocks_per_row, new_recs_per_block, inew_da + INTEGER :: i, j, k, boffset, recloc, nsplit, isplit, new_row_offset + CHARACTER*(*) :: new_filename + REAL(dp), ALLOCATABLE :: DataItem(:) + + +!store new parameters + new_data_size = datasize + new_rec_length = byte_size_rec*datasize + new_block_size = byte_size_dp*blksize + new_blocks_per_row = blocksperrow +!skip this distance to next block, if rec_length different from block_size + new_recs_per_block = MAX(1,blksize/datasize) + inew_da = iunit_da+1 + + IF ((rec_length.eq.new_rec_length) .and. & + & (block_size.eq.new_block_size)) RETURN + + +! create disk file for doing direct access i/o. + ierr = INDEX(filename,'.',back=.true.) + + filename = new_filename + + CALL safe_open(inew_da, ierr, filename, 'replace', 'unformatted', & + & new_rec_length, 'DIRECT') + IF (ierr .ne. 0) STOP 'Error opening existing Direct Access file!' + + ALLOCATE (DataItem(new_data_size), stat=ierr) + IF (ierr .ne. 0) STOP 'Allocation error in ChangeDAFileParams' + +!Load up block by reading a column at a time + IF (irec_pos .eq. 0) THEN + DO i = 1, nrows + DO j = 1, blocks_per_row + boffset = 1 + DO k = 1, recs_per_block + CALL ReadDAItem1(DataItem(boffset), i, j, k) + boffset = boffset + recs_per_block + END DO + !write full block in new da file + recloc = 1 + new_recs_per_block*((j-1) + new_blocks_per_row*(i-1)) + WRITE (inew_da, rec=recloc, iostat=ierr) DataItem + END DO + END DO + + ELSE + num_rows = nrows + +! Data comes out as follows for each COLUMN (m,n,ntype): +! L2,D1,U0 L5,D4,U3 .... L(3*n1+2),D(3*n1+1),U(3*n1) +! L3,D2,U1 L6,D5,U4 L(3*n2+3),D(3*n2+2),U(3*n2+1) +! L4,D3,U2 L7,D6,U5 L(3*n3+4),D(3*n3+3),U(3*n3+2) +! +! Therefore we must split the i=1,nrows loop into 3 + isplit = 0 + DO nsplit = 1, 3 + DO i = nsplit, nrows, 3 + isplit = isplit+1 !sequential index of records in original file + DO j = 1, blocks_per_row +! j=1=>L 2=>D 3=>U block + boffset = 1 + new_row_offset = 2-j+i + IF (new_row_offset.lt.1 .or. new_row_offset.gt.nrows) CYCLE + DO k = 1, recs_per_block +! Read one column (k) at a time + CALL ReadDAItem_SEQ(DataItem(boffset), isplit, j, k) + boffset = boffset + recs_per_block + END DO + !write full block to new da file + recloc = 1 + new_recs_per_block*((j-1) + new_blocks_per_row*(new_row_offset-1)) + WRITE (inew_da, rec=recloc, iostat=ierr) DataItem + END DO + END DO + END DO + + IF (isplit .ne. nrows) STOP 'isplit != nrows' + + END IF + +! Close old scratch file when finished writing out new file + CLOSE (iunit_da, status='DELETE') + + iunit_da = inew_da + data_size = new_data_size + rec_length = new_rec_length + block_size = new_block_size + blocks_per_row = new_blocks_per_row + recs_per_block = new_recs_per_block + irec_pos = 0 + + READ(inew_da, rec=2) DataItem +! WRITE (133, '(1p,4e14.4)') DataItem + + DEALLOCATE (DataItem) + + END SUBROUTINE ChangeDAFileParams + + + SUBROUTINE CloseDAFile + + IF (iunit_da .gt. 0) THEN + CLOSE (iunit_da) + iunit_da = 0 + END IF + + END SUBROUTINE CloseDAFile + + + SUBROUTINE DeleteDAFile (filename) + CHARACTER*(*) :: filename + INTEGER :: ierr, rec_length=1 + + IF (iunit_da .eq. 0) THEN + iunit_da=100 + CALL safe_open(iunit_da, ierr, filename, 'replace', 'unformatted', & + & rec_length, 'DIRECT') + IF (ierr .ne. 0) THEN + PRINT *,'Unable to open existing ScratchFile' + RETURN + END IF + END IF + + CLOSE (iunit_da, status='DELETE') + iunit_da = 0 + + END SUBROUTINE DeleteDAFile + + + SUBROUTINE WriteDAItem_RA(DataItem, BlockRowIndex, ColIndex, IndexInBlock) + REAL(dp), INTENT(in) :: DataItem(data_size) + INTEGER, INTENT(in) :: BlockRowIndex, ColIndex, IndexInBlock + INTEGER :: recloc, ierr + INTEGER :: StartIndex + + IF (ColIndex > blocks_per_row) STOP 'ColIndex > Block_Per_Row in WriteDAItem' + IF (IndexInBlock > recs_per_block) STOP 'IndexInBloc > skip_size in WriteDAItem' + + + StartIndex = IndexInBlock + IF (recs_per_block .eq. 1) StartIndex = 1 + recloc = StartIndex + recs_per_block*((ColIndex-1) + blocks_per_row*(BlockRowIndex-1)) + + WRITE (iunit_da, rec=recloc, iostat=ierr) DataItem + IF (ierr .ne. 0) THEN + WRITE (6,*) 'Ierr = ', ierr, ' in WriteDAItem' + STOP + END IF + + END SUBROUTINE WriteDAItem_RA + + + SUBROUTINE WriteDAItem_SEQ(DataItem) + REAL(dp), INTENT(in) :: DataItem(data_size) + INTEGER :: ierr + + !Perform "sequential" write of direct access elements (buffering helps) + + irec_pos = irec_pos+1 + + WRITE (iunit_da, rec=irec_pos, iostat=ierr) DataItem + IF (ierr .ne. 0) THEN + WRITE (6,*) 'Ierr = ', ierr, ' in WriteDAItem' + STOP + END IF + + END SUBROUTINE WriteDAItem_SEQ + + + SUBROUTINE ReadDAItem1(DataItem, BlockRowIndex, ColIndex, StartIndex) + REAL(dp), INTENT(out) :: DataItem(data_size) + INTEGER, INTENT(in) :: BlockRowIndex, ColIndex, StartIndex + INTEGER :: recloc, ierr +! INTEGER :: StartIndex=1 + + recloc = StartIndex + recs_per_block*((ColIndex-1) + blocks_per_row*(BlockRowIndex-1)) + READ (iunit_da, rec=recloc, iostat=ierr) DataItem + IF (ierr .ne. 0) THEN + WRITE (6,*) 'Ierr = ', ierr, ' in ReadDAItem' + STOP + END IF + + END SUBROUTINE ReadDAItem1 + + + SUBROUTINE ReadDAItem2(DataItem, BlockRowIndex, ColIndex) + REAL(dp), INTENT(out) :: DataItem(data_size) + INTEGER, INTENT(in) :: BlockRowIndex, ColIndex + INTEGER :: recloc, ierr +! INTEGER :: StartIndex=1 + + recloc = 1 + recs_per_block*((ColIndex-1) + blocks_per_row*(BlockRowIndex-1)) + READ (iunit_da, rec=recloc, iostat=ierr) DataItem + IF (ierr .ne. 0) THEN + WRITE (6,*) 'Ierr = ', ierr, ' in ReadDAItem' + STOP + END IF + + END SUBROUTINE ReadDAItem2 + + + SUBROUTINE ReadDAItem_SEQ(DataItem, BlockRowIndex, BlockTypeIndex, ColIndex) + REAL(dp), INTENT(out) :: DataItem(data_size) + INTEGER, INTENT(in) :: BlockRowIndex, ColIndex, BlockTypeIndex + INTEGER :: recloc, ierr + + recloc = BlockTypeIndex + blocks_per_row*(BlockRowIndex-1+num_rows*(ColIndex-1)) + READ (iunit_da, rec=recloc, iostat=ierr) DataItem + IF (ierr .ne. 0) THEN + WRITE (6,*) 'Ierr = ', ierr, ' in ReadDAItem' + STOP + END IF + + END SUBROUTINE ReadDAItem_SEQ + + + END MODULE DirectAccess diff --git a/Sources/General/fbal.f b/Sources/General/fbal.f new file mode 100644 index 0000000..9f831f5 --- /dev/null +++ b/Sources/General/fbal.f @@ -0,0 +1,300 @@ + MODULE fbal + USE stel_kinds, ONLY: dp + REAL(dp), DIMENSION(:), ALLOCATABLE :: rzu_fac, rru_fac, + 1 frcc_fac, fzsc_fac + + CONTAINS + + SUBROUTINE calc_fbal_par(bsubu, bsubv) + USE vmec_main, ONLY: buco, bvco, equif, iequi, + 1 jcurv, jcuru, chipf, vp, pres, + 2 phipf, vpphi, presgrad, ohs + USE vmec_params, ONLY: signgs + USE vmec_dim, ONLY: ns, nrzt, nznt, ns1 + USE realspace, ONLY: pwint, phip + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ntheta3 + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- + REAL(dp), INTENT(in) :: bsubu(nznt,ns), + 1 bsubv(nznt,ns) +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, lk + INTEGER :: nsmin, nsmax +!----------------------------------------------- + + nsmin=t1lglob; nsmax=t1rglob + DO js = nsmin, nsmax + buco(js) = SUM(bsubu(:,js)*pwint(:,js)) + bvco(js) = SUM(bsubv(:,js)*pwint(:,js)) + END DO + + CALL Gather1XArray(bvco) + CALL Gather1XArray(buco) + +! FROM AMPERE'S LAW, JcurX are angle averages of jac*JsupX, so +! JcurX = (dV/ds)/twopi**2 where <...> is flux surface average + !nsmin=MAX(2,t1lglob); nsmax=MIN(t1rglob,ns-1) + nsmin=MAX(2,tlglob); nsmax=MIN(trglob,ns-1) + DO js = nsmin, nsmax + jcurv(js) = (signgs*ohs)*(buco(js+1) - buco(js)) + jcuru(js) =-(signgs*ohs)*(bvco(js+1) - bvco(js)) + vpphi(js) = (vp(js+1) + vp(js))/2 + presgrad(js) = (pres(js+1) - pres(js))*ohs + equif(js) = (-phipf(js)*jcuru(js) + chipf(js)*jcurv(js)) + 1 /vpphi(js) + presgrad(js) + END DO + equif(1) = 0 + equif(ns) = 0 + + !SKS-RANGE: All LHS's computed correctly in [t1lglob, trglob] + + END SUBROUTINE calc_fbal_par + + SUBROUTINE calc_fbal(bsubu, bsubv) + USE vmec_main, ONLY: buco, bvco, equif, + 1 jcurv, jcuru, chipf, vp, pres, + 2 phipf, vpphi, presgrad, ohs +#ifdef _ANIMEC + 3 ,pmap, pd, phot, tpotb, zero +#endif + USE vmec_params, ONLY: signgs + USE vmec_dim, ONLY: ns, nrzt, nznt, ns1 + USE realspace, ONLY: wint, phip +#ifdef _ANIMEC + 1 ,pperp, ppar, onembc, sigma_an, + 2 pp1, pp2, pp3 + USE vforces, gsqrt => azmn_o +#endif + + IMPLICIT NONE +!----------------------------------------------- + REAL(dp), INTENT(in) :: bsubu(1:nrzt), bsubv(1:nrzt) +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, lk + INTEGER :: nsmin, nsmax +#ifdef _ANIMEC + REAL(dp) :: t4, t5 +#endif +!----------------------------------------------- + DO js = 2, ns + buco(js) = SUM(bsubu(js:nrzt:ns)*wint(js:nrzt:ns)) + bvco(js) = SUM(bsubv(js:nrzt:ns)*wint(js:nrzt:ns)) + END DO + +! FROM AMPERE'S LAW, JcurX are angle averages of jac*JsupX, so +! JcurX = (dV/ds)/twopi**2 where <...> is flux surface average + DO js = 2, ns1 + jcurv(js) = (signgs*ohs)*(buco(js+1) - buco(js)) + jcuru(js) =-(signgs*ohs)*(bvco(js+1) - bvco(js)) +!FOR RFP vpphi(js) = (vp(js+1)/phip(js+1) + vp(js)/phip(js))/2 + vpphi(js) = (vp(js+1) + vp(js))/2 + presgrad(js) = (pres(js+1) - pres(js))*ohs + equif(js) = (-phipf(js)*jcuru(js) + chipf(js)*jcurv(js)) + 1 /vpphi(js) + presgrad(js) + END DO + equif(1) = 0 + equif(ns) = 0 + + END SUBROUTINE calc_fbal + +#ifdef _ANIMEC + SUBROUTINE bimax_ppargrad(pp1, pp2, pp3, ppar, onembc, pres, phot, + 1 tpotb) + USE vmec_main, ONLY: zero + USE vmec_dim, ONLY: ns, nrzt, nznt, ns1 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), INTENT(in) :: pp3(nrzt), ppar(nrzt), phot(ns), + 1 onembc(nrzt) ,pres(ns), tpotb(ns) + REAL(dp), INTENT(out):: pp1(nrzt), pp2(nrzt) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: js, lk, l + REAL(dp), ALLOCATABLE :: tmp0(:), tmp2(:) + REAL(dp) :: eps +C----------------------------------------------- +!********0*********0*********0*********0*********0*********0*********0** +! Model with Anisotropic Pressure from Bi-Maxwellian Distribution. * +! EVALUATION OF AMPLITUDES OF partial p_parallel/partial s AT FIXED B. +! Compute hot particle parallel pressure gradient at fixed B times PP3 +! PP3 can be sqrt(g), sqrt(g)/V' or unity +!*********0*********0*********0*********0*********0*********0*********0* + eps = EPSILON(eps) + ALLOCATE (tmp0(nrzt), tmp2(nrzt)) + + pp1(1:nrzt:ns) = 0; pp2(1:nrzt:ns) = 0 + DO js = 2, ns + tmp0(js:nrzt:ns) = pp3(js:nrzt:ns)*(ppar(js:nrzt:ns)-pres(js)) + tmp2(js:nrzt:ns) = tmp0(js:nrzt:ns)/(pres(js)*phot(js)+eps) + END DO + + DO l = 1,nrzt-1 + pp2(l) = 0.5_dp*(tmp2(l)+tmp2(l+1)) + END DO + DO l = 1, nrzt + tmp2(l) = pp3(l)*(1-onembc(l)) + END DO + + DO js = 2,ns + DO lk = 1,nznt + l = js +(lk-1)*ns + IF (onembc(l) <= zero) THEN + pp1(l)= tmp0(l)/ + & (1 - tpotb(js) * onembc(l)+eps) + ELSE + pp1(l)=(2*tpotb(js )*tmp0(l)*onembc(l) + & + pres(js ) * phot(js ) * tmp2(l)* + & ( 1 - 5*(tpotb(js )*onembc(l))**1.5_dp)) + & / (1 - (tpotb(js )*onembc(l))**2 + eps) + END IF + END DO + END DO + + pp1 = pp1 * onembc + DO l=1, nrzt-1 + pp1(l) = 0.5_dp*(pp1(l)+pp1(l+1)) + END DO + + DEALLOCATE (tmp0, tmp2) + + END SUBROUTINE bimax_ppargrad + + SUBROUTINE mirror_crit(taumir, bsq) + USE stel_kinds, ONLY: rprec, dp + USE realspace, ONLY: sigma_an, pperp, ppar, onembc +! USE vforces, ONLY: bsq => bzmn_o + USE vmec_main, ONLY: tpotb, pppr, pmap, pres, papr, vp, wb, + & wp, wpar, wper, ns, nznt, nrzt, + & zero, one, nthreed +! +! WAC (11/30/07): See description of anisotropic pressure below +! + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nrzt), INTENT(out) :: taumir + REAL(dp), DIMENSION(nrzt), INTENT(inout) :: bsq +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER :: js , lk , l + REAL(dp) :: whpar, whper, bhotmx, taumin, ppprht, parpht, + & sigmin, bhotc, betath, betaht, betato, betapa, + & betape, betadi, betaew, es, betprc, betprx +C----------------------------------------------- +! CALCULATION OF MIRROR STABILITY CRITERION +!********0*********0*********0*********0*********0*********0*********0** +! * +! Anisotropic Pressure Model * +! specific to case where: * +! a Bi-Maxwellian distribution is considered (by J. Graves) * +! p_parallel(s,B) = pth(1 + phot(s)*H(s,B)) * +! H(s,B)=(B/B_crit)/[1-(T_perp/T_par)(1-B/B_crit)] for B>B_crit * +! For BB_crit){1-2[(T_perp/T_par)(1-B/B_crit)]^(5/2) / * +! [1+(T_perp/T_par)(1-B/B_crit)]} * +! * +!********0*********0*********0*********0*********0*********0*********0** +! +!********0*********0*********0*********0*********0*********0*********0** +! 1. Change BSQ from total pressure to magnetic pressure * +!********0*********0*********0*********0*********0*********0*********0** +c + bsq = bsq - pperp +! +!********0*********0*********0*********0*********0*********0*********0** +! 2. Compute Tau-minimum, Sigma-minimum, Peak Hot Particle Beta. * +!********0*********0*********0*********0*********0*********0*********0** +c + whpar = wpar - wp + whper = wper - wp + bhotmx = -HUGE(bhotmx) + taumin = HUGE(taumin) + sigmin = HUGE(sigmin) + + DO 57 js = 2,ns + DO 55 lk = 1,nznt + l = (lk-1) * ns + js + taumir(l) = one + (pperp(l) - pres(js)) / bsq(l)* + & (one - tpotb(js)) / (one - tpotb(js) * onembc(l)) +! taut = taumir(l) + pperp(l)/bsq(l) *0.25*tpotb(js) + if(onembc(l) .gt. zero) + & taumir(l) = taumir(l) + & + (pperp(l) - pres(js)) / bsq(l) * 0.25_dp*tpotb(js) + & * (one-onembc(l))*sqrt(tpotb(js)*onembc(l)) + & / (one + tpotb(js) * onembc(l)) + & * (15 - 5*tpotb(js) * onembc(l) + & - 7*(tpotb(js)*onembc(l))**2 + & - 3*(tpotb(js)*onembc(l))**3 ) + & / ((one + tpotb(js)*onembc(l))**2 + & - (tpotb(js)*onembc(l))**1.5_dp * (5 + & - (tpotb(js)*onembc(l))**2)) +55 end do +57 end do + do 62 js = 2,ns + do 60 lk = 1,nznt + l = (lk-1) * ns + js + taumin = MIN(taumir(l),taumin) + sigmin = MIN(sigma_an(l),sigmin) + bhotc = (2*pperp(l)+ppar(l)-3*pres(js))/bsq(l) + bhotmx = MAX(bhotc,bhotmx) + 60 end do + 62 end do + betprx = HUGE(betprx) + do 64 js=2,ns + betprc = 0.76786580_dp - 0.29708540_dp * tpotb(js) + & + 0.054249860_dp * tpotb(js)**2 + & - 0.0054254849_dp * tpotb(js)**3 + & + 0.00030947525_dp * tpotb(js)**4 + & - 9.7144781e-6_dp * tpotb(js)**5 + & + 1.3844199e-7_dp * tpotb(js)**6 + & - 1.4328673e-11_dp * (one + tpotb(js))*tpotb(js)**7 + betprx=min(betprx,betprc) + 64 end do + bhotmx = bhotmx/3 + write (nthreed,101) taumin, sigmin, bhotmx + 101 format(" taumin=",1pe15.6," sigmin=",1pe15.6, + & " peak hot beta=",1pe15.6) + betath = wp/wb + betaht = (2*whper+whpar)/(3*wb) + betato = (2*wper+wpar)/(3*wb) + betapa = whpar/wb + betape = whper/wb + betadi = betath + betape + betaew = betath + 0.5*(betapa+betape) + write (nthreed,102) betath,betaht,betato + 102 format(" thermal beta =",1pe13.4," beta-hot =",1pe13.4, + & " total beta =",1pe13.4) + write (nthreed,103) betapa,betape,betaew-betath + 103 format(' hot parallel beta =',1pe13.4, + & ' hot perpendicular beta =',1pe13.4,' beta-hot(EW) =',1pe13.4) + write (nthreed,104) betadi,betaew,betprx + 104 format(' diamagnetic beta =',1pe13.4,' beta(equal weighting) =' + & , 1pe13.4,' maximum hot perp. beta_c =',1pe10.3) + + IF (ABS(betaht) .GT. 1.E-12_dp) THEN + write (nthreed,105) + 105 format(/,' js',8x,'s',9x,'th. press',3x,'par. pres',2x, + & 'perp. pres') + DO 79 js = 2,ns + es = REAL(js - 1.5,dp) / (ns-1) + ppprht = pppr(js) - pres(js) + parpht = papr(js) - pres(js) + WRITE (nthreed,106) js, es, pres(js), parpht, ppprht + 79 END DO + END IF + 106 format (i3,1p,1e15.6,1p,3e12.3) + + END SUBROUTINE mirror_crit +#endif + + END MODULE fbal diff --git a/Sources/General/forces.f b/Sources/General/forces.f new file mode 100644 index 0000000..765cd13 --- /dev/null +++ b/Sources/General/forces.f @@ -0,0 +1,404 @@ + SUBROUTINE forces_par + USE vmec_main, p5 => cp5 + USE realspace + USE vforces, ru12 => pazmn_e, zu12 => parmn_e, + & pazmn_e => pazmn_e, parmn_e => parmn_e, + & lv_e => pcrmn_e, lu_e => pczmn_e, lu_o => pczmn_o, + & pcrmn_e => pcrmn_e, pczmn_e => pczmn_e, + & pczmn_o => pczmn_o + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: p25 = p5*p5, dshalfds=p25 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l, ndim + INTEGER :: i, j, k, nsmin, nsmax + REAL(dp), DIMENSION(:,:), POINTER :: + & bsqr, gvvs, guvs, guus + REAL(dp), ALLOCATABLE, DIMENSION(:) :: bcastbuf +C----------------------------------------------- + IF (.NOT.lactive .AND. .NOT.lfreeb) RETURN + + CALL second0 (tforon) + + ndim = 1+nrzt + + nsmin=tlglob; nsmax=t1rglob + +! POINTER ALIASES + bsqr => pextra1(:,:,1); gvvs => pextra2(:,:,1) + guvs => pextra3(:,:,1); guus => pextra4(:,:,1) + + lu_e(:,1) = 0; lv_e(:,1) = 0 + pguu(:,1) = 0; pguv(:,1) = 0; pgvv(:,1) = 0 + + DO l = nsmin, nsmax + guus(:,l) = pguu(:,l)*pshalf(:,l) + guvs(:,l) = pguv(:,l)*pshalf(:,l) + gvvs(:,l) = pgvv(:,l)* pshalf(:,l) + + parmn_e(:,l) = ohs*zu12(:,l)*lu_e(:,l) + pazmn_e(:,l) =-ohs*ru12(:,l)*lu_e(:,l) + pbrmn_e(:,l) = pbrmn_e(:,l)*lu_e(:,l) + pbzmn_e(:,l) =-pbzmn_e(:,l)*lu_e(:,l) + bsqr(:,l) = dshalfds*lu_e(:,l)/pshalf(:,l) + + parmn_o(:,l) = parmn_e(:,l)*pshalf(:,l) + pazmn_o(:,l) = pazmn_e(:,l)*pshalf(:,l) + pbrmn_o(:,l) = pbrmn_e(:,l)*pshalf(:,l) + pbzmn_o(:,l) = pbzmn_e(:,l)*pshalf(:,l) + END DO + +! +! CONSTRUCT CYLINDRICAL FORCE KERNELS +! NOTE: presg(ns+1) == 0, AND WILL BE "FILLED IN" AT EDGE +! FOR FREE-BOUNDARY BY RBSQ +! +!DIR$ IVDEP + nsmin=tlglob; nsmax=MIN(ns-1,trglob) + DO l = nsmin, nsmax + pguu(:,l) = p5*(pguu(:,l) + pguu(:,l+1)) + pgvv(:,l) = p5*(pgvv(:,l) + pgvv(:,l+1)) + bsqr(:,l) = bsqr(:,l) + bsqr(:,l+1) + guus(:,l) = p5*(guus(:,l) + guus(:,l+1)) + gvvs(:,l) = p5*(gvvs(:,l) + gvvs(:,l+1)) + END DO + + IF (trglob .ge. ns) THEN + pguu(:,ns) = p5*pguu(:,ns) + pgvv(:,ns) = p5*pgvv(:,ns) + guus(:,ns) = p5*guus(:,ns) + gvvs(:,ns) = p5*gvvs(:,ns) + END IF + +!DIR$ IVDEP + nsmin=tlglob; nsmax=MIN(ns-1,trglob) + DO l = nsmin, nsmax + parmn_e(:,l) = parmn_e(:,l+1) - parmn_e(:,l) + & + p5*(lv_e(:,l) + lv_e(:,l+1)) + pazmn_e(:,l) = pazmn_e(:,l+1) - pazmn_e(:,l) + pbrmn_e(:,l) = p5*(pbrmn_e(:,l) + pbrmn_e(:,l+1)) + pbzmn_e(:,l) = p5*(pbzmn_e(:,l) + pbzmn_e(:,l+1)) + END DO + + parmn_e(:,ns) = - parmn_e(:,ns) + p5*lv_e(:,ns) + pazmn_e(:,ns) = - pazmn_e(:,ns) + pbrmn_e(:,ns) = p5*pbrmn_e(:,ns) + pbzmn_e(:,ns) = p5*pbzmn_e(:,ns) + + nsmin=tlglob; nsmax=t1rglob + DO l = nsmin, nsmax + parmn_e(:,l) = parmn_e(:,l) + & - (gvvs(:,l)*pr1(:,l,1) + pgvv(:,l)*pr1(:,l,0)) + pbrmn_e(:,l) = pbrmn_e(:,l) + bsqr(:,l)*pz1(:,l,1) + & - (guus(:,l)*pru(:,l,1) + pguu(:,l)*pru(:,l,0)) + pbzmn_e(:,l) = pbzmn_e(:,l) - (bsqr(:,l)*pr1(:,l,1) + & + guus(:,l)*pzu(:,l,1) + pguu(:,l)*pzu(:,l,0)) + lv_e(:,l) = lv_e(:,l)*pshalf(:,l) + lu_o(:,l) = dshalfds*lu_e(:,l) + END DO + + nsmin=tlglob; nsmax=MIN(ns-1,trglob) +!DIR$ IVDEP + DO l = nsmin, nsmax + parmn_o(:,l) = parmn_o(:,l+1) - parmn_o(:,l) + & - pzu(:,l,0)*bsqr(:,l) + & + p5*(lv_e(:,l)+lv_e(:,l+1)) + pazmn_o(:,l) = pazmn_o(:,l+1) - pazmn_o(:,l) + & + pru(:,l,0)*bsqr(:,l) + pbrmn_o(:,l) = p5*(pbrmn_o(:,l) + pbrmn_o(:,l+1)) + pbzmn_o(:,l) = p5*(pbzmn_o(:,l) + pbzmn_o(:,l+1)) + lu_o(:,l) = lu_o(:,l) + lu_o(:,l+1) + END DO + + parmn_o(:,ns) = - parmn_o(:,ns) - pzu(:,ns,0)*bsqr(:,ns) + & + p5*lv_e(:,ns) + pazmn_o(:,ns) = - pazmn_o(:,ns) + pru(:,ns,0)*bsqr(:,ns) + pbrmn_o(:,ns) = p5*pbrmn_o(:,ns) + pbzmn_o(:,ns) = p5*pbzmn_o(:,ns) + lu_o(:,ns) = lu_o(:,ns) + + nsmin=tlglob; nsmax=trglob + DO l = nsmin, nsmax + pguu(:,l) = pguu(:,l) * psqrts(:,l)**2 + bsqr(:,l) = pgvv(:,l) * psqrts(:,l)**2 + END DO + + DO l = nsmin, nsmax + parmn_o(:,l) = parmn_o(:,l) - (pzu(:,l,1)*lu_o(:,l) + & + bsqr(:,l)*pr1(:,l,1) + gvvs(:,l)*pr1(:,l,0)) + pazmn_o(:,l) = pazmn_o(:,l) + pru(:,l,1)*lu_o(:,l) + pbrmn_o(:,l) = pbrmn_o(:,l) + pz1(:,l,1)*lu_o(:,l) + & -(pguu(:,l)*pru(:,l,1) + guus(:,l)*pru(:,l,0)) + pbzmn_o(:,l) = pbzmn_o(:,l) - (pr1(:,l,1)*lu_o(:,l) + & + pguu(:,l)*pzu(:,l,1) + guus(:,l)*pzu(:,l,0)) + END DO + + IF (lthreed) THEN +!DIR$ IVDEP + nsmin=tlglob; nsmax=MIN(ns-1,trglob) + DO l = nsmin, nsmax + pguv(:,l) = p5*(pguv(:,l) + pguv(:,l+1)) + guvs(:,l) = p5*(guvs(:,l) + guvs(:,l+1)) + END DO + pguv(:,ns) = p5*pguv(:,ns) + guvs(:,ns) = p5*guvs(:,ns) + + nsmin=tlglob; nsmax=trglob + DO l = nsmin, nsmax + pbrmn_e(:,l) = pbrmn_e(:,l) + & - (pguv(:,l)*prv(:,l,0) + guvs(:,l)*prv(:,l,1)) + pbzmn_e(:,l) = pbzmn_e(:,l) + & - (pguv(:,l)*pzv(:,l,0) + guvs(:,l)*pzv(:,l,1)) + pcrmn_e(:,l) = pguv(:,l)*pru(:,l,0) + pgvv(:,l)*prv(:,l,0) + & + gvvs(:,l)*prv(:,l,1) + guvs(:,l)*pru(:,l,1) + pczmn_e(:,l) = pguv(:,l)*pzu(:,l,0) + pgvv(:,l)*pzv(:,l,0) + & + gvvs(:,l)*pzv(:,l,1) + guvs(:,l)*pzu(:,l,1) + pguv(:,l) = pguv(:,l)*psqrts(:,l)*psqrts(:,l) + pbrmn_o(:,l) = pbrmn_o(:,l) + & - (guvs(:,l)*prv(:,l,0) + pguv(:,l)*prv(:,l,1)) + pbzmn_o(:,l) = pbzmn_o(:,l) + & - (guvs(:,l)*pzv(:,l,0) + pguv(:,l)*pzv(:,l,1)) + pcrmn_o(:,l) = guvs(:,l)*pru(:,l,0) + gvvs(:,l)*prv(:,l,0) + & + bsqr(:,l)*prv(:,l,1) + pguv(:,l)*pru(:,l,1) + pczmn_o(:,l) = guvs(:,l)*pzu(:,l,0) + gvvs(:,l)*pzv(:,l,0) + & + bsqr(:,l)*pzv(:,l,1) + pguv(:,l)*pzu(:,l,1) + END DO + ENDIF + +! +! ASSIGN EDGE FORCES (JS = NS) FOR FREE BOUNDARY CALCULATION +! + IF (ivac .GE. 1) THEN + + DO k = 1, ntheta3 + DO j = 1, nzeta + l = (k-1)*nzeta + j + parmn_e(l,ns) = parmn_e(l,ns) + pzu0(l,ns)*rbsq(l) + parmn_o(l,ns) = parmn_o(l,ns) + pzu0(l,ns)*rbsq(l) + pazmn_e(l,ns) = pazmn_e(l,ns) - pru0(l,ns)*rbsq(l) + pazmn_o(l,ns) = pazmn_o(l,ns) - pru0(l,ns)*rbsq(l) + END DO + END DO + + ENDIF + + 100 CONTINUE + +! +! COMPUTE CONSTRAINT FORCE KERNELS +! +#ifndef _HBANGLE + DO l = nsmin, nsmax + prcon(:,l,0) = (prcon(:,l,0)-prcon0(:,l))*pgcon(:,l) + pzcon(:,l,0) = (pzcon(:,l,0)-pzcon0(:,l))*pgcon(:,l) + pbrmn_e(:,l) = pbrmn_e(:,l) + prcon(:,l,0) + pbzmn_e(:,l) = pbzmn_e(:,l) + pzcon(:,l,0) + pbrmn_o(:,l) = pbrmn_o(:,l)+ prcon(:,l,0)*psqrts(:,l) + pbzmn_o(:,l) = pbzmn_o(:,l)+ pzcon(:,l,0)*psqrts(:,l) + prcon(:,l,0) = pru0(:,l) * pgcon(:,l) + pzcon(:,l,0) = pzu0(:,l) * pgcon(:,l) + prcon(:,l,1) = prcon(:,l,0) * psqrts(:,l) + pzcon(:,l,1) = pzcon(:,l,0) * psqrts(:,l) + END DO +#endif + CALL second0 (tforoff) + timer(tfor) = timer(tfor) + (tforoff - tforon) + forces_time = timer(tfor) + + END SUBROUTINE forces_par + + SUBROUTINE forces + USE vmec_main, p5 => cp5 + USE realspace + USE vforces, ru12 => azmn_e, zu12 => armn_e, + & azmn_e => azmn_e, armn_e => armn_e, + & lv_e => crmn_e, lu_e => czmn_e, lu_o => czmn_o, + & crmn_e => crmn_e, czmn_e => czmn_e, czmn_o => czmn_o + USE timer_sub + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: p25 = p5*p5, dshalfds=p25 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l, ndim + REAL(dp), DIMENSION(:), POINTER :: + & bsqr, gvvs, guvs, guus + +C----------------------------------------------- + ndim = 1+nrzt + CALL second0 (tforon) + +! POINTER ALIASES + bsqr => extra1(:,1); gvvs => extra2(:,1) + guvs => extra3(:,1); guus => extra4(:,1) + +! +! ON ENTRY, ARMN=ZU,BRMN=ZS,AZMN=RU,BZMN=RS,LU=R*BSQ,LV = BSQ*SQRT(G)/R12 +! HERE, XS (X=Z,R) DO NOT INCLUDE DERIVATIVE OF EXPLICIT SQRT(S) +! BSQ = |B|**2/2 + p +! GIJ = (BsupI * BsupJ) * SQRT(G) (I,J = U,V) +! IT IS ESSENTIAL THAT LU,LV AT j=1 ARE ZERO INITIALLY +! +! SOME OF THE BIGGER LOOPS WERE SPLIT TO FACILITATE CACHE +! HITS, PIPELINING ON RISCS +! +! FOR OPTIMIZATION ON CRAY, MUST USE COMPILER DIRECTIVES TO +! GET VECTORIZATION OF LOOPS INVOLVING POINTERS! +! +! +! ORIGIN OF VARIOUS TERMS +! +! LU : VARIATION OF DOMINANT RADIAL-DERIVATIVE TERMS IN JACOBIAN +! +! LV : VARIATION OF R-TERM IN JACOBIAN +! +! GVV: VARIATION OF R**2-TERM AND Rv**2,Zv**2 IN gvv +! +! GUU, GUV: VARIATION OF Ru, Rv, Zu, Zv IN guu, guv +! + + lu_e(1:ndim:ns) = 0; lv_e(1:ndim:ns) = 0 + guu(1:ndim:ns) = 0; guv(1:ndim:ns) = 0; gvv(1:ndim:ns) = 0 + guus = guu*shalf; guvs = guv*shalf; gvvs = gvv*shalf + + armn_e = ohs*zu12 * lu_e + azmn_e =-ohs*ru12 * lu_e + brmn_e = brmn_e * lu_e + bzmn_e =-bzmn_e * lu_e + bsqr = dshalfds*lu_e/shalf + + armn_o(1:ndim) = armn_e(1:ndim) *shalf + azmn_o(1:ndim) = azmn_e(1:ndim) *shalf + brmn_o(1:ndim) = brmn_e(1:ndim) *shalf + bzmn_o(1:ndim) = bzmn_e(1:ndim) *shalf + +! +! CONSTRUCT CYLINDRICAL FORCE KERNELS +! NOTE: presg(ns+1) == 0, AND WILL BE "FILLED IN" AT EDGE +! FOR FREE-BOUNDARY BY RBSQ +! +!DIR$ IVDEP + DO l = 1, nrzt + guu(l) = p5*(guu(l) + guu(l+1)) + gvv(l) = p5*(gvv(l) + gvv(l+1)) + bsqr(l) = bsqr(l) + bsqr(l+1) + guus(l) = p5*(guus(l) + guus(l+1)) + gvvs(l) = p5*(gvvs(l) + gvvs(l+1)) + END DO + +!DIR$ IVDEP + DO l = 1, nrzt + armn_e(l) = armn_e(l+1) - armn_e(l) + p5*(lv_e(l) + lv_e(l+1)) + azmn_e(l) = azmn_e(l+1) - azmn_e(l) + brmn_e(l) = p5*(brmn_e(l) + brmn_e(l+1)) + bzmn_e(l) = p5*(bzmn_e(l) + bzmn_e(l+1)) + END DO + + armn_e(:nrzt) = armn_e(:nrzt) - (gvvs(:nrzt)*r1(:nrzt,1) + & + gvv(:nrzt)*r1(:nrzt,0)) + brmn_e(:nrzt) = brmn_e(:nrzt) + bsqr(:nrzt)*z1(:nrzt,1) + & -(guus(:nrzt)*ru(:nrzt,1) + guu(:nrzt)*ru(:nrzt,0)) + bzmn_e(:nrzt) = bzmn_e(:nrzt) - (bsqr(:nrzt)*r1(:nrzt,1) + & + guus(:nrzt)*zu(:nrzt,1) + guu(:nrzt)*zu(:nrzt,0)) + lv_e(1:ndim) = lv_e(1:ndim)*shalf(1:ndim) + lu_o(1:ndim) = dshalfds*lu_e(1:ndim) + +!DIR$ IVDEP + DO l = 1, nrzt + armn_o(l) = armn_o(l+1) - armn_o(l) - zu(l,0)*bsqr(l) + & + p5*(lv_e(l) + lv_e(l+1)) + azmn_o(l) = azmn_o(l+1) - azmn_o(l) + ru(l,0)*bsqr(l) + brmn_o(l) = p5*(brmn_o(l) + brmn_o(l+1)) + bzmn_o(l) = p5*(bzmn_o(l) + bzmn_o(l+1)) + lu_o(l) = lu_o(l) + lu_o(l+1) + END DO + + guu(1:nrzt) = guu(1:nrzt) * sqrts(1:nrzt)**2 + bsqr(1:nrzt) = gvv(1:nrzt) * sqrts(1:nrzt)**2 + + armn_o(:nrzt) = armn_o(:nrzt) - (zu(:nrzt,1)*lu_o(:nrzt) + & + bsqr(:nrzt)*r1(:nrzt,1) + gvvs(:nrzt)*r1(:nrzt,0)) + azmn_o(:nrzt) = azmn_o(:nrzt) + ru(:nrzt,1)*lu_o(:nrzt) + brmn_o(:nrzt) = brmn_o(:nrzt) + z1(:nrzt,1)*lu_o(:nrzt) + & -(guu(:nrzt)*ru(:nrzt,1) + guus(:nrzt)*ru(:nrzt,0)) + bzmn_o(:nrzt) = bzmn_o(:nrzt) - (r1(:nrzt,1)*lu_o(:nrzt) + & + guu(:nrzt)*zu(:nrzt,1) + guus(:nrzt)*zu(:nrzt,0)) + + IF (lthreed) THEN +!DIR$ IVDEP + DO l = 1, nrzt + guv(l) = p5*(guv(l) + guv(l+1)) + guvs(l) = p5*(guvs(l) + guvs(l+1)) + END DO + + brmn_e(:nrzt) = brmn_e(:nrzt) + & - (guv(:nrzt)*rv(:nrzt,0) + guvs(:nrzt)*rv(:nrzt,1)) + bzmn_e(:nrzt) = bzmn_e(:nrzt) + & - (guv(:nrzt)*zv(:nrzt,0) + guvs(:nrzt)*zv(:nrzt,1)) + crmn_e(:nrzt) = guv(:nrzt) *ru(:nrzt,0) + & + gvv(:nrzt) *rv(:nrzt,0) + & + gvvs(:nrzt)*rv(:nrzt,1) + guvs(:nrzt)*ru(:nrzt,1) + czmn_e(:nrzt) = guv(:nrzt) *zu(:nrzt,0) + & + gvv(:nrzt) *zv(:nrzt,0) + & + gvvs(:nrzt)*zv(:nrzt,1) + guvs(:nrzt)*zu(:nrzt,1) + guv(:nrzt) = guv(:nrzt) *sqrts(:nrzt)*sqrts(:nrzt) + brmn_o(:nrzt) = brmn_o(:nrzt) + & - (guvs(:nrzt)*rv(:nrzt,0) + guv(:nrzt)*rv(:nrzt,1)) + bzmn_o(:nrzt) = bzmn_o(:nrzt) + & - (guvs(:nrzt)*zv(:nrzt,0) + guv(:nrzt)*zv(:nrzt,1)) + crmn_o(:nrzt) = guvs(:nrzt)*ru(:nrzt,0) + & + gvvs(:nrzt)*rv(:nrzt,0) + & + bsqr(:nrzt)*rv(:nrzt,1) + guv(:nrzt) *ru(:nrzt,1) + czmn_o(:nrzt) = guvs(:nrzt)*zu(:nrzt,0) + & + gvvs(:nrzt)*zv(:nrzt,0) + & + bsqr(:nrzt)*zv(:nrzt,1) + guv(:nrzt) *zu(:nrzt,1) + ENDIF + +! +! ASSIGN EDGE FORCES (JS = NS) FOR FREE BOUNDARY CALCULATION +! + IF (ivac .ge. 1) THEN + armn_e(ns:nrzt:ns) = armn_e(ns:nrzt:ns) + & + zu0(ns:nrzt:ns)*rbsq(1:nznt) + armn_o(ns:nrzt:ns) = armn_o(ns:nrzt:ns) + & + zu0(ns:nrzt:ns)*rbsq(1:nznt) + azmn_e(ns:nrzt:ns) = azmn_e(ns:nrzt:ns) + & - ru0(ns:nrzt:ns)*rbsq(1:nznt) + azmn_o(ns:nrzt:ns) = azmn_o(ns:nrzt:ns) + & - ru0(ns:nrzt:ns)*rbsq(1:nznt) +! fz00_edge = SUM(wint(ns:nrzt:ns)*ru0(ns:nrzt:ns)*rbsq(1:nznt)) + ENDIF + + 100 CONTINUE +! CALL Print1DArrayMNSP (gcon,tlglob,trglob,500,.TRUE.,"prcon") + +! +! COMPUTE CONSTRAINT FORCE KERNELS +! +#ifndef _HBANGLE + rcon(:nrzt,0) = (rcon(:nrzt,0) - rcon0(:nrzt)) * gcon(:nrzt) + zcon(:nrzt,0) = (zcon(:nrzt,0) - zcon0(:nrzt)) * gcon(:nrzt) + brmn_e(:nrzt) = brmn_e(:nrzt) + rcon(:nrzt,0) + bzmn_e(:nrzt) = bzmn_e(:nrzt) + zcon(:nrzt,0) + brmn_o(:nrzt) = brmn_o(:nrzt)+ rcon(:nrzt,0)*sqrts(:nrzt) + bzmn_o(:nrzt) = bzmn_o(:nrzt)+ zcon(:nrzt,0)*sqrts(:nrzt) + rcon(:nrzt,0) = ru0(:nrzt) * gcon(:nrzt) + zcon(:nrzt,0) = zu0(:nrzt) * gcon(:nrzt) + rcon(:nrzt,1) = rcon(:nrzt,0) * sqrts(:nrzt) + zcon(:nrzt,1) = zcon(:nrzt,0) * sqrts(:nrzt) +#endif + + CALL second0 (tforoff) + timer(tfor) = timer(tfor) + (tforoff - tforon) + + END SUBROUTINE forces diff --git a/Sources/General/funct3d.f b/Sources/General/funct3d.f new file mode 100644 index 0000000..1ecc463 --- /dev/null +++ b/Sources/General/funct3d.f @@ -0,0 +1,827 @@ + SUBROUTINE funct3d_par (lscreen, ier_flag) + USE vmec_main + USE vacmod, ONLY: bsqvac, bsqvac0, raxis_nestor, zaxis_nestor, + & nuv, nuv3 + USE vmec_params, ONLY: ntmax, norm_term_flag + USE realspace + USE vforces + USE xstuff + USE timer_sub + USE precon2d, ONLY: ictrl_prec2d, lHess_exact, l_edge + USE vparams, ONLY: twopi + USE totzsp_mod + USE tomnsp_mod + USE timer_sub + USE parallel_include_module + USE parallel_vmec_module, ONLY: SAXLASTNTYPE, ZEROLASTNTYPE, + & SAXPBYLASTNTYPE + USE blocktridiagonalsolver, ONLY: L_COLSCALE + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(inout) :: ier_flag + LOGICAL, INTENT(in) :: lscreen +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l0pi, l, ivacskip + INTEGER :: nvskip0 = 0 + REAL(dp), DIMENSION(mnmax) :: + & rmnc, zmns, lmns, rmns, zmnc, lmnc + REAL(dp), DIMENSION(:,:,:), POINTER :: lu, lv + REAL(dp) :: presf_ns, delr_mse, delt0 + REAL(dp) :: tbroadon, tbroadoff + REAL(dp), EXTERNAL :: pmass + INTEGER :: i, j, k, nsmin, nsmax, m + REAL(dp), ALLOCATABLE, DIMENSION(:) :: bcastbuf + INTEGER, DIMENSION(4) :: bbuf +C----------------------------------------------- + CALL second0 (tfunon) +! +! POINTER ALIASES +! + + nfunct3d = nfunct3d + 1 + lu => pczmn; lv => pcrmn + + +! CONVERT ODD M TO 1/SQRT(S) INTERNAL REPRESENTATION + ACTIVE1: IF (lactive) THEN + IF (ictrl_prec2d .EQ. 3) THEN + CALL SAXPBYLASTNTYPE(one, pxc, one, pxcdot, pgc) + CALL SAXLASTNTYPE(pgc, pscalxc, pgc) + ELSE IF (ictrl_prec2d.EQ.1 .AND. l_colscale) THEN + pgc = (pxc-pxsave)*pcol_scale + pxsave + CALL SAXLASTNTYPE(pgc, pscalxc, pgc) + ELSE + CALL SAXLASTNTYPE(pxc, pscalxc, pgc) + END IF + +! RIGID BODY SHIFT OF RMNCC(JS.GT.1,0,0) BY DELR_MSE= R00-RAXMSE +! + +! INVERSE FOURIER TRANSFORM TO S,THETA,ZETA SPACE +! R, Z, AND LAMBDA ARRAYS IN FOURIER SPACE +! FIRST, DO SYMMETRIC [ F(u,v) = F(-u,-v) ] PIECES +! ON THE RANGE u = 0,pi and v = 0,2*pi +! + + CALL totzsps_par (pgc, pr1, pru, prv, pz1, pzu, pzv, lu, lv, + & prcon, pzcon, ier_flag) + +! +! ANTI-SYMMETRIC CONTRIBUTIONS TO INVERSE TRANSFORMS +! + IF (lasym) THEN + CALL totzspa_par (pgc, parmn, pbrmn, pextra3, pazmn, pbzmn, + & pextra4, pblmn, pclmn, pextra1, pextra2) + +! SUM SYMMETRIC, ANTISYMMETRIC PIECES APPROPRIATELY +! TO GET R, Z, L, (AND RCON, ZCON) ON FULL RANGE OF u (0 to 2*pi) + CALL symrzl_par (pr1, pru, prv, pz1, pzu, pzv, lu, lv, + & prcon, pzcon, parmn, pbrmn, pextra3, pazmn, + & pbzmn, pextra4, pblmn, pclmn, pextra1, + & pextra2) + END IF + +! l0pi = ns*(1 + nzeta*(ntheta2 - 1)) !u = pi, v = 0, js = ns +! router = r1(ns,0) + r1(ns,1) +! rinner = r1(l0pi,0) + r1(l0pi,1) + r00 = pr1(1,1,0) + z00 = pz1(1,1,0) + + +! +! COMPUTE CONSTRAINT RCON, ZCON +! + nsmin=tlglob; nsmax=trglob + DO l = nsmin, nsmax + prcon(:,l,0) = prcon(:,l,0) + prcon(:,l,1)*psqrts(:,l) + pzcon(:,l,0) = pzcon(:,l,0) + pzcon(:,l,1)*psqrts(:,l) + pru0(:,l) = pru(:,l,0) + pru(:,l,1)*psqrts(:,l) + pzu0(:,l) = pzu(:,l,0) + pzu(:,l,1)*psqrts(:,l) + END DO + +! COMPUTE RCON0, ZCON0 FOR FIXED BOUNDARY BY SCALING EDGE VALUES +! SCALE BY POWER OF SQRTS, RATHER THAN USE rcon0 = rcon, etc. THIS +! PREVENTS A DISCONTINUITY WHEN RESTARTING FIXED BOUNDARY WITH NEW RCON0.... +! +! NOTE: IN ORDER TO MAKE INITIAL CONSTRAINT FORCES SAME FOR FREE/FIXED +! BOUNDARY, WE SET RCON0,ZCON0 THE SAME INITIALLY, BUT TURN THEM OFF +! SLOWLY IN FREE-BOUNDARY VACUUM LOOP (BELOW) +! + IF (ictrl_prec2d .EQ. 2) THEN + DO l = nsmin, nsmax + prcon0(:,l) = prcon(:,l,0) + pzcon0(:,l) = pzcon(:,l,0) + END DO + ELSE IF (iter2 .EQ. iter1 .AND. + & ivac .LE. 0 .AND. + & ictrl_prec2d .EQ. 0) THEN +#if defined(MPI_OPT) + ALLOCATE(bcastbuf(2*nznt)) + bcastbuf(1:nznt)=prcon(:,ns,0) + bcastbuf(nznt+1:2*nznt)=pzcon(:,ns,0) + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8,nranks-1, + & NS_COMM,MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff-tbroadon) + prcon(:,ns,0)=bcastbuf(1:nznt) + pzcon(:,ns,0)=bcastbuf(nznt+1:2*nznt) + DEALLOCATE(bcastbuf) +#endif + DO l = nsmin, nsmax + prcon0(:,l) = prcon(:,ns,0)*psqrts(:,l)**2 + pzcon0(:,l) = pzcon(:,ns,0)*psqrts(:,l)**2 + END DO + END IF + +! +! COMPUTE S AND THETA DERIVATIVE OF R AND Z AND JACOBIAN ON HALF-GRID +! + CALL jacobian_par + +! COMPUTE COVARIANT COMPONENTS OF B, MAGNETIC AND KINETIC +! PRESSURE, AND METRIC ELEMENTS ON HALF-GRID + + CALL second0(tbcovon) + CALL bcovar_par(lu, lv, pxc, ier_flag) + CALL second0(tbcovoff) + bcovar_time=bcovar_time+(tbcovoff - tbcovon) + + END IF ACTIVE1 + + CALL MPI_BCast( ier_flag, 1, MPI_INTEGER, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) !SAL 070719 + +#if defined(MPI_OPT) + bbuf(1)=irst; bbuf(2)=iequi; bbuf(3)=ivac; bbuf(4)=iter2 + CALL MPI_BCast(bbuf,4,MPI_INTEGER,0,RUNVMEC_COMM_WORLD,MPI_ERR) + irst=bbuf(1); iequi=bbuf(2); ivac=bbuf(3); iter2=bbuf(4) + CALL MPI_BCast(lfreeb,1,MPI_LOGICAL,0,RUNVMEC_COMM_WORLD,MPI_ERR) + IF (ier_flag .ne. norm_term_flag) RETURN !SAL 070719 +#endif + + IF (irst.EQ.2 .AND. iequi.EQ.0) THEN + CALL ZEROLASTNTYPE(pgc) + GOTO 100 + END IF + + timer(tbcov) = timer(tbcov) + (tbcovoff - tbcovon) + +! COMPUTE VACUUM MAGNETIC PRESSURE AT PLASMA EDGE +! NOTE: FOR FREE BOUNDARY RUNS, THE VALUE OF RBTOR=R*BTOR +! AT THE PLASMA EDGE SHOULD BE ADJUSTED TO APPROXIMATELY +! EQUAL THE VACUUM VALUE. THIS CAN BE DONE BY CHANGING +! EITHER PHIEDGE OR THE INITIAL CROSS SECTION ACCORDING +! TO THE SCALING LAW R*BTOR .EQ. PHIEDGE/(R1 * Z1). + + IF (lfreeb .AND. + & iter2 .GT. 1 .AND. + & iequi .EQ. 0) THEN + + IF (ictrl_prec2d.LE.1 .AND. (fsqr + fsqz).LE.1.e-3_dp) + & ivac = ivac+1 !decreased from e-1 to e-3 - sph12/04 + + IF (nvskip0 .EQ. 0) nvskip0 = MAX(1, nvacskip) + + IVAC0: IF (ivac .GE. 0) THEN +!SPH OFF: 6.20.17 +! IF INITIALLY ON, TURN OFF rcon0, zcon0 SLOWLY + IF (lactive) THEN + IF (ictrl_prec2d .EQ. 2) THEN + prcon0(:,nsmin:nsmax) = 0; pzcon0(:,nsmin:nsmax) = 0 + ELSE IF (ictrl_prec2d .EQ. 0) THEN + prcon0(:,nsmin:nsmax) = 0.9_dp*prcon0(:,nsmin:nsmax) + pzcon0(:,nsmin:nsmax) = 0.9_dp*pzcon0(:,nsmin:nsmax) + END IF + ENDIF + CALL second0 (tvacon) + ivacskip = MOD(iter2-iter1,nvacskip) + IF (ivac .LE. 2) ivacskip = 0 + +! EXTEND NVACSKIP AS EQUILIBRIUM CONVERGES + IF (ivacskip .EQ. 0) THEN + nvacskip = one/MAX(1.e-1_dp, 1.e11_dp*(fsqr+fsqz)) + nvacskip = MAX(nvacskip, nvskip0) + END IF + +! +! NORMALLY, WHEN COMPUTING THE HESSIAN, IT IS SUFFICIENT TO +! COMPUTE THE VARIATIONS IN THE "EXACT" SOLUTION, NOT THE ENTIRE +! FIELD PERIOD SUM. THUS, FOR ictrl_prec2d >= 2, SET ivacskip = 1 +! FOR ictrl_prec2d = 1 (RUN WITH PRECONDITIONER APPLIED), MUST +! COMPUTE EXACT VACUUM RESPONSE NOW. +! +! THE EXCEPTION TO THIS IS IF WE ARE TESTING THE HESSIAN (lHess_exact=T), +! THEN MUST USE FULL VACUUM CALCULATION TO COMPUTE IT (ivacskip=0) +! +! lHess_exact = .FALSE. + + IF (ictrl_prec2d .NE. 0) THEN + IF (lHess_exact .OR. ictrl_prec2d.EQ.2) THEN !Accurate Hessian + ivacskip = 0 + ELSE + ivacskip = 1 !Fast vacuum calculation used to compute Hessian + ENDIF + ENDIF + +! NOTE: pgc contains correct edge values of r,z,l arrays +! convert_sym, convert_asym have been applied to m=1 modes + + CALL convert_par(rmnc,zmns,lmns,rmns,zmnc,lmnc,pgc) + +! DO NOT UPDATE THIS WHEN USING PRECONDITIONER: BREAKS TRI-DIAGONAL STRUCTURE + IF (ictrl_prec2d.EQ.0 .OR. ictrl_prec2d.EQ.2) THEN + raxis_nestor(1:nzeta) = pr1(1:nzeta,1,0) + zaxis_nestor(1:nzeta) = pz1(1:nzeta,1,0) + +#if defined(MPI_OPT) + ALLOCATE (bcastbuf(2*nzeta)) + bcastbuf(1:nzeta) = raxis_nestor(1:nzeta) + bcastbuf(nzeta+1:2*nzeta) = zaxis_nestor(1:nzeta) + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8,0, + & RUNVMEC_COMM_WORLD,MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + raxis_nestor(1:nzeta) = bcastbuf(1:nzeta) + zaxis_nestor(1:nzeta) = bcastbuf(nzeta+1:2*nzeta) + DEALLOCATE (bcastbuf) +#endif + END IF + +#if defined(MPI_OPT) + ALLOCATE (bcastbuf(2)) + bcastbuf(1)=rbtor + bcastbuf(2)=ctor + IF (lactive) THEN + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8, + & nranks-1,NS_COMM,MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff -tbroadon) + END IF + + CALL second0(tbroadon) + IF (vlactive) THEN + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8,0, + & VAC_COMM,MPI_ERR) + END IF + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff -tbroadon) + rbtor=bcastbuf(1) + ctor=bcastbuf(2) + DEALLOCATE (bcastbuf) +#endif + + IF (vlactive) THEN + IF (ictrl_prec2d .NE. 3 .OR. + & l_edge) THEN + CALL vacuum_par (rmnc, rmns, zmns, zmnc, xm, xn, + & ctor, rbtor, pwint_ns, ns, ivacskip, + & ivac, mnmax, ier_flag, lscreen) + IF (ictrl_prec2d .EQ. 2) bsqvac0 = bsqvac + ELSE + bsqvac = bsqvac0; ier_flag = 0 + END IF + END IF + + IF (vnranks .LT. nranks) THEN +#if defined(MPI_OPT) + CALL MPI_Bcast(bsqvac,SIZE(bsqvac),MPI_REAL8,0, + & NS_COMM,MPI_ERR) +#endif + END IF + + IF (ier_flag .NE. 0) THEN + RETURN + END IF +! +! RESET FIRST TIME FOR SOFT START +! + IF (ivac .EQ. 1) THEN + irst = 2; delt0 = delt + CALL restart_iter(delt0) + irst = 1 + END IF + +! +! IN CASE PRESSURE IS NOT ZERO AT EXTRAPOLATED EDGE... +! UNCOMMENT ALL "RPRES" COMMENTS HERE AND IN BCOVAR, FORCES ROUTINES +! IF NON-VARIATIONAL FORCES ARE DESIRED +! +! presf_ns = 1.5_dp*pres(ns) - 0.5_dp*pres(ns1) +! MUST NOT BREAK TRI-DIAGONAL RADIAL COUPLING: OFFENDS PRECONDITIONER! + presf_ns = pmass(hs*(ns-1.5_dp)) + IF (presf_ns .NE. zero) THEN + presf_ns = (pmass(1._dp)/presf_ns) * pres(ns) + END IF + + DO l = 1, nznt + bsqsav(l,3) = 1.5_dp*pbzmn_o(l,ns) + & - 0.5_dp*pbzmn_o(l,ns-1) + pgcon(l,ns) = bsqvac(l) + presf_ns + rbsq(l) = pgcon(l,ns)*(pr1(l,ns,0) + pr1(l,ns,1))*ohs + dbsq(l) = ABS(pgcon(l,ns)-bsqsav(l,3)) + END DO + + IF (ivac .EQ. 1) THEN + IF (vlactive) THEN + bsqsav(:nznt,1) = pbzmn_o(:,ns) + bsqsav(:nznt,2) = bsqvac(:nznt) +#if defined(MPI_OPT) + CALL MPI_Bcast(bsqsav(:,1),nznt,MPI_REAL8, + & nranks-1,NS_COMM,MPI_ERR) +#endif + END IF + ELSE IF (ictrl_prec2d .NE. 3) THEN +#if defined(MPI_OPT) + CALL MPI_Bcast(bsqsav(:,1),nznt,MPI_REAL8, + & 0,NS_COMM,MPI_ERR) +#endif + END IF + + CALL second0 (tvacoff) + timer(tvac) = timer(tvac) + (tvacoff - tvacon) + IF (ictrl_prec2d .GE. 2) THEN + timer(tvac_2d) = timer(tvac_2d)+ (tvacoff - tvacon) + END IF + END IF IVAC0 + END IF +! +! COMPUTE CONSTRAINT FORCE +! + ACTIVE2: IF (lactive) THEN + IF (iequi .NE. 1) THEN + DO l = nsmin, nsmax + pextra1(:,l,0) = (prcon(:,l,0) - prcon0(:,l))*pru0(:,l) + & + (pzcon(:,l,0) - pzcon0(:,l))*pzu0(:,l) + END DO + CALL alias_par (pgcon, pextra1(:,:,0), pgc, pgc(1+mns), + & pgc(1+2*mns), pextra1(:,:,1)) + ELSE + IF (lrecon) THEN + pxc(:ns) = pxc(:ns) + delr_mse + END IF + GOTO 100 + END IF + +! +! COMPUTE MHD FORCES ON INTEGER-MESH +! + CALL forces_par + +! SYMMETRIZE FORCES (in u-v space) +! + + IF (lasym) THEN + CALL symforce_par (parmn, pbrmn, pcrmn, pazmn, pbzmn, + & pczmn, pblmn, pclmn, prcon, pzcon, pr1, + & pru, prv, pz1, pzu, pzv, pextra3, + & pextra4, pextra1, pextra2) + END IF + +! +! FOURIER-TRANSFORM MHD FORCES TO (M,N)-SPACE +! + + CALL tomnsps_par (pgc, parmn, pbrmn, pcrmn, pazmn, pbzmn, + & pczmn, pblmn, pclmn, prcon, pzcon) + + IF (lasym) THEN + CALL tomnspa_par (pgc, pr1, pru, prv, pz1, pzu, pzv, + & pextra3, pextra4, pextra1, pextra2) + END IF + +!================================================================ +! +! COMPUTE FORCE RESIDUALS (RAW AND PRECONDITIONED) +! +!================================================================ + CALL second0 (treson) + + CALL SAXLASTNTYPE(pgc, pscalxc, pgc) + + CALL residue_par(pgc, pgc(1+irzloff), pgc(1+2*irzloff)) + + END IF ACTIVE2 + +!NEED THIS ON ALL PROCESSORS IN GROUP (NOT JUST ACTIVE ONES) FOR STOPPING CRITERION IN EVOLVE +#if defined(MPI_OPT) + IF (gnranks .GT. nranks) THEN + ALLOCATE(bcastbuf(6)) + bcastbuf(1) = fsqr; bcastbuf(2) = fsqr1 + bcastbuf(3) = fsqz; bcastbuf(4) = fsqz1 + bcastbuf(5) = fsql; bcastbuf(6) = fsql1 + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8,0, + & RUNVMEC_COMM_WORLD,MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff -tbroadon) + fsqr = bcastbuf(1); fsqr1 = bcastbuf(2) + fsqz = bcastbuf(3); fsqz1 = bcastbuf(4) + fsql = bcastbuf(5); fsql1 = bcastbuf(6) + DEALLOCATE(bcastbuf) + END IF +#endif + +! Force new initial axis guess IF ALLOWED (l_moveaxis=T) + IF (lmove_axis .and. + & iter2 .eq .1 .and. + & (fsqr + fsqz +fsql) .gt. 1.E2_dp) THEN + irst = 4 + END IF + + CALL second0 (tresoff) + timer(tres) = timer(tres) + (tresoff - treson) + + 100 CONTINUE + + CALL second0 (tfunoff) + timer(tfun) = timer(tfun) + (tfunoff - tfunon) + IF (ictrl_prec2d .GE. 2) THEN + timer(tfun_2d) = timer(tfun_2d) + (tfunoff - tfunon) + END IF + + END SUBROUTINE funct3d_par + + SUBROUTINE funct3d (lscreen, ier_flag) + USE vmec_main +#ifdef _VACUUM2 + USE vac2_vacmod, ONLY: mf, nf, bsqvac +#else + USE vacmod, ONLY: bsqvac, bsqvac0, raxis_nestor, zaxis_nestor +#endif + USE vmec_params, ONLY: ntmax + USE realspace + USE vforces + USE xstuff + USE timer_sub + USE precon2d, ONLY: ictrl_prec2d, lHess_exact, l_edge + USE vparams, ONLY: twopi + USE totzsp_mod + USE tomnsp_mod + USE timer_sub +#ifdef _HBANGLE + USE angle_constraints, ONLY: getrz, getfrho, xtempa +#endif + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(inout) :: ier_flag + LOGICAL, INTENT(in) :: lscreen +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: l0pi, l, lk, ivacskip + INTEGER :: nvskip0 = 0 + REAL(dp), DIMENSION(mnmax) :: + 1 rmnc, zmns, lmns, rmns, zmnc, lmnc + REAL(dp), DIMENSION(:), POINTER :: lu, lv + REAL(dp) :: presf_ns, delr_mse, delt0 + REAL(dp), EXTERNAL :: pmass +!----------------------------------------------- +! +! POINTER ALIASES +! + lu => czmn; lv => crmn + + CALL second0 (tfunon) + +! CONVERT ODD M TO 1/SQRT(S) INTERNAL REPRESENTATION +! +#ifdef _HBANGLE +!Overwrites rzl_array, but that is OK since gc = rzl_array in CALL, xc preserved + xtempa = xc + CALL getrz(xc) +#endif + IF (ictrl_prec2d .EQ. 3) THEN + gc(:neqs) = scalxc(:neqs)*(xc(:neqs)+xcdot(:neqs)) + ELSE + gc(:neqs) = scalxc(:neqs)*xc(:neqs) + END IF + +! +! INVERSE FOURIER TRANSFORM TO S,THETA,ZETA SPACE +! R, Z, AND LAMBDA ARRAYS IN FOURIER SPACE +! FIRST, DO SYMMETRIC [ F(u,v) = F(-u,-v) ] PIECES +! ON THE RANGE u = 0,pi and v = 0,2*pi +! + + CALL totzsps (gc, r1, ru, rv, z1, zu, zv, lu, lv, rcon, zcon) +! +! ANTI-SYMMETRIC CONTRIBUTIONS TO INVERSE TRANSFORMS +! + IF (lasym) THEN + CALL totzspa (gc, armn, brmn, extra3, azmn, bzmn, extra4, + & blmn, clmn, extra1, extra2) + +! SUM SYMMETRIC, ANTISYMMETRIC PIECES APPROPRIATELY +! TO GET R, Z, L, (AND RCON, ZCON) ON FULL RANGE OF u (0 to 2*pi) + CALL symrzl (r1, ru, rv, z1, zu, zv, lu, lv, rcon, zcon, + & armn, brmn, extra3, azmn, bzmn, extra4, blmn, + & clmn, extra1, extra2) + END IF + + l0pi = ns*(1 + nzeta*(ntheta2 - 1)) !u = pi, v = 0, js = ns + router = r1(ns,0) + r1(ns,1) + rinner = r1(l0pi,0) + r1(l0pi,1) + r00 = r1(1,0) + z00 = z1(1,0) + +! +! COMPUTE CONSTRAINT RCON, ZCON +! +#ifndef _HBANGLE + rcon(:nrzt,0) = rcon(:nrzt,0) + rcon(:nrzt,1)*sqrts(:nrzt) + zcon(:nrzt,0) = zcon(:nrzt,0) + zcon(:nrzt,1)*sqrts(:nrzt) +#endif + ru0(:nrzt) = ru(:nrzt,0) + ru(:nrzt,1)*sqrts(:nrzt) + zu0(:nrzt) = zu(:nrzt,0) + zu(:nrzt,1)*sqrts(:nrzt) + +! +! COMPUTE RCON0, ZCON0 FOR FIXED BOUNDARY BY SCALING EDGE VALUES +! SCALE BY POWER OF SQRTS, RATHER THAN USE rcon0 = rcon, etc. THIS +! PREVENTS A DISCONTINUITY WHEN RESTARTING FIXED BOUNDARY WITH NEW RCON0.... +! +! NOTE: IN ORDER TO MAKE INITIAL CONSTRAINT FORCES SAME FOR FREE/FIXED +! BOUNDARY, WE SET RCON0,ZCON0 THE SAME INITIALLY, BUT TURN THEM OFF +! SLOWLY IN FREE-BOUNDARY VACUUM LOOP (BELOW) +! +#ifndef _HBANGLE + IF (ictrl_prec2d .EQ. 2) THEN + rcon0(1:nrzt) = rcon(1:nrzt,0) + zcon0(1:nrzt) = zcon(1:nrzt,0) + ALLOCATE(bsqvac0(nznt)) + ELSE IF (iter2 .EQ. iter1 .AND. + & ivac .le. 0 .AND. + & ictrl_prec2d .EQ. 0) THEN + DO l = 1, ns + rcon0(l:nrzt:ns) = rcon(ns:nrzt:ns,0)*sqrts(l:nrzt:ns)**2 + zcon0(l:nrzt:ns) = zcon(ns:nrzt:ns,0)*sqrts(l:nrzt:ns)**2 + END DO + END IF +#endif +! +! COMPUTE S AND THETA DERIVATIVE OF R AND Z AND JACOBIAN ON HALF-GRID +! + CALL jacobian + IF (irst .EQ. 2 .AND. + & iequi .EQ. 0) THEN + gc=0 + GOTO 100 + END IF + +! +! COMPUTE COVARIANT COMPONENTS OF B, MAGNETIC AND KINETIC +! PRESSURE, AND METRIC ELEMENTS ON HALF-GRID +! + CALL second0 (tbcovon) + CALL bcovar (lu, lv) + + CALL second0 (tbcovoff) + timer(tbcov) = timer(tbcov) + (tbcovoff - tbcovon) + +! COMPUTE VACUUM MAGNETIC PRESSURE AT PLASMA EDGE +! NOTE: FOR FREE BOUNDARY RUNS, THE VALUE OF RBTOR=R*BTOR +! AT THE PLASMA EDGE SHOULD BE ADJUSTED TO APPROXIMATELY +! EQUAL THE VACUUM VALUE. THIS CAN BE DONE BY CHANGING +! EITHER PHIEDGE OR THE INITIAL CROSS SECTION ACCORDING +! TO THE SCALING LAW R*BTOR .EQ. PHIEDGE/(R1 * Z1). + + IF (lfreeb .and. iter2.gt.1 .and. iequi.eq.0) THEN + IF (ictrl_prec2d .le. 1 .and. + & (fsqr + fsqz) .le. 1.e-3_dp) THEN + ivac = ivac+1 !decreased from e-1 to e-3 - sph12/04 + END IF + IF (nvskip0 .eq. 0) THEN + nvskip0 = MAX(1, nvacskip) + END IF + IVAC0: IF (ivac .ge. 0) THEN +!SPH OFF: 6.20.17 +! IF INITIALLY ON, TURN OFF rcon0, zcon0 SLOWLY + IF (ictrl_prec2d .eq. 2) THEN + rcon0 = 0; zcon0 = 0 + ELSE IF (ictrl_prec2d .eq. 0) THEN + rcon0 = 0.9_dp*rcon0; zcon0 = 0.9_dp*zcon0 + END IF + CALL second0 (tvacon) + ivacskip = MOD(iter2-iter1,nvacskip) + IF (ivac .LE. 2) THEN + ivacskip = 0 + END IF + +! EXTEND NVACSKIP AS EQUILIBRIUM CONVERGES + IF (ivacskip .eq. 0) THEN + nvacskip = one/MAX(1.e-1_dp, 1.e11_dp*(fsqr+fsqz)) + nvacskip = MAX(nvacskip, nvskip0) + END IF + +! +! NORMALLY, WHEN COMPUTING THE HESSIAN, IT IS SUFFICIENT TO +! COMPUTE THE VARIATIONS IN THE "EXACT" SOLUTION, NOT THE ENTIRE +! FIELD PERIOD SUM. THUS, FOR ictrl_prec2d >= 2, SET ivacskip = 1 +! FOR ictrl_prec2d = 1 (RUN WITH PRECONDITIONER APPLIED), MUST +! COMPUTE EXACT VACUUM RESPONSE NOW. +! +! THE EXCEPTION TO THIS IS IF WE ARE TESTING THE HESSIAN (lHess_exact=T), +! THEN MUST USE FULL VACUUM CALCULATION TO COMPUTE IT (ivacskip=0) +! +! lHess_exact = .FALSE. + IF (ictrl_prec2d .NE. 0) THEN + IF (lHess_exact .OR. ictrl_prec2d.EQ.2) THEN !Accurate Hessian + ivacskip = 0 + ELSE + ivacskip = 1 !Fast vacuum calculation used to compute Hessian + END IF + ENDIF + +! NOTE: gc contains correct edge values of r,z,l arrays +! convert_sym, convert_asym have been applied to m=1 modes + CALL convert (rmnc, zmns, lmns, rmns, zmnc, lmnc, gc, ns) + IF (ictrl_prec2d.NE.3 .OR. l_edge) THEN +#ifdef _VACUUM2 + CALL vac2_vacuum(rmnc, rmns, zmns, zmnc, xm, xn, ctor, + & ivacskip, mnmax) + +#else +! DO NOT UPDATE THIS WHEN USING PRECONDITIONER: BREAKS TRI-DIAGONAL STRUCTURE + IF (ictrl_prec2d .EQ. 0 .OR. + & ictrl_prec2d .EQ. 2) THEN + raxis_nestor(1:nzeta) = r1(1:ns*nzeta:ns,0) + zaxis_nestor(1:nzeta) = z1(1:ns*nzeta:ns,0) + END IF + + CALL vacuum (rmnc, rmns, zmns, zmnc, xm, xn, + & ctor, rbtor, wint, ns, ivacskip, ivac, + & mnmax, ier_flag, lscreen) + IF (ictrl_prec2d .EQ. 2) THEN + bsqvac0 = bsqvac + END IF +#endif + ELSE + bsqvac = bsqvac0 + ier_flag = 0 + END IF + + IF (ier_flag .NE. 0) THEN + GOTO 100 + END IF +! +! RESET FIRST TIME FOR SOFT START +! + IF (ivac .eq. 1) THEN + irst = 2; delt0 = delt +#ifdef _HBANGLE + gc = xc; xc = xtempa +#endif + CALL restart_iter(delt0) +#ifdef _HBANGLE + xc = gc +#endif + irst = 1 + END IF + +! +! IN CASE PRESSURE IS NOT ZERO AT EXTRAPOLATED EDGE... +! UNCOMMENT ALL "RPRES" COMMENTS HERE AND IN BCOVAR, FORCES ROUTINES +! IF NON-VARIATIONAL FORCES ARE DESIRED +! +! presf_ns = 1.5_dp*pres(ns) - 0.5_dp*pres(ns1) +! MUST NOT BREAK TRI-DIAGONAL RADIAL COUPLING: OFFENDS PRECONDITIONER! + presf_ns = pmass(hs*(ns-1.5_dp)) + IF (presf_ns .ne. zero) THEN + presf_ns = (pmass(one)/presf_ns) * pres(ns) + END IF + + lk = 0 +! gcon(:nrzt) = r1(:nrzt,0)+sqrts(:nrzt)*r1(:nrzt,1) +! gcon(1+nrzt) = 0 + DO l = ns, nrzt, ns + lk = lk + 1 + bsqsav(lk,3) = 1.5_dp*bzmn_o(l) - 0.5_dp*bzmn_o(l-1) +#ifdef _ANIMEC + gcon(l) = bsqvac(lk) + pperp_ns(lk) +#else + gcon(l) = bsqvac(lk) + presf_ns +#endif + + rbsq(lk) = gcon(l)*(r1(l,0) + r1(l,1))*ohs + dbsq(lk) = ABS(gcon(l)-bsqsav(lk,3)) + END DO +! +! COMPUTE m=0,n=0 EDGE "pedestals" +! +!! alphaR = hs*hs*ard(ns,1) +!! IF (alphaR .ne. zero) alphaR = +!! & hs*SUM(wint(ns:nrzt:ns)*zu0(ns:nrzt:ns)*rbsq)/alphaR + +!! PRINT *,' alphaR/r1(ns) = ', alphaR/gcon(ns) + + IF (ivac .eq. 1) THEN + bsqsav(:nznt,1) = bzmn_o(ns:nrzt:ns) + bsqsav(:nznt,2) = bsqvac(:nznt) + END IF + CALL second0 (tvacoff) + timer(tvac) = timer(tvac) + (tvacoff - tvacon) + IF (ictrl_prec2d .GE. 2) THEN + timer(tvac_2d) = timer(tvac_2d)+ (tvacoff - tvacon) + END IF + + END IF IVAC0 + END IF + +! +! COMPUTE CONSTRAINT FORCE +! +#ifdef _HBANGLE + gcon = 0 + IF (iequi .EQ. 1) THEN + GOTO 100 + END IF +#else + IF (iequi .NE. 1) THEN + extra1(:nrzt,0) = (rcon(:nrzt,0) - rcon0(:nrzt))*ru0(:nrzt) + & + (zcon(:nrzt,0) - zcon0(:nrzt))*zu0(:nrzt) + CALL alias (gcon, extra1(:,0), gc, gc(1+mns), gc(1+2*mns), + & extra1(:,1)) + ELSE + IF (lrecon) xc(:ns) = xc(:ns) + delr_mse + GOTO 100 + END IF +#endif +! +! COMPUTE MHD FORCES ON INTEGER-MESH +! + CALL forces + +! +! FFT TEST +! +#ifdef _TEST_FOURIER +! xc = xc*scalxc +! CALL tomnsps_t (gc, xc, r1, ru, rv, z1, zu, zv) +! IF (lasym) CALL tomnspa_t (gc, xc, r1, ru, rv, z1, zu, zv) +! STOP +#endif +! +! SYMMETRIZE FORCES (in u-v space): NOTE - gc IS SMALL BY FACTOR 2 +! IF lasym=T +! + IF (lasym) THEN + CALL symforce (armn, brmn, crmn, azmn, bzmn, + & czmn, blmn, clmn, rcon, zcon, r1, ru, rv, + & z1, zu, zv, extra3, extra4, extra1, extra2) +!NOT NECESSARY (EVEN THOUGH CORRECT) gc = 2*gc + END IF + +! +! FOURIER-TRANSFORM MHD FORCES TO (M,N)-SPACE +! + CALL tomnsps (gc, armn, brmn, crmn, azmn, bzmn, czmn, + & blmn, clmn, rcon, zcon) + + IF (lasym) THEN + CALL tomnspa (gc, r1, ru, rv, z1, zu, zv, + & extra3, extra4, extra1, extra2) + END IF + +!================================================================ +! +! COMPUTE FORCE RESIDUALS (RAW AND PRECONDITIONED) +! +!================================================================ + CALL second0 (treson) + + gc = gc * scalxc !!IS THIS CORRECT: SPH010214? +#ifdef _HBANGLE + CALL getfrho(gc) +#endif + CALL residue (gc, gc(1+irzloff), gc(1+2*irzloff)) +! Force new initial axis guess IF ALLOWED (l_moveaxis=T) + IF (lmove_axis .and. + & iter2 .eq. 1 .and. + & (fsqr + fsqz + fsql) .gt. 1.E2_dp) THEN + irst = 4 + END IF + + CALL second0 (tresoff) + timer(tres) = timer(tres) + (tresoff - treson) + + 100 CONTINUE + +#ifdef _HBANGLE + xc = xtempa +#endif + CALL second0 (tfunoff) + timer(tfun) = timer(tfun) + (tfunoff - tfunon) + IF (ictrl_prec2d .GE. 2) THEN + timer(tfun_2d) = timer(tfun_2d) + (tfunoff - tfunon) + END IF + + END SUBROUTINE funct3d diff --git a/Sources/General/getfsq.f b/Sources/General/getfsq.f new file mode 100644 index 0000000..8661c6f --- /dev/null +++ b/Sources/General/getfsq.f @@ -0,0 +1,60 @@ + SUBROUTINE getfsq_par(gcr, gcz, gnormr, gnormz, gnorm, medge) + USE vmec_main, ONLY: rprec, ns, ns1, mnsize + USE vmec_params, ONLY: ntmax + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(in) :: medge + REAL(dp), INTENT(out) :: gnormr, gnormz + REAL(dp), INTENT(in) :: gnorm + REAL(dp), DIMENSION(mnsize,ns,ntmax), INTENT(IN) :: gcr, gcz +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: jsmax, nsmin, nsmax, l + REAL(dp) :: tmpgcx(ns,2), totalgcx(2) +!----------------------------------------------- + IF (.NOT. lactive) RETURN + + jsmax = ns1 + medge + nsmin=tlglob; nsmax=MIN(trglob,jsmax) + IF (trglob .GT. jsmax) tmpgcx(jsmax+1:trglob,1:2) = 0 + + DO l = nsmin, nsmax + tmpgcx(l,1) = SUM(gcr(:,l,:)**2) + tmpgcx(l,2) = SUM(gcz(:,l,:)**2) + END DO + DO l = 1, 2 + CALL Gather1XArray(tmpgcx(:,l)) + totalgcx(l) = SUM(tmpgcx(:,l)) + END DO + + gnormr = gnorm * totalgcx(1) + gnormz = gnorm * totalgcx(2) + + END SUBROUTINE getfsq_par + + SUBROUTINE getfsq(gcr, gcz, gnormr, gnormz, gnorm, medge) + USE vmec_main, ONLY: rprec, ns, ns1, mnsize + USE vmec_params, ONLY: ntmax + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(in) :: medge + REAL(dp), INTENT(out) :: gnormr, gnormz + REAL(dp), INTENT(in) :: gnorm + REAL(dp), DIMENSION(ns,mnsize*ntmax), INTENT(in) :: gcr, gcz +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: jsmax +!----------------------------------------------- + jsmax = ns1 + medge + gnormr = gnorm * SUM(gcr(:jsmax,:)**2) + gnormz = gnorm * SUM(gcz(:jsmax,:)**2) + + END SUBROUTINE getfsq diff --git a/Sources/General/jacobian.f b/Sources/General/jacobian.f new file mode 100644 index 0000000..479e020 --- /dev/null +++ b/Sources/General/jacobian.f @@ -0,0 +1,178 @@ + SUBROUTINE jacobian_par + USE vmec_input, ONLY: nzeta + USE vmec_main, ONLY: ohs, nrzt, irst, nznt, iter2 + USE vmec_params, ONLY: meven, modd + USE realspace + USE vmec_dim, ONLY: ns, ntheta3 + USE vforces, pr12 => parmn_o, pzu12 => parmn_e, pru12 => pazmn_e, + & prs => pbzmn_e, pzs => pbrmn_e, ptau => pazmn_o + USE parallel_include_module + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: zero = 0, p5 = 0.5_dp, p25 = p5*p5 + REAL(dp) :: dphids +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, nsmin, nsmax, lnsnum + REAL(dp) :: ltaumax, ltaumin + REAL(dp) :: taumax, taumin + REAL(dp), ALLOCATABLE, DIMENSION(:) :: temp + REAL(dp), ALLOCATABLE, DIMENSION(:) :: minarr, maxarr + REAL(dp) :: t1, t2, tjacon, tjacoff +C----------------------------------------------- + CALL second0(tjacon) + + nsmin=MAX(2,tlglob); nsmax=t1rglob; + dphids = p25 + irst = 1 + + DO i = nsmin, nsmax + pru12(:,i) = p5*(pru(:,i,meven) + pru(:,i-1,meven) + + & pshalf(:,i)*(pru(:,i,modd) + + & pru(:,i-1,modd))) + pzs(:,i) = ohs*(pz1(:,i,meven) - pz1(:,i-1,meven) + + & pshalf(:,i)*(pz1(:,i,modd) - + & pz1(:,i-1,modd))) + ptau(:,i) = pru12(:,i)*pzs(:,i) + & + dphids*(pru(:,i,modd)*pz1(:,i,modd) + + & pru(:,i-1,modd)*pz1(:,i-1,modd) + + & (pru(:,i,meven)*pz1(:,i,modd) + + & pru(:,i-1,meven)*pz1(:,i-1,modd)) / + & pshalf(:,i)) + END DO + + DO i = nsmin, nsmax + pzu12(:,i) = p5*(pzu(:,i,meven) + pzu(:,i-1,meven) + + & pshalf(:,i)*(pzu(:,i,modd) + + & pzu(:,i-1,modd))) + prs(:,i) = ohs*(pr1(:,i,meven) - pr1(:,i-1,meven) + + & pshalf(:,i)*(pr1(:,i,modd) - + & pr1(:,i-1,modd))) + pr12(:,i) = p5*(pr1(:,i,meven) + pr1(:,i-1,meven) + + & pshalf(:,i)*(pr1(:,i,modd) + + & pr1(:,i-1,modd))) + ptau(:,i) = ptau(:,i) - prs(:,i)*pzu12(:,i) + & - dphids*(pzu(:,i,modd)*pr1(:,i,modd) + + & pzu(:,i-1,modd)*pr1(:,i-1,modd) + + & (pzu(:,i,meven)*pr1(:,i,modd) + + & pzu(:,i-1,meven)*pr1(:,i-1,modd)) / + & pshalf(:,i)) + END DO + + ALLOCATE(temp(1:nznt)) + temp(:)=ptau(:,2) + ptau(:,1)=temp(:) + DEALLOCATE(temp) + + ltaumax=MAXVAL(ptau(:,nsmin:nsmax)) + ltaumin=MINVAL(ptau(:,nsmin:nsmax)) +! ltaumax=MAXVAL(ptau(:,tlglob:trglob)) +! ltaumin=MINVAL(ptau(:,tlglob:trglob)) + + taumax=ltaumax + taumin=ltaumin + + IF (nranks.GT.1.AND.grank.LT.nranks) THEN + CALL second0(t1) + CALL MPI_Allreduce(ltaumax,taumax,1,MPI_REAL8, + & MPI_MAX,NS_COMM,MPI_ERR) + CALL MPI_Allreduce(ltaumin,taumin,1,MPI_REAL8, + & MPI_MIN,NS_COMM,MPI_ERR) + CALL second0(t2) + allreduce_time = allreduce_time + (t2-t1) + END IF + + IF (taumax*taumin .lt. zero) THEN + irst = 2 + END IF + + CALL second0(tjacoff) + jacobian_time=jacobian_time+(tjacoff-tjacon) + + END SUBROUTINE jacobian_par + + SUBROUTINE jacobian + USE vmec_main, ONLY: ohs, nrzt, irst, iter2 + USE vmec_params, ONLY: meven, modd + USE realspace + USE vmec_dim, ONLY: ns + USE vforces, r12 => armn_o, ru12 => azmn_e, zu12 => armn_e, + & rs => bzmn_e, zs => brmn_e, tau => azmn_o !,z12 => blmn_e, + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: zero = 0, p5 = 0.5_dp, p25 = p5*p5 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l + REAL(dp) :: taumax, taumin, dphids, temp(nrzt/ns) + +C----------------------------------------------- +! +! (RS, ZS)=(R, Z) SUB S, (RU12, ZU12)=(R, Z) SUB THETA(=U) +! AND TAU=SQRT(G)/R ARE DIFFERENCED ON HALF MESH +! NOTE: LOOPS WERE SPLIT TO ALLOW EFFICIENT MEMORY BUS USAGE +! +! SQRT(G) = R*TAU IS COMPUTED IN BCOVAR +! +! FOR OPTIMIZATION ON CRAY, MUST USE COMPILER DIRECTIVES TO +! GET VECTORIZATION OF LOOPS INVOLVING MORE THAN ONE POINTER! +! +! +! HERE, TAU = (Ru * Zs - Rs * Zu). THE DERIVATIVES OF SHALF = SQRT(s) +! WERE COMPUTED EXPLICITLY AS: d(shalf)/ds = .5/shalf +! +! NOTE: z12 IS USED IN RECONSTRUCTION PART OF CODE ONLY; COULD BE ELIMINATED... +! +! + dphids = p25 + irst = 1 + +CDIR$ IVDEP + DO l = 2,nrzt + ru12(l) = p5*(ru(l,meven) + ru(l-1,meven) + + & shalf(l)*(ru(l,modd) + ru(l-1,modd))) + zs(l) = ohs*(z1(l,meven) - z1(l-1,meven) + + & shalf(l)*(z1(l,modd) - z1(l-1,modd))) + tau(l) = ru12(l)*zs(l) + & + dphids*(ru(l,modd)*z1(l,modd) + + & ru(l-1,modd)*z1(l-1,modd) + + & (ru(l,meven)*z1(l,modd) + + & ru(l-1,meven)*z1(l-1,modd))/shalf(l)) + ENDDO + + +CDIR$ IVDEP + DO l = 2,nrzt + zu12(l) = p5*(zu(l,meven) + zu(l-1,meven) + & + shalf(l)*(zu(l,modd) + zu(l-1,modd))) + rs(l) = ohs*(r1(l,meven) - r1(l-1,meven) + & + shalf(l)*(r1(l,modd) - r1(l-1,modd))) + r12(l) = p5*(r1(l,meven) + r1(l-1,meven) + + & shalf(l)*(r1(l,modd) + r1(l-1,modd))) + tau(l) = tau(l) - rs(l)*zu12(l) - + & dphids*(zu(l,modd)*r1(l,modd) + + & zu(l-1,modd)*r1(l-1,modd) + + & (zu(l,meven)*r1(l,modd) + + & zu(l-1,meven)*r1(l-1,modd))/shalf(l)) + END DO + +! +! TEST FOR SIGN CHANGE IN JACOBIAN +! + temp(:) = tau(2:nrzt:ns) + tau(1:nrzt:ns) = temp(:) + taumax = MAXVAL(tau(2:nrzt)) + taumin = MINVAL(tau(2:nrzt)) + IF (taumax*taumin .lt. zero) THEN + irst = 2 + END IF + + END SUBROUTINE jacobian diff --git a/Sources/General/lamcal.f90 b/Sources/General/lamcal.f90 new file mode 100644 index 0000000..8ab48db --- /dev/null +++ b/Sources/General/lamcal.f90 @@ -0,0 +1,162 @@ + SUBROUTINE lamcal_par(overg, guu, guv, gvv) + USE vmec_main + USE vmec_params, ONLY: ntmax, jlam, lamscale + USE realspace, ONLY: psqrts + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(nznt,ns), INTENT(in) :: & + overg, guu, guv, gvv +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(rprec), PARAMETER :: damping_fac = 2 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: m, n, js, nsmin, nsmax, numjs, i, j, k, l + REAL(rprec) :: tnn, tnm, tmm, power, pfactor0, pfactor + + INTEGER :: blksize + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(rprec), ALLOCATABLE, DIMENSION(:,:,:,:) :: send_buf + REAL(rprec), ALLOCATABLE, DIMENSION(:) :: recv_buf + REAL(rprec) :: allgvton, allgvtoff +!----------------------------------------------- + + nsmin=tlglob; nsmax=t1rglob + + blam(nsmin:nsmax) = SUM(guu(:,nsmin:nsmax)*overg(:,nsmin:nsmax), dim=1) + clam(nsmin:nsmax) = SUM(gvv(:,nsmin:nsmax)*overg(:,nsmin:nsmax), dim=1) + dlam(nsmin:nsmax) = SUM(guv(:,nsmin:nsmax)*overg(:,nsmin:nsmax), dim=1) + blam(1) = blam(2) + clam(1) = clam(2) + dlam(1) = dlam(2) + blam(ns+1) = 0 + clam(ns+1) = 0 + dlam(ns+1) = 0 + + nsmin=MAX(2,tlglob); nsmax=trglob + DO js = nsmin, nsmax + blam(js) = cp5*(blam(js) + blam(js+1)) + clam(js) = cp5*(clam(js) + clam(js+1)) + dlam(js) = cp5*(dlam(js) + dlam(js+1)) + END DO + + pfaclam = 0 +! pfactor0 = 2*damping_fac/(2*r0scale*lamscale)**2 + pfactor0 = damping_fac/(2*r0scale*lamscale)**2 + + DO m = 0, mpol1 + tmm = m*m + power = MIN(tmm/256, 8._dp) + pfactor = pfactor0 + DO n = 0, ntor + IF (m.eq.0 .and. n.eq.0) CYCLE + tnn = (n*nfp)**2 + tnm = 2*m*n*nfp + + DO js = MAX(jlam(m),tlglob), trglob + pfaclam(n,m,js,1) = blam(js)*tnn + clam(js)*tmm & + + SIGN(dlam(js),blam(js))*tnm + IF (pfaclam(n,m,js,1) .eq. zero) THEN + pfaclam(n,m,js,1) = -1.E-10_dp + END IF + pfaclam(n,m,js,1) = (pfactor/pfaclam(n,m,js,1)) & + * psqrts(1,js)**power !Damps m > 16 modes + END DO + END DO + END DO + + nsmin=tlglob; nsmax=trglob + DO n = 2, ntmax + pfaclam(0:ntor,0:mpol1,nsmin:nsmax,n) = & + pfaclam(0:ntor,0:mpol1,nsmin:nsmax,1) + END DO + +! +! ADD NORM FOR CHIP (PREVIOUSLY IOTA) FORCE, STORED IN lmnsc(m=0,n=0) COMPONENT +! + nsmin=tlglob; nsmax=trglob + DO js = nsmin, nsmax + pfaclam(0,0,js,1) = (pfactor0*lamscale**2)/blam(js) + END DO + + END SUBROUTINE lamcal_par + + SUBROUTINE lamcal(overg, guu, guv, gvv) + USE vmec_main + USE vmec_params, ONLY: ntmax, jlam, lamscale + USE realspace, ONLY: sqrts + + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(ns,nznt), INTENT(in) :: & + overg, guu, guv, gvv +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(rprec), PARAMETER :: damping_fac=2 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: m,n,js + REAL(rprec) :: tnn, tnm, tmm, power, pfactor0, pfactor + +!----------------------------------------------- + + + blam(:ns) = SUM(guu*overg, dim=2) + clam(:ns) = SUM(gvv*overg, dim=2) + dlam(:ns) = SUM(guv*overg, dim=2) + blam(1) = blam(2) + clam(1) = clam(2) + dlam(1) = dlam(2) + blam(ns+1) = 0 + clam(ns+1) = 0 + dlam(ns+1) = 0 + DO js = 2, ns + blam(js) = cp5*(blam(js) + blam(js+1)) + clam(js) = cp5*(clam(js) + clam(js+1)) + dlam(js) = cp5*(dlam(js) + dlam(js+1)) + END DO + + faclam = 0 + pfactor0 = damping_fac/(2*r0scale*lamscale)**2 + + DO m = 0, mpol1 + tmm = m*m + power = MIN(tmm/256, 8._dp) + pfactor = pfactor0 + DO n = 0, ntor + IF (m.eq.0 .and. n.eq.0) CYCLE +! IF (n .gt. 1) pfactor = pfactor0/4 !sometimes helps convergence + tnn = (n*nfp)**2 + tnm = 2*m*n*nfp + DO js = jlam(m), ns + faclam(js,n,m,1) = blam(js)*tnn + clam(js)*tmm & + + SIGN(dlam(js),blam(js))*tnm + IF (faclam(js,n,m,1) .eq. zero) THEN + faclam(js,n,m,1) = -1.E-10_dp + END IF + faclam(js,n,m,1) = (pfactor/faclam(js,n,m,1)) & + * sqrts(js)**power !Damps m > 16 modes + END DO + END DO + END DO + + DO n = 2, ntmax + faclam(:ns,0:ntor,0:mpol1,n) = faclam(:ns,0:ntor,0:mpol1,1) + END DO +! +! ADD NORM FOR CHIP (PREVIOUSLY IOTA) FORCE, STORED IN lmnsc(m=0,n=0) COMPONENT +! + DO js = 1, ns + faclam(js,0,0,1) = (pfactor0*lamscale**2)/blam(js) + END DO + + END SUBROUTINE lamcal diff --git a/Sources/General/precondn.f b/Sources/General/precondn.f new file mode 100644 index 0000000..5cdc1db --- /dev/null +++ b/Sources/General/precondn.f @@ -0,0 +1,235 @@ + ! SKS-RANGE: All OUT arrays computed correctly between + ! [tlglob, trglob] + SUBROUTINE precondn_par(lu1, bsq, gsqrt, r12, xs, xu12, xue, xuo, + & xodd, axm, axd, bxm, bxd, + & cx, eqfactor, trigmult) + USE vmec_main + USE vmec_params, ONLY: signgs + USE realspace, ONLY: pshalf, pwint + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(nznt,ns), INTENT(in) :: + & lu1, bsq, gsqrt, r12, xs, xu12, xue, xuo, xodd + REAL(rprec), DIMENSION(ns+1,2), INTENT(out) :: + & axm, axd, bxm, bxd + REAL(rprec), DIMENSION(ns+1), INTENT(out) :: cx + REAL(rprec), DIMENSION(ns), INTENT(out) :: eqfactor + REAL(rprec), DIMENSION(nznt), INTENT(in) :: trigmult +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: js, l, lk + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: ax, bx + !REAL(rprec) :: temp(ns+1) + REAL(rprec), ALLOCATABLE, DIMENSION(:) :: temp + REAL(rprec), DIMENSION(:), ALLOCATABLE :: ptau, ptau2 + REAL(rprec) :: t1, t2, t3, pfactor + + INTEGER :: nsmin, nsmax, i, j, k, numjs + INTEGER, DIMENSION(:), ALLOCATABLE :: ldisps, lcounts + REAL(rprec), DIMENSION(:), ALLOCATABLE :: sbuf + + nsmin=tlglob; nsmax=t1rglob + ! Correct incoming lu1, bsq, gsqrt, , xue, xuo, xodd, trigmult + ! between [t1lglob, t1rglob] + + ALLOCATE (ax(ns+1,4), bx(ns+1,4), + & ptau(nznt), ptau2(nznt), temp(ns+1)) + ax = 0 + bx = 0 + cx = 0 + temp = 0 + pfactor = -4*r0scale**2 !restored in v8.51 + + nsmin = MAX(2,tlglob) + nsmax = t1rglob + DO js = nsmin, nsmax +! +! COMPUTE DOMINANT (1/DELTA-S)**2 PRECONDITIONING +! MATRIX ELEMENTS +! + lk = 0 + DO k = 1, ntheta3 + DO j = 1, nzeta + lk = lk + 1 + t1 = pfactor*r12(lk,js)*bsq(lk,js) + ptau2(lk) = r12(lk,js)*t1/gsqrt(lk,js) + t1 = t1*pwint(lk,js) + temp(js) = temp(js) + t1*trigmult(lk)*xu12(lk,js) + ptau(lk) = r12(lk,js)*t1/gsqrt(lk,js) + t1 = xu12(lk,js)*ohs + t2 = cp25*(xue(lk,js)/pshalf(lk,js)+xuo(lk,js)) + & / pshalf(lk,js) + t3 = cp25*(xue(lk,js-1)/pshalf(lk,js) + + & xuo(lk,js-1))/pshalf(lk,js) + ax(js,1) = ax(js,1) + ptau(lk)*t1*t1 + ax(js,2) = ax(js,2) + ptau(lk)*(-t1+t3)*(t1+t2) + ax(js,3) = ax(js,3) + ptau(lk)*(t1+t2)*(t1+t2) + ax(js,4) = ax(js,4) + ptau(lk)*(-t1+t3)*(-t1+t3) + END DO + END DO +! +! COMPUTE PRECONDITIONING MATRIX ELEMENTS FOR M**2, N**2 TERMS +! + lk = 0 + DO k = 1, ntheta3 + DO j = 1, nzeta + lk = lk+1 + t1 = cp5*(xs(lk,js) + cp5*xodd(lk,js)/pshalf(lk,js)) + t2 = cp5*(xs(lk,js) + cp5*xodd(lk,js-1)/pshalf(lk,js)) + bx(js,1) = bx(js,1) + ptau(lk)*t1*t2 + bx(js,2) = bx(js,2) + ptau(lk)*t1*t1 + bx(js,3) = bx(js,3) + ptau(lk)*t2*t2 + cx(js) = cx(js) + & + cp25*pfactor*lu1(lk,js)**2 * + & gsqrt(lk,js)*pwint(lk,js) + END DO + END DO + + END DO + + nsmin = MAX(2,tlglob) + nsmax = t1rglob + temp(1) = 0 + temp(nsmin:nsmax) = temp(nsmin:nsmax)/vp(nsmin:nsmax); + temp(ns+1) = 0 + + nsmin = t1lglob + nsmax = t1rglob + DO js = nsmin, nsmax + axm(js,1) = -ax(js,1) + axd(js,1) = ax(js,1) + ax(js+1,1) + axm(js,2) = ax(js,2) * sm(js) * sp(js-1) + axd(js,2) = ax(js,3)*sm(js)**2 + ax(js+1,4)*sp(js)**2 + bxm(js,1) = bx(js,1) + bxm(js,2) = bx(js,1) * sm(js) * sp(js-1) + bxd(js,1) = bx(js,2) + bx(js+1,3) + bxd(js,2) = bx(js,2)*sm(js)**2 + bx(js+1,3)*sp(js)**2 + cx(js) = cx(js) + cx(js+1) + temp(js) = signgs*(temp(js) + temp(js+1)) + END DO + + nsmin = MAX(2,tlglob) + nsmax = MIN(ns-1,trglob) + eqfactor(nsmin:nsmax) = axd(nsmin:nsmax,2)*hs*hs/ + & temp(nsmin:nsmax) + eqfactor(1) = 0 + eqfactor(ns) = 0 + axm(ns+1,:) = 0 + axd(ns+1,:) = 0 + bxm(ns+1,:) = 0 + bxd(ns+1,:) = 0 + DEALLOCATE (ax, bx, ptau, ptau2, temp) + + END SUBROUTINE precondn_par + + SUBROUTINE precondn(lu1, bsq, gsqrt, r12, xs, xu12, xue, xuo, + & xodd, axm, axd, bxm, bxd, + & cx, eqfactor, trigmult) + USE vmec_main + USE vmec_params, ONLY: signgs + USE realspace + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(nrzt), INTENT(in) :: + 1 lu1, bsq, gsqrt, r12, xs, xu12, xue, xuo, xodd + REAL(rprec), DIMENSION(ns+1,2), INTENT(out) :: + 1 axm, axd, bxm, bxd + REAL(rprec), DIMENSION(ns+1), INTENT(out) :: cx + REAL(rprec), DIMENSION(ns), INTENT(out) :: eqfactor + REAL(rprec), DIMENSION(nznt), INTENT(in) :: trigmult +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: js, l, lk + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: ax, bx + REAL(rprec) :: temp(ns+1) + REAL(rprec), DIMENSION(:), ALLOCATABLE :: ptau, ptau2 + REAL(rprec) :: t1, t2, t3, pfactor + +C----------------------------------------------- +! +! COMPUTE PRECONDITIONING MATRIX ELEMENTS FOR R,Z +! FORCE. NOTE THAT THE NORMALIZATION IS: +! +! AX(off-diag) ~ <(cosmui cosmu cosnv cosnv) 2(R**2*Xu**2*bsq/gsqrt)> +! Factor of 2 arising from 1/gsqrt**2 in bsq +! +! Now, cosmui cosmu ~ mscale(0)**2, cosnv**2 ~ nscale(0)**2 +! Therefore, AX ~ (mscale(0)*nscale(0))**2 2 +! ~ 2*r0scale**2 <...> +! + ALLOCATE (ax(ns+1,4), bx(ns+1,4), ptau(nznt), ptau2(nznt)) + ax = 0; bx = 0; cx = 0 + temp = 0 +! pfactor = -2*r0scale**2 !v8.50 + pfactor = -4*r0scale**2 !restored in v8.51 + + DO 20 js = 2,ns +! +! COMPUTE DOMINANT (1/DELTA-S)**2 PRECONDITIONING +! MATRIX ELEMENTS +! + lk = 0 + DO l = js,nrzt,ns + lk = lk + 1 + t1 = pfactor*r12(l)*bsq(l) + ptau2(lk) = r12(l)*t1/gsqrt(l) + t1 = t1*wint(l) + temp(js) = temp(js) + t1*trigmult(lk)*xu12(l) + ptau(lk) = r12(l)*t1/gsqrt(l) + t1 = xu12(l)*ohs + t2 = cp25*(xue(l)/shalf(js) + xuo(l))/shalf(js) + t3 = cp25*(xue(l-1)/shalf(js) + xuo(l-1))/shalf(js) + ax(js,1) = ax(js,1) + ptau(lk)*t1*t1 + ax(js,2) = ax(js,2) + ptau(lk)*(-t1+t3)*(t1+t2) + ax(js,3) = ax(js,3) + ptau(lk)*(t1+t2)*(t1+t2) + ax(js,4) = ax(js,4) + ptau(lk)*(-t1+t3)*(-t1+t3) + END DO +! +! COMPUTE PRECONDITIONING MATRIX ELEMENTS FOR M**2, N**2 TERMS +! + lk = 0 + DO l = js,nrzt,ns + lk = lk+1 + t1 = cp5*(xs(l) + cp5*xodd(l)/shalf(js)) + t2 = cp5*(xs(l) + cp5*xodd(l-1)/shalf(js)) + bx(js,1) = bx(js,1) + ptau(lk)*t1*t2 + bx(js,2) = bx(js,2) + ptau(lk)*t1*t1 + bx(js,3) = bx(js,3) + ptau(lk)*t2*t2 + cx(js) = cx(js) + cp25*pfactor*lu1(l)**2*gsqrt(l)*wint(l) + END DO + 20 CONTINUE + + temp(1) = 0 + temp(2:ns) = temp(2:ns)/vp(2:ns) + temp(ns+1) = 0 + DO js = 1,ns + axm(js,1) =-ax(js,1) + axd(js,1) = ax(js,1) + ax(js+1,1) + axm(js,2) = ax(js,2) * sm(js) * sp(js-1) + axd(js,2) = ax(js,3)*sm(js)**2 + ax(js+1,4)*sp(js)**2 + bxm(js,1) = bx(js,1) + bxm(js,2) = bx(js,1) * sm(js) * sp(js-1) + bxd(js,1) = bx(js,2) + bx(js+1,3) + bxd(js,2) = bx(js,2)*sm(js)**2 + bx(js+1,3)*sp(js)**2 + cx(js) = cx(js) + cx(js+1) + temp(js) = signgs*(temp(js) + temp(js+1)) + END DO + + eqfactor(2:ns-1) = axd(2:ns-1,2)*hs*hs/temp(2:ns-1) + eqfactor(1) = 0 + eqfactor(ns) = 0 + axm(ns+1,:) = 0 + axd(ns+1,:) = 0 + bxm(ns+1,:) = 0 + bxd(ns+1,:) = 0 + DEALLOCATE (ax, bx, ptau, ptau2) + + END SUBROUTINE precondn diff --git a/Sources/General/realspace.f b/Sources/General/realspace.f new file mode 100644 index 0000000..e41122c --- /dev/null +++ b/Sources/General/realspace.f @@ -0,0 +1,33 @@ + MODULE realspace + USE stel_kinds, ONLY: dp + IMPLICIT NONE +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: + 1 r1, ru, rv, zu, zv, rcon, zcon + REAL(dp), DIMENSION(:,:), ALLOCATABLE, TARGET :: z1 +#ifdef _ANIMEC + REAL(dp), DIMENSION(:), ALLOCATABLE :: + 1 pperp, ppar, onembc, pp1, pp2, pp3 +#endif + REAL(dp), DIMENSION(:), ALLOCATABLE :: guu, guv, gvv, sigma_an, + 1 ru0, zu0, gcon, rcon0, zcon0, phip, chip, shalf, sqrts, wint + REAL(dp), DIMENSION(:,:), ALLOCATABLE, TARGET :: + 1 extra1, extra2, extra3, extra4 + INTEGER, DIMENSION(:), ALLOCATABLE :: ireflect_par + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: pru, pz1, pzu, pr1 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: prv, pzv + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: prcon, pzcon + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pgcon + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pshalf + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: + 1 pextra1, pextra2, pextra3, pextra4 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pguu, pguv, pgvv + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pwint, pchip, pphip + REAL(dp), DIMENSION(:), ALLOCATABLE :: pwint_ns + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: pru0, pzu0 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: prcon0, pzcon0 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: psqrts + + END MODULE realspace diff --git a/Sources/General/residue.f90 b/Sources/General/residue.f90 new file mode 100755 index 0000000..031e0fa --- /dev/null +++ b/Sources/General/residue.f90 @@ -0,0 +1,481 @@ + SUBROUTINE residue_par (gcr, gcz, gcl) + USE vmec_main, p5 => cp5 + USE vmec_params, ONLY: rss, zcs, rsc, zcc, & + meven, modd, ntmax, signgs + USE realspace, ONLY: phip + USE xstuff + USE precon2d + USE parallel_include_module + USE parallel_vmec_module, ONLY: tlglob_arr, trglob_arr, & + lactive, SAXLASTNTYPE + USE blocktridiagonalsolver, ONLY: L_COLSCALE + + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntmax), INTENT(INOUT) :: & + gcr, gcz, gcl +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + INTEGER, PARAMETER :: n0=0, m0=0, m1=1 + INTEGER, PARAMETER :: n3d=0, nasym=1 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: nsfix, jedge, delIter + REAL(dp) :: r1, fac, tmp, tmp2(ns), ftotal + + INTEGER :: i, j, k, l, m, blksize, left, right + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + INTEGER :: MPI_STAT(MPI_STATUS_SIZE) + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: send_buf + REAL(dp), ALLOCATABLE, DIMENSION(:) :: recv_buf + REAL(dp) :: tredon, tredoff +!----------------------------------------------- + CALL second0 (treson) + +#ifdef _HBANGLE +!FREE-BDY RFP MAY NEED THIS TO IMPROVE CONVERGENCE (SPH 022514) + IF (lfreeb .AND. lrfp) THEN + fac = 0 + IF (ictrl_prec2d .EQ. 0) THEN + fac = 1.E-1_dp + END IF + gcz(ns,0,m0,:) = fac*gcz(ns,0,m0,:) + END IF +#else +! +! SYMMETRIC PERTURBATIONS (BASED ON POLAR RELATIONS): +! Rss(n) = Zcs(n), n != 0 +! ASYMMETRIC PERTURBATIONS: +! Rsc(n) = Zcc(n), ALL n +! +! INTERNALLY: +! XC(rss) = .5*(Rss + Zcs), XC(zcs) = .5*(Rss - Zcs) -> 0 +! XC(rsc) = .5*(Rsc + Zcc), XC(zcc) = .5*(Rsc - Zcc) -> 0 +! THIS IMPLIES THE CONSTRAINT +! 3D ONLY : GC(zcs) = 0; +! ASYM: GC(zcc) = 0 +! + + IF (lthreed) THEN + CALL constrain_m1_par(gcr(:,m1,:,rss), gcz(:,m1,:,zcs)) + END IF + IF (lasym) THEN + CALL constrain_m1_par(gcr(:,m1,:,rsc), gcz(:,m1,:,zcc)) + END IF + + IF (lfreeb .AND. lrfp) THEN + fac = 0 + IF (ictrl_prec2d .EQ. 0) THEN + fac = 1.E-1_dp + END IF + gcr(0,m0,ns,:) = fac*gcr(0,m0,ns,:) + gcz(0,m0,ns,:) = fac*gcz(0,m0,ns,:) + END IF +#endif + +! PRECONDITIONER MUST BE CALCULATED USING RAW (UNPRECONDITIONED) FORCES + IF (ictrl_prec2d .GE. 2 .OR. ictrl_prec2d .EQ. -1) RETURN + +! +! COMPUTE INVARIANT RESIDUALS +! + r1 = one/(2*r0scale)**2 + jedge = 0 + delIter = iter2-iter1 + + IF (delIter .lt. 50 .and. & + (fsqr + fsqz) .LT. 1.E-6_dp) THEN + jedge = 1 + ENDIF + + CALL getfsq_par (gcr, gcz, fsqr, fsqz, r1*fnorm, jedge) + + CALL second0(tredon) + tmp = SUM(gcl(:,:,tlglob:trglob,:)*gcl(:,:,tlglob:trglob,:)) + CALL MPI_Allreduce(tmp,ftotal,1,MPI_REAL8,MPI_SUM,NS_COMM,MPI_ERR) + CALL second0(tredoff) + allreduce_time = allreduce_time + (tredoff - tredon) + fsql = fnormL*ftotal + IF(rank .EQ. nranks-1) THEN + fedge = r1*fnorm*SUM(gcr(:,:,ns,:)**2 + gcz(:,:,ns,:)**2) + END IF +! +! PERFORM PRECONDITIONING AND COMPUTE RESIDUES +! + IF (ictrl_prec2d .EQ. 1) THEN + + IF (l_colscale .AND. lactive) THEN + CALL SAXLASTNTYPE(pgc, pcol_scale, pgc) + END IF + + LRESIDUECALL = .TRUE. + CALL block_precond_par(pgc) + LRESIDUECALL = .FALSE. + + IF (.NOT.lfreeb .AND. ANY(gcr(:,:,ns,:) .NE. zero)) THEN + STOP 'gcr(ns) != 0 for fixed boundary in residue' + END IF + IF (.NOT.lfreeb .AND. ANY(gcz(:,:,ns,:) .NE. zero)) THEN + STOP 'gcz(ns) != 0 for fixed boundary in residue' + END IF + IF (ANY(gcl(1:,m0,:,zsc) .NE. zero)) THEN + STOP 'gcl(m=0,n>0,sc) != 0 in residue' + END IF + IF (lthreed .AND. ANY(gcl(n0,:,:,zcs) .NE. zero)) THEN + STOP 'gcl(n=0,m,cs) != 0 in residue' + END IF + + fsqr1 = SUM(gcr*gcr) + fsqz1 = SUM(gcz*gcz) + fsql1 = SUM(gcl*gcl) + + ELSE +! m = 1 constraint scaling + + IF (lthreed) THEN + CALL scale_m1_par(gcr(:,m1,:,rss), gcz(:,m1,:,zcs)) + END IF + IF (lasym) THEN + CALL scale_m1_par(gcr(:,m1,:,rsc), gcz(:,m1,:,zcc)) + END IF + + jedge = 0 + CALL scalfor_par (gcr, arm, brm, ard, brd, crd, jedge) + jedge = 1 + CALL scalfor_par (gcz, azm, bzm, azd, bzd, crd, jedge) + + CALL getfsq_par (gcr, gcz, fsqr1, fsqz1, fnorm1, m1) + + DO l = tlglob, trglob + gcl(:,:,l,:) = pfaclam(:,:,l,:)*gcl(:,:,l,:) + tmp2(l) = SUM(gcl(:,:,l,:)**2) + END DO + CALL Gather1XArray(tmp2) + ftotal = SUM(tmp2(2:ns)) + fsql1 = hs*ftotal + + CALL PadSides(pgc) + + ENDIF + + CALL second0 (tresoff) + residue_time = residue_time + (tresoff-treson) + + END SUBROUTINE residue_par + + SUBROUTINE constrain_m1_par(gcr, gcz) + USE vmec_main + USE parallel_include_module + USE precon2d, ONLY: ictrl_prec2d + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,ns), INTENT(INOUT) :: gcr, gcz +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(dp), PARAMETER :: FThreshold = 1.E-6_dp + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: temp +!----------------------------------------------- +! +! COMPUTE INTERNAL gr, gz +! NOTE: internal gz => 0 for both values of lconm1 (although gz is different) +! FOR lconm1=T, gcr(internal) = gcr+gcz, gcz(internal) = gcr-gcz->0 +! + ALLOCATE(temp(0:ntor,ns)) + IF (lconm1) THEN + temp(:,tlglob:trglob) = gcr(:,tlglob:trglob) + gcr(:,tlglob:trglob) = osqrt2*(gcr(:,tlglob:trglob) + & + gcz(:,tlglob:trglob)) + gcz(:,tlglob:trglob) = osqrt2*(temp(:,tlglob:trglob) - & + gcz(:,tlglob:trglob)) + END IF + +!v8.50: ADD iter2<2 so reset= works + IF (fsqz .LT. FThreshold .OR. & + & iter2 .LT. 2 .OR. & + & ictrl_prec2d .NE. 0) THEN + gcz(:,tlglob:trglob) = 0 + END IF + + DEALLOCATE(temp) + END SUBROUTINE constrain_m1_par + + SUBROUTINE scale_m1_par(gcr, gcz) + USE vmec_main + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,ns), INTENT(inout) :: gcr, gcz +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + INTEGER, PARAMETER :: nodd=2 + INTEGER :: n + REAL(dp) :: fac(ns) +!----------------------------------------------- + IF (.not.lconm1) RETURN + + fac(tlglob:trglob) = (ard(tlglob:trglob,nodd) + & + brd(tlglob:trglob,nodd)) & + / (ard(tlglob:trglob,nodd) + & + brd(tlglob:trglob,nodd) + & + azd(tlglob:trglob,nodd) + & + bzd(tlglob:trglob,nodd)) + DO n = 0, ntor + gcr(n,tlglob:trglob) = fac(tlglob:trglob)*gcr(n,tlglob:trglob) + END DO + + fac(tlglob:trglob) = (azd(tlglob:trglob,nodd) + & + bzd(tlglob:trglob,nodd)) & + / (ard(tlglob:trglob,nodd) + & + brd(tlglob:trglob,nodd) + & + azd(tlglob:trglob,nodd) + & + bzd(tlglob:trglob,nodd)) + DO n = 0, ntor + gcz(n,tlglob:trglob) = fac(tlglob:trglob)*gcz(n,tlglob:trglob) + END DO + + END SUBROUTINE scale_m1_par + + SUBROUTINE residue (gcr, gcz, gcl) + USE vmec_main, p5 => cp5 + USE vmec_params, ONLY: rss, zcs, rsc, zcc, & + meven, modd, ntmax, signgs + USE realspace, ONLY: phip + USE xstuff + USE precon2d +#ifdef _HBANGLE + USE angle_constraints, ONLY: scalfor_rho +#endif + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntmax), INTENT(inout) :: & + gcr, gcz, gcl +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + INTEGER, PARAMETER :: n0=0, m0=0, m1=1 + INTEGER, PARAMETER :: n3d=0, nasym=1 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: nsfix, jedge, delIter + REAL(dp) :: r1, fac + INTEGER :: i, j, k, l +!----------------------------------------------- +! +! IMPOSE M=1 MODE CONSTRAINT TO MAKE THETA ANGLE +! INVARIANT TO PHI-SHIFTS (AND THETA SHIFTS FOR ASYMMETRIC CASE) +! (ZCS = RSS, ZSS = RCS ARE THE CORRECT POLAR RELATIONS) +! + +#ifdef _HBANGLE +!FREE-BDY RFP MAY NEED THIS TO IMPROVE CONVERGENCE (SPH 022514) + IF (lfreeb .AND. lrfp) THEN + fac = 0 + IF (ictrl_prec2d .EQ. 0) THEN + fac = 1.E-1_dp + END IF + gcz(ns,0,m0,:) = fac*gcz(ns,0,m0,:) + END IF +#else +! +! SYMMETRIC PERTURBATIONS (BASED ON POLAR RELATIONS): +! RSS(n) = ZCS(n), n != 0 +! ASYMMETRIC PERTURBATIONS: +! RSC(n) = ZCC(n), ALL n +! +! INTERNALLY: +! XC(rss) = .5*(Rss + Zcs), XC(zcs) = .5*(Rss - Zcs) -> 0 +! XC(rsc) = .5*(Rsc + Zcc), XC(zcc) = .5*(Rsc - Zcc) -> 0 +! THIS IMPLIES THE CONSTRAINT +! 3D ONLY : GC(zcs) = 0; +! ASYM: GC(zcc) = 0 +! + + IF (lthreed) THEN + CALL constrain_m1(gcr(:,:,m1,rss), gcz(:,:,m1,zcs)) + END IF + IF (lasym) THEN + CALL constrain_m1(gcr(:,:,m1,rsc), gcz(:,:,m1,zcc)) + END IF + +!FREE-BDY RFP MAY NEED THIS TO IMPROVE CONVERGENCE (SPH 022514) + IF (lfreeb .AND. lrfp) THEN + fac = 0 + IF (ictrl_prec2d .EQ. 0) THEN + fac = 1.E-1_dp + END IF + gcr(ns,0,m0,:) = fac*gcr(ns,0,m0,:) + gcz(ns,0,m0,:) = fac*gcz(ns,0,m0,:) + END IF +#endif + +! PRECONDITIONER MUST BE CALCULATED USING RAW (UNPRECONDITIONED) FORCES + IF (ictrl_prec2d .GE. 2 .OR. & + ictrl_prec2d .EQ. -1) THEN + RETURN + END IF + +! +! COMPUTE INVARIANT RESIDUALS +! + r1 = one/(2*r0scale)**2 + jedge = 0 +!SPH-JAH013108: MUST INCLUDE EDGE FORCE (INITIALLY) FOR V3FITA TO WORK +!ADD A V3FIT RELATED FLAG? ADD fsq criterion first + delIter = iter2 - iter1 + + IF (delIter .lt. 50 .and. & + (fsqr + fsqz) .lt. 1.E-6_dp) THEN + jedge = 1 + END IF + + CALL getfsq (gcr, gcz, fsqr, fsqz, r1*fnorm, jedge) + + fsql = fnormL*SUM(gcl*gcl) + fedge = r1*fnorm*SUM(gcr(ns,:,:,:)**2 + gcz(ns,:,:,:)**2) + +! +! PERFORM PRECONDITIONING AND COMPUTE RESIDUES +! + + IF (ictrl_prec2d .EQ. 1) THEN + + CALL block_precond(gc) + + IF (.not.lfreeb .and. ANY(gcr(ns,:,:,:) .ne. zero)) THEN + STOP 'gcr(ns) != 0 for fixed boundary in residue' + END IF + IF (.not.lfreeb .and. ANY(gcz(ns,:,:,:) .ne. zero)) THEN + STOP 'gcz(ns) != 0 for fixed boundary in residue' + END IF + IF (ANY(gcl(:,1:,0,zsc) .ne. zero)) THEN + STOP 'gcl(m=0,n>0,sc) != 0 in residue' + END IF + IF (lthreed .and. ANY(gcl(:,n0,:,zcs) .ne. zero)) THEN + STOP 'gcl(n=0,m,cs) != 0 in residue' + END IF + + fsqr1 = SUM(gcr*gcr) + fsqz1 = SUM(gcz*gcz) + fsql1 = SUM(gcl*gcl) + + ELSE +#ifdef _HBANGLE + CALL scalfor_rho(gcr, gcz) +#else +! m = 1 constraint scaling + IF (lthreed) THEN + CALL scale_m1(gcr(:,:,m1,rss), gcz(:,:,m1,zcs)) + END IF + IF (lasym) THEN + CALL scale_m1(gcr(:,:,m1,rsc), gcz(:,:,m1,zcc)) + END IF + + jedge = 0 + CALL scalfor (gcr, arm, brm, ard, brd, crd, jedge) + jedge = 1 + CALL scalfor (gcz, azm, bzm, azd, bzd, crd, jedge) +#endif + +!SPH: add fnorm1 ~ 1/R**2, since preconditioned forces gcr,gcz ~ Rmn or Zmn + CALL getfsq (gcr, gcz, fsqr1, fsqz1, fnorm1, m1) +#ifdef _HBANGLE +! +! TO IMPROVE CONVERGENCE, REDUCE FORCES INITIALLY IF THEY ARE TOO LARGE +! + fac = .5_dp + IF ((iter2 - iter1) .LT. 25 .AND. & + (fsqr + fsqz) .GT. 1.E-2_dp) THEN + fac = fac / SQRT(1.E2_dp*(fsqr+fsqz)) + END IF + gcr = fac*gcr + gcz = fac*gcz +#endif + +!SPH: THIS IS NOT INVARIANT UNDER PHIP->A*PHIP, AM->A**2*AM IN PROFIL1D +! (EXTCUR -> A*EXTCUR for FREE BOUNDARY) + + gcl = faclam*gcl + fsql1 = hs*SUM(gcl*gcl) +!030514 fsql1 = hs*lamscale**2*SUM(gcl*gcl) + + END IF + + END SUBROUTINE residue + + SUBROUTINE constrain_m1(gcr, gcz) + USE vmec_main + USE precon2d, ONLY: ictrl_prec2d + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor), INTENT(INOUT) :: gcr, gcz +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(dp), PARAMETER :: FThreshold = 1.E-6_dp + REAL(dp) :: temp(ns,0:ntor) +!----------------------------------------------- +! +! COMPUTE INTERNAL gr, gz +! NOTE: internal gz => 0 for both values of lconm1 (although gz is different) +! FOR lconm1=T, gcr(internal) = gcr+gcz, gcz(internal) = gcr-gcz->0 +! + IF (lconm1) THEN + temp = gcr + gcr = osqrt2*(gcr + gcz) + gcz = osqrt2*(temp - gcz) + END IF + +!v8.50: ADD iter2<2 so reset= works + IF (fsqz .LT. FThreshold .OR. & + & iter2 .LT. 2 .OR. & + & ictrl_prec2d .NE. 0) THEN + gcz = 0 + END IF + + END SUBROUTINE constrain_m1 + + SUBROUTINE scale_m1(gcr, gcz) + USE vmec_main + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor), INTENT(inout) :: gcr, gcz +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + INTEGER, PARAMETER :: nodd=2 + INTEGER :: n + REAL(dp) :: fac(ns) +!----------------------------------------------- + IF (.not.lconm1) RETURN + + fac = (ard(:,nodd) + brd(:,nodd)) & + / (ard(:,nodd) + brd(:,nodd) + azd(:,nodd) + bzd(:,nodd)) + DO n = 0, ntor + gcr(:,n) = fac*gcr(:,n) + END DO + + fac = (azd(:,nodd) + bzd(:,nodd)) & + / (ard(:,nodd) + brd(:,nodd) + azd(:,nodd) + bzd(:,nodd)) + DO n = 0, ntor + gcz(:,n) = fac*gcz(:,n) + END DO + + END SUBROUTINE scale_m1 + diff --git a/Sources/General/scalfor.f b/Sources/General/scalfor.f new file mode 100644 index 0000000..dc0751f --- /dev/null +++ b/Sources/General/scalfor.f @@ -0,0 +1,455 @@ + SUBROUTINE scalfor_par(gcx, axm, bxm, axd, bxd, cx, iflag) + USE vmec_main + USE vmec_params + USE vmec_dim, ONLY: ns + USE realspace, ONLY: wint, ru0 + USE parallel_include_module + USE parallel_vmec_module, ONLY: PadSides1X + USE xstuff, ONLY: pxc, pgc + IMPLICIT NONE +C----------------------------------------------- +C Dummy Arguments +C----------------------------------------------- + INTEGER, INTENT(IN) :: iflag + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntmax), + 1 INTENT(INOUT) :: gcx + REAL(dp), DIMENSION(ns+1,2), INTENT(INOUT) :: + 1 axm, bxm, axd, bxd + REAL(dp), DIMENSION(ns), INTENT(IN) :: cx +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), PARAMETER :: ftol_edge = 1.e-9_dp, c1p5 = 1.5_dp, + 1 fac = 0.25_dp, edge_pedestal = 0.05_dp + INTEGER :: m , mp, n, js, jmax, jmin4(0:mnsize-1) + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ax, bx, dx + REAL(dp) :: mult_fac + INTEGER :: nsmin, nsmax, i, j, k, l + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: send_buf2 + INTEGER :: MPI_STAT(MPI_STATUS_SIZE) + REAL(dp) :: tridslvton, tridslvtoff + REAL(dp) :: scalforton, scalfortoff +C----------------------------------------------- + IF (.NOT.lactive) RETURN + + DO i = 1, 2 + CALL PadSides1X(axm(:,i)) + CALL PadSides1X(bxm(:,i)) + END DO + + ALLOCATE (ax(0:ntor,0:mpol1,ns), bx(0:ntor,0:mpol1,ns), + 1 dx(0:ntor,0:mpol1,ns)) + ax(:,:,1) = 0; bx(:,:,1) = 0; dx(:,:,1) = 0 + ax(:,:,ns) = 0; bx(:,:,ns) = 0; dx(:,:,ns) = 0 + + jmax = ns + IF (ivac .lt. 1) THEN + jmax = ns1 + END IF + +! FOR SOME 3D PLASMAS, THIS SOMETIME HELPS (CHOOSE mult_fac =1 otherwise) +! TO AVOID JACOBIAN RESETS BY GIVING A SMOOTH TRANSITION FROM FIXED TO FREE ITERATIONS +! mult_fac = 1._dp/(1._dp + 10*(fsqr+fsqz)) +! gcx(ns,:,:,:) = mult_fac*gcx(ns,:,:,:) + + nsmax = MIN(trglob, jmax) + DO m = 0, mpol1 + nsmin = MAX(jmin2(m), tlglob) + mp = MOD(m,2) + 1 + DO n = 0, ntor + ax(n,m,tlglob:trglob) = 0 + bx(n,m,tlglob:trglob) = 0 + dx(n,m,tlglob:trglob) = 0 + DO js = nsmin, nsmax + ax(n,m,js) = -(axm(js+1,mp) + bxm(js+1,mp)*m**2) + bx(n,m,js) = -(axm(js,mp) + bxm(js,mp)*m**2) + dx(n,m,js) = -(axd(js,mp) + bxd(js,mp)*m**2 + & + cx(js)*(n*nfp)**2) + END DO + + IF (m .eq. 1 .and. nsmin .eq. 2) THEN + dx(n,m,2) = dx(n,m,2) + bx(n,m,2) + END IF + END DO + END DO + + IF (jmax .GE. ns) THEN +! +! SMALL EDGE PEDESTAL NEEDED TO IMPROVE CONVERGENCE +! IN PARTICULAR, NEEDED TO ACCOUNT FOR POTENTIAL ZERO +! EIGENVALUE DUE TO NEUMANN (GRADIENT) CONDITION AT EDGE +! + dx(:,0:1,ns) = (1 + edge_pedestal) *dx(:,0:1,ns) + dx(:,2:mpol1,ns) = (1 + 2*edge_pedestal)*dx(:,2:mpol1,ns) +! +! STABILIZATION ALGORITHM FOR ZC_00(NS) +! FOR UNSTABLE CASE, HAVE TO FLIP SIGN OF -FAC -> +FAC FOR CONVERGENCE +! COEFFICIENT OF < Ru (R Pvac)> ~ -fac*(z-zeq) WHERE fac (EIGENVALUE, OR +! FIELD INDEX) DEPENDS ON THE EQUILIBRIUM MAGNETIC FIELD AND CURRENT, +! AND zeq IS THE EQUILIBRIUM EDGE VALUE OF Z00 + mult_fac = MIN(fac, fac*hs*15) + IF (iflag .eq. 1) THEN +! +! METHOD 1: SUBTRACT (INSTABILITY) Pedge ~ fac*z/hs FROM PRECONDITIONER AT EDGE +! + dx(0,0,ns) = dx(0,0,ns)*(1 - mult_fac)/(1 + edge_pedestal) + END IF + + ENDIF +! +! ACCELERATE (IMPROVE) CONVERGENCE OF FREE BOUNDARY. THIS WAS ADDED +! TO DEAL WITH CASES WHICH MIGHT OTHERWISE DIVERGE. BY DECREASING THE +! FSQ TOLERANCE LEVEL WHERE THIS KICKS IN (FTOL_EDGE), THE USER CAN +! TURN-OFF THIS FEATURE +! +! DIAGONALIZE (DX DOMINANT) AND REDUCE FORCE (DX ENHANCED) AT EDGE +! TO IMPROVE CONVERGENCE FOR N != 0 TERMS +! + +! ledge = .false. +! IF ((fsqr+fsqz) .lt. ftol_edge) ledge = .true. +! IF ((iter2-iter1).lt.400 .or. ivac.lt.1) ledge = .false. + +! IF (ledge) THEN +! dx(ns,1:,1:) = 3*dx(ns,1:,1:) +! END IF + +! FOR DATA MATCHING MODE (0 <= IRESIDUE < 3), +! MAGNETIC AXIS IS FIXED SO JMIN3(0) => 2 FOR M=0,N=0 + + jmin4 = jmin3 + IF (iresidue .GE. 0 .AND. iresidue .LT. 3) THEN + jmin4(0) = 2 + END IF + +! Padsides moved to SUBROUTINE residue AFTER this completes + CALL second0(tridslvton) + CALL bst_parallel_tridiag_solver(ax,dx,bx,gcx,jmin4,jmax, + 1 mnsize - 1,ns,ntmax) + CALL second0(tridslvtoff) + tridslv_time = tridslv_time + (tridslvtoff-tridslvton) + + DEALLOCATE (ax, bx, dx) + + CALL second0(scalfortoff) +! scalfor_time = scalfor_time + (scalfortoff-scalforton) + + END SUBROUTINE scalfor_par + + SUBROUTINE bst_parallel_tridiag_solver(a, d, b, c, jmin, + 1 jmax, mnd1, ns, nrhs) + USE stel_kinds + USE parallel_include_module + USE blocktridiagonalsolver_bst, ONLY: SetMatrixRowColL_bst + USE blocktridiagonalsolver_bst, ONLY: SetMatrixRowColD_bst + USE blocktridiagonalsolver_bst, ONLY: SetMatrixRowColU_bst + USE blocktridiagonalsolver_bst, ONLY: ForwardSolve_bst + USE blocktridiagonalsolver_bst, ONLY: SetMatrixRHS_bst + USE blocktridiagonalsolver_bst, ONLY: BackwardSolve_bst + USE blocktridiagonalsolver_bst, ONLY: GetSolutionVector_bst + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: jmax, mnd1, ns, nrhs + INTEGER, DIMENSION(0:mnd1), INTENT(IN) :: jmin + REAL(dp), DIMENSION(0:mnd1,ns) :: a, d, b + REAL(dp), DIMENSION(0:mnd1,ns,nrhs), INTENT(INOUT) :: c +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: zero = 0, one = 1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mn, in0, in1, jrhs + INTEGER :: irow, icol, blklength, i, j + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: tmp + REAL(dp), ALLOCATABLE, DIMENSION(:) :: tmpv + REAL(dp), DIMENSION(0:mnd1) :: psi0 + REAL(dp) :: t1, t2 +C----------------------------------------------- +! SOLVES B(I)*X(I-1)+D(I)*X(I)+A(I)*X(I+1)=C(I), I=IN,JMAX +! AND RETURNS ANSWER IN C(I) + + CALL second0(t1) + IF (jmax .GT. ns) THEN + STOP 'jmax>ns in tridslv_par' + END IF + in0 = MINVAL(jmin) + DO mn = 0, mnd1 + in1 = jmin(mn)-1 + IF (in1 .ge. in0) THEN + d(mn, in0:in1) = 1 + b(mn, in0:in1) = 0 + a(mn, in0:in1) = 0 + c(mn, in0:in1, 1:nrhs) = 0 + END IF + END DO + + blklength=mnd1+1 + ALLOCATE(tmp(blklength,blklength)) + tmp=zero + CALL second0(t2) + init_time = init_time + (t2-t1) + + CALL second0(t1) + DO irow = tlglob, trglob + + ! Set up L + IF (irow .EQ. ns .AND. jmax .LT. ns) THEN + b(:,irow) = 0 + END IF + CALL SetMatrixRowColL_bst(irow,b(:,irow)) + + ! Set up D + IF (irow .EQ. ns .AND. jmax .LT. ns) THEN + d(:,irow) = 1 + END IF + CALL SetMatrixRowColD_bst(irow,d(:,irow)) + + ! Set up U + CALL SetMatrixRowColU_bst(irow,a(:,irow)) + END DO + CALL second0(t2) + setup_time = setup_time + (t2-t1) + + CALL second0(t1) + CALL ForwardSolve_bst + CALL second0(t2) + forwardsolve_time = forwardsolve_time + (t2-t1) + + ALLOCATE(tmpv(0:mnd1)) + CALL second0(t1) + DO jrhs = 1, nrhs + + ! Set RHS + DO irow = tlglob, trglob + tmpv(0:mnd1)=c(:,irow,jrhs) + IF (irow.EQ.ns.AND.jmax.LT.ns) tmpv(0:mnd1)=0 + CALL SetMatrixRHS_bst(irow,tmpv) + END DO + + ! Backward solve + CALL BackwardSolve_bst + + ! Get solution vector + DO irow = tlglob, trglob + CALL GetSolutionVector_bst(irow, tmpv) + c(:,irow,jrhs)=tmpv(0:mnd1) + END DO + + END DO + DEALLOCATE(tmp, tmpv) + CALL second0(t2) + backwardsolve_time = backwardsolve_time + (t2-t1) + + END SUBROUTINE bst_parallel_tridiag_solver + + SUBROUTINE scalfor(gcx, axm, bxm, axd, bxd, cx, iflag) + USE vmec_main + USE vmec_params + USE vmec_dim, ONLY: ns + USE realspace, ONLY: wint, ru0 + + IMPLICIT NONE +C----------------------------------------------- +C Dummy Arguments +C----------------------------------------------- + INTEGER, INTENT(in) :: iflag + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntmax), + 1 INTENT(inout) :: gcx + REAL(dp), DIMENSION(ns+1,2), INTENT(in) :: + 1 axm, bxm, axd, bxd + REAL(dp), DIMENSION(ns), INTENT(in) :: cx +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), PARAMETER :: ftol_edge = 1.e-9_dp, c1p5 = 1.5_dp, + 1 fac = 0.25_dp, edge_pedestal = 0.05_dp + INTEGER :: m , mp, n, js, jmax, jmin4(0:mnsize-1) + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: ax, bx, dx + REAL(dp) :: mult_fac + +C----------------------------------------------- + + ALLOCATE (ax(ns,0:ntor,0:mpol1), bx(ns,0:ntor,0:mpol1), + & dx(ns,0:ntor,0:mpol1)) + ax(1,:,:) = 0; bx(1,:,:) = 0; dx(1,:,:) = 0 + ax(ns,:,:) = 0; bx(ns,:,:) = 0; dx(ns,:,:) = 0 + + jmax = ns + IF (ivac .lt. 1) THEN + jmax = ns1 + END IF + +! FOR SOME 3D PLASMAS, THIS SOMETIME HELPS (CHOOSE mult_fac =1 otherwise) +! TO AVOID JACOBIAN RESETS BY GIVING A SMOOTH TRANSITION FROM FIXED TO FREE ITERATIONS +! mult_fac = 1._dp/(1._dp + 10*(fsqr+fsqz)) +! gcx(ns,:,:,:) = mult_fac*gcx(ns,:,:,:) + + DO m = 0, mpol1 + mp = MOD(m,2) + 1 + DO n = 0, ntor + DO js = jmin2(m), jmax + ax(js,n,m) = -(axm(js+1,mp) + bxm(js+1,mp)*m**2) + bx(js,n,m) = -(axm(js,mp) + bxm(js,mp)*m**2) + dx(js,n,m) = -(axd(js,mp) + bxd(js,mp)*m**2 + 1 + cx(js)*(n*nfp)**2) + END DO + + IF (m .eq. 1) THEN + dx(2,n,m) = dx(2,n,m) + bx(2,n,m) +!OFF 050311 DO js = jmin2(m), jmax +!OFF 050311 ax(js,n,m) = c1p5*ax(js,n,m) +!OFF 050311 bx(js,n,m) = c1p5*bx(js,n,m) +!OFF 050311 dx(js,n,m) = c1p5*dx(js,n,m) +!OFF 050311 END DO + END IF + END DO + END DO + + IF (jmax .ge. ns) THEN +! +! SMALL EDGE PEDESTAL NEEDED TO IMPROVE CONVERGENCE +! IN PARTICULAR, NEEDED TO ACCOUNT FOR POTENTIAL ZERO +! EIGENVALUE DUE TO NEUMANN (GRADIENT) CONDITION AT EDGE +! + dx(ns,:,0:1) = (1+edge_pedestal) *dx(ns,:,0:1) + dx(ns,:,2:mpol1) = (1+2*edge_pedestal)*dx(ns,:,2:mpol1) +! +! STABILIZATION ALGORITHM FOR ZC_00(NS) +! FOR UNSTABLE CASE, HAVE TO FLIP SIGN OF -FAC -> +FAC FOR CONVERGENCE +! COEFFICIENT OF < Ru (R Pvac)> ~ -fac*(z-zeq) WHERE fac (EIGENVALUE, OR +! FIELD INDEX) DEPENDS ON THE EQUILIBRIUM MAGNETIC FIELD AND CURRENT, +! AND zeq IS THE EQUILIBRIUM EDGE VALUE OF Z00 + mult_fac = MIN(fac, fac*hs*15) + IF (iflag .eq. 1) THEN +! +! METHOD 1: SUBTRACT (INSTABILITY) Pedge ~ fac*z/hs FROM PRECONDITIONER AT EDGE +! + dx(ns,0,0) = dx(ns,0,0)*(1-mult_fac)/(1+edge_pedestal) + END IF + END IF + + +! +! ACCELERATE (IMPROVE) CONVERGENCE OF FREE BOUNDARY. THIS WAS ADDED +! TO DEAL WITH CASES WHICH MIGHT OTHERWISE DIVERGE. BY DECREASING THE +! FSQ TOLERANCE LEVEL WHERE THIS KICKS IN (FTOL_EDGE), THE USER CAN +! TURN-OFF THIS FEATURE +! +! DIAGONALIZE (DX DOMINANT) AND REDUCE FORCE (DX ENHANCED) AT EDGE +! TO IMPROVE CONVERGENCE FOR N != 0 TERMS +! + +! ledge = .false. +! IF ((fsqr+fsqz) .lt. ftol_edge) ledge = .true. +! IF ((iter2-iter1).lt.400 .or. ivac.lt.1) ledge = .false. + +! IF (ledge) THEN +! dx(ns,1:,1:) = 3*dx(ns,1:,1:) +! END IF + +! FOR DATA MATCHING MODE (0 <= IRESIDUE < 3), +! MAGNETIC AXIS IS FIXED SO JMIN3(0) => 2 FOR M=0,N=0 + + jmin4 = jmin3 + IF (iresidue.GE.0 .and. iresidue.LT.3) THEN + jmin4(0) = 2 + END IF + +! SOLVES BX(I)*X(I-1)+DX(I)*X(I)+AX(I)*X(I+1)=GCX(I), I=JMIN4,JMAX +! AND RETURNS ANSWER IN GCX(I) + CALL serial_tridslv (ax, dx, bx, gcx, jmin4, jmax, mnsize - 1, + & ns, ntmax) + DEALLOCATE (ax, bx, dx) + + END SUBROUTINE scalfor + + SUBROUTINE serial_tridslv(a, d, b, c, jmin, jmax, mnd1, ns, nrhs) + USE stel_kinds + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: jmax, mnd1, ns, nrhs + INTEGER, DIMENSION(0:mnd1), INTENT(in) :: jmin + REAL(dp), DIMENSION(ns,0:mnd1) :: a, d, b + REAL(dp), DIMENSION(ns,0:mnd1, nrhs), INTENT(inout) :: c +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: zero = 0, one = 1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mn, in, i0, in1, jrhs + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: alf + REAL(dp), DIMENSION(0:mnd1) :: psi0 +C----------------------------------------------- +! +! SOLVES B(I)*X(I-1)+D(I)*X(I)+A(I)*X(I+1)=C(I), I=IN,JMAX +! AND RETURNS ANSWER IN C(I) +! ADDED VECTORIZATION ON FOURIER MODE ARGUMENT (01-2000) +! AND NEW ARGUMENT (NRHS) TO DO MULTIPLE RIGHT SIDES SIMULTANEOUSLY +! + IF (jmax .gt. ns) THEN + STOP 'jmax>ns in tridslv' + END IF + + ALLOCATE (alf(ns,0:mnd1), stat = in) + IF (in .ne. 0) THEN + STOP 'Allocation error in tridslv' + END IF + + in = MINVAL(jmin) +! +! FILL IN MN BELOW MAX(JMIN) WITH DUMMY VALUES +! TO ALLOW VECTORIZATION ON MN INDEX +! + DO mn = 0, mnd1 + in1 = jmin(mn)-1 + IF (in1 .ge. in) THEN + d(in:in1, mn) = 1 + c(in:in1, mn, 1:nrhs) = 0 + b(in:in1, mn) = 0 + a(in:in1, mn) = 0 + END IF + END DO + + in1 = in + 1 + + psi0(:)= d(in,:) + IF (ANY(psi0 .eq. zero)) THEN + STOP 'psi0 == 0 error in tridslv' + END IF + psi0 = one/psi0 + DO jrhs = 1, nrhs + c(in,:,jrhs) = c(in,:,jrhs)*psi0(:) + END DO + + DO i0 = in1,jmax + alf(i0-1,:) = a(i0-1,:)*psi0(:) + psi0 = d(i0,:) - b(i0,:)*alf(i0-1,:) + IF (ANY(ABS(psi0) .le. 1.E-8_dp*ABS(d(i0,:)))) THEN + STOP 'psi0/d(i0) < 1.E-8: possible singularity in tridslv' + END IF + psi0 = one/psi0 + DO jrhs = 1, nrhs + c(i0,:,jrhs) = (c(i0,:,jrhs) - b(i0,:)*c(i0-1,:,jrhs))*psi0 + END DO + END DO + + DO i0 = jmax - 1, in, -1 + DO jrhs = 1,nrhs + c(i0,:,jrhs) = c(i0,:,jrhs) - alf(i0,:)*c(i0+1,:,jrhs) + END DO + END DO + + DEALLOCATE (alf) + + END SUBROUTINE serial_tridslv + diff --git a/Sources/General/spectrum.f b/Sources/General/spectrum.f new file mode 100644 index 0000000..f73657c --- /dev/null +++ b/Sources/General/spectrum.f @@ -0,0 +1,110 @@ + SUBROUTINE spectrum_par(rmn, zmn) + USE parallel_include_module + USE vmec_main + USE vmec_params, ONLY: mscale, nscale, ntmax, rss, zcs, rsc, zcc + USE totzsp_mod, ONLY: convert_sym, convert_asym + USE totzsp_mod, ONLY: convert_sym_par, convert_asym_par + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntmax), + 1 INTENT(inout) :: rmn, zmn +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, PARAMETER :: m1 = 1 + INTEGER :: js, ntype, n, m, nsmin, nsmax + REAL(dp), DIMENSION(ns) :: t1, dnumer, denom + REAL(dp) :: scale +C----------------------------------------------- +! +! CONVERT FROM INTERNAL XC REPRESENTATION FOR m=1 MODES, R+(at rsc) = .5(rsc + zcc), +! R-(at zcc) = .5(rsc - zcc), TO REQUIRED rsc, zcc FORMS +! + nsmin=MAX(2,tlglob); nsmax=MIN(t1rglob,ns) +#ifndef _HBANGLE + IF (lthreed) THEN + CALL convert_sym_par(rmn(:,m1,:,rss), zmn(:,m1,:,zcs), + & nsmin, nsmax) + END IF + IF (lasym) THEN + CALL convert_asym_par(rmn(:,m1,:,rsc), zmn(:,m1,:,zcc), + & nsmin, nsmax) + END IF +#endif + dnumer(nsmin:nsmax) = zero + denom(nsmin:nsmax) = zero + DO ntype = 1,ntmax + DO n = 0,ntor + DO m = 1,mpol1 + scale = (mscale(m)*nscale(n))**2 + DO js = nsmin,nsmax + t1(js) = (rmn(n,m,js,ntype)**2 + + & zmn(n,m,js,ntype)**2)*scale + END DO + dnumer(nsmin:nsmax) = dnumer(nsmin:nsmax) + & + t1(nsmin:nsmax)*xmpq(m,3) + denom(nsmin:nsmax) = denom (nsmin:nsmax) + & + t1(nsmin:nsmax)*xmpq(m,2) + END DO + END DO + END DO + + specw(nsmin:nsmax) = dnumer(nsmin:nsmax)/denom(nsmin:nsmax) + + END SUBROUTINE spectrum_par + + SUBROUTINE spectrum(rmn, zmn) + USE vmec_main + USE vmec_params, ONLY: mscale, nscale, ntmax, rss, zcs, rsc, zcc + USE totzsp_mod, ONLY: convert_sym, convert_asym + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntmax), + 1 INTENT(inout) :: rmn, zmn +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, PARAMETER :: m1 = 1 + INTEGER :: js, ntype, n, m, nsmin, nsmax + REAL(dp), DIMENSION(ns) :: t1, dnumer, denom + REAL(dp) :: scale +C----------------------------------------------- +! +! CONVERT FROM INTERNAL XC REPRESENTATION FOR m=1 MODES, R+(at rsc) = .5(rsc + zcc), +! R-(at zcc) = .5(rsc - zcc), TO REQUIRED rsc, zcc FORMS +! + nsmin=MAX(2,tlglob) + nsmax=MIN(t1rglob,ns) +#ifndef _HBANGLE + IF (lthreed) THEN + CALL convert_sym(rmn(:,:,m1,rss), zmn(:,:,m1,zcs)) + END IF + IF (lasym) THEN + CALL convert_asym(rmn(:,:,m1,rsc), zmn(:,:,m1,zcc)) + END IF +#endif + dnumer(2:ns) = zero + denom(2:ns) = zero + DO ntype = 1,ntmax + DO n = 0,ntor + DO m = 1,mpol1 + scale = (mscale(m)*nscale(n))**2 + DO js = 2,ns + t1(js) =(rmn(js,n,m,ntype)**2 + + & zmn(js,n,m,ntype)**2)*scale + END DO + dnumer(2:ns) = dnumer(2:ns) + t1(2:ns)*xmpq(m,3) + denom (2:ns) = denom (2:ns) + t1(2:ns)*xmpq(m,2) + END DO + END DO + END DO + + specw(2:ns) = dnumer(2:ns)/denom(2:ns) + + END SUBROUTINE spectrum diff --git a/Sources/General/symforce.f b/Sources/General/symforce.f new file mode 100644 index 0000000..9cd34fb --- /dev/null +++ b/Sources/General/symforce.f @@ -0,0 +1,400 @@ + SUBROUTINE symforce_par(ars, brs, crs, azs, bzs, czs, bls, cls, + & rcs, zcs, ara, bra, cra, aza, bza, cza, + & bla, cla, rca, zca) + USE vmec_main, p5 => cp5 + USE realspace, ONLY: ireflect_par + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), + & INTENT(inout) :: ars, brs, crs, azs, bzs, czs, + & bls, cls, rcs, zcs + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(out) :: + & ara, bra, cra, aza, bza, cza, bla, cla, rca, zca +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mpar, ir, i, jk, jka + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: ars_0, brs_0, azs_0, + & bzs_0, bls_0, rcs_0, zcs_0, crs_0, czs_0, cls_0 + INTEGER :: nsmin, nsmax, j, k +C----------------------------------------------- + CALL second0(tforon) + nsmin=t1lglob + nsmax=t1rglob + + ALLOCATE (ars_0(nzeta,ns), brs_0(nzeta,ns), azs_0(nzeta,ns), + & bzs_0(nzeta,ns), bls_0(nzeta,ns), rcs_0(nzeta,ns), + & zcs_0(nzeta,ns), crs_0(nzeta,ns), czs_0(nzeta,ns), + & cls_0(nzeta,ns), stat=ir) + +! +! SYMMETRIZE FORCES ON RESTRICTED THETA INTERVAL (0 <= u <= pi) +! SO COS,SIN INTEGRALS CAN BE PERFORMED. FOR EXAMPLE, +! +! ARS(v,u) = .5*( ARS(v,u) + ARS(-v,-u) ) ! * COS(mu - nv) +! ARA(v,u) = .5*( ARS(v,u) - ARS(-v,-u) ) ! * SIN(mu - nv) +! +! + DO k = nsmin, nsmax + DO mpar = 0, 1 + DO i = 1, ntheta2 + ir = ntheta1 + 2 - i !-theta + IF (i .eq. 1) THEN + ir = 1 + END IF + DO j = 1, nzeta + jka = ireflect_par(j) !-zeta + ara(j,i,k,mpar) = p5*(ars(j,i,k,mpar) - + & ars(jka,ir,k,mpar)) + ars_0(j,k) = p5*(ars(j,i,k,mpar) + + & ars(jka,ir,k,mpar)) + bra(j,i,k,mpar) = p5*(brs(j,i,k,mpar) + + & brs(jka,ir,k,mpar)) + brs_0(j,k) = p5*(brs(j,i,k,mpar) - + & brs(jka,ir,k,mpar)) + aza(j,i,k,mpar) = p5*(azs(j,i,k,mpar) + + & azs(jka,ir,k,mpar)) + azs_0(j,k) = p5*(azs(j,i,k,mpar) - + & azs(jka,ir,k,mpar)) + bza(j,i,k,mpar) = p5*(bzs(j,i,k,mpar) - + & bzs(jka,ir,k,mpar)) + bzs_0(j,k) = p5*(bzs(j,i,k,mpar) + + & bzs(jka,ir,k,mpar)) + bla(j,i,k,mpar) = p5*(bls(j,i,k,mpar) - + & bls(jka,ir,k,mpar)) + bls_0(j,k) = p5*(bls(j,i,k,mpar) + + & bls(jka,ir,k,mpar)) + rca(j,i,k,mpar) = p5*(rcs(j,i,k,mpar) - + & rcs(jka,ir,k,mpar)) + rcs_0(j,k) = p5*(rcs(j,i,k,mpar) + + & rcs(jka,ir,k,mpar)) + zca(j,i,k,mpar) = p5*(zcs(j,i,k,mpar) + + & zcs(jka,ir,k,mpar)) + zcs_0(j,k) = p5*(zcs(j,i,k,mpar) - + & zcs(jka,ir,k,mpar)) + END DO + + ars(:,i,k,mpar) = ars_0(:,k) + brs(:,i,k,mpar) = brs_0(:,k) + azs(:,i,k,mpar) = azs_0(:,k) + bzs(:,i,k,mpar) = bzs_0(:,k) + bls(:,i,k,mpar) = bls_0(:,k) + rcs(:,i,k,mpar) = rcs_0(:,k) + zcs(:,i,k,mpar) = zcs_0(:,k) + + IF (lthreed) THEN + DO j = 1, nzeta + jka = ireflect_par(j) + cra(j,i,k,mpar)= p5*(crs(j,i,k,mpar) + + & crs(jka,ir,k,mpar)) + crs_0(j,k) = p5*(crs(j,i,k,mpar) - + & crs(jka,ir,k,mpar)) + cza(j,i,k,mpar)= p5*(czs(j,i,k,mpar) - + & czs(jka,ir,k,mpar)) + czs_0(j,k) = p5*(czs(j,i,k,mpar) + + & czs(jka,ir,k,mpar)) + cla(j,i,k,mpar)= p5*(cls(j,i,k,mpar) - + & cls(jka,ir,k,mpar)) + cls_0(j,k) = p5*(cls(j,i,k,mpar) + + & cls(jka,ir,k,mpar)) + END DO + + crs(:,i,k,mpar) = crs_0(:,k) + czs(:,i,k,mpar) = czs_0(:,k) + cls(:,i,k,mpar) = cls_0(:,k) + END IF + + END DO + END DO + END DO + + DEALLOCATE (ars_0, brs_0, azs_0, bzs_0, bls_0, + 1 rcs_0, zcs_0, crs_0, czs_0, cls_0, stat=ir) + + CALL second0(tforoff) + symforces_time = symforces_time + (tforoff - tforon) + timer(tfor) = timer(tfor) + (tforoff - tforon) + + END SUBROUTINE symforce_par + + SUBROUTINE symforce(ars, brs, crs, azs, bzs, czs, bls, cls, rcs, + & zcs, ara, bra, cra, aza, bza, cza, bla, cla, + & rca, zca) + USE vmec_main, p5 => cp5 + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(inout) :: + & ars, brs, crs, azs, bzs, czs, bls, cls, rcs, zcs + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(out) :: + & ara, bra, cra, aza, bza, cza, bla, cla, rca, zca +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mpar, ir, i, jk, jka + REAL(dp), DIMENSION(:), ALLOCATABLE :: ars_0, brs_0, azs_0, + & bzs_0, bls_0, rcs_0, zcs_0, crs_0, czs_0, cls_0 +C----------------------------------------------- + CALL second0(tforon) + i = ns*nzeta + ALLOCATE (ars_0(i), brs_0(i), azs_0(i), bzs_0(i), bls_0(i), + & rcs_0(i), zcs_0(i), crs_0(i), czs_0(i), cls_0(i), + & stat=ir) + +! +! SYMMETRIZE FORCES ON RESTRICTED THETA INTERVAL (0 <= u <= pi) +! SO COS,SIN INTEGRALS CAN BE PERFORMED. FOR EXAMPLE, +! +! ARS(v,u) = .5*( ARS(v,u) + ARS(-v,-u) ) ! * COS(mu - nv) +! ARA(v,u) = .5*( ARS(v,u) - ARS(-v,-u) ) ! * SIN(mu - nv) +! +! + DO mpar = 0, 1 + DO i = 1, ntheta2 + ir = ntheta1 + 2 - i !-theta + IF (i .eq. 1) THEN + ir = 1 + END IF + DO jk = 1, ns*nzeta + jka = ireflect(jk) !-zeta + ara(jk,i,mpar) = p5*(ars(jk,i,mpar) - ars(jka,ir,mpar)) + ars_0(jk) = p5*(ars(jk,i,mpar) + ars(jka,ir,mpar)) + bra(jk,i,mpar) = p5*(brs(jk,i,mpar) + brs(jka,ir,mpar)) + brs_0(jk) = p5*(brs(jk,i,mpar) - brs(jka,ir,mpar)) + aza(jk,i,mpar) = p5*(azs(jk,i,mpar) + azs(jka,ir,mpar)) + azs_0(jk) = p5*(azs(jk,i,mpar) - azs(jka,ir,mpar)) + bza(jk,i,mpar) = p5*(bzs(jk,i,mpar) - bzs(jka,ir,mpar)) + bzs_0(jk) = p5*(bzs(jk,i,mpar) + bzs(jka,ir,mpar)) + bla(jk,i,mpar) = p5*(bls(jk,i,mpar) - bls(jka,ir,mpar)) + bls_0(jk) = p5*(bls(jk,i,mpar) + bls(jka,ir,mpar)) + rca(jk,i,mpar) = p5*(rcs(jk,i,mpar) - rcs(jka,ir,mpar)) + rcs_0(jk) = p5*(rcs(jk,i,mpar) + rcs(jka,ir,mpar)) + zca(jk,i,mpar) = p5*(zcs(jk,i,mpar) + zcs(jka,ir,mpar)) + zcs_0(jk) = p5*(zcs(jk,i,mpar) - zcs(jka,ir,mpar)) + END DO + + ars(:,i,mpar) = ars_0(:) + brs(:,i,mpar) = brs_0(:) + azs(:,i,mpar) = azs_0(:) + bzs(:,i,mpar) = bzs_0(:) + bls(:,i,mpar) = bls_0(:) + rcs(:,i,mpar) = rcs_0(:) + zcs(:,i,mpar) = zcs_0(:) + + IF (lthreed) THEN + DO jk = 1, ns*nzeta + jka = ireflect(jk) + cra(jk,i,mpar) = p5*(crs(jk,i,mpar) + + & crs(jka,ir,mpar)) + crs_0(jk) = p5*(crs(jk,i,mpar) - + & crs(jka,ir,mpar)) + cza(jk,i,mpar) = p5*(czs(jk,i,mpar) - + & czs(jka,ir,mpar)) + czs_0(jk) = p5*(czs(jk,i,mpar) + + & czs(jka,ir,mpar)) + cla(jk,i,mpar) = p5*(cls(jk,i,mpar) - + & cls(jka,ir,mpar)) + cls_0(jk) = p5*(cls(jk,i,mpar) + + & cls(jka,ir,mpar)) + END DO + + crs(:,i,mpar) = crs_0(:) + czs(:,i,mpar) = czs_0(:) + cls(:,i,mpar) = cls_0(:) + END IF + + END DO + END DO + + DEALLOCATE (ars_0, brs_0, azs_0, bzs_0, bls_0, + 1 rcs_0, zcs_0, crs_0, czs_0, cls_0, stat=ir) + + + CALL second0(tforoff) + s_symforces_time = s_symforces_time + (tforoff - tforon) + timer(tfor) = timer(tfor) + (tforoff - tforon) + + END SUBROUTINE symforce + + SUBROUTINE symoutput(bsq, gsqrt , bsubu , bsubv ,bsupu, + & bsupv, bsubs, +#ifdef _ANIMEC + & ppar, pperp, densit, sigma_an, tau_an, + & pbprim, ppprim, +#endif + & bsqa, gsqrta, bsubua, bsubva, bsupua, + & bsupva, bsubsa +#ifdef _ANIMEC + & , ppara, pperpa, densita, sigma_ana, tau_ana, + & pbprima, ppprima +#endif + & ) + + USE vmec_main, p5 => cp5 + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(inout) :: + & bsq, gsqrt, bsubu, bsubv, bsupu, bsupv, bsubs +#ifdef _ANIMEC + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(inout) :: + & ppar, pperp, sigma_an, tau_an, pbprim, ppprim, densit +#endif + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(out) :: + & bsqa,gsqrta,bsubua,bsubva,bsupua,bsupva,bsubsa +#ifdef _ANIMEC + REAL(dp), DIMENSION(ns*nzeta,ntheta3), INTENT(out) :: + & ppara, pperpa, sigma_ana, tau_ana, pbprima, ppprima, + & densita +#endif +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ir, i, jk, jka + REAL(dp), DIMENSION(ns*nzeta) :: bsq_0, gsqrt_0, bsubu_0, + & bsubv_0, bsupu_0, bsupv_0, bsubs_0 +#ifdef _ANIMEC + REAL(dp), DIMENSION(ns*nzeta) :: ppar_0, pperp_0, + & sigma_an0 , tau_an0 , pbprim_0, ppprim_0, densit_0 +#endif +C----------------------------------------------- + +! +! SYMMETRIZE FORCES ON RESTRICTED THETA INTERVAL (0 <= u <= pi) +! SO COS,SIN INTEGRALS CAN BE PERFORMED. FOR EXAMPLE, +! +! BSQ-S(v,u) = .5*( BSQ(v,u) + BSQ(-v,-u) ) ! * COS(mu - nv) +! BSQ-A(v,u) = .5*( BSQ(v,u) - BSQ(-v,-u) ) ! * SIN(mu - nv) +! +! FOR BSUBS, THIS IS REVERSED, S-PIECE ~ SIN, A-PIECE ~ COS +! +! + DO i = 1, ntheta2 + ir = ntheta1 + 2 - i !-theta + IF (i == 1) THEN + ir = 1 + END IF + DO jk = 1, ns*nzeta + jka = ireflect(jk) !-zeta + bsqa(jk,i) = p5*(bsq(jk,i) - bsq(jka,ir)) + bsq_0(jk) = p5*(bsq(jk,i) + bsq(jka,ir)) + gsqrta(jk,i) = p5*(gsqrt(jk,i) - gsqrt(jka,ir)) + gsqrt_0(jk) = p5*(gsqrt(jk,i) + gsqrt(jka,ir)) + bsubua(jk,i) = p5*(bsubu(jk,i) - bsubu(jka,ir)) + bsubu_0(jk) = p5*(bsubu(jk,i) + bsubu(jka,ir)) + bsubva(jk,i) = p5*(bsubv(jk,i) - bsubv(jka,ir)) + bsubv_0(jk) = p5*(bsubv(jk,i) + bsubv(jka,ir)) + bsupua(jk,i) = p5*(bsupu(jk,i) - bsupu(jka,ir)) + bsupu_0(jk) = p5*(bsupu(jk,i) + bsupu(jka,ir)) + bsupva(jk,i) = p5*(bsupv(jk,i) - bsupv(jka,ir)) + bsupv_0(jk) = p5*(bsupv(jk,i) + bsupv(jka,ir)) +#ifdef _ANIMEC + sigma_ana(jk,i) = p5*(sigma_an(jk,i) - sigma_an(jka,ir)) + sigma_an0(jk) = p5*(sigma_an(jk,i) + sigma_an(jka,ir)) + tau_ana(jk,i) = p5*(tau_an(jk,i) - tau_an(jka,ir)) + tau_an0(jk) = p5*(tau_an(jk,i) + tau_an(jka,ir)) + ppara(jk,i) = p5*(ppar(jk,i) - ppar(jka,ir)) + ppar_0(jk) = p5*(ppar(jk,i) + ppar(jka,ir)) + pperpa(jk,i) = p5*(pperp(jk,i) - pperp(jka,ir)) + pperp_0(jk) = p5*(pperp(jk,i) + pperp(jka,ir)) + pbprima(jk,i) = p5*(pbprim(jk,i) - pbprim(jka,ir)) + pbprim_0(jk) = p5*(pbprim(jk,i) + pbprim(jka,ir)) + ppprima(jk,i) = p5*(ppprim(jk,i) - ppprim(jka,ir)) + ppprim_0(jk) = p5*(ppprim(jk,i) + ppprim(jka,ir)) + densita(jk,i) = p5*(densit(jk,i) - densit(jka,ir)) + densit_0(jk) = p5*(densit(jk,i) + densit(jka,ir)) +#endif +! Dominant symmetry reversed + bsubsa(jk,i) = p5*(bsubs(jk,i) + bsubs(jka,ir)) + bsubs_0(jk) = p5*(bsubs(jk,i) - bsubs(jka,ir)) + END DO + + bsq(:,i) = bsq_0(:) + gsqrt(:,i) = gsqrt_0(:) + bsubu(:,i) = bsubu_0(:) + bsubv(:,i) = bsubv_0(:) + bsupu(:,i) = bsupu_0(:) + bsupv(:,i) = bsupv_0(:) + bsubs(:,i) = bsubs_0(:) +#ifdef _ANIMEC + sigma_an(:,i) = sigma_an0(:) + tau_an(:,i) = tau_an0(:) + ppar(:,i) = ppar_0(:) + pperp(:,i) = pperp_0(:) + pbprim(:,i) = pbprim_0(:) + ppprim(:,i) = ppprim_0(:) + densit(:,i) = densit_0(:) +#endif + + END DO + + END SUBROUTINE symoutput + +! Put the surface routines in a separate subroutine since these the quantites +! these work on only exist on free boundary runs. + SUBROUTINE symoutput_sur(bsubu, bsubv, bsupu, bsupv, & + & bsubua, bsubva, bsupua, bsupva) + USE vmec_main, p5 => cp5 + + IMPLICIT NONE + +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nzeta,ntheta3), INTENT(inout) :: + 1 bsubu, bsubv, bsupu, bsupv + REAL(dp), DIMENSION(nzeta,ntheta2), INTENT(out) :: + 1 bsubua, bsubva, bsupua, bsupva + +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ir, i, jk, jka + REAL(dp), DIMENSION(nzeta) :: bsubu_0, bsubv_0, + 1 bsupu_0, bsupv_0 +C----------------------------------------------- + +! +! SYMMETRIZE FORCES ON RESTRICTED THETA INTERVAL (0 <= u <= pi) +! SO COS,SIN INTEGRALS CAN BE PERFORMED. FOR EXAMPLE, +! +! BSQ-S(v,u) = .5*( BSQ(v,u) + BSQ(-v,-u) ) ! * COS(mu - nv) +! BSQ-A(v,u) = .5*( BSQ(v,u) - BSQ(-v,-u) ) ! * SIN(mu - nv) +! +! FOR BSUBS, THIS IS REVERSED, S-PIECE ~ SIN, A-PIECE ~ COS +! +! + + ir = 1 !-theta + DO i = 1, ntheta2 + jka = 1 !-zeta + DO jk = 1, nzeta + bsubua(jk,i) = p5*(bsubu(jk,i) - bsubu(jka,ir)) + bsubu_0(jk) = p5*(bsubu(jk,i) + bsubu(jka,ir)) + bsubva(jk,i) = p5*(bsubv(jk,i) - bsubv(jka,ir)) + bsubv_0(jk) = p5*(bsubv(jk,i) + bsubv(jka,ir)) + bsupua(jk,i) = p5*(bsupu(jk,i) - bsupu(jka,ir)) + bsupu_0(jk) = p5*(bsupu(jk,i) + bsupu(jka,ir)) + bsupva(jk,i) = p5*(bsupv(jk,i) - bsupv(jka,ir)) + bsupv_0(jk) = p5*(bsupv(jk,i) + bsupv(jka,ir)) + jka = nzeta - jk + 1 + + END DO + ir = ntheta3 - i + 1 + + bsubu(:,i) = bsubu_0(:) + bsubv(:,i) = bsubv_0(:) + bsupu(:,i) = bsupu_0(:) + bsupv(:,i) = bsupv_0(:) + + END DO + + END SUBROUTINE symoutput_sur diff --git a/Sources/General/symrzl.f b/Sources/General/symrzl.f new file mode 100644 index 0000000..922cbfe --- /dev/null +++ b/Sources/General/symrzl.f @@ -0,0 +1,163 @@ + SUBROUTINE symrzl_par(r1s, rus, rvs, z1s, zus, zvs, lus, lvs, + 1 rcons, zcons, r1a, rua, rva, z1a, zua, zva, lua, lva, rcona, + 2 zcona) + USE vmec_main + USE realspace, ONLY: ireflect_par + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(inout) :: + 1 r1s, rus, rvs, z1s, zus, zvs, lus, lvs, rcons, zcons + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(in) :: + 1 r1a, rua, rva, z1a, zua, zva, lua, lva, rcona, zcona +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mpar, ir, i, jk, jka, n2 + INTEGER :: j, k, nsmin, nsmax + REAL(dp) :: tsymon, tsymoff +C----------------------------------------------- +! +! FIRST SUM SYMMETRIC, ANTISYMMETRIC PIECES ON EXTENDED INTERVAL, THETA = [PI,2*PI] +! + CALl second0(tsymon) + nsmin = t1lglob + nsmax = t1rglob + + DO k = nsmin, nsmax + DO mpar = 0, 1 + DO i = 1 + ntheta2, ntheta1 + ir = ntheta1 + 2 - i !-theta + DO j = 1, nzeta + jka = ireflect_par(j) !-zeta + r1s(j,i,k,mpar) = r1s(jka,ir,k,mpar) + & - r1a(jka,ir,k,mpar) + rus(j,i,k,mpar) = rua(jka,ir,k,mpar) + & - rus(jka,ir,k,mpar) + z1s(j,i,k,mpar) = z1a(jka,ir,k,mpar) + & - z1s(jka,ir,k,mpar) + zus(j,i,k,mpar) = zus(jka,ir,k,mpar) + & - zua(jka,ir,k,mpar) + lus(j,i,k,mpar) = lus(jka,ir,k,mpar) + & - lua(jka,ir,k,mpar) + rcons(j,i,k,mpar) = rcons(jka,ir,k,mpar) + & - rcona(jka,ir,k,mpar) + zcons(j,i,k,mpar) = zcona(jka,ir,k,mpar) + & - zcons(jka,ir,k,mpar) + END DO + IF (lthreed) THEN + DO j = 1, nzeta + jka = ireflect_par(j) !-zeta + rvs(j,i,k,mpar) = rva(jka,ir,k,mpar) + & - rvs(jka,ir,k,mpar) + zvs(j,i,k,mpar) = zvs(jka,ir,k,mpar) + & - zva(jka,ir,k,mpar) + lvs(j,i,k,mpar) = lvs(jka,ir,k,mpar) + & - lva(jka,ir,k,mpar) + END DO + END IF + END DO + +! +! NOW SUM SYMMETRIC, ANTISYMMETRIC PIECES FOR THETA = [0,PI] +! + n2 = ntheta2 + r1s(:,:n2,k,mpar) = r1s(:,:n2,k,mpar) + r1a(:,:n2,k,mpar) + rus(:,:n2,k,mpar) = rus(:,:n2,k,mpar) + rua(:,:n2,k,mpar) + z1s(:,:n2,k,mpar) = z1s(:,:n2,k,mpar) + z1a(:,:n2,k,mpar) + zus(:,:n2,k,mpar) = zus(:,:n2,k,mpar) + zua(:,:n2,k,mpar) + lus(:,:n2,k,mpar) = lus(:,:n2,k,mpar) + lua(:,:n2,k,mpar) + rcons(:,:n2,k,mpar) = rcons(:,:n2,k,mpar) + & + rcona(:,:n2,k,mpar) + zcons(:,:n2,k,mpar) = zcons(:,:n2,k,mpar) + & + zcona(:,:n2,k,mpar) + IF (lthreed) THEN + rvs(:,:n2,k,mpar) = rvs(:,:n2,k,mpar) + & + rva(:,:n2,k,mpar) + zvs(:,:n2,k,mpar) = zvs(:,:n2,k,mpar) + & + zva(:,:n2,k,mpar) + lvs(:,:n2,k,mpar) = lvs(:,:n2,k,mpar) + & + lva(:,:n2,k,mpar) + END IF + + END DO + END DO + + CALl second0(tsymoff) + symrzl_time = symrzl_time + (tsymoff - tsymon) + + END SUBROUTINE symrzl_par + + SUBROUTINE symrzl(r1s, rus, rvs, z1s, zus, zvs, lus, lvs, rcons, + & zcons, r1a, rua, rva, z1a, zua, zva, lua, lva, + & rcona, zcona) + USE vmec_main + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(inout) :: + 1 r1s, rus, rvs, z1s, zus, zvs, lus, lvs, rcons, zcons + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(in) :: + 1 r1a, rua, rva, z1a, zua, zva, lua, lva, rcona, zcona +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mpar, ir, i, jk, jka, n2 + INTEGER :: j, k, nsmin, nsmax + REAL(dp) :: tsymon, tsymoff +C----------------------------------------------- +! +! FIRST SUM SYMMETRIC, ANTISYMMETRIC PIECES ON EXTENDED INTERVAL, THETA = [PI,2*PI] +! + CALl second0(tsymon) + DO mpar = 0, 1 + DO i = 1 + ntheta2, ntheta1 + ir = ntheta1 + 2 - i !-theta + DO jk = 1, ns*nzeta + jka = ireflect(jk) !-zeta + r1s(jk,i,mpar) = r1s(jka,ir,mpar) - r1a(jka,ir,mpar) + rus(jk,i,mpar) = rua(jka,ir,mpar) - rus(jka,ir,mpar) + z1s(jk,i,mpar) = z1a(jka,ir,mpar) - z1s(jka,ir,mpar) + zus(jk,i,mpar) = zus(jka,ir,mpar) - zua(jka,ir,mpar) + lus(jk,i,mpar) = lus(jka,ir,mpar) - lua(jka,ir,mpar) + rcons(jk,i,mpar) = rcons(jka,ir,mpar) + & - rcona(jka,ir,mpar) + zcons(jk,i,mpar) = zcona(jka,ir,mpar) + & - zcons(jka,ir,mpar) + END DO + IF (lthreed) THEN + DO jk = 1, ns*nzeta + jka = ireflect(jk) + rvs(jk,i,mpar) = rva(jka,ir,mpar) - rvs(jka,ir,mpar) + zvs(jk,i,mpar) = zvs(jka,ir,mpar) - zva(jka,ir,mpar) + lvs(jk,i,mpar) = lvs(jka,ir,mpar) - lva(jka,ir,mpar) + END DO + ENDIF + END DO + +! +! NOW SUM SYMMETRIC, ANTISYMMETRIC PIECES FOR THETA = [0,PI] +! + n2 = ntheta2 + r1s(:,:n2,mpar) = r1s(:,:n2,mpar) + r1a(:,:n2,mpar) + rus(:,:n2,mpar) = rus(:,:n2,mpar) + rua(:,:n2,mpar) + z1s(:,:n2,mpar) = z1s(:,:n2,mpar) + z1a(:,:n2,mpar) + zus(:,:n2,mpar) = zus(:,:n2,mpar) + zua(:,:n2,mpar) + lus(:,:n2,mpar) = lus(:,:n2,mpar) + lua(:,:n2,mpar) + rcons(:,:n2,mpar) = rcons(:,:n2,mpar) + rcona(:,:n2,mpar) + zcons(:,:n2,mpar) = zcons(:,:n2,mpar) + zcona(:,:n2,mpar) + IF (lthreed) THEN + rvs(:,:n2,mpar) = rvs(:,:n2,mpar) + rva(:,:n2,mpar) + zvs(:,:n2,mpar) = zvs(:,:n2,mpar) + zva(:,:n2,mpar) + lvs(:,:n2,mpar) = lvs(:,:n2,mpar) + lva(:,:n2,mpar) + END IF + END DO + + CALl second0(tsymoff) + s_symrzl_time = s_symrzl_time + (tsymoff - tsymon) + + END SUBROUTINE symrzl diff --git a/Sources/General/tomnsp_mod.f b/Sources/General/tomnsp_mod.f new file mode 100644 index 0000000..76104fe --- /dev/null +++ b/Sources/General/tomnsp_mod.f @@ -0,0 +1,712 @@ + MODULE tomnsp_mod + USE timer_sub + IMPLICIT NONE + + CONTAINS + + SUBROUTINE tomnsps_par(frzl_array, armn, brmn, crmn, azmn, + & bzmn, czmn, blmn, clmn, arcon, azcon) + USE realspace, ONLY: wint, phip + USE vmec_main, p5 => cp5 + USE vmec_params, ONLY: jlam, jmin2, ntmax, rcc, rss, zsc, zcs, + & nscale + USE fbal, ONLY: rru_fac, rzu_fac, frcc_fac, fzsc_fac + USE precon2d, ONLY: ictrl_prec2d + USE parallel_include_module + USE xstuff +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), + & TARGET, INTENT(out) :: frzl_array + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(INout) :: + & armn, brmn, crmn, azmn, bzmn, czmn, blmn, clmn, arcon, azcon +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER, PARAMETER :: m0 = 0, m1 = 1, n0 = 0 + INTEGER :: jmax, m, mparity, i, n, k, l, nsz + INTEGER :: ioff, joff, mj, ni, nsl, j2, j2l, jl, jll, jmaxl + REAL(dp), DIMENSION(:,:,:), POINTER :: + & frcc, frss, fzcs, fzsc, flcs, flsc + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: work1 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: tempr, tempz + REAL(dp) :: t1 + INTEGER :: j, nsmin, nsmax, ub1, lb1, ub2, lb2, js +!----------------------------------------------- + CALL second0 (tffton) + + frcc => frzl_array(:,:,:,rcc) !!COS(mu) COS(nv) + fzsc => frzl_array(:,:,:,zsc+ntmax) !!SIN(mu) COS(nv) + flsc => frzl_array(:,:,:,zsc+2*ntmax) !!SIN(mu) COS(nv) + IF (lthreed) THEN + frss => frzl_array(:,:,:,rss) !!SIN(mu) SIN(nv) + fzcs => frzl_array(:,:,:,zcs+ntmax) !!COS(mu) SIN(nv) + flcs => frzl_array(:,:,:,zcs+2*ntmax) !!COS(mu) SIN(nv) + END IF + + nsz = ns*nzeta + + nsmin = tlglob + nsmax = trglob + + ALLOCATE (work1(12,nzeta,nsmin:nsmax), stat=i) + ALLOCATE (tempr(nzeta,nsmin:nsmax), stat=i) + ALLOCATE (tempz(nzeta,nsmin:nsmax), stat=i) + IF (i .ne. 0) THEN + STOP 'Allocation error in VMEC2000 tomnsps' + END IF + + ioff = LBOUND(frcc,1) + joff = LBOUND(frcc,2) + + jmax = ns + IF (ivac .LT. 1) THEN + jmax = ns1 + END IF + +! +! BEGIN FOURIER TRANSFORM +! +! FRmn = ARmn - d(BRmn)/du + d(CRmn)/dv +! FZmn = AZmn - d(BZmn)/du + d(CZmn)/dv +! FLmn = - d(BLmn)/du + d(CLmn)/dv +! +! NOTE: sinmumi = -m sin(mu), sinnvn = -n sin(nv) +! + DO js = nsmin, nsmax + frzl_array(:,:,js,:) = 0 + DO m = 0, mpol1 + mparity = MOD(m,2) + work1(:,:,js) = 0 + +! DO THETA (U) INTEGRATION FIRST ON HALF INTERVAL (0 < U < PI) + DO i = 1, ntheta2 + DO k = 1, nzeta + tempr(k,js) = armn(k,i,js,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*arcon(k,i,js,mparity) +#endif + tempz(k,js) = azmn(k,i,js,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*azcon(k,i,js,mparity) +#endif + work1(1,k,js) = work1(1,k,js) + & + tempr(k,js)*cosmui(i,m) + & + brmn(k,i,js,mparity)*sinmumi(i,m) + work1(7,k,js) = work1(7,k,js) + & + tempz(k,js)*sinmui(i,m) + & + bzmn(k,i,js,mparity)*cosmumi(i,m) + work1(11,k,js) = work1(11,k,js) + & + blmn(k,i,js,mparity)*cosmumi(i,m) + + IF (.NOT.lthreed) CYCLE + + work1(2,k,js) = work1(2,k,js) + & - crmn(k,i,js,mparity)*cosmui(i,m) + work1(3,k,js) = work1(3,k,js) + & + tempr(k,js)*sinmui(i,m) + & + brmn(k,i,js,mparity)*cosmumi(i,m) + work1(4,k,js) = work1(4,k,js) + & - crmn(k,i,js,mparity)*sinmui(i,m) + work1(5,k,js) = work1(5,k,js) + & + tempz(k,js)*cosmui(i,m) + & + bzmn(k,i,js,mparity)*sinmumi(i,m) + work1(6,k,js) = work1(6,k,js) + & - czmn(k,i,js,mparity)*cosmui(i,m) + work1(8,k,js) = work1(8,k,js) + & - czmn(k,i,js,mparity)*sinmui(i,m) + work1(9,k,js) = work1(9,k,js) + & + blmn(k,i,js,mparity)*sinmumi(i,m) + work1(10,k,js) = work1(10,k,js) + & - clmn(k,i,js,mparity)*cosmui(i,m) + work1(12,k,js) = work1(12,k,js) + & - clmn(k,i,js,mparity)*sinmui(i,m) + END DO + END DO + +! +! NEXT, DO ZETA (V) TRANSFORM + mj = m + joff + j2 = jmin2(m) + jl = jlam(m) + + lb1 = MAX(tlglob,j2) + ub1 = MIN(trglob,jmax) + lb2 = MAX(tlglob,jl) + ub2 = trglob + + + DO n = 0, ntor + ni = n+ioff + DO k = 1, nzeta + + IF (lb1 .LE. js .AND. js .LE. ub1) THEN + frcc(ni,mj,js) = frcc(ni,mj,js) + & + work1(1,k,js)*cosnv(k,n) + + fzsc(ni,mj,js) = fzsc(ni,mj,js) + & + work1(7,k,js)*cosnv(k,n) + END IF + + IF (lb2 .LE. js .AND. js .LE. ub2) THEN + flsc(ni,mj,js) = flsc(ni,mj,js) + & + work1(11,k,js)*cosnv(k,n) + END IF + + IF (.NOT.lthreed) CYCLE + + IF (lb1 .LE. js .AND. js .LE. ub1) THEN + frcc(ni,mj,js) = frcc(ni,mj,js) + & + work1(2,k,js)*sinnvn(k,n) + + fzsc(ni,mj,js) = fzsc(ni,mj,js) + & + work1(8,k,js)*sinnvn(k,n) + + frss(ni,mj,js) = frss(ni,mj,js) + & + work1(3,k,js)*sinnv(k,n) + & + work1(4,k,js)*cosnvn(k,n) + + fzcs(ni,mj,js) = fzcs(ni,mj,js) + & + work1(5,k,js)*sinnv(k,n) + & + work1(6,k,js)*cosnvn(k,n) + END IF + + IF (lb2 .LE. js .AND. js .LE. ub2) THEN + flsc(ni,mj,js) = flsc(ni,mj,js) + & + work1(12,k,js)*sinnvn(k,n) + + flcs(ni,mj,js) = flcs(ni,mj,js) + & + work1(9,k,js)*sinnv(k,n) + & + work1(10,k,js)*cosnvn(k,n) + END IF + END DO + END DO + END DO + END DO + +! +! COMPUTE IOTA EVOLUTION EQUATION [STORED IN LMNSC(0,0) COMPONENT] +! +!SPH071017 +#if defined(CHI_FORCE) + IF (ictrl_prec2d .NE. 0 .AND. ncurr .EQ. 1) THEN + ni = n0 + ioff + mj = m0 + joff + t1 = r0scale + nsmin = MAX(2,tlglob) + nsmax = trglob + DO js = nsmin, nsmax + flsc(ni, mj, js) = -t1*(buco(js) - icurv(js)) + END DO + END IF +#endif +! +! MAKE R,Z(m=1,n=0) SATISFY AVERAGE FORCE BALANCE EXACTLY +! NOTE: for m=1, FR ~ Z1*(f0 + f2), FZ ~ R1*(f0 - f2), WHERE +! f0 is the m=0 component of frho, f2 is m=2 component. + IF (lforbal) THEN + ni = m0 + ioff + mj = m1 + joff + t1 = nscale(n0)*r0scale !/4 !!v8.52 + nsmin = MAX(2,tlglob) + nsmax = MIN(trglob,ns-1) + DO jl = nsmin, nsmax + DO k = 1, nzeta + work1(k,1,jl) = frcc_fac(jl)*frcc(ni,mj,jl) + & + fzsc_fac(jl)*fzsc(ni,mj,jl) + frcc(ni,mj,jl) = rzu_fac(jl)*(t1*equif(jl) + & + work1(k,1,jl)) + fzsc(ni,mj,jl) = rru_fac(jl)*(t1*equif(jl) + & - work1(k,1,jl)) + END DO + END DO + END IF + + DEALLOCATE (work1, tempr, tempz) + + CALL second0 (tfftoff) + tomnsps_time = tomnsps_time + (tfftoff - tffton) + timer(tffi) = timer(tffi) + (tfftoff - tffton) + + END SUBROUTINE tomnsps_par + + SUBROUTINE tomnspa_par(frzl_array, armn, brmn, crmn, azmn, bzmn, + & czmn, blmn, clmn, arcon, azcon) + USE vmec_main + USE vmec_params, ONLY: jlam, jmin2, ntmax, rsc, rcs, zcc, zss + USE parallel_include_module +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), + & TARGET, INTENT(inout) :: frzl_array + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(in) :: + & armn, brmn, crmn, azmn, bzmn, czmn, blmn, clmn, arcon, azcon +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: jmax, m, mparity, i, n, k, l + INTEGER :: ioff, joff, mj, ni, nsl, j2, j2l, jl, jll, jmaxl + REAL(dp), DIMENSION(:,:,:), POINTER :: + & frcs, frsc, fzcc, fzss, flcc, flss +! REAL(dp), DIMENSION(ns*nzeta) :: temp1, temp3 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: temp1, temp3 + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: work1 + INTEGER :: j, nsmin, nsmax, ub1, lb1, ub2, lb2, js +!----------------------------------------------- + CALL second0(tffton) + + frsc => frzl_array(:,:,:,rsc) !!R-SIN(mu) COS(nv) + fzcc => frzl_array(:,:,:,zcc+ntmax) !!Z-COS(mu) COS(nv) + flcc => frzl_array(:,:,:,zcc+2*ntmax) !!L-COS(mu) COS(nv) + IF (lthreed) THEN + frcs => frzl_array(:,:,:,rcs) !!R-COS(mu) SIN(nv) + fzss => frzl_array(:,:,:,zss+ntmax) !!Z-SIN(mu) SIN(nv) + flss => frzl_array(:,:,:,zss+2*ntmax) !!L-SIN(mu) SIN(nv) + END IF + + nsmin = tlglob + nsmax = trglob + ALLOCATE (work1(12,nzeta,nsmin:nsmax), + & temp1(nzeta,nsmin:nsmax), + & temp3(nzeta,nsmin:nsmax), stat=i) + IF (i .NE. 0) THEN + STOP 'Allocation error in VMEC tomnspa' + END IF + + ioff = LBOUND(frsc,1) + joff = LBOUND(frsc,2) + + jmax = ns + IF (ivac .LT. 1) THEN + jmax = ns1 + END IF + +! +! BEGIN FOURIER TRANSFORM +! + DO js = nsmin, nsmax + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m + joff + j2 = jmin2(m) + jl = jlam(m) + work1(:,:,js) = 0 +! +! DO THETA (U) TRANSFORM FIRST +! + DO i = 1, ntheta2 + DO k = 1, nzeta + temp1(k,js) = armn(k,i,js,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*arcon(k,i,js,mparity) +#endif + temp3(k,js) = azmn(k,i,js,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*azcon(k,i,js,mparity) +#endif + work1(3,k,js) = work1(3,k,js) + & + temp1(k,js)*sinmui(i,m) + & + brmn(k,i,js,mparity)*cosmumi(i,m) + work1(5,k,js) = work1(5,k,js) + & + temp3(k,js)*cosmui(i,m) + & + bzmn(k,i,js,mparity)*sinmumi(i,m) + work1(9,k,js) = work1(9,k,js) + & + blmn(k,i,js,mparity)*sinmumi(i,m) + + IF (.not.lthreed) CYCLE + + work1(1,k,js) = work1(1,k,js) + & + temp1(k,js)*cosmui(i,m) + & + brmn(k,i,js,mparity)*sinmumi(i,m) + work1(2,k,js) = work1(2,k,js) + & - crmn(k,i,js,mparity)*cosmui(i,m) + work1(4,k,js) = work1(4,k,js) + & - crmn(k,i,js,mparity)*sinmui(i,m) + work1(6,k,js) = work1(6,k,js) + & - czmn(k,i,js,mparity)*cosmui(i,m) + work1(7,k,js) = work1(7,k,js) + & + temp3(k,js)*sinmui(i,m) + & + bzmn(k,i,js,mparity)*cosmumi(i,m) + work1(8,k,js) = work1(8,k,js) + & - czmn(k,i,js,mparity)*sinmui(i,m) + work1(10,k,js) = work1(10,k,js) + & - clmn(k,i,js,mparity)*cosmui(i,m) + work1(11,k,js) = work1(11,k,js) + & + blmn(k,i,js,mparity)*cosmumi(i,m) + work1(12,k,js) = work1(12,k,js) + & - clmn(k,i,js,mparity)*sinmui(i,m) + END DO + END DO +! +! NEXT, DO ZETA (V) TRANSFORM +! + + lb1 = MAX(tlglob,j2) + ub1 = MIN(trglob,jmax) + lb2 = MAX(tlglob,jl) + ub2 = trglob + + DO n = 0, ntor + ni = n + ioff + DO k = 1, nzeta + + IF (lb1 .LE. js .AND. js .LE. ub1) THEN + frsc(ni,mj,js) = frsc(ni,mj,js) + & + work1(3,k,js)*cosnv(k,n) + fzcc(ni,mj,js) = fzcc(ni,mj,js) + & + work1(5,k,js)*cosnv(k,n) + END IF + + IF (lb2 .LE. js .AND. js .LE. ub2) THEN + flcc(ni,mj,js) = flcc(ni,mj,js) + & + work1(9,k,js)*cosnv(k,n) + END IF + + IF (.not.lthreed) CYCLE + + IF (lb1 .LE. js .AND. js .LE. ub1) THEN + frsc(ni,mj,js) = frsc(ni,mj,js) + & + work1(4,k,js)*sinnvn(k,n) + fzcc(ni,mj,js) = fzcc(ni,mj,js) + & + work1(6,k,js)*sinnvn(k,n) + frcs(ni,mj,js) = frcs(ni,mj,js) + & + work1(1,k,js)*sinnv(k,n) + & + work1(2,k,js)*cosnvn(k,n) + fzss(ni,mj,js) = fzss(ni,mj,js) + & + work1(7,k,js)*sinnv(k,n) + & + work1(8,k,js)*cosnvn(k,n) + END IF + + IF (lb2 .LE. js .AND. js .LE. ub2) THEN + flcc(ni,mj,js) = flcc(ni,mj,js) + & + work1(10,k,js)*sinnvn(k,n) + flss(ni,mj,js) = flss(ni,mj,js) + & + work1(11,k,js)*sinnv(k,n) + & + work1(12,k,js)*cosnvn(k,n) + END IF + END DO + END DO + END DO + END DO + +! IF THE SYMMETRIZED MODE USED, NEED EXTRA FACTOR OF 2 +! IF ntheta3 USED INSTEAD OF ntheta3, DO NOT NEED THIS FACTOR +! frzl_array(:,:,nsmin:nsmax,:) = 2*frzl_array(:,:,nsmin:nsmax,:) + + DEALLOCATE (work1, temp1, temp3) + CALL second0(tfftoff) + tomnspa_time = tomnspa_time + (tfftoff - tffton) + timer(tffi) = timer(tffi) + (tfftoff - tffton) + + END SUBROUTINE tomnspa_par + + SUBROUTINE tomnsps(frzl_array, armn, brmn, crmn, azmn, + 1 bzmn, czmn, blmn, clmn, arcon, azcon) + USE realspace, ONLY: wint, phip + USE vmec_main, p5 => cp5 + USE vmec_params, ONLY: jlam, jmin2, ntmax, rcc, rss, zsc, zcs, + 1 nscale + USE fbal, ONLY: rru_fac, rzu_fac, frcc_fac, fzsc_fac + USE precon2d, ONLY: ictrl_prec2d +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + 1 TARGET, INTENT(out) :: frzl_array + REAL(dp), DIMENSION(ns*nzeta*ntheta3,0:1), INTENT(in) :: + 1 armn, brmn, crmn, azmn, bzmn, czmn, blmn, clmn, arcon, azcon +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: jmax, m, mparity, i, n, k, l, nsz + INTEGER :: ioff, joff, mj, ni, nsl, j2, j2l, jl, jll, jmaxl + REAL(dp), DIMENSION(:,:,:), POINTER :: + 1 frcc, frss, fzcs, fzsc, flcs, flsc + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: work1 + REAL(dp), DIMENSION(:), ALLOCATABLE :: tempr, tempz + REAL(dp) :: t1 +!----------------------------------------------- + frcc => frzl_array(:,:,:,rcc) !!COS(mu) COS(nv) + fzsc => frzl_array(:,:,:,zsc+ntmax) !!SIN(mu) COS(nv) + flsc => frzl_array(:,:,:,zsc+2*ntmax) !!SIN(mu) COS(nv) + IF (lthreed) THEN + frss => frzl_array(:,:,:,rss) !!SIN(mu) SIN(nv) + fzcs => frzl_array(:,:,:,zcs+ntmax) !!COS(mu) SIN(nv) + flcs => frzl_array(:,:,:,zcs+2*ntmax) !!COS(mu) SIN(nv) + END IF + + nsz = ns*nzeta + + ALLOCATE (work1(nsz,12), tempr(nsz), tempz(nsz), + 1 stat=i) + IF (i .ne. 0) THEN + STOP 'Allocation error in VMEC2000 tomnsps' + END IF + + ioff = LBOUND(frcc,2) + joff = LBOUND(frcc,3) + + frzl_array = 0 + + jmax = ns + IF (ivac .lt. 1) THEN + jmax = ns1 + END IF + +! +! BEGIN FOURIER TRANSFORM +! +! FRmn = ARmn - d(BRmn)/du + d(CRmn)/dv +! FZmn = AZmn - d(BZmn)/du + d(CZmn)/dv +! FLmn = - d(BLmn)/du + d(CLmn)/dv +! +! NOTE: sinmumi = -m sin(mu), sinnvn = -n sin(nv) +! + DO m = 0, mpol1 + mparity = MOD(m,2) + work1 = 0 +! DO THETA (U) INTEGRATION FIRST ON HALF INTERVAL (0 < U < PI) +! + l = 0 + DO i = 1, ntheta2 + jll = l + 1 + nsl = nsz + l + l = l + nsz + tempr(:) = armn(jll:nsl,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*arcon(jll:nsl,mparity) +#endif + tempz(:) = azmn(jll:nsl,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*azcon(jll:nsl,mparity) +#endif + work1(:,1) = work1(:,1) + tempr(:)*cosmui(i,m) + & + brmn(jll:nsl,mparity)*sinmumi(i,m) + work1(:,7) = work1(:,7) + tempz(:)*sinmui(i,m) + & + bzmn(jll:nsl,mparity)*cosmumi(i,m) + work1(:,11)= work1(:,11)+ blmn(jll:nsl,mparity)*cosmumi(i,m) + + IF (.not.lthreed) CYCLE + + work1(:,2) = work1(:,2) - crmn(jll:nsl,mparity)*cosmui(i,m) + work1(:,3) = work1(:,3) + tempr(:)*sinmui(i,m) + & + brmn(jll:nsl,mparity)*cosmumi(i,m) + work1(:,4) = work1(:,4) - crmn(jll:nsl,mparity)*sinmui(i,m) + work1(:,5) = work1(:,5) + tempz(:)*cosmui(i,m) + & + bzmn(jll:nsl,mparity)*sinmumi(i,m) + work1(:,6) = work1(:,6) - czmn(jll:nsl,mparity)*cosmui(i,m) + work1(:,8) = work1(:,8) - czmn(jll:nsl,mparity)*sinmui(i,m) + + work1(:,9) = work1(:,9) + blmn(jll:nsl,mparity)*sinmumi(i,m) + work1(:,10) =work1(:,10)- clmn(jll:nsl,mparity)*cosmui(i,m) + work1(:,12) =work1(:,12)- clmn(jll:nsl,mparity)*sinmui(i,m) + END DO + +! +! NEXT, DO ZETA (V) TRANSFORM + mj = m + joff + j2 = jmin2(m) + jl = jlam(m) + + DO n = 0, ntor + ni = n+ioff + l = 0 + DO k = 1, nzeta + j2l = j2 + l + jmaxl = jmax + l + jll = jl + l + nsl = ns + l + l = l + ns + frcc(j2:jmax,ni,mj) = frcc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,1)*cosnv(k,n) + fzsc(j2:jmax,ni,mj) = fzsc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,7)*cosnv(k,n) + flsc(jl:ns,ni,mj) = flsc(jl:ns,ni,mj) + & + work1(jll:nsl,11)*cosnv(k,n) + + IF (.not.lthreed) CYCLE + + frcc(j2:jmax,ni,mj) = frcc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,2)*sinnvn(k,n) + fzsc(j2:jmax,ni,mj) = fzsc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,8)*sinnvn(k,n) + frss(j2:jmax,ni,mj) = frss(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,3)*sinnv(k,n) + & + work1(j2l:jmaxl,4)*cosnvn(k,n) + fzcs(j2:jmax,ni,mj) = fzcs(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,5)*sinnv(k,n) + & + work1(j2l:jmaxl,6)*cosnvn(k,n) + + flsc(jl:ns,ni,mj) = flsc(jl:ns,ni,mj) + & + work1(jll:nsl,12)*sinnvn(k,n) + flcs(jl:ns,ni,mj) = flcs(jl:ns,ni,mj) + & + work1(jll:nsl,9)*sinnv(k,n) + & + work1(jll:nsl,10)*cosnvn(k,n) + END DO + END DO + END DO + +! +! COMPUTE IOTA EVOLUTION EQUATION [STORED IN LMNSC(0,0) COMPONENT] +! +#if defined(CHI_FORCE) + IF (ictrl_prec2d.gt.0 .and. ncurr.eq.1) THEN + ni = 0 + ioff + mj = 0 + joff + t1 = r0scale + DO jl = 2, ns + flsc(jl, ni, mj) = -t1*(buco(jl) - icurv(jl)) + END DO + END IF +#endif +! +! MAKE R,Z(m=1,n=0) SATISFY AVERAGE FORCE BALANCE EXACTLY +! NOTE: for m=1, FR ~ Z1*(f0 + f2), FZ ~ R1*(f0 - f2), WHERE +! f0 is the m=0 component of frho, f2 is m=2 component. + IF (lforbal) THEN + mj = 1 + joff + ni = 0 + ioff + t1 = nscale(0)*r0scale !/4 !!v8.52 + DO jl = 2, ns - 1 + work1(jl,1) = frcc_fac(jl)*frcc(jl,ni,mj) + & + fzsc_fac(jl)*fzsc(jl,ni,mj) + frcc(jl,ni,mj) = rzu_fac(jl)*(t1*equif(jl) + work1(jl,1)) + fzsc(jl,ni,mj) = rru_fac(jl)*(t1*equif(jl) - work1(jl,1)) + END DO + END IF + + DEALLOCATE (work1, tempr, tempz) + + END SUBROUTINE tomnsps + + SUBROUTINE tomnspa(frzl_array, armn, brmn, crmn, azmn, bzmn, + & czmn, blmn, clmn, arcon, azcon) + USE vmec_main + USE vmec_params, ONLY: jlam, jmin2, ntmax, rsc, rcs, zcc, zss +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + & TARGET, INTENT(inout) :: frzl_array + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(in) :: + & armn, brmn, crmn, azmn, bzmn, czmn, blmn, clmn, arcon, azcon +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: jmax, m, mparity, i, n, k, l + INTEGER :: ioff, joff, mj, ni, nsl, j2, j2l, jl, jll, jmaxl + REAL(dp), DIMENSION(:,:,:), POINTER :: + & frcs, frsc, fzcc, fzss, flcc, flss + REAL(dp), DIMENSION(ns*nzeta) :: temp1, temp3 + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: work1 +!----------------------------------------------- + frsc => frzl_array(:,:,:,rsc) !!R-SIN(mu) COS(nv) + fzcc => frzl_array(:,:,:,zcc+ntmax) !!Z-COS(mu) COS(nv) + flcc => frzl_array(:,:,:,zcc+2*ntmax) !!L-COS(mu) COS(nv) + IF (lthreed) THEN + frcs => frzl_array(:,:,:,rcs) !!R-COS(mu) SIN(nv) + fzss => frzl_array(:,:,:,zss+ntmax) !!Z-SIN(mu) SIN(nv) + flss => frzl_array(:,:,:,zss+2*ntmax) !!L-SIN(mu) SIN(nv) + END IF + + ALLOCATE (work1(ns*nzeta,12), stat=i) + IF (i .ne. 0) THEN + STOP 'Allocation error in VMEC tomnspa' + END IF + + ioff = LBOUND(frsc,2) + joff = LBOUND(frsc,3) + + jmax = ns + IF (ivac .lt. 1) jmax = ns1 +! +! BEGIN FOURIER TRANSFORM +! + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m + joff + j2 = jmin2(m) + jl = jlam(m) + work1 = 0 +! +! DO THETA (U) TRANSFORM FIRST +! + DO i = 1, ntheta2 + temp1(:) = armn(:,i,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*arcon(:,i,mparity) +#endif + temp3(:) = azmn(:,i,mparity) +#ifndef _HBANGLE + & + xmpq(m,1)*azcon(:,i,mparity) +#endif + work1(:,3) = work1(:,3) + temp1(:)*sinmui(i,m) + & + brmn(:,i,mparity)*cosmumi(i,m) + work1(:,5) = work1(:,5) + temp3(:)*cosmui(i,m) + & + bzmn(:,i,mparity)*sinmumi(i,m) + work1(:,9) = work1(:,9) + blmn(:,i,mparity)*sinmumi(i,m) + + IF (.not.lthreed) CYCLE + + work1(:,1) = work1(:,1) + temp1(:)*cosmui(i,m) + & + brmn(:,i,mparity)*sinmumi(i,m) + work1(:,2) = work1(:,2) - crmn(:,i,mparity)*cosmui(i,m) + work1(:,4) = work1(:,4) - crmn(:,i,mparity)*sinmui(i,m) + work1(:,6) = work1(:,6) - czmn(:,i,mparity)*cosmui(i,m) + work1(:,7) = work1(:,7) + temp3(:)*sinmui(i,m) + & + bzmn(:,i,mparity)*cosmumi(i,m) + work1(:,8) = work1(:,8) - czmn(:,i,mparity)*sinmui(i,m) + work1(:,10) = work1(:,10) - clmn(:,i,mparity)*cosmui(i,m) + work1(:,11) = work1(:,11) + blmn(:,i,mparity)*cosmumi(i,m) + work1(:,12) = work1(:,12) - clmn(:,i,mparity)*sinmui(i,m) + END DO +! +! NEXT, DO ZETA (V) TRANSFORM +! + DO n = 0, ntor + ni = n + ioff + DO k = 1, nzeta + l = ns*(k - 1) + j2l = j2 + l + jmaxl = jmax + l + jll = jl + l + nsl = ns + l + frsc(j2:jmax,ni,mj) = frsc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,3)*cosnv(k,n) + fzcc(j2:jmax,ni,mj) = fzcc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,5)*cosnv(k,n) + flcc(jl:ns,ni,mj) = flcc(jl:ns,ni,mj) + & + work1(jll:nsl,9)*cosnv(k,n) + + IF (.not.lthreed) CYCLE + + frsc(j2:jmax,ni,mj) = frsc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,4)*sinnvn(k,n) + fzcc(j2:jmax,ni,mj) = fzcc(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,6)*sinnvn(k,n) + frcs(j2:jmax,ni,mj) = frcs(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,1)*sinnv(k,n) + & + work1(j2l:jmaxl,2)*cosnvn(k,n) + fzss(j2:jmax,ni,mj) = fzss(j2:jmax,ni,mj) + & + work1(j2l:jmaxl,7)*sinnv(k,n) + & + work1(j2l:jmaxl,8)*cosnvn(k,n) + flcc(jl:ns,ni,mj) = flcc(jl:ns,ni,mj) + & + work1(jll:nsl,10)*sinnvn(k,n) + flss(jl:ns,ni,mj) = flss(jl:ns,ni,mj) + & + work1(jll:nsl,11)*sinnv(k,n) + & + work1(jll:nsl,12)*cosnvn(k,n) + END DO + END DO + END DO + +! IF THE SYMMETRIZED MODE USED, NEED EXTRA FACTOR OF 2 +! IF ntheta3 USED INSTEAD OF ntheta3, DO NOT NEED THIS FACTOR +! frzl_array = 2*frzl_array + + DEALLOCATE (work1) + + END SUBROUTINE tomnspa + + END MODULE tomnsp_mod diff --git a/Sources/General/totzsp_mod.f b/Sources/General/totzsp_mod.f new file mode 100644 index 0000000..4d0859b --- /dev/null +++ b/Sources/General/totzsp_mod.f @@ -0,0 +1,924 @@ + MODULE totzsp_mod + USE vmec_main + USE timer_sub + IMPLICIT NONE + + INTEGER, PARAMETER, PRIVATE :: m0=0, m1=1, n0=0 + REAL(dp), ALLOCATABLE, PRIVATE :: work1(:,:,:), work2(:,:) + REAL(dp), PRIVATE :: cosmux, sinmux + + CONTAINS + +!------------------------------------------------------------------------------- +!> @brief Convert symmetric quantities from Fourier space to real space. +!> +!> Forier transforms between Fourier space and real space. Computes quantities +!> for R, dR/du, dR/dv, Z, dZ/du, dZ/dv, dlambda/du and dlambda/dv. Non +!> derivative quantities are trans formed via +!> +!> A_real = A_mnc*cos(mu - nv) + A_mns*sin(mu - nv) (1) +!> +!> Derivatives with respect to u are transformed as +!> +!> dA_real/du = -m*A_mnc*sin(mu - nv) + m*A_mns*cos(mu - nv) (2) +!> +!> Derivatives with respect to v are transformed as +!> +!> dA_real/dv = n*A_mnc*sin(mu - nv) - m*A_mns*cos(mu - nv) (3) +!> +!> @param[inout] rzl_array Fourier amplitudes for Rmnc, Zmns and Lmns for +!> lasym false. When lasym is true, this also contains +!> Rmns, Zmnc, Lmnc. +!> @paran[out] r11 Real space R. +!> @param[out] ru1 Real space dR/du. +!> @param[out] rv1 Real space dR/dz. +!> @param[out] z11 Real space Z. +!> @param[out] zu1 Real space dZ/du. +!> @param[out] zv1 Real space dZ/dv. +!> @param[out] lu1 Real space dlambda/du. +!> @param[out] lv1 Real space dlambda/dv. +!> @param[out] rcn1 Unknown R quantity. +!> @param[out] zcn1 Unknown Z quantity. +!> @param[out] ier_flag Status of the transform. Takes the value of +!> @ref r01_bad_value_flag if rmnc(0,1) is zero. +!> +!> @note FIXME Figure out what rcn1 and zcn1 are. +!------------------------------------------------------------------------------- + SUBROUTINE totzsps_par(rzl_array, r11, ru1, rv1, z11, zu1, zv1, + & lu1, lv1, rcn1, zcn1, ier_flag) + USE vmec_params, ONLY: jmin1, jlam, ntmax, rcc, rss, zsc, zcs, + & r01_bad_value_flag + USE precon2d, ONLY: ictrl_prec2d + USE parallel_include_module +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), + & TARGET, INTENT(INOUT) :: rzl_array + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), + & INTENT(out) :: r11, ru1, + & rv1, z11, zu1, zv1, lu1, lv1, rcn1, zcn1 + INTEGER, INTENT(inout) :: ier_flag +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: n, m, mparity, k, i, l + INTEGER :: ioff, joff, mj, ni, nsz + INTEGER :: nsmin, nsmax, js + REAL(dp), DIMENSION(:,:,:), POINTER :: + & rmncc, rmnss, zmncs, zmnsc, lmncs, lmnsc + REAL(dp) :: tbroadon, tbroadoff +!----------------------------------------------- + CALL second0(tffton) + + nsmin = t1lglob + nsmax = t1rglob + + rmncc=>rzl_array(:,:,:,rcc) !COS(mu) COS(nv) + zmnsc=>rzl_array(:,:,:,zsc+ntmax) !SIN(mu) COS(nv) + lmnsc=>rzl_array(:,:,:,zsc+2*ntmax) !SIN(mu) COS(nv) + IF (lthreed) THEN + rmnss=>rzl_array(:,:,:,rss) !SIN(mu) SIN(nv) + zmncs=>rzl_array(:,:,:,zcs+ntmax) !COS(mu) SIN(nv) + lmncs=>rzl_array(:,:,:,zcs+2*ntmax) !COS(mu) SIN(nv) + END IF + rzl_array(:,m1,1,:) = rzl_array(:,m1,2,:) + + ioff = LBOUND(rmncc,1) + joff = LBOUND(rmncc,2) + IF (lthreed) THEN + CALL convert_sym_par(rmnss(:,m1+joff,:), zmncs(:,m1+joff,:), + & nsmin, nsmax) + END IF + +! +! ORIGIN EXTRAPOLATION OF M=0 MODES FOR LAMBDA +! + IF (lthreed .AND. jlam(m0) .GT. 1) THEN + lmncs(:,m0+joff,1) = lmncs(:,m0+joff,2) + END IF + +! +! EVOLVE CHIPS BY FORCES IN TOMNSPS WHEN NCURR=1, ICTRL_PREC2D != 0 +! +!SPH071017 +#if defined(CHI_FORCE) + IF (ncurr .EQ. 1) THEN + IF (ictrl_prec2d .EQ. 2) THEN + lmnsc(n0+ioff,m0+joff,nsmin:nsmax) = chips(nsmin:nsmax) + ELSE IF (ictrl_prec2d .NE. 0) THEN + chips(nsmin:nsmax) = lmnsc(n0+ioff,m0+joff,nsmin:nsmax) + END IF + END IF +#endif + + ALLOCATE (work1(nzeta,12,nsmin:nsmax), stat=i) + IF (i .ne. 0) THEN + STOP 'Allocation error in VMEC2000 totzsps' + END IF + + DO js = nsmin, nsmax + r11(:,:,js,:) = 0 + ru1(:,:,js,:) = 0 + rv1(:,:,js,:) = 0 + rcn1(:,:,js,:) = 0 + zcn1(:,:,js,:) = 0 + z11(:,:,js,:) = 0 + zu1(:,:,js,:) = 0 + zv1(:,:,js,:) = 0 + lu1(:,:,js,:) = 0 + lv1(:,:,js,:) = 0 + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m + joff + work1(:,:,js) = 0 +! +! INVERSE TRANSFORM IN N-ZETA, FOR FIXED M +! + DO n = 0, ntor + ni = n + ioff + DO k = 1, nzeta + work1(k,1,js) = work1(k,1,js) + & + rmncc(ni,mj,js)*cosnv(k,n) + work1(k,6,js) = work1(k,6,js) + & + zmnsc(ni,mj,js)*cosnv(k,n) + work1(k,10,js) = work1(k,10,js) + & + lmnsc(ni,mj,js)*cosnv(k,n) + + IF (.NOT.lthreed) CYCLE + + work1(k,4,js) = work1(k,4,js) + & + rmnss(ni,mj,js)*cosnvn(k,n) + work1(k,7,js) = work1(k,7,js) + & + zmncs(ni,mj,js)*cosnvn(k,n) + work1(k,11,js) = work1(k,11,js) + & + lmncs(ni,mj,js)*cosnvn(k,n) + + work1(k,2,js) = work1(k,2,js) + & + rmnss(ni,mj,js)*sinnv(k,n) + work1(k,5,js) = work1(k,5,js) + & + zmncs(ni,mj,js)*sinnv(k,n) + work1(k,9,js) = work1(k,9,js) + & + lmncs(ni,mj,js)*sinnv(k,n) + + work1(k,3,js) = work1(k,3,js) + & + rmncc(ni,mj,js)*sinnvn(k,n) + work1(k,8,js) = work1(k,8,js) + & + zmnsc(ni,mj,js)*sinnvn(k,n) + work1(k,12,js) = work1(k,12,js) + & + lmnsc(ni,mj,js)*sinnvn(k,n) + END DO + END DO + +! +! INVERSE TRANSFORM IN M-THETA, FOR ALL RADIAL, ZETA VALUES +! + l = 0 + DO i = 1, ntheta2 + cosmux = xmpq(m,1)*cosmu(i,m) + sinmux = xmpq(m,1)*sinmu(i,m) + + r11(:,i,js,mparity) = r11(:,i,js,mparity) + & + work1(:,1,js)*cosmu(i,m) + ru1(:,i,js,mparity) = ru1(:,i,js,mparity) + & + work1(:,1,js)*sinmum(i,m) + rcn1(:,i,js,mparity) = rcn1(:,i,js,mparity) + & + work1(:,1,js)*cosmux + + z11(:,i,js,mparity) = z11(:,i,js,mparity) + & + work1(:,6,js)*sinmu(i,m) + zu1(:,i,js,mparity) = zu1(:,i,js,mparity) + & + work1(:,6,js)*cosmum(i,m) + zcn1(:,i,js,mparity) = zcn1(:,i,js,mparity) + & + work1(:,6,js)*sinmux + + lu1(:,i,js,mparity) = lu1(:,i,js,mparity) + & + work1(:,10,js)*cosmum(i,m) + + IF (.not.lthreed) CYCLE + + r11(:,i,js,mparity) = r11(:,i,js,mparity) + & + work1(:,2,js)*sinmu(i,m) + ru1(:,i,js,mparity) = ru1(:,i,js,mparity) + & + work1(:,2,js)*cosmum(i,m) + rcn1(:,i,js,mparity) = rcn1(:,i,js,mparity) + & + work1(:,2,js)*sinmux + + rv1(:,i,js,mparity) = rv1(:,i,js,mparity) + & + work1(:,3,js)*cosmu(i,m) + & + work1(:,4,js)*sinmu(i,m) + z11(:,i,js,mparity) = z11(:,i,js,mparity) + & + work1(:,5,js)*cosmu(i,m) + + zu1(:,i,js,mparity) = zu1(:,i,js,mparity) + & + work1(:,5,js)*sinmum(i,m) + zcn1(:,i,js,mparity) = zcn1(:,i,js,mparity) + & + work1(:,5,js)*cosmux + zv1(:,i,js,mparity) = zv1(:,i,js,mparity) + & + work1(:,7,js)*cosmu(i,m) + & + work1(:,8,js)*sinmu(i,m) + + lu1(:,i,js,mparity) = lu1(:,i,js,mparity) + & + work1(:,9,js)*sinmum(i,m) + lv1(:,i,js,mparity) = lv1(:,i,js,mparity) + & - (work1(:,11,js)*cosmu(i,m) + & + work1(:,12,js)*sinmu(i,m)) + END DO + END DO + END DO + + DEALLOCATE (work1) + + z01(nsmin:nsmax) = zmnsc(n0+ioff,m1+joff,nsmin:nsmax) + r01(nsmin:nsmax) = rmncc(n0+ioff,m1+joff,nsmin:nsmax) + IF (lactive) THEN + IF (rank.EQ.0 .AND. r01(1).EQ.zero) THEN + ier_flag = r01_bad_value_flag + ELSE IF (rank.EQ.0 .AND. r01(1).NE.zero) THEN + dkappa = z01(1)/r01(1) + END IF + CALL second0(tbroadon) + CALL MPI_Bcast(dkappa,1, MPI_REAL8,0,NS_COMM,MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + END IF + + CALL second0(tfftoff) + totzsps_time = totzsps_time + (tfftoff - tffton) + timer(tfft) = timer(tfft) + (tfftoff - tffton) + + END SUBROUTINE totzsps_par + +!------------------------------------------------------------------------------- +!> @brief Convert asymmetric quantities from Fourier space to real space. +!> +!> Forier transforms between Fourier space and real space. Computes quantities +!> for R, dR/du, dR/dv, Z, dZ/du, dZ/dv, dlambda/du and dlambda/dv. Non +!> derivative quantities are trans formed via +!> +!> A_real = A_mnc*cos(mu - nv) + A_mns*sin(mu - nv) (1) +!> +!> Derivatives with respect to u are transformed as +!> +!> dA_real/du = -m*A_mnc*sin(mu - nv) + m*A_mns*cos(mu - nv) (2) +!> +!> Derivatives with respect to v are transformed as +!> +!> dA_real/dv = n*A_mnc*sin(mu - nv) - m*A_mns*cos(mu - nv) (3) +!> +!> @param[inout] rzl_array Fourier amplitudes for Rmnc, Zmns and Lmns for +!> lasym false. When lasym is true, this also contains +!> Rmns, Zmnc, Lmnc. +!> @paran[out] r11 Real space R. +!> @param[out] ru1 Real space dR/du. +!> @param[out] rv1 Real space dR/dz. +!> @param[out] z11 Real space Z. +!> @param[out] zu1 Real space dZ/du. +!> @param[out] zv1 Real space dZ/dv. +!> @param[out] lu1 Real space dlambda/du. +!> @param[out] lv1 Real space dlambda/dv. +!> @param[out] rcn1 Unknown R quantity. +!> @param[out] zcn1 Unknown Z quantity. +!> @param[out] ier_flag Status of the transform. Takes the value of +!> @ref r01_bad_value_flag if rmnc(0,1) is zero. +!> +!> @note FIXME Figure out what rcn1 and zcn1 are. +!------------------------------------------------------------------------------- + SUBROUTINE totzspa_par(rzl_array, r11, ru1, rv1, z11, zu1, zv1, + 1 lu1, lv1, rcn1, zcn1) + USE vmec_params, ONLY: jmin1, jlam, ntmax, rcs, rsc, zcc, zss + USE precon2d, ONLY: ictrl_prec2d + USE parallel_include_module +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), + 1 TARGET, INTENT(inout) :: rzl_array + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(out) :: + 1 r11, ru1, rv1, z11, zu1, zv1, lu1, lv1, rcn1, zcn1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: m, n, mparity, k, i, l, j1 + INTEGER :: ioff, joff, mj, ni + INTEGER :: nsmin, nsmax, js + REAL(dp), DIMENSION(:,:,:), POINTER :: + 1 rmncs, rmnsc, zmncc, zmnss, lmncc, lmnss +C----------------------------------------------- + CALL second0(tffton) + nsmin = t1lglob + nsmax = t1rglob + + rmnsc => rzl_array(:,:,:,rsc) !!SIN(mu) COS(nv) + zmncc => rzl_array(:,:,:,zcc+ntmax) !!COS(mu) COS(nv) + lmncc => rzl_array(:,:,:,zcc+2*ntmax) !!COS(mu) COS(nv) + IF (lthreed) THEN + rmncs => rzl_array(:,:,:,rcs) !!COS(mu) SIN(nv) + zmnss => rzl_array(:,:,:,zss+ntmax) !!SIN(mu) SIN(nv) + lmnss => rzl_array(:,:,:,zss+2*ntmax) !!SIN(mu) SIN(nv) + END IF + +! +! CONVERT FROM INTERNAL XC REPRESENTATION FOR m=1 MODES, R+(at rsc) = .5(rsc + zcc), +! R-(at zcc) = .5(rsc - zcc), TO REQUIRED rsc, zcc FORMS +! + ioff = LBOUND(rmnsc,1) + joff = LBOUND(rmnsc,2) + CALL convert_asym_par(rmnsc(:,m1+joff,:), zmncc(:,m1+joff,:), + & nsmin, nsmax) + + z00b = zmncc(ioff,joff,ns) + + ALLOCATE (work1(nzeta,12,nsmin:nsmax), stat=i) + IF (i .NE. 0) THEN + STOP 'Allocation error in VMEC totzspa' + END IF + +! +! INITIALIZATION BLOCK +! + + IF (jlam(m0) .gt. 1) THEN + lmncc(:,m0+joff,1) = lmncc(:,m0+joff,2) + END IF + + DO js = nsmin, nsmax + r11(:,:,js,:) = 0 + ru1(:,:,js,:) = 0 + rv1(:,:,js,:) = 0 + rcn1(:,:,js,:) = 0 + zcn1(:,:,js,:) = 0 + z11(:,:,js,:) = 0 + zu1(:,:,js,:) = 0 + zv1(:,:,js,:) = 0 + lu1(:,:,js,:) = 0 + lv1(:,:,js,:) = 0 + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m+joff + work1(:,:,js) = 0 + j1 = jmin1(m) + + DO n = 0, ntor + ni = n+ioff + DO k = 1, nzeta + work1(k,1,js) = work1(k,1,js) + & + rmnsc(ni,mj,js)*cosnv(k,n) + work1(k,6,js) = work1(k,6,js) + & + zmncc(ni,mj,js)*cosnv(k,n) + work1(k,10,js) = work1(k,10,js) + & + lmncc(ni,mj,js)*cosnv(k,n) + + IF (.NOT.lthreed) CYCLE + + work1(k,2,js) = work1(k,2,js) + & + rmncs(ni,mj,js)*sinnv(k,n) + work1(k,3,js) = work1(k,3,js) + & + rmnsc(ni,mj,js)*sinnvn(k,n) + work1(k,4,js) = work1(k,4,js) + & + rmncs(ni,mj,js)*cosnvn(k,n) + work1(k,5,js) = work1(k,5,js) + & + zmnss(ni,mj,js)*sinnv(k,n) + work1(k,7,js) = work1(k,7,js) + & + zmnss(ni,mj,js)*cosnvn(k,n) + work1(k,8,js) = work1(k,8,js) + & + zmncc(ni,mj,js)*sinnvn(k,n) + work1(k,9,js) = work1(k,9,js) + & + lmnss(ni,mj,js)*sinnv(k,n) + work1(k,11,js) = work1(k,11,js) + & + lmnss(ni,mj,js)*cosnvn(k,n) + work1(k,12,js) = work1(k,12,js) + & + lmncc(ni,mj,js)*sinnvn(k,n) + END DO + END DO + +! +! INVERSE TRANSFORM IN M-THETA +! + DO i = 1, ntheta2 + cosmux = xmpq(m,1)*cosmu(i,m) + sinmux = xmpq(m,1)*sinmu(i,m) + + r11(:,i,js,mparity) = r11(:,i,js,mparity) + & + work1(:,1,js)*sinmu(i,m) + ru1(:,i,js,mparity) = ru1(:,i,js,mparity) + & + work1(:,1,js)*cosmum(i,m) + z11(:,i,js,mparity) = z11(:,i,js,mparity) + & + work1(:,6,js)*cosmu(i,m) + zu1(:,i,js,mparity) = zu1(:,i,js,mparity) + & + work1(:,6,js)*sinmum(i,m) + lu1(:,i,js,mparity) = lu1(:,i,js,mparity) + & + work1(:,10,js)*sinmum(i,m) + rcn1(:,i,js,mparity) = rcn1(:,i,js,mparity) + & + work1(:,1,js)*sinmux + zcn1(:,i,js,mparity) = zcn1(:,i,js,mparity) + & + work1(:,6,js)*cosmux + + IF (.not.lthreed) CYCLE + + r11(:,i,js,mparity) = r11(:,i,js,mparity) + & + work1(:,2,js)*cosmu(i,m) + ru1(:,i,js,mparity) = ru1(:,i,js,mparity) + & + work1(:,2,js)*sinmum(i,m) + z11(:,i,js,mparity) = z11(:,i,js,mparity) + & + work1(:,5,js)*sinmu(i,m) + zu1(:,i,js,mparity) = zu1(:,i,js,mparity) + & + work1(:,5,js)*cosmum(i,m) + lu1(:,i,js,mparity) = lu1(:,i,js,mparity) + & + work1(:,9,js)*cosmum(i,m) + rcn1(:,i,js,mparity) = rcn1(:,i,js,mparity) + & + work1(:,2,js)*cosmux + zcn1(:,i,js,mparity) = zcn1(:,i,js,mparity) + & + work1(:,5,js)*sinmux + rv1(:,i,js,mparity) = rv1(:,i,js,mparity) + & + work1(:,3,js)*sinmu(i,m) + & + work1(:,4,js)*cosmu(i,m) + zv1(:,i,js,mparity) = zv1(:,i,js,mparity) + & + work1(:,7,js)*sinmu(i,m) + & + work1(:,8,js)*cosmu(i,m) + lv1(:,i,js,mparity) = lv1(:,i,js,mparity) + & - work1(:,11,js)*sinmu(i,m) + & - work1(:,12,js)*cosmu(i,m) + END DO + END DO + END DO + + DEALLOCATE (work1) + + CALL second0(tfftoff) + totzspa_time = totzspa_time + (tfftoff - tffton) + timer(tfft) = timer(tfft) + (tfftoff - tffton) + + END SUBROUTINE totzspa_par + + SUBROUTINE convert_sym_par(rmnss, zmncs, nsmin, nsmax) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: nsmin, nsmax + REAL(dp), DIMENSION(0:ntor,ns), INTENT(INOUT) :: rmnss, zmncs +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,nsmin:nsmax) :: temp +C----------------------------------------------- +! +! CONVERT FROM INTERNAL REPRESENTATION TO "PHYSICAL" RMNSS, ZMNCS FOURIER FORM +! (for lconm1, rss = zmncs) +! + IF (lconm1) THEN + temp(:,nsmin:nsmax) = rmnss(:,nsmin:nsmax) + rmnss(:,nsmin:nsmax) = temp(:,nsmin:nsmax) + & + zmncs(:,nsmin:nsmax) + zmncs(:,nsmin:nsmax) = temp(:,nsmin:nsmax) + & - zmncs(:,nsmin:nsmax) + END IF + + END SUBROUTINE convert_sym_par + + SUBROUTINE convert_asym_par(rmnsc, zmncc, nsmin, nsmax) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: nsmin, nsmax + REAL(dp), DIMENSION(0:ntor,ns), INTENT(INOUT) :: rmnsc, zmncc +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,nsmin:nsmax) :: temp +C----------------------------------------------- +! +! CONVERT FROM INTERNAL REPRESENTATION TO RMNSC, ZMNCC FOURIER FORM +! + IF (lconm1) THEN + temp(:,nsmin:nsmax) = rmnsc(:,nsmin:nsmax) + rmnsc(:,nsmin:nsmax) = temp(:,nsmin:nsmax) + & + zmncc(:,nsmin:nsmax) + zmncc(:,nsmin:nsmax) = temp(:,nsmin:nsmax) + & - zmncc(:,nsmin:nsmax) + END IF + + END SUBROUTINE convert_asym_par + + SUBROUTINE totzsps(rzl_array, r11, ru1, rv1, z11, zu1, zv1, + & lu1, lv1, rcn1, zcn1) + USE vmec_params, ONLY: jmin1, jlam, ntmax, rcc, rss, zsc, zcs + USE precon2d, ONLY: ictrl_prec2d + +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + & TARGET, INTENT(INOUT) :: rzl_array + REAL(dp), DIMENSION(ns*nzeta*ntheta3,0:1), + & INTENT(OUT) :: r11, ru1, + & rv1, z11, zu1, zv1, lu1, lv1, rcn1, zcn1 +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: n, m, mparity, k, i, j1, l, j1l, nsl + INTEGER :: ioff, joff, mj, ni, nsz + REAL(dp), DIMENSION(:,:,:), POINTER :: + & rmncc, rmnss, zmncs, zmnsc, lmncs, lmnsc +!----------------------------------------------- +! +! WORK1 Array of inverse transforms in toroidal angle (zeta), for all radial positions +! NOTE: ORDERING OF LAST INDEX IS DIFFERENT HERE THAN IN PREVIOUS VMEC2000 VERSIONS +! +! CONVERT FROM INTERNAL XC REPRESENTATION FOR m=1 MODES, R+(stored at rss) = .5(rss + zcs), +! R-(stored at zcs) = .5(rss - zcs), TO EXTERNAL ("PHYSICAL") rss, zcs FORMS. NEED THIS EVEN +! WHEN COMPUTING HESSIAN FOR FREE BOUNDARY (rmnss, zmncs at JS=NS needed in vacuum call) +! + CALL second0(tffton) + + rmncc => rzl_array(:,:,:,rcc) !!COS(mu) COS(nv) + zmnsc => rzl_array(:,:,:,zsc+ntmax) !!SIN(mu) COS(nv) + lmnsc => rzl_array(:,:,:,zsc+2*ntmax) !!SIN(mu) COS(nv) + IF (lthreed) THEN + rmnss => rzl_array(:,:,:,rss) !!SIN(mu) SIN(nv) + zmncs => rzl_array(:,:,:,zcs+ntmax) !!COS(mu) SIN(nv) + lmncs => rzl_array(:,:,:,zcs+2*ntmax) !!COS(mu) SIN(nv) + END IF + + ioff = LBOUND(rmncc,2) + joff = LBOUND(rmncc,3) +#ifndef _HBANGLE + IF (lthreed) THEN + CALL convert_sym(rmnss(:,:,m1+joff), zmncs(:,:,m1+joff)) + END IF +#endif + +!v8.50: Norm for preconditioned R,Z forces: scale to boundary value only +!v8.51 Restore hs dependence (1:ns, not just ns) +! fnorm1 = one/SUM(rzl_array(1:ns,:,m1:,1:2*ntmax)**2) + +! +! ORIGIN EXTRAPOLATION (JS=1) FOR M=1 MODES +! NOTE: PREVIOUS VERSIONS OF VMEC USED TWO-POINT EXTRAPOLATION +! FOR R,Z. HOWEVER,THIS CAN NOT BE USED TO COMPUTE THE +! TRI-DIAG 2D PRECONDITIONER +! + rzl_array(1,:,m1,:) = rzl_array(2,:,m1,:) + +! +! ORIGIN EXTRAPOLATION OF M=0 MODES FOR LAMBDA +! + IF (lthreed .and. jlam(m0) .gt. 1) THEN + lmncs(1,:,m0+joff) = lmncs(2,:,m0+joff) + END IF + +! +! EVOLVE CHIPS BY FORCES IN TOMNSPS WHEN NCURR=1, ICTRL_PREC2D != 0 +! +#if defined(CHI_FORCE) + IF (ncurr .EQ. 1) THEN + IF (ictrl_prec2d .EQ. 2) THEN + lmnsc(2:ns,n0+ioff,m0+joff) = chips(2:ns) + ELSE IF (ictrl_prec2d .NE. 0) THEN + chips(2:ns) = lmnsc(2:ns,n0+ioff,m0+joff) + END IF + END IF +#endif + nsz = ns*nzeta + ALLOCATE (work2(nsz,12), stat=i) + IF (i .NE. 0) THEN + STOP 'Allocation error in VMEC2000 totzsps' + END IF + + r11 = 0 + ru1 = 0 + rv1 = 0 + rcn1 = 0 + z11 = 0 + zu1 = 0 + zv1 = 0 + zcn1 = 0 + lu1 = 0 + lv1 = 0 + +! +! COMPUTE R, Z, AND LAMBDA IN REAL SPACE +! NOTE: LU = d(Lam)/du, LV = -d(Lam)/dv +! + + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m + joff + work2 = 0 + j1 = jmin1(m) +! +! INVERSE TRANSFORM IN N-ZETA, FOR FIXED M +! + DO n = 0, ntor + ni = n+ioff + DO k = 1, nzeta + l = ns*(k - 1) + j1l = j1 + l + nsl = ns + l + work2(j1l:nsl,1) = work2(j1l:nsl,1) + 1 + rmncc(j1:ns,ni,mj)*cosnv(k,n) + work2(j1l:nsl,6) = work2(j1l:nsl,6) + 1 + zmnsc(j1:ns,ni,mj)*cosnv(k,n) + work2(j1l:nsl,10) = work2(j1l:nsl,10) + 1 + lmnsc(j1:ns,ni,mj)*cosnv(k,n) + + IF (.not.lthreed) CYCLE + + work2(j1l:nsl,4) = work2(j1l:nsl,4) + 1 + rmnss(j1:ns,ni,mj)*cosnvn(k,n) + work2(j1l:nsl,7) = work2(j1l:nsl,7) + 1 + zmncs(j1:ns,ni,mj)*cosnvn(k,n) + work2(j1l:nsl,11) = work2(j1l:nsl,11) + 1 + lmncs(j1:ns,ni,mj)*cosnvn(k,n) + + work2(j1l:nsl,2) = work2(j1l:nsl,2) + 1 + rmnss(j1:ns,ni,mj)*sinnv(k,n) + work2(j1l:nsl,5) = work2(j1l:nsl,5) + 1 + zmncs(j1:ns,ni,mj)*sinnv(k,n) + work2(j1l:nsl,9) = work2(j1l:nsl,9) + 1 + lmncs(j1:ns,ni,mj)*sinnv(k,n) + + work2(j1l:nsl,3) = work2(j1l:nsl,3) + 1 + rmncc(j1:ns,ni,mj)*sinnvn(k,n) + work2(j1l:nsl,8) = work2(j1l:nsl,8) + 1 + zmnsc(j1:ns,ni,mj)*sinnvn(k,n) + work2(j1l:nsl,12) = work2(j1l:nsl,12) + 1 + lmnsc(j1:ns,ni,mj)*sinnvn(k,n) + END DO + END DO +! +! INVERSE TRANSFORM IN M-THETA, FOR ALL RADIAL, ZETA VALUES +! + l = 0 + DO i = 1, ntheta2 + j1l = l + 1 + nsl = nsz + l + l = l + nsz + cosmux = xmpq(m,1)*cosmu(i,m) + sinmux = xmpq(m,1)*sinmu(i,m) + + r11(j1l:nsl,mparity) = r11(j1l:nsl,mparity) + 1 + work2(1:nsz,1)*cosmu(i,m) + ru1(j1l:nsl,mparity) = ru1(j1l:nsl,mparity) + 1 + work2(1:nsz,1)*sinmum(i,m) +#ifndef _HBANGLE + rcn1(j1l:nsl,mparity) = rcn1(j1l:nsl,mparity) + 1 + work2(1:nsz,1)*cosmux +#endif + + z11(j1l:nsl,mparity) = z11(j1l:nsl,mparity) + 1 + work2(1:nsz,6)*sinmu(i,m) + zu1(j1l:nsl,mparity) = zu1(j1l:nsl,mparity) + 1 + work2(1:nsz,6)*cosmum(i,m) +#ifndef _HBANGLE + zcn1(j1l:nsl,mparity) = zcn1(j1l:nsl,mparity) + 1 + work2(1:nsz,6)*sinmux +#endif + + lu1(j1l:nsl,mparity) = lu1(j1l:nsl,mparity) + 1 + work2(1:nsz,10)*cosmum(i,m) + + IF (.not.lthreed) CYCLE + + r11(j1l:nsl,mparity) = r11(j1l:nsl,mparity) + 1 + work2(1:nsz,2)*sinmu(i,m) + ru1(j1l:nsl,mparity) = ru1(j1l:nsl,mparity) + 1 + work2(1:nsz,2)*cosmum(i,m) +#ifndef _HBANGLE + rcn1(j1l:nsl,mparity) = rcn1(j1l:nsl,mparity) + 1 + work2(1:nsz,2)*sinmux +#endif + + rv1(j1l:nsl,mparity) = rv1(j1l:nsl,mparity) + 1 + work2(1:nsz,3)*cosmu(i,m) + 1 + work2(1:nsz,4)*sinmu(i,m) + z11(j1l:nsl,mparity) = z11(j1l:nsl,mparity) + 1 + work2(1:nsz,5)*cosmu(i,m) + + zu1(j1l:nsl,mparity) = zu1(j1l:nsl,mparity) + 1 + work2(1:nsz,5)*sinmum(i,m) +#ifndef _HBANGLE + zcn1(j1l:nsl,mparity) = zcn1(j1l:nsl,mparity) + 1 + work2(1:nsz,5)*cosmux +#endif + zv1(j1l:nsl,mparity) = zv1(j1l:nsl,mparity) + 1 + work2(1:nsz,7)*cosmu(i,m) + 1 + work2(1:nsz,8)*sinmu(i,m) + + lu1(j1l:nsl,mparity) = lu1(j1l:nsl,mparity) + 1 + work2(1:nsz,9)*sinmum(i,m) + lv1(j1l:nsl,mparity) = lv1(j1l:nsl,mparity) + 1 - work2(1:nsz,11)*cosmu(i,m) + 1 - work2(1:nsz,12)*sinmu(i,m) + END DO + END DO + + DEALLOCATE (work2) + + z01(1:ns) = zmnsc(1:ns,n0+ioff,m1+joff) + r01(1:ns) = rmncc(1:ns,n0+ioff,m1+joff) + IF (r01(1) .eq. zero) THEN + STOP 'r01(0) = 0 in totzsps_SPH' + END IF + dkappa = z01(1)/r01(1) + + END SUBROUTINE totzsps + + SUBROUTINE convert_sym(rmnss, zmncs) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor), INTENT(INOUT) :: rmnss, zmncs +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor) :: temp +C----------------------------------------------- +! +! CONVERT FROM INTERNAL REPRESENTATION TO "PHYSICAL" RMNSS, ZMNCS FOURIER FORM +! + IF (lconm1) THEN + temp = rmnss + rmnss = temp + zmncs + zmncs = temp - zmncs + END IF + + END SUBROUTINE convert_sym + + + SUBROUTINE totzspa(rzl_array, r11, ru1, rv1, z11, zu1, zv1, lu1, + & lv1, rcn1, zcn1) + USE vmec_params, ONLY: jmin1, jlam, ntmax, rcs, rsc, zcc, zss + USE precon2d, ONLY: ictrl_prec2d + +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + 1 TARGET, INTENT(inout) :: rzl_array + REAL(dp), DIMENSION(ns*nzeta,ntheta3,0:1), INTENT(out) :: + 1 r11, ru1, rv1, z11, zu1, zv1, lu1, lv1, rcn1, zcn1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: m, n, mparity, k, i, l, j1, j1l, nsl + INTEGER :: ioff, joff, mj, ni + REAL(dp), DIMENSION(:,:,:), POINTER :: + 1 rmncs, rmnsc, zmncc, zmnss, lmncc, lmnss +C----------------------------------------------- + CALL second0(tffton) + rmnsc => rzl_array(:,:,:,rsc) !!SIN(mu) COS(nv) + zmncc => rzl_array(:,:,:,zcc+ntmax) !!COS(mu) COS(nv) + lmncc => rzl_array(:,:,:,zcc+2*ntmax) !!COS(mu) COS(nv) + IF (lthreed) THEN + rmncs => rzl_array(:,:,:,rcs) !!COS(mu) SIN(nv) + zmnss => rzl_array(:,:,:,zss+ntmax) !!SIN(mu) SIN(nv) + lmnss => rzl_array(:,:,:,zss+2*ntmax) !!SIN(mu) SIN(nv) + END IF + +! +! CONVERT FROM INTERNAL XC REPRESENTATION FOR m=1 MODES, R+(at rsc) = .5(rsc + zcc), +! R-(at zcc) = .5(rsc - zcc), TO REQUIRED rsc, zcc FORMS +! + ioff = LBOUND(rmnsc,2) + joff = LBOUND(rmnsc,3) + CALL convert_asym(rmnsc(:,:,m1+joff), zmncc(:,:,m1+joff)) + + z00b = zmncc(ns,ioff,joff) + + IF (jlam(m0) .GT. 1) THEN + lmncc(1,:,m0+joff) = lmncc(2,:,m0+joff) + END IF + +! IF (ictrl_prec2d .eq. 3) RETURN + + ALLOCATE (work2(ns*nzeta,12), stat=i) + IF (i .ne. 0) STOP 'Allocation error in VMEC totzspa' + +! +! INITIALIZATION BLOCK +! + r11 = 0 + ru1 = 0 + rv1 = 0 + z11 = 0 + zu1 = 0 + zv1 = 0 + lu1 = 0 + lv1 = 0 + rcn1 = 0 + zcn1 = 0 + + DO m = 0, mpol1 + mparity = MOD(m,2) + mj = m + joff + work2 = 0 + j1 = jmin1(m) + DO n = 0, ntor + ni = n + ioff + DO k = 1, nzeta + l = ns*(k - 1) + j1l = j1 + l + nsl = ns + l + work2(j1l:nsl,1) = work2(j1l:nsl,1) + 1 + rmnsc(j1:ns,ni,mj)*cosnv(k,n) + work2(j1l:nsl,6) = work2(j1l:nsl,6) + 1 + zmncc(j1:ns,ni,mj)*cosnv(k,n) + work2(j1l:nsl,10) = work2(j1l:nsl,10) + 1 + lmncc(j1:ns,ni,mj)*cosnv(k,n) + + IF (.not.lthreed) CYCLE + + work2(j1l:nsl,2) = work2(j1l:nsl,2) + 1 + rmncs(j1:ns,ni,mj)*sinnv(k,n) + work2(j1l:nsl,3) = work2(j1l:nsl,3) + 1 + rmnsc(j1:ns,ni,mj)*sinnvn(k,n) + work2(j1l:nsl,4) = work2(j1l:nsl,4) + 1 + rmncs(j1:ns,ni,mj)*cosnvn(k,n) + work2(j1l:nsl,5) = work2(j1l:nsl,5) + 1 + zmnss(j1:ns,ni,mj)*sinnv(k,n) + work2(j1l:nsl,7) = work2(j1l:nsl,7) + 1 + zmnss(j1:ns,ni,mj)*cosnvn(k,n) + work2(j1l:nsl,8) = work2(j1l:nsl,8) + 1 + zmncc(j1:ns,ni,mj)*sinnvn(k,n) + work2(j1l:nsl,9) = work2(j1l:nsl,9) + 1 + lmnss(j1:ns,ni,mj)*sinnv(k,n) + work2(j1l:nsl,11) = work2(j1l:nsl,11) + 1 + lmnss(j1:ns,ni,mj)*cosnvn(k,n) + work2(j1l:nsl,12) = work2(j1l:nsl,12) + 1 + lmncc(j1:ns,ni,mj)*sinnvn(k,n) + END DO + END DO + +! +! INVERSE TRANSFORM IN M-THETA +! + DO i = 1, ntheta2 + cosmux = xmpq(m,1)*cosmu(i,m) + sinmux = xmpq(m,1)*sinmu(i,m) + r11(:,i,mparity) = r11(:,i,mparity) + work2(:,1)*sinmu(i,m) + ru1(:,i,mparity) = ru1(:,i,mparity) + work2(:,1)*cosmum(i,m) + z11(:,i,mparity) = z11(:,i,mparity) + work2(:,6)*cosmu(i,m) + zu1(:,i,mparity) = zu1(:,i,mparity) + work2(:,6)*sinmum(i,m) + lu1(:,i,mparity) = lu1(:,i,mparity) + & + work2(:,10)*sinmum(i,m) + rcn1(:,i,mparity) = rcn1(:,i,mparity) + & + work2(:,1)*sinmux + zcn1(:,i,mparity) = zcn1(:,i,mparity) + & + work2(:,6)*cosmux + + IF (.not.lthreed) CYCLE + + r11(:,i,mparity) = r11(:,i,mparity) + & + work2(:,2)*cosmu(i,m) + ru1(:,i,mparity) = ru1(:,i,mparity) + & + work2(:,2)*sinmum(i,m) + z11(:,i,mparity) = z11(:,i,mparity) + & + work2(:,5)*sinmu(i,m) + zu1(:,i,mparity) = zu1(:,i,mparity) + & + work2(:,5)*cosmum(i,m) + lu1(:,i,mparity) = lu1(:,i,mparity) + & + work2(:,9)*cosmum(i,m) + rcn1(:,i,mparity) = rcn1(:,i,mparity) + & + work2(:,2)*cosmux + zcn1(:,i,mparity) = zcn1(:,i,mparity) + & + work2(:,5)*sinmux + rv1(:,i,mparity) = rv1(:,i,mparity) + & + work2(:,3)*sinmu(i,m) + & + work2(:,4)*cosmu(i,m) + zv1(:,i,mparity) = zv1(:,i,mparity) + & + work2(:,7)*sinmu(i,m) + & + work2(:,8)*cosmu(i,m) + lv1(:,i,mparity) = lv1(:,i,mparity) + & - work2(:,11)*sinmu(i,m) + & - work2(:,12)*cosmu(i,m) + END DO + END DO + + DEALLOCATE (work2) + + END SUBROUTINE totzspa + + + SUBROUTINE convert_asym(rmnsc, zmncc) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor), INTENT(INOUT) :: rmnsc, zmncc +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor) :: temp +C----------------------------------------------- +! +! CONVERT FROM INTERNAL REPRESENTATION TO RMNSC, ZMNCC FOURIER FORM +! + IF (lconm1) THEN + temp = rmnsc + rmnsc = temp + zmncc + zmncc = temp - zmncc + END IF + + END SUBROUTINE convert_asym + + END MODULE totzsp_mod diff --git a/Sources/General/vforces.f b/Sources/General/vforces.f new file mode 100644 index 0000000..8bdf44b --- /dev/null +++ b/Sources/General/vforces.f @@ -0,0 +1,22 @@ + MODULE vforces + USE stel_kinds, ONLY: rprec + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec), DIMENSION(:), ALLOCATABLE, TARGET :: + 1 armn, azmn, brmn, bzmn, crmn, czmn, blmn, clmn + REAL(rprec), POINTER, DIMENSION(:) :: + 1 armn_e, armn_o, azmn_e, azmn_o, + 2 brmn_e, brmn_o, bzmn_e, bzmn_o, + 3 crmn_e, crmn_o, czmn_e, czmn_o, blmn_e, + 4 blmn_o, clmn_e, clmn_o + REAL(rprec), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: + 1 parmn, pazmn, pbrmn, pbzmn, pcrmn, pczmn, pblmn, pclmn + REAL(rprec), POINTER, DIMENSION(:,:) :: + 1 parmn_e, parmn_o, pazmn_e, pazmn_o, + 2 pbrmn_e, pbrmn_o, pbzmn_e, pbzmn_o, + 3 pcrmn_e, pcrmn_o, pczmn_e, pczmn_o, + 4 pblmn_e, pblmn_o, pclmn_e, pclmn_o +c----------------------------------------------- + END MODULE vforces diff --git a/Sources/General/vmec_dim.f b/Sources/General/vmec_dim.f new file mode 100644 index 0000000..446b82e --- /dev/null +++ b/Sources/General/vmec_dim.f @@ -0,0 +1,10 @@ + MODULE vmec_dim + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mpol1, ntor1, mnmax, ntheta1, ntheta2, ntheta3, + 1 nznt, nrzt, mns, mnsize, mnmax_nyq, ns, ns1, + 2 ns_maxval +C----------------------------------------------- + END MODULE vmec_dim diff --git a/Sources/General/vmec_main.f b/Sources/General/vmec_main.f new file mode 100644 index 0000000..1c94a63 --- /dev/null +++ b/Sources/General/vmec_main.f @@ -0,0 +1,61 @@ + MODULE vmec_main + USE vmec_dim + USE vmec_input + USE vmec_persistent + USE vmec_params, ONLY: ndamp + USE vparams + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: + 1 ard, arm, brd, brm, azd, azm, bzd, bzm, bmin, bmax + REAL(dp), DIMENSION(:), ALLOCATABLE :: + 1 crd, iotaf, phipf, chipf, mass, phi, presf, beta_vol, + 2 jcuru, jcurv, jdotb, +#ifdef _ANIMEC +!WAC: ANISOTROPIC ARRAYS + 2 phot, pmap, pppr, papr, tpotb, pd, +#endif + 2 buco, bvco, bdotgradv, equif, specw, tcon, + 3 psi, yellip, yinden, ytrian, yshift, ygeo, overr, + 4 sm, sp, iotas, phips, chips, pres, vp, jpar2, jperp2, bdotb, + 5 blam, clam, dlam, icurv, vpphi, presgrad, + 6 r01, z01, bdamp, bucof, bvcof, chi + REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: faclam, faclam0 + REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: pfaclam + REAL(dp), ALLOCATABLE :: xcl0(:) + + REAL(dp), DIMENSION(0:mpol1d,3) :: xmpq + REAL(dp), DIMENSION(0:mpol1d) :: faccon + REAL(dp) :: dcon, currv, aspect, hs, ohs, voli, + 1 signiota, rc0mse, r00, r0scale, z00, dkappa, fsqsum0, + 2 pressum0, fnorm, fsqr=1, fsqz=1, fsql=1, fnorm1, fnorml, + 3 fsqr1, fsqz1, fsql1, fsq, fedge, wb, wp, r00b, z00b, fz00_edge +#ifdef _ANIMEC + 4 ,wpar, wper +#endif + REAL(dp), DIMENSION(nstore_seq) :: fsqt, wdot + REAL(dp) :: ftolv, otav, alphaR, alphaZ + REAL(dp), DIMENSION(ndamp) :: otau + REAL(dp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: + 1 rmn_bdy, zmn_bdy + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: bsqsav + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubu0, dbsq, rbsq +#ifdef _ANIMEC + REAL(dp), DIMENSION(:), ALLOCATABLE :: pperp_ns + REAL(dp) :: medge, phedg +#endif + REAL(dp) :: rbtor, rbtor0, ctor, delbsq, res0, res1, delt0r !DO NOT remove res0, delt0r -> V3FIT + REAL(dp), DIMENSION(ndatafmax) :: + 1 spfa, spfa2, hp, sifa, sifa2, hi + LOGICAL :: lthreed, lconm1 + INTEGER, DIMENSION(:), ALLOCATABLE :: ireflect + INTEGER :: multi_ns_grid, iequi, itype_precon, irst, + 1 iter1, iter2, iterc=1, ijacob, itfsq, iresidue, neqs, + 2 irzloff, ivac, ndatap, ndatai + + REAL(dp) :: router + REAL(dp) :: rinner +C----------------------------------------------- + END MODULE vmec_main diff --git a/Sources/General/vmec_params.f b/Sources/General/vmec_params.f new file mode 100644 index 0000000..132bd83 --- /dev/null +++ b/Sources/General/vmec_params.f @@ -0,0 +1,143 @@ + MODULE vmec_params + USE stel_kinds, ONLY: rprec, dp + USE vparams, ONLY: mpold +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER, PARAMETER :: meven = 0, modd = 1 + INTEGER, PARAMETER :: ndamp = 10 + INTEGER, PARAMETER :: ns4 = 25 + + INTEGER, PRIVATE :: ink + INTEGER, PARAMETER, DIMENSION(0:mpold) :: + 1 jmin1 = (/ 1,1,(2,ink=2,mpold) /), !starting js(m) values where R,Z are non-zero + 2 jmin2 = (/ 1,2,(2,ink=2,mpold) /), !starting js(m) values for which R,Z are evolved + 3 jlam = (/ 2,2,(2,ink=2,mpold) /) !starting js(m) values for which Lambda is evolved + +! Besure to update werror in fileout.f when adding more error flags. + INTEGER, PARAMETER :: norm_term_flag=0, bad_jacobian_flag=1, + 1 more_iter_flag=2, + 2 jac75_flag=4, input_error_flag=5, + 3 phiedge_error_flag=7, + 4 ns_error_flag=8, + 5 misc_error_flag=9, + 6 successful_term_flag=11, !ftol force criterion has been met + 7 bsub_bad_js1_flag=12, + 8 r01_bad_value_flag=13, + 9 arz_bad_value_flag=14 + INTEGER, PARAMETER :: restart_flag=1, readin_flag=2, + 1 timestep_flag=4,output_flag=8, + 2 cleanup_flag=16, reset_jacdt_flag=32 + + REAL(rprec), PARAMETER :: pdamp = 0.05_dp + CHARACTER(LEN=*), PARAMETER :: version_ = '9.0' +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: ntmax, rcc, rss, rsc, rcs, zsc, zcs, zcc, zss + INTEGER :: mnyq, nnyq + INTEGER, ALLOCATABLE :: uminus(:) + REAL(rprec), ALLOCATABLE :: mscale(:), nscale(:) + REAL(rprec) :: signgs, lamscale +!----------------------------------------------- +! +! VERSION INFORMATION HISTORY +! +! 8.00 +! a) added lforbal logical to fbal module to control whether to compute the flux-averaged +! force balance equation printed in the threed1 file. This requires a modification of +! the m=1,n=0 forces for R,Z in tomnsps subroutine. This works well, generally, and +! yields an improved in threed1 file. However, there have been some cases where +! this non-variational departure fails to converge. +! b) added "bias" to iotas in bcovar when determining preconditioner for very small iota +! values. Seems to need this for improving convergence of preconditioned current-hole cases. +! Eliminated in v8.20. +! c) added "totzsps,a_hess" to recompute r,z,l rapidly for only those modes that are jogged during +! Hessian calculation. NOTE: need to do this for lasym=true case, as well, eventually +! 8.20 (August, 2004) +! a) removed 2-pt tie at origin for m=1 modes, to preserve tri-diagonal structure of Hessian. +! This is needed for preconditioning, which assumes block-tridi structure of equations +! b) fixed problem with free-boundary preconditioner, namely, ctor can not be extrapolated +! at edge when computing preconditioner, because this breaks tri-diagonal structure +! c) added new variables to input file to control preconditioning: +! 1) PRECON_TYPE: = 'default', default tri-di (block size = 1) +! = 'cg', block tri-di, conjugate-gradient time-stepper +! = 'gmres', " ", gmres time-stepper +! = 'tfqmr', " ", transpose free qmr +! 2) PREC2D_THRESHOLD: value of (unpreconditioned) forces at which block (2D) preconditioner +! is turned on (=0 block preconditioner never turned on); recommended +! (default) value ~ 1.E-10, or smaller, if convergence is poor +! 3) LFORBAL: logical variable (default = .true.); when true, the force balance +! used in the threed1 file is used to evolve the m=1 R,Z components. This +! is a non-variational departure from the force equations for these modes, +! but generally does not have an unfavorable impact on convergence. +! d) added new internal variable, ICTRL_PREC2D, to precon2d module. Replaces previous lprec2d +! and iequi>1 variables. +! e) removed lsweep_fast option from module precon2d. This slows the computation of the Hessian +! by about 2/3, but is more accurate (includes pdamp, liota, lforbal correctly) +! f) removed lflam logicals from bcovar and tomnsps, since now we must compute dFlam/dR,Z by +! jogging +! g) removed Compute_Hess_Flam_RZ from lamblks; this is now computed via jogging +! (also removed Get_dFlam_dRZ, FFT2Hessian, Forbal_avg, GetGsqrtVar supporting routines) +! h) removed internal liota logic, used to push iota profile rather than solving for it. Had +! needed this for symmetric Hessian (lsweep_fast=true option), but no longer required. Also, +! it was not implemented entirely correctly for lforbal=true case +! i) for lasym m=1 constraint rsc = zcc, changed xc array so that R+ = .5*(rsc + zcc) is stored at +! xc(rsc,m=1) and R- = .5*(rsc - zcc) is stored at xc(zcc,m=1). In residue, gcz(R-) == gcz(zcc) +! is zeroed by "evolving" gcr(zcc) = azd*[xc(zcc)-xcint], and gcr(rsc) => .5*[gcr(rsc) + gcz(zcc)] +! is evolved. In totzspa, the real rsc and zcc are computed from the internal representations +! (check convert call, too) by calling a new routine convert_asym (also called from wrout before +! writing out xc info). In readin, the original R+,R- are stored, so that for external "jogs", +! there will be no change in forces. All these changes are needed to obtain an invertible Hessian. +! j) added m=1 constraint for 3D case (similar to (i)), rss(n) = zcs(n), for n != 0. Imposed this +! on forces by adding routine constrain_m1 in residue. Added convert_sym routine to totzsp to convert +! from internal xc representation TO internal one. +! k) Decreased exponent on pdamp factor r2 (in bcovar) from 2 to 1, to give better conditioning +! especially for current hole cases +! l) Eliminated iotas bias for determining preconditioner, previously added in v8.00 for stabilizing +! current hole cases (not needed with corrected preconditioner) +! 8.30 (October, 2004) +! a) Implemented flags for "reverse-communication" mode of vmec +! 8.40 a) Converted the m=1 constraints for 3D and asym back to old way; did not always +! converge well with the new constraints introduced in 8.20 (i-j) +! 8.45 (December, 2005) +! a) Added the lconm1 logical. If = True, new constraint; if = False, old m=1 constraint used +! b) Added "perturbation" computation for lasym=TRUE case (totzspa_hess) +! 8.46 (June, 2009) +! a) Added LRFP logical to allow easy switching of profiles between Stellarator/tokamak (PHIP=1, LRFP=F) +! and RFP (CHIP=1, LRFP=T). When LRFP=T, AI coefficients are expansion of q = 1/iota. Added lrfp to +! LIBSTELL/vmec_input module. +! 8.47 (July, 2010) +! a) Rewrote magnetic field representation so that phip*lambda = new internal lambda. This greatly improves +! the conditioning of the lambda equations which otherwise become singular at the RFP reversal point +! 8.48 (March 2012 - JDH) +! a) Accumulated small changes from SPH & JDH +! b) Modifications from J Geiger, March 2012 +! - to be able to get additional main iterations if the force tolerance is +! not met. Parameter MAX_MAIN_ITERATIONS specifies how many main iteration +! cycles should be run. +! - to get a full output in the threed1-file if the force tolerance is not +! met. Specify the logical LFULL3D1OUT to true for this. +! - if vmec2000 is compiled with netcdf, you can still get the ascii-output +! if you specify the logical LWOUTTXT as true. +! - you get the output for diagno 1.0 and 1.5 if the logical LDIAGNO set true. +! - you get a rather old fort.8-output if you specify LOLDOUT as true. +! +! If none of these new variables is set, the behavior of vmec2000 is as +! expected from the version without the changes. +! 8.49 (June, 2012) +! a) Fixed bug in bcovar when averaging half-grid covariant components onto full grid: did not +! zero components at (phantom) js=1 point, so edge force averages were incorrect +! b) Added lamscale factor to scale lambda in contravariant B-components. Modify wrout to maintain +! old-style lambda output +! c) Set lbsubs=F in jxbforce by default to capture current sheets +! d) Added lmove_axis INPUT logical (=T by default) so user can control whether or not the magnetic +! axis can be initially shifted to improve the initial force residuals. It is important NOT to move +! the helical axis for RFP equilibria requiring a helical seed (set l_moveaxis=F for this case!) +! +! 8.50 (Jan, 2013) +! a) Improved scaling of lambda forces with respect to lamscale +! b) Fixed fnorm1 scaling (remove hs dependence) +! c) Added lgiveup logical (M. Drevlak/J. Geiger) +!----------------------------------------------- + END MODULE vmec_params diff --git a/Sources/General/vmec_persistent.f b/Sources/General/vmec_persistent.f new file mode 100644 index 0000000..167b90f --- /dev/null +++ b/Sources/General/vmec_persistent.f @@ -0,0 +1,17 @@ + MODULE vmec_persistent + USE stel_kinds, ONLY: rprec + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, DIMENSION(:), ALLOCATABLE :: ixm, jmin3 + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: cosmu, sinmu, + 1 cosmum, sinmum, cosmumi, sinmumi, + 2 cosnv, sinnv, cosnvn, sinnvn + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: cosmui, sinmui, + 1 cosmui3, cosmumi3 + REAL(rprec), DIMENSION(:), ALLOCATABLE, TARGET :: + 1 xm, xn, xm_nyq, xn_nyq + REAL(rprec), DIMENSION(:), ALLOCATABLE :: cos01, sin01 +c----------------------------------------------- + END MODULE vmec_persistent diff --git a/Sources/General/xstuff.f b/Sources/General/xstuff.f new file mode 100644 index 0000000..18ef200 --- /dev/null +++ b/Sources/General/xstuff.f @@ -0,0 +1,17 @@ + MODULE xstuff + USE stel_kinds, ONLY: rprec + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec), DIMENSION(:), ALLOCATABLE :: + 1 gc, xcdot, xsave, xstore, scalxc, col_scale + REAL(rprec), DIMENSION(:), ALLOCATABLE, TARGET :: + 1 xc + + REAL(rprec), DIMENSION(:), ALLOCATABLE :: + 1 pgc, pxcdot, pxsave, pxstore, pscalxc, pcol_scale + REAL(rprec), DIMENSION(:), ALLOCATABLE, TARGET :: + 1 pxc +C----------------------------------------------- + END MODULE xstuff diff --git a/Sources/Hessian/CMakeLists.txt b/Sources/Hessian/CMakeLists.txt new file mode 100644 index 0000000..9116907 --- /dev/null +++ b/Sources/Hessian/CMakeLists.txt @@ -0,0 +1,4 @@ +target_sources(vmec + PRIVATE + $ +) diff --git a/Sources/Hessian/precon2d.f b/Sources/Hessian/precon2d.f new file mode 100644 index 0000000..db62fd3 --- /dev/null +++ b/Sources/Hessian/precon2d.f @@ -0,0 +1,2077 @@ + MODULE precon2d + USE stel_kinds, ONLY: dp + USE vmec_dim + USE vmec_params + USE vparams, ONLY: nthreed, one, zero + USE vmec_input, ONLY: ntor, nzeta, lfreeb, lasym + USE timer_sub + USE safe_open_mod + USE directaccess + USE parallel_include_module + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, PRIVATE, PARAMETER :: sp = dp + INTEGER, PRIVATE :: ntyptot, m_2d, n_2d, ntype_2d + INTEGER, PRIVATE, ALLOCATABLE :: ipiv_blk(:,:) + INTEGER, PRIVATE :: mblk_size + INTEGER, PRIVATE :: mystart(3), myend(3) + LOGICAL, PRIVATE :: FIRSTPASS=.TRUE. + REAL(sp),PRIVATE, ALLOCATABLE, DIMENSION(:,:,:,:,:,:,:) :: + 1 block_diag, block_plus, block_mins, + 2 block_dsave, block_msave, block_psave + REAL(sp),PRIVATE, ALLOCATABLE, DIMENSION(:,:,:,:,:,:) :: + 1 block_diag_sw, block_plus_sw, block_mins_sw + + REAL(dp), PRIVATE, DIMENSION(:,:,:,:), ALLOCATABLE :: gc_save + REAL(dp) :: ctor_prec2d + INTEGER :: ictrl_prec2d + LOGICAL :: lHess_exact = .TRUE., !FALSE -> FASTER, LESS ACCURATE VACUUM CALCULATION OF HESSIAN + 1 l_backslv = .FALSE., + 2 l_comp_prec2D = .TRUE., + 3 l_edge = .FALSE., !=T IF EDGE PERTURBED + 4 edge_mesh(3) + + LOGICAL, PARAMETER, PRIVATE :: lscreen = .FALSE. + INTEGER, PARAMETER, PRIVATE :: jstart(3) = (/1,2,3/) + + PRIVATE :: swap_forces, reswap_forces + +! +! Direct-Access (swap to disk) stuff +! CHARACTER(LEN=3) :: FlashDrive ="F:\" + CHARACTER(LEN=3) :: FlashDrive ="" + CHARACTER(LEN=128) :: ScratchFile="" + INTEGER, PARAMETER :: blmin=1, bldia=2, blpls=3 + REAL(sp), ALLOCATABLE, DIMENSION(:,:,:) :: DataItem + INTEGER :: iunit_dacess=10 + LOGICAL :: lswap2disk = .FALSE. !Set internally if blocks do not fit in memory + INTEGER, PARAMETER :: LOWER=3,DIAG=2,UPPER=1 + +C----------------------------------------------- +! +! SP: forces single precision for blocks (smaller size) +! ICTRL_PREC2D: controls initialization and application of 2d block preconditioner +! = 0, no preconditioner applied +! = 1, apply preconditioner +! = 2, initial call of funct3d to set up residue vector, store saved vectors, +! and (for .not.lasym case), call LAMBLKS routine +! = 3, radial jog vector is being computed to calculate hessian elements +! L_BACKSLV: if true, test that Hessian is inverted correctly by back-solving +! LHESS_EXACT : if true, edge value of ctor (in bcovar) is computed as a constant to make +! Hessian symmetric. Also, sets ivacskip=0 in call to vacuum in computation of +! Hessian. However, the ivacskip=0 option is (very) slow and found not to be necessary +! in practice. Set this true primarily for debugging purposes (check Ap ~ -p in MatVec +! routine, for example, in GMRes module) +! + + CONTAINS + + SUBROUTINE swap_forces(gc, temp, mblk, nblocks) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: mblk, nblocks + REAL(dp), DIMENSION(nblocks,mblk), INTENT(in) :: gc + REAL(dp), DIMENSION(mblk,nblocks), INTENT(out) :: temp +C----------------------------------------------- +! +! reorders forces (gc) array prior to applying +! block-tridiagonal pre-conditioner. on exit, temp is the reordered array +! flip sign so eigenvalue is negative (corresponding to damping) +! + temp = -TRANSPOSE(gc) + + END SUBROUTINE swap_forces + + SUBROUTINE reswap_forces(temp, gc, mblk, nblocks) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: mblk, nblocks + REAL(dp), DIMENSION(nblocks,mblk), INTENT(inout) :: gc + REAL(dp), DIMENSION(mblk,nblocks), INTENT(in) :: temp +C----------------------------------------------- +! +! Following application of block pre-conditioner, restores original +! order of forces (gc) array previously ordered by call to "swap_forces" +! + gc = TRANSPOSE(temp) + + END SUBROUTINE reswap_forces + + SUBROUTINE block_precond(gc) +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntyptot) :: gc +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mblk, m, n, js, ntype, istat + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: temp + REAL(dp) :: t1, error +C----------------------------------------------- +! +! Applies 2D block-preconditioner to forces vector (gc) +! + IF (ntyptot .le. 0) STOP 'ntyptot must be > 0' + + IF (l_backslv) gc_save = gc + + mblk = ntyptot*mnsize + ALLOCATE (temp(mblk,ns), stat=ntype) + IF (ntype .ne. 0) STOP 'Allocation error1 in block_precond' + +! Reorder gc(JS,MN) -> temp(MN,JS) + CALL swap_forces(gc, temp, mblk, ns) + +! Apply preconditioner to temp, using LU factors stored in block_... matrices + IF (lswap2disk) THEN + CALL blk3d_slv_swp(temp, ipiv_blk, mblk, ns) + ELSE + CALL blk3d_slv(block_diag, block_mins, block_plus, temp, + 1 ipiv_blk, mblk, ns) + END IF + +! Restores original ordering (after preconditioner applied): temp(MN,JS) -> gc(JS,MN) + CALL reswap_forces(temp, gc, mblk, ns) + + IF (l_backslv) THEN + l_backslv = .false. + + WRITE (6, *) ' Writing block Hessian check to unit 34' + WRITE (34, *) + WRITE (34, *) ' BLK3D FACTORIZATION CHECK: Ax = b ?' + + DO n = 0, ntor + WRITE (34, *) ' N = ', n + DO m = 0, mpol1 + WRITE (34, *) ' M = ', m + DO ntype = 1, ntyptot + WRITE (34, *) ' TYPE = ', ntype + WRITE (34, *) + 1 ' js Ax b Ax - b' // + 2 ' RelErr' + js = 1 + t1 = SUM(block_dsave(n,m,ntype,:,:,:,js)*gc(js,:,:,:) + 1 + block_psave(n,m,ntype,:,:,:,js)*gc(js+1,:,:,:)) + + error = t1 + gc_save(js,n,m,ntype) + IF (t1 .eq. zero) t1 = EPSILON(t1) + WRITE (34, 100) js, t1, -gc_save(js,n,m,ntype), + 2 error, error/t1 + + DO js = 2, ns-1 + t1 = SUM( + 1 block_msave(n,m,ntype,:,:,:,js)*gc(js-1,:,:,:) + 2 + block_dsave(n,m,ntype,:,:,:,js)*gc(js,:,:,:) + 3 + block_psave(n,m,ntype,:,:,:,js)*gc(js+1,:,:,:)) + error = t1 + gc_save(js,n,m,ntype) + IF (t1 .eq. zero) t1 = EPSILON(t1) + WRITE (34, 100) js, t1, -gc_save(js,n,m,ntype), + 2 error, error/t1 + END DO + + js = ns + t1 = SUM(block_msave(n,m,ntype,:,:,:,js)*gc(js-1,:,:,:) + 1 + block_dsave(n,m,ntype,:,:,:,js)*gc(js,:,:,:)) + error = t1 + gc_save(js,n,m,ntype) + IF (t1 .eq. zero) t1 = EPSILON(t1) + WRITE (34, 100) js, t1, -gc_save(js,n,m,ntype), + 2 error, error/t1 + END DO + END DO + END DO + + IF (.not.l_backslv) DEALLOCATE(block_dsave, block_msave, + 1 block_psave, gc_save, stat=istat) + + 100 FORMAT(i6,1p,4e14.4) + END IF + + + DEALLOCATE (temp, stat=istat) + + END SUBROUTINE block_precond + + SUBROUTINE block_precond_par(gc) + USE blocktridiagonalsolver, ONLY: SetMatrixRHS + USE blocktridiagonalsolver, ONLY: BackwardSolve + USE blocktridiagonalsolver, ONLY: GetSolutionVector + USE parallel_include_module +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntyptot) :: gc +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mblk, istat, globrow + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: tmp + REAL(dp) :: ton, toff + REAL(dp), DIMENSION (:,:), ALLOCATABLE :: solvec +C----------------------------------------------- + IF (.NOT.lactive) THEN + RETURN + END IF +! +! Applies 2D block-preconditioner to forces vector (gc) +! + IF (ntyptot .LE. 0) THEN + STOP 'ntyptot must be > 0' + END IF + + mblk = ntyptot*mnsize + +! Apply preconditioner to temp, using LU factors stored in block_... matrices + + ALLOCATE (tmp(mblk,ns), stat=istat) + CALL tolastns(gc, tmp) + tmp(:,tlglob:trglob) = -tmp(:,tlglob:trglob) + + DO globrow=tlglob, trglob + CALL SetMatrixRHS(globrow,tmp(:,globrow)) + END DO + DEALLOCATE (tmp, stat=istat) + + CALL second0(ton) + CALL BackwardSolve + CALL second0(toff) + bcyclic_backwardsolve_time=bcyclic_backwardsolve_time+(toff-ton) + + ALLOCATE (solvec(mblk,ns), stat=istat) + IF (istat .NE. 0) THEN + STOP 'Allocation error in block_precond before gather' + END IF + + DO globrow=tlglob, trglob + CALL GetSolutionVector (globrow,solvec(:,globrow)) + END DO + + CALL tolastntype(solvec, gc) + + CALL Gather4XArray(gc) + + DEALLOCATE (solvec) + + END SUBROUTINE block_precond_par + + SUBROUTINE compute_blocks_par (xc, xcdot, gc) + USE blocktridiagonalsolver, ONLY: ForwardSolve + USE parallel_include_module + USE vmec_main, ONLY: iter2 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp),DIMENSION(0:ntor,0:mpol1,ns,3*ntmax) :: xc, gc, xcdot +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp + INTEGER :: m, n, i, ntype, istat, mblk, ibsize, iunit + REAL(dp) :: time_on, time_off, bsize, tprec2don, tprec2doff + REAL(dp) :: ton, toff + CHARACTER(LEN=100):: label + LOGICAL, PARAMETER :: lscreen = .false. + INTEGER :: j, k, l +C----------------------------------------------- +! +! COMPUTES THE JACOBIAN BLOCKS block_mins, block_diag, block_plus +! USING EITHER A SLOW - BUT RELIABLE - "JOG" TECHNIQUE, OR +! USING PARTIAL ANALYTIC FORMULAE. +! +! THE SUBROUTINE lam_blks IS CALLED FROM BCOVAR TO COMPUTE +! THE ANALYTIC BLOCK ELEMENTS +! + CALL second0(tprec2don) + + IF (l_backslv .and. sp.ne.dp) THEN + STOP 'Should set sp = dp!' + END IF + + ntyptot = SIZE(gc,4) + IF (ntyptot .NE. 3*ntmax) THEN + STOP ' NTYPTOT != 3*ntmax' + END IF + mblk = ntyptot*mnsize + + bsize = REAL(mblk*mblk, dp)*3*KIND(block_diag) + IF (bsize .gt. HUGE(mblk)) THEN + WRITE (6, *) ' bsize: ', bsize, ' exceeds HUGE(int): ', + & HUGE(mblk) +! WRITE (6, *) ' Blocks will be written to disk.' +! lswap2disk = .TRUE. + ELSE + lswap2disk = .FALSE. + END IF + + bsize = bsize*ns + IF (bsize .lt. 1.E6_dp) THEN + ibsize = bsize/1.E1_dp + label = " Kb" + ELSE IF (bsize .lt. 1.E9_dp) THEN + ibsize = bsize/1.E4_dp + label = " Mb" + ELSE + ibsize = bsize/1.E7_dp + label = " Gb" + END IF + + DO i = 1,2 + IF (i .eq. 1) THEN + iunit = 6 + END IF + IF (i .eq. 2) THEN + iunit = nthreed + END IF + IF (grank.EQ.0) THEN + WRITE (iunit, '(/,2x,a,i5,a,/,2x,a,i5,a)') + & 'Initializing 2D block preconditioner at ', iter2, + & ' iterations', + & 'Estimated time to compute Hessian = ', + & 3*ntyptot*mnsize,' VMEC time steps' + WRITE (iunit, '(2x,a,i4,a,f12.2,a)') 'Block dim: ', mblk, + & '^2 Preconditioner size: ', REAL(ibsize)/100, + & TRIM(label) + END IF + END DO +! +! COMPUTE AND STORE BLOCKS (MN X MN) FOR PRECONDITIONER +! + CALL second0(time_on) + + ALLOCATE (gc_save(0:ntor,0:mpol1,ns,ntyptot), stat=istat) + IF (istat .NE. 0) THEN + STOP 'Allocation error: gc_save in compute_blocks' + END IF + + IF (ALLOCATED(block_diag)) THEN + DEALLOCATE (block_diag, block_plus, block_mins, stat=istat) + IF (istat .ne. 0) THEN + STOP 'Deallocation error in compute blocks' + END IF + END IF + +! +! GENERAL (SLOWER BY 2/3 THAN SYMMETRIC VERSION) METHOD: ASSUMES NO SYMMETRIES OF R, Z COEFFICIENTS +! + CALL sweep3_blocks_par (xc, xcdot, gc) + IF (lactive) THEN + CALL compute_col_scaling_par + END IF + + ictrl_prec2d = 1 !Signals funct3d (residue) to use block preconditioner + + CALL second0(time_off) + IF (grank .EQ. 0) THEN + WRITE (6,1000) time_off - time_on + WRITE (nthreed,1000) time_off - time_on + END IF + +! +! FACTORIZE HESSIAN +! + CALL second0(time_on) + IF (ALLOCATED(ipiv_blk)) THEN + DEALLOCATE(ipiv_blk, stat=ntype) + END IF + ALLOCATE (ipiv_blk(mblk,ns), stat=ntype) + IF (ntype .ne. 0) THEN + STOP 'Allocation error2 in block_precond' + END IF + + CALL second0(ton) + IF (lactive) THEN + CALL ForwardSolve + END IF + + CALL second0(time_off) + toff = time_off + bcyclic_forwardsolve_time = bcyclic_forwardsolve_time + & + (toff - ton) + + IF (grank.EQ.0) THEN + WRITE(6,1001) time_off - time_on + WRITE(nthreed,1001) time_off - time_on + END IF + + IF (.NOT.l_backslv) THEN + DEALLOCATE (gc_save) + END IF + + CALL second0(tprec2doff) + + timer(tprec2d) = timer(tprec2d) + (tprec2doff - tprec2don) + compute_blocks_time = compute_blocks_time + & + (tprec2doff - tprec2don) + +1000 FORMAT(1x,' Time to compute blocks: ',f10.2,' s') +1001 FORMAT(1x,' Time to factor blocks: ',f10.2,' s') + + END SUBROUTINE compute_blocks_par + + SUBROUTINE sweep3_blocks_par(xc, xcdot, gc) + USE vmec_main, ONLY: ncurr, r01, z01, lthreed, chips, delt0r + USE blocktridiagonalsolver, ONLY: Initialize, SetBlockRowCol + USE blocktridiagonalsolver, ONLY: WriteBlocks + USE parallel_vmec_module, ONLY: MPI_STAT +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntyptot) :: xc, xcdot, gc +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: js, js1, istat, mesh, lamtype, rztype, icol + INTEGER :: nsmin, nsmax + INTEGER :: lastrank, left, right + REAL(dp) :: eps, hj, hj_scale + REAL(dp), ALLOCATABLE, DIMENSION(:) :: diag_val + REAL(dp) :: ton, toff +C----------------------------------------------- +! +! COMPUTE FORCE "RESPONSE" TO PERTURBATION AT EVERY 3rd RADIAL POINT +! FOR EACH MESH STARTING AT js=1,2,3, RESPECTIVELY +! + CALL second0(ton) + ALLOCATE(diag_val(ns), stat=istat) + diag_val=zero + IF (grank.EQ.0) THEN + WRITE (6, *) + & " Using non-symmetric sweep to compute Hessian elements" + END IF + + eps = SQRT(EPSILON(eps)) + eps = eps/10 + rztype = 2*ntmax + lamtype = rztype + 1 + + n_2d = 0 + m_2d = 0 + + ALLOCATE(DataItem(0:ntor,0:mpol1,1:3*ntmax), stat=istat) + IF (istat .ne. 0) THEN + STOP 'Allocation error in sweep3_blocks' + END IF + +! +! CALL FUNCT3D FIRST TIME TO STORE INITIAL UN-PRECONDITIONED FORCES +! THIS WILL CALL LAMBLKS (SO FAR, ONLY IMPLEMENTED FOR lasym = false) +! + ictrl_prec2d = 2 !Signals funct3d that preconditioner is being initialized + CALL funct3d_par(lscreen, istat) + IF (istat .NE. 0) THEN + PRINT *,' ier_flag = ', istat, + 1 ' in SWEEP3_BLOCKS_PAR call to funct3d_par' + STOP + ENDIF + + nsmin = t1lglob + nsmax = t1rglob + xcdot(:,:,nsmin:nsmax,:) = 0 +! PRINT *,'rank: ', rank,' vrank: ', vrank,' nsmin: ',nsmin, +! 1 ' nsmax: ', nsmax + + IF (FIRSTPASS) THEN + edge_mesh = .FALSE. + FIRSTPASS = .FALSE. + mblk_size = (ntor + 1)*(mpol1 + 1)*3*ntmax + IF (mblk_size .NE. ntmaxblocksize) THEN + STOP 'wrong mblk_size in precon2d!' + END IF + CALL Initialize(.FALSE.,ns,mblk_size) + myend = nsmax +!Align starting pt in (nsmin,nsmax) + DO mesh = 1, 3 + icol = MOD(jstart(mesh) - nsmin, 3) + IF (icol .LT. 0) THEN + icol = icol + 3 + END IF + mystart(mesh) = nsmin + icol + IF (MOD(jstart(mesh) - ns, 3) .EQ. 0) THEN ! .AND. nsmax.EQ.ns) + edge_mesh(mesh) = .TRUE. + END IF + END DO + END IF + +! STORE chips in xc +#if defined(CHI_FORCE) + IF (ncurr .EQ. 1) THEN + xc(0,0,nsmin:nsmax,lamtype) = chips(nsmin:nsmax) + END IF +#endif + left = rank - 1 + IF (rank .EQ. 0) THEN + left = MPI_PROC_NULL + END IF + right = rank + 1 + IF (rank .EQ. nranks - 1) THEN + right = MPI_PROC_NULL + END IF + + CALL PadSides(xc) + CALL PadSides(gc) + CALL PadSides(xcdot) + + CALL restart_iter(delt0r) + gc_save(:,:,nsmin:nsmax,:) = gc(:,:,nsmin:nsmax,:) + ictrl_prec2d = 3 !Signals funct3d that preconditioner is being computed + + CALL MPI_COMM_SIZE(NS_COMM,lastrank,MPI_ERR) + lastrank = lastrank - 1 +! +! FIRST DO R00 JOG TO LOAD DIAG_VAL ARRAY (DO NOT RELY ON IT BEING THE FIRST JOG) +! + m_2d=0 + n_2d=0 +#ifdef _HBANGLE + ntype_2d = zsc + ntmax +#else + ntype_2d = rcc +#endif +! APPLY JOG + hj = eps * MAX(ABS(r01(ns)), ABS(z01(ns))) + IF (nranks .GT. 1) THEN + CALL MPI_BCAST(hj,1,MPI_REAL8,lastrank,NS_COMM,MPI_ERR) + CALL MPI_BCAST(edge_mesh,3,MPI_LOGICAL,lastrank,NS_COMM, & + & MPI_ERR) + END IF + DO js = mystart(1), myend(1), 3 + xcdot(n_2d,m_2d,js,ntype_2d) = hj + END DO + + istat = 0 + CALL funct3d_par (lscreen, istat) + + LACTIVE0: IF (lactive) THEN + IF (nranks .GT. 1) THEN + CALL Gather4XArray(gc) + END IF + IF (istat .NE. 0) THEN + STOP 'Error computing Hessian jog!' + END IF +! CLEAR JOG AND STORE BLOCKS FOR THIS JOG + xcdot(:,:,nsmin:nsmax,:) = 0 + DO js = mystart(1), myend(1), 3 + DataItem = (gc(:,:,js,:) - gc_save(:,:,js,:))/hj + diag_val(js) = DataItem(0,0,ntype_2d) + END DO + + IF (nranks .GT. 1) THEN + icol = 0 + IF (trglob_arr(1) .LT. 4) THEN + icol = 1 + END IF + CALL MPI_BCAST(diag_val(4), 1, MPI_REAL8, icol, NS_COMM, + & MPI_ERR) + icol = nranks - 1 + IF (tlglob_arr(nranks) .GT. ns - 3) THEN + icol = nranks-2 + END IF + CALL MPI_BCAST(diag_val(ns - 3), 1, MPI_REAL8, icol, + & NS_COMM, MPI_ERR) + END IF + IF (diag_val(1) .EQ. zero) THEN + diag_val(1) = diag_val(4) + END IF + IF (diag_val(ns) .EQ. zero) THEN + diag_val(ns) = diag_val(ns - 3) + END IF + + IF (nranks .GT. 1) THEN + CALL MPI_Sendrecv(diag_val(trglob), 1, MPI_REAL8, right, 1, + & diag_val(t1lglob), 1, MPI_REAL8, left, 1, + & NS_COMM, MPI_STAT, MPI_ERR) + END IF + DO js = mystart(2), myend(2), 3 + diag_val(js) = diag_val(js - 1) + END DO + + hj_scale = MAX(ABS(r01(ns)), ABS(z01(ns))) + + IF (nranks .GT. 1) THEN + CALL MPI_Sendrecv(diag_val(trglob), 1, MPI_REAL8, right, 1, + & diag_val(t1lglob), 1, MPI_REAL8, left, 1, + & NS_COMM, MPI_STAT, MPI_ERR) + CALL MPI_BCAST(hj_scale, 1, MPI_REAL8, lastrank, NS_COMM, + & MPI_ERR) + END IF + + DO js = mystart(3), myend(3), 3 + diag_val(js) = diag_val(js - 1) + END DO + + IF (ANY(diag_val(tlglob:trglob) .EQ. zero)) THEN + PRINT *, 'For rank: ', rank, ' some diag_val == 0' + STOP + END IF + END IF LACTIVE0 +! +! PERFORM "JOGS" FOR EACH VARIABLE AT EVERY 3rd RADIAL POINT ACROSS MESH +! FOR ntyp = (Rcc, Rss, Rsc, Rcs, Zsc, Zcs, Zcc, Zss) +! AND EVERY n2d (toroidal mode index) and EVERY m2d (poloidal mode index) + + icol=0 + + NTYPE2D: DO ntype_2d = 1, ntyptot + hj = eps + IF (ntype_2d .LT. lamtype) THEN + hj = hj*hj_scale + END IF + + M2D: DO m_2d = 0, mpol1 + + N2D: DO n_2d = 0, ntor + + icol = icol + 1 + + MESH_3PT: DO mesh = 1,3 + +! APPLY JOG TO ACTIVE PROCESSORS + IF (lactive) THEN + DO js = mystart(mesh), myend(mesh), 3 + xcdot(n_2d,m_2d,js,ntype_2d) = hj + END DO + IF (m_2d.GT.0 .AND. mystart(mesh).EQ.1) THEN + xcdot(n_2d,m_2d,1,ntype_2d) = 0 + END IF + END IF + + l_edge = edge_mesh(mesh) + CALL funct3d_par (lscreen, istat) + IF (istat .NE. 0) STOP 'Error computing Hessian jog!' + +! +! COMPUTE PRECONDITIONER (HESSIAN) ELEMENTS. LINEARIZED EQUATIONS +! OF FORM (FIXED mn FOR SIMPLICITY): +! +! F(j-1) = a(j-1)x(j-2) + d(j-1)x(j-1) + b(j-1)x(j) +! F(j) = a(j)x(j-1) + d(j) x(j) + b(j) x(j+1) +! F(j+1) = a(j+1)x(j) + d(j+1)x(j+1) + b(j+1)x(j+2) +! +! HESSIAN IS H(k,j) == dF(k)/dx(j); aj == block_mins; dj == block_diag; bj = block_plus +! +! THUS, A PERTURBATION (in xc) AT POSITION js PRODUCES THE FOLLOWING RESULTS: +! +! d(js) = dF(js )/hj(js) +! b(js-1) = dF(js-1)/hj(js) +! a(js+1) = dF(js+1)/hj(js) +! +! + LACTIVE1: IF (lactive) THEN + SKIP3_MESH: DO js = mystart(mesh), myend(mesh), 3 + +! CLEAR JOG AND STORE BLOCKS FOR THIS JOG + xcdot(n_2d,m_2d,js,ntype_2d) = 0 + + !block_mins(js+1) + js1 = js+1 + IF (tlglob.LE.js1 .AND. js1.LE.trglob) THEN + DataItem = + & (gc(:,:,js1,:)-gc_save(:,:,js1,:))/hj + CALL SetBlockRowCol(js1,icol,DataItem,LOWER) + END IF + + !block_diag(js) + IF (tlglob.LE.js .AND. js.LE.trglob) THEN + DataItem = (gc(:,:,js,:) + & - gc_save(:,:,js,:))/hj + + IF (rank .EQ. lastrank .AND. + & js .EQ. ns .AND. + & .NOT.lfreeb .AND. + & ANY(DataItem(:,:, + & 1:rztype) .NE. zero)) THEN + STOP 'DIAGONAL BLOCK AT EDGE != 0' + END IF + +!Levenberg-like offset - do NOT apply here if applied in colscaling routine + IF (ntype_2d .GE. lamtype) THEN + DataItem(n_2d,m_2d,ntype_2d) = + & 1.0001_dp*DataItem(n_2d,m_2d,ntype_2d) + END IF + + IF (DataItem(n_2d,m_2d, + & ntype_2d) .EQ. zero) THEN + DataItem(n_2d,m_2d,ntype_2d) = + & diag_val(js) + END IF + + CALL SetBlockRowCol(js,icol,DataItem,DIAG) + END IF + + !block_plus(js-1) + js1 = js - 1 + IF (tlglob .LE. js1 .AND. js1 .LE. trglob) THEN + DataItem = (gc(:,:,js1,:) - + & gc_save(:,:,js1,:))/hj + CALL SetBlockRowCol(js1,icol,DataItem,UPPER) + END IF + END DO SKIP3_MESH + END IF LACTIVE1 + + END DO MESH_3PT + END DO N2D + END DO M2D + END DO NTYPE2D + + l_edge = .FALSE. + + DEALLOCATE(DataItem, diag_val) + CALL second0(toff) + fill_blocks_time=fill_blocks_time + (toff - ton) + + END SUBROUTINE sweep3_blocks_par + + SUBROUTINE compute_blocks(xc, xcdot, gc) + USE vmec_main, ONLY: iter2 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp),DIMENSION(ns,0:ntor,0:mpol1,3*ntmax) :: xc, gc, xcdot +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp), PARAMETER :: p5 = 0.5_dp + INTEGER :: m, n, i, ntype, istat, + 1 mblk, ibsize, iunit + REAL(dp) :: time_on, time_off, bsize, tprec2don, tprec2doff + CHARACTER(LEN=100):: label + LOGICAL, PARAMETER :: lscreen = .false. +C----------------------------------------------- +! +! COMPUTES THE JACOBIAN BLOCKS block_mins, block_diag, block_plus +! USING EITHER A SLOW - BUT RELIABLE - "JOG" TECHNIQUE, OR +! USING PARTIAL ANALYTIC FORMULAE. +! +! THE SUBROUTINE lam_blks IS CALLED FROM BCOVAR TO COMPUTE +! THE ANALYTIC BLOCK ELEMENTS +! + CALL second0(tprec2don) + IF (l_backslv .and. sp.ne.dp) THEN + STOP 'Should set sp = dp!' + END IF + + ntyptot = SIZE(gc,4) + mblk = ntyptot*mnsize + + bsize = REAL(mblk*mblk, dp)*3*ns*KIND(block_diag) +! IF (bsize .gt. HUGE(mblk)) THEN +! WRITE (6, *) ' bsize: ', INT(bsize,SELECTED_INT_KIND(12)), +! 1 ' exceeds HUGE(int): ', HUGE(mblk) +! WRITE (6, *) ' Blocks will be written to disk.' +! lswap2disk = .TRUE. +! ELSE + lswap2disk = .FALSE. +! END IF + + IF (bsize .lt. 1.E6_dp) THEN + ibsize = bsize/1.E1_dp + label = " Kb" + ELSE IF (bsize .lt. 1.E9_dp) THEN + ibsize = bsize/1.E4_dp + label = " Mb" + ELSE + ibsize = bsize/1.E7_dp + label = " Gb" + END IF + + WRITE (6, 1000) iter2, 3*ntyptot*mnsize, mblk, REAL(ibsize)/100, + & TRIM(label) + WRITE (nthreed, 1000) iter2, 3*ntyptot*mnsize, mblk, + & REAL(ibsize)/100, TRIM(label) +! +! COMPUTE AND STORE BLOCKS (MN X MN) FOR PRECONDITIONER +! + CALL second0(time_on) + + ALLOCATE (gc_save(ns,0:ntor,0:mpol1,ntyptot), stat=istat) + IF (istat .ne. 0) THEN + STOP 'Allocation error: gc_save in compute_blocks' + END IF + + IF (ALLOCATED(block_diag)) THEN + DEALLOCATE (block_diag, block_plus, block_mins, stat=istat) + IF (istat .ne. 0) THEN + STOP 'Deallocation error in compute blocks' + END IF + ELSE IF (ALLOCATED(block_diag_sw)) THEN + DEALLOCATE (block_diag_sw, block_plus_sw, block_mins_sw, + & stat=istat) + IF (istat .ne. 0) THEN + STOP 'Deallocation error in compute blocks' + END IF + END IF + + ALLOCATE (block_diag(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & block_plus(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & block_mins(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & stat=istat) + + lswap2disk = (istat .NE. 0) + +!FOR DEBUGGING, SET THIS TO TRUE +! lswap2disk = .TRUE. + + IF (lswap2disk) THEN + WRITE (6,'(a,i4,a)') ' Allocation error(1) = ', istat, + & ': Not enough memory in compute_blocks' + WRITE (6,*) ' Writing blocks to disk file' + ALLOCATE (block_diag_sw(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot), + & block_plus_sw(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot), + & block_mins_sw(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot), + & stat=istat) + + IF (istat .ne. 0) THEN + WRITE (6,'(a,i4)') ' Allocation error(2) = ', istat + STOP + END IF + +! Open DIRECT ACCESS file for writing blocks to disk +! FIRST, we need to compute one row (in m,n,ntype-space) at a +! time (not the full block). So we use a record size = mblk +! with a block size = mblk**2. We will then close this and re-open +! it with a record size = mblk**2 do deal with full blocks + ScratchFile = "PRCND2A.bin" + IF (FlashDrive .ne. "") THEN + ScratchFile = FlashDrive // ScratchFile + END IF + CALL OpenDAFile(mblk, mblk**2, 3, ScratchFile, iunit_dacess, 0) + ScratchFile = "PRCND2B.bin" + IF (FlashDrive .ne. "") THEN + ScratchFile = FlashDrive // ScratchFile + END IF + block_plus_sw = 0 + block_mins_sw = 0 + block_diag_sw = 0 + ELSE + block_plus = 0 + block_mins = 0 + block_diag = 0 + END IF + +! +! GENERAL (SLOWER BY 2/3 THAN SYMMETRIC VERSION) METHOD: ASSUMES NO SYMMETRIES OF R, Z COEFFICIENTS +! + CALL sweep3_blocks (xc, xcdot, gc) + CALL compute_col_scaling + ictrl_prec2d = 1 !Signals funct3d (residue) to use block preconditioner + +!SPH021014: compute eigenvalues (for small enough matrices) +! CALL get_eigenvalues(mblk, ns, block_mins, block_diag, block_plus) + + CALL second0(time_off) + WRITE (6,1001) time_off - time_on + WRITE (6,1001) nthreed + +! SAVE ORIGINAL (UNFACTORED) BLOCKS FOR CHECKING INVERSE +! IN L_BACKSLV=TRUE LOOP IN BLOCK_PRECOND + IF (l_backslv) THEN + ALLOCATE (block_dsave(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & block_msave(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & block_psave(0:ntor,0:mpol1,ntyptot, + & 0:ntor,0:mpol1,ntyptot,ns), + & stat = istat) + IF (istat .ne. 0) THEN + WRITE (6,*) 'Allocation error in l_backslv block: stat = ', + & istat + l_backslv = .false. + ELSE + block_dsave = block_diag; block_msave = block_mins + block_psave = block_plus + END IF + END IF + +! +! FACTORIZE HESSIAN +! + CALL second0(time_on) + IF (ALLOCATED(ipiv_blk)) THEN + DEALLOCATE(ipiv_blk, stat=ntype) + END IF + ALLOCATE (ipiv_blk(mblk,ns), stat=ntype) + IF (ntype .ne. 0) STOP 'Allocation error2 in block_precond' + + IF (lswap2disk) THEN + CALL blk3d_factor_swp(ipiv_blk, mblk, ns) + ELSE + CALL blk3d_factor(block_diag, block_mins, block_plus, + 1 ipiv_blk, mblk, ns) + END IF + + CALL second0(time_off) + WRITE (6,1002) time_off - time_on + WRITE (nthreed,1002) time_off - time_on + + IF (.NOT.l_backslv) DEALLOCATE (gc_save) + + CALL second0(tprec2doff) + + timer(tprec2d) = timer(tprec2d) + (tprec2doff - tprec2don) + +1000 FORMAT(/,2x,'Initializing 2D block preconditioner at ',i5, + & ' iterations', + & /,2x,'Estimated time to compute Hessian = ',i5, + & ' VMEC time steps', + & /,2x,'Block dim: ',i4,'^2 Preconditioner size: ',f12.2,a) +1001 FORMAT(1x,' Time to compute blocks: ',f10.2,' s') +1002 FORMAT(1x,' Time to factor blocks: ',f10.2,' s') + + END SUBROUTINE compute_blocks + + SUBROUTINE sweep3_blocks(xc, xcdot, gc ) + USE vmec_main, ONLY: ncurr, r01, z01, lthreed, chips, delt0r +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntyptot) :: xc, xcdot, + & gc +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + REAL(dp) :: eps, hj, diag_val(ns) + INTEGER :: js, istat, mesh, lamtype, rztype + +! INTEGER :: m1, n1, nt1 + +!----------------------------------------------- +! +! COMPUTE EVERY 3rd RADIAL POINT FOR EACH MESH STARTING AT js=1,2,3, RESPECTIVELY +! + WRITE (6, *) + & " Using non-symmetric sweep to compute Hessian elements" + + eps = SQRT(EPSILON(eps)) + eps = eps/10 + rztype = 2*ntmax + lamtype = rztype+1 + + xcdot = 0 + n_2d = 0; m_2d = 0 + + ALLOCATE(DataItem(0:ntor,0:mpol1,3*ntmax), stat=istat) + IF (istat .NE. 0) THEN + STOP 'Allocation error in sweep3_blocks' + END IF + + diag_val = 1 + +! +! CALL FUNCT3D FIRST TIME TO STORE INITIAL UN-PRECONDITIONED FORCES +! + ictrl_prec2d = 2 !Signals funct3d to initialize preconditioner (save state) + CALL funct3d (lscreen, istat) + IF (istat .ne. 0) THEN + PRINT *,' ier_flag = ', istat, + & ' in SWEEP3_BLOCKS call to funct3d' + STOP + ENDIF + +#if defined(CHI_FORCE) +! STORE chips in xc + IF (ncurr .EQ. 1) THEN + xc(1:ns,0,0,lamtype) = chips(1:ns) + END IF +#endif + CALL restart_iter(delt0r) + ictrl_prec2d = 3 !Signals funct3d to compute preconditioner elements + gc_save = gc + +! +! PERFORM R(m=0,n=0) JOG TO LOAD DIAG_VAL ARRAY +! (DO NOT RELY ON IT BEING THE FIRST JOG IN LOOP) +! + m_2d = 0 + n_2d = 0 +#ifdef _HBANGLE + ntype_2d = zsc + ntmax +#else + ntype_2d = rcc +#endif + edge_mesh = .FALSE. + DO mesh = 1, 3 + DO js = jstart(mesh), ns, 3 + IF (js .EQ. ns) THEN + edge_mesh(mesh) = .TRUE. + END IF + END DO + END DO + +! APPLY JOG + hj = eps * MAX(ABS(r01(ns)), ABS(z01(ns))) + DO js = jstart(1), ns, 3 + xcdot(js,n_2d,m_2d,ntype_2d) = hj + END DO + + CALL funct3d (lscreen, istat) + IF (istat .NE. 0) THEN + STOP 'Error computing Hessian jog!' + END IF +! CLEAR JOG AND STORE BLOCKS FOR THIS JOG + xcdot = 0 + DO js = jstart(1), ns, 3 + DataItem = (gc(js,:,:,:) - gc_save(js,:,:,:))/hj + diag_val(js) = DataItem(0,0,ntype_2d) + END DO + IF (diag_val(1) .EQ. zero) THEN + diag_val(1) = diag_val(4) + END IF + IF (diag_val(ns).EQ. zero) THEN + diag_val(ns) = diag_val(ns-3) + END IF + + DO js = jstart(2), ns, 3 + diag_val(js) = diag_val(js-1) + END DO + DO js = jstart(3), ns, 3 + diag_val(js) = diag_val(js-1) + END DO + + IF (ANY(diag_val .EQ. zero)) THEN + STOP 'diag_val == 0' + END IF +! +! PERFORM "JOGS" FOR EACH VARIABLE AT EVERY 3rd RADIAL POINT ACROSS MESH +! FOR ntype_2d = (Rcc, Rss, Rsc, Rcs, Zsc, Zcs, Zcc, Zss) +! AND EVERY n_2d (toroidal mode index) and EVERY m_2d (poloidal mode index) +! + NTYPE2D: DO ntype_2d = 1, ntyptot + IF (ntype_2d .LT. lamtype) THEN + hj = eps*MAX(ABS(r01(ns)), ABS(z01(ns))) + ELSE + hj = eps + END IF + + M2D: DO m_2d = 0, mpol1 + N2D: DO n_2d = 0, ntor +#ifdef _HBANGLE + IF (ntype_2d.GT.ntmax .AND. ntype_2d.LE.2*ntmax) THEN + IF (m_2d .NE. 0) THEN + block_diag(n_2d,m_2d,ntype_2d, + & n_2d,m_2d,ntype_2d,:) = diag_val + CYCLE + END IF + END IF +#endif + MESH_3PT: DO mesh = 1,3 +! APPLY JOG + DO js = jstart(mesh), ns, 3 + xcdot(js,n_2d,m_2d,ntype_2d) = hj + END DO + + l_edge = edge_mesh(mesh) + CALL funct3d(lscreen, istat) + IF (istat .NE. 0) THEN + STOP 'Error computing Hessian jog!' + END IF + +! IF (.NOT.lfreeb) !NOT NEEDED, gcr, gcz -> 0 in RESIDUE for lfreeb=F +! 1 gc(ns,:,:,1:rztype) = gc_save(ns,:,:,1:rztype) +! +! COMPUTE PRECONDITIONER (HESSIAN) ELEMENTS. LINEARIZED EQUATIONS +! OF FORM (FIXED mn FOR SIMPLICITY): +! +! F(j-1) = a(j-1)x(j-2) + d(j-1)x(j-1) + b(j-1)x(j) +! F(j) = a(j)x(j-1) + d(j) x(j) + b(j) x(j+1) +! F(j+1) = a(j+1)x(j) + d(j+1)x(j+1) + b(j+1)x(j+2) +! +! HESSIAN IS H(k,j) == dF(k)/dx(j); aj == block_mins; dj == block_diag; bj = block_plus +! +! THUS, A PERTURBATION (in xc) AT POSITION js PRODUCES THE FOLLOWING RESULTS: +! +! d(js) = dF(js )/hj(js) +! b(js-1) = dF(js-1)/hj(js) +! a(js+1) = dF(js+1)/hj(js) +! +! CLEAR JOG + xcdot = 0 +! +! STORE BLOCK ELEMENTS FOR THIS JOG. +! FOR OFF-DIAGONAL ELEMENTS, NEED TO ADJUST js INDICES +/- 1 +! + SKIP3_MESH: DO js = jstart(mesh), ns, 3 + + !block_mins(js+1) == a + IF (js .lt. ns) THEN + DataItem = (gc(js+1,:,:,:) - + & gc_save(js+1,:,:,:))/hj + END IF + + IF (lswap2disk) THEN + CALL WriteDAItem_SEQ(DataItem) + ELSE IF (js .lt. ns) THEN + block_mins(:,:,:,n_2d,m_2d,ntype_2d,js+1) = + & DataItem + END IF + + !block_diag(js) == d + DataItem = (gc(js,:,:,:) - gc_save(js,:,:,:))/hj + + IF (DataItem(n_2d,m_2d,ntype_2d) .EQ. zero) THEN + DataItem(n_2d,m_2d,ntype_2d) = diag_val(js) + END IF + +!Levenberg-like offset - do NOT apply here if applied in colscaling routine + IF (ntype_2d .GE. lamtype) THEN + DataItem(n_2d,m_2d,ntype_2d) = + & 1.0001_dp*DataItem(n_2d,m_2d,ntype_2d) + END IF + + IF (lswap2disk) THEN + CALL WriteDAItem_SEQ(DataItem) + ELSE + block_diag(:,:,:,n_2d,m_2d,ntype_2d,js) = + & DataItem + END IF + + !block_plus(js-1) == b + IF (js .GT. 1) THEN + DataItem = (gc(js-1,:,:,:) - + & gc_save(js-1,:,:,:))/hj + END IF +!no coupling of ALL fixed bdy forces to ANY r,z bdy values + IF (lswap2disk) THEN + CALL WriteDAItem_SEQ(DataItem) + ELSE IF (js .GT. 1) THEN + block_plus(:,:,:,n_2d,m_2d,ntype_2d,js-1) = + & DataItem + END IF + + END DO SKIP3_MESH + END DO MESH_3PT + END DO N2D + END DO M2D + END DO NTYPE2D + + l_edge = .FALSE. + DEALLOCATE(DataItem) + + END SUBROUTINE sweep3_blocks + + SUBROUTINE blk3d_factor(a, bm1, bp1, ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(sp), PARAMETER :: zero = 0, one = 1 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(out) :: ipiv(mblk,nblocks) + REAL(sp), TARGET, DIMENSION(mblk,mblk,nblocks), INTENT(inout) :: + & a, bm1, bp1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- +! INTEGER :: ibuph, incnow, irecl, incbu, iunit=102, ndisk + INTEGER :: k, k1, ier + INTEGER, POINTER :: ipivot(:) + REAL(sp), POINTER :: amat(:,:), bmat(:,:), cmat(:,:) + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: temp +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c----------------------------------------------------------------------- +c +c this subroutine solves for the Q factors of a block-tridiagonal system of equations. +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block dimension (elements in a block=mblk X mblk) +c nblocks : number of blocks +c a : diagonal blocks +c bp1, bm1 : lower, upper blocks (see equation below) +c +c OUTPUT +c ipiv : pivot elements for kth block +c a : a-1 LU factor blocks +c bm1 : q = a-1 * bm1 matrix +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c solutions are indexed in m-n fourier-space, legendre-space. the tri-diagonal +c equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c +c GENERAL SOLUTION SCHEME APPLIED TO EACH BLOCK ROW (INDEX L) +c +c 1. Start from row N and solve for x(N) in terms of x(N-1): +c +c x(N) = -q(N)*x(N-1) + r(N) +c +c q(N) = a(N)[-1] * bm1; r(N) = a(N)[-1] * s(N) +c +c where a(N)[-1] is the inverse of a(N) +c +c 2. Substitute for lth row to get recursion equation fo q(l) and r(l): +c +c x(l) = -q(l)*x(l-1) + r(l), in general, where: +c +c q(l) = (a(l) - bp1(l)*q(l+1))[-1] * bm1(l) +c +c qblk(l) == (a(l) - bp1(l) * q(l+1))[-1] on return +c +c r(l) = (a(l) - bp1(l)*q(l+1))[-1] * (s(l) - bp1(l)*r(l+1)) +c +c 3. At row l = 1, bm1(1) = 0 and get an equation for x(1) corresponding to q(1) = 0: +c +c x(1) = r(1) +c +c 4. Finally, can back-solve for x(N) in terms of x(N-1) from eqn.(1) above +c +c +c NUMERICAL IMPLEMENTATION (USING LAPACK ROUTINES) +c +c 1. CALL dgetrf: Perform LU factorization of diagonal block (A) - faster than sgefa +c 2. CALL dgetrs: With multiple (mblk) right-hand sides, to do block inversion +c operation, A X = B (stores result in B; here B is a matrix) +c + +c main loop. load and process (backwards) block-rows nblocks to 1. + + + BLOCKS: DO k = nblocks, 1, -1 +! +! Compute (and save) qblk(k) = ablk(k)[-1] * bml +! + amat => a(:,:,k); ipivot => ipiv(:,k) + CALL dgetrf(mblk, mblk, amat, mblk, ipivot, ier) + IF (ier .ne. 0) GOTO 200 + IF (k .eq. 1) EXIT + + bmat => bm1(:,:,k) + CALL dgetrs('n', mblk, mblk, amat, mblk, ipivot, bmat, mblk, + & ier) + + IF (ier .ne. 0) GOTO 305 + +! +! Update effective diagonal "a" matrix. Use dgemm: faster AND doesn't overflow normal stack +! + k1 = k-1 + amat => bp1(:,:,k1) + cmat => a(:,:,k1) +! cmat = cmat - MATMUL(amat, bmat) + CALL dgemm('N','N',mblk,mblk,mblk,-one,amat,mblk, + 1 bmat, mblk, one, cmat, mblk) + + END DO BLOCKS + +! +! COMPUTE TRANSPOSES HERE, SINCE REPEATEDLY CALLING MATMUL OPERATION +! X*At IS FASTER THAN A*X DUE TO UNIT STRIDE +! + ALLOCATE (temp(mblk,mblk), stat=k) + IF (k .ne. 0) STOP 'Allocation error in blk3d_factor!' + + DO k = 1, nblocks + IF (k .ne. nblocks) THEN + temp = TRANSPOSE(bp1(:,:,k)) + bp1(:,:,k) = temp + END IF + IF (k .ne. 1) THEN + temp = TRANSPOSE(bm1(:,:,k)) + bm1(:,:,k) = temp + END IF + END DO + + DEALLOCATE (temp) + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 200 CONTINUE +! < 0: if info = -i, the i-th argument had an illegal value +! > 0: if info = i, u(i,i) is exactly zero. the factorization + WRITE (6,1000) k + IF (ier < 0) THEN + WRITE (6,1001) ier + END IF + IF (ier > 0) THEN + WRITE (6,1002) ier + END IF + STOP + 305 CONTINUE + WRITE (6, 1003) ier + STOP + + + 400 CONTINUE + +1000 FORMAT(2x,'Error factoring matrix in blk3d: block = ',i4) +1001 FORMAT(i4,'th argument has illegal value') +1002 FORMAT(i4,'th diagonal factor exactly zero') +1003 FORMAT(2/' BLK3D: error detected: ier =',i4,2/) + + END SUBROUTINE blk3d_factor + + + SUBROUTINE blk3d_factor_swp(ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(sp), PARAMETER :: zero = 0, one = 1 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(out) :: ipiv(mblk,nblocks) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: + & amat, bmat, cmat, temp + INTEGER :: k, k1, ier + INTEGER, POINTER :: ipivot(:) +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c modified (June, 2007, ORNL), added lswap2disk logic +c----------------------------------------------------------------------- +c +c this subroutine solves for the Q factors of a block-tridiagonal system of equations. +c see blk3d_factor for more details +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block dimension (elements in a block=mblk X mblk) +c nblocks : number of blocks +c +c OUTPUT +c ipiv : pivot elements for kth block +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c solutions are indexed in m-n fourier-space, legendre-space. the tri-diagonal +c equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c +c +c NUMERICAL IMPLEMENTATION (USING LAPACK ROUTINES) +c +c 1. CALL dgetrf: Perform LU factorization of diagonal block (A) - faster than sgefa +c 2. CALL dgetrs: With multiple (mblk) right-hand sides, to do block inversion +c operation, A X = B (stores result in B; here B is a matrix) +c + +c main loop. load and process (backwards) block-rows nblocks to 1. + +! CHANGE Direct Access Record length to block size (from individual rows) + CALL ChangeDAFileParams(mblk**2, mblk**2, 3, ScratchFile, nblocks) + + ALLOCATE(amat(mblk,mblk), bmat(mblk,mblk), cmat(mblk,mblk), + & temp(mblk,mblk), stat=ier) + IF (ier .ne. 0) STOP 'Allocation error in blk3d_factor_swp!' + + CALL ReadDAItem2(temp, nblocks, bldia) + + BLOCKS: DO k = nblocks, 1, -1 +! +! Compute (and save) qblk(k) = ablk(k)[-1] * bml +! + amat = temp + ipivot => ipiv(:,k) + CALL dgetrf(mblk, mblk, amat, mblk, ipivot, ier) + IF (ier .ne. 0) GOTO 200 +!CONFIRM READ-WRITE ALLOWED...OK FOR DA Files! + CALL WriteDAItem_RA(amat, k, bldia, 1) + + IF (k .eq. 1) EXIT + + CALL ReadDAItem2(bmat, k, blmin) + CALL dgetrs('n', mblk, mblk, amat, mblk, ipivot, bmat, mblk, + & ier) + IF (ier .ne. 0) GOTO 305 +! +! COMPUTE TRANSPOSES HERE (and for cmat below), SINCE REPEATEDLY CALLING MATMUL OPERATION +! X*At IS FASTER THAN A*X DUE TO UNIT STRIDE +! + temp = TRANSPOSE(bmat) + CALL WriteDAItem_RA(temp, k, blmin, 1) + +! +! Update effective diagonal "a" matrix. Use dgemm: faster AND doesn't overflow normal stack +! + k1 = k-1 + CALL ReadDAItem2(amat, k1, blpls) + CALL ReadDAItem2(temp, k1, bldia) +! temp = temp - MATMUL(amat, bmat) + CALL dgemm('N','N',mblk,mblk,mblk,-one,amat,mblk, bmat, mblk, + & one, temp, mblk) + cmat = TRANSPOSE(amat) + CALL WriteDAItem_RA(cmat, k1, blpls, 1) + + END DO BLOCKS + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 200 CONTINUE +! < 0: if info = -i, the i-th argument had an illegal value +! > 0: if info = i, u(i,i) is exactly zero. the factorization + WRITE (6,1000) k + IF (ier < 0) THEN + WRITE (6,1001) ier + END IF + IF (ier > 0) THEN + WRITE (6,1002) ier + END IF + STOP + 305 CONTINUE + WRITE (6, 1003) ier + STOP + + 400 CONTINUE + + DEALLOCATE(amat, bmat, cmat, temp, stat=ier) + + CALL CloseDAFile + +1000 FORMAT(2x,'Error factoring matrix in blk3d: block = ',i4) +1001 FORMAT(i4,'th argument has illegal value') +1002 FORMAT(i4,'th diagonal factor exactly zero') +1003 FORMAT(2/' BLK3D: error detected: ier =',i4,2/) + + END SUBROUTINE blk3d_factor_swp + + SUBROUTINE blk3d_factor_swp2(ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(sp), PARAMETER :: zero = 0, one = 1 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(out) :: ipiv(mblk,nblocks) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: + 1 amat, bmat, cmat, temp + INTEGER :: k, k1, ier + INTEGER, POINTER :: ipivot(:) +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c modified (June, 2007, ORNL), added lswap2disk logic +c modified (July, 2007, ORNL/VA State):Helen Yang - forward sweep for speed +c----------------------------------------------------------------------- +c +c this subroutine solves for the Q factors of a block-tridiagonal system of equations. +c see blk3d_factor for more details +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block dimension (elements in a block=mblk X mblk) +c nblocks : number of blocks +c +c OUTPUT +c ipiv : pivot elements for kth block +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c solutions are indexed in m-n fourier-space, legendre-space. the tri-diagonal +c equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c +c +c NUMERICAL IMPLEMENTATION (USING LAPACK ROUTINES) +c +c 1. CALL dgetrf: Perform LU factorization of diagonal block (A) - faster than sgefa +c 2. CALL dgetrs: With multiple (mblk) right-hand sides, to do block inversion +c operation, A X = B (stores result in B; here B is a matrix) +c + +c main loop. load and process (backwards) block-rows nblocks to 1. + +! CHANGE Direct Access Record length to block size (from individual rows) + CALL ChangeDAFileParams(mblk**2, mblk**2, 3, ScratchFile, nblocks) + + ALLOCATE(amat(mblk,mblk), bmat(mblk,mblk), cmat(mblk,mblk), + & temp(mblk,mblk), stat=ier) + IF (ier .ne. 0) STOP 'Allocation error in blk3d_factor_swp!' + + CALL ReadDAItem2(temp, 1, bldia) + + BLOCKS: DO k = 1,nblocks +! +! Compute (and save) qblk(k) = ablk(k)[-1] * bml +! + amat = temp + ipivot => ipiv(:,k) + CALL dgetrf (mblk, mblk, amat, mblk, ipivot, ier) + IF (ier .ne. 0) GOTO 200 +!CONFIRM READ-WRITE ALLOWED...OK FOR DA Files! + CALL WriteDAItem_RA(amat, k, bldia, 1) + + IF (k .eq. nblocks) EXIT + + CALL ReadDAItem2(bmat, k, blpls) + CALL dgetrs('n', mblk, mblk, amat, mblk, ipivot, bmat, mblk, + & ier) + IF (ier .ne. 0) GOTO 305 +! +! COMPUTE TRANSPOSES HERE (and for cmat below), SINCE REPEATEDLY CALLING MATMUL OPERATION +! X*At IS FASTER THAN A*X DUE TO UNIT STRIDE +! + temp = TRANSPOSE(bmat) + CALL WriteDAItem_RA(temp, k, blpls, 1) + +! +! Update effective diagonal "a" matrix. Use dgemm: faster AND doesn't overflow normal stack +! + k1 = k + 1 + CALL ReadDAItem2(amat, k1, blmin) + CALL ReadDAItem2(temp, k1, bldia) +! temp = temp - MATMUL(amat, bmat) + CALL dgemm('N','N',mblk,mblk,mblk,-one,amat,mblk, bmat, mblk, + & one, temp, mblk) + cmat = TRANSPOSE(amat) + CALL WriteDAItem_RA(cmat, k1, blmin, 1) + + END DO BLOCKS + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 200 CONTINUE +! < 0: if info = -i, the i-th argument had an illegal value +! > 0: if info = i, u(i,i) is exactly zero. the factorization + WRITE (6,1000) k + IF (ier < 0) THEN + WRITE (6,1001) ier + END IF + IF (ier > 0) THEN + WRITE (6,1002) ier + END IF + STOP + 305 CONTINUE + WRITE (6,1003) ier + STOP + + 400 CONTINUE + + DEALLOCATE(amat, bmat, cmat, temp, stat=ier) + + CALL CloseDAFile + +1000 FORMAT(2x,'Error factoring matrix in blk3d: block = ',i4) +1001 FORMAT(i4,'th argument has illegal value') +1002 FORMAT(i4,'th diagonal factor exactly zero') +1003 FORMAT(2/' BLK3D: error detected: ier =',i4,2/) + + END SUBROUTINE blk3d_factor_swp2 + + + SUBROUTINE blk3d_slv(ablk, qblk, bp1, source, + 1 ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- + USE stel_kinds +! USE safe_open_mod +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(in) :: ipiv(mblk,nblocks) + REAL(sp), TARGET, DIMENSION(mblk,mblk,nblocks), INTENT(in) :: + 1 ablk, qblk, bp1 + REAL(dp), DIMENSION(mblk,nblocks), INTENT(inout) + 1 :: source +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, POINTER :: ipivot(:) + INTEGER :: k, ier + REAL(sp), POINTER :: amat(:,:) !, x1(:), y1(:) + REAL(sp) :: source_sp(mblk) +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c----------------------------------------------------------------------- +c +c this subroutine solves a block-tridiagonal system of equations, using +c the ABLK, QBLK factors from blk3d_factor, +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block size +c nblocks : number of blocks +c bp1 : upper blocks (see equation below) +c ipiv : pivot elements for kth block +c ablk : a-1 blocks +c qblk : q = a-1 * bm1 +c source : input right side +c +c OUTPUT +c source : Solution x of A x = source +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c solutions are indexed in m-n fourier-space, legendre-space. the tri-diagonal +c equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c +c GENERAL SOLUTION SCHEME APPLIED TO EACH BLOCK ROW (INDEX L) +c +c 1. Start from row N and solve for x(N) in terms of x(N-1): +c +c x(N) = -q(N)*x(N-1) + r(N) +c +c q(N) = a(N)[-1] * bm1; r(N) = a(N)[-1] * s(N) +c +c where a(N)[-1] is the inverse of a(N) +c +c 2. Substitute for lth row to get recursion equation fo q(l) and r(l): +c +c x(l) = -q(l)*x(l-1) + r(l), in general, where: +c +c q(l) = (a(l) - bp1(l)*q(l+1))[-1] * bm1(l) +c +c qblk(l) == (a(l) - bp1(l) * q(l+1))[-1] on return +c +c r(l) = (a(l) - bp1(l)*q(l+1))[-1] * (s(l) - bp1(l)*r(l+1)) +c +c 3. At row l = 1, bm1(1) = 0 and get an equation for x(1) corresponding to q(1) = 0: +c +c x(1) = r(1) +c +c 4. Finally, can back-solve for x(N) in terms of x(N-1) from eqn.(1) above +c +c +c NUMERICAL IMPLEMENTATION (USING LAPACK ROUTINES) +c +c 1. CALL dgetrs: With single right hand side (source) to solve A x = b (b a vector) +c Faster than dgesl +! ndisk = mblk*mblk + +c main loop. load and process (backwards) block-rows nblocks to 1. +! note: about equal time is spent in calling dgetrs and in performing +! the two loop sums: on ibm-pc, 2 s (trs) vs 3 s (sums); on linux (logjam), +! 2.4 s (trs) vs 3 s (sums). + +! +! Back-solve for modified sources first +! + BLOCKS: DO k = nblocks, 1, -1 + + source_sp = source(:,k) + ipivot => ipiv(:,k); amat => ablk(:,:,k) + CALL dgetrs('n', mblk, 1, amat, mblk, + 1 ipivot, source_sp, mblk, ier) + source(:,k) = source_sp + + IF (ier .ne. 0) GOTO 305 + IF (k .eq. 1) EXIT + +! +! NOTE: IN BLK3D_FACTOR, BP1 AND BM1 WERE TRANSPOSED (AND STORED) +! TO MAKE FIRST INDEX FASTEST VARYING IN THE FOLLOWING MATMUL OPS +! + amat => bp1(:,:,k-1) + source(:,k-1) = source(:,k-1) - MATMUL(source(:,k),amat) !USE THIS FORM IF TRANSPOSED bp1 +! source(:,k-1) = source(:,k-1) - MATMUL(amat,source(:,k)) !UNTRANSPOSED FORM +! x1 => source(:,k); y1 => source(:,k-1) +! CALL dgemv('T',mblk,mblk,-one,amat,mblk,x1,1, +! 1 one,y1,1) + + END DO BLOCKS +! +! forward (back-substitution) solution sweep for block-rows k = 2 to nblocks +! now, source contains the solution vector +! + DO k = 2, nblocks + amat => qblk(:,:,k) + source(:,k) = source(:,k) - MATMUL(source(:,k-1),amat) !USE THIS FORM IF TRANSPOSED qblk +! source(:,k) = source(:,k) - MATMUL(amat,source(:,k-1)) !UNTRANSPOSED FORM +! x1 => source(:,k-1); y1 => source(:,k) +! CALL dgemv('T',mblk,mblk,-one,amat,mblk,x1,1, +! 1 one,y1,1) + + END DO + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 305 CONTINUE + WRITE (6, '(2/a,i4,2/)') ' BLK3D: error detected: ier =', + 1 ier + STOP + + 400 CONTINUE + + END SUBROUTINE blk3d_slv + + + SUBROUTINE blk3d_slv_swp(source, ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- + USE stel_kinds +! USE safe_open_mod +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(in) :: ipiv(mblk,nblocks) + REAL(dp), DIMENSION(mblk,nblocks), INTENT(inout) + 1 :: source +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: amat + INTEGER, POINTER :: ipivot(:) + INTEGER :: k, k1, ier + REAL(sp) :: source_sp(mblk) +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c modified (June, 2007, ORNL), added lswap2disk logic +c----------------------------------------------------------------------- +c +c this subroutine solves a block-tridiagonal system of equations, using +c the ABLK, QBLK factors from blk3d_factor, +c See blk3d_slv for details +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block size +c nblocks : number of blocks +c ipiv : pivot elements for kth block +c source : input right side +c +c OUTPUT +c source : Solution x of A x = source +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c the tri-diagonal equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c + +c main loop. load and process (backwards) block-rows nblocks to 1. +! note: about equal time is spent in calling dgetrs and in performing +! the two loop sums: on ibm-pc, 2 s (trs) vs 3 s (sums); on linux (logjam), +! 2.4 s (trs) vs 3 s (sums). + + CALL OpenDAFile(mblk**2, mblk**2, 3, ScratchFile, iunit_dacess, 1) + + ALLOCATE (amat(mblk,mblk), stat=ier) + IF (ier .ne. 0) STOP 'Allocation error in blk3d_slv_swp!' +! +! Back-solve for modified sources first +! + BLOCKS: DO k = nblocks, 1, -1 + + source_sp = source(:,k) + ipivot => ipiv(:,k) + CALL ReadDAItem2(amat, k, bldia) + CALL dgetrs('n', mblk, 1, amat, mblk, + 1 ipivot, source_sp, mblk, ier) + source(:,k) = source_sp + + IF (ier .ne. 0) GOTO 305 + IF (k .eq. 1) EXIT + +! +! NOTE: IN BLK3D_FACTOR, BP1 AND BM1 WERE TRANSPOSED (AND STORED) +! TO MAKE FIRST INDEX FASTEST VARYING IN THE FOLLOWING MATMUL OPS +! + k1 = k-1 + CALL ReadDAItem2(amat, k1, blpls) + source(:,k1) = source(:,k1) - MATMUL(source(:,k),amat) !USE THIS FORM IF TRANSPOSED bp1 +! source(:,k1) = source(:,k1) - MATMUL(amat,source(:,k)) !UNTRANSPOSED FORM +! x1 => source(:,k); y1 => source(:,k-1) +! CALL dgemv('T',mblk,mblk,-one,amat,mblk,x1,1, +! 1 one,y1,1) + + END DO BLOCKS +! +! forward (back-substitution) solution sweep for block-rows k = 2 to nblocks +! now, source contains the solution vector +! + DO k = 2, nblocks + + CALL ReadDAItem2(amat, k, blmin) + source(:,k) = source(:,k) - MATMUL(source(:,k-1),amat) !USE THIS FORM IF TRANSPOSED qblk +! source(:,k) = source(:,k) - MATMUL(amat,source(:,k-1)) !UNTRANSPOSED FORM +! x1 => source(:,k-1); y1 => source(:,k) +! CALL dgemv('T',mblk,mblk,-one,amat,mblk,x1,1, +! 1 one,y1,1) + + END DO + + WRITE(100,'(1p,6e14.4)') source(:,ns/2) + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 305 CONTINUE + WRITE (6, '(2/a,i4,2/)') ' BLK3D: error detected: ier =', + 1 ier + STOP + + 400 CONTINUE + + CALL CloseDAFile + + END SUBROUTINE blk3d_slv_swp + + + SUBROUTINE blk3d_slv_swp2(source, ipiv, mblk, nblocks) +C----------------------------------------------- +C M o d u l e s +C----------------------------------------------- + USE stel_kinds +! USE safe_open_mod +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: nblocks, mblk + INTEGER, TARGET, INTENT(in) :: ipiv(mblk,nblocks) + REAL(dp), DIMENSION(mblk,nblocks), INTENT(inout) + 1 :: source +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(sp), ALLOCATABLE, DIMENSION(:,:) :: amat + INTEGER, POINTER :: ipivot(:) + INTEGER :: k, k1, ier + REAL(sp) :: source_sp(mblk) +C----------------------------------------------- +c modified (June, 2003, ORNL): S. P. Hirshman +c modified (June, 2007, ORNL), added lswap2disk logic +c modified (July, 2007, ORNL/VA State):Helen Yang - forward sweep for speed +c----------------------------------------------------------------------- +c +c this subroutine solves a block-tridiagonal system of equations, using +c the ABLK, QBLK factors from blk3d_factor, +c See blk3d_slv for details +c +c----------------------------------------------------------------------- +c INPUT +c mblk : block size +c nblocks : number of blocks +c bp1 : upper blocks (see equation below) +c ipiv : pivot elements for kth block +c ablk : a-1 blocks +c qblk : q = a-1 * bm1 +c source : input right side +c +c OUTPUT +c source : Solution x of A x = source +c +c LOCAL VARIABLES +c iunit : unit number for block-tridiagonal solution disk file. +c +c the tri-diagonal equation is: +c +c bm1 * f(l-1) + a * f(l) + bp1 * f(l+1) = source(l) +c + +c main loop. load and process (backwards) block-rows nblocks to 1. +! note: about equal time is spent in calling dgetrs and in performing +! the two loop sums: on ibm-pc, 2 s (trs) vs 3 s (sums); on linux (logjam), +! 2.4 s (trs) vs 3 s (sums). + + CALL OpenDAFile(mblk**2, mblk**2, 3, ScratchFile, iunit_dacess, 1) + + ALLOCATE (amat(mblk,mblk), stat=ier) + IF (ier .ne. 0) STOP 'Allocation error in blk3d_slv_swp!' +! +! Back-solve for modified sources first +! + BLOCKS: DO k = 1, nblocks + + source_sp = source(:,k) + ipivot => ipiv(:,k) + CALL ReadDAItem2(amat, k, bldia) + CALL dgetrs('n', mblk, 1, amat, mblk, + 1 ipivot, source_sp, mblk, ier) + source(:,k) = source_sp + + IF (ier .ne. 0) GOTO 305 + IF (k .eq. nblocks) EXIT + +! +! NOTE: IN BLK3D_FACTOR, BP1 AND BM1 WERE TRANSPOSED (AND STORED) +! TO MAKE FIRST INDEX FASTEST VARYING IN THE FOLLOWING MATMUL OPS +! + k1 = k+1 + CALL ReadDAItem2(amat, k1, blmin) + source(:,k1) = source(:,k1) - MATMUL(source(:,k),amat) !USE THIS FORM IF TRANSPOSED bp1 + + END DO BLOCKS +! +! backward solution sweep for block-rows k = nblocks-1 to 1 +! now, source contains the solution vector +! + DO k = nblocks-1, 1, -1 + + CALL ReadDAItem2(amat, k, blpls) + k1 = k+1 + source(:,k) = source(:,k) - MATMUL(source(:,k1),amat) !USE THIS FORM IF TRANSPOSED qblk + + END DO + + WRITE(100,'(1p,6e14.4)') source(:,ns/2) + + GOTO 400 + +c error returns. ------------------------------------------------------ + + 305 CONTINUE + WRITE (6, '(2/a,i4,2/)') ' BLK3D: error detected: ier =', + 1 ier + STOP + + 400 CONTINUE + + CALL CloseDAFile + + END SUBROUTINE blk3d_slv_swp2 + + + SUBROUTINE compute_col_scaling_par + USE xstuff, ONLY: pcol_scale + USE blocktridiagonalsolver, ONLY: GetColSum, ParallelScaling + USE parallel_vmec_module, ONLY: ToLastNtype, CopyLastNtype +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: nsmin, nsmax + REAL(dp), ALLOCATABLE :: tmp(:) + REAL(dp), ALLOCATABLE :: colsum(:,:) + REAL(dp), PARAMETER :: levmarq_param = 1.E-6_dp +C----------------------------------------------- + +!FOR NO COL SCALING - col-scaling not working well yet (8.1.17) + pcol_scale = 1 + RETURN + +!BE SURE TO TURN OFF LEV_MARQ SCALING IN SUBROUTINE sweep3_blocks_par + nsmin = tlglob; nsmax = trglob + + ALLOCATE (colsum(mblk_size,nsmin:nsmax)) + CALL GetColSum(colsum) + CALL VectorCopyPar (colsum, pcol_scale) + CALL ParallelScaling(levmarq_param,colsum) + + DEALLOCATE(colsum) + +!Convert to internal PARVMEC format + ALLOCATE (tmp(ntmaxblocksize*ns)) + CALL tolastntype(pcol_scale,tmp) + CALL copylastntype(tmp,pcol_scale) + DEALLOCATE(tmp) + + END SUBROUTINE compute_col_scaling_par + + SUBROUTINE compute_col_scaling + USE xstuff, ONLY: col_scale +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + +!FOR NO COL SCALING + col_scale = 1 + + END SUBROUTINE compute_col_scaling + + SUBROUTINE VectorCopyPar (colsum, colscale) + USE blocktridiagonalsolver, ONLY: rank +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), INTENT(IN) :: colsum(mblk_size,tlglob:trglob) + REAL(dp), INTENT(OUT) :: colscale(mblk_size,ns) + +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, M1 + INTEGER :: MPI_STAT(MPI_STATUS_SIZE) +!----------------------------------------------- + + DO js = tlglob, trglob + colscale(:,js) = colsum(:,js) + END DO + + M1 = mblk_size + +! Get left boundary elements (tlglob-1) + IF (rank.LT.nranks-1) THEN + CALL MPI_Send(colsum(:,trglob),M1,MPI_REAL8, + 1 rank+1,1,NS_COMM,MPI_ERR) + END IF + IF (rank.GT.0) THEN + CALL MPI_Recv(colscale(:,tlglob-1),M1, + 1 MPI_REAL8,rank-1,1,NS_COMM,MPI_STAT,MPI_ERR) + END IF + +! Get right boundary elements (trglob+1) + IF (rank.GT.0) THEN + CALL MPI_Send(colsum(:,tlglob),M1,MPI_REAL8, + 1 rank-1,1,NS_COMM,MPI_ERR) + END IF + IF (rank.LT.nranks-1) THEN + CALL MPI_Recv(colscale(:,trglob+1),M1,MPI_REAL8, + 1 rank+1,1,NS_COMM,MPI_STAT,MPI_ERR) + END IF + + END SUBROUTINE VectorCopyPar + + + SUBROUTINE free_mem_precon + INTEGER :: istat + + istat=0 + IF (ALLOCATED(block_diag)) + 1 DEALLOCATE (block_diag, block_plus, block_mins, stat=istat) + IF (istat .ne. 0) STOP 'Deallocation error-1 in free_mem_precon' + + istat=0 + IF (ALLOCATED(block_diag_sw)) + 1 DEALLOCATE (block_diag_sw, block_plus_sw, block_mins_sw, + 2 stat=istat) + IF (istat .ne. 0) STOP 'Deallocation error-2 in free_mem_precon' + + istat=0 + IF (ALLOCATED(ipiv_blk)) DEALLOCATE (ipiv_blk, stat=istat) + IF (istat .ne. 0) STOP 'Deallocation error-3 in free_mem_precon' + + END SUBROUTINE free_mem_precon + + END MODULE precon2d diff --git a/Sources/Initialization_Cleanup/CMakeLists.txt b/Sources/Initialization_Cleanup/CMakeLists.txt new file mode 100644 index 0000000..91fdc34 --- /dev/null +++ b/Sources/Initialization_Cleanup/CMakeLists.txt @@ -0,0 +1,24 @@ +target_sources(vmec + PRIVATE + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ +) diff --git a/Sources/Initialization_Cleanup/allocate_funct3d.f b/Sources/Initialization_Cleanup/allocate_funct3d.f new file mode 100644 index 0000000..e747fb4 --- /dev/null +++ b/Sources/Initialization_Cleanup/allocate_funct3d.f @@ -0,0 +1,290 @@ + SUBROUTINE allocate_funct3d_par + USE vmec_main + USE realspace + USE vforces + USE vacmod + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ns, ntheta3 + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1, ndim, ndim2 +C----------------------------------------------- + CALL free_mem_funct3d_par + + ALLOCATE(parmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pazmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pbrmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pbzmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pcrmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pczmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pblmn(nznt,ns,0:1),stat=istat1) + ALLOCATE(pclmn(nznt,ns,0:1),stat=istat1) + + ALLOCATE(pru(nznt,ns,0:1),stat=istat1) + ALLOCATE(pr1(nznt,ns,0:1),stat=istat1) + + ALLOCATE(prv(nznt,ns,0:1),stat=istat1) + ALLOCATE(pzv(nznt,ns,0:1),stat=istat1) + + ALLOCATE(prcon(nznt,ns,0:1),stat=istat1) + ALLOCATE(pzcon(nznt,ns,0:1),stat=istat1) + +!SPH CHANGE (add =0) + ALLOCATE(pgcon(nznt,ns),stat=istat1) + ALLOCATE(prcon0(nznt,ns),stat=istat1); prcon0 = 0 + ALLOCATE(pzcon0(nznt,ns),stat=istat1); pzcon0 = 0 + + ALLOCATE(pzu(nznt,ns,0:1),stat=istat1) + ALLOCATE(pz1(nznt,ns,0:1),stat=istat1) + + ALLOCATE(pguu(nznt,ns),stat=istat1) + ALLOCATE(pguv(nznt,ns),stat=istat1) + ALLOCATE(pgvv(nznt,ns),stat=istat1) + + ALLOCATE(pru0(nznt,ns),stat=istat1) + ALLOCATE(pzu0(nznt,ns),stat=istat1) + + ALLOCATE (pextra1(nznt,ns,0:1), stat=istat1) + IF (istat1.ne.0) STOP 'allocation error #3 in allocate_funct3d' + pextra1=0 + + IF (lasym) THEN + ALLOCATE (pextra2(nznt,ns,0:1), + & pextra3(nznt,ns,0:1), + & pextra4(nznt,ns,0:1),stat=istat1) + ELSE + ALLOCATE (pextra2(nznt,ns,1), + & pextra3(nznt,ns,1), + & pextra4(nznt,ns,1),stat=istat1) + END IF + IF (istat1.ne.0) STOP 'allocation error #3 in allocate_funct3dpar' + pextra2=0; pextra3=0; pextra4=0 + +! +! Pointer alias assignments +! NOTE: In FORCES, X_e(nrzt+1) overlaps X_o(1), which should never be used... +! + parmn_e => parmn(:,:,0) + parmn_o => parmn(:,:,1) + parmn = zero + + pazmn_e => pazmn(:,:,0) + pazmn_o => pazmn(:,:,1) + pazmn = zero + + pbrmn_e => pbrmn(:,:,0) + pbrmn_o => pbrmn(:,:,1) + pbrmn = zero + + pbzmn_e => pbzmn(:,:,0) + pbzmn_o => pbzmn(:,:,1) + pbzmn = zero + + pcrmn_e => pcrmn(:,:,0) + pcrmn_o => pcrmn(:,:,1) + pcrmn = zero + + pczmn_e => pczmn(:,:,0) + pczmn_o => pczmn(:,:,1) + pczmn = zero + + pblmn_e => pblmn(:,:,0) + pblmn_o => pblmn(:,:,1) + pblmn = zero + + pclmn_e => pclmn(:,:,0) + pclmn_o => pclmn(:,:,1) + pclmn = zero + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ndim = 1+nrzt + ndim2 = 2*ndim + CALL free_mem_funct3d + + ALLOCATE (armn(ndim2), azmn(ndim2), brmn(ndim2), bzmn(ndim2), + & crmn(ndim2), czmn(ndim2), blmn(ndim2), clmn(ndim2), + & r1(nrzt,0:1), ru(nrzt,0:1), rv(nrzt,0:1), + & z1(nrzt,0:1), zu(nrzt,0:1), zv(nrzt,0:1), + & rcon(nrzt,0:1), zcon(nrzt,0:1), ru0(ndim), zu0(ndim), + & rcon0(ndim), zcon0(ndim), guu(ndim), guv(ndim), + & gvv(ndim), gcon(ndim), sigma_an(nrzt), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #1 in allocate_funct3d' + END IF + armn=0; azmn=0; brmn=0; bzmn=0; crmn=0; czmn=0; blmn=0; clmn=0 + r1=0; ru=0; rv=0; z1=0; zu=0; zv=0; rcon=0; zcon=0 + ru0=0; zu0=0; rcon0=0; zcon=0; guu=0; guv=0; gvv=0 + sigma_an=1 + +#ifdef _ANIMEC + ALLOCATE(pperp(nrzt), ppar(nrzt), onembc(nrzt), + & pp1(nrzt), pp2(nrzt), pp3(nrzt), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #1A in allocate_funct3d' + END IF + pperp=0; ppar=0; onembc=0; pp1=0; pp2=0; pp3=0 +#endif + + IF (lfreeb) THEN + ALLOCATE (brv(nznt), bphiv(nznt), bzv(nznt), bsqvac(nznt), + & bsqvac0(nznt), bsubu_sur(nuv3), bsubv_sur(nuv3), !MRC 10-15-15 + & bsupu_sur(nuv3), bsupv_sur(nuv3), + & stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #2 in allocate_funct3d' + END IF + brv=0; bphiv=0; bzv=0; bsqvac=0 + END IF + + ALLOCATE (extra1(ndim,0:1), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #3 in allocate_funct3d' + END IF + extra1=0 + + IF (lasym) THEN + ALLOCATE (extra2(ndim,0:1), extra3(ndim,0:1), + 1 extra4(ndim,0:1),stat=istat1) + ELSE + ALLOCATE (extra2(ndim,1), extra3(ndim,1), extra4(ndim,1), + 1 stat=istat1) + END IF + IF (istat1.ne.0) THEN + STOP 'allocation error #3 in allocate_funct3d' + END IF + extra2=0; extra3=0; extra4=0 + +! +! Pointer alias assignments +! NOTE: In FORCES, X_e(nrzt+1) overlaps X_o(1), which should never be used... +! + armn_e => armn(:ndim) + armn_o => armn(ndim:) + armn(:ndim2) = zero + brmn_e => brmn(:ndim) + brmn_o => brmn(ndim:) + brmn(:ndim2) = zero + azmn_e => azmn(:ndim) + azmn_o => azmn(ndim:) + azmn(:ndim2) = zero + bzmn_e => bzmn(:ndim) + bzmn_o => bzmn(ndim:) + bzmn(:ndim2) = zero + crmn_e => crmn(:ndim) + crmn_o => crmn(ndim:) + crmn(:ndim2) = zero + czmn_e => czmn(:ndim) + czmn_o => czmn(ndim:) + czmn(:ndim2) = zero + blmn_e => blmn(:ndim) + blmn_o => blmn(ndim:) + blmn(:ndim2) = zero + clmn_e => clmn(:ndim) + clmn_o => clmn(ndim:) + clmn(:ndim2) = zero + rcon0(:ndim) = zero + zcon0(:ndim) = zero + + END SUBROUTINE allocate_funct3d_par + + SUBROUTINE allocate_funct3d + USE vmec_main + USE realspace + USE vforces + USE vacmod + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1, ndim, ndim2 +C----------------------------------------------- + ndim = 1 + nrzt + ndim2 = 2*ndim + + CALL free_mem_funct3d + + ALLOCATE (armn(ndim2), azmn(ndim2), brmn(ndim2), bzmn(ndim2), + & crmn(ndim2), czmn(ndim2), blmn(ndim2), clmn(ndim2), + & r1(nrzt,0:1), ru(nrzt,0:1), rv(nrzt,0:1), + & z1(nrzt,0:1), zu(nrzt,0:1), zv(nrzt,0:1), + & rcon(nrzt,0:1), zcon(nrzt,0:1), ru0(ndim), zu0(ndim), + & rcon0(ndim), zcon0(ndim), guu(ndim), guv(ndim), + & gvv(ndim), gcon(ndim), sigma_an(nrzt), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #1 in allocate_funct3d' + END IF + armn=0; azmn=0; brmn=0; bzmn=0; crmn=0; czmn=0; blmn=0; clmn=0 + r1=0; ru=0; rv=0; z1=0; zu=0; zv=0; rcon=0; zcon=0 + ru0=0; zu0=0; rcon0=0; zcon=0; guu=0; guv=0; gvv=0 + sigma_an=1 + +#ifdef _ANIMEC + ALLOCATE(pperp(nrzt), ppar(nrzt), onembc(nrzt), + & pp1(nrzt), pp2(nrzt), pp3(nrzt), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #1A in allocate_funct3d' + END IF + pperp=0; ppar=0; onembc=0; pp1=0; pp2=0; pp3=0 +#endif + + IF (lfreeb) THEN + ALLOCATE (brv(nznt), bphiv(nznt), bzv(nznt), bsqvac(nznt), + & bsubu_sur(nznt), bsubv_sur(nznt), !MRC 10-15-15 + & bsupu_sur(nznt), bsupv_sur(nznt), + & stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #2 in allocate_funct3d' + END IF + brv=0; bphiv=0; bzv=0; bsqvac=0 + END IF + + ALLOCATE (extra1(ndim,0:1), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #3 in allocate_funct3d' + END IF + extra1=0 + + IF (lasym) THEN + ALLOCATE (extra2(ndim,0:1), extra3(ndim,0:1), + & extra4(ndim,0:1),stat=istat1) + ELSE + ALLOCATE (extra2(ndim,1), extra3(ndim,1), extra4(ndim,1), + & stat=istat1) + END IF + IF (istat1.ne.0) STOP 'allocation error #3 in allocate_funct3d' + extra2=0; extra3=0; extra4=0 +! +! Pointer alias assignments +! NOTE: In FORCES, X_e(nrzt+1) overlaps X_o(1), which should never be used... +! + armn_e => armn(:ndim) + armn_o => armn(ndim:) + armn(:ndim2) = zero + brmn_e => brmn(:ndim) + brmn_o => brmn(ndim:) + brmn(:ndim2) = zero + azmn_e => azmn(:ndim) + azmn_o => azmn(ndim:) + azmn(:ndim2) = zero + bzmn_e => bzmn(:ndim) + bzmn_o => bzmn(ndim:) + bzmn(:ndim2) = zero + crmn_e => crmn(:ndim) + crmn_o => crmn(ndim:) + crmn(:ndim2) = zero + czmn_e => czmn(:ndim) + czmn_o => czmn(ndim:) + czmn(:ndim2) = zero + blmn_e => blmn(:ndim) + blmn_o => blmn(ndim:) + blmn(:ndim2) = zero + clmn_e => clmn(:ndim) + clmn_o => clmn(ndim:) + clmn(:ndim2) = zero + rcon0(:ndim) = zero + zcon0(:ndim) = zero + + END SUBROUTINE allocate_funct3d diff --git a/Sources/Initialization_Cleanup/allocate_ns.f b/Sources/Initialization_Cleanup/allocate_ns.f new file mode 100644 index 0000000..8a5c7b3 --- /dev/null +++ b/Sources/Initialization_Cleanup/allocate_ns.f @@ -0,0 +1,186 @@ + SUBROUTINE allocate_ns (linterp, neqs_old) + USE vmec_main + USE vmec_params, ONLY: ntmax + USE realspace + USE vforces + USE xstuff + USE csplinx + USE mgrid_mod + USE fbal + USE parallel_include_module + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ns, ntheta3 + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y V a r i a b l e s +C----------------------------------------------- + INTEGER, INTENT(in) :: neqs_old + LOGICAL, INTENT(inout) :: linterp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ndim, nsp1, istat1 + REAL(rprec), DIMENSION(:), ALLOCATABLE :: xc_old, scalxc_old + REAL(rprec), DIMENSION(:), ALLOCATABLE :: pxc_old, pscalxc_old + REAL(rprec) :: delr_mse +C----------------------------------------------- +! +! FIRST STORE COARSE-MESH XC FOR INTERPOLATION +! + ndim = 1 + nrzt + nsp1 = 1 + ns + delr_mse = zero + +! +! Save old xc, scalxc for possible interpolation or IF iterations restarted on same mesh... +! + IF (PARVMEC) THEN + IF (neqs_old.GT.0 .AND. ALLOCATED(pscalxc) .AND. linterp) THEN + ALLOCATE(pxc_old(neqs_old),pscalxc_old(neqs_old), + & stat=istat1) + IF (istat1.NE.0) THEN + STOP 'allocation error #1 in allocate_ns' + ENDIF + pxc_old(:neqs_old) = pxc(:neqs_old) + pscalxc_old(:neqs_old) = pscalxc(:neqs_old) + END IF + END IF + + IF (neqs_old .GT. 0 .AND. ALLOCATED(scalxc) .AND. linterp) THEN + ALLOCATE(xc_old(neqs_old), scalxc_old(neqs_old), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #1 in allocate_ns' + END IF + xc_old(:neqs_old) = xc(:neqs_old) + scalxc_old(:neqs_old) = scalxc(:neqs_old) + END IF + +! +! ALLOCATES MEMORY FOR NS-DEPENDENT ARRAYS +! FIRST BE SURE TO FREE MEMORY PREVIOUSLY ALLOCATED +! + IF (PARVMEC) THEN + CALL free_mem_ns_par (.true.) + END IF + CALL free_mem_ns (.true.) + + ALLOCATE (phip(ndim), chip(ndim), shalf(ndim), sqrts(ndim), + 1 wint(ndim), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #2 in allocate_ns' + END IF + phip=0; chip=0; shalf=0; sqrts=0; wint=0 + + IF(PARVMEC) THEN + ALLOCATE(pshalf(nznt,ns),stat=istat1) + ALLOCATE(pwint(nznt,ns),stat=istat1) + ALLOCATE(pwint_ns(nznt),stat=istat1) + ALLOCATE(ireflect_par(nzeta),stat=istat1) + ALLOCATE(pchip(nznt,ns),stat=istat1) + ALLOCATE(pphip(nznt,ns),stat=istat1) + ALLOCATE(psqrts(nznt,ns),stat=istat1) + ALLOCATE(pfaclam(0:ntor,0:mpol1,1:ns,ntmax),stat=istat1) + END IF + + ALLOCATE(ireflect(ns*nzeta), stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #3 in allocate_ns' + END IF + + ALLOCATE(ard(nsp1,2),arm(nsp1,2),brd(nsp1,2),brm(nsp1,2), + & azd(nsp1,2),azm(nsp1,2),bzd(nsp1,2), bzm(nsp1,2), + & sm(ns), sp(0:ns), bmin(ntheta2,ns), bmax(ntheta2,ns), + & stat=istat1) + IF (istat1.ne.0) THEN + STOP 'allocation error #6 in allocate_ns' + END IF + + ALLOCATE(iotaf(nsp1), crd(nsp1), mass(ns), phi(ns), presf(ns), + & jcuru(ns), jcurv(ns), jdotb(ns), buco(ns), bvco(ns), +#ifdef _ANIMEC +!WAC ANISTROPIC VARIABLES + & phot(ns), pmap(ns), pppr(ns), papr(ns), tpotb(ns), + & pd(ns), +#endif + & bucof(ns), bvcof(ns), chi(ns), + & bdotgradv(ns), equif(ns), specw(ns), tcon(ns), + & psi(ns),yellip(ns),yinden(ns), ytrian(ns),yshift(ns), + & ygeo(ns),overr(ns), faclam(ns,0:ntor,0:mpol1,ntmax), + & iotas(nsp1), phips(nsp1), chips(nsp1), pres(nsp1), + & beta_vol(ns), jperp2(ns), jpar2(ns), bdotb(ns), + & phipf(ns), chipf(ns), blam(nsp1), clam(nsp1), + & dlam(nsp1), rru_fac(ns), rzu_fac(ns), frcc_fac(ns), + & fzsc_fac(ns), icurv(ns+1), vpphi(ns), bdamp(ns), + & presgrad(ns), vp(nsp1), r01(ns), z01(ns), stat=istat1) + + frcc_fac = 0; fzsc_fac = 0 +#ifdef _ANIMEC + phot=0; tpotb=0 +#endif + IF (istat1 .NE. 0) THEN + STOP 'allocation error #7 in allocate_ns' + END IF + + iotaf(nsp1) = 0 + + ALLOCATE(rmidx(2*ns), hmidx(2*ns), wmidx(2*ns), qmidx(2*ns), + 1 tenmidx(2*ns), ymidx(2*ns), y2midx(2*ns), stat=istat1) + IF (istat1 .NE. 0) THEN + STOP 'allocation error #8 in allocate_ns' + END IF + + IF(PARVMEC) THEN + ALLOCATE(pgc(neqs), pxcdot(neqs), pxsave(neqs), + & pxstore(neqs), pcol_scale(neqs), stat=istat1) + pxstore = zero + IF (istat1 .NE. 0) THEN + STOP 'allocation error #9 in allocate_ns' + END IF + + IF (.not.ALLOCATED(pxc)) THEN + ALLOCATE (pxc(neqs), pscalxc(neqs), stat=istat1) + IF (istat1 .NE. 0) THEN + STOP 'allocation error #10 in allocate_ns' + END IF + pxc(:neqs) = zero + END IF + + IF (ALLOCATED(pxc_old)) THEN + pxstore(1:neqs_old) = pxc_old(1:neqs_old) + pscalxc(1:neqs_old) = pscalxc_old(1:neqs_old) + DEALLOCATE (pxc_old, pscalxc_old) + END IF + END IF + + ALLOCATE(gc(neqs), xcdot(neqs), xsave(neqs), + & xstore(neqs), col_scale(neqs), stat=istat1) + xstore = zero + IF (istat1 .NE. 0) THEN + STOP 'allocation error #9 in allocate_ns' + END IF + + IF (.NOT.ALLOCATED(xc)) THEN + ALLOCATE (xc(neqs), scalxc(neqs), stat=istat1) + IF (istat1 .NE. 0) THEN + STOP 'allocation error #10 in allocate_ns' + END IF + xc(:neqs) = zero + END IF + + IF (ALLOCATED(xc_old)) THEN + xstore(1:neqs_old) = xc_old(1:neqs_old) + scalxc(1:neqs_old) = scalxc_old(1:neqs_old) + DEALLOCATE (xc_old, scalxc_old) + END IF + +! +! Allocate nrzt-dependent arrays (persistent) for funct3d +! + IF (PARVMEC) THEN + CALL allocate_funct3d_par + ELSE + CALL allocate_funct3d + END IF + + END SUBROUTINE allocate_ns diff --git a/Sources/Initialization_Cleanup/allocate_nunv.f b/Sources/Initialization_Cleanup/allocate_nunv.f new file mode 100644 index 0000000..2e4f466 --- /dev/null +++ b/Sources/Initialization_Cleanup/allocate_nunv.f @@ -0,0 +1,30 @@ + SUBROUTINE allocate_nunv + USE vmec_main + USE vmec_params, ONLY: ntmax + USE vacmod + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 +C----------------------------------------------- + CALL free_mem_nunv + + ALLOCATE (bsubu0(nznt), rbsq(nznt), dbsq(nznt), stat=istat1) + IF (istat1.ne.0) STOP 'allocation error #1 in allocate_nunv' + +#ifdef _ANIMEC + ALLOCATE (pperp_ns(nznt), stat=istat1) +#endif + ALLOCATE (rmn_bdy(0:ntor,0:mpol1,ntmax), + 1 zmn_bdy(0:ntor,0:mpol1,ntmax), stat=istat1) + IF (istat1.ne.0) STOP 'allocation error #2 in allocate_nunv' + +! PERSISTENT ARRAYS (DURATION OF PROGRAM) + IF (lfreeb) + 1 ALLOCATE (amatsav(mnpd2*mnpd2),bvecsav(mnpd2), + 2 bsqsav(nznt,3), potvac(2*mnpd), raxis_nestor(nv), + 3 zaxis_nestor(nv), stat=istat1) + IF (istat1.ne.0) STOP 'allocation error #3 in allocate_nunv' + + END SUBROUTINE allocate_nunv diff --git a/Sources/Initialization_Cleanup/close_all_files.f b/Sources/Initialization_Cleanup/close_all_files.f new file mode 100644 index 0000000..7a5f5eb --- /dev/null +++ b/Sources/Initialization_Cleanup/close_all_files.f @@ -0,0 +1,9 @@ + SUBROUTINE close_all_files + USE vparams, ONLY: nmac, nthreed + IMPLICIT NONE +C----------------------------------------------- + + IF (nthreed .gt. 0) CLOSE (nthreed) + IF (nmac .gt. 0) CLOSE (nmac) + + END SUBROUTINE close_all_files diff --git a/Sources/Initialization_Cleanup/fixaray.f b/Sources/Initialization_Cleanup/fixaray.f new file mode 100644 index 0000000..8215aef --- /dev/null +++ b/Sources/Initialization_Cleanup/fixaray.f @@ -0,0 +1,176 @@ + SUBROUTINE fixaray + USE vmec_main, p5 => cp5 + USE vmec_params, ONLY: jmin2, mscale, nscale, + & mnyq, nnyq, signgs +#ifdef _HBANGLE + USE angle_constraints, ONLY: init_multipliers +#endif + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: two=2, pexp=4 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, m, j, n, mn, mn1, nmin0, istat1, istat2 + INTEGER :: mnyq0, nnyq0 + REAL(dp) :: argi, arg, argj, dnorm, tfixon, tfixoff +C----------------------------------------------- +! +! INDEX OF LOCAL VARIABLES +! +! mscale array for norming theta-trig functions (internal use only) +! so that the discrete SUM[cos(mu)*cos(m'u)] = .5 delta(m,m') +! nscale array for norming zeta -trig functions (internal use only) + +! +! COMPUTE TRIGONOMETRIC FUNCTION ARRAYS +! NOTE: ARRAYS ALLOCATED HERE ARE GLOBAL AND ARE DEALLOCATED IN FILEOUT +! NOTE: NEED 2 X NYQUIST FOR FAST HESSIAN CALCULATIONS +! + mnyq0 = ntheta1/2 + nnyq0 = nzeta/2 + + mnyq = MAX(0, 2*mnyq0, 2*mpol1) + nnyq = MAX(0, 2*nnyq0, 2*ntor) + + mnmax_nyq = nnyq/2 + 1 + mnyq*(nnyq + 1)/2 + + ALLOCATE(cosmu(ntheta3,0:mnyq), sinmu(ntheta3,0:mnyq), + 1 cosmum(ntheta3,0:mnyq), sinmum(ntheta3,0:mnyq), + 2 cosmui(ntheta3,0:mnyq), cosmumi(ntheta3,0:mnyq), + 2 cosmui3(ntheta3,0:mnyq),cosmumi3(ntheta3,0:mnyq), + 3 sinmui(ntheta3,0:mnyq), sinmumi(ntheta3,0:mnyq), + 4 cosnv(nzeta,0:nnyq), sinnv(nzeta,0:nnyq), + 5 cosnvn(nzeta,0:nnyq), sinnvn(nzeta,0:nnyq), + 6 cos01(nznt), sin01(nznt), stat=istat1 ) + ALLOCATE(xm(mnmax), xn(mnmax), ixm(mnsize), jmin3(0:mnsize-1), + 1 xm_nyq(mnmax_nyq), xn_nyq(mnmax_nyq), + 2 mscale(0:mnyq), nscale(0:nnyq), stat=istat2) + + IF (istat1.ne.0) THEN + STOP 'allocation error in fixaray: istat1' + END IF + IF (istat2.ne.0) THEN + STOP 'allocation error in fixaray: istat2' + END IF + + dnorm = one/(nzeta*(ntheta2 - 1)) + IF (lasym) THEN + dnorm = one/(nzeta*ntheta3) !Fix, SPH012314 + END IF + + mscale(0) = 1; nscale(0) = 1 +! mscale(0) = osqrt2; nscale(0) = osqrt2 !versions < 6.9, incorrectly used osqrt2 + + mscale(1:mnyq) = mscale(0)/osqrt2 + nscale(1:nnyq) = nscale(0)/osqrt2 + r0scale = mscale(0)*nscale(0) + +! +! GENERALLY, ONLY NEED THIS FROM 1, ntheta2 EXCEPT IN GETBRHO ROUTINE +! + DO i = 1, ntheta3 + argi = twopi*(i - 1)/ntheta1 + DO m = 0, mnyq + arg = argi*m + cosmu(i,m) = COS(arg)*mscale(m) + sinmu(i,m) = SIN(arg)*mscale(m) + cosmui(i,m) = dnorm*cosmu(i,m) + cosmui3(i,m) = cosmui(i,m) !Use this if integration over FULL 1,ntheta3 interval + sinmui(i,m) = dnorm*sinmu(i,m) + IF (i.EQ.1 .OR. i.EQ.ntheta2) THEN + cosmui(i,m) = cosmui(i,m)/2 + END IF + IF (ntheta2 .EQ. ntheta3) THEN + cosmui3(i,m) = cosmui(i,m) + END IF + cosmum(i,m) = cosmu(i,m)*(m) + sinmum(i,m) = -sinmu(i,m)*(m) + cosmumi(i,m) = cosmui(i,m)*(m) + cosmumi3(i,m) = cosmui3(i,m)*m + sinmumi(i,m) = -sinmui(i,m)*(m) + END DO + END DO + + DO j = 1, nzeta + argj = twopi*(j - 1)/nzeta + DO n = 0, nnyq + arg = argj*(n) + cosnv(j,n) = COS(arg)*nscale(n) + sinnv(j,n) = SIN(arg)*nscale(n) + cosnvn(j,n) = cosnv(j,n)*(n*nfp) + sinnvn(j,n) = -sinnv(j,n)*(n*nfp) + END DO + END DO + +! +! R,Z,L / s**(m/2) ARE LINEAR NEAR ORIGIN +! + mn = 0 + mn1 = 0 + DO m = 0, mpol1 + xmpq(m,1) = m*(m - 1) + xmpq(m,2) = m**pexp + xmpq(m,3) = m**(pexp + 1) + DO n = 0, ntor + jmin3(mn) = jmin2(m) + mn = mn + 1 + ixm(mn) = m + END DO + nmin0 = -ntor + IF (m .eq. 0) nmin0 = 0 + DO n = nmin0, ntor + mn1 = mn1 + 1 + xm(mn1) = m + xn(mn1) = n*nfp + END DO + END DO + + IF (mn1 .ne. mnmax) THEN + STOP 'mn1 != mnmax' + END IF + +! +! COMPUTE NYQUIST-SIZED ARRAYS FOR OUTPUT. +! RESTORE m,n Nyquist TO 1 X ... (USED IN WROUT, JXBFORCE) +! mnyq = mnyq0; nnyq = nnyq0 + mnyq = mnyq/2 + nnyq = nnyq/2 + + mn1 = 0 + DO m = 0, mnyq + nmin0 = -nnyq + IF (m .eq. 0) nmin0 = 0 + DO n = nmin0, nnyq + mn1 = mn1 + 1 + xm_nyq(mn1) = m + xn_nyq(mn1) = n*nfp + END DO + END DO + + IF (mn1 .ne. mnmax_nyq) THEN + STOP 'mn1 != mnmax_nyq' + END IF + + mn = 0 + m = 1 + DO i = 1, ntheta3 + argi = twopi*(i - 1)/ntheta1 + DO j = 1, nzeta + mn = mn + 1 + cos01(mn) = m*COS(m*argi)*mscale(m) + sin01(mn) = -m*SIN(m*argi)*mscale(m) + END DO + END DO + + faccon(0) = zero + faccon(mpol1) = zero + faccon(1:mpol1 - 1) = -0.25_dp*signgs/xmpq(2:mpol1,1)**2 + +#ifdef _HBANGLE + CALL init_multipliers +#endif + + END SUBROUTINE fixaray diff --git a/Sources/Initialization_Cleanup/free_mem_funct3d.f b/Sources/Initialization_Cleanup/free_mem_funct3d.f new file mode 100644 index 0000000..6bba5cd --- /dev/null +++ b/Sources/Initialization_Cleanup/free_mem_funct3d.f @@ -0,0 +1,83 @@ + SUBROUTINE free_mem_funct3d_par + USE vmec_main + USE realspace + USE vforces + USE vacmod + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 = 0 +C----------------------------------------------- + IF (ALLOCATED(parmn)) + & DEALLOCATE(parmn, pazmn, pbrmn, pbzmn, pcrmn, pczmn, pblmn, + & pclmn, pr1, pru, prv, pz1, pzu, pzv, pgcon, prcon, + & pzcon, prcon0, pzcon0, pguu, pguv, pgvv, + & pru0, pzu0, stat=istat1) + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#1 in funct3d' + END IF + + IF (ALLOCATED(pextra1)) THEN + DEALLOCATE (pextra1, pextra2, pextra3, pextra4, stat=istat1) + END IF + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#3 in funct3d' + END IF + + END SUBROUTINE free_mem_funct3d_par + + SUBROUTINE free_mem_funct3d + USE vmec_main + USE realspace + USE vforces + USE vacmod + + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 = 0 +C----------------------------------------------- + + IF (ALLOCATED(armn)) THEN + DEALLOCATE (armn, azmn, brmn, bzmn, crmn, czmn, blmn, clmn, + & r1, ru, rv, z1, zu, zv, gcon, rcon, zcon, ru0, zu0, + & rcon0, zcon0, guu, guv, gvv, sigma_an, stat=istat1) + END IF + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#1 in funct3d' + END IF + +#ifdef _ANIMEC + IF (ALLOCATED(pperp)) THEN + DEALLOCATE (pperp, ppar, onembc, pp1, pp2, pp3, + & stat=istat1) + END IF + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#1A in funct3d' + END IF +#endif + + IF (ALLOCATED(brv)) THEN + DEALLOCATE(brv, bphiv, bzv, bsqvac, + & bsubu_sur, bsubv_sur, + & bsupu_sur, bsupv_sur, stat=istat1) + END IF + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#2 in funct3d' + END IF + + IF (ALLOCATED(bsqvac0)) THEN + DEALLOCATE (bsqvac0) + END IF + + IF (ALLOCATED(extra1)) THEN + DEALLOCATE (extra1, extra2, extra3, extra4, stat=istat1) + END IF + IF (istat1 .ne. 0) THEN + STOP 'deallocation error#3 in funct3d' + END IF + + END SUBROUTINE free_mem_funct3d diff --git a/Sources/Initialization_Cleanup/free_mem_ns.f b/Sources/Initialization_Cleanup/free_mem_ns.f new file mode 100644 index 0000000..b668ded --- /dev/null +++ b/Sources/Initialization_Cleanup/free_mem_ns.f @@ -0,0 +1,104 @@ + SUBROUTINE free_mem_ns_par(lreset) + USE vmec_main + USE realspace + USE vforces + USE xstuff + USE csplinx + USE fbal + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + LOGICAL, INTENT(in) :: lreset + +C----------------------------------------------- + IF (ALLOCATED(pshalf)) DEALLOCATE(pshalf) + IF (ALLOCATED(psqrts)) DEALLOCATE(psqrts) + IF (ALLOCATED(pwint)) DEALLOCATE(pwint) + IF (ALLOCATED(pfaclam)) DEALLOCATE(pfaclam) + IF (ALLOCATED(pchip)) DEALLOCATE(pchip) + IF (ALLOCATED(pphip)) DEALLOCATE(pphip) + IF (ALLOCATED(pfaclam)) DEALLOCATE(pfaclam) + + IF (ALLOCATED(pxc) .and. lreset) DEALLOCATE(pxc) + IF (ALLOCATED(pscalxc) .and. lreset) DEALLOCATE (pscalxc) + + IF (ALLOCATED(pxstore)) DEALLOCATE (pxstore) + IF (ALLOCATED(pxcdot)) DEALLOCATE (pxcdot) + IF (ALLOCATED(pxsave)) DEALLOCATE (pxsave) + IF (ALLOCATED(pgc)) DEALLOCATE (pgc) + IF (ALLOCATED(pcol_scale)) DEALLOCATE(pcol_scale) + + END SUBROUTINE free_mem_ns_par + + SUBROUTINE free_mem_ns(lreset) + USE vmec_main + USE realspace + USE vforces + USE xstuff + USE csplinx + USE fbal + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + LOGICAL, INTENT(in) :: lreset +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 = 0, istat2 = 0, istat3 = 0, istat4 = 0, + 1 istat5 = 0, istat6 = 0, istat7 = 0, istat8 = 0, + 2 istat9 = 0, istat10 = 0 +C----------------------------------------------- + + IF (ALLOCATED(phip)) THEN + DEALLOCATE(phip, chip, shalf, sqrts, wint, stat=istat1) + END IF + + IF (ALLOCATED(ireflect)) THEN + DEALLOCATE(ireflect, stat=istat2) + END IF + + IF (ALLOCATED(ard)) THEN + DEALLOCATE(ard, arm, brd, brm, crd, azd, azm, bzd, bzm, sm, + & sp, bmin, bmax, stat=istat5) + END IF + + IF (ALLOCATED(iotaf)) THEN + DEALLOCATE(iotaf, mass, phi, presf, jcuru, jcurv, jdotb, buco, + & bvco, bucof, bvcof, chi, +#ifdef _ANIMEC + & phot, pmap, pppr, papr, tpotb, pd, +#endif + & bdotgradv, equif, specw, tcon, psi, yellip, yinden, + & ytrian, yshift, ygeo, overr, faclam, iotas, phips, + & chips, pres, vp, beta_vol, jperp2, jpar2, bdotb, + & clam, blam, dlam, phipf, chipf, rru_fac, rzu_fac, + & frcc_fac, fzsc_fac, icurv, vpphi, presgrad, r01, + & z01, bdamp, stat=istat6) + END IF + + IF (ALLOCATED(rmidx)) THEN + DEALLOCATE(rmidx, hmidx, wmidx, qmidx, tenmidx, ymidx, y2midx, + & stat=istat7) + END IF + + IF (ALLOCATED(gc)) THEN + DEALLOCATE(gc, xsave, xstore, xcdot, col_scale, stat=istat8) + END IF + IF (ALLOCATED(xc) .AND. lreset) THEN + DEALLOCATE(xc, scalxc) + END IF + + IF ((istat1 + istat2 + istat3 + istat4 + istat5 + istat6 + + & istat7 + istat8) .ne. 0) THEN + PRINT *,' deallocation problem in free_mem_ns' + PRINT *,' istat1 = ',istat1,' istat2 = ',istat2 + PRINT *,' istat3 = ',istat3,' istat4 = ',istat4 + PRINT *,' istat5 = ',istat5,' istat6 = ',istat6 + PRINT *,' istat7 = ',istat7,' istat8 = ',istat8 + END IF + + END SUBROUTINE free_mem_ns diff --git a/Sources/Initialization_Cleanup/free_mem_nunv.f b/Sources/Initialization_Cleanup/free_mem_nunv.f new file mode 100644 index 0000000..642ad4b --- /dev/null +++ b/Sources/Initialization_Cleanup/free_mem_nunv.f @@ -0,0 +1,29 @@ + SUBROUTINE free_mem_nunv + USE vmec_main + USE vacmod + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 = 0, istat2 = 0, istat3 = 0 +C----------------------------------------------- + + IF (ALLOCATED(bsubu0)) + 1 DEALLOCATE (bsubu0, rbsq, dbsq, stat=istat1) +#ifdef _ANIMEC + IF (ALLOCATED(pperp_ns)) DEALLOCATE(pperp_ns) +#endif + IF (ALLOCATED(rmn_bdy)) + 1 DEALLOCATE (rmn_bdy, zmn_bdy, stat=istat2) + + IF (ALLOCATED(amatsav)) + 1 DEALLOCATE (amatsav, bvecsav, potvac, bsqsav, + 2 raxis_nestor, zaxis_nestor, stat=istat3) + + IF (istat1.ne.0 .or. istat2.ne.0 .or. istat3.ne.0) THEN + PRINT *,' deallocation problem in free_mem_nunv' + PRINT *,' istat1 = ',istat1,' istat2 = ',istat2 + PRINT *,' istat3 = ',istat3 + ENDIF + + END SUBROUTINE free_mem_nunv diff --git a/Sources/Initialization_Cleanup/free_persistent_mem.f b/Sources/Initialization_Cleanup/free_persistent_mem.f new file mode 100644 index 0000000..d48affa --- /dev/null +++ b/Sources/Initialization_Cleanup/free_persistent_mem.f @@ -0,0 +1,19 @@ + SUBROUTINE free_persistent_mem + USE vmec_main + USE xstuff + USE mgrid_mod, ONLY: free_mgrid + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat1 = 0, istat2 = 0 +c----------------------------------------------- + IF (ALLOCATED(xc)) DEALLOCATE (xc, scalxc, stat=istat1) + CALL free_mgrid (istat2) + + IF (istat1.ne.0 .or. istat2.ne.0) THEN + PRINT *,'problem in free_persistent_mem' + PRINT *,' istat1 = ',istat1,' istat2 = ',istat2 + ENDIF + + END SUBROUTINE free_persistent_mem diff --git a/Sources/Initialization_Cleanup/guess_axis.f b/Sources/Initialization_Cleanup/guess_axis.f new file mode 100644 index 0000000..662de34 --- /dev/null +++ b/Sources/Initialization_Cleanup/guess_axis.f @@ -0,0 +1,406 @@ + SUBROUTINE guess_axis_par(r1, z1, ru0, zu0, lscreen) + USE vmec_main + USE vmec_params, ONLY: nscale, signgs + USE realspace, ONLY: psqrts + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nzeta,ntheta3,ns,0:1), INTENT(inout) :: r1, z1 + REAL(dp), DIMENSION(nzeta,ntheta3,ns),INTENT(inout) :: ru0, zu0 + LOGICAL, INTENT(in) :: lscreen +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER, PARAMETER :: limpts = 61 + REAL(dp), PARAMETER :: p5 = 0.5_dp, two = 2 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, j, k + INTEGER :: iv, iu, iu_r, ivminus, nlim, ns12, klim, n + REAL(dp), DIMENSION(nzeta) :: rcom, zcom + REAL(dp), DIMENSION(ntheta1) :: r1b, z1b, rub, zub + REAL(dp), DIMENSION(ntheta1) :: r12, z12 + REAL(dp), DIMENSION(ntheta1) :: rs, zs, tau, ru12, zu12, tau0 + REAL(dp) :: rlim, zlim + REAL(dp) :: rmax, rmin, zmax, zmin, dzeta + REAL(dp) :: ds, mintau, mintemp + INTEGER :: blksize, numjs, left, right, bcastrank + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: send_buf + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: send_buf2 + REAL(dp), ALLOCATABLE, DIMENSION(:) :: recv_buf + REAL(dp) :: tbroadon, tbroadoff, tguesson, tguessoff + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: bcastbuf + REAL(dp), ALLOCATABLE :: tmp(:) + REAL(dp) :: tmp2(nzeta,2) +C----------------------------------------------- +! +! COMPUTES GUESS FOR MAGNETIC AXIS IF USER GUESS +! LEADS TO INITIAL SIGN CHANGE OF JACOBIAN. DOES A GRID +! SEARCH (irgrid, izgrid) IN EACH PHI-PLANE FOR POINTS WHICH +! YIELD A VALUE FOR THE JACOBIAN WITH THE CORRECT SIGN (SIGNGS) +! CHOOSES THE AXIS POSITION SO THE MIN VALUE OF THE JACOBIAN IS MAXIMIZED +! + CALL second0(tguesson) + ns12 = (ns + 1)/2 + +#if defined(MPI_OPT) + IF (nranks.GT.1) THEN + bcastrank = -1 + IF (ns.EQ.nranks) THEN + bcastrank=ns12 + ELSE IF (ns.GT.nranks) THEN + !!! Can make this log P (for later) : SKS : NOV 13, 2014 + DO i=1, nranks + IF (tlglob_arr(i) .LE. ns12 .AND. + & ns12 .LE. trglob_arr(i)) THEN + bcastrank = i - 1 + EXIT + END IF + END DO + ELSE + IF (rank.EQ.0) THEN + WRITE(*,*) 'Something wrong in guess_axis' + END IF + CALL STOPMPI(666) + END IF + + ALLOCATE(bcastbuf(nzeta,ntheta3,6)) + bcastbuf(:,:,1) = r1(:,:,ns12,0) + bcastbuf(:,:,2) = r1(:,:,ns12,1) + bcastbuf(:,:,3) = z1(:,:,ns12,0) + bcastbuf(:,:,4) = z1(:,:,ns12,1) + bcastbuf(:,:,5) = ru0(:,:,ns12) + bcastbuf(:,:,6) = zu0(:,:,ns12) + + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf, 6*nznt, MPI_REAL8, bcastrank, + & NS_COMM, MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff-tbroadon) + + r1(:,:,ns12,0) = bcastbuf(:,:,1) + r1(:,:,ns12,1) = bcastbuf(:,:,2) + z1(:,:,ns12,0) = bcastbuf(:,:,3) + z1(:,:,ns12,1) = bcastbuf(:,:,4) + ru0(:,:,ns12) = bcastbuf(:,:,5) + zu0(:,:,ns12) = bcastbuf(:,:,6) + + bcastbuf(:,:,1) = r1(:,:,ns,0) + bcastbuf(:,:,2) = r1(:,:,ns,1) + bcastbuf(:,:,3) = z1(:,:,ns,0) + bcastbuf(:,:,4) = z1(:,:,ns,1) + bcastbuf(:,:,5) = ru0(:,:,ns) + bcastbuf(:,:,6) = zu0(:,:,ns) + + CALL second0(tbroadon) + CALL MPI_Bcast(bcastbuf, 6*nznt, MPI_REAL8, nranks - 1, + & NS_COMM, MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + + r1(:,:,ns,0) = bcastbuf(:,:,1) + r1(:,:,ns,1) = bcastbuf(:,:,2) + z1(:,:,ns,0) = bcastbuf(:,:,3) + z1(:,:,ns,1) = bcastbuf(:,:,4) + ru0(:,:,ns) = bcastbuf(:,:,5) + zu0(:,:,ns) = bcastbuf(:,:,6) + DEALLOCATE(bcastbuf) + + CALL second0(tbroadon) + CALL MPI_Bcast(psqrts(1,ns12), 1, MPI_REAL8, bcastrank, + & NS_COMM, MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + + ALLOCATE(tmp(2*nzeta)) + tmp(1:nzeta) = r1(:,1,1,0) + tmp(nzeta + 1:2*nzeta) = z1(:,1,1,0) + CALL second0(tbroadon) + CALL MPI_Bcast(tmp, 2*nzeta, MPI_REAL8, 0, NS_COMM, MPI_ERR) + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + r1(:,1,1,0) = tmp(1:nzeta) + z1(:,1,1,0) = tmp(nzeta + 1:2*nzeta) + DEALLOCATE(tmp) + END IF +#endif + + planes: DO iv = 1, nzeta + IF (.not.lasym .and. iv .gt. nzeta/2 + 1) THEN + rcom(iv) = rcom(nzeta + 2 - iv) + zcom(iv) =-zcom(nzeta + 2 - iv) + CYCLE + END IF + r1b(:ntheta3) = r1(iv,:,ns,0) + r1(iv,:,ns,1) + z1b(:ntheta3) = z1(iv,:,ns,0) + z1(iv,:,ns,1) + r12(:ntheta3) = r1(iv,:,ns12,0)+r1(iv,:,ns12,1)*psqrts(1,ns12) + z12(:ntheta3) = z1(iv,:,ns12,0)+z1(iv,:,ns12,1)*psqrts(1,ns12) + rub(:ntheta3) = ru0(iv,:,ns) + zub(:ntheta3) = zu0(iv,:,ns) + ru12(:ntheta3) = p5*(ru0(iv,:,ns) + ru0(iv,:,ns12)) + zu12(:ntheta3) = p5*(zu0(iv,:,ns) + zu0(iv,:,ns12)) + + IF (.not.lasym) THEN +! +! USE Z(v,-u) = -Z(twopi-v,u), R(v,-u) = R(twopi-v,u) +! TO DO EXTEND R,Z, etc. OVER ALL THETA (NOT JUST 0,PI) +! + ivminus = MOD(nzeta + 1 - iv,nzeta) + 1 !!(twopi-v) + DO iu = 1+ntheta2, ntheta1 + iu_r = ntheta1 + 2 - iu + r1b(iu) = r1(ivminus,iu_r,ns,0) + r1(ivminus,iu_r,ns,1) + z1b(iu) =-(z1(ivminus,iu_r,ns,0) + + & z1(ivminus,iu_r,ns,1)) + r12(iu) = r1(ivminus,iu_r,ns12,0) + & + r1(ivminus,iu_r,ns12,1)*psqrts(1,ns12) + z12(iu) =-(z1(ivminus,iu_r,ns12,0) + + & z1(ivminus,iu_r,ns12,1)*psqrts(1,ns12)) + rub(iu) =-ru0(ivminus,iu_r,ns) + zub(iu) = zu0(ivminus,iu_r,ns) + ru12(iu) =-p5*(ru0(ivminus,iu_r,ns) + + & ru0(ivminus,iu_r,ns12)) + zu12(iu) = p5*(zu0(ivminus,iu_r,ns) + + & zu0(ivminus,iu_r,ns12)) + END DO + END IF +! +! Scan over r-z grid for interior point +! + rmin = MINVAL(r1b) + rmax = MAXVAL(r1b) + zmin = MINVAL(z1b) + zmax = MAXVAL(z1b) + rcom(iv) = (rmax + rmin)/2 + zcom(iv) = (zmax + zmin)/2 + +! +! Estimate jacobian based on boundary and 1/2 surface +! + ds = (ns - ns12)*hs + DO iu = 1, ntheta1 + rs(iu) = (r1b(iu) - r12(iu))/ds + r1(iv,1,1,0) + zs(iu) = (z1b(iu) - z12(iu))/ds + z1(iv,1,1,0) + tau0(iu) = ru12(iu)*zs(iu) - zu12(iu)*rs(iu) + END DO + + mintau = 0 + + DO nlim = 1, limpts + zlim = zmin + ((zmax - zmin)*(nlim-1))/(limpts - 1) + IF (.not.lasym .and. + & (iv .eq. 1 .or. iv .eq. nzeta/2 + 1)) THEN + zlim = 0 + IF (nlim .gt. 1) EXIT + END IF +! +! Find value of magnetic axis that maximizes the minimum jacobian value +! + DO klim = 1, limpts + rlim = rmin + ((rmax - rmin)*(klim - 1))/(limpts - 1) + tau = signgs*(tau0 - ru12(:)*zlim + zu12(:)*rlim) + mintemp = MINVAL(tau) + IF (mintemp .gt. mintau) THEN + mintau = mintemp + rcom(iv) = rlim + zcom(iv) = zlim +! If up-down symmetric and lasym=T, need this to pick z = 0 + ELSE IF (mintemp .eq. mintau) THEN + IF (ABS(zcom(iv)).gt.ABS(zlim)) THEN + zcom(iv) = zlim + END IF + END IF + END DO + END DO + + END DO planes + +!Distribute to all processors, not just NS_COMM +#if defined(MPI_OPT) + tmp2(:,1) = rcom + tmp2(:,2) = zcom + CALL MPI_BCast(tmp2, 2*nzeta, MPI_REAL8, 0, + 1 RUNVMEC_COMM_WORLD, MPI_ERR) + rcom = tmp2(:,1) + zcom = tmp2(:,2) +#endif +! +! FOURIER TRANSFORM RCOM, ZCOM +! + dzeta = two/nzeta + DO n = 0, ntor + raxis_cc(n) = dzeta*SUM(cosnv(:,n)*rcom(:))/nscale(n) + zaxis_cs(n) =-dzeta*SUM(sinnv(:,n)*zcom(:))/nscale(n) + raxis_cs(n) =-dzeta*SUM(sinnv(:,n)*rcom(:))/nscale(n) + zaxis_cc(n) = dzeta*SUM(cosnv(:,n)*zcom(:))/nscale(n) + IF (n .eq. 0 .or. n .eq. nzeta/2) THEN + raxis_cc(n) = p5*raxis_cc(n) + zaxis_cc(n) = p5*zaxis_cc(n) + END IF + END DO + + IF (grank == 0 .and. lscreen) THEN + PRINT *,' ---- Improved AXIS Guess ----' + PRINT *,' RAXIS_CC = ',raxis_cc(0:ntor) + PRINT *,' ZAXIS_CS = ',zaxis_cs(0:ntor) + PRINT *,' -----------------------------' + END IF + + CALL second0(tguessoff) + guess_axis_time = guess_axis_time + (tguessoff - tguesson) + + END SUBROUTINE guess_axis_par + + SUBROUTINE guess_axis(r1, z1, ru0, zu0) + USE vmec_main + USE vmec_params, ONLY: nscale, signgs + USE realspace, ONLY: sqrts + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(ns,nzeta,ntheta3,0:1), + 1 INTENT(in) :: r1, z1 + REAL(dp), DIMENSION(ns,nzeta,ntheta3), INTENT(in) :: ru0, zu0 +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER, PARAMETER :: limpts = 61 + REAL(dp), PARAMETER :: p5 = 0.5_dp, two = 2 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, j, k + INTEGER :: iv, iu, iu_r, ivminus, nlim, ns12, klim, n + REAL(dp), DIMENSION(nzeta) :: rcom, zcom + REAL(dp), DIMENSION(ntheta1) :: r1b, z1b, rub, zub + REAL(dp), DIMENSION(ntheta1) :: r12, z12 + REAL(dp), DIMENSION(ntheta1) :: rs, zs, tau, ru12, zu12, tau0 + REAL(dp) :: rlim, zlim + REAL(dp) :: rmax, rmin, zmax, zmin, dzeta + REAL(dp) :: ds, mintau, mintemp + REAL(dp) :: tguesson, tguessoff +C----------------------------------------------- +! +! COMPUTES GUESS FOR MAGNETIC AXIS IF USER GUESS +! LEADS TO INITIAL SIGN CHANGE OF JACOBIAN. DOES A GRID +! SEARCH (irgrid, izgrid) IN EACH PHI-PLANE FOR POINTS WHICH +! YIELD A VALUE FOR THE JACOBIAN WITH THE CORRECT SIGN (SIGNGS) +! CHOOSES THE AXIS POSITION SO THE MIN VALUE OF THE JACOBIAN IS MAXIMIZED +! + CALL second0(tguesson) + ns12 = (ns+1)/2 + + planes: DO iv = 1, nzeta + IF (.not.lasym .and. iv.gt.nzeta/2+1) THEN + rcom(iv) = rcom(nzeta+2-iv) + zcom(iv) =-zcom(nzeta+2-iv) + CYCLE + END IF + r1b(:ntheta3) = r1(ns,iv,:,0) + r1(ns,iv,:,1) + z1b(:ntheta3) = z1(ns,iv,:,0) + z1(ns,iv,:,1) + r12(:ntheta3) = r1(ns12,iv,:,0) + r1(ns12,iv,:,1)*sqrts(ns12) + z12(:ntheta3) = z1(ns12,iv,:,0) + z1(ns12,iv,:,1)*sqrts(ns12) + rub(:ntheta3) = ru0(ns,iv,:) + zub(:ntheta3) = zu0(ns,iv,:) + ru12(:ntheta3) = p5*(ru0(ns,iv,:) + ru0(ns12,iv,:)) + zu12(:ntheta3) = p5*(zu0(ns,iv,:) + zu0(ns12,iv,:)) + + IF (.not.lasym) THEN +! +! USE Z(v,-u) = -Z(twopi-v,u), R(v,-u) = R(twopi-v,u) +! TO DO EXTEND R,Z, etc. OVER ALL THETA (NOT JUST 0,PI) +! + ivminus = MOD(nzeta + 1 - iv,nzeta) + 1 !!(twopi-v) + DO iu = 1+ntheta2, ntheta1 + iu_r = ntheta1 + 2 - iu + r1b(iu) = r1(ns,ivminus,iu_r,0) + r1(ns,ivminus,iu_r,1) + z1b(iu) =-(z1(ns,ivminus,iu_r,0) + z1(ns,ivminus,iu_r,1)) + r12(iu) = r1(ns12,ivminus,iu_r,0) + & + r1(ns12,ivminus,iu_r,1)*sqrts(ns12) + z12(iu) =-(z1(ns12,ivminus,iu_r,0) + & + z1(ns12,ivminus,iu_r,1)*sqrts(ns12)) + rub(iu) =-ru0(ns,ivminus,iu_r) + zub(iu) = zu0(ns,ivminus,iu_r) + ru12(iu) = -p5*(ru0(ns,ivminus,iu_r) + & + ru0(ns12,ivminus,iu_r)) + zu12(iu) = p5*(zu0(ns,ivminus,iu_r) + & + zu0(ns12,ivminus,iu_r)) + END DO + + END IF + +! +! Scan over r-z grid for interior point +! + rmin = MINVAL(r1b) + rmax = MAXVAL(r1b) + zmin = MINVAL(z1b) + zmax = MAXVAL(z1b) + rcom(iv) = (rmax + rmin)/2 + zcom(iv) = (zmax + zmin)/2 + +! +! Estimate jacobian based on boundary and 1/2 surface +! + ds = (ns - ns12)*hs + DO iu = 1, ntheta1 + rs(iu) = (r1b(iu) - r12(iu))/ds + r1(1,iv,1,0) + zs(iu) = (z1b(iu) - z12(iu))/ds + z1(1,iv,1,0) + tau0(iu) = ru12(iu)*zs(iu) - zu12(iu)*rs(iu) + END DO + + mintau = 0 + + DO nlim = 1, limpts + zlim = zmin + ((zmax - zmin)*(nlim - 1))/(limpts - 1) + IF (.not.lasym .and. + & (iv .eq. 1 .or. iv .eq. nzeta/2 + 1)) THEN + zlim = 0 + IF (nlim .gt. 1) EXIT + END IF +! +! Find value of magnetic axis that maximizes the minimum jacobian value +! + DO klim = 1, limpts + rlim = rmin + ((rmax - rmin)*(klim - 1))/(limpts - 1) + tau = signgs*(tau0 - ru12(:)*zlim + zu12(:)*rlim) + mintemp = MINVAL(tau) + IF (mintemp .gt. mintau) THEN + mintau = mintemp + rcom(iv) = rlim + zcom(iv) = zlim +! If up-down symmetric and lasym=T, need this to pick z = 0 + ELSE IF (mintemp .eq. mintau) THEN + IF (ABS(zcom(iv)).gt.ABS(zlim)) zcom(iv) = zlim + END IF + END DO + END DO + + END DO planes + +! +! FOURIER TRANSFORM RCOM, ZCOM +! + dzeta = two/nzeta + DO n = 0, ntor + raxis_cc(n) = dzeta*SUM(cosnv(:,n)*rcom(:))/nscale(n) + zaxis_cs(n) =-dzeta*SUM(sinnv(:,n)*zcom(:))/nscale(n) + raxis_cs(n) =-dzeta*SUM(sinnv(:,n)*rcom(:))/nscale(n) + zaxis_cc(n) = dzeta*SUM(cosnv(:,n)*zcom(:))/nscale(n) + IF (n .eq. 0 .or. n .eq. nzeta/2) THEN + raxis_cc(n) = p5*raxis_cc(n) + zaxis_cc(n) = p5*zaxis_cc(n) + END IF + END DO + +! 100 FORMAT(' n = ',i4,' raxis = ',1pe10.3,' zaxis = ',1pe10.3) + + CALL second0(tguessoff) + s_guess_axis_time = s_guess_axis_time + (tguessoff - tguesson) + + END SUBROUTINE guess_axis diff --git a/Sources/Initialization_Cleanup/heading.f b/Sources/Initialization_Cleanup/heading.f new file mode 100644 index 0000000..08b548d --- /dev/null +++ b/Sources/Initialization_Cleanup/heading.f @@ -0,0 +1,84 @@ + SUBROUTINE heading(extension, time_slice, iseq_count, lmac, + 1 lscreen, lwrite) + USE vmec_main, ONLY: rprec + USE vparams, ONLY: nthreed, nmac + USE vmec_params, ONLY: version_ + USE date_and_computer + USE parallel_include_module, ONLY: grank + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: iseq_count + REAL(rprec) :: time_slice + CHARACTER(LEN=*) :: extension + LOGICAL :: lmac, lscreen, lwrite +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + CHARACTER(LEN=100), PARAMETER :: + & banner = ' THIS IS PARVMEC (PARALLEL VMEC), VERSION ' + CHARACTER(LEN=*), PARAMETER :: VersionID1 = + & ' Lambda: Full Radial Mesh. L-Force: hybrid full/half.' +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: imon, nout + CHARACTER(LEN=10) :: date0, time0, zone0 + CHARACTER(LEN=50) :: dateloc, Version + LOGICAL :: lfirst +C----------------------------------------------- +! +! Open output files +! + IF (grank .NE. 0) THEN + lscreen = .FALSE. + END IF + + CALL open_output_files(extension, iseq_count, lmac, lscreen, + & lfirst, lwrite) + + IF (.NOT.lfirst .OR. .NOT.lwrite) RETURN + +! FORTRAN-90 ROUTINE + CALL DATE_AND_TIME(date0, time0, zone0) + READ(date0(5:6),'(i2)') imon + WRITE(dateloc,1000) months(imon), date0(7:8), date0(1:4), + & time0(1:2), time0(3:4), time0(5:6) + + IF (lscreen) THEN + CALL GetComputerInfo + + Version = TRIM(ADJUSTL(version_)) + WRITE (nthreed,1002) TRIM(banner), TRIM(Version), + & TRIM(VersionID1), TRIM(computer), + & TRIM(os), TRIM(os_release), TRIM(dateloc) + + IF (lfirst) THEN + WRITE (*,1001) iseq_count + 1, time_slice, TRIM(extension) + WRITE (*,1003) TRIM(banner), TRIM(Version), + & TRIM(VersionID1), TRIM(computer), TRIM(os), + & TRIM(os_release), TRIM(dateloc) + END IF + ENDIF + + DO nout = nthreed, nthreed + 1 + imon = nout + IF (imon .eq. nthreed + 1) THEN + imon = nmac + END IF + IF (imon .eq. nmac .and. .not.lmac) CYCLE + WRITE (imon,1004) TRIM(extension), iseq_count, time_slice + END DO + +1000 FORMAT('DATE = ',a3,' ',a2,',',a4,' ',' TIME = ',2(a2,':'),a2) +1001 FORMAT(' SEQ = ',i4,' TIME SLICE',1p,e12.4/ + & ' PROCESSING INPUT.',a) +1002 FORMAT(a,1x,a,/a,//,' COMPUTER: ',a,2x,' OS: ',a,2x, + & ' RELEASE: ',a,2x,a) +1003 FORMAT(1x,a,1x,a,/1x,a,//,' COMPUTER: ',a,2x,' OS: ',a,2x, + & ' RELEASE: ',a,2x,a) +1004 FORMAT(' SHOT ID.: ',a,2x,'SEQ. NO.:',i4,/, + & ' TIME SLICE = ',f5.0,' ms') + + END SUBROUTINE heading diff --git a/Sources/Initialization_Cleanup/init_geometry.f90 b/Sources/Initialization_Cleanup/init_geometry.f90 new file mode 100755 index 0000000..2f25ee5 --- /dev/null +++ b/Sources/Initialization_Cleanup/init_geometry.f90 @@ -0,0 +1,58 @@ + MODULE INIT_GEOMETRY + + LOGICAL :: lflip + + CONTAINS + + SUBROUTINE flip_theta(rmn, zmn, lmn) + USE vmec_main + USE vmec_params, ONLY: ntmax, rcc, rss, zsc, zcs, & + zcc, zss, rsc, rcs +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(0:ntor,0:mpol1,ntmax), & + INTENT(inout) :: rmn, zmn + REAL(rprec), DIMENSION(0:ntor,0:mpol1,ntmax), & + INTENT(inout), OPTIONAL :: lmn +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: n, m + REAL(rprec) :: mul1 + LOGICAL :: l_lmn +!----------------------------------------------- +! +! FLIP THETA -> PI - THETA (INITIALLY, TO MAKE JACOBIAN < 0) +! + mul1=-1 + l_lmn = PRESENT(lmn) + DO m=1,mpol1 + DO n=0,ntor + rmn(n,m,rcc) = mul1*rmn(n,m,rcc) + zmn(n,m,zsc) =-mul1*zmn(n,m,zsc) + IF (l_lmn) lmn(n,m,zsc) =-mul1*lmn(n,m,zsc) + IF (lthreed) THEN + rmn(n,m,rss) =-mul1*rmn(n,m,rss) + zmn(n,m,zcs) = mul1*zmn(n,m,zcs) + IF (l_lmn) lmn(n,m,zcs) = mul1*lmn(n,m,zcs) + END IF + IF (lasym) THEN + rmn(n,m,rsc) =-mul1*rmn(n,m,rsc) + zmn(n,m,zcc) = mul1*zmn(n,m,zcc) + IF (l_lmn) lmn(n,m,zcc) = mul1*lmn(n,m,zcc) + IF (lthreed) THEN + rmn(n,m,rcs) = mul1*rmn(n,m,rcs) + zmn(n,m,zss) =-mul1*zmn(n,m,zss) + IF (l_lmn) lmn(n,m,zss) =-mul1*lmn(n,m,zss) + END IF + END IF + END DO + + mul1 = -mul1 + + END DO + + END SUBROUTINE flip_theta + + END MODULE INIT_GEOMETRY diff --git a/Sources/Initialization_Cleanup/initialize_radial.f b/Sources/Initialization_Cleanup/initialize_radial.f new file mode 100644 index 0000000..af4e565 --- /dev/null +++ b/Sources/Initialization_Cleanup/initialize_radial.f @@ -0,0 +1,157 @@ + SUBROUTINE initialize_radial(nsval, ns_old, delt0, + 1 lscreen, reset_file_name) + USE vmec_main + USE vmec_params, ONLY: ntmax + USE realspace + USE xstuff +#ifdef _HBANGLE + USE angle_constraints, ONLY: getrz, store_init_array +#endif + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: nsval + INTEGER, INTENT(INOUT) :: ns_old + CHARACTER(LEN=*), OPTIONAL :: reset_file_name + REAL(dp), INTENT(OUT) :: delt0 + LOGICAL, INTENT(IN) :: lscreen +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: neqs_old = 0 + LOGICAL :: lreset_internal, linterp + INTEGER :: nsmin, nsmax, i, j, k, l, lk +C----------------------------------------------- +! +! Allocates memory for radial arrays and initializes radial profiles +! Loads data (if available) from a reset file +! +C----------------------------------------------- +! +! INDEX OF LOCAL VARIABLES +! +! hs radial mesh size increment +! irzloff offset in xc array between R,Z,L components +! neqs total number of equations to evolve (size of xc) +C----------------------------------------------- +! Set timestep control parameters + fsq = one + iter2 = 1 + iter1 = iter2 + ijacob = 0 + irst = 1 + res0 = -1 +! +! INITIALIZE MESH-DEPENDENT SCALARS +! + ns = nsval + ns1 = ns - 1 + delt0 = delt + hs = one/ns1 + ohs = one/hs + mns = ns*mnsize + irzloff = ntmax*mns + nrzt = nznt*ns + neqs = 3*irzloff + + + IF (grank .EQ. 0) THEN + WRITE (nthreed, 1000) ns, mnmax, ftolv, niter + IF (lscreen) THEN + PRINT 1000, ns, mnmax, ftolv, niter + END IF + IF (lactive) THEN + IF (lfreeb) THEN + WRITE(nthreed,1002) nranks, vnranks + IF (lscreen) PRINT 1002, nranks, vnranks + ELSE + WRITE (nthreed, 1001) nranks + IF (lscreen) PRINT 1001, nranks + END IF + END IF + END IF + +! +! ALLOCATE NS-DEPENDENT ARRAYS +! + lreset_internal = .true. + linterp = (ns_old .LT. ns .AND. ns_old .NE. 0) + IF (ns_old .EQ. ns) RETURN + CALL allocate_ns(linterp, neqs_old) +! +! SAVE THIS FOR INTERPOLATION +! + IF (neqs_old.gt.0 .and. linterp) THEN +#ifdef _HBANGLE + ns = ns_old + CALL getrz(xstore) + ns = ns1 + 1 +#endif + IF (PARVMEC) THEN +#if defined(MPI_OPT) + pgc(1:neqs_old) = pscalxc(1:neqs_old)*pxstore(1:neqs_old) + IF (lfreeb) THEN + CALL MPI_Bcast(rbsq, SIZE(rbsq), MPI_REAL8, + & 0, NS_COMM, MPI_ERR) + END IF +#endif + ELSE + gc(1:neqs_old) = scalxc(1:neqs_old)*xstore(1:neqs_old) + END IF + END IF + +! +! COMPUTE INITIAL R, Z AND MAGNETIC FLUX PROFILES +! + + IF (PARVMEC) THEN + CALL profil1d_par(pxc, pxcdot, lreset_internal) + ELSE + CALL profil1d(xc, xcdot, lreset_internal) + END IF + IF (PRESENT(reset_file_name)) THEN + IF (LEN_TRIM(reset_file_name) .ne. 0) THEN + CALL load_xc_from_wout(xc(1), xc(1+irzloff), + & xc(1+2*irzloff), lreset_internal, + & ntor, mpol1, ns, reset_file_name) + IF (PARVMEC) THEN + CALL Serial2Parallel4X(xc,pxc) + END IF + END IF + END IF + + IF (PARVMEC) THEN + CALL profil3d_par(pxc(1), pxc(1+irzloff), lreset_internal, + & linterp) + ELSE + CALL profil3d(xc(1), xc(1+irzloff), lreset_internal, linterp) + END IF +! +! INTERPOLATE FROM COARSE (ns_old) TO NEXT FINER (ns) RADIAL GRID +! + IF (linterp) THEN + IF(PARVMEC) THEN + CALL interp_par(pxc, pgc, pscalxc, ns, ns_old) + ELSE + CALL interp(xc, gc, scalxc, ns, ns_old) + END IF +#ifdef _HBANGLE + CALL store_init_array(xc) +#endif + END IF + +!SPH 012417: move this AFTER interpolation call + irst = 1 + CALL restart_iter(delt) + + ns_old = ns + neqs_old = neqs + +1000 FORMAT(/' NS = ',i4,' NO. FOURIER MODES = ',i4,' FTOLV = ', + & 1p,e10.3,' NITER = ',i6) +1001 FORMAT(' PROCESSOR COUNT - RADIAL: ',i4) +1002 FORMAT(' PROCESSOR COUNT - RADIAL: ',i4,' VACUUM: ',i4) + + END SUBROUTINE initialize_radial diff --git a/Sources/Initialization_Cleanup/load_xc_from_wout.f b/Sources/Initialization_Cleanup/load_xc_from_wout.f new file mode 100644 index 0000000..5d59aaa --- /dev/null +++ b/Sources/Initialization_Cleanup/load_xc_from_wout.f @@ -0,0 +1,146 @@ + SUBROUTINE load_xc_from_wout(rmn, zmn, lmn, lreset, + 1 ntor_in, mpol1_in, ns_in, reset_file) + USE read_wout_mod, ONLY: rmnc, zmns, lmns, rmns, zmnc, lmnc, + 1 xm, xn, ntor, ns, + 2 nfp, mnmax, read_wout_file, read_wout_deallocate + USE vmec_params, ONLY: mscale, nscale, ntmax, + 1 rcc, rss, rsc, rcs, zsc, zcs, zcc, zss + USE vmec_dim, ONLY: mpol1 + USE vparams, ONLY: one, zero, rprec + USE vmec_input, ONLY: lasym + USE vmec_main, ONLY: lthreed, p5 => cp5, sp, sm, phipf + USE parallel_include_module, ONLY: rank + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: ns_in, mpol1_in, ntor_in + REAL(rprec), DIMENSION(ns_in,0:ntor_in,0:mpol1_in,ntmax), + 1 INTENT(out) :: rmn, zmn, lmn + LOGICAL, INTENT(out) :: lreset + CHARACTER(LEN=*) :: reset_file +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ierr, mn, m, n, n1, js + REAL(rprec) :: t1, t2 + REAL(rprec), ALLOCATABLE :: temp(:,:) +C----------------------------------------------- + +! +! THIS ALLOWS SEQUENTIAL RUNNING OF VMEC FROM THE COMMAND LINE +! i.e., WHEN VMEC INTERNAL ARRAYS ARE NOT KEPT IN MEMORY (compared to sequence file input) +! THIS IS THE CASE WHEN VMEC IS CALLED FROM, SAY, THE OPTIMIZATION CODE +! +! SPH 12-13-11: allow for paths in wout file name (as per Ed Lazarus request) + CALL read_wout_file (reset_file, ierr) +! CALL read_wout_file (reset_file(5:), ierr) + reset_file = " " !nullify so this routine will not be recalled with present reset_file + + IF (ierr .ne. 0.AND.rank.EQ.0) THEN + PRINT *,' Error opening/reading wout file in VMEC load_xc!' + RETURN + END IF + + IF (ns_in .ne. ns.AND.rank.EQ.0) THEN + PRINT *, 'ns_in (passed to load_xc) != ns (from reading wout)' + RETURN + END IF + + IF (ntor_in .ne. ntor ) STOP 'ntor_in != ntor in load_xc' + IF (mpol1_in .ne. mpol1) STOP 'mpol1_in != mpol1 in load_xc' + IF (nfp .eq. 0) STOP 'nfp = 0 in load_xc' + + lreset = .false. !Signals profil3d NOT to overwrite axis values + + rmn = zero + zmn = zero + lmn = zero + + DO mn = 1, mnmax + m = NINT(xm(mn)) + n = NINT(xn(mn))/nfp + n1 = ABS(n) + t1 = one/(mscale(m)*nscale(n1)) + t2 = t1 + IF (n .lt. 0) t2 = -t2 + IF (n .eq. 0) t2 = zero + rmn(:ns,n1,m,rcc) = rmn(:ns,n1,m,rcc) + t1*rmnc(mn,:ns) + zmn(:ns,n1,m,zsc) = zmn(:ns,n1,m,zsc) + t1*zmns(mn,:ns) + lmn(:ns,n1,m,zsc) = lmn(:ns,n1,m,zsc) + t1*lmns(mn,:ns) + IF (lthreed) THEN + rmn(:ns,n1,m,rss) = rmn(:ns,n1,m,rss) + t2*rmnc(mn,:ns) + zmn(:ns,n1,m,zcs) = zmn(:ns,n1,m,zcs) - t2*zmns(mn,:ns) + lmn(:ns,n1,m,zcs) = lmn(:ns,n1,m,zcs) - t2*lmns(mn,:ns) + END IF + IF (lasym) THEN + rmn(:ns,n1,m,rsc) = rmn(:ns,n1,m,rsc) + t1*rmns(mn,:ns) + zmn(:ns,n1,m,zcc) = zmn(:ns,n1,m,zcc) + t1*zmnc(mn,:ns) + lmn(:ns,n1,m,zcc) = lmn(:ns,n1,m,zcc) + t1*lmnc(mn,:ns) + IF (lthreed) THEN + rmn(:ns,n1,m,rcs) = rmn(:ns,n1,m,rcs) - t2*rmns(mn,:ns) + zmn(:ns,n1,m,zss) = zmn(:ns,n1,m,zss) + t2*zmnc(mn,:ns) + lmn(:ns,n1,m,zss) = lmn(:ns,n1,m,zss) + t2*lmnc(mn,:ns) + END IF + END IF + IF (m .eq. 0) THEN + zmn(:ns,n1,m,zsc) = zero + lmn(:ns,n1,m,zsc) = zero + IF (lthreed) rmn(:ns,n1,m,rss) = zero + IF (lasym) THEN + rmn(:ns,n1,m,rsc) = zero + IF (lthreed) THEN + zmn(:ns,n1,m,zss) = zero + lmn(:ns,n1,m,zss) = zero + END IF + END IF + END IF + END DO + +! +! CONVERT TO INTERNAL FORM FOR (CONSTRAINED) m=1 MODES +! + + IF (lthreed .or. lasym) ALLOCATE (temp(ns_in,0:ntor_in)) + IF (lthreed) THEN + temp = rmn(:,:,1,rss) + rmn(:,:,1,rss) = p5*(temp + zmn(:,:,1,zcs)) + zmn(:,:,1,zcs) = p5*(temp - zmn(:,:,1,zcs)) + END IF + IF (lasym) THEN + temp = rmn(:,:,1,rsc) + rmn(:,:,1,rsc) = p5*(temp + zmn(:,:,1,zcc)) + zmn(:,:,1,zcc) = p5*(temp - zmn(:,:,1,zcc)) + END IF + + IF (ALLOCATED(temp)) DEALLOCATE (temp) + +! +! CONVERT lambda TO INTERNAL FULL MESH REPRESENTATION +! +! START ITERATION AT JS=1 +! + lmn(1,:,0,:) = lmn(2,:,0,:) + lmn(1,:,1,:) = 2*lmn(2,:,1,:)/(sm(2) + sp(1)) + lmn(1,:,2:,:) = 0 + + DO m = 0, mpol1, 2 + DO js = 2, ns + lmn(js,:,m,:) = 2*lmn(js,:,m,:) - lmn(js-1,:,m,:) + END DO + END DO + + DO m = 1, mpol1, 2 + DO js = 2, ns + lmn(js,:,m,:) = (2*lmn(js,:,m,:) + 1 - sp(js-1)*lmn(js-1,:,m,:))/sm(js) + END DO + END DO + + DO js = 2, ns + lmn(js,:,:,:) = phipf(js)*lmn(js,:,:,:) + END DO + + CALL read_wout_deallocate + + END SUBROUTINE load_xc_from_wout diff --git a/Sources/Initialization_Cleanup/magnetic_fluxes.f b/Sources/Initialization_Cleanup/magnetic_fluxes.f new file mode 100644 index 0000000..aeebbfd --- /dev/null +++ b/Sources/Initialization_Cleanup/magnetic_fluxes.f @@ -0,0 +1,103 @@ + FUNCTION torflux_deriv (x) + USE stel_kinds + USE vmec_main, ONLY: zero + USE vmec_input, ONLY: lRFP, tf => aphi +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), INTENT(IN) :: x + REAL(rprec) :: torflux_deriv + REAL(rprec), EXTERNAL :: polflux_deriv, piota + INTEGER :: i +C----------------------------------------------- +! x: radial flux variable (=TOROIDAL FLUX ONLY IF APHI=1) + + IF (lRFP) THEN +! RFP/TOKAMAK + IF (piota(x) .eq. zero) STOP 'piota(x) = 0!' + torflux_deriv = polflux_deriv(x)/piota(x) + + ELSE +! TOKAMAK/STELLARATOR (default is tf(1) = 1) + torflux_deriv = 0 + DO i = UBOUND(tf,1), LBOUND(tf,1), -1 + torflux_deriv = x*torflux_deriv + i*tf(i) + END DO +! torflux_deriv = 1 + END IF + + END FUNCTION torflux_deriv + + FUNCTION polflux_deriv (x) + USE stel_kinds + USE vmec_input, ONLY: lRFP +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), INTENT(IN) :: x + REAL(rprec) :: tf, polflux_deriv + REAL(rprec), EXTERNAL :: torflux, torflux_deriv, piota +C----------------------------------------------- +! x: radial flux variable (=TOROIDAL FLUX ONLY IF APHI=1) +! polflux_deriv == d(chi)/dx = iota(TF(x)) * torflux_deriv(x) + + IF (lRFP) THEN +! RFP/TOKAMAK + polflux_deriv = 1 + + ELSE +! TOKAMAK/STELLARATOR: dchi/ds = iota * dphi/ds +! piota is assumed to be a function of the TF(x) on input + tf = torflux(x) + tf = MIN(tf, 1.0_dp) + polflux_deriv = piota(tf)*torflux_deriv(x) +! polflux_deriv = piota(x)*torflux_deriv(x) + END IF + + END FUNCTION polflux_deriv + + FUNCTION torflux (x) + USE stel_kinds +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), INTENT(IN) :: x + REAL(rprec) :: torflux, h, xi + REAL(rprec), EXTERNAL :: torflux_deriv + INTEGER :: i +C----------------------------------------------- +! x: radial flux variable (=TOROIDAL FLUX ONLY IF APHI=1) + h = 1.E-2_dp*x + torflux = 0 + DO i=1,101 + xi = (i-1)*h + torflux = torflux + torflux_deriv(xi) + END DO + torflux = torflux-0.5_dp*(torflux_deriv(0._dp)+torflux_deriv(x)) + torflux = h*torflux + + END FUNCTION torflux + + FUNCTION polflux (x) + USE stel_kinds +! USE vmec_input, ONLY: af => achi +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), INTENT(IN) :: x + REAL(rprec) :: polflux, h, xi + REAL(rprec), EXTERNAL :: polflux_deriv + INTEGER :: i +C----------------------------------------------- + h = 1.E-2_dp*x + polflux = 0 + DO i=1,101 + xi = (i-1)*h + polflux = polflux + polflux_deriv(xi) + END DO + polflux = polflux-0.5_dp*(polflux_deriv(0._dp)+polflux_deriv(x)) + polflux = h*polflux + + END FUNCTION polflux + +! function piota moved to a separate file, piota.f. J Hanson, 2010-03-16 diff --git a/Sources/Initialization_Cleanup/open_output_files.f b/Sources/Initialization_Cleanup/open_output_files.f new file mode 100644 index 0000000..c677542 --- /dev/null +++ b/Sources/Initialization_Cleanup/open_output_files.f @@ -0,0 +1,57 @@ + SUBROUTINE open_output_files (extension, iseq, lmac, lscreen, + 1 lfirst, lwrite) + USE safe_open_mod + USE vparams, ONLY: nmac, nthreed, nmac0, nthreed0 + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: iseq + CHARACTER(LEN=*) :: extension + LOGICAL :: lmac, lscreen, lfirst, lwrite +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: iread, inthreed=0, imac0=0 + CHARACTER(LEN=120) :: mac_file, threed1_file +C----------------------------------------------- +! +! OPEN FILES FOR READING, WRITING +! + threed1_file = 'threed1.'//extension + mac_file = 'mac.'//extension + +! PRINT *,'lwrite: ', lwrite,' Threed1 file: ', TRIM(threed1_file) + + IF (lwrite) THEN + INQUIRE(FILE=threed1_file, OPENED=lfirst) +! PRINT *,' lfirst: ', lfirst + lfirst = .not.lfirst + IF (.NOT.lfirst) RETURN + + IF (lscreen) WRITE (*, '(33('' -''))') + nthreed = nthreed0 + CALL safe_open(nthreed, iread, threed1_file, 'new', + 1 'formatted') + IF (iread .ne. 0) THEN + IF (iseq .eq. 0 .and. lscreen) PRINT *, + 1 ' VMEC OUTPUT FILES ALREADY EXIST: OVERWRITING THEM ...' + CALL safe_open(nthreed, inthreed, threed1_file, + 1 'replace', 'formatted') + ENDIF + + nmac = MAX(nmac0, nthreed) + IF (lmac) THEN + CALL safe_open(nmac, imac0, mac_file, 'replace', + 1 'formatted') + END IF + IF (inthreed.ne.0 .or. imac0.ne.0) THEN + PRINT *,' nthreed = ', nthreed, ' istat_threed = ', + 1 inthreed, ' nmac0 = ', nmac,' istat_mac0 = ', imac0 + PRINT *, 'Error opening output file in VMEC ', + 1 'open_output_files' + STOP 10 + ENDIF + ENDIF + + END SUBROUTINE open_output_files diff --git a/Sources/Initialization_Cleanup/profil1d.f b/Sources/Initialization_Cleanup/profil1d.f new file mode 100644 index 0000000..9f39ece --- /dev/null +++ b/Sources/Initialization_Cleanup/profil1d.f @@ -0,0 +1,414 @@ + SUBROUTINE profil1d_par(xc, xcdot, lreset) + USE vmec_main + USE vmec_params, ONLY: signgs, lamscale, rcc, pdamp + USE vmec_input, ONLY: lRFP + USE vspline + USE init_geometry, ONLY: lflip + USE vmec_input, ONLY: nzeta + USE vmec_dim, ONLY: ns, ntheta3 + USE realspace + USE vmec_params, ONLY: ntmax + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,3*ntmax), INTENT(OUT) :: + 1 xc, xcdot + LOGICAL, INTENT(IN) :: lreset + +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: c1p5 = 1.5_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i + REAL(dp) :: Itor, si, tf, pedge, vpnorm, polflux_edge + REAL(dp) :: phipslocal, phipstotal + INTEGER :: j, k, l, nsmin, nsmax + REAL (dp) :: torflux_edge +C----------------------------------------------- +C E x t e r n a l F u n c t i o n s +C----------------------------------------------- + REAL(dp), EXTERNAL :: pcurr, pmass, piota, torflux, + 1 torflux_deriv, polflux, polflux_deriv +#ifdef _ANIMEC + 2 , photp, ptrat +#endif +C----------------------------------------------- +! +! INDEX OF LOCAL VARIABLES +! +! ai array of coefficients in phi-series for iota (ncurr=0) +! ac array of coefficients in phi-series for the quantity d(Icurv)/ds = toroidal +! current density * Vprime, so Icurv(s) = Itor(s) (used for ncurr=1) +! am array of coefficients in phi-series for mass (NWT/m**2) +! iotas rotational transform , on half radial mesh +! Icurv (-)toroidal current inside flux surface (vanishes like s) +! mass mass profile on half-grid +! phiedge value of real toroidal flux at plasma edge (s=1) +! phips toroidal flux (same as phip), one-dimensional array +! chips poloidal flux (same as chip), one-dimensional array +! presf pressure profile on full-grid, mass/phip**gamma +! spres_ped value of s beyond which pressure profile is flat (pedestal) + +! +! COMPUTE PHIP, IOTA PROFILES ON FULL-GRID +! COMPUTE MASS PROFILE ON HALF-GRID +! BY READING INPUT COEFFICIENTS. PRESSURE CONVERTED TO +! INTERNAL UNITS BY MULTIPLICATION BY mu0 = 4*pi*10**-7 +! + + IF (ncurr.EQ.1 .AND. lRFP) THEN + STOP 'ncurr=1 inconsistent with lRFP=T!' + END IF + torflux_edge = signgs*phiedge/twopi + si = torflux(one) + IF (si .ne. zero) THEN + torflux_edge = torflux_edge/si + END IF + polflux_edge = torflux_edge + si = polflux(one) + IF (si .ne. zero) THEN + polflux_edge = polflux_edge/si + END IF + r00 = rmn_bdy(0,0,rcc) + + phips(1) = 0 + chips(1) = 0 + icurv(1) = 0 + + nsmin = MAX(2, t1lglob) + nsmax = t1rglob + DO i = nsmin, nsmax + si = hs*(i - c1p5) + tf = MIN(one, torflux(si)) + IF (lRFP) THEN + tf = si + END IF + phips(i) = torflux_edge*torflux_deriv(si) + chips(i) = torflux_edge*polflux_deriv(si) + iotas(i) = piota(tf) + icurv(i) = pcurr(tf) + END DO + +! +! Compute lamscale factor for "normalizing" lambda (needed for scaling hessian) +! DO IT THIS WAY (rather than ALLREDUCE) FOR PROCESSOR INDEPENDENCE +! + CALL Gather1XArray(phips) + phipstotal = SUM(phips(2:ns)**2) + lamscale = SQRT(hs*phipstotal) + + IF (lflip) THEN + iotas = -iotas + chips = -chips + END IF + + nsmin = t1lglob + nsmax = t1rglob + + DO i = nsmin, nsmax + si = hs*(i - 1) + tf = MIN(one, torflux(si)) + IF (lRFP) THEN + tf = si + END IF + iotaf(i) = piota(tf) + phipf(i) = torflux_edge*torflux_deriv(si) + chipf(i) = torflux_edge*polflux_deriv(si) + END DO +! +! SCALE CURRENT TO MATCH INPUT EDGE VALUE, CURTOR +! FACTOR OF SIGNGS NEEDED HERE, SINCE MATCH IS MADE TO LINE +! INTEGRAL OF BSUBU (IN GETIOTA) ~ SIGNGS * CURTOR +! + pedge = pcurr(one) + Itor = 0 + IF (ABS(pedge) .gt. ABS(EPSILON(pedge)*curtor)) THEN + Itor = signgs*currv/(twopi*pedge) + END IF + + nsmin = MAX(2, t1lglob) + nsmax = t1rglob + icurv(nsmin:nsmax) = Itor*icurv(nsmin:nsmax) + +! +! POSSIBLE PRESSURE PEDESTAL FOR S >= SPRES_PED +! + spres_ped = ABS(spres_ped) + IF (.not.lrecon) THEN + nsmin = MAX(2,t1lglob) + nsmax = t1rglob + DO i = nsmin, nsmax + si = hs*(i - c1p5) + +! NORMALIZE mass so dV/dPHI (or dV/dPSI) in pressure to mass relation +! See line 195 of bcovar: pres(2:ns) = mass(2:ns)/vp(2:ns)**gamma + + IF (lRFP) THEN + tf=si + vpnorm = polflux_edge*polflux_deriv(si) + ELSE + tf = MIN(one, torflux(si)) + vpnorm = torflux_edge*torflux_deriv(si) + END IF + IF (si .gt. spres_ped) THEN + pedge = pmass(spres_ped) + ELSE + pedge = pmass(tf) + END IF + mass(i) = pedge*(ABS(vpnorm)*r00)**gamma +#ifdef _ANIMEC +! ANISOTROPIC PRESSURE, Tper/T|| RATIOS + phot(i) = photp(tf) + tpotb(i) = ptrat(tf) +#endif + END DO + + ELSE + nsmin = t1lglob + nsmax = t1rglob + iotas(nsmin:nsmax) = 0 + iotaf(nsmin:nsmax) = 0 + mass (nsmin:nsmax) = 0 + presf(nsmin:nsmax) = 0 + END IF + + + nsmin = t1lglob + nsmax = MIN(t1rglob, ns + 1) + pres(nsmin:nsmax) = 0 + xcdot(:,:,nsmin:nsmax,:) = 0 + +#ifdef _ANIMEC + medge = pmass(one)*(ABS(phips(ns))*r00)**gamma + phedg = photp(one) +#endif + nsmin = MAX(1, t1lglob - 1) + nsmax = MIN(t1rglob + 1,ns) + DO i = nsmin, nsmax + si = hs*ABS(i - 1.5_dp) + pshalf(:,i) = SQRT(si) + si = hs*(i - 1) + psqrts(:,i) = SQRT(si) + bdamp(i) = 2*pdamp*(1 - si) + END DO + + psqrts(:,ns) = 1 !!Avoid round-off + + nsmin = MAX(2, t1lglob) + nsmax = t1rglob + DO i = nsmin, nsmax + sm(i) = pshalf(1,i)/psqrts(1,i) + IF (i .LT. ns) THEN + sp(i) = pshalf(1,i + 1)/psqrts(1,i) + ELSE + sp(i)=one/psqrts(1,i) + END IF + END DO + + + sm(1) = 0 + sp(0) = 0 + sp(1) = sm(2) + + IF (lreset) THEN + xc(:,:,t1lglob:t1rglob,:) = 0 + END IF + + END SUBROUTINE profil1d_par + + SUBROUTINE profil1d(xc, xcdot, lreset) + USE vmec_main + USE vmec_params, ONLY: signgs, lamscale, rcc, pdamp + USE vmec_input, ONLY: lRFP + USE vspline + USE realspace, ONLY: shalf, sqrts + USE init_geometry, ONLY: lflip + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(neqs), INTENT(out) :: xc, xcdot + LOGICAL, INTENT(IN) :: lreset +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: c1p5 = 1.5_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i + REAL(dp) :: Itor, si, tf, pedge, vpnorm, polflux_edge + REAL(dp) :: torflux_edge +C----------------------------------------------- +C E x t e r n a l F u n c t i o n s +C----------------------------------------------- + REAL(dp), EXTERNAL :: pcurr, pmass, piota, torflux, + 1 torflux_deriv, polflux, polflux_deriv +#ifdef _ANIMEC + 2 , photp, ptrat +#endif +C----------------------------------------------- +! +! INDEX OF LOCAL VARIABLES +! +! ai array of coefficients in phi-series for iota (ncurr=0) +! ac array of coefficients in phi-series for the quantity d(Icurv)/ds = toroidal +! current density * Vprime, so Icurv(s) = Itor(s) (used for ncurr=1) +! am array of coefficients in phi-series for mass (NWT/m**2) +! iotas rotational transform , on half radial mesh +! Icurv (-)toroidal current inside flux surface (vanishes like s) +! mass mass profile on half-grid +! phiedge value of real toroidal flux at plasma edge (s=1) +! phips toroidal flux (same as phip), one-dimensional array +! chips poloidal flux (same as chip), one-dimensional array +! presf pressure profile on full-grid, mass/phip**gamma +! spres_ped value of s beyond which pressure profile is flat (pedestal) + +! +! COMPUTE PHIP, IOTA PROFILES ON FULL-GRID +! COMPUTE MASS PROFILE ON HALF-GRID +! BY READING INPUT COEFFICIENTS. PRESSURE CONVERTED TO +! INTERNAL UNITS BY MULTIPLICATION BY mu0 = 4*pi*10**-7 +! + IF (ncurr.EQ.1 .AND. lRFP) THEN + STOP 'ncurr=1 inconsistent with lRFP=T!' + END IF + + torflux_edge = signgs*phiedge/twopi + si = torflux(one) + IF (si .ne. zero) THEN + torflux_edge = torflux_edge/si + END IF + polflux_edge = torflux_edge + si = polflux(one) + IF (si .ne. zero) THEN + polflux_edge = polflux_edge/si + END IF + r00 = rmn_bdy(0,0,rcc) + + phips(1) = 0 + chips(1) = 0 + icurv(1) = 0 + + DO i = 2, ns + si = hs*(i - c1p5) + tf = MIN(one, torflux(si)) + IF (lRFP) THEN + tf = si + END IF + phips(i) = torflux_edge*torflux_deriv(si) + chips(i) = torflux_edge*polflux_deriv(si) + iotas(i) = piota(tf) + icurv(i) = pcurr(tf) + END DO + +! +! Compute lamscale factor for "normalizing" lambda (needed for scaling hessian) +! + lamscale = SQRT(hs*SUM(phips(2:ns)**2)) + + IF (lflip) THEN + iotas = -iotas + chips = -chips + END IF + + DO i = 1,ns + si = hs*(i - 1) + tf = MIN(one, torflux(si)) + IF (lRFP) THEN + tf = si + END IF + iotaf(i) = piota(tf) + phipf(i) = torflux_edge*torflux_deriv(si) + chipf(i) = torflux_edge*polflux_deriv(si) + ENDDO +! +! SCALE CURRENT TO MATCH INPUT EDGE VALUE, CURTOR +! FACTOR OF SIGNGS NEEDED HERE, SINCE MATCH IS MADE TO LINE +! INTEGRAL OF BSUBU (IN GETIOTA) ~ SIGNGS * CURTOR +! + pedge = pcurr(one) + Itor = 0 + IF (ABS(pedge) .gt. ABS(EPSILON(pedge)*curtor)) THEN + Itor = signgs*currv/(twopi*pedge) + END IF + icurv(2:ns) = Itor*icurv(2:ns) + +! +! POSSIBLE PRESSURE PEDESTAL FOR S >= SPRES_PED +! + spres_ped = ABS(spres_ped) + IF (.not.lrecon) THEN + DO i = 2, ns + si = hs*(i - c1p5) + +! NORMALIZE mass so dV/dPHI (or dV/dPSI) in pressure to mass relation +! See line 195 of bcovar: pres(2:ns) = mass(2:ns)/vp(2:ns)**gamma + + IF (lRFP) THEN + tf = si + vpnorm = polflux_edge*polflux_deriv(si) + ELSE + tf = MIN(one, torflux(si)) + vpnorm = torflux_edge*torflux_deriv(si) + END IF + IF (si .gt. spres_ped) THEN + pedge = pmass(spres_ped) + ELSE + pedge = pmass(tf) + END IF + mass(i) = pedge*(ABS(vpnorm)*r00)**gamma +#ifdef _ANIMEC +! ANISOTROPIC PRESSURE, Tper/T|| RATIOS + phot(i) = photp(tf) + tpotb(i) = ptrat(tf) +#endif + END DO + + ELSE + iotas(:ns) = 0 + iotaf(:ns) = 0 + mass (:ns) = 0 + presf(:ns) = 0 + END IF + + pres(:ns + 1) = 0 + xcdot(:neqs) = 0 + +#ifdef _ANIMEC + medge = pmass(one)*(ABS(phips(ns))*r00)**gamma + phedg = photp(one) +#endif + DO i = 1, ns + si = hs*ABS(i - 1.5_dp) +! si = torflux(si) !SPH060409: shalf = sqrt(s), NOT sqrt(phi(s))! + shalf(i:nrzt:ns) = SQRT(si) + si = hs*(i - 1) + sqrts(i:nrzt:ns) = SQRT(si) + bdamp(i) = 2*pdamp*(1 - si) + END DO + + sqrts(ns:nrzt:ns) = 1 !!Avoid round-off + shalf(nrzt + 1) = 1 + sqrts(nrzt + 1) = 1 + + DO i = 2,ns + sm(i) = shalf(i)/sqrts(i) + sp(i) = shalf(i+1)/sqrts(i) + END DO + + sm(1) = 0 + sp(0) = 0 + sp(1) = sm(2) + + IF (lreset) THEN + xc(:neqs) = 0 + END IF + + END SUBROUTINE profil1d diff --git a/Sources/Initialization_Cleanup/profil3d.f b/Sources/Initialization_Cleanup/profil3d.f new file mode 100644 index 0000000..8ea6aa0 --- /dev/null +++ b/Sources/Initialization_Cleanup/profil3d.f @@ -0,0 +1,338 @@ + SUBROUTINE profil3d_par(rmn, zmn, lreset, linterp) + USE vmec_main + USE vmec_params + USE vspline, ONLY: sknots, pknots, hstark, hthom + USE realspace + USE xstuff +#ifdef _HBANGLE + USE angle_constraints, ONLY: store_init_array +#endif + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(0:ntor,0:mpol1,ns,ntmax), INTENT(inout) :: + & rmn, zmn + LOGICAL, INTENT(in) :: lreset, linterp + +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, l, lk, lt, lz, ntype, m, n, mn + REAL(dp), DIMENSION(0:ntor,ntmax) :: rold, zold + REAL(dp) :: sm0, t1, facj, si, rax1, zax1 + INTEGER :: jcount, jk, k + INTEGER :: i, j, nsmin, nsmax, lpar + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: bcast_buf + +!----------------------------------------------- +! INDEX OF LOCAL VARIABLES +! +! phip radial derivative of phi/(2*pi) on half-grid +! chip radial derivative of chi/(2*pi) on half-grid +! shalf sqrt(s) ,two-dimensional array on half-grid +! sqrts sqrt(s), two-dimensional array on full-grid +! wint two-dimensional array for normalizing angle integrations +! ireflect two-dimensional array for computing 2pi-v angle +!----------------------------------------------- +! CALL second0(tprofon) + + nsmin = t1lglob; nsmax = t1rglob + DO js = nsmin, nsmax + pphip(:,js) = phips(js) + pchip(:,js) = chips(js) + END DO + + faclam = 0 + sigma_an = 1 !INITIALIZE sigma FOR ANISOTROPIC PLASMA + pwint(:,1) = 0 + pfaclam(:,:,nsmin:nsmax,:)=0 +! +! COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym) +! + DO k = 1, nzeta + jk = nzeta + 2 - k + IF (k .eq. 1) THEN + jk = 1 + END IF + ireflect_par(k) = jk + END DO + + lk = 0 + DO lt = 1, ntheta3 + DO lz = 1, nzeta + lk = lk + 1 + pwint_ns(lk) = cosmui3(lt,0)/mscale(0) + DO js = MAX(2, t1lglob), t1rglob + pwint(lk,js) = pwint_ns(lk) + END DO + END DO + END DO + +! INDEX FOR u = -u (need for lasym integration in wrout) + lk = 0 + IF (.NOT.ALLOCATED(uminus)) THEN + ALLOCATE(uminus(nznt)) + END IF + DO lt = 1, ntheta2 + k = ntheta1 - lt + 2 + IF (lt .eq. 1) THEN + k = 1 !u=-0 => u=0 + END IF + DO lz = 1, nzeta + lk = lk + 1 + uminus(lk) = k !(-u), for u = 0,pi + END DO + END DO + +! +! COMPUTE INITIAL R AND Z FOURIER COEFFICIENTS, +! FROM SCALED BOUNDARY VALUES, AND SCALXC ARRAY +! (1/SQRTS FACTOR FOR ODD M VALUES) +! + + nsmin = t1lglob + nsmax = t1rglob + + rold(0:ntor,1:ntmax) = rmn(0:ntor,0,1,1:ntmax) + zold(0:ntor,1:ntmax) = zmn(0:ntor,0,1,1:ntmax) + + IF (nranks.GT.1) THEN + ALLOCATE(bcast_buf(0:2*ntor+1,1:ntmax)) + bcast_buf(0:ntor,1:ntmax) = rold(0:ntor,1:ntmax) + bcast_buf(ntor+1:2*ntor+1,1:ntmax) = zold(0:ntor,1:ntmax) + CALL MPI_Bcast(bcast_buf, 2*(ntor + 1)*ntmax, MPI_REAL8, 0, + & NS_COMM, MPI_ERR) + rold(0:ntor,1:ntmax) = bcast_buf(0:ntor,1:ntmax) + zold(0:ntor,1:ntmax) = bcast_buf(ntor+1:2*ntor+1,1:ntmax) + DEALLOCATE(bcast_buf) + END IF + + nsmin = t1lglob + nsmax = t1rglob + DO js = nsmin, nsmax + si = psqrts(1,js)*psqrts(1,js) + sm0 = one - si + DO ntype = 1, ntmax + DO m = 0, mpol1 + DO n = 0, ntor + t1 = one/(mscale(m)*nscale(n)) + mn = n + ntor1*m + lpar = mn+mnsize*(js - 1) + (ntype - 1)*mns + 1 + IF (MOD(m,2) .eq. 0) THEN + pscalxc(lpar) = one + ELSE + pscalxc(lpar) = one/psqrts(1,MAX(2,js)) + END IF + + pscalxc(lpar+irzloff)=pscalxc(lpar) + pscalxc(lpar+2*irzloff)=pscalxc(lpar) + +! Do not overwrite r,z if read in from wout file AND in free bdy mode +! For fixed boundary, edge values MAY have been perturbed, so must execute this loop + IF (.not.lreset .and. lfreeb) CYCLE + IF (m .eq. 0) THEN + IF (.not.lreset) CYCLE !Freeze axis if read in from wout file + + rmn(n,m,js,ntype) = rmn(n,m,js,ntype) + & + si*(rmn_bdy(n,m,ntype)*t1 - + & rmn(n,m,ns,ntype)) + zmn(n,m,js,ntype) = zmn(n,m,js,ntype) + & + si*(zmn_bdy(n,m,ntype)*t1 - + & zmn(n,m,ns,ntype)) + + IF (ntype .eq. rcc) rax1 = raxis_cc(n) + IF (ntype .eq. zcs) zax1 =-zaxis_cs(n) + IF (ntype .eq. rcs) rax1 =-raxis_cs(n) + IF (ntype .eq. zcc) zax1 = zaxis_cc(n) + + IF (ntype.eq.rcc .or. ntype.eq.rcs) THEN + rmn(n,m,js,ntype) = rmn(n,m,js,ntype) + & + sm0*(rax1*t1 - + & rold(n,ntype)) + END IF + IF (ntype.eq.zcs .or. ntype.eq.zcc) THEN + zmn(n,m,js,ntype) = zmn(n,m,js,ntype) + & + sm0*(zax1*t1 - + & zold(n,ntype)) + END IF + ELSE + facj = psqrts(1,js)**m !!TURN OFF NEXT 3 LINES IF THIS ONE ACTIVATED + rmn(n,m,js,ntype) = rmn(n,m,js,ntype) + & + (rmn_bdy(n,m,ntype)*t1 - + & rmn(n,m,ns,ntype))*facj + zmn(n,m,js,ntype) = zmn(n,m,js,ntype) + & + (zmn_bdy(n,m,ntype)*t1 - + & zmn(n,m,ns,ntype))*facj + END IF + END DO + END DO + END DO + END DO + +#ifdef _HBANGLE + IF (.NOT.linterp) THEN + CALL store_init_array(xc) + END IF +#endif + + END SUBROUTINE profil3d_par + + SUBROUTINE profil3d(rmn, zmn, lreset, linterp) + USE vmec_main + USE vmec_params + USE vspline, ONLY: sknots, pknots, hstark, hthom + USE realspace + USE xstuff +#ifdef _HBANGLE + USE angle_constraints, ONLY: store_init_array +#endif + + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,ntmax), INTENT(inout) :: + & rmn, zmn + LOGICAL, INTENT(in) :: lreset, linterp +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: js, l, lk, lt, lz, ntype, m, n, mn + REAL(dp), DIMENSION(0:ntor,ntmax) :: rold, zold + REAL(dp) :: sm0, t1, facj, si, rax1, zax1 + INTEGER :: jcount, jk, k + +!----------------------------------------------- + +! +! INDEX OF LOCAL VARIABLES +! +! phip radial derivative of phi/(2*pi) on half-grid +! chip radial derivative of chi/(2*pi) on half-grid +! shalf sqrt(s) ,two-dimensional array on half-grid +! sqrts sqrt(s), two-dimensional array on full-grid +! wint two-dimensional array for normalizing angle integrations +! ireflect two-dimensional array for computing 2pi-v angle + + DO js = 1, ns + phip(js:nrzt:ns) = phips(js) + chip(js:nrzt:ns) = chips(js) + END DO + + phip(nrzt + 1) = 0 + faclam = 0 + sigma_an = 1 !INITIALIZE sigma FOR ANISOTROPIC PLASMA + wint(1:nrzt:ns) = 0 + + lk = 0 + DO lt = 1, ntheta3 + DO lz = 1, nzeta + lk = lk + 1 + DO js = 2,ns + wint(js+ns*(lk-1)) = cosmui3(lt,0)/mscale(0) + END DO + END DO + END DO + +! +! COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym) +! + jcount = 0 + DO k = 1, nzeta + jk = nzeta + 2 - k + IF (k .eq. 1) jk = 1 + DO js = 1, ns + jcount = jcount+1 + ireflect(jcount) = js + ns*(jk - 1) !Index for -zeta[k] + END DO + END DO + +! INDEX FOR u = -u (need for lasym integration in wrout) + lk = 0 + IF (.NOT.ALLOCATED(uminus)) THEN + ALLOCATE (uminus(nznt)) + END IF + DO lt = 1, ntheta2 + k = ntheta1 - lt + 2 + IF (lt .eq. 1) THEN + k = 1 !u=-0 => u=0 + END IF + DO lz = 1, nzeta + lk = lk + 1 + uminus(lk) = k !(-u), for u = 0,pi + END DO + END DO + +! +! COMPUTE INITIAL R AND Z FOURIER COEFFICIENTS, +! FROM SCALED BOUNDARY VALUES, AND SCALXC ARRAY +! (1/SQRTS FACTOR FOR ODD M VALUES) +! + + DO js = 1, ns + si = sqrts(js)*sqrts(js) + sm0 = one - si + DO ntype = 1, ntmax + DO m = 0, mpol1 + DO n = 0, ntor + t1 = one/(mscale(m)*nscale(n)) + mn = n + ntor1*m + l = js + ns*mn + (ntype - 1)*mns + IF (MOD(m,2) .eq. 0) THEN + scalxc(l) = one + ELSE + scalxc(l) = one/MAX(sqrts(js),sqrts(2)) + END IF +! Do not overwrite r,z if read in from wout file AND in free bdy mode +! For fixed boundary, edge values MAY have been perturbed, so must execute this loop + IF (.not.lreset .and. lfreeb) CYCLE + IF (m .eq. 0) THEN + IF (.not.lreset) CYCLE !Freeze axis if read in from wout file + rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + & + si*(rmn_bdy(n,m,ntype)*t1 - + & rmn(ns,n,m,ntype)) + zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + & + si*(zmn_bdy(n,m,ntype)*t1 - + & zmn(ns,n,m,ntype)) + IF (js .eq. 1) THEN + rold(n,ntype) = rmn(1,n,0,ntype) + zold(n,ntype) = zmn(1,n,0,ntype) + END IF + IF (ntype .eq. rcc) rax1 = raxis_cc(n) + IF (ntype .eq. zcs) zax1 =-zaxis_cs(n) + IF (ntype .eq. rcs) rax1 =-raxis_cs(n) + IF (ntype .eq. zcc) zax1 = zaxis_cc(n) + IF (ntype.eq.rcc .or. ntype.eq.rcs) THEN + rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + & + sm0*(rax1*t1 - + & rold(n,ntype)) + END IF + IF (ntype.eq.zcs .or. ntype.eq.zcc) THEN + zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + & + sm0*(zax1*t1 - + & zold(n,ntype)) + END IF + ELSE + facj = sqrts(js)**m !!TURN OFF NEXT 3 LINES IF THIS ONE ACTIVATED + rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + & + (rmn_bdy(n,m,ntype)*t1 - + & rmn(ns,n,m,ntype))*facj + zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + & + (zmn_bdy(n,m,ntype)*t1 - + & zmn(ns,n,m,ntype))*facj + END IF + END DO + END DO + END DO + END DO + + scalxc(1+irzloff:2*irzloff) = scalxc(:irzloff) !Z-components + scalxc(1+2*irzloff:3*irzloff) = scalxc(:irzloff) !Lamda-components + +#ifdef _HBANGLE + IF (.NOT.linterp) CALL store_init_array(xc) +#endif + + END SUBROUTINE profil3d diff --git a/Sources/Initialization_Cleanup/profile_functions.f b/Sources/Initialization_Cleanup/profile_functions.f new file mode 100644 index 0000000..329c7cc --- /dev/null +++ b/Sources/Initialization_Cleanup/profile_functions.f @@ -0,0 +1,906 @@ +! File profile_functions.f contains +! FUNCTION pcurr +! FUNCTION piota +! FUNCTION pmass +! (JDH 2010-03-30) +!****************************************************************************** + + FUNCTION pcurr (xx) +! Function to compute the current profile + +! Variables declared in vmec_input: +! ac array (0:20) of coefficients +! ac_aux_s Auxiliary array s, s-values used for splines +! ac_aux_f Auxiliary array f, function-values used for splines +! bloat used to expand the current profile +! pcurr_type character, specifies the parameterization of the profile +! | - X for parametrization of I-prime(s), _ for I(s) +! sum_cossq_s X Sum of cos**2-waves - I-prime +! sum_cossq_sqrts X Sum of cos**2-waves with respect to sqrt(s) - I-prime +! sum_cossq_s_free X Sum of cos**2-waves up to 7, free position and width - I-prime +! gauss_trunc X Truncated Gaussian - I-prime +! two_power X Two powers - ac(0) * (1 - s ** ac(1)) ** ac(2) +! two_power_gs X Two powers with gaussian peaks - +! ac(0) * ((1 - s ** ac(1)) ** ac(2))*(1 + Sum[ac(i)*Exp(-(s - ac(i+1))/ac(i+2)) ** 2]) +! sum_atan _ sum of arctangents +! power_series_I _ Power series for I(s) (NOT default) +! Akima_spline_Ip X Akima spline for I-prime(s) +! Akima_spline_I _ Akima spline for I(s) +! cubic_spline_Ip X cubic spline for I-prime(s) +! cubic_spline_I _ cubic spline for I(s) +! pedestal _ Pedestal profile +! rational _ Rational function (ratio of polynomials) +! line_segment_Ip X Line segments for I-prime(s) +! line_segment_I _ Line segments for I(s) +! power_series X Power Series for I-prime(s) (Default) + +! Local Variables +! i integer counter +! ioff offset for ac array. Should be zero +! iflag error flag for spline call +! xx real argument +! x constrained to be between 0 and 1 +! xp variable for Gauss_legendre quadrature +! pcurr_type_lc character, pcurr_type -> lower case +! gli index for Gauss-Legendre quadrature loop +! gln order of Gauss-Legendre quadrature +! glx array of abscissa values for Gauss-Legendre quadrature +! glw array of wieghts for Gauss-Legendre quadrature + +! Note that the profile that is parameterized is often I-prime, whereas +! I(x) (= Integral_from_0_to_x I-prime(s) ds) is the function that pcurr +! returns. For the default case of a power series, the integral can be +! computed analytically. For other cases, a numerical quadrature is done, +! using a 10-point Gauss-Legendre quadrature. + USE stel_kinds + USE stel_constants, ONLY: zero, one, pi + USE vmec_input, ONLY: ac, bloat, pcurr_type, ac_aux_s, ac_aux_f + USE line_segment + USE functions + IMPLICIT NONE +! ac assumed to be dimensioned (0:n), with n >= 20 +!----------------------------------------------- + INTEGER :: i, ioff, iflag + REAL(rprec) :: xx, pcurr, x, xp, temp_num, temp_denom + CHARACTER(len=20) :: pcurr_type_lc + + INTEGER, PARAMETER :: gln = 10 + INTEGER :: gli + REAL(rprec), DIMENSION(gln), PARAMETER :: glx = (/ & + & 0.01304673574141414, 0.06746831665550774, 0.1602952158504878, & + & 0.2833023029353764, 0.4255628305091844, 0.5744371694908156, & + & 0.7166976970646236, 0.8397047841495122, 0.9325316833444923, & + & 0.9869532642585859 /) + REAL(rprec), DIMENSION(gln), PARAMETER :: glw = (/ & + & 0.03333567215434407, 0.0747256745752903, 0.1095431812579910, & + & 0.1346333596549982, 0.1477621123573764, 0.1477621123573764, & + & 0.1346333596549982, 0.1095431812579910, 0.0747256745752903, & + & 0.03333567215434407 /) + REAL(rprec) :: g1,g2,g3,g4,a8,a12 + REAL(rprec), dimension(21) :: xi, bsta, bend, wd + REAL(rprec) :: sqx,delx,delxsq,pisq + INTEGER :: ni + INTEGER :: ncssq + +!----------------------------------------------- +! +! NOTE: AC COEFFICIENTS OBTAINED IN THREED1 FILE +! BY MATCHING TO * dV/dPHI ~ SUM[x^(i+1) * ac(i)/(i+1)], i=0...UBOUND(ac) +! +! Start of executable code + + x = MIN (ABS(xx * bloat), one) + ioff = LBOUND(ac,1) ! Expected to be zero. + + pcurr = 0 + +! Convert to Lower Case, to avoid typo issues + pcurr_type_lc = pcurr_type + CALL tolower(pcurr_type_lc) + SELECT CASE(TRIM(pcurr_type_lc)) + + CASE ('sum_cossq_s') +! 20180218, Joachim Geiger +! The idea was to use the combination of cos**2-waves located at +! different radial locations to build up a current density in a +! hopefully quite flexible way. Since the current is needed, the +! integration is done analytically. +! Sum of ncssq cos**2 terms put at different radial locations +! and with a windowing around the maxima as current density: +! ac(0) holds ncssq +! ac(1)*(H(x)-H(x-dx))*(cos(pi*(x-xi(1))/(2*dx))**2 +! +ac(2)*(H(x-(xi(2)-dx))-H(x-(xi(2)+dx)))*cos(pi*(x-xi(2))/(2*dx))**2 +! + ... +! +ac(ncssq)*(H(x-(xi(ncssq)-dx))-H(x-(xi(ncssq))))*cos(pi*(x-xi(ncssq))/(2*dx))**2 +! windowing is done with the Heavyside-functions producing the +! Boxcar Function: H(x-a)-H(x-b) is, for a azmn_o !gsqrt +! r12 => armn_o; bphi => czmn_o +! bsupu => crmn_e +! bsupv => czmn_e + + js = 3*ns/4 +! js = 2 !!Check this: not working as well as it should at js=2, js>=3 is EXCELLENT!!! + si = hs*(js-1.5_dp) + + IF (ls_mesh) THEN + WRITE(33,'(3a)') + 1 ' L sflx-del uflx-del br1/2 bphi1/2 bz1/2', + 2 ' brf-wout bphif-wout bzf-wout brf-vmec bphif-vmec', + 3 ' bzf-vmec' + END IF + + DO k = 1, nzeta + vi = (twopi*(k-1))/nzeta + DO j = 1, ntheta3 + ui = (twopi*(j-1))/ntheta1 + l = js + ns*(k-1 + nzeta*(j-1)) + + IF (ls_mesh) THEN + + rfull = r1(l,0) + sqrts(l)*r1(l,1) + zfull = z1(l,0) + sqrts(l)*z1(l,1) +! +! TEST WOUT-BASED VERSION +! + CALL GetBcyl(rfull, vi/nfp, zfull, br1f, bphi1f, bz1f, + 1 sflx, uflx, istat) + IF (istat .ne. 0) PRINT *,' WOUT-BASED ISTAT = ', istat +! +! TEST VMEC-BASED VERSION +! + CALL GetBcyl(rfull, vi/nfp, zfull, br2f, bphi2f, bz2f, + 1 sflx, uflx, bsupu, bsupv, rzl_array, ns, ntor, mpol, + 2 ntmax, nzeta, ntheta3, nfp, mscale, nscale, + 3 lthreed, lasym, istat) + IF (istat .ne. 0) PRINT *,' VMEC-BASED ISTAT = ', istat + + WRITE (33, 1225) l, sflx-si, MOD(uflx-ui,twopi), + 1 br(l), czmn_o(l), bz(l), + 2 br1f, bphi1f, bz1f, br2f, bphi2f, bz1f + + 1225 FORMAT(i4, 1p,2e10.2, 9e12.3) + + ELSE + + z12 = (z1(l,0) + z1(l-1,0) + shalf(l)* + 1 (z1(l,1) + z1(l-1,1)))/2 + r12 = armn_o(l) + +! +! TEST WOUT-BASED VERSION +! + CALL GetBcyl(r12, vi/nfp, z12, br12, bphi12, bz12, + 1 sflx, uflx, istat) + + IF (istat .eq. 0) THEN + WRITE (33, 1224) l, sflx-si, MOD(uflx-ui,twopi), + 1 (br(l) - br12)/bphi12, (czmn_o(l)-bphi12)/bphi12, + 2 (bz(l) - bz12)/bphi12 + ELSE + WRITE (33, *)' istat = ', istat + END IF + + +! +! TEST VMEC-BASED VERSION (OVERLOADED, SAME FUNCTION CALL, DIFF ARG.) +! + CALL GetBcyl(r12, vi/nfp, z12, br12, bphi12, bz12, sflx, + 1 uflx, bsupu, bsupv, rzl_array, ns, ntor, mpol, + 2 ntmax, nzeta, ntheta3, nfp, mscale, nscale, + 3 lthreed, lasym, istat) + IF (istat .eq. 0) THEN + WRITE (34, 1224) l, sflx-si, MOD(uflx-ui,twopi), + 1 (br(l) - br12)/bphi12, (czmn_o(l)-bphi12)/bphi12, + 2 (bz(l) - bz12)/bphi12 + ELSE + WRITE (34, *)' istat = ', istat + END IF + + END IF + +! CALL tosuvspace(si,ui,vi,gsqrt=gsqrt1) +! WRITE(33, 1223) l, gsqrt(l), gsqrt1, +! 1 ABS(gsqrt(l)-gsqrt1)/ABS(gsqrt1) + END DO + END DO + 1223 FORMAT(' l = ',i4,' GSQRT = ',1p,e12.4,' FROM WOUT = ',e12.4, + 1 ' REL.ERROR = ',e10.2) + 1224 FORMAT(' l = ',i4, ' del-SFLX = ', 1p,e10.2, + 1 ' del-UFLX = ', e10.2, + 2 ' del-BR = ', e12.4,' del-BPHI = ', + 3 e12.4, ' del-BZ = ', e12.4) + + CALL read_wout_deallocate + + END SUBROUTINE TestWout diff --git a/Sources/Input_Output/bss.f b/Sources/Input_Output/bss.f new file mode 100644 index 0000000..55a1a27 --- /dev/null +++ b/Sources/Input_Output/bss.f @@ -0,0 +1,41 @@ + SUBROUTINE bss(r12, rs, zs, ru12, zu12, bsubs, bsupu, bsupv, + 1 br, bphi, bz) + USE vmec_main + USE realspace + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(nrzt), INTENT(in) :: r12, rs, zs, + 1 ru12, zu12, bsupu, bsupv + REAL(rprec), DIMENSION(nrzt), INTENT(out) :: + 1 br, bphi, bz, bsubs +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: p5 = 0.5_dp, p25 = p5*p5 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l + REAL(rprec) :: rv12, zv12, gsu, gsv, dphids, rs12, zs12 +C----------------------------------------------- +! +! Computes br, bphi, bz, bsubs on HALF-RADIAL mesh +! + dphids = p25 + + DO l = 2, nrzt + rv12 = p5*(rv(l,0)+rv(l-1,0) + shalf(l)*(rv(l,1) + rv(l-1,1))) + zv12 = p5*(zv(l,0)+zv(l-1,0) + shalf(l)*(zv(l,1) + zv(l-1,1))) + rs12 = rs(l) + dphids*(r1(l,1) + r1(l-1,1))/shalf(l) + zs12 = zs(l) + dphids*(z1(l,1) + z1(l-1,1))/shalf(l) + gsu = rs12*ru12(l) + zs12*zu12(l) + gsv = rs12*rv12 + zs12*zv12 + br(l) = bsupu(l)*ru12(l) + bsupv(l)*rv12 + bphi(l) = bsupv(l)*r12(l) + bz(l) = bsupu(l)*zu12(l) + bsupv(l)*zv12 + bsubs(l) = bsupu(l)*gsu + bsupv(l)*gsv + END DO + + END SUBROUTINE bss diff --git a/Sources/Input_Output/dump_output.f b/Sources/Input_Output/dump_output.f new file mode 100644 index 0000000..009c3d6 --- /dev/null +++ b/Sources/Input_Output/dump_output.f @@ -0,0 +1,55 @@ + MODULE dump_output + USE vmec_main + USE realspace + IMPLICIT NONE + + INTEGER, PRIVATE :: js, lu, lv + + CONTAINS + + SUBROUTINE dump_special + +! Dumps out any "special" information the user might want for debugging, etc + + js = (ns-1)/4 + 1 + + WRITE (66,100) ns, ntheta, ntheta3, nzeta + 100 FORMAT("NS: ",i4," NU: ",i4," NU2: ",i4," NV: ",i4) + WRITE (66, 110) js + 110 FORMAT("JS POINT: ", i4, /) + + WRITE (66, *)" R1 Z1 RU ZU", + 1 " RV ZV" + WRITE (66, *) + CALL WRITE_RZL(r1,z1,ru,zu,rv,zv,js) + + END SUBROUTINE dump_special + + SUBROUTINE WRITE_RZL(r1,z1,ru,zu,rv,zv,jspt) + REAL(rprec), INTENT(in), DIMENSION(ns,nzeta,ntheta3,0:1) :: + 1 r1, z1, ru, zu, rv, zv + REAL(rprec) :: factor, temp1, temp2, temp3, temp4, temp5, temp6 + INTEGER :: jspt + + factor = sqrts(jspt) + + DO lu = 1, ntheta3 + WRITE (66, 100) lu + DO lv = 1, nzeta + temp1 = r1(jspt,lv,lu,0) + factor*r1(jspt,lv,lu,1) + temp2 = z1(jspt,lv,lu,0) + factor*z1(jspt,lv,lu,1) + temp3 = ru(jspt,lv,lu,0) + factor*ru(jspt,lv,lu,1) + temp4 = zu(jspt,lv,lu,0) + factor*zu(jspt,lv,lu,1) + temp5 = rv(jspt,lv,lu,0) + factor*rv(jspt,lv,lu,1) + temp6 = zv(jspt,lv,lu,0) + factor*zv(jspt,lv,lu,1) + WRITE (66, 200) lv, temp1, temp2, temp3, + 1 temp4, temp5, temp6 + END DO + END DO + + 100 FORMAT ("lu: ", i4) + 200 FORMAT (i4, 1p,6e12.4) + + END SUBROUTINE WRITE_RZL + + END MODULE dump_output diff --git a/Sources/Input_Output/elongation.f b/Sources/Input_Output/elongation.f new file mode 100644 index 0000000..5861d6d --- /dev/null +++ b/Sources/Input_Output/elongation.f @@ -0,0 +1,23 @@ + SUBROUTINE elongation (r1, z1, waist, height) + USE vmec_main + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), INTENT(out) :: waist(2), height(2) + REAL(rprec), INTENT(in), DIMENSION(ns,nzeta,ntheta3,0:1) :: r1, z1 + INTEGER :: nv, n1 +C----------------------------------------------- +! +! Compute Waist thickness, Height in phi = 0, pi symmetry planes +! + n1 = 0 + DO nv = 1, nzeta/2+1 + IF (nv.ne.1 .and. nv.ne.nzeta/2+1) CYCLE + n1 = n1+1 + waist(n1) = (r1(ns,nv,1,0) + r1(ns,nv,1,1)) - + 1 (r1(ns,nv,ntheta2,0) + r1(ns,nv,ntheta2,1)) + height(n1) = 2*MAXVAL(ABS(z1(ns,nv,:,0) + z1(ns,nv,:,1))) + END DO + + END SUBROUTINE elongation diff --git a/Sources/Input_Output/eqfor.f b/Sources/Input_Output/eqfor.f new file mode 100644 index 0000000..9626f8b --- /dev/null +++ b/Sources/Input_Output/eqfor.f @@ -0,0 +1,703 @@ + SUBROUTINE eqfor(br, bz, bsubu, bsubv, tau, rzl_array, ier_flag) + USE vmec_main + USE vmec_params + USE realspace + USE vforces, r12 => armn_o, bsupu => crmn_e, bsupv => czmn_e, + 1 gsqrt => azmn_o, bsq => bzmn_o, izeta => azmn_e, + 2 brho => bzmn_e, bphi => czmn_o, curtheta => brmn_e +#ifdef _ANIMEC + 3 ,tau_an => brmn_o +#endif + USE vacmod + USE vspline + USE csplinx + USE vmec_io + USE mgrid_mod + USE fbal + USE v3f_vmec_comm + USE stel_constants, ONLY: pi + + USE xstuff, ONLY: xc, pxc + USE safe_open_mod + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: ier_flag + REAL(dp), DIMENSION(ns,nznt,0:1), INTENT(in) :: bsubu, bsubv + REAL(dp), DIMENSION(nrzt), INTENT(out) :: br, bz + REAL(dp), DIMENSION(nrzt), INTENT(out) :: tau + REAL(dp), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), TARGET, + & INTENT(in) :: rzl_array +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: c1p5=1.5_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, icount, itheta, js, js1, l, loff, + & lpi, lt, n, n1, nchicur, nchiiota0, noff, + & nout, nsort, iv, iu, lk, nplanes + REAL(dp), DIMENSION(:), POINTER :: + & rmags, zmags, rmaga, zmaga + REAL(dp), DIMENSION(:,:,:), POINTER :: rmncc,zmnsc + REAL(dp), DIMENSION(ns) :: phi1, chi1, jPS2 + REAL(dp) :: modb(nznt) + REAL(dp), DIMENSION(:), ALLOCATABLE :: + & btor_vac, btor1, dbtor, phat, t12u, guu_1u, surf_area, + & r3v, redge, rbps1u, bpol2vac, phipf_loc + REAL(dp) :: aminr1, !aminr2, + & aminr2in, anorm, + & aspectratio, betai, betstr, scaling_ratio, + & bminz2, bminz2in, btor, iotamax, musubi, + & bzcalc, bzin, chisq, chiwgt, cur0, + & delphid_exact, delta1, delta2, delta3, denwgt, lambda, + & dlogidsi, !dmusubi_meas, + & er, es, fac, facnorm, factor, fgeo, + & fmax, fmin, flao, fpsi0, pavg, pitchc, pitchm, + & pprime, qedge, qmin1, qmin2, qmin3, qzero, + & raxis0, rcalc, rcen, + & rcenin, rgeo, rjs, + & rjs1, rlao, rqmin1, rqmin2, rshaf, rshaf1, rshaf2, s11, s12, + & s13, s2, s3, sigr0, sigr1, sigz1, smaleli, + & splintx, splints, sqmin, sumbpol, sumbtot, sumbtor, sump, + & sump2, sump20, t1, tz, jpar_perp=0, jparPs_perp=0, + & tol, toroidal_flux, vnorm, vprime, wght0, xmax, + & xmida, xmidb, xmin, rzmax, rzmin, zxmax, zxmin, zaxis0, + & zmax, zmin, yr1u, yz1u, waist(2), height(2) + REAL(dp) :: d_of_kappa, tmpxc, rmssum + INTEGER :: istat1, OFU, j, k +C----------------------------------------------- +C E x t e r n a l F u n c t i o n s +C----------------------------------------------- + EXTERNAL splintx, splints +C----------------------------------------------- +! +! POINTER ASSOCIATIONS +! + rmags => rzl_array(1,:,0,rcc) + zmags => rzl_array(1,:,0,zcs+ntmax) + rmncc => rzl_array(:,:,:,rcc) + zmnsc => rzl_array(:,:,:,zsc+ntmax) + IF (lasym) THEN + rmaga => rzl_array(1,:,0,rcs) + zmaga => rzl_array(1,:,0,zcc+ntmax) + END IF + +! crmn_o => bss on half grid + CALL bss(r12, bzmn, brmn, azmn, armn, crmn_o, bsupu, bsupv, + & br, bphi, bz) + +! +! STORE EDGE VALUES OF B-FIELD +! + IF ((lfreeb .and. ivac .gt. 1) .or. ledge_dump) THEN + IF (ALLOCATED(bredge)) THEN + DEALLOCATE(bredge, bpedge, bzedge) + END IF + ALLOCATE(bredge(2*nznt), bpedge(2*nznt), bzedge(2*nznt), + & stat=i) + IF (i .ne. 0) STOP 'Error in EQFOR allocating bredge' + DO iv = 1,nzeta + DO iu = 1, ntheta3 + lk = iv + nzeta*(iu - 1) + n1 = ns*lk + bredge(lk) = 1.5_dp*br(n1) - p5*br(n1 - 1) + bpedge(lk) = 1.5_dp*bphi(n1) - p5*bphi(n1 - 1) + bzedge(lk) = 1.5_dp*bz(n1) - p5*bz(n1 - 1) + END DO + END DO + END IF + +#ifdef _ANIMEC +!EVALUATE MIRROR STABILITY CRITERION; BSQ ==> MAGNETIC PRESSURE + CALL mirror_crit(tau_an, bsq) +#endif +! +! NOTE: JXBFORCE ROUTINE MUST BE CALLED TO COMPUTE IZETA, JDOTB +! ON OUTPUT, J, IZETA, JDOTB ARE IN MKS UNITS (1/MU0 FACTOR) +! +! CAUTION: THIS CALL WILL WRITE OVER br, bz +! + + CALL jxbforce(bsupu, bsupv, bsubu, bsubv, crmn_o, rcon, zcon, + & gsqrt, bsq, curtheta, izeta, brho, sigma_an, + & ier_flag +#ifdef _ANIMEC + & , pp1, pp2, ppar, onembc +#endif + & ) + +! +! HALF-MESH VOLUME-AVERAGED BETA +! + + tau(1) = 0 + tau(2:nrzt) = signgs*wint(2:nrzt)*gsqrt(2:nrzt) + DO i = 2, ns + s2 = SUM(bsq(i:nrzt:ns)*tau(i:nrzt:ns))/vp(i) - pres(i) + overr(i) = SUM(tau(i:nrzt:ns)/r12(i:nrzt:ns)) / vp(i) + beta_vol(i) = pres(i)/s2 + END DO + + betaxis = c1p5*beta_vol(2) - p5*beta_vol(3) + + IF (grank.EQ. 0) WRITE (nthreed, 5) + 5 FORMAT(/,' NOTE: S=normalized toroidal flux (0 - 1)',/, + 1 ' U=poloidal angle (0 - 2*pi)',/, + 1 ' V=geometric toroidal angle (0 - 2*pi)',/, + 1 ' = d(Ipol)/dPHI', + 1 ' - IOTA*d(Itor)/dPHI - dp/dPHI * d(VOL)/dPHI',/, + 1 ' = d(VOL)/dPHI*[', + 1 ' - IOTA* - SIGN(JAC)*dp/dPHI]',/, + 1 ' (NORMED TO SUM OF INDIVIDUAL TERMS)',//, + 1 ' S d(VOL)/', + 2 ' d(PRES)/ PRESF ', + 3 ' ',/, + 4 ' FORCE> FLUX ', + 5 ' d(PHI) ', + 6 ' d(PHI) ',/,148('-'),/) + ALLOCATE (phipf_loc(ns)) + + phipf_loc(1) = twopi*signgs*(c1p5*phip(2) - p5*phip(3)) + presf(1) = c1p5*pres(2) - p5*pres(3) + DO i = 2,ns1 + presf(i) = p5*(pres(i) + pres(i + 1)) + phipf_loc(i) = p5*twopi*signgs*(phip(i) + phip(i + 1)) + END DO + presf(ns) = c1p5*pres(ns) - p5*pres(ns - 1) + phipf_loc(ns) = twopi*signgs*(c1p5*phip(ns) - p5*phip(ns1)) + + phi1(1) = zero + chi1(1) = zero + DO i = 2, ns + phi1(i) = phi1(i - 1) + hs*phip(i) + chi1(i) = chi1(i - 1) + hs*(phip(i)*iotas(i)) + END DO + + chi = twopi*chi1 + +! WRITE (36, 201) (i, phi1(i), chi1(i), iotas(i), i=1, ns) +!201 FORMAT (i4, 1p,3e14.6) + + CALL calc_fbal(bsubu, bsubv) + + bucof(1) = 0 + bvcof(1) = c1p5*bvco(2) - p5*bvco(3) +! +! NOTE: jcuru, jcurv on FULL radial mesh coming out of calc_fbal +! They are local (surface-averaged) current densities (NOT integrated in s) +! jcurX = (dV/ds)/twopi**2 for X=u,v +! + DO i = 2, ns1 + equif(i) = equif(i)*vpphi(i)/(ABS(jcurv(i)*chipf(i)) + + & ABS(jcuru(i)*phipf(i)) + + & ABS(presgrad(i)*vpphi(i))) + bucof(i) = p5*(buco(i) + buco(i + 1)) + bvcof(i) = p5*(bvco(i) + bvco(i + 1)) + END DO + + bucof(ns) = c1p5*buco(ns) - p5*buco(ns1) + bvcof(ns) = c1p5*bvco(ns) - p5*bvco(ns1) + + equif(1) = two*equif(2) - equif(3) + jcuru(1) = two*jcuru(2) - jcuru(3) + jcurv(1) = two*jcurv(2) - jcurv(3) + presgrad(1) = two*presgrad(2) - presgrad(3) + presgrad(ns) = two*presgrad(ns1) - presgrad(ns1-1) + vpphi(1) = two*vpphi(2) - vpphi(3) + vpphi(ns) = two*vpphi(ns1) - vpphi(ns1-1) + equif(ns) = two*equif(ns1) - equif(ns1-1) + jcuru(ns) = two*jcuru(ns1) - jcuru(ns1-1) + jcurv(ns) = two*jcurv(ns1) - jcurv(ns1-1) +! NOTE: phipf = phipf_loc/(twopi), phipf_loc ACTUAL (twopi factor) Toroidal flux derivative +! SPH/JDH (060211): remove twopi factors from (agree with output in JXBOUT file) + fac = twopi*signgs + DO js = 1, ns + es = (js - 1)*hs + cur0 = fac*vpphi(js)*twopi !==dV/ds = dV/dPHI * d(PHI/ds) (V=actual volume) + IF (rank .EQ. 0) THEN + WRITE (nthreed, 30) es, equif(js), fac*phi1(js), iotaf(js), + & jcuru(js)/vpphi(js)/mu0, + & jcurv(js)/vpphi(js)/mu0, + & cur0/phipf_loc(js), + & presgrad(js)/phipf_loc(js)/mu0, + & specw(js), presf(js)/mu0, bucof(js), + & bvcof(js), jdotb(js), bdotb(js) + END IF + END DO + 30 FORMAT(1p,2e10.2,2e12.4,4e11.3,0p,f7.3,1p,5e11.3) + + DEALLOCATE(phipf_loc) + +! +! MAKE SURE WOUT FILE DOES NOT REQUIRE ANY STUFF COMPUTED BELOW.... +! + IF (ier_flag .NE. successful_term_flag) RETURN + +! +! Calculate mean (toroidally averaged) poloidal cross section area & toroidal flux +! + anorm = twopi*hs + vnorm = twopi*anorm + toroidal_flux = anorm*SUM(bsupv(2:nrzt)*tau(2:nrzt)) + +! +! Calculate poloidal circumference and normal surface area and aspect ratio +! Normal is | dr/du X dr/dv | = SQRT [R**2 guu + (RuZv - RvZu)**2] +! + ALLOCATE(guu_1u(nznt), surf_area(nznt)) + guu_1u(:nznt) = ru0(ns:nrzt:ns)*ru0(ns:nrzt:ns) + + 1 zu0(ns:nrzt:ns)*zu0(ns:nrzt:ns) + surf_area(:nznt) = wint(ns:nrzt:ns)*SQRT(guu_1u(:nznt)) + circum_p = twopi*SUM(surf_area(:nznt)) + surf_area(:nznt) = wint(ns:nrzt:ns)*SQRT( + 1 + (r1(ns:nrzt:ns,0) + r1(ns:nrzt:ns,1))**2*guu_1u(:nznt) + 2 +((rv(ns:nrzt:ns,0) + rv(ns:nrzt:ns,1))*zu0(ns:nrzt:ns) + 3 - (zv(ns:nrzt:ns,0) + zv(ns:nrzt:ns,1))*ru0(ns:nrzt:ns))**2) + surf_area_p = twopi**2*SUM(surf_area(:nznt)) + DEALLOCATE (guu_1u) + + aspect = aspectratio() + +! Also, estimate mean elongation of plasma from the following relations +! for an axisymmetric torus with elliptical cross section and semi-axes +! a and a * kappa (kappa >= 1) +! +! surf_area _p = 2*pi*R * 2*pi*a ctwiddle(kappa_p) +! volume_p = 2*pi*R * pi*a ** 2 * kappa_p +! cross_area _p = pi*a ** 2 * kappa_p +! +! The cirumference of an ellipse of semi-axes a and a * kappa_p is +! 2 * pi * a ctwiddle(kappa_p) +! The exact form for ctwiddle is 4 E(1 - kappa_p^2) / (2 pi), where +! E is the complete elliptic integral of the second kind +! (with parameter argument m, not modulus argument k) +! +! The coding below implements an approximate inverse of the function +! d(kappa) = ctwiddle(kappa) / sqrt(kappa) +! The approximate inverse is +! kappa = 1 + (pi^2/8) * (d^2+sqrt(d^4-1)-1) +! Note that the variable aminor_p, for an elliptic cross section, +! would be a * sqrt(kappa) +! + d_of_kappa = surf_area_p * aminor_p / ( 2 * volume_p) + kappa_p = 1 + (pi * pi / 8) * (d_of_kappa ** 2 + SQRT & + & (ABS(d_of_kappa ** 4 - 1)) -1) + vvc_kappa_p = kappa_p ! Save result for v3fit. + + aminr1 = 2*volume_p/surf_area_p + +! +! +! OUTPUT BETAS, INDUCTANCES, SAFETY FACTORS, ETC. +! (EXTRACTED FROM FQ-CODE, 9-10-92) +! +! b poloidals (cylindrical estimates) +! +! rcen = p5*(router + rinner) !geometric center + n = 0 + n1 = n + 1 + rcenin = DOT_PRODUCT(rmncc(ns,n1,:mpol1+1:2), + 1 mscale(:mpol1:2)*nscale(n)) + + l = (mpol1+1)/2 + ALLOCATE (t12u(l)) + t12u(:l) = mscale(1:mpol1:2)*nscale(n) + aminr2in = DOT_PRODUCT(rmncc(ns,n1,2:mpol1+1:2),t12u(:l)) + bminz2in = DOT_PRODUCT(zmnsc(ns,n1,2:mpol1+1:2),t12u(:l)) + bminz2 = DOT_PRODUCT(zmnsc(ns,n1,2:mpol1+1:2),t12u(:l)) + DEALLOCATE (t12u) + aminr1 = SQRT(two*volume_p/(twopi*twopi*r00)) !vol av minor radius +! aminr2 = p5*(router - rinner) !geometric plasma radius +! +! cylindrical estimates for beta poloidal +! + sump = vnorm*SUM(vp(2:ns)*pres(2:ns)) + pavg = sump/volume_p +! ppeak = presf(1) + factor = 2*pavg +! +! delphid_exact = Integral[ (Bvac - B) * dSphi ] +! rshaf [= RT in Eq.(12), Phys Fluids B 5 (1993) 3119] +! +! Note: tau = |gsqrt|*wint +! + ALLOCATE (btor_vac(nznt), btor1(nznt), dbtor(nznt), + 1 phat(nznt), redge(nznt)) + delphid_exact = zero !Eq. 20 in Shafranov + musubi = zero + rshaf1 = zero + rshaf2 = zero + DO js = 2, ns + btor_vac(:nznt) = rbtor/r12(js:nrzt:ns) + btor1(:nznt) = r12(js:nrzt:ns)*bsupv(js:nrzt:ns) + delphid_exact = delphid_exact + SUM( + 1 (btor_vac(:nznt)/r12(js:nrzt:ns) - + 2 bsupv(js:nrzt:ns))*tau(js:nrzt:ns)) + dbtor(:nznt) = btor1(:nznt)**2 - btor_vac(:nznt)**2 + musubi = musubi - SUM(dbtor(:nznt)*tau(js:nrzt:ns)) + phat(:nznt) = bsq(js:nrzt:ns) - p5*btor_vac(:nznt)**2 + phat(:nznt) = (phat(:nznt) - dbtor(:nznt))*tau(js:nrzt:ns) + rshaf1 = rshaf1 + SUM(phat(:nznt)) + rshaf2 = rshaf2 + SUM(phat(:nznt)/r12(js:nrzt:ns)) + END DO + + redge(:nznt) = r1(ns:nrzt:ns,0) + r1(ns:nrzt:ns,1) + IF (lfreeb .and. ivac.gt.1) THEN + phat = bsqvac(:) - p5*(bsubvvac/redge(:))**2 + ELSE + phat = c1p5*bsq(ns:nrzt:ns) - p5*bsq(ns-1:nrzt:ns) + 1 - p5*(rbtor/redge(:))**2 + END IF + + DEALLOCATE (btor_vac, btor1, dbtor) + + delphid_exact = anorm*delphid_exact + rshaf = rshaf1/rshaf2 + fpsi0 = c1p5*bvco(2) - p5*bvco(3) + b0 = fpsi0/r00 + + rmax_surf = MAXVAL(r1(ns:nrzt:ns,0)+r1(ns:nrzt:ns,1)) + rmin_surf = MINVAL(r1(ns:nrzt:ns,0)+r1(ns:nrzt:ns,1)) + zmax_surf = MAXVAL(ABS(z1(ns:nrzt:ns,0)+z1(ns:nrzt:ns,1))) + + DO js = 2, ns + modb(:nznt) = SQRT(two*(bsq(js:nrzt:ns)-pres(js))) + CALL bextrema (modb, bmin(1,js), bmax(1,js), nzeta, ntheta2) + END DO + +! +! output geometrical, |B| quantities +! + CALL elongation (r1, z1, waist, height) + + IF(rank.EQ.0) WRITE (nthreed, 75) bmin(1,ns), bmax(1,ns), + 1 bmin(ntheta2,ns), bmax(ntheta2,ns) + 75 FORMAT(/ + 1 ' Magnetic field modulation (averaged over toroidal angle)',/, + 2 1x,71('-')/,' BMIN(u=0) = ',f14.6/ + 3 ' BMAX(u=0) = ',f14.6/' BMIN(u=pi) = ', + 4 f14.6/' BMAX(u=pi) = ',f14.6/) + + sumbtot = 2*(vnorm*SUM(bsq(2:nrzt)*tau(2:nrzt)) - sump) + sumbtor = vnorm*SUM(tau(2:nrzt)*(r12(2:nrzt)*bsupv(2:nrzt))**2) + sumbpol = sumbtot - sumbtor + betapol = 2*sump/sumbpol + sump20 = 2*sump + sump2 = SUM(pres(2:ns)*pres(2:ns)*vp(2:ns)*vnorm) + betatot = sump20/sumbtot + betator = sump20/sumbtor + VolAvgB = SQRT(ABS(sumbtot/volume_p)) + IonLarmor = 0.0032_dp/VolAvgB + jPS2(2:ns1) = (jpar2(2:ns1) - jdotb(2:ns1)**2/bdotb(2:ns1)) + jpar_perp = SUM(jpar2(2:ns1)*(vp(2:ns1) + vp(3:ns))) + jparPS_perp = SUM(jPS2(2:ns1)*(vp(2:ns1) + vp(3:ns))) + s2 = SUM(jperp2(2:ns1)*(vp(2:ns1) + vp(3:ns))) + IF (s2 .ne. zero) THEN + jpar_perp = jpar_perp/s2 + jparPS_perp = jparPS_perp/s2 + END IF + IF (ntor .gt. 1) THEN + IF(rank.EQ.0) WRITE (nthreed, 80) aspect, kappa_p, volume_p, + 1 cross_area_p, surf_area_p, circum_p, Rmajor_p, Aminor_p, + 2 rmin_surf, rmax_surf, zmax_surf, waist(1), height(1), + 3 waist(2), height(2) + ELSE + IF(rank.EQ.0) WRITE (nthreed, 80) aspect, kappa_p, volume_p, + 1 cross_area_p, surf_area_p, circum_p, Rmajor_p, Aminor_p, + 2 rmin_surf, rmax_surf, zmax_surf, waist(1), height(1) + END IF + 80 FORMAT(/,' Geometric and Magnetic Quantities',/,1x,71('-')/, + 1 ' Aspect Ratio = ',f14.6, / + 1 ' Mean Elongation = ',f14.6, / + 1 ' Plasma Volume = ',f14.6,' [M**3]',/ + 2 ' Cross Sectional Area = ',f14.6,' [M**2]',/ + 3 ' Normal Surface Area = ',f14.6,' [M**2]',/ + 4 ' Poloidal Circumference= ',f14.6,' [M]',/ + 5 ' Major Radius = ',f14.6,' [M]', + 6 ' (from Volume and Cross Section)',/ + 7 ' Minor Radius = ',f14.6,' [M]', + 8 ' (from Cross Section)',/ + 9 ' Minimum (inboard) R = ',f14.6,' [M]',/ + A ' Maximum (outboard) R = ',f14.6,' [M]',/ + A ' Maximum height Z = ',f14.6,' [M]',/ + B ' Waist (v = 0) in R = ',f14.6,' [M]',/ + B ' Full Height(v = 0) = ',f14.6,' [M]',:,/ + B ' Waist (v = pi) in R = ',f14.6,' [M]',:,/ + B ' Full Height(v = pi) = ',f14.6,' [M]') + IF (rank.EQ.0) WRITE (nthreed, 85) toroidal_flux, + 1 1.e-6_dp*ctor/mu0, rbtor, rbtor0, VolAvgB, IonLarmor, + 2 jpar_perp, jparPS_perp + 85 FORMAT( + 1 ' Toroidal Flux = ',f14.6,' [Wb]',/ + 1 ' Toroidal Current = ',f14.6,' [MA]',/ + 1 ' RBtor(s=1) = ',f14.6,' [T-m]',/ + 1 ' RBtor(s=0) = ',f14.6,' [T-m]',/ + 1 ' Volume Average B = ',f14.6,' [T]',/ + 2 ' Ion Larmor Radius = ',f14.6,' [M] X Ti(keV)**0.5',/ + 3 ' / = ',f14.6,' (Vol. Averaged)',/ + 4 ' / = ',f14.6,' (Vol. Averaged)',/) + + IF(rank.EQ.0) WRITE (nthreed, 90) + 90 FORMAT(/,71('-'),/,' MORE GEOMETRIC AND PHYSICS QUANTITIES',/, + 1 71('-'),/,' Toroidal Plane: Phi = 0',/, + 1 5x,'j',3x,'psi-psiaxis',9x,'a [M]',3x,'ellipticity',3x, + 2 'indentation',7x,'d-shape',4x,'rel. shift',6x,'/',4x, + 3 '/',/,95x, + 4 '',3x,''/,' -----',8(2x,12('-'))) + + fac = twopi*hs*signgs + psi(1) = zero + ALLOCATE (r3v(ns-1)) + r3v(:ns-1) = fac*phip(2:ns)*iotas(2:ns) + DO i = 1, ns - 1 + psi(1+i) = psi(i) + r3v(i) + END DO + DEALLOCATE (r3v) + +! nphi-plane, noff = 1,....,nzeta + DO nplanes = 1, 2 + IF (nplanes .eq. 1) THEN + noff = 1 + ELSE + IF (nzeta .eq. 1) EXIT + IF(rank.EQ.0) WRITE (nthreed, 95) + noff = 1 + nzeta/2 + END IF + + ygeo(1) = zero + DO js = 2, ns + zmin = HUGE(zmin) + zmax = -HUGE(zmax) + xmin = HUGE(xmin) + xmax = -HUGE(xmax) + rzmax = zero + +! Theta = 0 to pi in upper half of X-Z plane + DO icount = 1,2 + n1 = noff !nphi-plane, n1 = noff,...,nzeta + IF (icount .eq. 2) + 1 n1 = MOD(nzeta + 1 - noff,nzeta) + 1 !(twopi-v), reflected plane + loff = js + ns*(n1-1) + t1 = one + IF (icount .eq. 2) t1 = -one + DO itheta = 1,ntheta2 + yr1u = r1(loff,0) + sqrts(js)*r1(loff,1) + yz1u = z1(loff,0) + sqrts(js)*z1(loff,1) + yz1u = t1*yz1u + IF (yz1u .ge. zmax) THEN + zmax = ABS(yz1u) + rzmax = yr1u + ELSE IF (yz1u .le. zmin) THEN + zmin = yz1u + rzmin = yr1u + END IF + IF (yr1u .ge. xmax) THEN + xmax = yr1u + zxmax = yz1u + ELSE IF (yr1u .le. xmin) THEN + xmin = yr1u + zxmin = yz1u + END IF + loff = loff + ns*nzeta + END DO + END DO + + + lpi = ns*((noff-1) + nzeta*(ntheta2 - 1)) + lt = ns*((noff-1)) + xmida = r1(js+lpi,0) + sqrts(js)*r1(js+lpi,1) + xmidb = r1(js+lt,0) + sqrts(js)*r1(js+lt,1) + + rgeo = p5*(xmidb + xmida) !Geometric major radius + ygeo(js) = p5*(xmidb - xmida) !Geometric minor radius + + yinden(js) = (xmida - xmin)/(xmax - xmin) !Geometric indentation + yellip(js) = (zmax - zmin)/(xmax - xmin) !Geometric ellipticity + + ytrian(js) = (rgeo - rzmax)/(xmax - xmin) !Geometric triangularity + yshift(js) = (r1(1+lt,0)-rgeo)/(xmax - xmin) !Geometric shift + + IF (jperp2(js) .eq. zero) jperp2(js) = EPSILON(jperp2(js)) + jpar_perp = jpar2(js)/jperp2(js) + IF (js .lt. ns) THEN + jparPS_perp = jPS2(js)/jperp2(js) + ELSE + jparPS_perp = zero + END IF + + IF (nplanes .eq. 1) THEN + IF(rank.EQ.0) WRITE (nthreed, 120) js, psi(js), ygeo(js), + 1 yellip(js), yinden(js), ytrian(js), yshift(js), jpar_perp, + 2 jparPS_perp + ELSE + IF(rank.EQ.0) WRITE (nthreed, 120) js, psi(js), ygeo(js), + 1 yellip(js), yinden(js), ytrian(js), yshift(js) + END IF + + END DO + END DO + + 95 FORMAT(/,71('-'),/,' Toroidal Plane: Phi = 180/Nfp',/,71('-'),/) + 120 FORMAT(1x,i5,6f14.5,1p,3e14.2) + + IF(rank.EQ.0) WRITE (nthreed, 130) + 130 FORMAT(//,' Magnetic Fields and Pressure',/,1x,71('-')) + fac = p5/mu0 + IF(rank.EQ.0) WRITE (nthreed, 140) sump/mu0, pavg/mu0, + 1 fac*sumbpol, fac*sumbpol/volume_p, fac*sumbtor, fac*sumbtor/ + 2 volume_p, fac*sumbtot, fac*sumbtot/volume_p, c1p5*sump/mu0, + 3 c1p5*pavg/mu0 + 140 FORMAT(' Volume Integrals (Joules) and Volume ', + 1 'Averages (Pascals)',/,24x,'Integral',6x,'Average',/, + 2 ' pressure = ',1p,2e14.6,/,' bpol**2 /(2 mu0) = ', + 3 2e14.6,/,' btor**2/(2 mu0) = ',2e14.6,/, + 4 ' b**2/(2 mu0) = ',2e14.6,/,' EKIN (3/2p) = ', + 5 2e14.6,/) + + IF(rank.EQ.0) WRITE (nthreed, 800) + 800 FORMAT(/,' MAGNETIC AXIS COEFFICIENTS'/, + 1 ' n rmag zmag rmag zmag',/, + 2 ' (cos nv) (sin nv) (sin nv) (cos nv)',/) + loff = LBOUND(rmags,1) + IF (rank. EQ. 0) THEN + DO n = 0, ntor + n1 = n + loff + t1 = mscale(0)*nscale(n) + tz = t1 + IF (.NOT.lthreed) tz = 0 + IF (lasym) THEN + WRITE (nthreed, 820) n, t1*rmags(n1), + 1 tz*zmags(n1), tz*rmaga(n1), t1*zmaga(n1) + ELSE + WRITE (nthreed, 820) n, t1*rmags(n1), + 1 tz*zmags(n1) + END IF + END DO + END IF + 820 FORMAT(i5,1p,4e12.4) + + betstr = two*SQRT(sump2/volume_p)/(sumbtot/volume_p) + + IF(rank.EQ.0) WRITE (nthreed, 150) betatot, betapol, betator + 150 FORMAT(/,' From volume averages over plasma, betas are',/, + 1 ' beta total = ',f14.6,/,' beta poloidal = ',f14.6,/, + 2 ' beta toroidal = ',f14.6,/) + + IF(rank.EQ.0) WRITE (nthreed, 160) rbtor, betaxis, betstr + 160 FORMAT(' R * Btor-vac = ',f14.6,' [Wb/M]',/, + 1 ' Peak Beta = ',f14.6,/, + 2 ' Beta-star = ',f14.6,/) + +! +! +! Shafranov surface integrals s1,s2 +! Plasma Physics vol 13, pp 757-762 (1971) +! Also, s3 = .5*S3, defined in Lao, Nucl. Fusion 25, p.1421 (1985) +! Note: if ctor = 0, use Int(Bsupu*Bsubu dV) for ctor*ctor/R +! Phys. Fluids B, Vol 5 (1993) p 3121, Eq. 9a-9d +! + + ALLOCATE (rbps1u(nznt), bpol2vac(nznt)) + IF (lfreeb .and. ivac.gt.1) THEN + bpol2vac = 2*bsqvac - bphiv*bphiv + ELSE + bpol2vac = 2*(c1p5*bsq(ns:nrzt:ns) - p5*bsq(ns-1:nrzt:ns)) + 1 - ((c1p5*bsupv(ns:nrzt:ns) - p5*bsupv(ns-1:nrzt:ns)) + 2 * redge)**2 + END IF + +! Compute current-like norm (factor) in Eq.(8), * int(Bpol**2 * dA) +! where == 2*pi*Rs in Eq. 8 is the effective minor radius = Vol/Asurf +! (corrects wrong description of Rs in paper, which is NOT the major radius) +! This aminr1 = 1/2 the "correct" aminr1 + aminr1 = volume_p/surf_area_p + factor = twopi**2*aminr1*SUM(bpol2vac*surf_area) + factor = one/factor + facnorm = factor*twopi**2 + +! Lao's definition of normalization factor + scaling_ratio = (mu0*curtor/circum_p)**2*volume_p + scaling_ratio = scaling_ratio*factor + + rbps1u(:nznt) = facnorm*redge(:nznt)*phat(:nznt) + 1 *wint(ns:nznt*ns:ns) + sigr0 = SUM(rbps1u(:nznt)*zu0(ns:nrzt:ns)) + sigr1 = SUM(rbps1u(:nznt)*zu0(ns:nrzt:ns)*redge(:nznt)) + sigz1 =-SUM(rbps1u(:nznt)*ru0(ns:nrzt:ns)* + 1 (z1(ns:nrzt:ns,0) + z1(ns:nrzt:ns,1))) + DEALLOCATE (redge, phat, rbps1u, bpol2vac, surf_area) + + er = sigr1 + sigz1 + rlao = volume_p/(twopi*cross_area_p) !LAO, NUCL.FUS.25(1985)1421 + flao = rshaf/rlao +! fgeo = rshaf/rcen + + smaleli = factor*sumbpol + vvc_smaleli = smaleli ! Save result for v3fit. + betai = 2*factor*sump + musubi = vnorm*factor*musubi +! dmusubi_meas = 2*twopi*factor*delphid*rbtor + lambda = p5*smaleli + betai + s11 = er - rshaf*sigr0 !Shafranov def. based on RT, Eq.(12) + s12 = er - rcen*sigr0 !R = Rgeometric + s13 = er - rlao*sigr0 !R = RLao + s2 = sigr0*rshaf + s3 = sigz1 !1/2 S3 in Eq.(14c) + delta1 = zero + delta2 = one - fgeo + delta3 = one - flao + IF(rank.EQ.0) WRITE (nthreed, 168) + IF(rank.EQ.0) WRITE (nthreed, 170) rshaf, rcen, rlao, + 1 scaling_ratio, s3, smaleli, musubi, betai, lambda +! IF (lrecon.AND.rank.EQ.0) WRITE (nthreed, 172) dmusubi_meas + IF(rank.EQ.0) WRITE (nthreed, 174) delta1, delta2, delta3, + 1 s11, s12, s13, s2, s2/fgeo, s2/flao, + 5 musubi + s11,musubi + s12, + 6 musubi + s13, + 8 p5*s11 + s2, p5*s12 + s2/fgeo, p5*s13 + s2/flao, + A p5*(3*betai+smaleli-musubi)/(s11+s2) - one, + B p5*(3*betai+smaleli-musubi)/(s12+s2/fgeo) - one, + C p5*(3*betai+smaleli-musubi)/(s13+s2/flao) - one, + D p5*(betai+smaleli+musubi)/s2 - one, + E p5*fgeo*(betai+smaleli+musubi)/s2 - one, + F p5*flao*(betai+smaleli+musubi)/s2 - one + + 168 FORMAT(' Shafranov Surface Integrals',/ + 1 ' Ref: S. P. Hirshman, Phys. Fluids B, 5, (1993) 3119',/, + 2 ' Note: s1 = S1/2, s2 = S2/2, where ', + 3 ' s1,s2 are the Shafranov definitions,',/, + 4 ' and s3 = S3/2, where S3 is Lao''s definition.',/, + 5 ' The quantity lsubi gives the ratio of volume poloidal', + 6 /,' field energy to the field energy estimated from the', + 7 /,' surface integral in Eq.8.',/,1x,22('-'),/) + + 170 FORMAT( + 5 ' RT (Pressure-weighted) = ',f14.6,' [M]',/, + 6 ' RG (Geometric) = ',f14.6,' [M]',/, + 7 ' RL (Vol/2*pi*Area-Lao) = ',f14.6,' [M]',/, + 8 ' Poloidal Field Energy',/, + 8 ' Normalization Ratio = ',f14.6,' (Lao/Hirshman)',//, + 8 ' s3 = ',f14.6,/, + 9 ' lsubi = ',f14.6,/, + 6 ' musubi = ',f14.6,/, + 7 ' betai = ',f14.6,/, + 9 ' lambda = ',f14.6,/) + 172 FORMAT(' musubi (diamagnetism) = ',f14.6) + 174 FORMAT(/,32x,'R = RT',12x,'R = RG',12x,'R = RL',/, + 1 20x,3(10x,8('-')),/, + 1 ' delta = 1 - RT/R = ',3(f14.6,4x),/, + 2 ' s1 = ',3(f14.6,4x),/, + 3 ' s2 = ',3(f14.6,4x),/, + 8 ' betai (Mui + s1) = ',3(f14.6,4x),/, + A ' lambda (s1/2 + s2) = ',3(f14.6,4x),/, + B ' 1st Shafr''v relation = ',3(f14.6,4x),/, + C ' (3*Betai + Li - Mui)/[2*(s1+s2)] - 1',/, + D ' Radial force balance = ',3(f14.6,4x),/, + E ' (Betai + Li + Mui)/(2*s2) - 1',/) + + END SUBROUTINE eqfor diff --git a/Sources/Input_Output/fileout.f b/Sources/Input_Output/fileout.f new file mode 100644 index 0000000..1897278 --- /dev/null +++ b/Sources/Input_Output/fileout.f @@ -0,0 +1,330 @@ + SUBROUTINE fileout_par(iseq, ictrl_flag, ier_flag, lscreen) + USE vmec_main, ONLY: ns, ntheta1, ntheta2, nzeta, bdamp, + & lfreeb + USE parallel_include_module + USE xstuff, ONLY: pxc, pgc, pxsave, pscalxc + USE xstuff, ONLY: xc, gc, xsave, scalxc + USE vmec_main, ONLY: vp, iotas, phips, chips, mass, icurv + USE vmec_main, ONLY: ireflect, nznt, phipf, specw, sp, sm + USE vmec_params, ONLY: uminus, output_flag + USE realspace, ONLY: phip, sqrts, shalf, wint + USE realspace, ONLY: pphip, psqrts, pshalf, pwint + USE vacmod, ONLY: bsqvac, brv, bphiv, bzv, nv, nuv3, + & bsupu_sur, bsupv_sur, bsubu_sur, bsubv_sur + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: iseq, ictrl_flag + INTEGER, INTENT(inout) :: ier_flag + LOGICAL :: lscreen + LOGICAL :: loutput !SAL 070719 + INTEGER :: i, j, ij, k, js, jk, lk, lt, lz, jcount + REAL(dp) :: tfileon, tfileoff + REAL(dp), ALLOCATABLE :: buffer(:,:), tmp(:,:) +C----------------------------------------------- + CALL second0(tfileon) + + loutput = (IAND(ictrl_flag, output_flag) .ne. 0) !SAL 070719 + + IF (lfreeb .AND. vlactive .AND. loutput) THEN !SAL070719 + ALLOCATE(buffer(numjs_vac, 7), tmp(nznt, 7),stat=i) + IF (i .NE. 0) CALL STOPMPI(440) + buffer(:,1) = brv(nuv3min:nuv3max) + buffer(:,2) = bphiv(nuv3min:nuv3max) + buffer(:,3) = bzv(nuv3min:nuv3max) + buffer(:,4) = bsupu_sur(nuv3min:nuv3max) + buffer(:,5) = bsupv_sur(nuv3min:nuv3max) + buffer(:,6) = bsubu_sur(nuv3min:nuv3max) + buffer(:,7) = bsubv_sur(nuv3min:nuv3max) + + DO i = 1, 7 + CALL MPI_Allgatherv(buffer(:,i), numjs_vac, MPI_REAL8, + & tmp(:,i), counts_vac, disps_vac, + & MPI_REAL8, VAC_COMM,MPI_ERR) + END DO + DEALLOCATE(buffer) + + brv = tmp(:,1); + bphiv = tmp(:,2); + bzv = tmp(:,3) + bsupu_sur = tmp(:,4); + bsupv_sur = tmp(:,5) + bsubu_sur = tmp(:,6); + bsubv_sur = tmp(:,7) + DEALLOCATE(tmp) + END IF +! +! COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym) +! + jcount = 0 + DO k = 1, nzeta + jk = nzeta + 2 - k + IF (k .eq. 1) jk = 1 + DO js = 1,ns + jcount = jcount + 1 + ireflect(jcount) = js+ns*(jk - 1) !Index for -zeta[k] + ENDDO + END DO + +! INDEX FOR u = -u (need for lasym integration in wrout) + lk = 0 + IF (.NOT.ALLOCATED(uminus)) ALLOCATE (uminus(nznt)) + DO lt = 1, ntheta2 + k = ntheta1-lt+2 + IF (lt .eq. 1) k = 1 !u=-0 => u=0 + DO lz = 1, nzeta + lk = lk + 1 + uminus(lk) = k !(-u), for u = 0,pi + END DO + END DO + + IF (grank.LT.nranks .AND. + & IAND(ictrl_flag, output_flag).NE.0) THEN + CALL Gather1XArray(vp) + CALL Gather1XArray(iotas) + CALL Gather1XArray(phips) + CALL Gather1XArray(phipf) + CALL Gather1XArray(chips) + CALL Gather1XArray(mass) + CALL Gather1XArray(icurv) + CALL Gather1XArray(specw) + CALL Gather1XArray(bdamp) + CALL Gather1XArray(sm) + CALL Gather1XArray(sp) + + CALL Gather2XArray(pphip) + CALL Parallel2Serial2X(pphip, phip) + CALL Gather2XArray(psqrts) + CALL Parallel2Serial2X(psqrts, sqrts) + CALL Gather2XArray(pshalf) + CALL Parallel2Serial2X(pshalf, shalf) + CALL Gather2XArray(pwint) + CALL Parallel2Serial2X(pwint, wint) + + CALL Gather4XArray(pxc) + CALL Parallel2Serial4X(pxc,xc) + CALL Gather4XArray(pscalxc) + CALL Parallel2Serial4X(pscalxc,scalxc) + CALL second0(tfileoff) + END IF + fo_prepare_time = fo_prepare_time + (tfileoff-tfileon) + +! ORIGPARVMEC=PARVMEC +! PARVMEC=.FALSE. + IF (grank .EQ. 0) THEN + CALL fileout(iseq, ictrl_flag, ier_flag, lscreen) + ENDIF + !CALL MPI_Barrier(NS_COMM, MPI_ERR) !SAL 070719 + CALL second0(tfileoff) + fileout_time = fileout_time + (tfileoff-tfileon) + fo_par_call_time = fileout_time + + END SUBROUTINE fileout_par + + SUBROUTINE fileout(iseq, ictrl_flag, ier_flag, lscreen) + USE vmec_main + USE vac_persistent + USE realspace + USE vmec_params, ONLY: mscale, nscale, signgs, uminus, + & norm_term_flag, more_iter_flag, output_flag, + & cleanup_flag, successful_term_flag + USE vforces + USE xstuff, ONLY: xc, gc, xsave, scalxc + USE precon2d, ONLY: ictrl_prec2d + USE timer_sub +#ifdef _HBANGLE + USE angle_constraints, ONLY: free_multipliers, getrz +#endif + USE parallel_include_module + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: iseq, ictrl_flag + INTEGER, INTENT(inout) :: ier_flag + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER :: istat, loc_ier_flag + LOGICAL, PARAMETER :: lreset_xc = .false. +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: js, istat1=0, irst0, OFU + REAL(dp), DIMENSION(:), POINTER :: lu, lv + REAL(dp), ALLOCATABLE :: br_out(:), bz_out(:) + CHARACTER(LEN=*), PARAMETER, DIMENSION(0:14) :: werror = (/ + & 'EXECUTION TERMINATED NORMALLY ', ! norm_term_flag + & 'INITIAL JACOBIAN CHANGED SIGN (IMPROVE INITIAL GUESS) ', ! bad_jacobian_flag + & 'FORCE RESIDUALS EXCEED FTOL: MORE ITERATIONS REQUIRED ', ! more_iter_flag + & 'VMEC INDATA ERROR: NCURR.ne.1 but BLOAT.ne.1. ', ! + & 'MORE THAN 75 JACOBIAN ITERATIONS (DECREASE DELT) ', ! jac75_flag + & 'ERROR READING INPUT FILE OR NAMELIST ', ! input_error_flag + & 'NEW AXIS GUESS STILL FAILED TO GIVE GOOD JACOBIAN ', ! + & 'PHIEDGE HAS WRONG SIGN IN VACUUM SUBROUTINE ', ! phiedge_error_flag + & 'NS ARRAY MUST NOT BE ALL ZEROES ', ! ns_error_flag + & 'ERROR READING MGRID FILE ', ! misc_error_flag + & 'VAC-VMEC I_TOR MISMATCH : BOUNDARY MAY ENCLOSE EXT. COIL ', ! + & 'SUCCESSFUL VMEC CONVERGENCE ', ! successful_term_flag + & 'BSUBU OR BSUBV JS=1 COMPONENT NON-ZERO ', ! bsub_bad_js1_flag + & 'RMNC N=0, M=1 IS ZERO ', ! r01_bad_value_flag + & 'ARNORM OR AZNORM EQUAL ZERO IN BCOVAR ' ! arz_bad_value_flag + & /) + CHARACTER(LEN=*), PARAMETER :: + & Warning = " Error deallocating global memory FILEOUT" + LOGICAL :: lwrite, loutput, lterm + REAL(dp) :: tmpxc, rmssum +C----------------------------------------------- + + INFILEOUT=.TRUE. + + lu => czmn; lv => crmn + +! +! COMPUTE REMAINING COVARIANT COMPONENT OF B (BSUBS), +! CYLINDRICAL COMPONENTS OF B (BR, BPHI, BZ), AND +! AVERAGE EQUILIBRIUM PROPERTIES AT END OF RUN +! + + iequi = 1 + lterm = ier_flag .eq. norm_term_flag .or. + & ier_flag .eq. successful_term_flag + lwrite = lterm .or. ier_flag.eq.more_iter_flag + loutput = (IAND(ictrl_flag, output_flag) .ne. 0) + loc_ier_flag = ier_flag + if (ier_flag .eq. successful_term_flag) THEN + loc_ier_flag = norm_term_flag + end if + + IF (lwrite .AND. loutput) THEN +! +! The sign of the jacobian MUST multiply phi to get the physically +! correct toroidal flux +! + phi(1) = zero + DO js = 2, ns + phi(js) = phi(js-1) + phip(js) + END DO + phi = (signgs*twopi*hs)*phi + +! Must save irst value if in "restart" mode + irst0 = irst + CALL funct3d (lscreen, istat) + fo_funct3d_time = timer(tfun) + + +! Write out any special files here +! CALL dump_special + + irst = irst0 + + ALLOCATE(br_out(nrzt), bz_out(nrzt), stat=istat) + gc = xc +#ifdef _HBANGLE + CALL getrz(gc) +#endif + CALL eqfor(br_out, bz_out, clmn, blmn, rcon(1,1), + & gc, ier_flag) + END IF + +! CALL free_mem_precon +! +! Call WROUT to write output or error message if lwrite = false +! + + IF (loutput .AND. ASSOCIATED(bzmn_o)) THEN + CALL wrout(bzmn_o, azmn_o, clmn, blmn, crmn_o, czmn_e, + & crmn_e, xsave, gc, loc_ier_flag, lwrite +#ifdef _ANIMEC + & ,brmn_o, sigma_an, ppar, pperp, onembc, pp1, pp2, + & pp3 +#endif + & ) + + IF (ntor .EQ. 0) THEN + CALL write_dcon (xc) + END IF + + IF (lscreen .and. ier_flag.ne.more_iter_flag) + & PRINT 120, TRIM(werror(loc_ier_flag)) + IF (lscreen .and. lterm) THEN + IF (grank.EQ.0) THEN + PRINT 10, TRIM(input_extension), ijacob + END IF + END IF + + IF (nthreed .gt. 0) THEN + WRITE (nthreed,120) TRIM(werror(loc_ier_flag)) + IF (.not. lterm) GOTO 1000 + WRITE (nthreed, 10) TRIM(input_extension), ijacob + IF (rank.EQ.0) THEN + CALL write_times(nthreed, lscreen, lfreeb, lrecon, + & ictrl_prec2d .ne. 0) + + IF (grank.EQ.0) THEN + WRITE(nthreed,*) + WRITE(nthreed,'(1x,a,i4)') 'NO. OF PROCS: ',gnranks + WRITE(nthreed,101) 'PARVMEC : ',PARVMEC + WRITE(nthreed,101) 'LPRECOND : ',LPRECOND + WRITE(nthreed,101) 'LV3FITCALL : ',LV3FITCALL + END IF + 101 FORMAT(1x,a,l4) + END IF + END IF + END IF + + 10 FORMAT(' FILE : ',a,/,' NUMBER OF JACOBIAN RESETS = ',i4,/) + 120 FORMAT(/1x,a,/) + +! +! TESTING READ_WOUT MODULE WRITING ROUTINES +! + IF (ALLOCATED(br_out)) THEN +! IF (lscreen) CALL TestWout(xc, br_out, bz_out, crmn_e, czmn_e) + DEALLOCATE (br_out, bz_out) + END IF + +! END TEST + + 1000 CONTINUE + +! +! DEALLOCATE GLOBAL MEMORY AND CLOSE FILES +! + IF (IAND(ictrl_flag, cleanup_flag) .eq. 0 .or. + & ier_flag .eq. more_iter_flag) THEN + RETURN + END IF + + IF (ALLOCATED(cosmu)) + & DEALLOCATE(cosmu, sinmu, cosmum, sinmum, cosmui, cosmumi, + & sinmui, sinmumi, cosnv, sinnv, cosnvn, sinnvn, + & cosmui3, cosmumi3, cos01, sin01, stat=istat1) + IF (istat1 .ne. 0) PRINT *, Warning // "#1" +#ifdef _HBANGLE + CALL free_multipliers +#endif + + IF (ALLOCATED(xm)) DEALLOCATE (xm, xn, ixm, xm_nyq, xn_nyq, + & jmin3, mscale, nscale, uminus, stat=istat1) + IF (istat1 .ne. 0) PRINT *, Warning // "#2" + + IF (ALLOCATED(tanu)) + & DEALLOCATE(tanu, tanv, sinper, cosper, sinuv, cosuv, sinu, + & cosu, sinv, cosv, sinui, cosui, cmns, csign, sinu1, + & cosu1, sinv1, cosv1, imirr, xmpot, xnpot, + & stat=istat1) + IF (istat1 .ne. 0) PRINT *, Warning // "#3" + + CALL free_mem_funct3d + CALL free_mem_ns (lreset_xc) + CALL free_mem_nunv + CALL free_persistent_mem + + CALL close_all_files + + END SUBROUTINE fileout +!------------------------------------------------ diff --git a/Sources/Input_Output/freeb_data.f b/Sources/Input_Output/freeb_data.f new file mode 100644 index 0000000..ad307e9 --- /dev/null +++ b/Sources/Input_Output/freeb_data.f @@ -0,0 +1,151 @@ + SUBROUTINE freeb_data (rmnc, zmns, rmns, zmnc, bmodmn, bmodmn1) + USE vmec_main + USE vacmod + USE realspace, ONLY: r1, z1 + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(mnmax) :: rmnc, zmns, rmns, zmnc, + 1 bmodmn, bmodmn1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: iprint, nzskip, i, l, k, lk, mn, + 1 mn0, n, nedge, nedge0 = 99, iu, iv, nl, lkr + REAL(rprec) :: zeta, potsin, potcos + REAL(rprec), ALLOCATABLE, DIMENSION(:) :: rb, phib, zb +C----------------------------------------------- +! +! WRITE OUT EDGE VALUES OF FIELDS TO FORT.NEDGE0 (INCLUDE REFLECTED POINT) +! +! NOTE: BR, BPHI, BZ WERE COMPUTED IN BSS, CALLED FROM EQFOR +! + IF (ivac.le.0 .or. (.not.lfreeb .and. .not.ledge_dump)) RETURN + + ALLOCATE (rb(2*nznt), phib(2*nznt), zb(2*nznt), stat=l) + IF (l .ne. 0) STOP 'allocation error in freeb_data' + + nedge = 0 + lkr = nznt + DO iv = 1,nzeta + zeta = (twopi*(iv-1))/(nzeta*nfp) + DO iu = 1,ntheta3 + lk = iv + nzeta*(iu-1) + nl = ns*lk + nedge = nedge+1 + rb(lk) = r1(nl,0) + r1(nl,1) + phib(lk) = zeta + zb(lk) = z1(nl,0) + z1(nl,1) +! +! INCLUDE -u,-v POINTS HERE BY STELLARATOR SYMMETRY +! + IF (.not.lasym .and. (iu.ne.1 .and. iu.ne.ntheta2)) THEN + lkr = lkr + 1 + nedge = nedge+1 + rb(lkr) = rb(lk) + phib(lkr) =-phib(lk) + zb(lkr) =-zb(lk) + bredge(lkr) = -bredge(lk) + bpedge(lkr) = bpedge(lk) + bzedge(lkr) = bzedge(lk) + ENDIF + END DO + END DO + + IF (ledge_dump) THEN + WRITE(NEDGE0,*) 'INPUT FILE = ',arg1 + WRITE(NEDGE0,*) 'NEDGE = ',nedge + WRITE(NEDGE0,*) 'RB = ', (rb(i), i=1,nedge) + WRITE(NEDGE0,*) 'PHIB = ',(phib(i), i=1,nedge) + WRITE(NEDGE0,*) 'ZB = ', (zb(i), i=1,nedge) + WRITE(NEDGE0,*) 'BREDGE = ', (bredge(i), i=1,nedge) + WRITE(NEDGE0,*) 'BPEDGE = ', (bpedge(i), i=1,nedge) + WRITE(NEDGE0,*) 'BZEDGE = ', (bzedge(i), i=1,nedge) + END IF + +! +! WRITE OUT (TO THREED1 FILE) VACUUM INFORMATION +! + + IF (.not.lfreeb) THEN + DEALLOCATE (rb, phib, zb, stat=l) + RETURN + END IF + + DO iprint = 1, 2 + IF (iprint .eq. 1) WRITE (nthreed, 750) + IF (iprint .eq. 2) WRITE (nthreed, 760) + nzskip = 1 + nzeta/6 + DO l = 1, nzeta, nzskip + zeta = (360.0_dp*(l - 1))/nzeta + IF (iprint .eq. 1) THEN + DO k = 1, ntheta2 + lk = l + nzeta*(k - 1) + WRITE (nthreed, 770) zeta, rb(lk), + 1 zb(lk), (bsqsav(lk,n),n=1,3), bsqvac(lk) + END DO + ELSE + DO k = 1, ntheta2 + lk = l + nzeta*(k - 1) + WRITE (nthreed, 780) zeta, rb(lk), zb(lk), + 1 bredge(lk), bpedge(lk), bzedge(lk), + 2 brv(lk), bphiv(lk), bzv(lk) + END DO + ENDIF + END DO + END DO + + DEALLOCATE (rb, phib, zb, bredge, bpedge, bzedge, stat=l) + + IF (lasym) THEN + WRITE (nthreed, 900) + DO mn = 1, mnmax + potsin = 0; potcos = 0 + DO mn0 = 1, mnpd + IF ( (NINT(xnpot(mn0)).eq.NINT(xn(mn))) .and. + 1 (NINT(xmpot(mn0)).eq.NINT(xm(mn))) ) THEN + potsin = potvac(mn0) + potcos = potvac(mn0+mnpd) + EXIT + END IF + END DO + WRITE (nthreed, 910) NINT(xn(mn)/nfp), NINT(xm(mn)), rmnc(mn), + 1 zmns(mn), rmns(mn), zmnc(mn), potsin, potcos, + 2 bmodmn(mn), bmodmn1(mn) + END DO + + ELSE + WRITE (nthreed, 800) + DO mn = 1, mnmax + potsin = 0 + DO mn0 = 1, mnpd + IF ( (NINT(xnpot(mn0)).eq.NINT(xn(mn))) .and. + 1 (NINT(xmpot(mn0)).eq.NINT(xm(mn))) ) THEN + potsin = potvac(mn0) + EXIT + END IF + END DO + WRITE (nthreed, 810) NINT(xn(mn)/nfp), NINT(xm(mn)), + 1 rmnc(mn), zmns(mn), potsin, bmodmn(mn), bmodmn1(mn) + END DO + END IF + + WRITE (nthreed, *) + + 750 FORMAT(/,3x,'NF*PHI',7x,' Rb ',8x,' Zb ',6x,'BSQMHDI',5x,'BSQVACI' + 1 ,5x,'BSQMHDF',5x,'BSQVACF',/) + 760 FORMAT(/,3x,'NF*PHI',7x,' Rb ',8x,' Zb ',6x,'BR',8x,'BPHI',6x,'BZ' + 1 ,8x,'BRv',7x,'BPHIv',5x,'BZv',/) + 770 FORMAT(1p,e10.2,6e12.4) + 780 FORMAT(1p,e10.2,2e12.4,6e10.2) + 790 FORMAT(i5,/,(1p,3e12.4)) + 800 FORMAT(//,3x,'nb',2x,'mb',6x,'rbc',9x,'zbs',6x,'vacpot_s', + 1 2x, '|B|_c(s=.5)',1x,'|B|_c(s=1.)'/) + 810 FORMAT(i5,i4,1p,7e12.4) + 900 FORMAT(//,3x,'nb',2x,'mb',6x,'rbc',9x,'zbs',9x,'rbs',9x,'zbc', + 1 6x,'vacpot_s',4x,'vacpot_c',2x,'|B|_c(s=.5)', + 2 1x,'|B|_c(s=1.)'/) + 910 FORMAT(i5,i4,1p,10e12.4) + + END SUBROUTINE freeb_data diff --git a/Sources/Input_Output/fsym_fft.f b/Sources/Input_Output/fsym_fft.f new file mode 100644 index 0000000..1f06de9 --- /dev/null +++ b/Sources/Input_Output/fsym_fft.f @@ -0,0 +1,74 @@ + SUBROUTINE fext_fft (bout, bs_s, bs_a) + USE vmec_main + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(nzeta,ntheta3), INTENT(out) :: bout + REAL(rprec), DIMENSION(nzeta,ntheta2), INTENT(in) :: bs_s, bs_a +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ir, i, kz, kzr +C----------------------------------------------- +! +! Extends bs from ntheta2 interval to full ntheta3 interval in angle u +! bs_s ~ cos(mu-nv) (symmetric); bs_a ~ sin(mu-nv) (anti-symmetric) +! ntheta2 = pi +! + bout(:,1:ntheta2) = bs_s(:,1:ntheta2) + bs_a(:,1:ntheta2) + DO i = 1+ntheta2, ntheta3 + ir = ntheta1+2-i !-theta + DO kz= 1, nzeta +! kzr = ireflect(kz*ns)/ns !-zeta + kzr = nzeta+2-kz + IF (kz .eq. 1) kzr = 1 + bout(kz,i) = bs_s(kzr,ir) - bs_a(kzr,ir) + END DO + END DO + + END SUBROUTINE fext_fft + + + SUBROUTINE fsym_fft (bs, bu, bv, bs_s, bu_s, bv_s, + 1 bs_a, bu_a, bv_a) + USE vmec_main + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(nzeta,ntheta3), INTENT(in) :: bs + REAL(rprec), DIMENSION(nzeta,ntheta3,0:1), INTENT(in) :: bu, bv + REAL(rprec), DIMENSION(nzeta,ntheta2,0:1), INTENT(out) :: + 1 bu_s, bv_s, bu_a, bv_a + REAL(rprec), DIMENSION(nzeta,ntheta2) :: bs_s, bs_a +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ir, i, kz, kzr +C----------------------------------------------- +! CONTRACTS bs,bu,bv FROM FULL nu INTERVAL TO HALF-U INTERVAL +! SO COS,SIN INTEGRALS CAN BE PERFORMED ON HALF-U INTERVAL +! +! bs_s(v,u) = .5*( bs(v,u) - bs(-v,-u) ) ! * SIN(mu - nv) +! bs_a(v,u) = .5*( bs(v,u) + bs(-v,-u) ) ! * COS(mu - nv) +! +! bu, bv have opposite parity +! + DO i = 1, ntheta2 + ir = ntheta1+2-i !-theta + IF (i == 1) ir = 1 + DO kz = 1, nzeta +! kzr = ireflect(ns*kz)/ns !-zeta + kzr = nzeta+2-kz + IF (kz .eq. 1) kzr = 1 + bs_a(kz,i) = cp5*(bs(kz,i)+bs(kzr,ir)) + bs_s(kz,i) = cp5*(bs(kz,i)-bs(kzr,ir)) + bu_a(kz,i,:) = cp5*(bu(kz,i,:)-bu(kzr,ir,:)) + bu_s(kz,i,:) = cp5*(bu(kz,i,:)+bu(kzr,ir,:)) + bv_a(kz,i,:) = cp5*(bv(kz,i,:)-bv(kzr,ir,:)) + bv_s(kz,i,:) = cp5*(bv(kz,i,:)+bv(kzr,ir,:)) + END DO + END DO + + END SUBROUTINE fsym_fft diff --git a/Sources/Input_Output/fsym_invfft.f b/Sources/Input_Output/fsym_invfft.f new file mode 100644 index 0000000..d519025 --- /dev/null +++ b/Sources/Input_Output/fsym_invfft.f @@ -0,0 +1,31 @@ + SUBROUTINE fsym_invfft (bsubsu, bsubsv) + USE vmec_main, ONLY: rprec, ns, nzeta, ntheta1, ntheta2, + 1 ntheta3, ireflect + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(ns*nzeta,ntheta3,0:1), + 1 INTENT(inout) :: bsubsu, bsubsv +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ir, i, jkz, jkr +C----------------------------------------------- +! +! EXTENDS FUNCTION FROM ntheta2 to ntheta3 range +! ASSUMES bsubsu,v(0) ~ cos(mu-nv) bsubsu,v(1) ~ sin(mu-nv) +! + DO i = 1+ntheta2, ntheta1 + ir = ntheta1+2-i !-theta + DO jkz= 1, ns*nzeta + jkr = ireflect(jkz) !-zeta + bsubsu(jkz,i,0) = bsubsu(jkr,ir,0) - bsubsu(jkr,ir,1) + bsubsv(jkz,i,0) = bsubsv(jkr,ir,0) - bsubsv(jkr,ir,1) + END DO + END DO + + bsubsu(:,:ntheta2,0)=bsubsu(:,:ntheta2,0) + bsubsu(:,:ntheta2,1) + bsubsv(:,:ntheta2,0)=bsubsv(:,:ntheta2,0) + bsubsv(:,:ntheta2,1) + + END SUBROUTINE fsym_invfft diff --git a/Sources/Input_Output/getbrho.f b/Sources/Input_Output/getbrho.f new file mode 100644 index 0000000..6d062fd --- /dev/null +++ b/Sources/Input_Output/getbrho.f @@ -0,0 +1,208 @@ + SUBROUTINE getbsubs (bsubsmn, frho, bsupu, bsupv, mmax, + 1 nmax, info) + USE stel_kinds + USE vmec_input, ONLY: nfp, nzeta, lasym + USE vmec_dim, ONLY: ntheta1, ntheta2, ntheta3 + USE vmec_persistent, ONLY: cosmu, sinmu, cosnv, sinnv + USE vmec_main, ONLY: r0scale + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: mmax, nmax + INTEGER, INTENT(out) :: info + REAL(rprec), INTENT(out) :: bsubsmn(0:mmax, -nmax:nmax, 0:1) + REAL(rprec), DIMENSION(nzeta, ntheta3), INTENT(in) :: + 1 bsupu, bsupv, frho +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: p5 = 0.5_dp, one = 1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, j, m, n, nmax1, itotal, ijtot, mntot + REAL(rprec) :: ccmn, ssmn, csmn, scmn, dm, dn, termsc, termcs, + ` termcc, termss, amn + REAL(rprec), ALLOCATABLE :: amatrix(:,:), save_matrix(:,:), + 1 brhs(:) + LOGICAL :: lpior0 + EXTERNAL solver +C----------------------------------------------- +! +! Solves the radial force balance B dot bsubs = Fs for bsubs in real space using collocation +! Here, Fs = frho(mn) is the Fourier transform SQRT(g)*F (part of radial force +! balance sans the B dot bsubs term) +! +! Storage layout: bsubsmn(0:mmax, 0:nmax,0) :: coefficient of sin(mu)cos(nv) +! bsubsmn(0:mmax,-1:nmax,0) :: coefficient of cos(mu)sin(nv) +! for lasym = T +! bsubsmn(0:mmax, 0:nmax,1) :: coefficient of cos(mu)cos(nv) +! bsubsmn(0:mmax,-1:nmax,1) :: coefficient of sin(mu)sin(nv) +! +! where 0<=m<=mmax and 0<=n<=nmax +! + info = -3 + IF ((mmax+1 .ne. ntheta2) .or. (nmax .ne. nzeta/2)) RETURN + + nmax1 = MAX(0,nmax-1) + itotal = ntheta3*nzeta + IF (.not.lasym) itotal = itotal - 2*nmax1 + ALLOCATE (amatrix(itotal, itotal), + 1 brhs(itotal), save_matrix(itotal, itotal), stat=m) + IF (m .ne. 0) STOP 'Allocation error in getbsubs' + + amatrix = 0 + +! +! bsubs = BSC(M,N)*SIN(MU)COS(NV) + BCS(M,N)*COS(MU)SIN(NV) +! + BCC(M,N)*COS(MU)COS(NV) + BSS(M,N)*SIN(MU)SIN(NV) (LASYM=T ONLY) +! + + ijtot = 0 + brhs = 0 + + DO i = 1, ntheta3 + DO j = 1, nzeta +! IGNORE u=0,pi POINTS FOR v > pi: REFLECTIONAL SYMMETRY + lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1)) + IF (lpior0 .and. .not. lasym) CYCLE + ijtot = ijtot + 1 + brhs(ijtot) = frho(j,i) + mntot = 0 + DO m = 0, mmax + DO n = 0, nmax + IF (mntot .ge. itotal) EXIT + IF (m.eq.0 .and. n.eq.0 .and. lasym) CYCLE + mntot = mntot+1 + ccmn = cosmu(i,m)*cosnv(j,n) + ssmn = sinmu(i,m)*sinnv(j,n) + dm = m * bsupu(j,i) + dn = n * bsupv(j,i) * nfp + termsc = dm*ccmn - dn*ssmn + termcs =-dm*ssmn + dn*ccmn + IF (n.eq.0 .or. n.eq.nmax) THEN + IF (m .gt. 0) THEN + amatrix(ijtot,mntot) = termsc !!ONLY bsc != 0 for n=0, nmax1 + ELSE IF (n .eq. 0) THEN + amatrix(ijtot,mntot) = bsupv(j,i) !!pedestal for m=0,n=0 mode, which should = 0 + ELSE + amatrix(ijtot,mntot) = termcs !!bcs(m=0,n=nmax) + END IF + ELSE IF (m.eq.0 .or. m.eq.mmax) THEN + amatrix(ijtot,mntot) = termcs !!ONLY bcs != 0 for m=0,mmax + ELSE + amatrix(ijtot,mntot) = termsc + mntot = mntot+1 + amatrix(ijtot,mntot) = termcs + END IF + + IF (.not.lasym) CYCLE + IF (m.eq.0 .and. (n.eq.0 .or. n.eq.nmax)) CYCLE + + IF (mntot .ge. itotal) EXIT + mntot = mntot+1 + csmn = cosmu(i,m)*sinnv(j,n) + scmn = sinmu(i,m)*cosnv(j,n) + termcc =-dm*scmn - dn*csmn + termss = dm*csmn + dn*scmn + + IF ((n.eq.0 .or. n.eq.nmax) .or. + 1 (m.eq.0 .or. m.eq.mmax)) THEN + amatrix(ijtot,mntot) = termcc !!ONLY bcc != 0 for m=0 or mmax + ELSE + amatrix(ijtot,mntot) = termcc + mntot = mntot+1 + amatrix(ijtot,mntot) = termss + END IF + + END DO + END DO + END DO + END DO + + save_matrix = amatrix + + info = -1 + IF (ijtot .ne. itotal .or. mntot .ne. itotal) THEN + PRINT *,' itotal = ', itotal,' ijtot = ', ijtot, + 1 ' mntot = ', mntot + PRINT *,' ntheta3: ',ntheta3,' nzeta: ', nzeta, + 1 ' mnyq: ', mmax,' nnyq: ', nmax + GOTO 200 + ELSE + CALL solver (amatrix, brhs, itotal, 1, info) + IF (info .ne. 0) GOTO 200 + END IF + +! +! CHECK SOLUTION FROM SOLVER +! +! GOTO 100 + ijtot = 0 + DO i = 1, ntheta3 + DO j = 1, nzeta + lpior0 = ((i.eq.1 .or. i.eq.ntheta2) .and. (j.gt.nzeta/2+1)) + IF (lpior0 .and. .not.lasym) CYCLE + ijtot = ijtot + 1 + amn = SUM(save_matrix(ijtot,:)*brhs(:)) + IF (ABS(amn) .lt. 1.E-12_dp) CYCLE + IF (ABS(frho(j,i) - amn) .gt. 1.e-8_dp*ABS(amn)) THEN + PRINT 50,'In GETbsubs, i = ',i,' j = ',j, + 1 ' Original force = ', frho(j,i),' Final force = ', amn + END IF + END DO + END DO + 50 FORMAT(a,i5,a,i5,a,1p,e10.3,a,1p,e10.3) + 100 CONTINUE +! +! CONVERT BACK TO BS*SIN(MU - NV) REPRESENTATION +! AND (FOR lasym) BC*COS(MU - NV) +! + mntot = 0 + bsubsmn = 0 + DO m = 0, mmax + DO n = 0, nmax + IF (mntot .ge. itotal) EXIT + IF (m.eq.0 .and. n.eq.0 .and. lasym) CYCLE + mntot = mntot+1 + IF (n.eq.0 .or. n.eq.nmax) THEN + IF (m .gt. 0) THEN + bsubsmn(m,n,0) = brhs(mntot) + ELSE IF (n .eq. 0) THEN + bsubsmn(m,n,0) = brhs(mntot) + ELSE + bsubsmn(m,-n,0) = brhs(mntot) + END IF + ELSE IF (m.eq.0 .or. m.eq.mmax) THEN + bsubsmn(m,-n,0) = brhs(mntot) + ELSE + bsubsmn(m,n,0) = brhs(mntot) + mntot = mntot+1 + bsubsmn(m,-n,0) = brhs(mntot) + END IF + + IF (.not.lasym) CYCLE + IF (m.eq.0 .and. (n.eq.0 .or. n.eq.nmax)) CYCLE + IF (mntot .ge. itotal) EXIT + mntot = mntot+1 + + IF ((n.eq.0 .or. n.eq.nmax) .or. + 1 (m.eq.0 .or. m.eq.mmax)) THEN + bsubsmn(m,n,1) = brhs(mntot) + ELSE + bsubsmn(m,n,1) = brhs(mntot) + mntot = mntot+1 + bsubsmn(m,-n,1)= brhs(mntot) + END IF + + END DO + END DO + + IF (mntot .ne. ijtot) info = -2 + + 200 CONTINUE + + DEALLOCATE (amatrix, save_matrix, brhs) + + END SUBROUTINE getbsubs diff --git a/Sources/Input_Output/getcurmid.f b/Sources/Input_Output/getcurmid.f new file mode 100644 index 0000000..3704181 --- /dev/null +++ b/Sources/Input_Output/getcurmid.f @@ -0,0 +1,31 @@ + SUBROUTINE getcurmid (curmid, izeta, gsqrt, r12) + USE vmec_input, ONLY: rprec, dp, nzeta + USE vmec_dim, ONLY: ns, ns1, ntheta2 +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec) :: curmid(2*ns) + REAL(rprec) :: izeta(ns,nzeta,*), gsqrt(ns,nzeta,*), + 1 r12(ns,nzeta,*) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec) :: midcur(ns) +C----------------------------------------------- +! THETA = pi, PHI = 0 + midcur(2:ns) = r12(2:ns,1,ntheta2)/gsqrt(2:ns,1,ntheta2) + + curmid(1) = izeta(ns,1,ntheta2)*midcur(ns) + curmid(2:ns1) = 0.5_dp*izeta(ns1:2:-1,1,ntheta2)* + 1 (midcur(ns1:2:-1) + midcur(ns:3:-1)) + +! THETA = 0, PHI = 0 + midcur(2:ns) = r12(2:ns,1,1)/gsqrt(2:ns,1,1) + + curmid(ns+1:2*ns-1) = 0.5_dp*izeta(2:ns1,1,1)* + 1 (midcur(2:ns1) + midcur(3:ns)) + + curmid(ns) = 0.5_dp*(curmid(ns-1) + curmid(ns+1)) + curmid(2*ns) = 2*curmid(2*ns-1) - curmid(2*ns-2) + + END SUBROUTINE getcurmid diff --git a/Sources/Input_Output/jxbforce.f b/Sources/Input_Output/jxbforce.f new file mode 100644 index 0000000..30105c2 --- /dev/null +++ b/Sources/Input_Output/jxbforce.f @@ -0,0 +1,820 @@ + SUBROUTINE jxbforce(bsupu, bsupv, bsubu, bsubv, bsubs, bsubsu, + 1 bsubsv, gsqrt, bsq, itheta, izeta, brho, sigma_an, ier_flag +#ifdef _ANIMEC + 2 ,pp1, pp2, ppar, onembc +#endif + 3 ) + USE safe_open_mod + USE vmec_main + USE vmec_params, ONLY: mscale, nscale, signgs, mnyq, nnyq, + 1 successful_term_flag + USE realspace, ONLY: shalf, wint, guu, guv, gvv, r1, ru, rv, + 1 zu , zv , phip +#ifdef _ANIMEC + 2 ,pp3 + USE fbal, ONLY: bimax_ppargrad +#endif +#ifdef NETCDF + USE ezcdf +#endif + USE xstuff, ONLY: xc + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(rprec), DIMENSION(ns,nznt), INTENT(in) :: + 1 bsupu, bsupv, bsq, gsqrt, sigma_an +#ifdef _ANIMEC + 2 ,ppar, onembc +#endif + REAL(rprec), DIMENSION(ns,nznt,0:1), TARGET, INTENT(inout) :: + 1 bsubu, bsubv + REAL(rprec), DIMENSION(ns,nznt), INTENT(inout), TARGET :: bsubs + REAL(rprec), DIMENSION(ns,nznt), INTENT(out) :: + 1 itheta, brho, izeta +#ifdef _ANIMEC + 1 ,pp1, pp2 +#endif + REAL(rprec), DIMENSION(ns,nznt,0:1) :: bsubsu, bsubsv + INTEGER, INTENT(in) :: ier_flag +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- +!RESET lbsubs DEFAULT FLAG TO FALSE TO CAPTURE CURRENT SHEETS! +! LOGICAL, PARAMETER :: lbsubs = .false. !!False to use (correct) bsubs calculation (from metrics) + !!True to use (modified) bsubs calculation (from mag. diff. eq.) +! J Hanson 2014-01-12. Commented out above line. Variable is now declared +! in module vmec_input, available here through module vmec_main. +! lbsubs is now a namelist input variable, so user can change. +! LOGICAL, PARAMETER :: lbsubs = .true. !!True to use NEW bsubs calculation (from mag. diff. eq.) +! !!False to use OLD bsubs calculation (from metrics) + LOGICAL, PARAMETER :: lprint = .false. !!Prints out bsubs spectrum to fort.33 + REAL(rprec), PARAMETER :: two=2, p5=0.5_dp, c1p5=1.5_dp +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER lk, lz, lt, k, m, js, j, n, injxbout, mparity, nznt1 + INTEGER :: njxbout = jxbout0, nmin, info + INTEGER, PARAMETER :: ns_skip = 1, nu_skip = 1, nv_skip = 1 + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: + 1 bdotk, bsubuv, bsubvu + REAL(rprec), DIMENSION(:,:,:,:), ALLOCATABLE :: bsubsmn + REAL(rprec), DIMENSION(:,:,:), ALLOCATABLE :: brhomn, + 1 bsubs3, bsubv3, bsubu3, jxb_gradp, jcrossb, sqrtg3, + 2 bsupv3, bsupu3, jsups3, jsupv3, jsupu3, jdotb_sqrtg + REAL(rprec), POINTER :: bs1(:), bu1(:,:), bv1(:,:) + REAL(rprec), DIMENSION(:), ALLOCATABLE :: kperpu, kperpv, + 2 sqgb2, sqrtg, kp2, jxb, jxb2, bsupu1, bsupv1, bsubu1, bsubv1, + 3 avforce, aminfor, amaxfor, toroidal_angle, phin, pprim, pprime + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: bsubua, bsubva + REAL(rprec) :: + 1 bsubsmn1, bsubsmn2, bsubvmn1, bsubvmn2, bsubumn1, bsubumn2, + 1 bsubsmn3, bsubsmn4, bsubvmn3, bsubvmn4, bsubumn3, bsubumn4, + 2 dnorm1, tcos1, tcos2, tsini1, tsini2, tcosi1, tcosi2, + 3 tcosm1, tcosm2, tcosn1, tcosn2, tsinm1, tsinm2, tsin1, tsin2, + 4 tsinn1, tsinn2, tjnorm, ovp, pnorm, brho00(ns) + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: + 1 bsubu_s, bsubu_a, bsubv_s, bsubv_a + REAL(rprec), DIMENSION(:), ALLOCATABLE :: + 1 bsubs_s, bsubs_a + CHARACTER(LEN=100) :: jxbout_file + CHARACTER(LEN=100) :: legend(13) + LOGICAL :: lprint_flag +!----------------------------------------------- +#ifdef NETCDF + CHARACTER(LEN=*), PARAMETER :: + 1 vn_legend = 'legend', + 1 vn_radial_surfaces = 'radial_surfaces', + 1 vn_poloidal_grid_points = 'poloidal_grid_points', + 1 vn_toroidal_grid_points = 'toroidal_grid_points', + 1 vn_mpol = 'mpol', + 1 vn_ntor = 'ntor', + 1 vn_phin = 'phin', + 1 vn_toroidal_angle = 'toroidal_angle', + 1 vn_avforce = 'avforce', + 1 vn_jdotb = 'surf_av_jdotb', + 1 vn_sqg_bdotk = 'sqrt(g)*bdotk', + 1 vn_sqrtg = 'sqrt(g)', + 1 vn_bdotgradv = 'bdotgradv', + 1 vn_amaxfor = 'amaxfor', + 1 vn_aminfor = 'aminfor', + 1 vn_pprime = 'pprime', + 1 vn_jsupu = 'jsupu', + 1 vn_jsupv = 'jsupv', + 1 vn_jsups = 'jsups', + 1 vn_bsupu = 'bsupu', + 1 vn_bsupv = 'bsupv', + 1 vn_jcrossb = 'jcrossb', + 1 vn_jxb_gradp = 'jxb_gradp', + 1 vn_bsubu = 'bsubu', + 1 vn_bsubv = 'bsubv', + 1 vn_bsubs = 'bsubs' +!----------------------------------------------- +#endif + lprint_flag = (ier_flag.eq.successful_term_flag) + IF (lprint_flag) THEN +#ifdef NETCDF + jxbout_file = 'jxbout_'//TRIM(input_extension)//'.nc' + + CALL cdf_open(njxbout,jxbout_file,'w',injxbout) +#else + jxbout_file = 'jxbout.'//TRIM(input_extension)//'.txt' + CALL safe_open(njxbout, injxbout, jxbout_file, 'replace', + 1 'formatted') +#endif +#if !defined(_ANIMEC) + IF (ANY(sigma_an .NE. one)) STOP 'SIGMA_AN != 1' +#endif + IF (injxbout .ne. 0) THEN + PRINT *,' Error opening JXBOUT file in jxbforce' + RETURN + END IF + +! PROGRAM FOR COMPUTING LOCAL KXB = grad-p FORCE BALANCE +! +! sigma_an = one + (pperp-ppar)/(2*bsq(1:nrzt)) (=1 for isotropic pressure) +! K = CURL(sigma_an B) is the "effective" current (=J for isotropic pressure) +! Compute u (=theta), v (=zeta) derivatives of B sub s +! + legend(1) = " S = normalized toroidal flux (0 - 1)" + IF (lasym) THEN + legend(2) = " U = VMEC poloidal angle (0 - 2*pi, FULL period)" + ELSE + legend(2) = " U = VMEC poloidal angle (0 - pi, HALF a period)" + END IF + legend(3) = " V = VMEC (geometric) toroidal angle (0 - 2*pi)" + legend(4) = " SQRT(g') = |SQRT(g-VMEC)| / VOL':" // + 1 " Cylindrical-to-s,u,v Jacobian normed to volume derivative" + legend(5) = " VOL = Int_s'=0,s Int_u Int_v |SQRT(g_VMEC)| :" // + 1 " plasma volume enclosed by surface s'=s" + legend(6) = " VOL' = d(VOL)/ds: differential volume element" + legend(7) = " Es = SQRT(g') [grad(U) X grad(V)] : covariant" // + 1 " radial unit vector (based on volume radial coordinate)" + legend(8) = " BSUP{U,V} = sigma_an B DOT GRAD{U,V}:" // + 1 " contravariant components of B" + legend(9) = " JSUP{U,V} = SQRT(g') J DOT GRAD{U,V}" + legend(10)= + 1 " K X B = Es DOT [K X B]: covariant component of K X B force" + legend(11)= " K * B = K DOT B * SQRT(g')" + legend(12)= " p' = dp/d(VOL): pressure gradient (based on" // + 1 " volume radial coordinate)" + legend(13)= " = Int_u Int_v [KSUP{U,V}]/dV/ds" + +#if !defined(NETCDF) + WRITE (njxbout,5) (ns1-1)/ns_skip, ntheta3/nu_skip, nzeta/nv_skip, + 1 mpol, ntor, phiedge + 5 FORMAT(/,' Radial surfaces = ',i3, ' Poloidal grid points = ',i3, + 1 ' Toroidal grid points = ',i3,/, + 2 ' Poloidal modes = ',i3,' Toroidal modes = ', i3, + 3 ' Toroidal Flux = ',1pe12.3) + WRITE (njxbout, 6) (legend(j), j=1,13) + 6 FORMAT(/,100('-'),/,' LEGEND:',/,100('-'),/, + 1 2(3(a,/),/),5(a,/),/,2(a,/),100('-'),//) +#endif + ENDIF + + nznt1 = nzeta*ntheta2 + ALLOCATE (avforce(ns),aminfor(ns),amaxfor(ns)) + ALLOCATE (bdotk(ns,nznt), bsubuv(ns,nznt), + 1 bsubvu(ns,nznt), kperpu(nznt), kperpv(nznt), + 2 sqgb2(nznt), brhomn(0:mnyq,-nnyq:nnyq,0:1),kp2(nznt), + 3 jxb(nznt), jxb2(nznt), bsupu1(nznt), + 3 bsubua(nznt1,0:1), bsubva(nznt1,0:1), + 4 bsupv1(nznt), bsubu1(nznt), bsubv1(nznt), + 5 bsubsmn(ns,0:mnyq,-nnyq:nnyq,0:1), + 6 bsubs_s(nznt), bsubs_a(nznt), sqrtg(nznt), + 7 bsubu_s(nznt1,0:1), bsubu_a(nznt1,0:1), + 8 bsubv_s(nznt1,0:1), bsubv_a(nznt1,0:1), stat=j) + IF (j .ne. 0) STOP 'Allocation error in jxbforce' + +! +! NOTE: bsubuv, bsubvu are used to compute the radial current (should be zero) +! + bsubsu = 0; bsubsv = 0; bsubuv = 0; bsubvu = 0; bdotk = 0 + bsubs(1,:) = 0; bsubsmn = 0 + + radial: DO js = 1, ns +! +! Put bsubs on full mesh +! + IF (js.gt.1 .and. js.lt.ns) THEN + bsubs(js,:) = p5*(bsubs(js,:) + bsubs(js+1,:)) + END IF + + bsubu(js,:,1) = bsubu(js,:,1)/shalf(js) + bsubv(js,:,1) = bsubv(js,:,1)/shalf(js) + bsubua = 0; bsubva = 0 + +! _s: symmetric in u,v _a: antisymmetric in u,v on half (ntheta2) interval + IF (lasym) THEN + bs1=>bsubs(js,:); bu1=>bsubu(js,:,:); bv1=>bsubv(js,:,:) + CALL fsym_fft (bs1, bu1, bv1, bsubs_s, bsubu_s, bsubv_s, + 1 bsubs_a, bsubu_a, bsubv_a) + ELSE + bsubs_s(:) = bsubs(js,:) + bsubu_s = bsubu(js,:,:); bsubv_s = bsubv(js,:,:) + END IF + +! +! FOURIER LOW-PASS FILTER bsubX + + DO m = 0, mpol1 + mparity = MOD(m, 2) + DO n = 0, ntor +! +! FOURIER TRANSFORM +! + dnorm1 = one/r0scale**2 + IF (m .eq. mnyq) dnorm1 = p5*dnorm1 + IF (n.eq.nnyq .and. n.ne.0) dnorm1 = p5*dnorm1 + bsubsmn1 = 0; bsubsmn2 = 0 + IF (lasym) THEN + dnorm1 = 2*dnorm1 !SPH012314 in FixAray + bsubsmn3 = 0; bsubsmn4 = 0 + END IF + bsubumn1 = 0; bsubumn2 = 0; bsubvmn1 = 0; bsubvmn2 = 0 + IF (lasym) THEN + bsubumn3 = 0; bsubumn4 = 0; bsubvmn3 = 0; bsubvmn4 = 0 + END IF + + DO k = 1, nzeta + lk = k + DO j = 1, ntheta2 + tsini1 = sinmui(j,m)*cosnv(k,n)*dnorm1 + tsini2 = cosmui(j,m)*sinnv(k,n)*dnorm1 + tcosi1 = cosmui(j,m)*cosnv(k,n)*dnorm1 + tcosi2 = sinmui(j,m)*sinnv(k,n)*dnorm1 + bsubsmn1 = bsubsmn1 + tsini1*bsubs_s(lk) + bsubsmn2 = bsubsmn2 + tsini2*bsubs_s(lk) + bsubvmn1 = bsubvmn1 + tcosi1*bsubv_s(lk, mparity) + bsubvmn2 = bsubvmn2 + tcosi2*bsubv_s(lk, mparity) + bsubumn1 = bsubumn1 + tcosi1*bsubu_s(lk, mparity) + bsubumn2 = bsubumn2 + tcosi2*bsubu_s(lk, mparity) + + IF (lasym) THEN + bsubsmn3 = bsubsmn3 + tcosi1*bsubs_a(lk) + bsubsmn4 = bsubsmn4 + tcosi2*bsubs_a(lk) + bsubvmn3 = bsubvmn3 + tsini1*bsubv_a(lk, mparity) + bsubvmn4 = bsubvmn4 + tsini2*bsubv_a(lk, mparity) + bsubumn3 = bsubumn3 + tsini1*bsubu_a(lk, mparity) + bsubumn4 = bsubumn4 + tsini2*bsubu_a(lk, mparity) + END IF + + lk = lk + nzeta + + END DO + END DO + +! +! FOURIER INVERSE TRANSFORM +! Compute on u-v grid (must add symmetric, antisymmetric parts for lasym=T) +! + DO k = 1, nzeta + lk = k + DO j = 1, ntheta2 + tcos1 = cosmu(j,m)*cosnv(k,n) + tcos2 = sinmu(j,m)*sinnv(k,n) + bsubua(lk,0) = bsubua(lk,0) + tcos1*bsubumn1 + + 1 tcos2*bsubumn2 + bsubva(lk,0) = bsubva(lk,0) + tcos1*bsubvmn1 + + 1 tcos2*bsubvmn2 + + tcosm1 = cosmum(j,m)*cosnv(k,n) + tcosm2 = sinmum(j,m)*sinnv(k,n) + bsubsu(js,lk,0) = bsubsu(js,lk,0) + + 1 tcosm1*bsubsmn1 + tcosm2*bsubsmn2 + tcosn1 = sinmu(j,m)*sinnvn(k,n) + tcosn2 = cosmu(j,m)*cosnvn(k,n) + bsubsv(js,lk,0) = bsubsv(js,lk,0) + + 1 tcosn1*bsubsmn1 + tcosn2*bsubsmn2 + bsubvu(js,lk) = bsubvu(js,lk) + + 1 sinmum(j,m)*cosnv(k,n)*bsubvmn1 + + 2 cosmum(j,m)*sinnv(k,n)*bsubvmn2 + bsubuv(js,lk) = bsubuv(js,lk) + + 1 cosmu(j,m)*sinnvn(k,n)*bsubumn1 + + 2 sinmu(j,m)*cosnvn(k,n)*bsubumn2 + + IF (lasym) THEN + tsin1 = sinmu(j,m)*cosnv(k,n) + tsin2 = cosmu(j,m)*sinnv(k,n) + bsubua(lk,1) = bsubua(lk,1) + tsin1*bsubumn3 + + 1 tsin2*bsubumn4 + bsubva(lk,1) = bsubva(lk,1) + tsin1*bsubvmn3 + + 1 tsin2*bsubvmn4 + + tsinm1 = sinmum(j,m)*cosnv(k,n) + tsinm2 = cosmum(j,m)*sinnv(k,n) + bsubsu(js,lk,1) = bsubsu(js,lk,1) + + 1 tsinm1*bsubsmn3 + tsinm2*bsubsmn4 + tsinn1 = cosmu(j,m)*sinnvn(k,n) + tsinn2 = sinmu(j,m)*cosnvn(k,n) + bsubsv(js,lk,1) = bsubsv(js,lk,1) + + 1 tsinn1*bsubsmn3 + tsinn2*bsubsmn4 + bsubvu(js,lk) = bsubvu(js,lk) + + 1 cosmum(j,m)*cosnv(k,n)*bsubvmn3 + + 2 sinmum(j,m)*sinnv(k,n)*bsubvmn4 + bsubuv(js,lk) = bsubuv(js,lk) + + 1 sinmu(j,m)*sinnvn(k,n)*bsubumn3 + + 2 cosmu(j,m)*cosnvn(k,n)*bsubumn4 + END IF + + lk = lk + nzeta + + END DO + END DO + +! +! bsubsmn: coefficients of sin(mu)cos(nv), n>=0, cos(mu)sin(nv), n<0 (type=0) +! cos(mu)cos(nv), n>=0, sin(mu)sin(nv), n<0 (type=1, nonzero only for lasym=T) +! + IF (.not.lprint) CYCLE !Don't need these except for comparison + + bsubsmn(js,m,n,0) = bsubsmn1 + IF (n .gt. 0) bsubsmn(js,m,-n,0) = bsubsmn2 + + IF (.not.lasym) CYCLE + + bsubsmn(js,m,n,1) = bsubsmn3 + IF (n .gt. 0) bsubsmn(js,m,-n,0) = bsubsmn4 + + END DO + END DO + + IF (lasym) THEN +! EXTEND FILTERED bsubu, bsubv TO NTHETA3 MESH +! NOTE: INDEX 0 - COS(mu-nv) SYMMETRY; 1 - SIN(mu-nv) SYMMETRY + CALL fext_fft (bsubu(js,:,0), bsubua(:,0), bsubua(:,1)) + CALL fext_fft (bsubv(js,:,0), bsubva(:,0), bsubva(:,1)) + ELSE + bsubu(js,:,0) = bsubua(:,0) + bsubv(js,:,0) = bsubva(:,0) + END IF + + END DO radial + + DEALLOCATE (bsubua, bsubva) + +! EXTEND bsubsu, bsubsv TO NTHETA3 MESH + IF (lasym) CALL fsym_invfft (bsubsu, bsubsv) + +#ifdef _ANIMEC + CALL bimax_ppargrad(pp1, pp2, gsqrt, ppar, onembc, pres, + 1 phot,tpotb) +#endif + +! SKIPS Bsubs Correction - uses Bsubs from metric elements + IF (.not.lbsubs) GOTO 1500 + +! +! Compute corrected Bsubs coefficients (brhomn) (impacts currents) +! by solving es dot (KXB - gradp_parallel) = 0 equation for brhomn in REAL SPACE +! Can be written Bsupu d(bs)/du + Bsupv d(bs)/dv = RHS (jxb below), bs==bsubs +! brho==sigma B_s, pp1 and pp2 are the Jacobian times the hot particle parallel +! pressure radial gradient Amplitudes on the full integer mesh +! + correct_bsubs: DO js = 2, ns-1 + jxb(:) = p5*(gsqrt(js,:) + gsqrt(js+1,:)) + bsupu1(:) = p5*(bsupu(js,:)*gsqrt(js,:) + 1 + bsupu(js+1,:)*gsqrt(js+1,:)) + bsupv1(:) = p5*(bsupv(js,:)*gsqrt(js,:) + 1 + bsupv(js+1,:)*gsqrt(js+1,:)) + brho(js,:) = ohs* + 1 ( bsupu1(:)*(bsubu(js+1,:,0) - bsubu(js,:,0)) + 2 + bsupv1(:)*(bsubv(js+1,:,0) - bsubv(js,:,0))) + 3 + (pres(js+1) - pres(js))*ohs*jxb(:) +#ifdef _ANIMEC +!WAC Last two lines of brho contain hot particle parallel pressure gradients + 4 + ohs*((pres(js+1)*phot(js+1) - pres(js)*phot(js)) * pp2(js,:) + 5 + (tpotb(js+1) - tpotb(js) ) * pp1(js,:)) +#endif +! +! SUBTRACT FLUX-SURFACE AVERAGE FORCE BALANCE FROM brho, OTHERWISE +! LOCAL FORCE BALANCE EQUATION B dot grad(Bs) = brho CAN'T BE SOLVED +! + brho00(js) = SUM(brho(js,:)*wint(js:nrzt:ns)) + brho(js,:) = brho(js,:) - signgs*jxb(:)*brho00(js)/ + 1 (p5*(vp(js) + vp(js+1))) + + jxb(:) = brho(js,:) + CALL getbsubs (brhomn, jxb, bsupu1, bsupv1, mnyq, nnyq, info) + IF (info .ne. 0) THEN + PRINT *, 'Error in GETBRHO: info= ',info, ' js= ',js + ELSE IF (lprint) THEN + WRITE (33, *) ' JS = ', js + IF (lasym) THEN + WRITE (33, '(a)') + 1 ' M N BSUBS(old) BSUBS(new)' // + 2 ' BSUBS(old) BSUBS(new)' + ELSE + WRITE (33, *) ' M N BSUBS(old) BSUBS(new)' + END IF + DO m = 0, mpol1 + DO n = -ntor, ntor + IF (lasym) THEN + WRITE(33,1223) m, n, bsubsmn(js,m,n,0), brhomn(m,n,0), + 1 bsubsmn(js,m,n,1), brhomn(m,n,1) + ELSE + WRITE(33,1224) m, n, bsubsmn(js,m,n,0), brhomn(m,n,0) + END IF + END DO + END DO + END IF + 1223 FORMAT (i4,1x,i4,4(6x,1p,e12.3)) + 1224 FORMAT (i4,1x,i4,2(6x,1p,e12.3)) + +! +! Recompute bsubsu,v now using corrected bsubs +! Store old values (itheta,izeta) for checking force balance later +! + itheta(js,:) = bsubsu(js,:,0); izeta (js,:) = bsubsv(js,:,0) + + IF (info .ne. 0) CYCLE + bsubsu(js,:,:) = 0; bsubsv(js,:,:) = 0; bsubs_s = 0 + IF (lasym) bsubs_a = 0; + + DO m = 0, mnyq + DO n = 0, nnyq + IF (n .eq. 0) THEN + bsubsmn1 = brhomn(m,0,0) + bsubsmn2 = 0 + ELSE + bsubsmn1 = brhomn(m,n,0) + bsubsmn2 = brhomn(m,-n,0) + END IF + + IF (lasym) THEN + IF (n .eq. 0) THEN + bsubsmn3 = brhomn(m,0,1) + bsubsmn4 = 0 + ELSE + bsubsmn3 = brhomn(m,n,1) + bsubsmn4 = brhomn(m,-n,1) + END IF + END IF + + DO k = 1, nzeta + lk = k + DO j = 1, ntheta2 + tsin1 = sinmu(j,m)*cosnv(k,n) + tsin2 = cosmu(j,m)*sinnv(k,n) + bsubs_s(lk) = bsubs_s(lk) + tsin1*bsubsmn1 + 1 + tsin2*bsubsmn2 + tcosm1 = cosmum(j,m)*cosnv(k,n) + tcosm2 = sinmum(j,m)*sinnv(k,n) + bsubsu(js,lk,0) = bsubsu(js,lk,0) + + 1 tcosm1*bsubsmn1 + tcosm2*bsubsmn2 + tcosn1 = sinmu(j,m)*sinnvn(k,n) + tcosn2 = cosmu(j,m)*cosnvn(k,n) + bsubsv(js,lk,0) = bsubsv(js,lk,0) + + 1 tcosn1*bsubsmn1 + tcosn2*bsubsmn2 + + IF (lasym) THEN + tcos1 = cosmu(j,m)*cosnv(k,n) + tcos2 = sinmu(j,m)*sinnv(k,n) + bsubs_a(lk) = bsubs_a(lk) + tcos1*bsubsmn3 + 1 + tcos2*bsubsmn4 + tsinm1 = sinmum(j,m)*cosnv(k,n) + tsinm2 = cosmum(j,m)*sinnv(k,n) + bsubsu(js,lk,1) = bsubsu(js,lk,1) + + 1 tsinm1*bsubsmn3 + tsinm2*bsubsmn4 + tsinn1 = cosmu(j,m)*sinnvn(k,n) + tsinn2 = sinmu(j,m)*cosnvn(k,n) + bsubsv(js,lk,1) = bsubsv(js,lk,1) + + 1 tsinn1*bsubsmn3 + tsinn2*bsubsmn4 + + END IF + + lk = lk + nzeta + + END DO + END DO + END DO + END DO + + IF (lasym) THEN +! EXTEND TO FULL (ntheta3) u-GRID + bs1 => bsubs(js,:) + CALL fext_fft (bs1, bsubs_a, bsubs_s) + ELSE + bsubs(js,:) = bsubs_s(:) + END IF + + END DO correct_bsubs + +! EXTEND bsubsu, bsubsv TO NTHETA3 MESH + IF (lasym) CALL fsym_invfft (bsubsu, bsubsv) + +! +! CHECK FORCE BALANCE: SQRT(g)*(bsupu*bsubsu + bsupv*bsubsv) = brho +! + IF (.not.lprint) GOTO 1500 + + WRITE (33, '(/,2a,/)') 'ANGLE INDEX B*grad(Bs) Frhs', + 1 ' Fold' + check_fb: DO js = 2, ns-1 + bsupu1(:) = p5*(bsupu(js,:)*gsqrt(js,:) + 1 + bsupu(js+1,:)*gsqrt(js+1,:)) + bsupv1(:) = p5*(bsupv(js,:)*gsqrt(js,:) + 1 + bsupv(js+1,:)*gsqrt(js+1,:)) + kp2(:) = bsupu1(:)*bsubsu(js,:,0) + bsupv1(:)*bsubsv(js,:,0) + jxb(:) = bsupu1(:)*itheta(js,:) + bsupv1(:)*izeta(js,:) + + WRITE (33, '(/,a,i4)') 'JS = ',js + DO lk = 1, nznt + WRITE(33,1230) lk, brho(js,lk), kp2(lk), jxb(lk) + END DO + + END DO check_fb + + 1230 FORMAT (i9,5x, 1p,3e14.4) + + 1500 CONTINUE + + DEALLOCATE (bsubs_s, bsubs_a, bsubu_s, + 1 bsubu_a, bsubv_s, bsubv_a, stat=lk) + +! +! Compute end point values for bsubs +! + bsubs(1,:) = 2*bsubs(2,:) - bsubs(3,:) + bsubs(ns,:) = 2*bsubs(ns,:) - bsubs(ns-1,:) +! +! Now compute currents on the FULL radial mesh +! Here: +! +! Itheta = sqrt(g) * Ksupu +! Izeta = sqrt(g) * Ksupv +! Ksupx = K dot grad(x) x=(u,v) +! jxb = (K X B) dot (grad-u X grad-v) sqrt(g) +! bdotk = sigma*sqrt(g)*K dot B +! kperpx = (B X gradp) dot grad(x) / |B|**2 x=(u,v) +! sqgb2 = sigma*sqrt(g)*|B|**2 +! sqrtg = sqrt(g) +! pprime = d(p||)/dV +! +! kp2 == |k-perp|**2 = kperpu**2 * guu + 2*kperpu*kperpv*guv + kperpv**2 * gvv +! This was compared to the alternative expression (agreed very well): +! |j-perp|**2 = |grad-s|**2 * (dp/ds)**2 / |B|**2 +! +! Note: Multiply currents, pressure by 1/mu0 to get in mks units! +! TWOPI*TWOPI factor incorporated in vp (thru ovp factor below), so V' = (2pi)**2*vp +! +#ifdef NETCDF + ALLOCATE( + 1 bsubs3(ns,nzeta,ntheta3), bsubv3(ns,nzeta,ntheta3), + 2 bsubu3(ns,nzeta,ntheta3), jxb_gradp(ns,nzeta,ntheta3), + 3 jcrossb(ns,nzeta,ntheta3), bsupv3(ns,nzeta,ntheta3), + 4 bsupu3(ns,nzeta,ntheta3), jsups3(ns,nzeta,ntheta3), + 5 jsupv3(ns,nzeta,ntheta3), jsupu3(ns,nzeta,ntheta3), + 6 jdotb_sqrtg(ns,nzeta,ntheta3), sqrtg3(ns,nzeta,ntheta3), + 7 phin(ns), toroidal_angle(nzeta), stat=j) + + bsubs3=0; bsubv3=0; bsubu3=0; jxb_gradp=0 + jcrossb=0 ; bsupv3=0; bsupu3=0; jsups3=0 + jsupv3=0; jsupu3=0; phin=0; phin(ns)=1 + jdotb_sqrtg=0; sqrtg3=0 +#endif + + ALLOCATE (pprime(nznt), pprim(ns),stat=j) + pprim=0 + + avforce=0; aminfor=0; amaxfor=0 + dnorm1 = twopi*twopi + + DO js = 2, ns1 + ovp = two/(vp(js+1) + vp(js))/dnorm1 + tjnorm = ovp*signgs + sqgb2(:nznt) = sigma_an(js+1,:)*gsqrt(js+1,:)* + 1 (bsq(js+1,:)- pres(js+1)) + 2 + sigma_an(js,:)*gsqrt(js,:) * + 3 (bsq(js,:) - pres(js)) +#ifdef _ANIMEC + sqgb2(:nznt) = sigma_an(js+1,:nznt)*gsqrt(js+1,:nznt) + 1 * bsq(js+1,:nznt) + 2 + sigma_an(js ,:nznt)*gsqrt(js ,:nznt) + 3 * bsq(js ,:nznt) +#elif defined _FLOW +! sqgb2(:nznt) = sigma_an(js+1,:nznt)*gsqrt(js+1,:nznt) +! 1 * (bsq(js+1,:nznt)-prot(js+1,:nznt)) +! 2 + sigma_an(js ,:nznt)*gsqrt(js ,:nznt) +! 3 * (bsq(js ,:nznt)-prot(js ,:nznt)) +#else + sqgb2(:nznt) = sigma_an(js+1,:nznt)*gsqrt(js+1,:nznt) + 1 * (bsq(js+1,:nznt)-pres(js+1)) + 2 + sigma_an(js ,:nznt)*gsqrt(js ,:nznt) + 3 * (bsq(js ,:nznt)-pres(js )) +#endif +! TAKE THIS OUT: MAY BE POORLY CONVERGED AT THIS POINT.... +! IF (ANY(sqgb2(:nznt)*signgs .le. zero)) +! 1 STOP ' SQGB2 <= 0 in JXBFORCE' + pprime(:) = ohs*(pres(js+1)-pres(js))/mu0 !dp/ds here +#ifdef _ANIMEC +!WAC Last two lines of 'pprime' contain the hot particle parallel pressure + 1 + ohs*((pres(js+1)*phot(js+1) - pres(js)*phot(js))*pp2(js,:nznt) + 2 + (tpotb(js+1) - tpotb(js) ) *pp1(js,:nznt)) + 3 / mu0 +#endif + kperpu(:nznt) = p5*(bsubv(js+1,:nznt,0) + bsubv(js,:nznt,0))* + 1 pprime(:)/sqgb2 + kperpv(:nznt) =-p5*(bsubu(js+1,:nznt,0) + bsubu(js,:nznt,0))* + 1 pprime(:)/sqgb2 + kp2(:nznt)=p5*(kperpu**2*(guu(js+1:nrzt:ns) + guu(js:nrzt:ns)) + 1 + 2*kperpu*kperpv*(guv(js+1:nrzt:ns) + guv(js:nrzt:ns)) + 2 + kperpv**2*(gvv(js+1:nrzt:ns) + gvv(js:nrzt:ns))) + itheta(js,:nznt) = bsubsv(js,:nznt,0) - ohs* + 1 (bsubv(js+1,:nznt,0) - bsubv(js,:nznt,0)) + izeta(js,:nznt) = -bsubsu(js,:nznt,0) + ohs* + 1 (bsubu(js+1,:nznt,0) - bsubu(js,:nznt,0)) + itheta(js,:nznt) = itheta(js,:nznt)/mu0 + izeta(js,:nznt) = izeta(js,:nznt)/mu0 + sqrtg(:) = p5*(gsqrt(js,:) + gsqrt(js+1,:)) + bsupu1(:nznt) = p5*(bsupu(js+1,:nznt)*gsqrt(js+1,:) + 1 + bsupu(js,:nznt) *gsqrt(js,:)) / sqrtg(:) + bsupv1(:nznt) = p5*(bsupv(js+1,:nznt)*gsqrt(js+1,:) + 1 + bsupv(js,:nznt) *gsqrt(js,:)) / sqrtg(:) + bsubu1(:nznt) = p5*(bsubu(js+1,:nznt,0) + bsubu(js,:nznt,0)) + bsubv1(:nznt) = p5*(bsubv(js+1,:nznt,0) + bsubv(js,:nznt,0)) + jxb(:nznt) = ovp*(itheta(js,:nznt) * bsupv1(:nznt) + 1 - izeta (js,:nznt) * bsupu1(:nznt)) + bdotk(js,:nznt) = itheta(js,:nznt) * bsubu1(:nznt) + + 1 izeta (js,:nznt) * bsubv1(:nznt) + pprime(:nznt) = ovp*pprime(:nznt) + pnorm = one/(ABS(pprime(1)) + EPSILON(pprime(1))) + amaxfor(js) = MAXVAL(jxb(:nznt)-pprime(:))*pnorm + aminfor(js) = MINVAL(jxb(:nznt)-pprime(:))*pnorm + avforce(js) = SUM(wint(2:nrzt:ns)*(jxb(:nznt) - pprime(:))) + amaxfor(js) = 100*MIN(amaxfor(js),9.999_dp) + aminfor(js) = 100*MAX(aminfor(js),-9.999_dp) + pprim(js) = SUM(wint(js:nrzt:ns)*pprime(:)) +! Compute , = signgs*phip +! jpar2 = , jperp2 = , with <...> = flux surface average + + jdotb(js) = dnorm1*tjnorm*SUM(bdotk(js,:nznt)*wint(2:nrzt:ns) + 1 / sigma_an(js,:nznt)) + bdotb(js) = dnorm1*tjnorm*SUM(sqgb2(:nznt)*wint(2:nrzt:ns) + 1 / sigma_an(js,:nznt)) + + bdotgradv(js) = p5*dnorm1*tjnorm*(phip(js) + phip(js+1)) + jpar2(js) = dnorm1*tjnorm* + 1 SUM(bdotk(js,:nznt)**2*wint(2:nrzt:ns) + 2 /(sigma_an(js,:nznt)*sqgb2(:nznt))) + jperp2(js)= dnorm1*tjnorm* + 1 SUM(kp2(:nznt)*wint(2:nrzt:ns)*sqrtg(:nznt)) + + IF (MOD(js,ns_skip) .eq. 0 .and. lprint_flag) THEN +#ifdef NETCDF + phin(js) = phi(js)/phi(ns) + DO lz = 1, nzeta + toroidal_angle(lz)=REAL(360*(lz-1),rprec)/nzeta + DO lt = 1, ntheta3 + lk = lz + nzeta*(lt-1) +C lu (js,lz,lt ) = lt + jsupu3 (js,lz,lt) = ovp*itheta(js,lk) + jsupv3 (js,lz,lt) = ovp*izeta(js,lk) + jsups3 (js,lz,lt) = ovp*(bsubuv(js,lk) + 1 - bsubvu(js,lk))/mu0 + bsupu3 (js,lz,lt) = bsupu1(lk) + bsupv3 (js,lz,lt) = bsupv1(lk) + jcrossb (js,lz,lt) = jxb(lk) + jxb_gradp (js,lz,lt) = (jxb(lk) - pprime(lk)) + jdotb_sqrtg (js,lz,lt) = ovp*bdotk(js,lk) + sqrtg3(js,lz,lt) = sqrtg(lk)*ovp + bsubu3(js,lz,lt) = bsubu(js,lk,0) + bsubv3(js,lz,lt) = bsubv(js,lk,0) + bsubs3(js,lz,lt) = bsubs(js,lk) + END DO + END DO +#else + WRITE (njxbout, 200) phi(js), avforce(js), jdotb(js), + 1 bdotgradv(js), pprime(1), one/ovp, + 2 (twopi**2)*tjnorm*SUM(itheta(js,:)*wint(js:nrzt:ns)), + 3 (twopi**2)*tjnorm*SUM(izeta (js,:)*wint(js:nrzt:ns)), + 4 amaxfor(js), aminfor(js) + WRITE (njxbout, 90) + DO lz = 1, nzeta, nv_skip + WRITE (njxbout, 100) REAL(360*(lz-1),rprec)/nzeta, lz + DO lt = 1, ntheta3, nu_skip + lk = lz + nzeta*(lt - 1) + WRITE (njxbout, 110) lt, tjnorm*itheta(js,lk), + 1 tjnorm*izeta(js,lk), ovp*(bsubuv(js,lk) - + 2 bsubvu(js,lk))/mu0, bsupu1(lk), bsupv1(lk), + 3 sqrtg(lk)*ovp, jxb(lk), jxb(lk) - pprime(lk), + 4 ovp*bdotk(js,lk), bsubu(js,lk,0), + 5 bsubv(js,lk,0), bsubs(js,lk) + END DO + END DO +#endif + ENDIF + END DO + + izeta(1,:nznt) = two*izeta(2,:nznt) - izeta(3,:nznt) !!Need in wrout + izeta(ns,:nznt)= two*izeta(ns-1,:nznt) - izeta(ns-2,:nznt) !!Need in wrout + jdotb(1) = two*jdotb(2) - jdotb(3) + jdotb(ns) = two*jdotb(ns-1) - jdotb(ns-2) + bdotb(1) = two*bdotb(3) - bdotb(2) + bdotb(ns) = two*bdotb(ns-1) - bdotb(ns-2) + bdotgradv(1) = two*bdotgradv(2) - bdotgradv(3) + bdotgradv(ns) = two*bdotgradv(ns-1) - bdotgradv(ns-2) + jpar2(1) = 0; jpar2(ns) = 0; jperp2(1) = 0; jperp2(ns) = 0 + pprim(1) = 2*pprim(ns-1) - pprim(ns-2) + pprim(ns) = 2*pprim(ns-1) - pprim(ns-2) + + IF (lprint_flag) THEN +#ifdef NETCDF + CALL cdf_define(njxbout,vn_legend,legend) + CALL cdf_define(njxbout,vn_mpol,mpol) + CALL cdf_define(njxbout,vn_ntor,ntor) + CALL cdf_define(njxbout,vn_phin,phin) + CALL cdf_define(njxbout,vn_radial_surfaces,ns) + CALL cdf_define(njxbout,vn_poloidal_grid_points,ntheta3) + CALL cdf_define(njxbout,vn_toroidal_grid_points,nzeta) + CALL cdf_define(njxbout,vn_avforce,avforce) + CALL cdf_define(njxbout,vn_jdotb,jdotb) + + CALL cdf_define(njxbout,vn_sqg_bdotk,jdotb_sqrtg) + CALL cdf_define(njxbout,vn_sqrtg,sqrtg3) + + CALL cdf_define(njxbout,vn_bdotgradv,bdotgradv) + CALL cdf_define(njxbout,vn_pprime,pprim) + CALL cdf_define(njxbout,vn_aminfor,aminfor) + CALL cdf_define(njxbout,vn_amaxfor,amaxfor) + CALL cdf_define(njxbout,vn_jsupu,jsupu3) + CALL cdf_define(njxbout,vn_jsupv,jsupv3) + CALL cdf_define(njxbout,vn_jsups,jsups3) + CALL cdf_define(njxbout,vn_bsupu,bsupu3) + CALL cdf_define(njxbout,vn_bsupv,bsupv3) + CALL cdf_define(njxbout,vn_jcrossb,jcrossb) + CALL cdf_define(njxbout,vn_jxb_gradp,jxb_gradp) + CALL cdf_define(njxbout,vn_bsubu,bsubu3) + CALL cdf_define(njxbout,vn_bsubv,bsubv3) + CALL cdf_define(njxbout,vn_bsubs,bsubs3) + + CALL cdf_write(njxbout,vn_legend,legend) + CALL cdf_write(njxbout,vn_mpol,mpol) + CALL cdf_write(njxbout,vn_ntor,ntor) + CALL cdf_write(njxbout,vn_phin,phin) + CALL cdf_write(njxbout,vn_radial_surfaces,ns) + CALL cdf_write(njxbout,vn_poloidal_grid_points,ntheta3) + CALL cdf_write(njxbout,vn_toroidal_grid_points,nzeta) + CALL cdf_write(njxbout,vn_avforce,avforce) + CALL cdf_write(njxbout,vn_jdotb,jdotb) + + CALL cdf_write(njxbout,vn_sqg_bdotk,jdotb_sqrtg) + CALL cdf_write(njxbout,vn_sqrtg,sqrtg3) + + CALL cdf_write(njxbout,vn_bdotgradv,bdotgradv) + CALL cdf_write(njxbout,vn_pprime,pprim) + CALL cdf_write(njxbout,vn_aminfor,aminfor) + CALL cdf_write(njxbout,vn_amaxfor,amaxfor) + CALL cdf_write(njxbout,vn_jsupu,jsupu3) + CALL cdf_write(njxbout,vn_jsupv,jsupv3) + CALL cdf_write(njxbout,vn_jsups,jsups3) + CALL cdf_write(njxbout,vn_bsupu,bsupu3) + CALL cdf_write(njxbout,vn_bsupv,bsupv3) + CALL cdf_write(njxbout,vn_jcrossb,jcrossb) + CALL cdf_write(njxbout,vn_jxb_gradp,jxb_gradp) + CALL cdf_write(njxbout,vn_bsubu,bsubu3) + CALL cdf_write(njxbout,vn_bsubv,bsubv3) + CALL cdf_write(njxbout,vn_bsubs,bsubs3) + + CALL cdf_close(njxbout) + + DEALLOCATE( + 1 bsubs3, bsubv3, bsubu3, jxb_gradp, jcrossb, bsupv3, + 2 bsupu3, jsups3, jsupv3, jsupu3, jdotb_sqrtg, phin, + 3 toroidal_angle, sqrtg3, stat=j) + +#else + CLOSE (njxbout) + + 90 FORMAT(/" LU JSUPU JSUPV JSUPS BSUPU", + 1 " BSUPV SQRT(g') J X B J X B - p' J * B", + 2 " BSUBU BSUBV BSUBS "/) + 100 FORMAT( " TOROIDAL ANGLE (PER PERIOD) = ", f8.3," DEGREES", + 1 " (PLANE #", i3,")") + 110 FORMAT(i5,1p,12e11.3) + 200 FORMAT(/" TOROIDAL FLUX = ",1p,e12.3,3x," = ", + 1 e12.3,3x," = ",e12.3,3x, + 2 " = ",e12.3,/, + 2 " dp/d(VOL) [p'] = ",e12.3,3x,'d(VOL)/ds = ',e12.3,3x, + 2 " = ",e12.3,3x," = ",e12.3,/, + 3 " MAXIMUM FORCE DEVIATIONS (RELATIVE TO p'): ",sp,0p,f7.2,"%", + 4 3x,f7.2,"%") +#endif + + END IF + + DEALLOCATE (kperpu, kperpv, sqgb2, sqrtg, kp2, brhomn, bsubsmn, + 1 jxb, jxb2, bsupu1, bsupv1, bsubu1, bsubv1, avforce, aminfor, + 2 amaxfor, pprim, stat=j) +! +! COMPUTE MERCIER CRITERION +! + bdotk = mu0*bdotk + CALL Mercier(gsqrt,bsq,bdotk,iotas,wint,r1,ru,rv,zu,zv,bsubu, + 1 vp,phips,pres,ns,nznt) + + DEALLOCATE (bdotk, bsubuv, bsubvu, pprime, stat=j) + + END SUBROUTINE jxbforce diff --git a/Sources/Input_Output/mercier.f b/Sources/Input_Output/mercier.f new file mode 100644 index 0000000..31780e8 --- /dev/null +++ b/Sources/Input_Output/mercier.f @@ -0,0 +1,194 @@ + SUBROUTINE mercier(gsqrt, bsq, bdotj, iotas, wint, + 1 r1, rt, rz, zt, zz, bsubu, vp, phips, pres, ns, nznt) + USE safe_open_mod + USE vmercier + USE vmec_input, ONLY: input_extension + USE vparams, ONLY: one, zero, twopi, nmercier0 + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: ns, nznt + REAL(rprec), DIMENSION(ns,nznt), INTENT(in) :: + 1 gsqrt, bsq + REAL(rprec), DIMENSION(ns,nznt), INTENT(inout) :: bdotj + REAL(rprec), DIMENSION(ns*nznt), INTENT(in) :: wint, bsubu + REAL(rprec), DIMENSION(ns,nznt,0:1), INTENT(in) :: + 1 r1, rt, rz, zt, zz + REAL(rprec), DIMENSION(ns), INTENT(in) :: + 1 iotas, vp, phips, pres +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: p5 = 0.5_dp, two = 2 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ns1, i, imercier0, nmerc = nmercier0, nrzt + REAL(rprec) :: sign_jac, hs, sqs, denom + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: + 1 gpp, gsqrt_full, b2 + REAL(rprec), DIMENSION(nznt) :: gtt, rtf, ztf, + 1 rzf, zzf, r1f, jdotb, ob2, b2i + REAL(rprec), DIMENSION(ns) :: vp_real, phip_real, + 1 shear, vpp, presp, torcur, ip, sj, tpp, tjb, tbb, tjj + CHARACTER(LEN=120) mercier_file +C----------------------------------------------- + nrzt = ns*nznt + mercier_file = 'mercier.'//TRIM(input_extension) + CALL safe_open (nmerc, imercier0, mercier_file, 'replace', + 1 'formatted') + IF (imercier0 .ne. 0) RETURN + + + ALLOCATE (gpp(ns,nznt), gsqrt_full(ns,nznt), b2(ns,nznt), stat=i) + IF (i .ne. 0) STOP 'allocation error in Mercier' + +! +! SCALE VP, PHIPS TO REAL UNITS (VOLUME, TOROIDAL FLUX DERIVATIVES) +! AND PUT GSQRT IN ABS UNITS (SIGNGS MAY BE NEGATIVE) +! NOTE: VP has (coming into this routine) the sign of the jacobian multiplied out +! i.e., vp = signgs* +! THE SHEAR TERM MUST BE MULTIPLIED BY THE SIGN OF THE JACOBIAN +! (OR A BETTER SOLUTION IS TO RETAIN THE JACOBIAN SIGN IN ALL TERMS, INCLUDING +! VP, THAT DEPEND EXPLICITLY ON THE JACOBIAN. WE CHOOSE THIS LATTER METHOD...) +! +! COMING INTO THIS ROUTINE, THE JACOBIAN(gsqrt) = 1./(grad-s . grad-theta X grad-zeta) +! WE CONVERT THIS FROM grad-s to grad-phi DEPENDENCE BY DIVIDING gsqrt by PHIP_real +! +! NOTE: WE ARE USING 0 < s < 1 AS THE FLUX VARIABLE, BEING CAREFUL +! TO KEEP d(phi)/ds == PHIP_real FACTORS WHERE REQUIRED +! THE V'' TERM IS d2V/d(PHI)**2, PHI IS REAL TOROIDAL FLUX +! +! SHEAR = d(iota)/d(phi) : FULL MESH +! VPP = d(vp)/d(phi) : FULL MESH +! PRESP = d(pres)/d(phi) : FULL MESH (PRES IS REAL PRES*mu0) +! IP = d(Itor)/d(phi) : FULL MESH +! +! ON ENTRY, BDOTJ = Jacobian * J*B ON THE FULL RADIAL GRID +! BSQ = 0.5*|B**2| + p IS ON THE HALF RADIAL GRID +! + + ns1 = ns - 1 + IF (ns1 .le. 0) RETURN + hs = one/ns1 + sign_jac = zero + IF (gsqrt(ns,1) .ne. zero) + 1 sign_jac = ABS(gsqrt(ns,1))/gsqrt(ns,1) + + IF (sign_jac .eq. zero) RETURN + phip_real = twopi * phips * sign_jac +! +! NOTE: phip_real should be > 0 to get the correct physical sign of REAL-space gradients +! For example, grad-p, grad-Ip, etc. However, with phip_real defined this way, +! Mercier will be correct +! + vp_real(2:ns) = sign_jac*(twopi*twopi)*vp(2:ns)/phip_real(2:ns) !!dV/d(PHI) on half mesh + +! +! COMPUTE INTEGRATED TOROIDAL CURRENT +! + DO i = 2,ns + torcur(i)=sign_jac*twopi*SUM(bsubu(i:nrzt:ns)*wint(i:nrzt:ns)) + END DO + +! +! COMPUTE SURFACE AVERAGE VARIABLES ON FULL RADIAL MESH +! + DO i = 2,ns1 + phip_real(i) = p5*(phip_real(i+1) + phip_REAL(i)) + denom = one/(hs*phip_real(i)) + shear(i) = (iotas(i+1) - iotas(i))*denom !!d(iota)/d(PHI) + vpp(i) = (vp_real(i+1) - vp_real(i))*denom !!d(VP)/d(PHI) + presp(i) = (pres(i+1) - pres(i))*denom !!d(p)/d(PHI) + ip(i) = (torcur(i+1) - torcur(i))*denom !!d(Itor)/d(PHI) + END DO + +! +! COMPUTE GPP == |grad-phi|**2 = PHIP**2*|grad-s|**2 (on full mesh) +! Gsqrt_FULL = JACOBIAN/PHIP == jacobian based on flux (on full mesh) +! + + DO i = 2, ns1 + gsqrt_full(i,:) = p5*(gsqrt(i,:) + gsqrt(i+1,:)) + bdotj(i,:) = bdotj(i,:)/gsqrt_full(i,:) + gsqrt_full(i,:) = gsqrt_full(i,:)/phip_real(i) + sj(i) = hs*(i-1) + sqs = SQRT(sj(i)) + rtf(:) = rt(i,:,0) + sqs*rt(i,:,1) + ztf(:) = zt(i,:,0) + sqs*zt(i,:,1) + gtt(:) = rtf(:)*rtf(:) + ztf(:)*ztf(:) + rzf(:) = rz(i,:,0) + sqs*rz(i,:,1) + zzf(:) = zz(i,:,0) + sqs*zz(i,:,1) + r1f(:) = r1(i,:,0) + sqs*r1(i,:,1) + gpp(i,:) = gsqrt_full(i,:)**2/(gtt(:)*r1f(:)**2 + + 1 (rtf(:)*zzf(:) - rzf(:)*ztf(:))**2) !!1/gpp + END DO + +! +! COMPUTE SURFACE AVERAGES OVER dS/|grad-PHI|**3 => |Jac| du dv / |grad-PHI|**2 +! WHERE Jac = gsqrt/phip_real +! + DO i = 2,ns + b2(i,:) = two*(bsq(i,:) - pres(i)) + END DO + + DO i = 2,ns1 + b2i(:) = p5*(b2(i+1,:) + b2(i,:)) + ob2(:) = gsqrt_full(i,:)/b2i(:) + tpp(i) = SUM(ob2(:)*wint(i:nrzt:ns)) !<1/B**2> + ob2(:) = b2i(:) * gsqrt_full(i,:) * gpp(i,:) + tbb(i) = SUM(ob2(:)*wint(i:nrzt:ns)) ! + jdotb(:) = bdotj(i,:) * gpp(i,:) * gsqrt_full(i,:) + tjb(i) = SUM(jdotb(:)*wint(i:nrzt:ns)) ! + jdotb(:) = jdotb(:) * bdotj(i,:) / b2i(:) + tjj(i) = SUM(jdotb(:)*wint(i:nrzt:ns)) !<(j*b)2/b**2*|grad-phi|**3> + END DO + + DEALLOCATE (gpp, gsqrt_full, b2, stat=i) + +! +! REFERENCE: BAUER, BETANCOURT, GARABEDIAN, MHD Equilibrium and Stability of Stellarators +! We break up the Omega-subs into a positive shear term (Dshear) and a net current term, Dcurr +! Omega_subw == Dwell and Omega-subd == Dgeod (geodesic curvature, Pfirsch-Schluter term) +! +! Include (eventually) Suydam for reference (cylindrical limit) +! + + WRITE(nmerc,90) + 90 FORMAT(6x,'S',10x,'PHI',9x,'IOTA',8x,'SHEAR',7x,' VP ',8x,'WELL', + 1 8x,'ITOR',7x,'ITOR''',7x,'PRES',7x,'PRES''',/,120('-')) + + DO i = 2,ns1 + sqs = p5*(vp_real(i) + vp_real(i+1))*sign_jac + IF (sqs .eq. zero) CYCLE + WRITE(nmerc,100) sj(i), hs*SUM(phip_real(2:i)), + 1 p5*(iotas(i+1)+iotas(i)), shear(i)/sqs, + 2 sqs, -vpp(i)*sign_jac, + 3 p5*(torcur(i) + torcur(i+1)), ip(i)/sqs, + 4 p5*(pres(i) + pres(i+1)), presp(i)/sqs + END DO + + 100 FORMAT(1p,10e12.4) + + WRITE(nmerc,190) + 190 FORMAT(/,6x,'S',8x,'DMerc',8x,'DShear',7x,'DCurr',7x,'DWell', + 1 7x,'Dgeod',/,100('-')) + + DO i = 2,ns1 + tpp(i) = (twopi*twopi)*tpp(i) + tjb(i) = (twopi*twopi)*tjb(i) + tbb(i) = (twopi*twopi)*tbb(i) + tjj(i) = (twopi*twopi)*tjj(i) + Dshear(i) = shear(i) * shear(i)/4 + Dcurr(i) =-shear(i) * (tjb(i) - ip(i) *tbb(i)) + Dwell(i) = presp(i) * (vpp(i) - presp(i) *tpp(i))*tbb(i) + Dgeod(i) = tjb(i) *tjb(i) - tbb(i) *tjj(i) + DMerc(i) = Dshear(i) + Dcurr(i) + Dwell(i) + Dgeod(i) + WRITE(nmerc,100) sj(i), Dmerc(i), Dshear(i), + 1 Dcurr(i), Dwell(i), Dgeod(i) + END DO + + CLOSE (nmerc) + + END SUBROUTINE mercier diff --git a/Sources/Input_Output/perf2likwid.f90 b/Sources/Input_Output/perf2likwid.f90 new file mode 100644 index 0000000..2d66786 --- /dev/null +++ b/Sources/Input_Output/perf2likwid.f90 @@ -0,0 +1,37 @@ +! perflib wrapper for likwid marker-API calls +! see http://code.google.com/p/likwid/wiki/LikwidPerfCtr#NEW:_Using_the_marker_API_with_Fortran_90 + +subroutine perfinit +!include "likwid_f90.h" +! call likwid_markerInit() +end subroutine perfinit + +subroutine perfon(region) +!#include "likwid_f90.h" + + character(*), intent(in) :: region +! call likwid_markerStart(region) +! call likwid_markerStartRegion(region,len_trim(region)) +end subroutine perfon + +subroutine perfoff(region) +!#include "likwid_f90.h" + character(*), intent(in) :: region +! call likwid_markerStop(region) +! call likwid_markerStopRegion(region,len_trim(region)) +end subroutine perfoff + +subroutine perfout(region) +!include "likwid_f90.h" + character(*), intent(in) :: region +! call likwid_markerClose() +end subroutine perfout + + +subroutine perf_context_start() + +end subroutine perf_context_start + +subroutine perf_context_end() + +end subroutine perf_context_end diff --git a/Sources/Input_Output/printout.f b/Sources/Input_Output/printout.f new file mode 100644 index 0000000..b232186 --- /dev/null +++ b/Sources/Input_Output/printout.f @@ -0,0 +1,192 @@ + SUBROUTINE printout(i0, delt0, w0, lscreen) + USE vmec_main + USE realspace + USE xstuff +#ifdef _HBANGLE + USE angle_constraints, ONLY: getrz +#endif + USE parallel_include_module + USE parallel_vmec_module, ONLY: CopyLastNtype + USE vmec_params, ONLY: ntmax + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: i0 + REAL(dp) :: delt0, w0 + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + CHARACTER(LEN=*), PARAMETER :: +#ifdef _HBANGLE + 1 iter_line = " ITER FSQRHO FSQ(m=0) FSQL ", + 1 iter_lines= " ITER FSQRHO FSQ(m=0) FSQL ", + 2 fsq_line = " fsqrho fsq(m=0) fsql DELT ", + 2 fsq_lines = " fsqrho fsq(m=0) fsql DELT ", + 4 raxis_line = " RAX(v=0) ", +#else + 1 iter_line = " ITER FSQR FSQZ FSQL ", + 2 fsq_line = " fsqr fsqz fsql DELT ", + 3 iter_lines = iter_line, fsq_lines = fsq_line, + 4 raxis_line = "RAX(v=0) ", +#endif + 3 delt_line = " DELT ", !J.Geiger 20101118 + 5 zaxis_line = " ZAX(v=0) " +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(dp) :: betav, w, avm, den, tbroadon, tbroadoff + REAL(dp), ALLOCATABLE :: bcastbuf(:) + CHARACTER(len=LEN(iter_line) + LEN(fsq_line) + + 1 LEN(raxis_line) + LEN(zaxis_line)) :: + 2 print_line + INTEGER :: i, j, k, l, lk +C----------------------------------------------- + IF(grank .GE. nranks) RETURN + +#ifdef _ANIMEC + betav = (2*wper + wpar)/(3*wb) +#else + betav = wp/wb +#endif + w = w0*twopi*twopi + den = zero + specw(1) = one + + IF(PARVMEC) THEN + CALL CopyLastNtype(pxstore, pgc) + ELSE + gc = xstore + END IF +#ifdef _HBANGLE + CALL getrz(gc) +#endif + + IF (PARVMEC) THEN + CALL spectrum_par (pgc(:irzloff), pgc(1+irzloff:2*irzloff)) + CALL Gather1XArray(vp) + CALL Gather1XArray(specw) + ELSE + CALL spectrum (gc(:irzloff), gc(1+irzloff:2*irzloff)) + END IF + + den = SUM(vp(2:ns)) + avm = DOT_PRODUCT(vp(2:ns),specw(2:ns)+specw(1:ns-1)) + avm = 0.5_dp*avm/den + IF (ivac .GE. 1) THEN + IF (PARVMEC) THEN +!SPH CHANGE (MOVE OUT OF FUNCT3D) +#if defined(MPI_OPT) + ACTIVE1: IF (lactive) THEN + CALL second0(tbroadon) + ALLOCATE(bcastbuf(3*nznt+1)) + bcastbuf(1:nznt) = dbsq + bcastbuf(nznt+1:2*nznt) = bsqsav(:,3) + bcastbuf(2*nznt+1:3*nznt) = rbsq !NEED THIS WHEN INTERPOLATING MESHES + bcastbuf(3*nznt+1) = fedge + + CALL MPI_Bcast(bcastbuf,SIZE(bcastbuf),MPI_REAL8, + 1 nranks-1,NS_COMM,MPI_ERR) + + dbsq = bcastbuf(1:nznt) + bsqsav(:,3) = bcastbuf(nznt+1:2*nznt) + rbsq = bcastbuf(2*nznt+1:3*nznt) + fedge = bcastbuf(3*nznt+1) + DEALLOCATE(bcastbuf) + + CALL second0(tbroadoff) + broadcast_time = broadcast_time + (tbroadoff - tbroadon) + den = SUM(bsqsav(:nznt,3)*pwint(:,2)) + IF (den .NE. zero) delbsq = + 1 SUM(dbsq(:nznt)*pwint(:,2))/den + END IF ACTIVE1 +#endif + ELSE + delbsq = + 1 SUM(dbsq(:nznt)*wint(2:nrzt:ns))/ + 2 SUM(bsqsav(:nznt,3)*wint(2:nrzt:ns)) + END IF + END IF + + IF (i0.EQ.1 .AND. lfreeb) THEN + print_line = iter_lines // " " // raxis_line + IF (lasym) print_line = TRIM(print_line) // " " // zaxis_line + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 20, TRIM(print_line)//delt_line !J Geiger 20101118 + print_line = iter_line // fsq_line // raxis_line + IF (lasym) print_line = TRIM(print_line) // " " // zaxis_line + IF (imatch_phiedge .eq. 1) THEN + IF(grank.EQ.0) WRITE (nthreed, 15) TRIM(print_line) + ELSE + IF(grank.EQ.0) WRITE (nthreed, 16) TRIM(print_line) + ENDIF + ELSE IF (i0.eq.1 .and. .not.lfreeb) THEN + print_line = raxis_line + IF (lasym) print_line = raxis_line // zaxis_line + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 30, iter_lines, TRIM(print_line)//delt_line !J Geiger 2010118 + print_line = iter_line // fsq_line // raxis_line // " " + IF (lasym) print_line = iter_line // fsq_line // raxis_line + 1 // zaxis_line + IF (grank .EQ. 0) WRITE (nthreed, 25) TRIM(print_line) + ENDIF + 15 FORMAT(/,a,6x,'WMHD BETA DEL-BSQ FEDGE',/) + 16 FORMAT(/,a,6x,'WMHD BETA PHIEDGE DEL-BSQ FEDGE',/) + 20 FORMAT(/,a,6x,'WMHD DEL-BSQ',/) + 25 FORMAT(/,a,6x,'WMHD BETA ',/) + 30 FORMAT(/,a,1x,a,5x,'WMHD',/) + + IF (.not. lasym) THEN + IF (.not.lfreeb) THEN + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 45, i0, fsqr, fsqz, fsql, r00, delt0, w !J Geiger 20101118 + IF(grank.EQ.0) WRITE (nthreed, 40) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, w, betav, avm + RETURN + ENDIF + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 50, i0, fsqr, fsqz, fsql, r00, delt0, w, + 2 delbsq !J Geiger 20101118 + IF (imatch_phiedge .eq. 1) THEN + IF(grank.EQ.0) WRITE (nthreed, 40) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, w, betav, avm, delbsq, + 2 fedge + ELSE + IF(grank.EQ.0) WRITE (nthreed, 42) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, w, betav, + 2 ABS(phiedge), delbsq, fedge + ENDIF + + ELSE + IF (.not.lfreeb) THEN + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 65, i0, fsqr, fsqz, fsql, r00, z00, !J Geiger 20101118 + 2 delt0, w !J Geiger 20101118 + IF(grank.EQ.0) WRITE (nthreed, 60) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, z00, w, betav, avm + RETURN + ENDIF + IF (lscreen.AND.grank.EQ.0) + 1 PRINT 70, i0, fsqr, fsqz, fsql, r00, z00, + 2 delt0, w, delbsq !J Geiger 20101118 + IF (imatch_phiedge .eq. 1) THEN + IF(grank.EQ.0) WRITE (nthreed, 60) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, z00, w, betav, avm, + 2 delbsq, fedge + ELSE + IF(grank.EQ.0) WRITE (nthreed, 60) i0, fsqr, fsqz, fsql, + 1 fsqr1, fsqz1, fsql1, delt0, r00, z00, w, betav, + 2 ABS(phiedge), delbsq, fedge + ENDIF + END IF + + 40 FORMAT(i6,1x,1p,7e10.2,e11.3,e12.4,e11.3,0p,f7.3,1p,2e9.2) + 42 FORMAT(i5,1p,7e10.2,e11.3,e12.4,2e11.3,0p,f7.3,1p,e9.2) + 45 FORMAT(i5,1p,3e10.2,e11.3,e10.2,e12.4) + 50 FORMAT(i5,1p,3e10.2,e11.3,e10.2,e12.4,e11.3) + 60 FORMAT(i6,1x,1p,7e10.2,2e11.3,e12.4,e11.3,0p,f7.3,1p,2e9.2) + 65 FORMAT(i5,1p,3e10.2,2e11.3,e10.2,e12.4) + 70 FORMAT(i5,1p,3e10.2,2e11.3,e10.2,e12.4,e11.3) + + END SUBROUTINE printout diff --git a/Sources/Input_Output/read_indata.f b/Sources/Input_Output/read_indata.f new file mode 100644 index 0000000..c43469e --- /dev/null +++ b/Sources/Input_Output/read_indata.f @@ -0,0 +1,116 @@ + SUBROUTINE read_indata(in_file, iunit, ier_flag) + USE vmec_main + USE vmec_input, ONLY: bloat, ncurr + USE vmec_params + USE vacmod + USE safe_open_mod + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER ier_flag, iunit + CHARACTER(LEN=*) :: in_file +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ireadseq, iosnml +C----------------------------------------------- + iunit = indata0+rank + CALL safe_open (iunit, ireadseq, in_file, 'old', 'formatted') + IF (ireadseq .ne. 0) THEN + WRITE (6, '(3a,i4)') ' In VMEC, error opening input file: ', + 1 TRIM(in_file), '. Iostat = ', ireadseq + ier_flag = input_error_flag + RETURN + ENDIF + + CALL read_namelist (iunit, iosnml, 'indata') + IF (iosnml .ne. 0) THEN + WRITE (6, '(a,i4)') + 1 ' In VMEC, indata NAMELIST error: iostat = ', iosnml + ier_flag = input_error_flag + RETURN + ENDIF + + CALL read_namelist (iunit, iosnml, 'mseprofile') + + IF (lrecon .and. itse.le.0 .and. imse.le.0) lrecon = .false. + IF (lfreeb .and. mgrid_file.eq.'NONE') lfreeb = .false. + + IF (bloat .eq. zero) bloat = one + IF ((bloat.ne.one) .and. (ncurr.ne.1)) THEN + ier_flag = 3 + RETURN + ENDIF +! +! COMPUTE NTHETA, NZETA VALUES +! + mpol = ABS(mpol) + ntor = ABS(ntor) + IF (mpol .gt. mpold) STOP 'mpol>mpold: lower mpol' + IF (ntor .gt. ntord) STOP 'ntor>ntord: lower ntor' + mpol1 = mpol - 1 + ntor1 = ntor + 1 + IF (ntheta .le. 0) ntheta = 2*mpol + 6 !number of theta grid points (>=2*mpol+6) + ntheta1 = 2*(ntheta/2) + ntheta2 = 1 + ntheta1/2 !u = pi + IF (ntor .eq. 0) lthreed = .false. + IF (ntor .gt. 0) lthreed = .true. + + IF (ntor.eq.0 .and. nzeta.eq.0) nzeta = 1 + IF (nzeta .le. 0) nzeta = 2*ntor + 4 !number of zeta grid points (=1 IF ntor=0) + mnmax = ntor1 + mpol1*(1 + 2*ntor) !SIZE of rmnc, rmns, ... + mnsize = mpol*ntor1 !SIZE of rmncc, rmnss, ... + + mf = mpol+1 + nf = ntor + nu = ntheta1 + nv = nzeta + mf1 = 1+mf + nf1 = 2*nf+1 + mnpd = mf1*nf1 + nfper = nfp + +! +! INDEXING FOR PACKED-ARRAY STRUCTURE OF XC, GC +! + rcc = 1; zsc = 1 + rss = 0; rsc = 0; rcs = 0 + zcc = 0; zss = 0; zcs = 0 + IF (.not.lasym) THEN + ntheta3 = ntheta2 + mnpd2 = mnpd + IF (lthreed) THEN + ntmax = 2 + rss = 2; zcs = 2 + ELSE + ntmax = 1 + END IF + ELSE + ntheta3 = ntheta1 + mnpd2 = 2*mnpd + IF (lthreed) THEN + ntmax = 4 + rss = 2; rsc = 3; rcs = 4 + zcs = 2; zcc = 3; zss = 4 + ELSE + ntmax = 2 + rsc = 2; zcc = 2 + END IF + END IF + + nuv = nu*nv + nu2 = nu/2 + 1 + nu3 = ntheta3 + nznt = nzeta*ntheta3 + nuv3 = nznt +! IF (nuv3 < mnpd) THEN +! PRINT *, ' nuv3 < mnpd: not enough integration points' +! STOP 11 +! ENDIF + + IF (ncurr.eq.1 .and. ALL(ac.eq.cbig)) ac = ai !!Old FORMAT: may not be reading in ac + WHERE (ac .eq. cbig) ac = zero + + END SUBROUTINE read_indata diff --git a/Sources/Input_Output/readin.f b/Sources/Input_Output/readin.f new file mode 100644 index 0000000..fb54dd5 --- /dev/null +++ b/Sources/Input_Output/readin.f @@ -0,0 +1,738 @@ + SUBROUTINE readin(input_file, iseq_count, ier_flag, lscreen) + USE vmec_main + USE vmec_params + USE vacmod + USE vspline + USE timer_sub + USE mgrid_mod, ONLY: nextcur, curlabel, nfper0, read_mgrid + USE init_geometry + USE parallel_include_module, ONLY: grank, mgrid_file_read_time, + & LPRECOND + USE parallel_vmec_module, ONLY: RUNVMEC_COMM_WORLD + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: iseq_count, ier_flag + LOGICAL :: lscreen + CHARACTER(LEN=*) :: input_file +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: iexit, ipoint, n, iunit, ier_flag_init, + & i, ni, m, nsmin, igrid, mj, isgn, ioff, joff, + & NonZeroLen + REAL(dp), DIMENSION(:,:), POINTER :: + & rbcc, rbss, rbcs, rbsc, zbcs, zbsc, zbcc, zbss + REAL(dp) :: rtest, ztest, tzc, trc, delta + REAL(dp), ALLOCATABLE :: temp(:) + CHARACTER(LEN=100) :: line, line2 + CHARACTER(LEN=1) :: ch1, ch2 + LOGICAL :: lwrite +C----------------------------------------------- +! +! LOCAL VARIABLES +! +! rbcc,rbss,rbcs,rbsc +! boundary Fourier coefficient arrays for R (of cosu*cosv, etc) +! zbcc,zbss,zbcs,zbsc +! boundary Fourier coefficient arrays for Z +! +! XCC*COS(MU)COS(NV), XCS*COS(MU)SIN(NV), ETC +! +! STACKING ORDER DEPENDS ON LASYM AND LTHREED. EACH COMPONENT XCC, XSS, XSC, XCS +! HAS SIZE = mns. (PHIFAC, MSE TAKE UP 1 INDEX EACH AT END OF ARRAY) +! +! LTHREED=F, LTHREED=F, LTHREED=T, LTHREED=T +! LASYM=F LASYM=T LASYM=F LASYM=T +! +! rmncc rmncc rmncc rmncc +! zmnsc rmnsc rmnss rmnss +! lmnsc zmnsc zmnsc rmnsc +! zmncc zmncs rmncs +! lmnsc lmnsc zmnsc +! lmncc lmncs zmncs +! zmncc +! zmnss +! lmnsc +! lmncs +! lmncc +! lmnss +! +! +! STANDARD INPUT DATA AND RECOMMENDED VALUES +! +! Plasma parameters (MKS units) +! ai: expansion coefficients for iota (power series in s) used when ncurr=0 +! Interpretation changes with piota_type +! am: mass or pressure (gamma=0) expansion coefficients (series in s) +! in MKS units [NWT/M**2] +! Interpretation changes with pmass_type +! ac: expansion coefficients for the normalized (pcurr(s=1) = 1) +! radial derivative of the flux-averaged toroidal current density +! (power series in s) used when ncurr=1 +! Interpretation changes with pcurr_type +! ai_aux_s: Auxiliary array for iota profile. Used for splines, s values +! ai_aux_f: Auxiliary array for iota profile. Used for splines, function values +! am_aux_s: Auxiliary array for mass profile. Used for splines, s values +! am_aux_f: Auxiliary array for mass profile. Used for splines, function values +! ac_aux_s: Auxiliary array for current profile. Used for splines, s values +! ac_aux_f: Auxiliary array for current profile. Used for splines, function values +! curtor: value of toroidal current [A]. Used if ncurr = 1 to specify +! current profile, or IF in data reconstruction mode. +! phiedge: toroidal flux enclosed by plasma at edge (in Wb) +! extcur: array of currents in each external current group. Used to +! multiply Green''s function for fields and loops read in from +! MGRID file. Should use real current units (A). +! gamma: value of compressibility index (gamma=0 => pressure prescribed) +! nfp: number of toroidal field periods ( =1 for Tokamak) +! rbc: boundary coefficients of COS(m*theta-n*zeta) for R [m] +! zbs: boundary coefficients of SIN(m*theta-n*zeta) for Z [m] +! rbs: boundary coefficients of SIN(m*theta-n*zeta) for R [m] +! zbc: boundary coefficients of COS(m*theta-n*zeta) for Z [m] +! +! +! Numerical and logical control parameters +! ncurr: flux conserving (=0) or prescribed toroidal current (=1) +! ns_array: array of radial mesh sizes to be used in multigrid sequence +! nvacskip: number of iteration steps between accurate calculation of vacuum +! response; use fast interpolation scheme in between +! pres_scale: factor used to scale pressure profile (default value = 1) +! useful so user can fix profile and change beta without having to change +! all AM coefficients separately +! tcon0: weight factor for constraint force (=1 by DEFAULT) +! lasym: =T, run in asymmetric mode; =F, run in stellarator symmetry mode +! lfreeb: =T, run in free boundary mode if mgrid_file exists +! lforbal: =T, use non-variational forces to ensure = 0; +! =F, use variational form of forces, ~ 0 +! +! Convergence control parameters +! ftol_array: array of value of residual(s) at which each multigrid +! iteration ends +! niter_array: array of number of iterations (used to terminate run) at +! each multigrid iteration +! nstep: number of timesteps between printouts on screen +! nvacskip: iterations skipped between full update of vacuum solution +! +! Preconditioner control parameters (added 8/30/04) +! precon_type: specifies type of 2D preconditioner to use ('default', diagonal in m,n, +! tri-diagonal in s; 'conjugate-gradient', block tri-di, evolve using +! cg method; 'gmres', block tri-di, generalized minimal residual method; +! 'tfqmr', block tri-di, transpose-free quasi minimum residual +! prec2d_threshold: +! value of preconditioned force residuals at which block (2d) tri-di +! solver is turned on, if requested via type_prec2d +! +! Character parameters +! mgrid_file: full path for vacuum Green''s function data +! pcurr_type: Specifies parameterization type of pcurr function +! 'power_series' - I'(s)=Sum[ ac(j) s ** j] - Default +! 'gauss_trunc' - I'(s)=ac(0) (exp(-(s/ac(1)) ** 2) - +! exp(-(1/ac(1)) ** 2)) +! others - see function pcurr +! piota_type: Specifies parameterization type of piota function +! 'power_series' - p(s)=Sum[ am(j) s ** j] - Default +! others - see function piota +! pmass_type: Specifies parameterization type of pmass function +! 'power_series' - p(s)=Sum[ am(j) s ** j] - Default +! 'gauss_trunc' - p(s)=am(0) (exp(-(s/am(1)) ** 2) - +! exp(-(1/am(1)) ** 2)) +! others - see function pmass + +! Equilibrium reconstruction parameters +! phifac: factor scaling toroidal flux to match apres or limiter +! datastark: pitch angle data from stark measurement +! datathom: pressure data from Thompson, CHEERS (Pa) +! imatch_ = 1 (default),match value of PHIEDGE in input file +! phiedge: = 0, USE pressure profile width to determine PHIEDGE +! = 2, USE LIMPOS data (in mgrid file) to find PHIEDGE +! = 3, USE Ip to find PHIEDGE (fixed-boundary only) +! imse: number of Motional Stark effect data points +! >0, USE mse data to find iota; <=0, fixed iota profile ai +! itse: number of pressure profile data points +! = 0, no thompson scattering data to READ +! isnodes: number of iota spline points (computed internally unless specified explicitly) +! ipnodes: number of pressure spline points (computed internally unless specified explicitly) +! lpofr: LOGICAL variable. =.true. IF pressure data are +! prescribed in REAL space. =.false. IF data in flux space. +! pknots: array of pressure knot values in SQRT(s) space +! sknots: array of iota knot values in SQRT(s) space +! tensp: spline tension for pressure profile +! +! tensi: spline tension for iota +! tensi2: vbl spline tension for iota +! fpolyi: vbl spline tension form factor (note: IF tensi!=tensi2 +! THEN tension(i-th point) = tensi+(tensi2-tensi)*(i/n-1))**fpolyi +! - - - - - - - - - - - - - - - - - - +! mseangle_ uniform EXPerimental offset of MSE data +! offset: (calibration offset) ... PLUS ... +! mseangle_ multiplier on mseprof offset array +! offsetM: (calibration offset) +! mseprof: offset array from NAMELIST MSEPROFIL +! so that the total offset on the i-th MSE data point is +! taken to be +! = mseangle_offset+mseangle_offsetM*mseprof(i) +! - - - - - - - - - - - - - - - - - - +! pres_offset: uniform arbitrary radial offset of pressure data +! presfac: number by which Thomson scattering data is scaled +! to get actual pressure +! phidiam: diamagnetic toroidal flux (Wb) +! dsiobt: measured flux loop signals corresponding to the +! combination of signals in iconnect array +! indxflx: array giving INDEX of flux measurement in iconnect array +! indxbfld: array giving INDEX of bfield measurement used in matching +! nobd: number of connected flux loop measurements +! nobser: number of individual flux loop positions +! nbsets: number of B-coil sets defined in mgrid file +! nbcoils(n): number of bfield coils in each set defined in mgrid file +! nbcoilsn: total number of bfield coils defined in mgrid file +! bbc(m,n): measured magnetic field at rbcoil(m,n),zbcoil(m,n) at +! the orientation br*COS(abcoil) + bz*SIN(abcoil) +! rbcoil(m,n): R position of the m-th coil in the n-th set from mgrid file +! zbcoil(m,n): Z position of the m-th coil in the n-th set from mgrid file +! abcoil(m,n): orientation (surface normal wrt R axis; in radians) +! of the m-th coil in the n-th set from mgrid file. +! nflxs: number of flux loop measurements used in matching +! nbfld(n): number of selected EXTERNAL bfield measurements in set n from nml file +! nbfldn: total number of EXTERNAL bfield measurements used in matching +! - - - - - - - - - - - - - - - - - - +! NOTE: FOR STANDARD DEVIATIONS (sigma''s) < 0, INTERPRET +! AS PERCENT OF RESPECTIVE MEASUREMENT +! sigma_thom: standard deviation (Pa) for pressure profile data +! sigma_stark: standard deviation (degrees) in MSE data +! sigma_flux: standard deviaton (Wb) for EXTERNAL poloidal flux data +! sigma_b: standard deviation (T) for EXTERNAL magnetic field data +!sigma_current: standard deviation (A) in toroidal current +!sigma_delphid: standard deviation (Wb) for diamagnetic match +! +! +! THE (ABSOLUTE) CHI-SQ ERROR IS DEFINED AS FOLLOWS: +! +! 2 +! CHI = SUM [ EQ(K,IOTA,PRESSURE) - DATA(K) ] ** 2 +! (K) ----------------------------------- +! SIGMA(K)**2 +! +! HERE, SIGMA IS THE STANDARD DEVIATION OF THE MEASURED DATA, AND +! EQ(IOTA,PRESSURE) IS THE EQUILIBRIUM EXPRESSION FOR THE DATA TO BE +! MATCHED: +! +! EQ(I) = SUM [ W(I,J)*X(J) ] +! (J) +! +! WHERE W(I,J) ARE THE (LINEAR) MATRIX ELEMENTS AND X(J) REPRESENT +! THE KNOT VALUES OF IOTA (AND/OR PRESSURE). THE RESULTING LEAST-SQUARES +! MATRIX ELEMENTS AND DATA ARRAY CAN BE EXPRESSED AS FOLLOWS: +! +! ALSQ(I,J) = SUM [ W(K,I) * W(K,J) / SIGMA(K) ** 2] +! (K) +! +! BLSQ(I) = SUM [ W(K,I) * DATA(K)/ SIGMA(K) ** 2] +! (K) +! +! THEREFORE, INTERNALLY IT IS CONVENIENT TO WORK WITH THE 'SCALED' +! W'(K,I) = W(K,I)/SIGMA(K) AND DATA'(K) = DATA(K)/SIGMA(K) +! +! ****! I - M - P - O - R - T - A - N - T N - O - T - E ***** +! +! THE INPUT DATA FILE WILL ACCEPT BOTH POSITIVE AND NEGATIVE +! SIGMAS, WHICH IT INTERPRETS DIFFERENTLY. FOR SIGMA > 0, IT +! TAKES SIGMA TO BE THE STANDARD DEVIATION FOR THAT MEASUREMENT +! AS DESCRIBED ABOVE. FOR SIGMA < 0, SIGMA IS INTERPRETED AS +! THE FRACTION OF THE MEASURED DATA NEEDED TO COMPUTE THE ABSOLUTE +! SIGMA, I.E., (-SIGMA * DATA) = ACTUAL SIGMA USED IN CODE. +! + + CALL second0(treadon) + + lwrite = (grank .EQ. 0) + ier_flag_init = ier_flag + ier_flag = norm_term_flag + IF (ier_flag_init .EQ. more_iter_flag) GOTO 1000 + +! +! READ IN DATA FROM INDATA FILE +! + CALL read_indata(input_file, iunit, ier_flag) + IF (ier_flag .NE. norm_term_flag) RETURN + + IF (tensi2 .EQ. zero ) tensi2 = tensi + +! +! Open output files here, print out heading to threed1 file +! +! PRINT *,'IN READIN, LWRITE: ', lwrite + IF (lwrite) THEN + CALL heading(input_extension, time_slice, + & iseq_count, lmac, lscreen, lwrite) + END IF + +! +! READ IN COMMENTS DEMARKED BY "!" +! + REWIND (iunit, iostat=iexit) + IF (lWrite) THEN + DO WHILE(iexit .EQ. 0) + READ (iunit, '(a)', iostat=iexit) line + IF (iexit .NE. 0) EXIT + iexit = INDEX(line,'INDATA') + iexit = iexit + INDEX(line,'indata') + ipoint = INDEX(line,'!') + IF (ipoint .EQ. 1) WRITE (nthreed, *) TRIM(line) + ENDDO + END IF + CLOSE (iunit) + +! +! READ IN AND STORE (FOR SEQUENTIAL RUNNING) MAGNETIC FIELD DATA +! FROM MGRID_FILE +! + IF (lfreeb) THEN + CALL second0(trc) + CALL read_mgrid (mgrid_file, extcur, nzeta, nfp, + & lscreen, ier_flag, comm = RUNVMEC_COMM_WORLD) + CALL second0(tzc) + mgrid_file_read_time = mgrid_file_read_time + (tzc - trc) + + IF (lfreeb .AND. lscreen .AND. lwrite) THEN + WRITE (6,'(2x,a,1p,e10.2,a)') 'Time to read MGRID file: ', + & tzc - trc, ' s' + IF (ier_flag .ne. norm_term_flag) RETURN + IF (lwrite) WRITE (nthreed,20) nr0b, nz0b, np0b, rminb, + & rmaxb, zminb, zmaxb, TRIM(mgrid_file) + 20 FORMAT(//,' VACUUM FIELD PARAMETERS:',/,1x,24('-'),/, + & ' nr-grid nz-grid np-grid rmin rmax zmin', + & ' zmax input-file',/,3i9,4f10.3,5x,a) + END IF + END IF + +! +! PARSE NS_ARRAY +! + nsin = MAX (3, nsin) + multi_ns_grid = 1 + IF (ns_array(1) .eq. 0) THEN !Old input style + ns_array(1) = MIN(nsin,nsd) + multi_ns_grid = 2 + ns_array(multi_ns_grid) = ns_default !Run on 31-point mesh + ELSE + nsmin = 1 + DO WHILE (ns_array(multi_ns_grid) .ge. nsmin .and. + & multi_ns_grid .lt. 100) ! .ge. previously .gt. + nsmin = MAX(nsmin, ns_array(multi_ns_grid)) + IF (nsmin .le. nsd) THEN + multi_ns_grid = multi_ns_grid + 1 + ELSE !Optimizer, Boozer code overflows otherwise + ns_array(multi_ns_grid) = nsd + nsmin = nsd + IF (lwrite) THEN + PRINT *,' NS_ARRAY ELEMENTS CANNOT EXCEED ',nsd + PRINT *,' CHANGING NS_ARRAY(',multi_ns_grid,') to ', + & nsd + END IF + END IF + END DO + multi_ns_grid = multi_ns_grid - 1 + ENDIF + IF (ftol_array(1) .eq. zero) THEN + ftol_array(1) = 1.e-8_dp + IF (multi_ns_grid .eq. 1) ftol_array(1) = ftol + DO igrid = 2, multi_ns_grid + ftol_array(igrid) = 1.e-8_dp * (1.e8_dp * ftol)** + & ( REAL(igrid-1,dp)/(multi_ns_grid-1) ) + END DO + ENDIF + + ns_maxval = nsmin +! +! WRITE OUT DATA TO THREED1 FILE +! + +!SPH121912 - SCALING TO RENDER LAMSCALE=1 +! delta = twopi/phiedge !phiedge=>twopi +! phiedge = phiedge*delta +! bcrit = bcrit*delta +! curtor = curtor*delta +! extcur = extcur*delta +! am = am*delta**2 + + IF (nvacskip .LE. 0) nvacskip = nfp + + PROC0: IF (lwrite) THEN + WRITE (nthreed,100) + & ns_array(multi_ns_grid),ntheta1,nzeta,mpol,ntor,nfp, +#ifdef _ANIMEC + & gamma,spres_ped,phiedge,curtor,bcrit,lRFP +#else + & gamma,spres_ped,phiedge,curtor,lRFP +#endif + 100 FORMAT(/,' COMPUTATION PARAMETERS: (u = theta, v = zeta)'/, + & 1x,45('-'),/, + & ' ns nu nv mu mv',/, + & 5i7,//,' CONFIGURATION PARAMETERS:',/,1x,39('-'),/, + & ' nfp gamma spres_ped phiedge(wb)' +#ifdef _ANIMEC + & ' curtor(A) BCrit(T) lRFP', + & /,i7,1p,e11.3,2e15.3,2e14.3,L12/) +#else + & ' curtor(A) lRFP', + & /,i7,1p,e11.3,2e15.3,e14.3,L12/) +#endif + WRITE (nthreed,110) ncurr,niter_array(multi_ns_grid), + & ns_array(1),nstep,nvacskip, + & ftol_array(multi_ns_grid),tcon0,lasym,lforbal,lmove_axis, + & lconm1,mfilter_fbdy,nfilter_fbdy,lfull3d1out, + & max_main_iterations,lgiveup,fgiveup ! M Drevlak 20130114 + 110 FORMAT(' RUN CONTROL PARAMETERS:',/,1x,23('-'),/, + & ' ncurr niter nsin nstep nvacskip ftol tcon0', + & ' lasym lforbal lmove_axis lconm1',/, + & 4i7,i10,1p,2e10.2,4L9,/, + & ' mfilter_fbdy nfilter_fbdy lfull3d1out max_main_iterations', ! J Geiger 20120203 + & ' lgiveup fgiveup',/, ! M Drevlak 20130114 + & 2(6x,i7),L12,10x,i10,L8,e9.1,/) ! M Drevlak 20130114 + + WRITE (nthreed,120) precon_type, prec2d_threshold + 120 FORMAT(' PRECONDITIONER CONTROL PARAMETERS:',/,1x,34('-'),/, + & ' precon_type prec2d_threshold',/,2x,a10,1p,e20.2,/) + + IF (nextcur .gt. 0) THEN + WRITE(nthreed, "(' EXTERNAL CURRENTS',/,1x,17('-'))") + ni = 0 + IF (ALLOCATED(curlabel)) THEN + ni = MAXVAL(LEN_TRIM(curlabel(1:nextcur))) + END IF + ni = MAX(ni+4, 14) + WRITE (line, '(a,i2.2,a)') "(5a",ni,")" + WRITE (line2, '(a,i2.2,a)') "(5(",ni-12,"x,1p,e12.4))" + DO i = 1,nextcur,5 + ni = MIN(i+4, nextcur) + IF (ALLOCATED(curlabel)) THEN + WRITE (nthreed, line, iostat=mj) + & (TRIM(curlabel(n)),n=i,ni) + WRITE (nthreed, line2,iostat=mj) (extcur(n), n=i,ni) + END IF + END DO + WRITE (nthreed, *) + END IF + + IF (bloat .ne. one) THEN + WRITE (nthreed,'(" Profile Bloat Factor: ",1pe11.4)') bloat + phiedge = phiedge*bloat + END IF + + IF (pres_scale .ne. one) THEN + WRITE (nthreed,121) pres_scale + END IF + 121 FORMAT(' Pressure profile factor: ',1pe11.4, + & ' (multiplier for pressure)') +! Print out am array + WRITE(nthreed,130) + WRITE(nthreed,131) TRIM(pmass_type) + WRITE(nthreed,132) + 130 FORMAT(' MASS PROFILE COEFFICIENTS - newton/m**2', + & ' (EXPANSION IN NORMALIZED RADIUS):') + 131 FORMAT(' PMASS parameterization type is ''', a,'''') + 132 FORMAT(1x,35('-')) +! WRITE(nthreed,135)(am(i-1),i=1, SIZE(am)) + 135 FORMAT(1p,6e12.3) + + SELECT CASE(TRIM(pmass_type)) + CASE ('Akima_spline','cubic_spline') + WRITE(nthreed,"(' am_aux_s is' )") + n = NonZeroLen(am_aux_s,SIZE(am_aux_s)) + WRITE(nthreed,135)(am_aux_s(i),i=1, n) + n = NonZeroLen(am_aux_f,SIZE(am_aux_f)) + WRITE(nthreed,"(' am_aux_f is' )") + WRITE(nthreed,135)(am_aux_f(i),i=1, n) + CASE DEFAULT + n = NonZeroLen(am,SIZE(am)) + WRITE(nthreed,135)(am(i-1),i=1,n) + END SELECT + + IF (ncurr.eq.0) THEN + IF (lRFP) THEN + WRITE (nthreed,142) + ELSE + WRITE (nthreed,140) + END IF +! Print out ai array +! WRITE(nthreed,135)(ai(i-1),i=1, SIZE(ai)) + WRITE(nthreed,143) TRIM(piota_type) + SELECT CASE(TRIM(piota_type)) + CASE ('Akima_spline','cubic_spline') + n = NonZeroLen(ai_aux_s,SIZE(ai_aux_s)) + WRITE(nthreed,"(' ai_aux_s is' )") + WRITE(nthreed,135)(ai_aux_s(i),i=1, n) + n = NonZeroLen(ai_aux_f,SIZE(ai_aux_f)) + WRITE(nthreed,"(' ai_aux_f is' )") + WRITE(nthreed,135)(ai_aux_f(i),i=1, n) + CASE DEFAULT + n = NonZeroLen(ai,SIZE(ai)) + WRITE(nthreed,135)(ai(i-1),i=1, n) + END SELECT + ELSE +! Print out ac array + WRITE(nthreed,145) + WRITE(nthreed,146) TRIM(pcurr_type) + WRITE(nthreed,147) +! WRITE(nthreed,135)(ac(i-1),i=1, SIZE(ac)) + SELECT CASE(TRIM(pcurr_type)) + CASE ('Akima_spline_Ip','Akima_spline_I', & + & 'cubic_spline_Ip','cubic_spline_I') + n = NonZeroLen(ac_aux_s,SIZE(ac_aux_s)) + WRITE(nthreed,"(' ac_aux_s is' )") + WRITE(nthreed,135)(ac_aux_s(i),i=1, n) + n = NonZeroLen(ac_aux_f,SIZE(ac_aux_f)) + WRITE(nthreed,"(' ac_aux_f is' )") + WRITE(nthreed,135)(ac_aux_f(i),i=1, n) + CASE DEFAULT + n = NonZeroLen(ac,SIZE(ac)) + WRITE(nthreed,135)(ac(i-1),i=1, n) + END SELECT + END IF + + 140 FORMAT(/' IOTA PROFILE COEFFICIENTS', + & ' (EXPANSION IN NORMALIZED RADIUS):',/,1x,35('-')) + 142 FORMAT(/' SAFETY-FACTOR (q) PROFILE COEFFICIENTS ai', + & ' (EXPANSION IN NORMALIZED RADIUS):',/,1x,35('-')) + 143 FORMAT(' PIOTA parameterization type is ''', a,'''') + 145 FORMAT(/' TOROIDAL CURRENT DENSITY (*V'') COEFFICIENTS', + & ' ac (EXPANSION IN NORMALIZED RADIUS):') + 146 FORMAT(' PCURR parameterization type is ''', a,'''') + 147 FORMAT(1x,38('-')) + + WRITE(nthreed,150) + n = NonZeroLen(aphi,SIZE(aphi)) + WRITE(nthreed,135)(aphi(i),i=1,n) + 150 FORMAT(/' NORMALIZED TOROIDAL FLUX COEFFICIENTS aphi', + & ' (EXPANSION IN S):',/,1x,35('-')) +#ifdef _ANIMEC + IF (ANY(ah .ne. zero)) THEN + WRITE(nthreed,160) + n = NonZeroLen(ah,SIZE(ah)) + WRITE(nthreed,135)(ah(i-1),i=1, n) + WRITE(nthreed,165) + n = NonZeroLen(at,SIZE(at)) + WRITE(nthreed,135)(at(i-1),i=1, n) + END IF + + 160 FORMAT(' HOT PARTICLE PRESSURE COEFFICIENTS ah', + & ' (EXPANSION IN TOROIDAL FLUX):',/,1x,35('-')) + 165 FORMAT(' HOT PARTICLE TPERP/T|| COEFFICIENTS at', + & ' (EXPANSION IN TOROIDAL FLUX):',/,1x,35('-')) +#endif + +! Fourier Boundary Coefficients + WRITE(nthreed,180) + 180 FORMAT(/,' R-Z FOURIER BOUNDARY COEFFICIENTS AND', + & ' MAGNETIC AXIS INITIAL GUESS',/, + & ' R = RBC*COS(m*u - n*v) + RBS*SIN(m*u - n*v),', + & ' Z = ZBC*COS(m*u - n*v) + ZBS*SIN(m*u-n*v)'/1x,86('-'), + & /,' nb mb rbc rbs zbc ', + & 'zbs ', + & ' raxis(c) raxis(s) zaxis(c) zaxis(s)') + + END IF PROC0 + +1000 CONTINUE + +! +! CONVERT TO REPRESENTATION WITH RBS(m=1) = ZBC(m=1) +! + IF (lasym) THEN + delta = ATAN((rbs(0,1) - zbc(0,1))/ + & (ABS(rbc(0,1)) + ABS(zbs(0,1)))) + IF (delta .ne. zero) THEN + DO m = 0,mpol1 + DO n = -ntor,ntor + trc = rbc(n,m)*COS(m*delta) + rbs(n,m)*SIN(m*delta) + rbs(n,m) = rbs(n,m)*COS(m*delta) + & - rbc(n,m)*SIN(m*delta) + rbc(n,m) = trc + tzc = zbc(n,m)*COS(m*delta) + zbs(n,m)*SIN(m*delta) + zbs(n,m) = zbs(n,m)*COS(m*delta) + & - zbc(n,m)*SIN(m*delta) + zbc(n,m) = tzc + END DO + END DO + END IF + END IF + +! +! ALLOCATE MEMORY FOR NU, NV, MPOL, NTOR SIZED ARRAYS +! + CALL allocate_nunv + +! +! CONVERT TO INTERNAL REPRESENTATION OF MODES +! +! R = RBCC*COS(M*U)*COS(N*V) + RBSS*SIN(M*U)*SIN(N*V) +! + RBCS*COS(M*U)*SIN(N*V) + RBSC*SIN(M*U)*COS(N*V) +! Z = ZBCS*COS(M*U)*SIN(N*V) + ZBSC*SIN(M*U)*COS(N*V) +! + ZBCC*COS(M*U)*COS(N*V) + ZBSS*SIN(M*U)*SIN(N*V) +! +! +! POINTER ASSIGNMENTS (NOTE: INDICES START AT 1, NOT 0, FOR POINTERS, EVEN THOUGH +! THEY START AT ZERO FOR RMN_BDY) +! ARRAY STACKING ORDER DETERMINED HERE +! + rbcc => rmn_bdy(:,:,rcc) + zbsc => zmn_bdy(:,:,zsc) + IF (lthreed) THEN + rbss => rmn_bdy(:,:,rss) + zbcs => zmn_bdy(:,:,zcs) + END IF + + IF (lasym) THEN + rbsc => rmn_bdy(:,:,rsc) + zbcc => zmn_bdy(:,:,zcc) + IF (lthreed) THEN + rbcs => rmn_bdy(:,:,rcs) + zbss => zmn_bdy(:,:,zss) + END IF + ENDIF + + rmn_bdy = 0; zmn_bdy = 0 + + ioff = LBOUND(rbcc,1) + joff = LBOUND(rbcc,2) + + DO m=0, mpol1 + mj = m + joff + IF (lfreeb .and. + & (mfilter_fbdy.gt.1 .and. m.gt.mfilter_fbdy)) CYCLE + DO n = -ntor, ntor + IF (lfreeb .and. + & (nfilter_fbdy.gt.0 .and. ABS(n).gt.nfilter_fbdy)) CYCLE + ni = ABS(n) + ioff + IF (n .eq. 0) THEN + isgn = 0 + ELSE IF (n .gt. 0) THEN + isgn = 1 + ELSE + isgn = -1 + END IF + rbcc(ni,mj) = rbcc(ni,mj) + rbc(n,m) + IF (m .gt. 0) zbsc(ni,mj) = zbsc(ni,mj) + zbs(n,m) + + IF (lthreed) THEN + IF (m .gt. 0) rbss(ni,mj) = rbss(ni,mj) + isgn*rbc(n,m) + zbcs(ni,mj) = zbcs(ni,mj) - isgn*zbs(n,m) + END IF + + IF (lasym) THEN + IF (m .gt. 0) rbsc(ni,mj) = rbsc(ni,mj) + rbs(n,m) + zbcc(ni,mj) = zbcc(ni,mj) + zbc(n,m) + IF (lthreed) THEN + rbcs(ni,mj) = rbcs(ni,mj) - isgn*rbs(n,m) + IF (m .gt. 0) zbss(ni,mj) = zbss(ni,mj) + isgn*zbc(n,m) + END IF + END IF + + IF (ier_flag_init .ne. norm_term_flag) CYCLE + trc = ABS(rbc(n,m)) + ABS(rbs(n,m)) + & + ABS(zbc(n,m)) + ABS(zbs(n,m)) + IF (m .eq. 0) THEN + IF (n .lt. 0) CYCLE + IF (trc.eq.zero .and. ABS(raxis_cc(n)).eq.zero .and. + & ABS(zaxis_cs(n)).eq.zero) CYCLE + IF (lwrite) WRITE (nthreed,195) n, m, rbc(n,m), rbs(n,m), + & zbc(n,m), zbs(n,m), raxis_cc(n), raxis_cs(n), + & zaxis_cc(n), zaxis_cs(n) + ELSE + IF (trc .eq. zero) CYCLE + IF (lwrite) WRITE (nthreed,195) n, m, rbc(n,m), rbs(n,m), + & zbc(n,m), zbs(n,m) + END IF + END DO + END DO + 195 FORMAT(i5,i4,1p,8e12.4) + +! +! CHECK SIGN OF JACOBIAN (SHOULD BE SAME AS SIGNGS) +! + m = 1 + mj = m+joff + rtest = SUM(rbcc(1:ntor1,mj)) + ztest = SUM(zbsc(1:ntor1,mj)) + lflip=(rtest*ztest .lt. zero) + signgs = -1 + IF (lflip) CALL flip_theta(rmn_bdy, zmn_bdy) + +! +! CONVERT TO INTERNAL FORM FOR (CONSTRAINED) m=1 MODES +! INTERNALLY, FOR m=1: XC(rss) = .5(RSS+ZCS), XC(zcs) = .5(RSS-ZCS) +! WITH XC(zcs) -> 0 FOR POLAR CONSTRAINT +! (see convert_sym, convert_asym in totzsp_mod file) +! + + IF (lconm1 .and. (lthreed .or. lasym)) THEN + ALLOCATE (temp(SIZE(rbcc,1))) + IF (lthreed) THEN + mj = 1+joff + temp = rbss(:,mj) + rbss(:,mj) = p5*(temp(:) + zbcs(:,mj)) + zbcs(:,mj) = p5*(temp(:) - zbcs(:,mj)) + END IF + IF (lasym) THEN + mj = 1+joff + temp = rbsc(:,mj) + rbsc(:,mj) = p5*(temp(:) + zbcc(:,mj)) + zbcc(:,mj) = p5*(temp(:) - zbcc(:,mj)) + END IF + IF (ALLOCATED(temp)) DEALLOCATE (temp) + END IF + +! +! PARSE TYPE OF PRECONDITIONER +! + precon_type = TRIM(ADJUSTL(precon_type)) + itype_precon = 0 !default scalar tri-di preconditioner + LPRECOND = .FALSE. + ch1 = precon_type(1:1); ch2 = precon_type(2:2) + +! ALL THE FOLLOWING USE THE FULL 2D BLOCK-TRI PRECONDITIONER +! BUT DIFFER IN THE WAY TIME-EVOLUTION IS HANDLED + SELECT CASE (ch1) + CASE ('c', 'C') +!conjugate gradient + IF (ch2 == 'g' .or. ch2 == 'G') itype_precon = 1 + LPRECOND = .TRUE. + CASE ('g', 'G') +!gmres or gmresr + IF (ch2 == 'm' .or. ch2 == 'M') itype_precon = 2 + IF (LEN_TRIM(precon_type) == 6) itype_precon = 3 + LPRECOND = .TRUE. + CASE ('t', 'T') +!transpose free qmr + IF (ch2 == 'f' .or. ch2 == 'F') itype_precon = 4 + LPRECOND = .TRUE. + END SELECT + + + iresidue = -1 + + currv = mu0*curtor !Convert to Internal units + + CALL second0(treadoff) + timer(tread) = timer(tread) + (treadoff-treadon) + CALL MPI_Bcast(LPRECOND,1,MPI_LOGICAL,0,RUNVMEC_COMM_WORLD, & + & MPI_ERR) + readin_time = timer(tread) + + END SUBROUTINE readin + + INTEGER FUNCTION NonZeroLen(array, n) + USE vmec_main, ONLY: dp, zero + IMPLICIT NONE + INTEGER, INTENT(IN) :: n + REAL(dp), INTENT(IN) :: array(n) + INTEGER :: k + + DO k = n, 1, -1 + IF (array(k) .NE. zero) EXIT + END DO + + NonZeroLen = k + + END FUNCTION NonZeroLen diff --git a/Sources/Input_Output/timer_sub.f b/Sources/Input_Output/timer_sub.f new file mode 100644 index 0000000..aee098e --- /dev/null +++ b/Sources/Input_Output/timer_sub.f @@ -0,0 +1,106 @@ + MODULE timer_sub + USE stel_kinds, ONLY: dp + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, PARAMETER :: tsum = 0, tvac = 1, tread = 2, twout= 3, + & teqf = 4, tfun = 5, trecon= 6, tfft = 7, + & tffi = 8, tfor = 9, tbcov =10, tres = 11, + & tprec2d = 12, tvac_2d = 13, tfun_2d = 14, + & tfact_2d=15, tio = 16 + + INTEGER, PARAMETER :: tsurf=1, tscal=2, tbext=3, tsolver=4, + & tallg=5, tfouri=6, tgreenf=7, tfourp=8, + & tallr=9, tanal=10, tasum=11, tasum2=12, + & tallgv=13, tanar=14 + + REAL(dp) :: treadon, treadoff, tfunon, tfunoff, + & treconon, treconoff, tffton, tfftoff, + & tbcovon, tbcovoff, tvacon, tvacoff, + & tforon, tforoff, treson, tresoff, + & tprec2don, tprec2doff, twouton, twoutoff, + & teqfon, teqfoff, timeon, timeoff, + & timer_tsum, timer_tfun, timer_io + REAL(dp), DIMENSION(0:15) :: timer=0 + REAL(dp), DIMENSION(15) :: timer_vac=0 + + CONTAINS + + SUBROUTINE write_times (nthreed, lscreen, lfreeb, lrecon, lprec2d) + IMPLICIT NONE + INTEGER, INTENT(in) :: nthreed + LOGICAL, INTENT(in) :: lscreen, lfreeb, lrecon, lprec2d + INTEGER :: i, nform + CHARACTER(LEN=*), DIMENSION(0:16), PARAMETER :: form = + & (/ 'TOTAL COMPUTATIONAL TIME (SEC) ', + & ' FREE BOUNDARY (VACUUM) ', + & ' READ IN DATA ', + & ' WRITE OUT DATA TO WOUT ', + & ' EQFORCE ', + & 'TIME IN FUNCT3D ', + & ' PROFILE RECONSTRUCTION ', + & ' FOURIER TRANSFORM ', + & ' INVERSE FOURIER TRANSFORM ', + & ' FORCES AND SYMMETRIZE ', + & ' BCOVAR FIELDS ', + & ' RESIDUE ', + & 'TIME IN PRECON2D SETUP ', + & ' VACUUM ONLY ', + & ' FUNCT3D ', + & ' FORWARD SOLVE (FACTOR BLKS) ', + & 'TIME TO INPUT/OUTPUT ' + & /) + + timer_tsum = timer(tsum) + timer(twout) + timer(teqf) + timer_tfun = timer(tfun) + timer_io = timer(tread) + timer(twout) + + DO i = 1,2 + IF (i .eq. 1) nform = 6 + IF (i .eq. 2) nform = nthreed + IF (.not.lscreen .and. i.eq.1) CYCLE + WRITE (nform, 20) + & form(tsum) ,timer_tsum, form(tio), timer_io, + & form(tread),timer(tread), form(twout),timer(twout), + & form(tfun) , timer(tfun), form(tbcov) ,timer(tbcov), + & form(tfft) , timer(tfft), form(tffi) ,timer(tffi), + & form(tfor) , timer(tfor), form(tres), timer(tres), + & form(teqf) ,timer(teqf) + IF (lrecon) WRITE (nform, 20) form(trecon),timer(trecon) + IF (lfreeb) THEN + WRITE (nform, 20) form(tvac) ,timer(tvac) + WRITE (nform, 24) timer_vac(tsurf), timer_vac(tbext), + & timer_vac(tscal), timer_vac(tanal), timer_vac(tasum), + & timer_vac(tasum2), timer_vac(tanar), timer_vac(tgreenf), + & timer_vac(tfourp), timer_vac(tallr), timer_vac(tallg), + & timer_vac(tfouri), timer_vac(tallgv),timer_vac(tsolver) + END IF + IF (lprec2d) THEN + WRITE (nform, 20) form(tprec2d), timer(tprec2d), + & form(tfun_2d), timer(tfun_2d), + & form(tfact_2d), timer(tprec2d)-timer(tfun_2d) + IF (lfreeb) WRITE (nform, 20) form(tvac_2d), timer(tvac_2d) + END IF + END DO + + 20 FORMAT(a35,f12.2) + 24 FORMAT( 10x, 'VACUUM SURFACE ',7x,f12.2, + & /,10x, 'VACUUM BEXTERN ',7x,f12.2, + & /,10x, 'VACUUM SCALPOT ',7x,f12.2, + & /,10x, ' ANALYT ',7x,f12.2, + & /,10x, ' ASUM ',7x,f12.2, + & /,10x, ' ASUM2 ',7x,f12.2, + & /,10x, ' ALLREDUCE ',7x,f12.2, + & /,10x, ' GREENF ',7x,f12.2, + & /,10x, ' FOURP ',7x,f12.2, + & /,10x, ' ALLREDUCE ',7x,f12.2, + & /,10x, ' ALLGATHER ',7x,f12.2, + & /,10x, ' FOURI ',7x,f12.2, + & /,10x, 'VACUUM ALLGATHER ',7x,f12.2, + & /,10x, 'VACUUM SOLVER ',7x,f12.2) + + END SUBROUTINE write_times + + END MODULE timer_sub diff --git a/Sources/Input_Output/vmec_io.f b/Sources/Input_Output/vmec_io.f new file mode 100644 index 0000000..1a7d938 --- /dev/null +++ b/Sources/Input_Output/vmec_io.f @@ -0,0 +1,11 @@ + MODULE vmec_io + USE stel_kinds + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec) :: VolAvgB, IonLarmor, Aminor_p, Rmajor_p, + 1 betatot, betapol, betator, betaxis, b0, volume_p, + 2 cross_area_p, surf_area_p, circum_p, kappa_p + REAL(rprec) :: rmax_surf, rmin_surf, zmax_surf + END MODULE vmec_io diff --git a/Sources/Input_Output/vmercier.f b/Sources/Input_Output/vmercier.f new file mode 100644 index 0000000..821b27b --- /dev/null +++ b/Sources/Input_Output/vmercier.f @@ -0,0 +1,9 @@ + MODULE vmercier + USE vparams, ONLY: nsd, rprec, dp + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec), DIMENSION(nsd) :: + 1 Dshear, Dwell, Dcurr, Dmerc, Dgeod + END MODULE vmercier diff --git a/Sources/Input_Output/write_dcon.f b/Sources/Input_Output/write_dcon.f new file mode 100644 index 0000000..939b496 --- /dev/null +++ b/Sources/Input_Output/write_dcon.f @@ -0,0 +1,73 @@ + SUBROUTINE write_dcon (rzl_array) + USE vmec_main, fpsi=>bvcof + USE vmec_params, ONLY: ntmax, rcc, rsc, zsc, zcc, mscale, nscale + USE realspace + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec), DIMENSION(ns,0:ntor,0:mpol1,3*ntmax), + 1 TARGET, INTENT(in) :: rzl_array +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: istat, m + REAL(rprec), ALLOCATABLE, DIMENSION(:,:,:) :: rmncc, rmnsc, zmnsc, & + & zmncc, lmnsc, lmncc + REAL(rprec) :: t1(0:mpol1) + CHARACTER*(256) :: dcon_file +C----------------------------------------------- + t1 = nscale(0)*mscale(0:mpol1) + + ALLOCATE (rmncc(ns,0:0,0:mpol1), zmnsc(ns,0:0,0:mpol1), & + & lmnsc(ns,0:0,0:mpol1), stat=istat) + IF (istat .ne. 0) STOP 'Allocation error in write_dcon' + DO m=0,mpol1 + rmncc(:,0,m) = rzl_array(:,0,m,rcc)*t1(m) !!COS(mu) COS(nv) + zmnsc(:,0,m) = rzl_array(:,0,m,zsc+ntmax)*t1(m) !!SIN(mu) COS(nv) + lmnsc(:,0,m) = rzl_array(:,0,m,zsc+2*ntmax)*t1(m) !!SIN(mu) COS(nv) + END DO + + IF (lasym) THEN + ALLOCATE (rmnsc(ns,0:0,0:mpol1), zmncc(ns,0:0,0:mpol1), & + & lmncc(ns,0:0,0:mpol1), stat=istat) + IF (istat .ne. 0) STOP 'Allocation error in write_dcon' + DO m=0,mpol1 + rmnsc(:,0,m) = rzl_array(:,0,m,rsc)*t1(m) !!SIN(mu) COS(nv) + zmncc(:,0,m) = rzl_array(:,0,m,zcc+ntmax)*t1(m) !!COS(mu) COS(nv) + lmncc(:,0,m) = rzl_array(:,0,m,zcc+2*ntmax)*t1(m) !!COS(mu) COS(nv) + END DO + ENDIF + +! HERE, FULL(i) = (i-1)*hs, i=1,ns (hs=1/(ns-1)) +! HALF(i) = (i-1.5)*hs, i=2,ns + + dcon_file = "dcon_" // TRIM(input_extension) // ".txt" + OPEN (unit=51,FILE=dcon_file,FORM='FORMATTED',iostat=istat) + IF (istat .ne. 0) STOP 'Error writing dcon output file' + + IF (mnmax .ne. mpol) STOP 'THIS IS NOT AXISYMMETRIC!' + + WRITE (51, *) ns !Number of flux surfaces + WRITE (51, *) mpol !Number of poloidal modes, m=[0:mpol-1] + WRITE (51, *) lasym !Up-down sym:=F + WRITE (51, *) rmncc(1:ns,0,0:mpol1) !r = sum [rmnc * cos (mu)], full mesh + WRITE (51, *) zmnsc(1:ns,0,0:mpol1) !z = sum [zmns * sin (mu)], full mesh + WRITE (51, *) lmnsc(1:ns,0,0:mpol1) !lam = sum[lmns * sin(mu)], half mesh +! NOTE: u + lam give a straight magnetic field line + IF (lasym) THEN + WRITE (51, *) rmnsc(1:ns,0,0:mpol1) !r = r+sum [rmns * sin (mu)], full mesh + WRITE (51, *) zmncc(1:ns,0,0:mpol1) !z = z+sum [zmnc * cos (mu)], full mesh + WRITE (51, *) lmncc(1:ns,0,0:mpol1) !lam = lam+sum[lmnc * cos(mu)], half mesh + END IF + WRITE (51, *) chi(1:ns) !pol flux, full mesh (included 2*pi factor) + WRITE (51, *) fpsi(1:ns) !R*BT, full mesh + WRITE (51, *) presf(1:ns)/mu0 !pressure, full mesh (MKS units) + WRITE (51, *) 1/iotaf(1:ns) !q, full mesh + + CLOSE (unit=51) + + DEALLOCATE (rmncc, zmnsc, lmnsc, stat=istat) + IF (lasym) DEALLOCATE (rmnsc, zmncc, lmncc, stat=istat) + + END SUBROUTINE write_dcon diff --git a/Sources/Input_Output/wrout.f b/Sources/Input_Output/wrout.f new file mode 100644 index 0000000..d0b0cf6 --- /dev/null +++ b/Sources/Input_Output/wrout.f @@ -0,0 +1,1669 @@ + SUBROUTINE wrout(bsq, gsqrt, bsubu, bsubv, bsubs, bsupv, bsupu, + 1 rzl_array, gc_array, ier_flag, lwrite +#ifdef _ANIMEC + 2 ,tau_an, sigma_an, ppar, pperp, onembc, pbprim, + 3 ppprim, densit +#endif + 4 ) +! ... from SPH 2009-10-05; changes for modB sine-harmonics included + USE vmec_input, ONLY: ns_array, ftol_array, lwouttxt, lnyquist + USE vmec_params + USE vmec_main + USE vmercier + USE vmec_persistent + USE vparams, p5 => cp5, two => c2p0 + USE vac_persistent + USE vspline + USE xstuff + USE vmec_io + USE realspace, ONLY: phip, chip, gsqrta=>z1, z1=>z1 + USE totzsp_mod + USE vforces, ONLY: bsupua=>brmn_e, bsupva=>czmn_o, bsqa=>bzmn_e, + 1 bsubsa=>armn_e, bsubua=>azmn_e, bsubva=>armn_o +#ifdef _VACUUM2 + USE vac2_vacmod, ONLY: potvac, mnpd, xmpot, xnpot +#else + USE vacmod, ONLY: potvac, mnpd, xmpot, xnpot !added for diagno, J.Geiger +#endif +#ifdef _HBANGLE + USE angle_constraints, ONLY: getrz +#endif +!undef NETCDF IF TXT DESIRED +#ifdef NETCDF + USE ezcdf + USE read_wout_mod, ONLY: Compute_Currents, + 1 vn_version, vn_extension, vn_mgrid, + 1 vn_magen, vn_therm, vn_gam, vn_maxr, vn_minr, vn_maxz, vn_fp, + 2 vn_radnod, vn_polmod, vn_tormod, vn_maxmod, vn_maxit, vn_actit, + 3 vn_asym, vn_recon, vn_free, vn_error, vn_aspect, vn_beta, + 4 vn_pbeta, vn_tbeta, vn_abeta, vn_b0, vn_rbt0, vn_maxmod_nyq, + 5 vn_rbt1, vn_sgs, vn_lar, vn_modB, vn_ctor, vn_amin, vn_Rmaj, + 5 vn_potsin, vn_potcos, vn_maxpot, vn_xmpot, vn_xnpot, !diagno/extender output (SPH071414) + 6 vn_vol, vn_mse, vn_thom, vn_ac, vn_ai, vn_am, vn_rfp, + 6 vn_pmass_type, vn_pcurr_type, vn_piota_type, + 6 vn_am_aux_s, vn_am_aux_f, vn_ac_aux_s, vn_ac_aux_f, + 6 vn_ai_aux_s, vn_ai_aux_f, + 6 vn_ftolv, vn_fsqr, vn_fsqz, vn_fsql, + 7 vn_pmod, vn_tmod, vn_pmod_nyq, vn_tmod_nyq, + 7 vn_racc, vn_zacs, vn_racs, vn_zacc, vn_iotaf, vn_qfact, + 8 vn_presf, vn_phi, vn_phipf, vn_jcuru, vn_jcurv, vn_iotah, + 8 vn_chi, vn_chipf, + 9 vn_mass, vn_presh, vn_betah, vn_buco, vn_bvco, vn_vp, vn_specw, + A vn_phip, vn_jdotb, vn_bdotb, vn_overr, vn_bgrv, vn_merc, + B vn_mshear, vn_mwell, vn_mcurr, vn_mgeo, vn_equif, vn_fsq, + C vn_wdot, vn_extcur, vn_curlab, vn_rmnc, vn_zmns, vn_lmns, + D vn_gmnc, vn_bmnc, vn_bsubumnc, vn_bsubvmnc, vn_bsubsmns, + E vn_bsupumnc, vn_bsupvmnc, vn_rmns, vn_zmnc, vn_lmnc, vn_gmns, + F vn_bmns, vn_bsubumns, vn_bsubvmns, vn_bsubsmnc, vn_bsupumns, + G vn_bsupvmns, vn_rbc, vn_zbs, vn_rbs, vn_zbc, + H ln_version, ln_extension, ln_mgrid, + + & vn_bsubumnc_sur, vn_bsubvmnc_sur, !MRC 10-15-15 + & vn_bsupumnc_sur, vn_bsupvmnc_sur, + & vn_bsubumns_sur, vn_bsubvmns_sur, + & vn_bsupumns_sur, vn_bsupvmns_sur, + & vn_currumnc, vn_currumns, vn_currvmnc, vn_currvmns, !MRC 8-12-16 + + 1 ln_magen, ln_therm, ln_gam, ln_maxr, ln_minr, ln_maxz, ln_fp, + 2 ln_radnod, ln_polmod, ln_tormod, ln_maxmod, ln_maxit, ln_actit, + 2 ln_maxpot, ln_potsin, ln_potcos, + 3 ln_asym, ln_recon, ln_free, ln_error, ln_aspect, ln_beta, + 4 ln_pbeta, ln_tbeta, ln_abeta, ln_b0, ln_rbt0, ln_maxmod_nyq, + 5 ln_rbt1, ln_sgs, ln_lar, ln_modB, ln_ctor, ln_amin, ln_Rmaj, + 6 ln_mse, ln_thom, ln_flp, ln_nobd, ln_nbset, ln_next, ln_nbfld, + 7 ln_pmod, ln_tmod, ln_pmod_nyq, ln_tmod_nyq, ln_racc, ln_zacs, + 7 ln_racs, ln_zacc, ln_iotaf, ln_qfact, ln_am, ln_ac, ln_ai, + 7 ln_pmass_type, ln_pcurr_type, ln_piota_type, + 7 ln_am_aux_s, ln_am_aux_f, ln_ac_aux_s, ln_ac_aux_f, + 7 ln_ai_aux_s, ln_ai_aux_f, ln_chi, ln_chipf, + 8 ln_presf, ln_phi, ln_phipf, ln_jcuru, ln_jcurv, ln_iotah, + 9 ln_mass, ln_presh, ln_betah, ln_buco, ln_bvco, ln_vp, ln_specw, + A ln_vol, ln_phip, ln_jdotb, ln_bdotb, ln_bgrv, ln_merc, + B ln_mshear, ln_mwell, ln_mcurr, ln_mgeo, ln_equif, ln_fsq, + C ln_wdot, ln_extcur, ln_curlab, ln_rmnc, ln_zmns, ln_lmns, + D ln_gmnc, ln_bmnc, ln_bsubumnc, ln_bsubvmnc, ln_bsubsmns, + E ln_bsupumnc, ln_bsupvmnc, ln_rmns, ln_zmnc, ln_lmnc, ln_gmns, + F ln_bmns, ln_bsubumns, ln_bsubvmns, ln_bsubsmnc, ln_bsupumns, + G ln_bsupvmns, ln_rbc, ln_zbs, ln_rbs, ln_zbc, + + & ln_bsubumnc_sur, ln_bsubvmnc_sur, !MRC 10-15-15 + & ln_bsupumnc_sur, ln_bsupvmnc_sur, + & ln_bsubumns_sur, ln_bsubvmns_sur, + & ln_bsupumns_sur, ln_bsupvmns_sur, + & ln_currumnc, ln_currumns, ln_currvmnc, ln_currvmns + +!------------------DEC$ ELSE !to use safe_open_mod in any case (J.Geiger) +#endif + USE safe_open_mod + USE mgrid_mod + + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(in) :: ier_flag + REAL(dp), DIMENSION(mnmax,ns,3*MAX(ntmax/2,1)), !reverse ns, mnmax for backwards compatibility + 1 INTENT(inout), TARGET :: rzl_array, gc_array + REAL(dp), DIMENSION(ns,nznt), INTENT(inout) :: + 1 bsq, gsqrt, bsubu, bsubv, bsubs, bsupv, bsupu +#ifdef _ANIMEC + 2 ,tau_an, ppar, pperp, onembc, sigma_an + REAL(dp), DIMENSION(ns,nznt), INTENT(out) :: + 1 densit, pbprim, ppprim +#endif + REAL(dp) :: qfact(ns) + LOGICAL :: lwrite +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(dp), PARAMETER :: c1p5 = 1.5_dp +#ifdef NETCDF + CHARACTER(LEN=*), PARAMETER, DIMENSION(1) :: + 1 r1dim = (/'radius'/), mn1dim = (/'mn_mode'/), + 2 mn2dim = (/'mn_mode_nyq'/), + 2 mnpotdim = (/'mn_mode_pot'/), + 3 currg = (/'ext_current'/), + 4 currl = (/'current_label'/) + CHARACTER(LEN=*), DIMENSION(2), PARAMETER :: + 1 r2dim = (/'mn_mode','radius '/), + 1 r3dim = (/'mn_mode_nyq','radius '/) +#endif +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: j, js, jlk, mn, lk, iasym, + 1 m, n, k, iwout0, n1, nwout, istat, i, indx1(1), + 2 mnmax_nyq0, mnyq0, nnyq0, nwout2 ! nwout2 by J.Geiger + 3 ,isgn, js2, nfort !for diagno 1.5 + REAL(dp) :: dmult, tcosi, tsini, vversion, sgn, tmult, + 1 presfactor, ftolx1, d_bsupumn, d_bsupvmn ! diagno 1.5 +#ifdef _ANIMEC + 2 ,hotdam, omtbc, optbc, pdh, pmh, pde, pme, eps +#endif + REAL(dp), POINTER, DIMENSION(:,:) :: rmnc, rmns, zmns, + 1 zmnc, lmns, lmnc + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: + 1 gmnc, bmnc, gmns, bmns, + 2 bsubumnc, bsubvmnc, bsubsmns, bsubumns, bsubvmns, bsubsmnc, + 3 currumnc, currvmnc, currumns, currvmns +#ifdef _ANIMEC + 3 ,sigmnc , taumnc , pparmnc , ppermnc , pbprmnc , ppprmnc , + 4 hotdmnc , hotdmns , + 5 sigmns , taumns , pparmns , ppermns , pbprmns , ppprmns + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: sigma_ana, tau_ana, + 1 ppara, pperpa, pbprima, ppprima, densita +#endif + REAL(dp), DIMENSION(mnmax) :: rmnc1, zmns1, lmns1, + 1 rmns1, zmnc1, lmnc1, bmodmn, bmodmn1 + REAL(dp), DIMENSION(:), ALLOCATABLE :: gmn, bmn, + 1 bsubumn, bsubvmn, bsubsmn, bsupumn, bsupvmn +#ifdef _ANIMEC + 2 ,sigmn , taumn , pparmn , ppermn , pbprmn , ppprmn , hotdmn +#endif + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubumnc_sur !MRC 10-15-15 + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubvmnc_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsupumnc_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsupvmnc_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubumns_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubvmns_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsupumns_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsupvmns_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsubua_sur, bsubva_sur + REAL(dp), DIMENSION(:), ALLOCATABLE :: bsupua_sur, bsupva_sur + + CHARACTER(LEN=120) :: wout_file, wout2_file ! wout2_file by J.Geiger + CHARACTER(LEN=120) :: fort_file ! fort_file for diagno 1.5 + REAL(dp), DIMENSION(:), ALLOCATABLE :: xfinal + REAL(dp), DIMENSION(:), POINTER :: xm_nyq0, xn_nyq0 +! ELIMINATE THESE EVENTUALLY + REAL(dp), ALLOCATABLE, DIMENSION(:,:) :: + 1 bsupumnc, bsupumns, bsupvmnc, bsupvmns + + LOGICAL :: lcurr + INTEGER :: nmin0 ! J Geiger: Added for diagno-file + +!----------------------------------------------- + CALL second0 (twouton) +! +! Pointer assignments for storage arrays +! + n1 = MAX(1,ntmax/2) + rmnc => rzl_array(:,:,1) !!store COS(mu-nv) components + zmns => rzl_array(:,:,1+n1) !!store SIN(mu-nv) + lmns => rzl_array(:,:,1+2*n1) !!store SIN(mu-nv) + + IF (lasym) THEN + rmns => gc_array(:,:,1) !!store SIN(mu-nv) + zmnc => gc_array(:,:,1+n1) !!store COS(mu-nv) + lmnc => gc_array(:,:,1+2*n1) !!store COS(mu-nv) + END IF + +! +! THIS SUBROUTINE CREATES THE FILE WOUT.IT CONTAINS THE CYLINDRICAL COORDINATE SPECTRAL +! COEFFICIENTS RMN,ZMN (full), LMN (half_mesh - CONVERTED FROM +! INTERNAL full REPRESENTATION), AS WELL AS COEFFICIENTS (ON NYQ MESH) FOR COMPUTED +! QUANTITIES: +! +! BSQ, BSUPU,V, BSUBU,V, GSQRT (HALF); BSUBS (FULL-CONVERTED IN JXBFORCE) +! + IF (lnyquist) THEN + mnmax_nyq0 = mnmax_nyq + mnyq0 = mnyq + nnyq0 = nnyq + xm_nyq0 => xm_nyq; xn_nyq0 => xn_nyq + ELSE + mnmax_nyq0 = mnmax + mnyq0 = mpol1 + nnyq0 = ntor + xm_nyq0 => xm; xn_nyq0 => xn + END IF + + ALLOCATE (gmn(mnmax_nyq0), bmn(mnmax_nyq0), + 1 bsubumn(mnmax_nyq0), bsubvmn(mnmax_nyq0), bsubsmn(mnmax_nyq0), + 2 bsupumn(mnmax_nyq0), bsupvmn(mnmax_nyq0), +#ifdef _ANIMEC + 3 sigmn(mnmax_nyq0) , + 4 taumn(mnmax_nyq0) , pparmn(mnmax_nyq0) , ppermn(mnmax_nyq0) , + 5 pbprmn(mnmax_nyq0) , ppprmn(mnmax_nyq0) , hotdmn(mnmax_nyq0) , +#endif + 6 stat=istat) + + IF (lfreeb) THEN !MRC 10-15-15 + ALLOCATE (bsubua_sur(nzeta*ntheta2), bsubva_sur(nzeta*ntheta2)) + ALLOCATE (bsupua_sur(nzeta*ntheta2), bsupva_sur(nzeta*ntheta2)) + + ALLOCATE (bsubumnc_sur(mnmax_nyq0), bsubvmnc_sur(mnmax_nyq0)) + ALLOCATE (bsupumnc_sur(mnmax_nyq0), bsupvmnc_sur(mnmax_nyq0)) + IF (lasym) THEN + ALLOCATE (bsubumns_sur(mnmax_nyq0), & + & bsubvmns_sur(mnmax_nyq0)) + ALLOCATE (bsupumns_sur(mnmax_nyq0), & + & bsupvmns_sur(mnmax_nyq0)) + END IF + END IF + + ALLOCATE (gmnc(mnmax_nyq0,ns), bmnc(mnmax_nyq0,ns), + 1 bsubumnc(mnmax_nyq0,ns), bsubvmnc(mnmax_nyq0,ns), + 2 bsubsmns(mnmax_nyq0,ns), bsupumnc(mnmax_nyq0,ns), + 3 bsupvmnc(mnmax_nyq0,ns), + 4 currumnc(mnmax_nyq0,ns), currvmnc(mnmax_nyq0,ns), +#ifdef _ANIMEC + 5 sigmnc(mnmax_nyq0,ns) , + 6 taumnc(mnmax_nyq0,ns) , pparmnc(mnmax_nyq0,ns) , + 7 ppermnc(mnmax_nyq0,ns) , pbprmnc(mnmax_nyq0,ns) , + 8 ppprmnc(mnmax_nyq0,ns) , hotdmnc(mnmax_nyq0,ns) , +#endif + 9 stat=istat) + IF (lasym) THEN + ALLOCATE (gmns(mnmax_nyq0,ns), bmns(mnmax_nyq0,ns), + 1 bsubumns(mnmax_nyq0,ns), bsubvmns(mnmax_nyq0,ns), + 2 bsubsmnc(mnmax_nyq0,ns), bsupumns(mnmax_nyq0,ns), + 3 bsupvmns(mnmax_nyq0,ns), + 4 currumns(mnmax_nyq0,ns), currvmns(mnmax_nyq0,ns), +#ifdef _ANIMEC + 4 sigmns(mnmax_nyq0,ns) , + 5 taumns(mnmax_nyq0,ns) , pparmns(mnmax_nyq0,ns) , + 6 ppermns(mnmax_nyq0,ns) , pbprmns(mnmax_nyq0,ns) , + 7 ppprmns(mnmax_nyq0,ns) , hotdmns(mnmax_nyq0,ns) , +#endif + 8 stat=istat) +#ifdef _ANIMEC + ALLOCATE (sigma_ana(ns,nznt) ,tau_ana(ns,nznt) ,densita(ns,nznt), + 1 ppara(ns,nznt) ,pperpa(ns,nznt) ,pbprima(ns,nznt), + 2 ppprima(ns,nznt), stat=istat) +#endif + END IF + IF (istat .ne. 0) STOP 'Error allocating arrays in VMEC WROUT' + +! IF (nextcur .eq. 0) THEN +! DO j = SIZE(extcur), 1, -1 +! IF (extcur(j) .ne. zero) THEN +! nextcur = j +! EXIT +! END IF +! END DO +! END IF + +! ftol info evaluated here! + indx1=MAXLOC(ns_array) + ftolx1=ftol_array(indx1(1)) + +! NYQUIST FREQUENCY REQUIRES FACTOR OF 1/2 + IF (lnyquist) THEN + IF (mnyq .ne. 0) cosmui(:,mnyq) = p5*cosmui(:,mnyq) + IF (nnyq .ne. 0) cosnv (:,nnyq) = p5*cosnv (:,nnyq) + END IF + wout_file = version_ + READ (wout_file, *) vversion + +#ifdef NETCDF + wout_file = 'wout_' // TRIM(input_extension) // '.nc' + CALL cdf_open(nwout,wout_file,'w',iwout0) + IF (iwout0 .ne. 0) STOP 'Error opening wout.nc file VMEC WROUT' + +!================================ +! Define Variables +!================================ +! Scalars + CALL cdf_define(nwout, vn_version, vversion) + CALL cdf_define(nwout, vn_extension, input_extension) + CALL cdf_define(nwout, vn_mgrid, mgrid_file) + CALL cdf_define(nwout, vn_pcurr_type, pcurr_type) + CALL cdf_define(nwout, vn_pmass_type, pmass_type) + CALL cdf_define(nwout, vn_piota_type, piota_type) + CALL cdf_define(nwout, vn_magen, wb) + CALL cdf_define(nwout, vn_therm, wp) + CALL cdf_define(nwout, vn_gam, gamma) + CALL cdf_define(nwout, vn_maxr, rmax_surf) + CALL cdf_define(nwout, vn_minr, rmin_surf) + CALL cdf_define(nwout, vn_maxz, zmax_surf) + CALL cdf_define(nwout, vn_fp, nfp) + CALL cdf_define(nwout, vn_radnod, ns) + CALL cdf_define(nwout, vn_polmod, mpol) + CALL cdf_define(nwout, vn_tormod, ntor) + CALL cdf_define(nwout, vn_maxmod, mnmax) + CALL cdf_define(nwout, vn_maxmod_nyq, mnmax_nyq0) + CALL cdf_define(nwout, vn_maxit, iter2) + CALL cdf_define(nwout, vn_actit, itfsq) + CALL cdf_define(nwout, vn_asym, lasym) + CALL cdf_define(nwout, vn_recon, lrecon) + CALL cdf_define(nwout, vn_free, lfreeb) + CALL cdf_define(nwout, vn_rfp, lrfp) + CALL cdf_define(nwout, vn_error, ier_flag) + CALL cdf_define(nwout, vn_aspect, aspect) + CALL cdf_define(nwout, vn_beta, betatot) + CALL cdf_define(nwout, vn_pbeta, betapol) + CALL cdf_define(nwout, vn_tbeta, betator) + CALL cdf_define(nwout, vn_abeta, betaxis) + CALL cdf_define(nwout, vn_b0, b0) + CALL cdf_define(nwout, vn_rbt0, rbtor0) + CALL cdf_define(nwout, vn_rbt1, rbtor) + CALL cdf_define(nwout, vn_sgs, NINT(signgs)) + CALL cdf_define(nwout, vn_lar, IonLarmor) + CALL cdf_define(nwout, vn_modB, volAvgB) + CALL cdf_define(nwout, vn_ctor, ctor) + CALL cdf_define(nwout, vn_amin, Aminor_p) + CALL cdf_define(nwout, vn_Rmaj, Rmajor_p) + CALL cdf_define(nwout, vn_vol, volume_p) + CALL cdf_define(nwout, vn_ftolv, ftolx1) + CALL cdf_define(nwout, vn_fsql, fsql) + CALL cdf_define(nwout, vn_fsqr, fsqr) + CALL cdf_define(nwout, vn_fsqz, fsqz) + + CALL cdf_define(nwout, vn_nextcur, nextcur) + CALL cdf_define(nwout, vn_extcur, extcur(1:nextcur), + 1 dimname=currg) + CALL cdf_define(nwout, vn_mgmode, mgrid_mode) + IF (lfreeb) THEN + CALL cdf_define(nwout, vn_maxpot, mnpd) + CALL cdf_define(nwout, vn_flp, nobser) + CALL cdf_define(nwout, vn_nobd, nobd) + CALL cdf_define(nwout, vn_nbset, nbsets) + IF (nbsets .gt. 0) + 1 CALL cdf_define(nwout,vn_nbfld,nbfld(1:nbsets)) + END IF + + IF (.not.lwrite) GO TO 800 + +! 1D Arrays + + CALL cdf_define(nwout, vn_pmod, xm, dimname=mn1dim) + CALL cdf_setatt(nwout, vn_pmod, ln_pmod) + CALL cdf_define(nwout, vn_tmod, xn, dimname=mn1dim) + CALL cdf_setatt(nwout, vn_tmod, ln_tmod) + CALL cdf_define(nwout, vn_pmod_nyq, xm_nyq0, dimname=mn2dim) + CALL cdf_setatt(nwout, vn_pmod_nyq, ln_pmod_nyq) + CALL cdf_define(nwout, vn_tmod_nyq, xn_nyq0, dimname=mn2dim) + CALL cdf_setatt(nwout, vn_tmod_nyq, ln_tmod_nyq) + + CALL cdf_define(nwout, vn_racc, raxis_cc(0:ntor), + 1 dimname=(/'n_tor'/)) + CALL cdf_setatt(nwout, vn_racc, ln_racc) + CALL cdf_define(nwout, vn_zacs, zaxis_cs(0:ntor), + 1 dimname=(/'n_tor'/)) + CALL cdf_setatt(nwout, vn_zacs, ln_zacs) + IF (lasym) THEN + CALL cdf_define(nwout, vn_racs, raxis_cs(0:ntor), + 1 dimname=(/'n_tor'/)) + CALL cdf_setatt(nwout, vn_racs, ln_racs) + CALL cdf_define(nwout, vn_zacc, zaxis_cc(0:ntor), + 1 dimname=(/'n_tor'/)) + CALL cdf_setatt(nwout, vn_zacc, ln_zacc) + END IF + + j = SIZE(am)-1 + CALL cdf_define(nwout, vn_am, am(0:j), + 1 dimname=(/'preset'/)) + j = SIZE(ac)-1 + CALL cdf_define(nwout, vn_ac, ac(0:j), + 1 dimname=(/'preset'/)) + j = SIZE(ai)-1 + CALL cdf_define(nwout, vn_ai, ai(0:j), + 1 dimname=(/'preset'/)) + + j = SIZE(am_aux_s) + CALL cdf_define(nwout, vn_am_aux_s, am_aux_s(1:j), + 1 dimname=(/'ndfmax'/)) + j = SIZE(am_aux_f) + CALL cdf_define(nwout, vn_am_aux_f, am_aux_f(1:j), + 1 dimname=(/'ndfmax'/)) + j = SIZE(ai_aux_s) + CALL cdf_define(nwout, vn_ai_aux_s, ai_aux_s(1:j), + 1 dimname=(/'ndfmax'/)) + j = SIZE(ai_aux_f) + CALL cdf_define(nwout, vn_ai_aux_f, ai_aux_f(1:j), + 1 dimname=(/'ndfmax'/)) + j = SIZE(ac_aux_s) + CALL cdf_define(nwout, vn_ac_aux_s, ac_aux_s(1:j), + 1 dimname=(/'ndfmax'/)) + j = SIZE(ac_aux_f) + CALL cdf_define(nwout, vn_ac_aux_f, ac_aux_f(1:j), + 1 dimname=(/'ndfmax'/)) + + + CALL cdf_define(nwout, vn_iotaf, iotaf(1:ns), + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_iotaf, ln_iotaf) + + qfact=HUGE(qfact) + WHERE (iotaf(1:ns) .NE. zero) qfact=one/iotaf(1:ns) + + CALL cdf_define(nwout, vn_qfact, qfact(1:ns), + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_iotaf, ln_qfact) + CALL cdf_define(nwout, vn_presf, presf, + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_presf, ln_presf, units='Pa') + CALL cdf_define(nwout, vn_phi, phi, + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_phi, ln_phi, units='wb') + CALL cdf_define(nwout, vn_phipf, + 1 phipf, dimname=r1dim) + CALL cdf_setatt(nwout, vn_phipf, ln_phipf) + CALL cdf_define(nwout, vn_chi, chi, + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_chi, ln_chi, units='wb') + CALL cdf_define(nwout, vn_chipf, + 1 phipf, dimname=r1dim) + CALL cdf_setatt(nwout, vn_chipf, ln_chipf) + CALL cdf_define(nwout, vn_jcuru, + 1 jcuru, dimname=r1dim) + CALL cdf_define(nwout, vn_jcurv, + 1 jcurv, dimname=r1dim) + + CALL cdf_define(nwout, vn_iotah, iotas(1:ns), + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_iotah, ln_iotah) + CALL cdf_define(nwout, vn_mass, mass, + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_mass, ln_mass) + CALL cdf_define(nwout, vn_presh, pres(1:ns), + 1 dimname=r1dim) + CALL cdf_setatt(nwout, vn_presh, ln_presh, units='Pa') + CALL cdf_define(nwout, vn_betah, beta_vol, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_buco, buco, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_bvco, bvco, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_vp, vp(1:ns), + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_specw, specw, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_phip, + 1 phips(1:ns), dimname=r1dim) + CALL cdf_define(nwout, vn_overr, + 2 overr(1:ns), dimname=r1dim) + + CALL cdf_define(nwout, vn_jdotb, jdotb, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_bdotb, bdotb, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_bgrv, bdotgradv, + 1 dimname=r1dim) + + CALL cdf_define(nwout, vn_merc, Dmerc, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_mshear, Dshear, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_mwell, Dwell, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_mcurr, Dcurr, + 1 dimname=r1dim) + CALL cdf_define(nwout, vn_mgeo, + 1 Dgeod, dimname=r1dim) + CALL cdf_define(nwout, vn_equif, + 1 equif, dimname=r1dim) + + CALL cdf_define(nwout, vn_fsq, fsqt(1:nstore_seq), + 1 dimname=(/'time'/)) + CALL cdf_define(nwout, vn_wdot, wdot(1:nstore_seq), + 1 dimname=(/'time'/)) + + IF (lfreeb) THEN + CALL cdf_define(nwout, vn_potsin, potvac(1:mnpd), + 1 dimname=mnpotdim) + CALL cdf_setatt(nwout, vn_potsin, ln_potsin) + CALL cdf_define(nwout, vn_xmpot, xmpot(1:mnpd), + 1 dimname=mnpotdim) + CALL cdf_define(nwout, vn_xnpot, xnpot(1:mnpd), + 1 dimname=mnpotdim) + IF (lasym) THEN + CALL cdf_define(nwout, vn_potcos, + 1 potvac(1+mnpd:2*mnpd), dimname=mnpotdim) + CALL cdf_setatt(nwout, vn_potcos, ln_potcos) + END IF + + IF (nextcur.gt.0 .and. ALLOCATED(curlabel)) THEN + CALL cdf_define(nwout, vn_curlab, + 1 curlabel(1:nextcur), dimname=currl) + END IF + ENDIF + +! 2D Arrays + CALL cdf_define(nwout, vn_rmnc, rmnc, dimname=r2dim) + CALL cdf_setatt(nwout, vn_rmnc, ln_rmnc, units='m') + CALL cdf_define(nwout, vn_zmns, zmns, dimname=r2dim) + CALL cdf_setatt(nwout, vn_zmns, ln_zmns, units='m') + CALL cdf_define(nwout, vn_lmns, lmns, dimname=r2dim) + CALL cdf_setatt(nwout, vn_lmns, ln_lmns) + CALL cdf_define(nwout, vn_gmnc, gmnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_gmnc, ln_gmnc) + CALL cdf_define(nwout, vn_bmnc, bmnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bmnc, ln_bmnc) + CALL cdf_define(nwout, vn_bsubumnc, bsubumnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubumnc, ln_bsubumnc) + CALL cdf_define(nwout, vn_bsubvmnc, bsubvmnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubvmnc, ln_bsubvmnc) + CALL cdf_define(nwout, vn_bsubsmns, bsubsmns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubsmns, ln_bsubsmns) + + CALL cdf_define(nwout, vn_currumnc, currumnc, dimname=r3dim) !MRC 8-12-16 + CALL cdf_setatt(nwout, vn_currumnc, ln_currumnc) + CALL cdf_define(nwout, vn_currvmnc, currvmnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_currvmnc, ln_currvmnc) + + IF (lfreeb) THEN + CALL cdf_define(nwout, vn_bsubumnc_sur, bsubumnc_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsubumnc_sur, ln_bsubumnc_sur) + CALL cdf_define(nwout, vn_bsubvmnc_sur, bsubvmnc_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsubvmnc_sur, ln_bsubvmnc_sur) + CALL cdf_define(nwout, vn_bsupumnc_sur, bsupumnc_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsupumnc_sur, ln_bsupumnc_sur) + CALL cdf_define(nwout, vn_bsupvmnc_sur, bsupvmnc_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsupvmnc_sur, ln_bsupvmnc_sur) + END IF + +! ELIMINATE THESE EVENTUALLY: DON'T NEED THEM - CAN COMPUTE FROM GSQRT + CALL cdf_define(nwout, vn_bsupumnc, bsupumnc, dimname=r3dim) + CALL cdf_define(nwout, vn_bsupvmnc, bsupvmnc, dimname=r3dim) +! IF (lfreeb) THEN +! CALL cdf_define(nwout, vn_rbc, rbc, +! 1 dimname=(/'n_mode','m_mode'/)) +! CALL cdf_setatt(nwout, vn_rbc, ln_rbc, units='m') +! CALL cdf_define(nwout, vn_zbs, zbs, +! 1 dimname=(/'n_mode','m_mode'/)) +! CALL cdf_setatt(nwout, vn_zbs, ln_zbs, units='m') +! IF (lasym) THEN +! CALL cdf_define(nwout, vn_rbs, rbs, +! 1 dimname=(/'n_mode','m_mode'/)) +! CALL cdf_define(nwout, vn_zbc, zbc, +! 1 dimname=(/'n_mode','m_mode'/)) +! END IF +! END IF + + IF (.NOT. lasym) GO TO 800 + + CALL cdf_define(nwout, vn_rmns, rmns, dimname=r2dim) + CALL cdf_setatt(nwout, vn_rmns, ln_rmns, units='m') + CALL cdf_define(nwout, vn_zmnc, zmnc, dimname=r2dim) + CALL cdf_setatt(nwout, vn_zmnc, ln_zmnc, units='m') + CALL cdf_define(nwout, vn_lmnc, lmnc, dimname=r2dim) + CALL cdf_setatt(nwout, vn_lmnc, ln_lmnc) + CALL cdf_define(nwout, vn_gmns, gmns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_gmns, ln_gmns) + CALL cdf_define(nwout, vn_bmns, bmns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bmns, ln_bmns) + CALL cdf_define(nwout, vn_bsubumns, bsubumns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubumns, ln_bsubumns) + CALL cdf_define(nwout, vn_bsubvmns, bsubvmns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubvmns, ln_bsubvmns) + CALL cdf_define(nwout, vn_bsubsmnc, bsubsmnc, dimname=r3dim) + CALL cdf_setatt(nwout, vn_bsubsmnc, ln_bsubsmnc) + + CALL cdf_define(nwout, vn_currumns, currumns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_currumns, ln_currumns) + CALL cdf_define(nwout, vn_currvmns, currvmns, dimname=r3dim) + CALL cdf_setatt(nwout, vn_currvmns, ln_currvmns) + + IF (lfreeb) THEN + CALL cdf_define(nwout, vn_bsubumns_sur, bsubumns_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsubumns_sur, ln_bsubumns_sur) + CALL cdf_define(nwout, vn_bsubvmns_sur, bsubvmns_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsubvmns_sur, ln_bsubvmns_sur) + CALL cdf_define(nwout, vn_bsupumns_sur, bsupumns_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsupumns_sur, ln_bsupumns_sur) + CALL cdf_define(nwout, vn_bsupvmns_sur, bsupvmns_sur, & + & dimname=mn2dim) + CALL cdf_setatt(nwout, vn_bsupvmns_sur, ln_bsupvmns_sur) + END IF + +! ELIMINATE THESE EVENTUALLY: DON'T NEED THEM + CALL cdf_define(nwout, vn_bsupumns, bsupumns, dimname=r3dim) + CALL cdf_define(nwout, vn_bsupvmns, bsupvmns, dimname=r3dim) + + 800 CONTINUE + +!================================ +! Write Variables +!================================ + +! Scalars + CALL cdf_write(nwout, vn_version, vversion) + CALL cdf_write(nwout, vn_extension, input_extension) + CALL cdf_write(nwout, vn_mgrid, mgrid_file) + CALL cdf_write(nwout, vn_pcurr_type, pcurr_type) + CALL cdf_write(nwout, vn_piota_type, piota_type) + CALL cdf_write(nwout, vn_pmass_type, pmass_type) + CALL cdf_write(nwout, vn_magen, wb) + CALL cdf_write(nwout, vn_therm, wp) + CALL cdf_write(nwout, vn_gam, gamma) + CALL cdf_write(nwout, vn_maxr, rmax_surf) + CALL cdf_write(nwout, vn_minr, rmin_surf) + CALL cdf_write(nwout, vn_maxz, zmax_surf) + CALL cdf_write(nwout, vn_fp, nfp) + CALL cdf_write(nwout, vn_radnod, ns) + CALL cdf_write(nwout, vn_polmod, mpol) + CALL cdf_write(nwout, vn_tormod, ntor) + CALL cdf_write(nwout, vn_maxmod, mnmax) + CALL cdf_write(nwout, vn_maxmod_nyq, mnmax_nyq0) + CALL cdf_write(nwout, vn_maxit, iter2) + CALL cdf_write(nwout, vn_actit, itfsq) + CALL cdf_write(nwout, vn_asym, lasym) + CALL cdf_write(nwout, vn_recon, lrecon) + CALL cdf_write(nwout, vn_free, lfreeb) + CALL cdf_write(nwout, vn_rfp, lrfp) + CALL cdf_write(nwout, vn_error, ier_flag) +! + CALL cdf_write(nwout, vn_aspect, aspect) + CALL cdf_write(nwout, vn_beta, betatot) + CALL cdf_write(nwout, vn_pbeta, betapol) + CALL cdf_write(nwout, vn_tbeta, betator) + CALL cdf_write(nwout, vn_abeta, betaxis) + CALL cdf_write(nwout, vn_b0, b0) + CALL cdf_write(nwout, vn_rbt0, rbtor0) + CALL cdf_write(nwout, vn_rbt1, rbtor) + CALL cdf_write(nwout, vn_sgs, NINT(signgs)) + CALL cdf_write(nwout, vn_lar, IonLarmor) + CALL cdf_write(nwout, vn_modB, volAvgB) + CALL cdf_write(nwout, vn_ctor, ctor/mu0) + CALL cdf_write(nwout, vn_amin, Aminor_p) + CALL cdf_write(nwout, vn_rmaj, Rmajor_p) + CALL cdf_write(nwout, vn_vol, volume_p) + CALL cdf_write(nwout, vn_ftolv, ftolx1) + CALL cdf_write(nwout, vn_fsql, fsql) + CALL cdf_write(nwout, vn_fsqr, fsqr) + CALL cdf_write(nwout, vn_fsqz, fsqz) + + CALL cdf_write(nwout, vn_nextcur, nextcur) + IF (nextcur .gt. 0) THEN + CALL cdf_write(nwout, vn_extcur, extcur(1:nextcur)) + CALL cdf_write(nwout, vn_mgmode, mgrid_mode) + ENDIF + IF (lfreeb) THEN + CALL cdf_write(nwout, vn_flp, nobser) + CALL cdf_write(nwout, vn_maxpot, mnpd) + CALL cdf_write(nwout, vn_nobd, nobd) + CALL cdf_write(nwout, vn_nbset, nbsets) + IF (nextcur.gt.0 .and. ALLOCATED(curlabel)) + 1 CALL cdf_write(nwout, vn_curlab, curlabel(1:nextcur)) + END IF + +! 1D Arrays + IF (nbsets .gt. 0) CALL cdf_write(nwout,vn_nbfld,nbfld(1:nbsets)) + + IF (.not.lwrite) GO TO 940 !change 970 to 940, J.Geiger + !skip the next cdf_write-calls + CALL cdf_write(nwout, vn_pmod, xm) + CALL cdf_write(nwout, vn_tmod, xn) + CALL cdf_write(nwout, vn_pmod_nyq, xm_nyq0) + CALL cdf_write(nwout, vn_tmod_nyq, xn_nyq0) + + IF (lfreeb) THEN + CALL cdf_write(nwout, vn_potsin, potvac(1:mnpd)) + IF (lasym) & + & CALL cdf_write(nwout, vn_potcos, potvac(1+mnpd:2*mnpd)) + CALL cdf_write(nwout, vn_xmpot, xmpot) + CALL cdf_write(nwout, vn_xnpot, xnpot) + END IF + +940 CONTINUE ! before closing, write the initial part of the wouttxt-file +#endif + IF (lwouttxt) THEN + wout2_file = 'wout_'//TRIM(input_extension) // '.txt' + nwout2 = nwout0 + CALL safe_open(nwout2, iwout0, wout2_file, + 1 'replace', 'formatted') + IF (iwout0 .ne. 0) STOP 'Error opening WOUT.txt file in WROUT' + + IF (lasym) THEN + iasym = 1 ! asymmetric mode + ELSE + iasym = 0 + END IF + +! +! Insert version information into wout file. This will be parsed in +! read_wout_file to return the real value version_ to check the version number. +! +#if defined(_ANIMEC) + WRITE (nwout2, '(a15,a,a)') 'VMEC VERSION = ', version_, + 1 '_ANIMEC' +#elif defined(_FLOW) + WRITE (nwout2, '(a15,a,a)') 'VMEC VERSION = ', version_,'_FLOW' +#else + WRITE (nwout2, '(a15,a)') 'VMEC VERSION = ', version_ +#endif + +#ifdef _ANIMEC + WRITE (nwout2, *) wb, wpar, gamma, pfac, +#else + WRITE (nwout2, *) wb, wp, gamma, 1, +#endif + 1 rmax_surf, rmin_surf, zmax_surf + + WRITE (nwout2, *) nfp, ns, mpol, ntor, mnmax, mnmax_nyq0, + 1 itfsq, iter2, iasym, 0, ier_flag + + WRITE (nwout2, *) 0, 0, nbsets, nobd, nextcur, nstore_seq + IF (nbsets .gt. 0) WRITE (nwout2, *) (nbfld(i),i=1,nbsets) + WRITE (nwout2, '(a)') mgrid_file + + IF (.not. lwrite) GOTO 950 ! J Geiger: At this point only closing of + ! txt- and nc-file is needed + pres(1) = pres(2) + END IF +!---------------------DEC$ ENDIF + + IF (.not. lwrite) GOTO 970 ! J Geiger: in case lwouttxt is not true + ! jump to close nc-file + ALLOCATE (xfinal(neqs), stat=js) + IF (js .NE. 0) STOP 'Allocation error for xfinal in WROUT!' + xfinal = xc +#ifdef _HBANGLE + CALL getrz(xfinal) +#else +! +! MUST CONVERT m=1 MODES... FROM INTERNAL TO PHYSICAL FORM +! Extrapolation of m=0 Lambda (cs) modes, which are not evolved at j=1, done in CONVERT +! + lk = ns*ntor1 + IF (lthreed) CALL convert_sym (xfinal(1+mns*(rss-1)+lk), + 1 xfinal(1+irzloff+mns*(zcs-1)+lk)) + IF (lasym) CALL convert_asym (xfinal(1+mns*(rsc-1)+lk), + 1 xfinal(1+irzloff+mns*(zcc-1)+lk)) +#endif +! +! CONVERT TO rmnc, zmns, lmns, etc EXTERNAL representation (without internal mscale, nscale) +! IF B^v ~ phip + lamu, MUST DIVIDE BY phipf(js) below to maintain old-style format +! THIS COULD BE A PROBLEM FOR RFP WHERE PHIPF->0 INSIDE THE PLASMA! +! + RADIUS1: DO js = 1, ns + + CALL convert (rmnc1, zmns1, lmns1, rmns1, zmnc1, lmnc1, + 1 xfinal, js) + + rmnc(:,js) = rmnc1(:) + zmns(:,js) = zmns1(:) + lmns(:,js) = (lmns1(:)/phipf(js)) * lamscale + IF (lasym) THEN + rmns(:,js) = rmns1(:) + zmnc(:,js) = zmnc1(:) + lmnc(:,js) = (lmnc1(:)/phipf(js)) * lamscale + END IF + + END DO RADIUS1 + + DEALLOCATE (xfinal) + +! +! INTERPOLATE LAMBDA ONTO HALF-MESH FOR BACKWARDS CONSISTENCY WITH EARLIER VERSIONS OF VMEC +! AND SMOOTHS POSSIBLE UNPHYSICAL "WIGGLE" ON RADIAL MESH +! + + WHERE (NINT(xm) .le. 1) lmns(:,1) = lmns(:,2) + DO js = ns,2,-1 + WHERE (MOD(NINT(xm),2) .eq. 0) + lmns(:,js) = p5*(lmns(:,js) + lmns(:,js-1)) + ELSEWHERE + lmns(:,js) = p5*(sm(js)*lmns(:,js) + sp(js-1)*lmns(:,js-1)) + END WHERE + END DO + + lmns(:,1) = 0 + raxis_cc(0:ntor) = rmnc(1:ntor+1,1) + zaxis_cs(0:ntor) = zmns(1:ntor+1,1) + + IF (.NOT.lasym) GOTO 900 + + WHERE (NINT(xm) .le. 1) lmnc(:,1) = lmnc(:,2) + DO js = ns,2,-1 + WHERE (MOD(NINT(xm),2) .eq. 0) + lmnc(:,js) = p5*(lmnc(:,js) + lmnc(:,js-1)) + ELSEWHERE + lmnc(:,js) = p5*(sm(js)*lmnc(:,js) + sp(js-1)*lmnc(:,js-1)) + END WHERE + END DO + + lmnc(:,1) = 0; + raxis_cs(0:ntor) = rmns(1:ntor+1,1) + zaxis_cc(0:ntor) = zmnc(1:ntor+1,1) + + 900 CONTINUE + +#ifdef _ANIMEC +!... CALCULATE RADIAL DERIVATIVES OF HOT PARTICLE PRESSURE TERMS +!... STORE IN ARRAYS pm AND pd PREVIOUSLY USED IN PRESSURE AND EQFOR + eps = EPSILON(eps) + DO js=2,ns-1 + pd(js) = ohs * (pres(js+1) * phot(js+1) - pres(js) * phot(js)) + pmap(js) = ohs * (tpotb(js+1) - tpotb(js)) + END DO +!... INTERPOLATE (EXTRAPOLATE) TO HALF INTEGER MESH + pdh = c1p5 * pd(2) - p5 * pd(3) + pmh = c1p5 * pmap(2) - p5 * pmap(3) + pde = c1p5 * pd(ns-1) - p5 * pd(ns-2) + pme = c1p5 * pmap(ns-1) - p5 * pmap(ns-2) + DO js=ns-2,2,-1 + pd(js+1) = p5*(pd(js+1) + pd(js)) / (pres(js+1)*phot(js+1)+eps) + pmap(js+1) = p5 * (pmap(js+1) + pmap(js)) + END DO + pd(2) = pdh / (pres(2)*phot(2)+eps) + pd(ns) = pde / (pres(ns)*phot(ns)+eps) + pmap(2) = pmh + pmap(ns) = pme +!ALTERNATE EXTRAPOLATION + pd(2) = 2*pd(3) - pd(4) + pd(ns) = 2*pd(ns-1) - pd(ns-2) + +!CALCULATE HOT PARTICLE PARALLEL AND PERPENDICULAR PRESSURE GRADIENT; DENSITY + DO 20 js = 2, ns + hotdam = pres(js) * phot(js) / SQRT(tpotb(js)+eps) + DO 10 lk = 1, nznt +! + omtbc = one - tpotb(js) * onembc(js,lk) + optbc = one + tpotb(js) * onembc(js,lk) + IF (onembc(js,lk) <= zero) THEN + densit(js,lk)= (ppar(js,lk) - pres(js))*hotdam / + & (pres(js)*phot(js)+eps) + pbprim(js,lk) = (ppar(js,lk) -pres(js)) * + & (pd(js) + onembc(js,lk) * pmap(js) / (omtbc+eps)) + ppprim(js,lk) = (pperp(js,lk)-pres(js)) * + & (pd(js) + optbc * pmap(js) / (omtbc * tpotb(js)+eps)) + ELSE + densit(js,lk) = hotdam * (one - onembc(js,lk)) * + & (optbc - 2*(tpotb(js)*onembc(js,lk))**c1p5) / (omtbc*optbc+eps) + pbprim(js,lk) = (ppar(js,lk) -pres(js)) * pd(js) + + & ( 2 * tpotb(js) * onembc(js,lk)**2 * (ppar(js,lk)-pres(js)) + & + pres(js)*phot(js)*(one-onembc(js,lk))*onembc(js,lk)*(one -5 + & *(tpotb(js)*onembc(js,lk))**c1p5))* pmap(js) / (omtbc*optbc+eps) + ppprim(js,lk) = (pperp(js,lk)-pres(js)) * pd(js) + + & ((pperp(js,lk)-pres(js))*(one+3*(tpotb(js)*onembc(js,lk))**2) / + & (tpotb(js)+eps)+ pres(js)*phot(js)*tpotb(js) + & *(one-onembc(js,lk))**2 + & * onembc(js,lk)*(two*optbc-sqrt(tpotb(js)*onembc(js,lk))*(7.5 + & - 3.5_dp*(tpotb(js)*onembc(js,lk))**2))/(omtbc*optbc+eps)) + & * pmap(js)/ (omtbc * optbc + eps) + END IF + 10 END DO + 20 END DO +#endif +!SPH100209: COMPUTE |B| = SQRT(|B|**2) and store in bsq, bsqa + DO js = 2, ns + bsq(js,:nznt) = SQRT(2*ABS(bsq(js,:nznt)-pres(js))) + END DO + + tmult = p5/r0scale**2 +!SPH: FIXED THIS 03-05-07 TO CALL symmetrization routine + IF (lasym) THEN +!Changed integration norm in fixaray, SPH012314 + tmult = 2*tmult + bsubs(1,:) = 0 + CALL symoutput (bsq, gsqrt, bsubu, bsubv, bsupu, + 1 bsupv, bsubs, +#ifdef _ANIMEC + 2 ppar , pperp , densit , + 3 sigma_an , tau_an , pbprim , ppprim , +#endif + 4 bsqa, gsqrta, bsubua, bsubva, bsupua, + 5 bsupva, bsubsa +#ifdef _ANIMEC + 6 ,ppara , pperpa , densita, + 7 sigma_ana, tau_ana, pbprima, ppprima +#endif + 8 ) + + IF (lfreeb) THEN !MRC 10-15-15 + CALL symoutput_sur(bsubu_sur, bsubv_sur, & + & bsupu_sur, bsupv_sur, & + & bsubua_sur, bsubva_sur, & + & bsupua_sur, bsupva_sur) + END IF + END IF + +! DO js = 2, ns +! WRITE (200, *) 'JS: ', js, 'BSUBU, BSUBV' +! WRITE (200, '(1p,6e12.4)') bsubu(js,:), bsubv(js,:) +! END DO + + RADIUS2: DO js = 2, ns + gmn = 0 + bmn = 0 + bsubumn = 0 + bsubvmn = 0 + bsubsmn = 0 + bsupumn = 0 + bsupvmn = 0 + + MN2: DO mn = 1, mnmax_nyq0 + n = NINT(xn_nyq0(mn))/nfp + m = NINT(xm_nyq0(mn)) + n1 = ABS(n) + dmult = mscale(m)*nscale(n1)*tmult + IF (m.eq.0 .or. n.eq.0) dmult = 2*dmult + sgn = SIGN(1, n) + lk = 0 + DO j = 1, ntheta2 + DO k = 1, nzeta + lk = lk + 1 + tcosi = dmult*(cosmui(j,m)*cosnv(k,n1) + + 1 sgn*sinmui(j,m)*sinnv(k,n1)) !cos(mu - nv) + tsini = dmult*(sinmui(j,m)*cosnv(k,n1) - + 1 sgn*cosmui(j,m)*sinnv(k,n1)) !sin(mu - nv) + bmn(mn) = bmn(mn) + tcosi*bsq(js,lk) + gmn(mn) = gmn(mn) + tcosi*gsqrt(js,lk) + bsubumn(mn) = bsubumn(mn) + tcosi*bsubu(js,lk) + bsubvmn(mn) = bsubvmn(mn) + tcosi*bsubv(js,lk) + bsubsmn(mn) = bsubsmn(mn) + tsini*bsubs(js,lk) + bsupumn(mn) = bsupumn(mn) + tcosi*bsupu(js,lk) + bsupvmn(mn) = bsupvmn(mn) + tcosi*bsupv(js,lk) +#ifdef _ANIMEC + pparmn(mn) = pparmn(mn) + tcosi* + 1 (ppar(js,lk)-pres(js)) + ppermn(mn) = ppermn(mn) + tcosi* + 1 (pperp(js,lk)-pres(js)) + sigmn(mn) = sigmn(mn) + tcosi*sigma_an(js,lk) + taumn(mn) = taumn(mn) + tcosi*tau_an(js,lk) + pbprmn(mn) = pbprmn(mn) + tcosi*pbprim(js,lk) + ppprmn(mn) = ppprmn(mn) + tcosi*ppprim(js,lk) + hotdmn(mn) = hotdmn(mn) + tcosi*densit(js,lk) +#endif + END DO + END DO + END DO MN2 + + IF (js .eq. ns/2) bmodmn = bmn(1:mnmax) + IF (js .eq. ns) bmodmn1 = bmn(1:mnmax) + gmnc(:,js) = gmn(:) + bmnc(:,js) = bmn(:) + bsubumnc(:,js) = bsubumn(:) + bsubvmnc(:,js) = bsubvmn(:) + bsubsmns(:,js) = bsubsmn(:) + bsupumnc(:,js) = bsupumn(:) + bsupvmnc(:,js) = bsupvmn(:) +#ifdef _ANIMEC + pparmnc(:,js) = pparmn(:) + ppermnc(:,js) = ppermn(:) + sigmnc(:,js) = sigmn(:) + taumnc(:,js) = taumn(:) + pbprmnc(:,js) = pbprmn(:) + ppprmnc(:,js) = ppprmn(:) + hotdmnc(:,js) = hotdmn(:) +#endif + END DO RADIUS2 + + IF (lfreeb) THEN !MRC 10-15-15 + bsubumnc_sur = 0 + bsubvmnc_sur = 0 + bsupumnc_sur = 0 + bsupvmnc_sur = 0 + DO mn = 1, mnmax_nyq0 + n = NINT(xn_nyq0(mn))/nfp + m = NINT(xm_nyq0(mn)) + n1 = ABS(n) + dmult = mscale(m)*nscale(n1)*tmult + IF (m.eq.0 .or. n.eq.0) dmult = 2*dmult + sgn = SIGN(1, n) + lk = 0 + DO j = 1, ntheta2 + DO k = 1, nzeta + lk = lk + 1 + tcosi = dmult*(cosmui(j,m)*cosnv(k,n1) + + 1 sgn*sinmui(j,m)*sinnv(k,n1)) + bsubumnc_sur(mn) = bsubumnc_sur(mn) & + & + tcosi*bsubu_sur(lk) + bsubvmnc_sur(mn) = bsubvmnc_sur(mn) & + & + tcosi*bsubv_sur(lk) + bsupumnc_sur(mn) = bsupumnc_sur(mn) & + & + tcosi*bsupu_sur(lk) + bsupvmnc_sur(mn) = bsupvmnc_sur(mn) & + & + tcosi*bsupv_sur(lk) + END DO + END DO + END DO + END IF + + gmnc(:,1) = 0; bmnc(:,1) = 0; + bsubumnc(:,1) = 0 + bsubvmnc(:,1) = 0 + bsubsmns(:,1) = 2*bsubsmns(:,2) - bsubsmns(:,3) + bsupumnc(:,1) = 0; bsupvmnc(:,1) = 0 + +#ifdef _ANIMEC + hotdmnc(:,1) = 0; pparmnc(:,1) = 0; ppermnc(:,1) = 0 + pbprmnc(:,1) = 0; ppprmnc(:,1) = 0 + sigmnc(:,1) = 0; taumnc(:,1) = 0 +#endif + + IF (.not.lasym) GO TO 200 + + RADIUS3: DO js = 2, ns + gmn = 0 + bmn = 0 + bsubumn = 0 + bsubvmn = 0 + bsubsmn = 0 + bsupumn = 0 + bsupvmn = 0 +#ifdef _ANIMEC + pparmn = 0 + ppermn = 0 + sigmn = 0 + taumn = 0 + pbprmn = 0 + ppprmn = 0 + hotdmn = 0 +#endif + MN3: DO mn = 1, mnmax_nyq0 + n = NINT(xn_nyq0(mn))/nfp + m = NINT(xm_nyq0(mn)) + n1 = ABS(n) + dmult = mscale(m)*nscale(n1)*tmult + IF (m.eq.0 .or. n.eq.0) dmult = 2*dmult + sgn = SIGN(1, n) + lk = 0 + jlk = js + DO j = 1, ntheta2 + DO k = 1, nzeta + lk = lk + 1 + tcosi = dmult*(cosmui(j,m)*cosnv(k,n1) + + 1 sgn*sinmui(j,m)*sinnv(k,n1)) + tsini = dmult*(sinmui(j,m)*cosnv(k,n1) - + 1 sgn*cosmui(j,m)*sinnv(k,n1)) + bmn(mn) = bmn(mn) + tsini*bsqa(jlk) + gmn(mn) = gmn(mn) + tsini*gsqrta(jlk,0) + bsubumn(mn) = bsubumn(mn) + tsini*bsubua(jlk) + bsubvmn(mn) = bsubvmn(mn) + tsini*bsubva(jlk) + bsubsmn(mn) = bsubsmn(mn) + tcosi*bsubsa(jlk) + bsupumn(mn) = bsupumn(mn) + tsini*bsupua(jlk) + bsupvmn(mn) = bsupvmn(mn) + tsini*bsupva(jlk) + +#ifdef _ANIMEC + pparmn(mn) = pparmn(mn) + tsini*ppara(js,lk) + ppermn(mn) = ppermn(mn) + tsini*pperpa(js,lk) + sigmn(mn) = sigmn(mn) + tsini*sigma_ana(js,lk) + taumn(mn) = taumn(mn) + tsini*tau_ana(js,lk) + pbprmn(mn) = pbprmn(mn) + tsini*pbprima(js,lk) + ppprmn(mn) = ppprmn(mn) + tsini*ppprima(js,lk) + hotdmn(mn) = hotdmn(mn) + tsini*densita(js,lk) +#endif + jlk = jlk+ns + END DO + END DO + END DO MN3 + + gmns(:,js) = gmn(:) + bmns(:,js) = bmn(:) + bsubumns(:,js) = bsubumn(:) + bsubvmns(:,js) = bsubvmn(:) + bsubsmnc(:,js) = bsubsmn(:) + bsupumns(:,js) = bsupumn(:) + bsupvmns(:,js) = bsupvmn(:) +#ifdef _ANIMEC + pparmns(:,js) = pparmn(:) + ppermns(:,js) = ppermn(:) + sigmns(:,js) = sigmn(:) + taumns(:,js) = taumn(:) + pbprmns(:,js) = pbprmn(:) + ppprmns(:,js) = ppprmn(:) + hotdmns(:,js) = hotdmn(:) +#endif + END DO RADIUS3 + + gmns(:,1) = 0; bmns(:,1) = 0 + bsubumns(:,1) = 0 + bsubvmns(:,1) = 0 + bsubsmnc(:,1) = 2*bsubsmnc(:,2) - bsubsmnc(:,3) + bsupumns(:,1) = 0; bsupvmns(:,1) = 0 +#ifdef _ANIMEC + hotdmns(:,1) = 0; pparmns(:,1) = 0; ppermns(:,1) = 0 + pbprmns(:,1) = 0; ppprmns(:,1) = 0 + sigmns(:,1) = 0; taumns(:,1) = 0 +#endif + + IF (lfreeb) THEN !MRC 10-15-15 + bsubumns_sur = 0 + bsubvmns_sur = 0 + bsupumns_sur = 0 + bsupvmns_sur = 0 + + DO mn = 1, mnmax_nyq0 + n = NINT(xn_nyq0(mn))/nfp + m = NINT(xm_nyq0(mn)) + n1 = ABS(n) + dmult = mscale(m)*nscale(n1)*tmult + IF (m.eq.0 .or. n.eq.0) dmult = 2*dmult + sgn = SIGN(1, n) + lk = 0 + DO j = 1, ntheta2 + DO k = 1, nzeta + lk = lk + 1 + tsini = dmult*(sinmui(j,m)*cosnv(k,n1) - + 1 sgn*cosmui(j,m)*sinnv(k,n1)) + bsubumns_sur(mn) = bsubumns_sur(mn) & + & + tsini*bsubua_sur(lk) + bsubvmns_sur(mn) = bsubvmns_sur(mn) & + & + tsini*bsubva_sur(lk) + bsupumns_sur(mn) = bsupumns_sur(mn) & + & + tsini*bsupua_sur(lk) + bsupvmns_sur(mn) = bsupvmns_sur(mn) & + & + tsini*bsupva_sur(lk) + END DO + END DO + END DO + END IF + + 200 CONTINUE + + CALL Compute_Currents(bsubsmnc, bsubsmns, bsubumnc, bsubumns, & + & bsubvmnc, bsubvmns, & + & xm_nyq0, xn_nyq0, mnmax_nyq0, lasym, ns, & + & currumnc, currvmnc, currumns, currvmns) + +#ifdef _DEBUG + WRITE (333, *) ' JS M*B_S GRAD(B_U) J^V' + DO mn = 1, mnmax_nyq0 + WRITE (333,'(2(a,i4))') 'm=', INT(xm_nyq0(mn)), + 1 ' n=', INT(xn_nyq0(mn))/nfp + DO js = 2,ns-1 + tmult=-xm_nyq0(mn)*bsubsmns(mn,js) + + 1 ohs*(bsubumnc(mn,js+1)-bsubumnc(mn,js)) + WRITE (333,'(i6,1p,3e12.4)') js, + 1 bsubsmns(mn,js)*xm_nyq0(mn), + 2 ohs*(bsubumnc(mn,js+1)-bsubumnc(mn,js)), + 3 tmult + END DO + END DO + + WRITE(333,*) version_ + IF (lasym) THEN + WRITE(333,2002) 'mn', 'rmnc', 'rmns', 'zmnc', 'zmns', & + & 'lmnc', 'lmns', 'gmnc', 'gmns', & + & 'bmnc', 'bmns', & + & 'bsubumnc', 'bsubumns', & + & 'bsubvmnc', 'bsubvmns', & + & 'bsubsmnc', 'bsubsmns', & + & 'bsupumnc', 'bsupumns', & + & 'bsupvmnc', 'bsupvmns' + ELSE + WRITE(333,2000) 'mn', 'rmnc', 'lmns', 'gmnc', 'bmnc', & + & 'bsubumnc', 'bsubvmnc', & + & 'bsubsmns', & + & 'bsupumnc', 'bsupvmnc' + END IF + DO mn = 1, mnmax + IF (lasym) THEN + WRITE(333,2003) mn, rmnc(mn,ns/2), rmns(mn,ns/2), & + & zmnc(mn,ns/2), zmns(mn,ns/2), & + & lmnc(mn,ns/2), lmns(mn,ns/2), & + & gmnc(mn,ns/2), gmns(mn,ns/2), & + & bmnc(mn,ns/2), bmns(mn,ns/2), & + & bsubumnc(mn,ns/2), bsubumns(mn,ns/2), & + & bsubvmnc(mn,ns/2), bsubvmns(mn,ns/2), & + & bsubsmnc(mn,ns/2), bsubsmns(mn,ns/2), & + & bsupumnc(mn,ns/2), bsupumns(mn,ns/2), & + & bsupvmnc(mn,ns/2), bsupvmns(mn,ns/2) + ELSE + WRITE(333,2001) mn, rmnc(mn,ns/2), lmns(mn,ns/2), & + & gmnc(mn,ns/2), bmnc(mn,ns/2), & + & bsubumnc(mn,ns/2), bsubvmnc(mn,ns/2), & + & bsubsmns(mn,ns/2), & + & bsupumnc(mn,ns/2), bsupvmnc(mn,ns/2) + END IF + END DO +2000 FORMAT(a2,10(2x,a12)) +2001 FORMAT(i2,10(2x,e12.5)) +2002 FORMAT(a2,20(2x,a12)) +2003 FORMAT(i2,20(2x,es12.5)) +#endif +! +! WRITE OUT ARRAYS +! +#ifdef NETCDF + CALL cdf_write(nwout, vn_racc, raxis_cc(0:ntor)) + CALL cdf_write(nwout, vn_zacs, zaxis_cs(0:ntor)) + CALL cdf_write(nwout, vn_rmnc, rmnc) + CALL cdf_write(nwout, vn_zmns, zmns) + CALL cdf_write(nwout, vn_lmns, lmns) + CALL cdf_write(nwout, vn_gmnc, gmnc) !Half mesh + CALL cdf_write(nwout, vn_bmnc, bmnc) !Half mesh + CALL cdf_write(nwout, vn_bsubumnc, bsubumnc) !Half mesh + CALL cdf_write(nwout, vn_bsubvmnc, bsubvmnc) !Half mesh + CALL cdf_write(nwout, vn_bsubsmns, bsubsmns) !Full mesh + + CALL cdf_write(nwout, vn_currumnc, currumnc) !MRK 8-12-16 + CALL cdf_write(nwout, vn_currvmnc, currvmnc) + +! GET RID OF THESE EVENTUALLY: DON'T NEED THEM (can express in terms of lambdas) + CALL cdf_write(nwout, vn_bsupumnc, bsupumnc) + CALL cdf_write(nwout, vn_bsupvmnc, bsupvmnc) + + IF (lfreeb) THEN !MRC 10-15-15 + CALL cdf_write(nwout, vn_bsubumnc_sur, bsubumnc_sur) + CALL cdf_write(nwout, vn_bsubvmnc_sur, bsubvmnc_sur) + CALL cdf_write(nwout, vn_bsupumnc_sur, bsupumnc_sur) + CALL cdf_write(nwout, vn_bsupvmnc_sur, bsupvmnc_sur) + END IF + +! FULL-MESH quantities +! NOTE: jdotb is in units_of_A (1/mu0 incorporated in jxbforce...) +! prior to version 6.00, this was output in internal VMEC units... + + j = SIZE(am)-1 + CALL cdf_write(nwout, vn_am, am(0:j)) + j = SIZE(ac)-1 + CALL cdf_write(nwout, vn_ac, ac(0:j)) + j = SIZE(ai)-1 + CALL cdf_write(nwout, vn_ai, ai(0:j)) + + j = SIZE(am_aux_s) + CALL cdf_write(nwout, vn_am_aux_s, am_aux_s(1:j)) + j = SIZE(am_aux_f) + CALL cdf_write(nwout, vn_am_aux_f, am_aux_f(1:j)) + j = SIZE(ac_aux_s) + CALL cdf_write(nwout, vn_ac_aux_s, ac_aux_s(1:j)) + j = SIZE(ac_aux_f) + CALL cdf_write(nwout, vn_ac_aux_f, ac_aux_f(1:j)) + j = SIZE(ai_aux_s) + CALL cdf_write(nwout, vn_ai_aux_s, ai_aux_s(1:j)) + j = SIZE(ai_aux_f) + CALL cdf_write(nwout, vn_ai_aux_f, ai_aux_f(1:j)) + + CALL cdf_write(nwout, vn_iotaf, iotaf(1:ns)) + CALL cdf_write(nwout, vn_qfact, qfact(1:ns)) + CALL cdf_write(nwout, vn_presf, presf/mu0) + CALL cdf_write(nwout, vn_phi, phi) + CALL cdf_write(nwout, vn_phipf, twopi*signgs*phipf) + CALL cdf_write(nwout, vn_chi, chi) + CALL cdf_write(nwout, vn_chipf, twopi*signgs*chipf) + CALL cdf_write(nwout, vn_jcuru, jcuru/mu0) + CALL cdf_write(nwout, vn_jcurv, jcurv/mu0) + CALL cdf_write(nwout, vn_jdotb, jdotb) + CALL cdf_write(nwout, vn_bdotb, bdotb) + CALL cdf_write(nwout, vn_bgrv, bdotgradv) + +! HALF-MESH quantities + iotas(1) = 0; mass(1) = 0; pres(1) = 0; phip(1) = 0; + buco(1) = 0; bvco(1) = 0; vp(1) = 0; overr(1) = 0; specw(1) = 1 + beta_vol(1) = 0 + CALL cdf_write(nwout, vn_iotah, iotas(1:ns)) + CALL cdf_write(nwout, vn_mass, mass/mu0) + CALL cdf_write(nwout, vn_presh, pres(1:ns)/mu0) + CALL cdf_write(nwout, vn_betah, beta_vol) + CALL cdf_write(nwout, vn_buco, buco) + CALL cdf_write(nwout, vn_bvco, bvco) + CALL cdf_write(nwout, vn_vp, vp(1:ns)) + CALL cdf_write(nwout, vn_specw, specw) + CALL cdf_write(nwout, vn_phip, phips(1:ns)) + CALL cdf_write(nwout, vn_overr, overr(1:ns)) + +! MERCIER_CRITERION + CALL cdf_write(nwout, vn_merc, Dmerc) + CALL cdf_write(nwout, vn_mshear, Dshear) + CALL cdf_write(nwout, vn_mwell, Dwell) + CALL cdf_write(nwout, vn_mcurr, Dcurr) + CALL cdf_write(nwout, vn_mgeo, Dgeod) + CALL cdf_write(nwout, vn_equif, equif) + + CALL cdf_write(nwout, vn_fsq, fsqt(1:nstore_seq)) + CALL cdf_write(nwout, vn_wdot, wdot(1:nstore_seq)) + +!----------------------------------------------- +! DATA AND MSE FITS : HAVE NOT CONVERTED TO NETCDF +! SINCE THIS WILL BE REPLACED SOON +!----------------------------------------------- +! IF (.not.lrecon) GOTO 925 +! 925 CONTINUE + +#endif + IF (lwouttxt) THEN + DO js = 1, ns + WRITE(nwout2, *) "JS: ", js + MN1_OUT: DO mn = 1, mnmax + IF (js .eq. 1) THEN + WRITE (nwout2, *) NINT(xm(mn)), NINT(xn(mn)) + END IF + + WRITE (nwout2, *) rmnc(mn,js), zmns(mn,js), lmns(mn,js) + IF (lasym) THEN + WRITE (nwout2, *)rmns(mn,js),zmnc(mn,js),lmnc(mn,js) + ENDIF + END DO MN1_OUT + + MN2_OUT: DO mn = 1, mnmax_nyq0 + IF (js .eq. 1) THEN + WRITE (nwout2, *) NINT(xm_nyq0(mn)), NINT(xn_nyq0(mn)) + END IF + WRITE (nwout2, *) bmnc(mn,js), gmnc(mn,js), + 1 bsubumnc(mn,js), bsubvmnc(mn,js), bsubsmns(mn,js), + 2 bsupumnc(mn,js), bsupvmnc(mn,js) +#ifdef _ANIMEC + 3 ,pparmnc (mn,js), ppermnc (mn,js), hotdmnc (mn,js), + 4 pbprmnc (mn,js), ppprmnc (mn,js), sigmnc (mn,js), + 5 taumnc (mn,js) +#endif + IF (lasym) THEN + WRITE (nwout2, *) bmns(mn,js), gmns(mn,js), + 1 bsubumns(mn,js), bsubvmns(mn,js), bsubsmnc(mn,js), + 2 bsupumns(mn,js), bsupvmns(mn,js) +#ifdef _ANIMEC + 3 ,pparmns (mn,js), ppermns (mn,js), hotdmns (mn,js), + 4 pbprmns (mn,js), ppprmns (mn,js), sigmns (mn,js), + 5 taumns (mn,js) +#endif + ENDIF + END DO MN2_OUT + END DO + +! +! HALF-MESH QUANTITIES (except phi, jcuru, jcurv which are FULL MESH - computed in eqfor) +! NOTE: jcuru, jcurv are local current densities, NOT integrated in s and normed to twopi +! NOTE: In version <= 6.00, mass, press are written out in INTERNAL units +! and should be multiplied by 1/mu0 to transform to pascals. In version > 6.00, +! the pressure, mass are in correct (physical) units +! + +! NOTE: phipf has a twopi * signgs factor compared with phips... + + + WRITE (nwout2, *) (iotaf(js), presf(js)/mu0, + 1 twopi*signgs*phipf(js), + 2 phi(js), jcuru(js)/mu0, jcurv(js)/mu0, js=1,ns) + WRITE (nwout2, *) (iotas(js), mass(js)/mu0, pres(js)/mu0, + 1 beta_vol(js), phip(js), buco(js), bvco(js), vp(js), + 2 overr(js), specw(js),js=2,ns) +!----------------------------------------------- + + WRITE (nwout2, *) aspect, betatot, betapol, betator, betaxis, + 1 b0 + +!----------------------------------------------- +! New output added to version 6.20 +!----------------------------------------------- + WRITE (nwout2, *) NINT(signgs) + WRITE (nwout2, '(a)') input_extension + WRITE (nwout2, *) IonLarmor, VolAvgB, rbtor0, rbtor, ctor/mu0, + 1 Aminor_p, Rmajor_p, volume_p +!----------------------------------------------- +! MERCIER CRITERION +!----------------------------------------------- + WRITE (nwout2, *) (Dmerc(js), Dshear(js), Dwell(js), Dcurr(js), + 1 Dgeod(js), equif(js), js=2,ns-1) + + IF (nextcur.gt.0) THEN + WRITE (nwout2, *) (extcur(i),i=1,nextcur) + lcurr = ALLOCATED(curlabel) .and. lfreeb + WRITE (nwout2, *) lcurr + IF (lcurr) WRITE (nwout2, *) (curlabel(i),i=1,nextcur) + ENDIF + +!----------------------------------------------- +! NOTE: jdotb is in units of A (1/mu0 incorporated in jxbforce...) +! prior to version 6.00, this was output in internal VMEC units... +!----------------------------------------------- + WRITE (nwout2, *) (fsqt(i),wdot(i),i=1,nstore_seq) + WRITE (nwout2, *) (jdotb(js),bdotgradv(js),bdotb(js),js=1,ns) + +!----------------------------------------------- +! Modification to obtain old fort.8 file (depracated) +! Write out only the stellarator symmetric parts +! Only kept for old codes. (J. Geiger) +!----------------------------------------------- + IF (loldout) THEN + WRITE (nfort8, '(f10.3,7i6)') + 1 gamma, nfp, ns, mpol, ntor, mnmax, itfsq, iter2/100+1 + DO js = 1, ns + mn = 0 + DO m = 0, mpol1 + nmin0 = -ntor + IF (m .eq. 0) nmin0 = 0 + DO n = nmin0, ntor + mn = mn + 1 + IF (js .eq. 1) + 1 WRITE (nfort8,'(2i10)') NINT(xm(mn)),NINT(xn(mn)) + WRITE (nfort8,'(5e20.13)') + 1 rmnc(mn,js),zmns(mn,js),lmns(mn,js), + 2 bmnc(mn,js),gmnc(mn,js), + 3 bsubumnc(mn,js),bsubvmnc(mn,js),bsubsmns(mn,js), + 4 bsupumnc(mn,js),bsupvmnc(mn,js) + END DO + END DO + END DO + WRITE (nfort8,'(5e20.13)') (iotas(js),mass(js),pres(js), + 1 phips(js),buco(js),bvco(js),phi(js),vp(js), + 2 jcuru(js)/mu0,jcurv(js)/mu0,specw(js),js=2,ns) + WRITE (nfort8,'(5e20.13)') (fsqt(i),wdot(i),i=1,100) + CLOSE(nfort8) !last write to nfort8 + END IF +!----------------------------------------------- +! Write diagno file (J.Geiger) +!----------------------------------------------- + IF ((.not.lasym).and. ldiagno .and.lfreeb) THEN + open(unit=21,file='diagno_input.data',status='unknown', + 1 action='write') + write(21,'(a8)') "vmec2000" + write(21,*) "nfp mpol ntor" + write(21,*) nfp, mpol, ntor + write(21,*) "rmnc" + write(21,'(1p,e24.16)') (rmnc(mn,ns),mn=1,mnmax) + write(21,*) "zmns" + write(21,'(1p,e24.16)') (zmns(mn,ns),mn=1,mnmax) + write(21,*) "potsin" + DO mn = 1, mnpd + write(21,'(1p,e24.16)') potvac(mn) + END DO + write(21,*) "phiedge" + write(21,*) phiedge + write(21,*) "nextcur" + write(21,*) nextcur + write(21,*) "external currents" + write(21,*) extcur(1:nextcur) + write(21,*) "plasma current" + write(21,*) ctor + write(21,*) "plasma current filament fc R" + write(21,*) rmnc(1:ntor+1,1) + write(21,*) "plasma current filament fc z" + write(21,*) zmns(1:ntor+1,1) + close(unit=21) + END IF +!----------------------------------------------- +! for diagno version 1.5 written by Sam Lazerson (SAL) start +!----------------------------------------------- + IF(ldiagno)THEN + IF(lfreeb .and. (.not.lasym))THEN + nfort = 21 + fort_file = 'diagno1.5_in.'//input_extension + call safe_open(nfort,iwout0,fort_file,'replace', + 1 'formatted') + if (iwout0 .ne. 0) + 1 stop 'Error writing diagno_in. file in VMEC WROUT' + + write(21,'(a)') "vmec2000_B" + write(21,*) "nfp mpol ntor" + write(21,*) nfp, mpol, ntor + write(21,*) "rmnc" + write(21,'(1p,e24.16)') (rmnc(mn,ns),mn=1,mnmax) + write(21,*) "zmns" + write(21,'(1p,e24.16)') (zmns(mn,ns),mn=1,mnmax) + + write(21,*) "potsin" + DO i = 1, mnpd + write(21,'(1p,e24.16)') potvac(i) + END DO + +!----- Added by SAL 11/2010 + write(21,*) "bsupu" + js=ns + js2=ns-1 + do m = 0, mpol1 + nmin0 = -ntor + if (m .eq. 0) nmin0 = 0 + do n = nmin0, ntor + dmult = two/(mscale(m)*nscale(abs(n))) + if (m .eq. 0 .and. n .eq. 0) dmult = p5*dmult + n1 = abs(n) + isgn = sign(1, n) + d_bsupumn = 0 + do j = 1, ntheta2 + do k = 1, nzeta + lk = k + nzeta*(j - 1) + tcosi = dmult*(cosmui(j,m)*cosnv(k,n1) + + 1 isgn*sinmui(j,m)*sinnv(k,n1)) + d_bsupumn = d_bsupumn + 1.5*tcosi*bsupu(js,lk) + 1 - 0.5*tcosi*bsupu(js2,lk) + end do + end do + write (21,'(1p,e24.16)') d_bsupumn + end do + end do +!----- Added by SAL 11/2010 + write(21,*) "bsupv" + js=ns + js2=ns-1 + do m = 0, mpol1 + nmin0 = -ntor + if (m .eq. 0) nmin0 = 0 + do n = nmin0, ntor + dmult = two/(mscale(m)*nscale(abs(n))) + if (m .eq. 0 .and. n .eq. 0) dmult = p5*dmult + n1 = abs(n) + isgn = sign(1, n) + d_bsupvmn = 0 + do j = 1, ntheta2 + do k = 1, nzeta + lk = k + nzeta*(j - 1) + tcosi = dmult*(cosmui(j,m)*cosnv(k,n1) + + 1 isgn*sinmui(j,m)*sinnv(k,n1)) + d_bsupvmn = d_bsupvmn + 1.5*tcosi*bsupv(js,lk) + 1 - 0.5*tcosi*bsupv(js2,lk) + end do + end do + write (21,'(1p,e24.16)') d_bsupvmn + end do + end do + + write(21,*) "phiedge" + write(21,*) phiedge + write(21,*) "nextcur" + write(21,*) nextcur + write(21,*) "external currents" + write(21,*) extcur(1:nextcur) + + write(21,*) "plasma current" + write(21,*) ctor + write(21,*) "plasma current filament fc R" + write(21,*) rmnc(1:ntor+1,1) + write(21,*) "plasma current filament fc z" + write(21,*) zmns(1:ntor+1,1) + + close(unit=21) + ELSE + write(6,*)"Diagno-file request not completed!" + write(6,*)"VMEC2000 not running in free-boundary mode!" + write(6,*)"-or- LASYM = .true. !" + write(6,*)"LASYM = ",lasym + write(6,*)"LFREEB = ",lfreeb + write(6,*)"Check mgrid-file and namelist!" + ENDIF + ENDIF !added for diagno version 1.5 end + + ENDIF + + 950 CONTINUE + + IF (lwouttxt) CLOSE (unit=nwout2) !J Geiger: Close only if open, i.e. lwouttxt==true +!--------------------DEC$ ENDIF + IF (.not. lwrite) GOTO 970 ! J Geiger: in case lwouttxt is not true and netcdf-write is finished +#ifdef NETCDF + IF (lasym) THEN + CALL cdf_write(nwout, vn_racs, raxis_cs(0:ntor)) + CALL cdf_write(nwout, vn_zacc, zaxis_cc(0:ntor)) + CALL cdf_write(nwout, vn_rmns, rmns) + CALL cdf_write(nwout, vn_zmnc, zmnc) + CALL cdf_write(nwout, vn_lmnc, lmnc) + CALL cdf_write(nwout, vn_gmns, gmns) + CALL cdf_write(nwout, vn_bmns, bmns) + CALL cdf_write(nwout, vn_bsubumns, bsubumns) + CALL cdf_write(nwout, vn_bsubvmns, bsubvmns) + CALL cdf_write(nwout, vn_bsubsmnc, bsubsmnc) + + CALL cdf_write(nwout, vn_currumns, currumns) !MRC 8-12-16 + CALL cdf_write(nwout, vn_currvmns, currvmns) + +! GET RID OF THESE EVENTUALLY: DON'T NEED THEM + CALL cdf_write(nwout, vn_bsupumns, bsupumns) + CALL cdf_write(nwout, vn_bsupvmns, bsupvmns) + + IF (lfreeb) THEN !MRC 10-15-15 + CALL cdf_write(nwout, vn_bsubumns_sur, bsubumns_sur) + CALL cdf_write(nwout, vn_bsubvmns_sur, bsubvmns_sur) + CALL cdf_write(nwout, vn_bsupumns_sur, bsupumns_sur) + CALL cdf_write(nwout, vn_bsupvmns_sur, bsupvmns_sur) + END IF + END IF +#endif + 970 CONTINUE ! J Geiger: need to keep label 970 out of NETCDF defines. + +#ifdef NETCDF + CALL cdf_close(nwout) +#endif +! +! RESTORE nyq ENDPOINT VALUES +! + IF (lnyquist) THEN + IF (mnyq .ne. 0) cosmui(:,mnyq) = 2*cosmui(:,mnyq) + IF (nnyq .ne. 0) cosnv (:,nnyq) = 2*cosnv (:,nnyq) + END IF + +! +! DEALLOCATIONS ! J Geiger: these have been moved downwards. +! + IF (ALLOCATED(gmnc)) DEALLOCATE(gmnc, bmnc, bsubumnc, bsubvmnc, + 1 bsubsmns, bsupumnc, bsupvmnc +#ifdef _ANIMEC + 2 ,sigmnc,taumnc,pparmnc,ppermnc,pbprmnc,ppprmnc,hotdmnc +#endif + 3 ) + IF (ALLOCATED(gmns)) DEALLOCATE(gmns, bmns, bsubumns, bsubvmns, + 1 bsubsmnc, bsupumns, bsupvmns +#ifdef _ANIMEC + 2 ,sigmns,taumns,pparmns,ppermns,pbprmns,ppprmns,hotdmns +#endif + 3 ) +#ifdef _ANIMEC + IF (ALLOCATED(tau_ana)) DEALLOCATE(sigma_ana, tau_ana, ppara, + 1 pperpa, pbprima, ppprima, densita) +#endif +! J Geiger: check also for allocation. + IF (ALLOCATED(gmn)) DEALLOCATE (gmn, bmn, bsubumn, bsubvmn, + 1 bsubsmn, bsupumn, bsupvmn, +#ifdef _ANIMEC + 2 sigmn, taumn, pparmn, ppermn, pbprmn, ppprmn, + 3 hotdmn, +#endif + 4 stat=istat) + + IF (ALLOCATED(bsubumnc_sur)) THEN + DEALLOCATE(bsubumnc_sur, bsubvmnc_sur) + DEALLOCATE(bsupumnc_sur, bsupvmnc_sur) + END IF + IF (ALLOCATED(bsubumns_sur)) THEN + DEALLOCATE(bsubumns_sur, bsubvmns_sur) + DEALLOCATE(bsupumns_sur, bsupvmns_sur) + END IF + IF (ALLOCATED(bsubua_sur)) THEN + DEALLOCATE(bsubua_sur, bsubva_sur) + DEALLOCATE(bsupua_sur, bsupva_sur) + END IF + +!----------------------------------------------- +! FREE BOUNDARY DATA +!----------------------------------------------- + IF (lwrite ) + 1 CALL freeb_data(rmnc1, zmns1, rmns1, zmnc1, bmodmn, bmodmn1) + 1000 CONTINUE + + rzl_array = 0 + + CALL second0 (twoutoff) + timer(twout) = timer(twout) + twoutoff - twouton + fo_wrout_time = timer(twout) + + END SUBROUTINE wrout diff --git a/Sources/NESTOR_vacuum/CMakeLists.txt b/Sources/NESTOR_vacuum/CMakeLists.txt new file mode 100644 index 0000000..486c029 --- /dev/null +++ b/Sources/NESTOR_vacuum/CMakeLists.txt @@ -0,0 +1,20 @@ +target_sources(vmec + PRIVATE + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ +) diff --git a/Sources/NESTOR_vacuum/analysum.f b/Sources/NESTOR_vacuum/analysum.f new file mode 100644 index 0000000..a8e33c7 --- /dev/null +++ b/Sources/NESTOR_vacuum/analysum.f @@ -0,0 +1,41 @@ + SUBROUTINE analysum (grpmn, bvec, sl, tl, m, n, l, ivacskip, + 1 ndim) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: m, n, l, ivacskip, ndim + REAL(dp), INTENT(INOUT) :: grpmn(0:mf,-nf:nf,ndim,nuv3) + REAL(dp), INTENT(INOUT) :: bvec(0:mf,-nf:nf,ndim) + REAL(dp), DIMENSION(nuv3), INTENT(IN) :: sl, tl +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i + REAL(dp) :: sinp, cosp, ton, toff +C----------------------------------------------- + CALL second0(ton) + + DO i = nuv3min, nuv3max + sinp = (sinu1(i,m)*cosv1(i,n) - sinv1(i,n)*cosu1(i,m)) + 1 * cmns(l,m,n) !SIN(mu - |n|v)*cmns + IF (ivacskip .EQ. 0) grpmn(m,n,1,i) = grpmn(m,n,1,i) + 1 + sl(i)*sinp + bvec(m,n,1) = bvec(m,n,1) + tl(i)*bexni(i)*sinp + + IF (lasym) THEN + cosp = (cosu1(i,m)*cosv1(i,n) + sinv1(i,n)*sinu1(i,m)) + 1 * cmns(l,m,n) !COS(mu - |n|v)*cmns + + IF (ivacskip .EQ. 0) grpmn(m,n,2,i) = grpmn(m,n,2,i) + 1 + sl(i)*cosp + bvec(m,n,2) = bvec(m,n,2) + tl(i)*bexni(i)*cosp + END IF + END DO + CALL second0(toff) + timer_vac(tasum) = timer_vac(tasum) + (toff-ton) + + END SUBROUTINE analysum diff --git a/Sources/NESTOR_vacuum/analysum2.f b/Sources/NESTOR_vacuum/analysum2.f new file mode 100644 index 0000000..a5948dc --- /dev/null +++ b/Sources/NESTOR_vacuum/analysum2.f @@ -0,0 +1,57 @@ + SUBROUTINE analysum2 (grpmn, bvec, slp, tlp, slm, tlm, + 1 m, n, l, ivacskip, ndim) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: m, n, l, ivacskip, ndim + REAL(dp), INTENT(inout) :: grpmn(0:mf,-nf:nf,ndim,nuv3) + REAL(dp), INTENT(inout) :: bvec(0:mf,-nf:nf,ndim) + REAL(dp), DIMENSION(nuv3), INTENT(in) :: + 1 slp, tlp, slm, tlm +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i + REAL(dp) :: sinp, sinm, cosp, cosm, temp, ton, toff +C----------------------------------------------- + CALL second0(ton) + + IF (n .LT. 0) STOP 'error calling analysum2!' + + DO i = nuv3min, nuv3max + sinp = sinu1(i,m)*cosv1(i,n)*cmns(l,m,n) + temp = -cosu1(i,m)*sinv1(i,n)*cmns(l,m,n) + sinm = sinp - temp !SIN(mu + |n|v) * cmns (l,m,|n|) + sinp = sinp + temp !SIN(mu - |n|v) * cmns (l,m,|n|) + bvec(m,n,1) = bvec(m,n,1) + tlp(i)*bexni(i)*sinp + bvec(m,-n,1) = bvec(m,-n,1) + tlm(i)*bexni(i)*sinm + + IF (ivacskip .EQ. 0) THEN + grpmn(m,n,1,i) = grpmn(m,n,1,i) + slp(i)*sinp + grpmn(m,-n,1,i) = grpmn(m,-n,1,i) + slm(i)*sinm + END IF + + + IF (lasym) THEN + cosp = cosu1(i,m)*cosv1(i,n)*cmns(l,m,n) + temp = sinu1(i,m)*sinv1(i,n)*cmns(l,m,n) + cosm = cosp - temp !COS(mu + |n|v) * cmns (l,m,|n|) + cosp = cosp + temp !COS(mu - |n|v) * cmns (l,m,|n|) + bvec(m,n,2) = bvec(m,n,2) + tlp(i)*bexni(i)*cosp + bvec(m,-n,2) = bvec(m,-n,2) + tlm(i)*bexni(i)*cosm + + IF (ivacskip .EQ. 0) THEN + grpmn(m,n,2,i) = grpmn(m,n,2,i) + slp(i)*cosp + grpmn(m,-n,2,i) = grpmn(m,-n,2,i) + slm(i)*cosm + END IF + END IF + END DO + + CALL second0(toff) + timer_vac(tasum2) = timer_vac(tasum2) + (toff-ton) + + END SUBROUTINE analysum2 diff --git a/Sources/NESTOR_vacuum/analyt.f b/Sources/NESTOR_vacuum/analyt.f new file mode 100644 index 0000000..eb1f87b --- /dev/null +++ b/Sources/NESTOR_vacuum/analyt.f @@ -0,0 +1,219 @@ + SUBROUTINE analyt (grpmn, bvec, ivacskip, ndim) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: ivacskip, ndim + REAL(dp), INTENT(OUT) :: grpmn(mnpd2,nuv3) + REAL(dp), INTENT(OUT) :: bvec(mnpd,ndim) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l, n, m, i, q, j, k, ll, blksize, mn + REAL(dp), DIMENSION(:), ALLOCATABLE :: + 1 r0p, r1p, r0m, r1m, sqrtc, sqrta, tlp2, tlp1, tlp, tlm2, + 2 tlm1, tlm, adp, adm, cma, ra1p, ra1m, slm, slp, tlpm, slpm, + 3 delt1u, azp1u, azm1u, cma11u, sqad1u, sqad2u + REAL(dp) :: fl, fl1, fl2, sign1, tanalon, tanaloff +C----------------------------------------------- + CALL second0(tanalon) + + ALLOCATE (r0p(nuv3), r1p(nuv3), r0m(nuv3), r1m(nuv3), + 1 sqrtc(nuv3), sqrta(nuv3), tlp2(nuv3), tlp1(nuv3), + 2 tlp(nuv3), tlm2(nuv3), tlm1(nuv3), tlm(nuv3), adp(nuv3), + 3 adm(nuv3), cma(nuv3), ra1p(nuv3), ra1m(nuv3), slm(nuv3), + 4 slp(nuv3), tlpm(nuv3), slpm(nuv3), delt1u(nuv3), + 5 azp1u(nuv3), azm1u(nuv3), cma11u(nuv3), sqad1u(nuv3), + 6 sqad2u(nuv3), stat = l) + IF (l .ne. 0) STOP 'Allocation error in SUBROUTINE analyt' + +! +! ALL EQUATIONS REFER TO THE PAPER BY P. MERKEL (PKM) +! IN J. COMPUT. PHYSICS 66, p83 (1986) +! +! IN GOING BETWEEN THE COMPLEX NOTATION OF (PKM) AND OUR REAL FORM, +! NOTE THAT THE INTEGRALS (APPENDIX, PKM) Imn AND Kmn ARE BOTH REAL. +! THUS, THE SIN(mu-nv) INTEGRALS OF THE SINGULAR PIECE (ANALYTIC CONTRIBUTION) +! VANISHES. +! +! THE REQUIRED SOURCE-TERM INTEGRALS ARE (Eq.2.16-2.17): +! +! BVECS(m,n) = Int< SIN(mu' - nv') han(u',v') > +! BVECC(m,n) = Int< COS(mu' - nv') han(u',v') > +! +! Where Int<...> means integration over u (theta) and v (zeta) and +! summation over field periods. These can be written in terms of PKM integrals +! Imn(a,b,c), where a(u,v) = guu (g theta-theta), etc.: +! +! BVECS(m,n) = ALP * Int +! BVECC(m,n) = ALP * Int +! +! Here, F = - BNORM(u',v') is defined in Eq.(2.13), and ALP = (2*pi/nfp). +! +! Similarly, the analytic part of the matrix A(m,n;m',n') can be written: +! +! A(m,n;m',n') = (2*pi/nfp) * Int +! +! On EXIT, GRPMN(ip,m,n) = ALP * SIN(ip,m,n) * K[m,-n](ip) +! +! +! COMPUTE ALL QUANTITIES INDEPENDENT OF THE MODE INDICES L,M,N +! NOTE: 2b = guv_b HAS FACTOR OF 2 BUILT IN (see SUBROUTINE SURFACE) +! +! ADP(M): a +(-)2b + c +! CMA: c - a +! DELTA: 4*(ac - b**2) +! AZP(M): A +(-)2*B + C +! CMA1: C - A +! R1P(M): Coefficient of l*Tl+(-) in eq (A17) +! R0P(M): Coefficient of l*T(l-1)+(-) in eq (A17) +! RA1P(M):Coefficient of Tl+(-) in eq (A17) +! + DO k = nuv3min, nuv3max + adp(k) = guu_b(k) + guv_b(k) + gvv_b(k) + adm(k) = guu_b(k) - guv_b(k) + gvv_b(k) + cma(k) = gvv_b(k) - guu_b(k) + sqrtc(k) = two*SQRT(gvv_b(k)) + sqrta(k) = two*SQRT(guu_b(k)) + END DO + + IF (ivacskip .EQ. 0) THEN + + grpmn(:,nuv3min:nuv3max) = 0 + + DO k = nuv3min, nuv3max + delt1u(k) = adp(k)*adm(k) - cma(k)*cma(k) + azp1u(k) = auu(k) + auv(k) + avv(k) + azm1u(k) = auu(k) - auv(k) + avv(k) + cma11u(k)= avv(k) - auu(k) + r1p(k) = (azp1u(k)*(delt1u(k) - cma(k)*cma(k))/adp(k) + 1 - azm1u(k)*adp(k) + two*cma11u(k)*cma(k))/delt1u(k) + r1m(k) = (azm1u(k)* (delt1u(k) - cma(k)*cma(k))/adm(k) + 1 - azp1u(k)*adm(k) + two*cma11u(k)*cma(k))/delt1u(k) + r0p(k) = (-azp1u(k)*adm(k)*cma(k)/adp(k) - azm1u(k)*cma(k) + 1 + two*cma11u(k)*adm(k))/delt1u(k) + r0m(k) = (-azm1u(k)*adp(k)*cma(k)/adm(k) - azp1u(k)*cma(k) + 1 + two*cma11u(k)*adp(k))/delt1u(k) + ra1p(k) = azp1u(k)/adp(k) + ra1m(k) = azm1u(k)/adm(k) + END DO + ENDIF + +! +! INITIALIZE VECTORS +! +! bvec = 0 +! +! INITIALIZE T0+ and T0- +! +! TLP(M): TL+(-) +! TLP(M)1:T(L-1)+(-) +! TLP(M)2:T(L-2)+(-) +! + DO k = nuv3min,nuv3max + sqad1u(k) = SQRT(adp(k)) + sqad2u(k) = SQRT(adm(k)) + tlp1(k) = 0 + tlm1(k) = 0 + tlp(k) = one/sqad1u(k)*log((sqad1u(k)*sqrtc(k) + 1 + adp(k) + cma(k))/(sqad1u(k)*sqrta(k) + 2 - adp(k) + cma(k))) + tlm(k) = one/sqad2u(k)*log((sqad2u(k)*sqrtc(k) + 1 + adm(k) + cma(k))/(sqad2u(k)*sqrta(k) + 2 - adm(k) + cma(k))) + tlpm(k) = tlp(k) + tlm(k) + END DO +! +! BEGIN L-SUM IN EQ (A14) TO COMPUTE Imn (and Kmn) INTEGRALS +! NOTE THAT IN THE LOOP OVER L BELOW: L == |m - n| + 2L_A14 +! THUS, L BELOW IS THE INDEX OF THE T+- (S+-) +! + sign1 = 1 + fl1 = 0 + + LLOOP: DO l = 0, mf + nf + fl = fl1 +! +! COMPUTE SL+ and SL- , Eq (A17) +! SLP(M): SL+(-) +! + IF (ivacskip .eq. 0) THEN + DO k = nuv3min,nuv3max + slp(k) = (r1p(k)*fl + ra1p(k))*tlp(k) + r0p(k)*fl*tlp1(k) + 1 - (r1p(k) + r0p(k))/sqrtc(k) + 2 + sign1*(r0p(k) - r1p(k))/sqrta(k) + slm(k) = (r1m(k)*fl + ra1m(k))*tlm(k) + r0m(k)*fl*tlm1(k) + 1 - (r1m(k) + r0m(k))/sqrtc(k) + 2 + sign1*(r0m(k) - r1m(k))/sqrta(k) + slpm(k) = slp(k) + slm(k) + END DO + ENDIF +! +! BEGIN MODE NUMBER (m,n) LOOP +! + DO n = 0, nf + DO m = 0, mf + + IF (l .EQ. 0) THEN + mn = m + mf1*(n+nf) + 1 + bvec(mn,:) = 0 + mn = m + mf1*(nf-n) + 1 + bvec(mn,:) = 0 + END IF + + IF (cmns(l,m,n) .eq. zero) CYCLE + + IF (n.eq.0 .or. m.eq.0) THEN +! +! 1. n = 0 and m >= 0 OR n > 0 and m = 0 +! + CALL analysum (grpmn, bvec, slpm, tlpm, m, n, l, + 1 ivacskip, ndim) + + ELSE +! +! 2. n>=1 and m>=1 +! + CALL analysum2 (grpmn, bvec, slm, tlm, slp, tlp, + 1 m, n, l, ivacskip, ndim) + + ENDIF + END DO + END DO + +! +! UPDATE "TL's" (FOR L -> L+1) USING EQ (A15) +! + fl1 = fl1 + 1 !next l + fl2 = 2*fl1-1 + sign1 = -sign1 !(-1)**l (next l now) + DO k = nuv3min, nuv3max + tlp2(k) = tlp1(k) + tlm2(k) = tlm1(k) + tlp1(k) = tlp(k) + tlm1(k) = tlm(k) + tlp(k) = ((sqrtc(k) + sign1*sqrta(k)) - fl2* + 1 cma(k)*tlp1(k) - fl*adm(k)*tlp2(k))/(adp(k)*fl1) + tlm(k) = ((sqrtc(k) + sign1*sqrta(k)) - fl2* + 1 cma(k)*tlm1(k) - fl*adp(k)*tlm2(k))/(adm(k)*fl1) + tlpm(k) = tlp(k) + tlm(k) + END DO + + END DO LLOOP + + DEALLOCATE (r0p, r1p, r0m, r1m, sqrtc, sqrta, tlp2, tlp1, + 1 tlp, tlm2, tlm1, tlm, adp, adm, cma, ra1p, ra1m, slm, + 2 slp, tlpm, slpm, delt1u, azp1u, azm1u, cma11u, sqad1u, + 3 sqad2u, stat = l) + + CALL second0(tanaloff) + timer_vac(tanal) = timer_vac(tanal) + (tanaloff-tanalon) + analyt_time = timer_vac(tanal) + + + END SUBROUTINE analyt + diff --git a/Sources/NESTOR_vacuum/becoil.f b/Sources/NESTOR_vacuum/becoil.f new file mode 100644 index 0000000..e8e3c15 --- /dev/null +++ b/Sources/NESTOR_vacuum/becoil.f @@ -0,0 +1,120 @@ + SUBROUTINE becoil (rad, zee, br, bp, bz, brvac, bpvac, bzvac, & + & lscreen) + USE vparams, ONLY: nthreed + USE vacmod + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), DIMENSION(nuv3), INTENT(in) :: rad, zee + REAL(dp), DIMENSION(nuv3), INTENT(out) :: br, bp, bz + REAL(dp), DIMENSION(nr0b,nz0b,np0b), INTENT(in) :: + 1 brvac, bpvac, bzvac + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + CHARACTER(LEN=50), PARAMETER :: warning = + 1 'Plasma Boundary exceeded Vacuum Grid Size' +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, SAVE :: icount = 0 + INTEGER :: i, kv, ir, jz, ir1, jz1 + REAL(dp) :: rad0, zee0, ri, zj, + 1 pr, qz, w22, w21, w12, w11, tbecon, tbecoff +C----------------------------------------------- +! +! DETERMINE THE CYLINDRICAL COMPONENTS OF THE EXTERNAL +! MAGNETIC FIELD (BR, BP, BZ) AT A FIXED PHI PLANE BY +! USING 2-D INTERPOLATION BASED ON THE FOUR POINT FORMULA +! IN ABRAMOWITZ AND STEGUN, EQ. 25.2.66 +! +! BRVAC, BPVAC, BZVAC: CYLINDRICAL COMPONENTS OF VACUUM B-FIELD +! STORED ON R, Z, PHI GRID +! +! RAD, ZEE: ARRAY OF R, Z VALUES (ON FLUX SURFACE) +! AT WHICH B-FIELD IS TO BE DETERMINED +! +C----------------------------------------------- + CALL second0(tbecon) + + icount = icount + 1 + + DO i = nuv3min, nuv3max +! +! CHECK THAT BOUNDARY POINTS ARE INSIDE VACUUM GRID. IF NOT, +! SET THEM EQUAL TO LARGEST (OR SMALLEST) VACUUM GRID POINTS +! + rad0 = MIN(rad(i), rmaxb) + rad0 = MAX(rad0, rminb) + zee0 = MIN(zee(i), zmaxb) + zee0 = MAX(zee0, zminb) +! +! DETERMINE PHI-PLANE, KV (MUST LIE IN FIRST FIELD PERIOD) +! + kv = 1 + MOD(i - 1,nv) + kv = MIN (kv, np0b) !!Axi-symmetric special case +! +! +! DETERMINE INTEGER INDICES (IR,JZ) FOR LOWER LEFT R, Z CORNER GRID POINT +! + ir = INT((rad0 - rminb)/delrb) + 1 + jz = INT((zee0 - zminb)/delzb) + 1 + ir1 = MIN(nr0b,ir + 1) + jz1 = MIN(nz0b,jz + 1) +! +! COMPUTE RI, ZJ AND PR , QZ AT GRID POINT (IR , JZ) +! ALSO, COMPUTE WEIGHTS WIJ FOR 4 CORNER GRID POINTS +! + ri = rminb + (ir - 1)*delrb + zj = zminb + (jz - 1)*delzb + pr = (rad0 - ri)/delrb + qz = (zee0 - zj)/delzb + w22 = pr*qz !p*q + w21 = pr - w22 !p*(1-q) + w12 = qz - w22 !q*(1-p) + w11 = 1 + w22 - (pr + qz) !(1-p)*(1-q) +! +! COMPUTE B FIELD AT R, PHI, Z BY INTERPOLATION +! + br(i) = w11*brvac(ir,jz,kv) + w22*brvac(ir1,jz1,kv) + + 1 w21*brvac(ir1,jz,kv) + w12*brvac(ir,jz1,kv) + bz(i) = w11*bzvac(ir,jz,kv) + w22*bzvac(ir1,jz1,kv) + + 1 w21*bzvac(ir1,jz,kv) + w12*bzvac(ir,jz1,kv) + bp(i) = w11*bpvac(ir,jz,kv) + w22*bpvac(ir1,jz1,kv) + + 1 w21*bpvac(ir1,jz,kv) + w12*bpvac(ir,jz1,kv) + + END DO + +! +! PRINT INFO IF R, Z OUT OF BOX +! + IF (MOD(icount,25).EQ.0 .AND. rank.EQ.0) THEN + i = 0 + rad0 = MAXVAL(rad) + zee0 = MAXVAL(zee) + IF (rad0 .gt. rmaxb) i = 1 + IF (zee0 .gt. zmaxb) i = i + 2 + ri = MINVAL(rad) + zj = MINVAL(zee) + IF (ri .lt. rminb) i = i + 4 + IF (zj .lt. zminb) i = i + 8 + IF (i .ne. 0 .and. lscreen) THEN + PRINT *, warning + WRITE (nthreed, *) warning + IF (i/8 .ne. 0) PRINT *,' zmin = ', zj + i = MOD(i,8) + IF (i/4 .ne. 0) PRINT *,' rmin = ', ri + i = MOD(i,4) + IF (i/2 .ne. 0) PRINT *,' zmax = ', zee0 + i = MOD(i,2) + IF (i .ne. 0) PRINT *,' rmax = ', rad0 + END IF + ENDIF + + CALL second0(tbecoff) + becoil_time = becoil_time + (tbecoff - tbecon) + + END SUBROUTINE becoil diff --git a/Sources/NESTOR_vacuum/belicu.f b/Sources/NESTOR_vacuum/belicu.f new file mode 100644 index 0000000..192ad14 --- /dev/null +++ b/Sources/NESTOR_vacuum/belicu.f @@ -0,0 +1,32 @@ + SUBROUTINE belicu(bx, by, bz, cos1, sin1, rp, zp) + USE vacmod + USE biotsavart + USE parallel_include_module + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), DIMENSION(nuv3), INTENT(in) :: cos1, sin1, rp, zp + REAL(dp), DIMENSION(nuv3), INTENT(out) :: bx, by, bz +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: j + REAL(dp), DIMENSION(3) :: xpt, bvec + REAL(dp) :: tbelon, tbeloff +!----------------------------------------------- + CALL second0(tbelon) + + DO j = nuv3min, nuv3max + xpt(1) = rp(j) * cos1(j) + xpt(2) = rp(j) * sin1(j) + xpt(3) = zp(j) + CALL bsc_b (single_coil, xpt, bvec) + bx(j) = bvec(1); by(j) = bvec(2); bz(j) = bvec(3) + END DO + CALL cleanup_biotsavart + + CALL second0(tbeloff) + belicu_time = belicu_time + (tbeloff - tbelon) + + END SUBROUTINE belicu diff --git a/Sources/NESTOR_vacuum/bextern.f b/Sources/NESTOR_vacuum/bextern.f new file mode 100644 index 0000000..852d0b1 --- /dev/null +++ b/Sources/NESTOR_vacuum/bextern.f @@ -0,0 +1,78 @@ + SUBROUTINE bextern(plascur, wint, lscreen) + USE vacmod + USE mgrid_mod, ONLY: bvac + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), INTENT(IN) :: plascur + REAL(dp), INTENT(IN) :: wint(nuv3) + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, k + REAL(dp), ALLOCATABLE :: brad(:), bphi(:), bz(:) + REAL(dp) :: tbexon, tbexoff +C----------------------------------------------- +c +c exterior Neumann problem +c + CALL second0(tbexon) + + IF (.not.ALLOCATED(bvac)) STOP 'BVAC unallocated in bextern' + ALLOCATE (brad(nuv3), bphi(nuv3), bz(nuv3), stat=i) + IF (i .ne. 0) STOP 'allocation error in bextern' + +! +! THIS ROUTINE COMPUTES THE B DOT DS ARISING FROM EXTERNAL COILS AND INTERNAL PLASMA CURRENT +! NOTE THAT BEXN = - BEX * DS IS THE EFFECTIVE SOURCE TERM +! +! COMPUTE B FROM COILS ON THE PLASMA BOUNDARY +! + + CALL becoil (r1b,z1b,brad,bphi,bz,bvac(1,1),bvac(1,2),bvac(1,3), & + & lscreen) + +! +! COMPUTE B (ON PLASMA BOUNDARY) FROM NET TOROIDAL PLASMA CURRENT +! THE NET CURRENT IS MODELLED AS A WIRE AT THE MAGNETIC AXIS, AND THE +! BIOT-SAVART LAW IS USED TO COMPUTE THE FIELD AT THE PLASMA SURFACE +! +! USE BEXU, BEXV, BEXN AS TEMPORARY STORAGE FOR BX, BY, BZ +! + CALL tolicu (plascur) + CALL belicu (bexu, bexv, bexn, cosuv, sinuv, r1b, z1b) + + DO i = nuv3min, nuv3max + brad(i) = brad(i) + bexu(i)*cosuv(i) + bexv(i)*sinuv(i) + bphi(i) = bphi(i) - bexu(i)*sinuv(i) + bexv(i)*cosuv(i) + bz(i) = bz(i) + bexn(i) + END DO + +! +! COMPUTE COVARIANT COMPONENTS OF EXTERNAL FIELD: BEXU = B0 dot dx/du, +! BEXV = B0 dot dx/dv. HERE, BEXN = -B0*SURF_NORM CORRESPONDS TO THE +! "exterior Neumann problem" convention of PKM (sign flipped as noted in PKM) +! THUS, THE UNIT NORMAL SHOULD POINT INTO THE PLASMA (OUTWARD FROM VACUUM), +! WHICH IT DOES FOR A NEGATIVE JACOBIAN (SIGNGS) SYSTEM +! + DO i = nuv3min, nuv3max + bexu(i) = rub(i)*brad(i) + zub(i)*bz(i) + bexv(i) = rvb(i)*brad(i) + zvb(i)*bz(i) + r1b(i)*bphi(i) + bexn(i) =-(brad(i)*snr(i) + bphi(i)*snv(i) + bz(i)*snz(i)) +! +! COMPUTE NORMALIZED [(2*pi)**2], READY-TO-INTEGRATE (WINT FACTOR) SOURCE TERM +! +! NOTE: BEXN == NP*F = -B0 dot [Xu cross Xv] NP (see PKM, Eq. 2.13) + bexni(i) = bexn(i)*wint(i)*pi2*pi2 + END DO + + DEALLOCATE (brad, bphi, bz) + + CALL second0(tbexoff) + bextern_time = bextern_time + (tbexoff - tbexon) + + END SUBROUTINE bextern + diff --git a/Sources/NESTOR_vacuum/fouri.f b/Sources/NESTOR_vacuum/fouri.f new file mode 100644 index 0000000..58aa70c --- /dev/null +++ b/Sources/NESTOR_vacuum/fouri.f @@ -0,0 +1,153 @@ + SUBROUTINE fouri (grpmn, gsource, amatrix, amatsq, bvec, + & bvecNS, ndim) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: ndim + REAL(dp), DIMENSION(mnpd2,nuv3), INTENT(IN) :: grpmn + REAL(dp), DIMENSION(nuv), INTENT(IN) :: gsource + REAL(dp), DIMENSION(mnpd,mnpd,ndim**2), INTENT(OUT) :: amatrix + REAL(dp), DIMENSION(mnpd2,mnpd2), INTENT(OUT) :: amatsq + REAL(dp), DIMENSION(mnpd,ndim), INTENT(INOUT) :: bvec, bvecNS +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- +C interior (int_ext=-1), exterior (int_ext=+1) neumann problem + REAL(dp), PARAMETER :: int_ext = 1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, j, k, m, mn, mn0, n + REAL(dp), ALLOCATABLE, DIMENSION(:) :: source + REAL(dp) :: ton, toff, tfourion, tfourioff +!----------------------------------------------- +! +! AMATRIX(,1) = A(Sin)(Sin'); AMATRIX(,2) = A(Sin)(Cos'); +! AMATRIX(,3) = A(Cos)(Sin'); AMATRIX(,4) = A(Cos)(Cos') +! +! ARG OF TRIG FUNCTIONS: m'u' - n'v' CORRESPONDING TO THE PRIMED MESH IN +! PKM EQ.(2.14), AND mu - nv (UNPRIMED MESH) IN EQ. (2.16) +! +! ON ENTRY, GRPMN(MN,...) HAS BEEN FOURIER-TRANSFORMED OVER THE UNPRIMED +! COORDINATES (IN FOURP), SO THE FIRST INDEX OF GRPMN CORRESPONDS TO THE FIRST +! INDEX OF AMATRIX. THUS, THE FOURIER TRANSFORMS OF GRPMN HERE ARE OVER THE PRIMED MESH. +! +! IN CONTRAST, THE INTEGRAL OF THE SOURCE TERM OVER THE PRIMED MESH WAS ALREADY +! DONE (IN SCALPOT), SO HERE THE FT ARE OVER THE UNPRIMED MESH FOR THE SOURCE. +! + CALL second0(tfourion) + + ALLOCATE (source(nuv3), stat=i) + IF (i .NE. 0) STOP 'Allocation error in fouri' +! +! STELLARATOR-SYMMETRIZE SOURCE TERMS (with respect to u,v and -u,-v) +! INDEX (1) IS ANTI-SYMMETRIC, INDEX (2) IS SYMMETRIC +! +! GSOURCE = - (2pi)**2 B * dS (h - hsing) * WINT +! +! WINT: needed to normalize integral over angles to unity +! + IF (lasym) THEN + source(nuv3min:nuv3max) = onp*gsource(nuv3min:nuv3max) + ELSE + k = 0 + DO i = 1, nu2 + DO j = 1, nv + k = k + 1 + IF (nuv3min.LE.k .AND. k.LE.nuv3max) THEN + source(k) = p5*onp*(gsource(k) - gsource(imirr(k))) + END IF + END DO + END DO + END IF + +! +! INITIALIZE RUNNING-SUM ARRAYS +! + bvecNS = 0 + amatrix = 0 + +! +! PERFORM M,N TRANSFORMS +! + mn = 0 + NLOOP2: DO n = -nf, nf + MLOOP: DO m = 0, mf + mn = mn + 1 + j = 0 + IF (m.EQ.0 .AND. n.LT.0) CYCLE + DO i = nuv3min, nuv3max + j = j + 1 + bvecNS(mn,1) = bvecNS(mn,1) + sinmni(j,mn)*source(i) + + amatrix(:,mn,1) = amatrix(:,mn,1) + & + sinmni(j,mn)*grpmn(:mnpd,i) + + IF (.NOT.lasym) CYCLE + + bvecNS(mn,2) = bvecNS(mn,2) + cosmni(j,mn)*source(i) + + amatrix(:,mn,2) = amatrix(:,mn,2) + & + cosmni(j,mn)*grpmn(:mnpd,i) + amatrix(:,mn,3) = amatrix(:,mn,3) + & + sinmni(j,mn)*grpmn(mnpd+1:,i) + amatrix(:,mn,4) = amatrix(:,mn,4) + & + cosmni(j,mn)*grpmn(mnpd+1:,i) + END DO + END DO MLOOP + END DO NLOOP2 + + IF (vlactive) THEN + CALL second0(ton) + CALL MPI_Allreduce(MPI_IN_PLACE, amatrix, SIZE(amatrix), + & MPI_REAL8, MPI_SUM, VAC_COMM, MPI_ERR) + CALL second0(toff) + allreduce_time = allreduce_time + (toff - ton) + END IF +! +! ADD (still not reduced) ANALYTIC AND NON-SINGULAR PARTS +! + bvec = bvec + bvecNS + + DEALLOCATE (source, stat=i) + + mn0 = 1 + mf1*nf !Index of m,n=(0,0) + +!SANITY CHECKS +! IF (ANY(bvec(1:mn0-mf1:mf1,:) .NE. 0._dp)) STOP 'BVEC != 0' +! IF (ANY(amatrix(:,1:mn0-mf1:mf1,:) .ne. 0._dp)) STOP 'AMAT1 != 0' +! IF (ANY(amatrix(1:mn0-mf1:mf1,:,:) .ne. 0._dp)) STOP 'AMAT2 != 0' +! +! ADD DIAGONAL TERMS TO AMATRIX [THE FIRST TERM IN EQ(3.2) OF PKM] +! + DO mn = 1, mnpd + amatrix(mn,mn,1) = amatrix(mn,mn,1) + pi3*int_ext + END DO + + IF (lasym) THEN + DO mn = 1, mnpd + amatrix(mn,mn,4) = amatrix(mn,mn,4) + pi3*int_ext + END DO + amatrix(mn0,mn0,4) = amatrix(mn0,mn0,4) + pi3*int_ext !!COS(0-0) mode *2 + END IF + +! +! PUT ELEMENTS INTO SQUARE MATRIX +! + amatsq(:mnpd,:mnpd) = amatrix(:,:,1) !Sin-Sin' + + IF (lasym) THEN + amatsq(:mnpd,1+mnpd:mnpd2) = amatrix(:,:,2) !Sin-Cos' + amatsq(1+mnpd:mnpd2,:mnpd) = amatrix(:,:,3) !Cos-Sin' + amatsq(1+mnpd:mnpd2,1+mnpd:mnpd2) = amatrix(:,:,4) !Cos-Cos' + END IF + + CALL second0(tfourioff) + timer_vac(tfouri) = timer_vac(tfouri) + (tfourioff-tfourion) + fouri_time = timer_vac(tfouri) + + END SUBROUTINE fouri diff --git a/Sources/NESTOR_vacuum/fourp.f b/Sources/NESTOR_vacuum/fourp.f new file mode 100644 index 0000000..2a05578 --- /dev/null +++ b/Sources/NESTOR_vacuum/fourp.f @@ -0,0 +1,104 @@ + SUBROUTINE fourp (grpmn, grp, istore, istart, iend, ndim) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(inout) :: istart + INTEGER, INTENT(in) :: iend, istore, ndim + REAL(dp), INTENT(in) :: grp(nuv,istore) + REAL(dp), INTENT(inout) :: grpmn(0:mf,-nf:nf,ndim,nuv3) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: n, kv, ku, ip, iuv, m, ireflect, isym + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: g1, g2 + REAL(dp), ALLOCATABLE :: kernel(:), gcos(:),gsin(:) + REAL(dp) :: cosm, sinm, cosn, sinn, tfourpon, tfourpoff +C----------------------------------------------- +! +! PERFORM KV (TOROIDAL ANGLE) TRANSFORM (OVER UNPRIMED MESH IN EQ. 2.14) +! THUS, THE (m,n) INDEX HERE CORRESPONDS TO THE FIRST INDEX OF AMATRIX +! NOTE: THE .5 FACTOR (IN COSN,SINN) ACCOUNTS FOR THE SUM IN KERNELM +! ON ENTRY THE FIRST TIME, GRPMN IS SIN,COS * Kmn(analytic) +! +! THE 3rd INDEX OF GRPMN IS THE PRIMED U,V MESH COORDINATE +! + CALL second0(tfourpon) + ALLOCATE (g1(istore,nu2,0:nf,ndim), g2(istore,nu2,0:nf,ndim), + 1 kernel(istore), gcos(istore), gsin(istore), stat=m) + IF (m .ne. 0) STOP 'Allocation error in fourp' + + g1 = 0 + g2 = 0 + + DO n = 0, nf + DO kv = 1,nv + cosn = p5*onp*cosv(n,kv) + sinn = p5*onp*sinv(n,kv) + iuv = kv + DO ku = 1,nu2 + ireflect = imirr(iuv) + DO isym = 1, ndim + DO ip = 1,istore + IF (isym .EQ. 1) THEN + kernel(ip) = + 1 grp(iuv,ip) - grp(ireflect,ip) !anti-symmetric part (u,v -> -u,-v) + ELSE IF (isym .EQ. 2) THEN + kernel(ip) = + 1 grp(iuv,ip) + grp(ireflect,ip) !symmetric part + END IF + g1(ip,ku,n,isym)=g1(ip,ku,n,isym) + cosn*kernel(ip) + g2(ip,ku,n,isym)=g2(ip,ku,n,isym) + sinn*kernel(ip) + END DO + END DO + iuv = iuv + nv + END DO + END DO + END DO + +! +! PERFORM KU (POLOIDAL ANGLE) TRANFORM [COMPLETE SIN(mu-nv) / COS(mu-nv) TRANSFORM] +! + + DO m = 0,mf + DO ku = 1,nu2 + DO isym = 1, ndim + IF (isym .EQ. 1) THEN + cosm = -cosui(m,ku) + sinm = sinui(m,ku) + ELSE IF (isym .EQ. 2) THEN + sinm = cosui(m,ku) + cosm = sinui(m,ku) + END IF + DO n= 0,nf + DO ip = 1,istore + gcos(ip) = g1(ip,ku,n,isym)*sinm + gsin(ip) = g2(ip,ku,n,isym)*cosm + grpmn(m,n,isym,ip+istart) = + 1 grpmn(m,n,isym,ip+istart) + gcos(ip) + gsin(ip) + END DO + + IF (n.NE.0 .AND. m.NE.0) THEN !zero for m=0,n<0 (SPH082515) + DO ip = 1,istore + grpmn(m,-n,isym,ip+istart) = + 1 grpmn(m,-n,isym,ip+istart) + 2 + gcos(ip) - gsin(ip) + END DO + ENDIF + END DO + END DO + END DO + END DO + + istart = iend + + DEALLOCATE (g1, g2, kernel, gcos, gsin, stat=m) + + CALL second0(tfourpoff) + timer_vac(tfourp) = timer_vac(tfourp) + (tfourpoff-tfourpon) + fourp_time = timer_vac(tfourp) + + END SUBROUTINE fourp diff --git a/Sources/NESTOR_vacuum/greenf.f b/Sources/NESTOR_vacuum/greenf.f new file mode 100644 index 0000000..f207d65 --- /dev/null +++ b/Sources/NESTOR_vacuum/greenf.f @@ -0,0 +1,130 @@ + SUBROUTINE greenf (delgr, delgrp, ip) + USE vacmod + USE vparams, ONLY: one + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: ip + REAL(dp), DIMENSION(nuv), INTENT(OUT) :: delgr, delgrp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, DIMENSION(2) :: ilow, ihigh + INTEGER :: ivoff, iskip, iuoff, i, kp, nloop + REAL(dp), DIMENSION(:), ALLOCATABLE :: + 1 ftemp, gsave, htemp, ga1, ga2, dsave + REAL(dp):: xip, yip, xper, yper, + 1 sxsave, sysave, tgreenon, tgreenoff +C----------------------------------------------- +! +! ON ENTRANCE, IP IS THE INDEX OF THE PRIMED MESH POINT (lies in 1st field period) +! +! ON EXIT, DELGR IS THE DIFFERENCE OF "GREEN'S FUNCTION" +! AND ANALYTIC APPROXIMATION, SUMMED OVER ALL FIELD PERIODS +! DELGRP IS DIFFERENCE OF DERIVATIVE OF "GREEN'S FUNCTION" +! AND ANALYTIC APPROXIMATION. +! +! BOTH THESE QUANTITIES ARE COMPUTED FOR ALL UNPRIMED U,V POINTS IN ONE FIELD PERIOD, +! FOR THIS FIXED PRIMED POINT (IP). +! + CALL second0(tgreenon) + + ALLOCATE (ftemp(nuv), gsave(nuv), htemp(nuv), ga1(nuv), ga2(nuv), + 1 dsave(nuv), stat=i) + IF (i .NE. 0) STOP 'allocation error in greenf' + +! +! COMPUTE OFFSETS FOR U,V ANGLE DIFFERENCES AND CONSTANTS +! + ilow(1) = 1 + ilow(2) = ip + 1 + ihigh(1) = ip - 1 + ihigh(2) = nuv + ivoff = nuv + 1 - ip + iskip = (ip - 1)/nv + iuoff = nuv - nv*iskip + xip = rcosuv(ip) !x == r*COS(ip), in 1st field period + yip = rsinuv(ip) !y == r*SIN(ip), in 1st field period + delgr = 0 + delgrp = 0 + +! +! COMPUTE FIELD-PERIOD INVARIANT VECTORS +! +! NOTE: |x - x'|**2 = gsave - 2*[x*x' + y*y'] +! + DO i = 1, nuv + gsave(i) = rzb2(ip) + rzb2(i) - 2*z1b(ip)*z1b(i) + dsave(i) = drv(ip) + z1b(i)*snz(ip) + END DO + +! +! SUM OVER FIELD-PERIODS (NVPER=NFPER) OR INTEGRATE OVER NV (NVPER=64) IF NV == 1 +! +! NOTE THE SURFACE NORMAL SNORM == Xu cross Xv = NP*[SNR, SNV, SNZ] +! IS PERIODIC ON EACH FIELD PERIOD +! + DO kp = 1, nvper + xper = xip*cosper(kp) - yip*sinper(kp) !x(ip) in field period kp + yper = yip*cosper(kp) + xip*sinper(kp) !y(ip) in field period kp + sxsave = (snr(ip)*xper - snv(ip)*yper)/r1b(ip) + sysave = (snr(ip)*yper + snv(ip)*xper)/r1b(ip) + + IF (kp.EQ.1 .OR. nv.EQ.1) THEN + +! INITIALIZE ANALYTIC APPROXIMATIONS GA1, GA2 + DO i = 1, nuv + ga1(i) = tanu(i+iuoff)*(guu_b(ip)*tanu(i+iuoff) + 1 + guv_b(ip)*tanv(i+ivoff)) + 2 + gvv_b(ip)*tanv(i+ivoff)*tanv(i+ivoff) + ga2(i) = tanu(i+iuoff)*(auu(ip)*tanu(i+iuoff) + 1 + auv(ip)*tanv(i+ivoff)) + 2 + avv(ip)*tanv(i+ivoff)*tanv(i+ivoff) + END DO + + DO nloop = 1, 2 + IF (kp.GT.1 .AND. nloop.EQ.2) CYCLE + DO i = ilow(nloop), ihigh(nloop) + ga2(i) = ga2(i)/ga1(i) + ga1(i) = one/SQRT(ga1(i)) + ftemp(i) = one/(gsave(i) + 1 - 2*(xper*rcosuv(i) + yper*rsinuv(i))) + htemp(i) = SQRT(ftemp(i)) + delgrp(i) = delgrp(i) - ga2(i)*ga1(i) + 1 + ftemp(i)*htemp(i)* + 2 (rcosuv(i)*sxsave + rsinuv(i)*sysave + dsave(i)) + delgr(i) = delgr(i) + htemp(i) - ga1(i) + END DO + END DO + + IF (kp.EQ.nvper .AND. nv.EQ.1) THEN + delgrp = delgrp/nvper + delgr = delgr /nvper + END IF + + ivoff = ivoff + 2*nu + ihigh(1) = nuv + + ELSE + DO i = 1, nuv + ftemp(i) = one/(gsave(i) + 1 - 2*(xper*rcosuv(i) + yper*rsinuv(i))) + htemp(i) = SQRT(ftemp(i)) + delgrp(i) = delgrp(i) + ftemp(i)*htemp(i)* + 1 (rcosuv(i)*sxsave + rsinuv(i)*sysave + dsave(i)) + delgr(i) = delgr(i) + htemp(i) + END DO + ENDIF + END DO + + DEALLOCATE (ftemp, gsave, htemp, ga1, ga2, dsave, stat=i) + + CALL second0(tgreenoff) + timer_vac(tgreenf) = timer_vac(tgreenf) + (tgreenoff-tgreenon) + greenf_time = timer_vac(tgreenf) + + END SUBROUTINE greenf + diff --git a/Sources/NESTOR_vacuum/precal.f b/Sources/NESTOR_vacuum/precal.f new file mode 100644 index 0000000..760dd77 --- /dev/null +++ b/Sources/NESTOR_vacuum/precal.f @@ -0,0 +1,237 @@ + SUBROUTINE precal (wint) + USE vparams, ONLY: zero, one, epstan + USE vacmod + USE vmec_main, ONLY: mnmax + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), INTENT(in) :: wint(nuv3) +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(dp), PARAMETER :: p25 = p5*p5, bigno = 1.e50_dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: kp, ku, kuminus, kv, kvminus, i, m, n, mn, n1, + 1 imn, jmn, kmn, l, istat1, smn, nuv_tan, ndim, q, qq + REAL(dp), DIMENSION(0:mf + nf,0:mf,0:nf) :: cmn + REAL(dp) :: argu, argv, argp, dn1, f1, f2, f3, alp_per, + 1 tprecon, tprecoff +C----------------------------------------------- +! +! THIS ROUTINE COMPUTES INITIAL CONSTANTS AND ARRAYS +! NOTE: alu*alv = (2*pi)**2 * wint +! + CALL second0(tprecon) + + pi2 = 8*ATAN(one) + pi3 = p5*pi2**3 + pi4 = 2*pi2 + onp = one/nfper + onp2 = onp*onp + alu = pi2/nu + alv = pi2/nv + alp = pi2*onp + alvp = onp*alv + +! +! ALLOCATE PERSISTENT ARRAYS. DEALLOCATED IN FILEOUT ROUTINE +! + IF (nv == 1) THEN !(AXISYMMETRIC CASE: DO FP SUM TO INTEGRATE IN V) + nvper = 64 + nuv_tan = 2*nu*nvper + ELSE + nvper = nfper + nuv_tan = 2*nuv + END IF + + alp_per = pi2/nvper + nvp = nv*nvper + + ALLOCATE (tanu(nuv_tan), tanv(nuv_tan), + 1 sinper(nvper), cosper(nvper), sinuv(nuv), cosuv(nuv), + 2 sinu(0:mf,nu), cosu(0:mf,nu), sinv(-nf:nf,nv), + 3 cosv(-nf:nf,nv), sinui(0:mf,nu2), cosui(0:mf,nu2), + 4 cmns(0:(mf+nf),0:mf,0:nf), csign(-nf:nf), + 5 sinu1(nuv3,0:mf), cosu1(nuv3,0:mf), + 6 sinv1(nuv3,0:nf), cosv1(nuv3,0:nf), imirr(nuv), + 7 xmpot(mnpd), xnpot(mnpd), stat=istat1) + IF (istat1.ne.0) STOP 'allocation error in precal' + + +! +! IMIRR(I) GIVES THE INDEX OF THE POINT TWOPI-THETA(I),TWOPI-ZETA(I) +! + DO kp = 1, nvper + cosper(kp) = COS(alp_per*(kp - 1)) + sinper(kp) = SIN(alp_per*(kp - 1)) + END DO + + DO ku = 1, nu + kuminus = MOD(nu + 1 - ku,nu) + 1 + DO kv = 1, nv + kvminus = MOD(nv + 1 - kv,nv) + 1 + i = kv + nv*(ku - 1) + imirr(i) = kvminus + nv*(kuminus - 1) + cosuv(i) = COS(alvp*(kv - 1)) + sinuv(i) = SIN(alvp*(kv - 1)) + END DO + END DO + +! +! NOTE: ANGLE DIFFERENCE IS PI2*{[NUV + (KUP-1)] - (KU-1)} +! THIS DIFFERENCE IS ACCOUNTED FOR BY THE OFFSET IUOFF IN GREENF ROUTINE +! +! THE KP SUM BELOW IS USED ONLY FOR NV == 1. IT PERFORMS THE V-INTEGRAL +! IN AN AXISYMMETRIC PLASMA +! + i = 0 + DO kp = 1, nvper + IF (kp.gt.1 .and. nv.ne.1) EXIT + argp = p5*alp_per*(kp-1) + DO ku = 1, 2*nu + argu = p5*alu*(ku - 1) + DO kv = 1, nv + i = i + 1 + argv = p5*alv*(kv - 1) + argp + IF (ABS(argu - p25*pi2) nuv3) CYCLE l40 + cosu1(i,m) = cosu(m,ku) + sinu1(i,m) = sinu(m,ku) + END DO + END DO l40 + DO ku = 1, nu2 + cosui(m,ku) = cosu(m,ku)*alu*alv*2 + sinui(m,ku) = sinu(m,ku)*alu*alv*2 + IF (ku.eq.1 .or. ku.eq.nu2) cosui(m,ku) = p5*cosui(m,ku) + END DO + END DO + + DO n = -nf, nf + dn1 = alvp*(n*nfper) + csign(n) = SIGN(one,dn1) + l50: DO ku = 1, nu + DO kv = 1, nv + i = kv + nv*(ku - 1) + cosv(n,kv) = COS(dn1*(kv - 1)) + sinv(n,kv) = SIN(dn1*(kv - 1)) + IF (i.gt.nuv3 .or. n.lt.0) CYCLE l50 + cosv1(i,n) = cosv(n,kv) + sinv1(i,n) = sinv(n,kv) + END DO + END DO l50 + END DO + + mn = 0 + imn = nuv3min-1 + numjs_vac=nuv3max-nuv3min+1 + + ALLOCATE(sinmni(numjs_vac,mnpd), cosmni(numjs_vac,mnpd),stat=i) + IF (i .NE. 0) STOP 'Allocation error in scalpot' + DO n = -nf, nf + n1 = ABS(n) + DO m = 0, mf + mn = mn + 1 + xmpot(mn) = m + xnpot(mn) = n*nfper + DO i = nuv3min, nuv3max + sinmni(i-imn,mn) = wint(i)*(sinu1(i,m)*cosv1(i,n1) + 1 - csign(n)*cosu1(i,m)*sinv1(i,n1))*(pi2*pi2) + cosmni(i-imn,mn) = wint(i)*(cosu1(i,m)*cosv1(i,n1) + 1 + csign(n)*sinu1(i,m)*sinv1(i,n1))*(pi2*pi2) + END DO + END DO + END DO +! +! COMPUTE CMNS AND THE COEFFICIENTS OF T+- IN EQ (A14 AND A13) IN J.COMP.PHYS PAPER (PKM) +! NOTE: HERE, THE INDEX L IN THE LOOP BELOW IS THE SUBSCRIPT OF T+-. THEREFORE, +! L = 2L' + Kmn (L' = INDEX IN EQ. A14, Kmn = |m-n|), WITH LMIN = K AND LMAX = Jmn == m+n. +! +! THE FOLLOWING DEFINITIONS PERTAIN (NOTE: kmn <= L <= jmn): +! +! F1 = [(L + jmn)/2]! / [(jmn - L)/2]! == [(jmn + kmn)/2 + L']!/[(jmn - kmn)/2 + L']! +! +! F2 = [(L + kmn)/2]! == (L' + kmn)! +! +! F3 = [(L - kmn)/2]! == (L')! +! + DO m = 0, mf + DO n = 0, nf + jmn = m + n + imn = m - n + kmn = ABS(imn) + smn = (jmn + kmn)/2 !!Integer: J+K always even + f1 = 1 + f2 = 1 + f3 = 1 + DO i = 1, kmn + f1 = f1*(smn + 1 - i) + f2 = f2*i + END DO + cmn(0:mf+nf,m,n) = 0 + DO l = kmn, jmn, 2 + cmn(l,m,n) = f1/(f2*f3)*((-1)**((l - imn)/2)) + f1 = f1*p25*((jmn + l + 2)*(jmn - l)) + f2 = f2*p5*(l + 2 + kmn) + f3 = f3*p5*(l + 2 - kmn) + END DO + END DO + END DO +! +! Now combine these into a single coefficient (cmns), Eq. A13). +! NOTE: The ALP=2*pi/nfper factor is needed to normalize integral over field periods +! + DO m = 1,mf + DO n = 1,nf + cmns(0:mf+nf,m,n) = p5*alp*(cmn(0:mf+nf,m,n) + + 1 cmn(0:mf+nf,m-1,n) + cmn(0:mf+nf,m,n-1) + + 2 cmn(0:mf+nf,m-1,n-1)) + END DO + END DO + cmns(0:mf+nf,1:mf,0) = (p5*alp)*(cmn(0:mf+nf,1:mf,0) + 1 + cmn(0:mf+nf,:mf-1,0)) + cmns(0:mf+nf,0,1:nf) = (p5*alp)*(cmn(0:mf+nf,0,1:nf) + 1 + cmn(0:mf+nf,0,:nf-1)) + cmns(0:mf+nf,0,0) = (p5*alp)*(cmn(0:mf+nf,0,0) + 1 + cmn(0:mf+nf,0,0)) + + numjs_vac=nuv3max-nuv3min+1 +! blksize_scp=mnpd2 + + ALLOCATE (counts_vac(vnranks),disps_vac(vnranks), stat=i) + IF (i .NE. 0) STOP 'Allocation error in precal' + DO i = 1, vnranks + counts_vac(i) = nuv3max_arr(i) - nuv3min_arr(i) + 1 + END DO + disps_vac(1)=0 + DO i = 2, vnranks + disps_vac(i) = disps_vac(i - 1) + counts_vac(i - 1) + END DO + + CALL second0(tprecoff) + precal_time = precal_time + (tprecoff - tprecon) + + END SUBROUTINE precal diff --git a/Sources/NESTOR_vacuum/scalpot.f b/Sources/NESTOR_vacuum/scalpot.f new file mode 100644 index 0000000..712508a --- /dev/null +++ b/Sources/NESTOR_vacuum/scalpot.f @@ -0,0 +1,133 @@ + SUBROUTINE scalpot(bvec, amatrix, ivacskip) + USE vacmod + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: ivacskip + REAL(dp), INTENT(out) :: bvec(mnpd2), amatrix(mnpd2*mnpd2) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ip, istore, istart, istore_max, ndim + REAL(dp), ALLOCATABLE :: grpmn(:), green(:), gstore(:) + REAL(dp), ALLOCATABLE :: greenp(:,:) + REAL(dp) :: ton, toff, tonscal +C----------------------------------------------- + CALL second0(tonscal) + + IF (.NOT.ALLOCATED(amatsav)) THEN + STOP 'AMATSAV: Allocation error in scalpot' + END IF + + ALLOCATE (grpmn(nuv3*mnpd2), stat=ip) + IF (ip .NE. 0) STOP 'GRPMN: Allocation error in scalpot' + +! +! COMPUTE TRANFORM OF ANALYTIC SOURCE AND KERNEL +! ON EXIT, BVEC CONTAINS THE TRANSFORM OF THE ANALYTIC SOURCE +! AND GRPMN CONTAINS TRANSFORM OF NORMAL DERIVATIVE +! OF THE GREENS FUNCTION [PKM, EQ.(2.15)] +! +! FOR ivacskip != 0, USE PREVIOUSLY COMPUTED bvecsav FOR SPEED +! + + ndim = mnpd2/mnpd + CALL analyt (grpmn, bvec, ivacskip, ndim) + + IF (ivacskip .NE. 0) THEN + bvec = bvec + bvecsav + ELSE + + istore_max = MIN(64,nuv3) + + ALLOCATE (green(nuv), gstore(nuv), greenp(nuv,istore_max), + & stat=ip) + IF (ip .NE. 0) STOP 'Allocation error in scalpot' +! bvecsav = bvec !Save in fouri now + gstore = 0 +! +! COMPUTE SURFACE INTEGRALS OF SOURCE AND GREENS FUNCTION NEEDED +! FOR SPECTRAL DECOMPOSITION OF POTENTIAL INTEGRAL EQUATION +! NOTE: SOURCE IS THE RHS OF EQ.(3.2), KERNEL IS THE LHS OF EQ (3.2). +! IP IS THE INDEX OF THE PRIMED VARIABLE MESH. +! + istart = nuv3min - 1 + + !SKS: Have to parallelize over ip since arrays computed in + !surface.f like rzb2, z1b, etc but used in green.f are + !known only within [nuv3min, nuv3max]. + + PRIMED: DO ip = nuv3min, nuv3max + istore = 1 + MOD(ip-nuv3min,istore_max) +! +! COMPUTE DIFFERENCE BETWEEN THE EXACT AND ANALYTIC GREENS FUNCTION AND GRADIENT +! [FIRST TERMS IN EQ.(2.14, 2.16)]. +! +! BECAUSE OF THE LARGE SIZES INVOLVED (nuv3*nuv3), THIS IS DONE HERE BY STORING +! THESE QUANTITIES - FOR ALL VALUES OF THE UNPRIMED U,V COORDINATE MESH - ON A +! LIMITED SUBSET (ISTORE_max) OF PRIMED MESH VALUES (INDEXED BY ISTORE~IP), +! THE FOURIER TRANSFORM OVER THE PRIMED MESH IS "BUILT-UP" BY MULTIPLE CALLS TO FOURP +! WITHIN THIS LOOP. +! + CALL greenf (green, greenp(1,istore), ip) + + +! PERFORM INTEGRAL (SUM) OVER PRIMED MESH OF NON-SINGULAR SOURCE TERM +! [(h-hsing)(u,v,u',v') == bexni(ip)*green(u,v; ip) in Eq. 2.16] +! AND STORE IT - FOR UNPRIMED MESH VALUES - IN GSTORE + + gstore = gstore + bexni(ip)*green + +! +! PERFORM FOURIER INTEGRAL OF GRADIENT KERNEL (GREENP) OVER THE UNPRIMED MESH +! AND STORE IN GRPMN (NOTE THAT GRPMN IS ADDED TO THE ANALYTIC PIECE IN EQ. 2.14, +! - COMPUTED IN ANALYT - WHICH HAS THE APPROPRIATE SIN, COS FACTORS ALREADY) +! + + IF (istore.EQ.istore_max .OR. ip.EQ.nuv3max) THEN + CALL fourp (grpmn, greenp, istore, istart, ip, ndim) + END IF + + END DO PRIMED + + CALL second0(ton) + IF (vlactive) THEN + CALL MPI_Allreduce(MPI_IN_PLACE, gstore, SIZE(gstore), + & MPI_REAL8, MPI_SUM, VAC_COMM, MPI_ERR) + END IF + CALL second0(toff) + allreduce_time = allreduce_time + (toff - ton) + timer_vac(tallr) = timer_vac(tallr) + (toff-ton) +! +! COMPUTE FOURIER INTEGRAL OF GRADIENT (GRPMN) OVER PRIMED MESH IN EQ. 2.14 +! AND SOURCE (GSTORE) OVER UNPRIMED MESH IN EQ. 2.16 +! + CALL fouri (grpmn, gstore, amatrix, amatsav, bvec, + & bvecsav, ndim) + DEALLOCATE (green, greenp, gstore) + + END IF + + DEALLOCATE (grpmn, stat=ip) + + amatrix = amatsav + +! +! FINAL REDUCTION OVER VAC_COMM DONE ONCE HERE +! + CALL second0(ton) + IF (vlactive) THEN + CALL MPI_Allreduce(MPI_IN_PLACE, bvec, SIZE(bvec), MPI_REAL8, + & MPI_SUM, VAC_COMM, MPI_ERR) + END IF + + CALL second0(toff) + allreduce_time = allreduce_time + (toff - ton) + timer_vac(tanar) = timer_vac(tanar) + (toff-ton) + + scalpot_time = scalpot_time + (tonscal - toff) + + END SUBROUTINE scalpot diff --git a/Sources/NESTOR_vacuum/surface.f b/Sources/NESTOR_vacuum/surface.f new file mode 100644 index 0000000..8f497a8 --- /dev/null +++ b/Sources/NESTOR_vacuum/surface.f @@ -0,0 +1,141 @@ + SUBROUTINE surface(rc, rs, zs, zc, xm, xn, mnmax) + USE vacmod + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER mnmax + REAL(dp), DIMENSION(mnmax) :: rc, rs, zs, zc, xm, xn +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, mn, m, n, n1 + REAL(dp), ALLOCATABLE, DIMENSION(:) :: + 1 ruu, ruv, rvv, zuu, zuv, zvv, cosmn1, sinmn1 + REAL(dp) :: tsurfon, tsurfoff +C----------------------------------------------- +! +! THIS ROUTINE COMPUTES THE SURFACE VALUES OF R,Z AND DERIVATIVES +! +! +! Compute R & Z (and their derivatives) on surface +! +! R = SUM [RC(m,n)*COS(mu - nv) + RS(m,n)*SIN(mu - nv)] +! Z = SUM [ZS(m,n)*SIN(mu - nv) + ZC(m,n)*COS(mu - nv)] +! +! NOTE: u, v here are actual angles (0, 2pi), NOT the normalized +! variables used in PKM paper +! + CALL second0(tsurfon) + + ALLOCATE (ruu(nuv3), ruv(nuv3), rvv(nuv3), zuu(nuv3), zuv(nuv3), + 1 zvv(nuv3), cosmn1(nuv3), sinmn1(nuv3), stat = i) + IF (i .ne. 0) STOP 'Allocation error in SURFACE' + + r1b = 0; z1b = 0 + DO i = nuv3min, nuv3max + zub(i) = 0; zvb(i) = 0; zuu(i) = 0; zuv(i) = 0; zvv(i) = 0 + rub(i) = 0; rvb(i) = 0; ruu(i) = 0; ruv(i) = 0; rvv(i) = 0 + END DO + + DO mn = 1, mnmax + m = NINT(xm(mn)) + n = NINT(xn(mn)/(nfper)) + n1 = ABS(n) + cosmn1(:) = cosu1(:,m)*cosv1(:,n1) + csign(n)*sinu1(:,m)* + 1 sinv1(:,n1) + sinmn1(:) = sinu1(:,m)*cosv1(:,n1) - csign(n)*cosu1(:,m)* + 1 sinv1(:,n1) + DO i = 1, nuv3 + r1b(i) = r1b(i) + rc(mn) * cosmn1(i) + z1b(i) = z1b(i) + zs(mn) * sinmn1(i) + END DO + DO i = nuv3min, nuv3max + rub(i) = rub(i) - xm(mn) * rc(mn) * sinmn1(i) + rvb(i) = rvb(i) + xn(mn) * rc(mn) * sinmn1(i) + zub(i) = zub(i) + xm(mn) * zs(mn) * cosmn1(i) + zvb(i) = zvb(i) - xn(mn) * zs(mn) * cosmn1(i) + ruu(i) = ruu(i) - xm(mn)*xm(mn)*rc(mn) * cosmn1(i) + ruv(i) = ruv(i) + xm(mn)*xn(mn)*rc(mn) * cosmn1(i) + rvv(i) = rvv(i) - xn(mn)*xn(mn)*rc(mn) * cosmn1(i) + zuu(i) = zuu(i) - xm(mn)*xm(mn)*zs(mn) * sinmn1(i) + zuv(i) = zuv(i) + xm(mn)*xn(mn)*zs(mn) * sinmn1(i) + zvv(i) = zvv(i) - xn(mn)*xn(mn)*zs(mn) * sinmn1(i) + END DO + + IF (.NOT.lasym) CYCLE + + DO i = 1, nuv3 + r1b(i) = r1b(i) + rs(mn) * sinmn1(i) + z1b(i) = z1b(i) + zc(mn) * cosmn1(i) + END DO + DO i = nuv3min, nuv3max + rub(i) = rub(i) + xm(mn) * rs(mn) * cosmn1(i) + rvb(i) = rvb(i) - xn(mn) * rs(mn) * cosmn1(i) + zub(i) = zub(i) - xm(mn) * zc(mn) * sinmn1(i) + zvb(i) = zvb(i) + xn(mn) * zc(mn) * sinmn1(i) + ruu(i) = ruu(i) - xm(mn)*xm(mn)*rs(mn) * sinmn1(i) + ruv(i) = ruv(i) + xm(mn)*xn(mn)*rs(mn) * sinmn1(i) + rvv(i) = rvv(i) - xn(mn)*xn(mn)*rs(mn) * sinmn1(i) + zuu(i) = zuu(i) - xm(mn)*xm(mn)*zc(mn) * cosmn1(i) + zuv(i) = zuv(i) + xm(mn)*xn(mn)*zc(mn) * cosmn1(i) + zvv(i) = zvv(i) - xn(mn)*xn(mn)*zc(mn) * cosmn1(i) + END DO + END DO + +! +! COMPUTE METRIC COEFFICIENTS GIJ_B AND SURFACE NORMAL COMPONENTS +! [SNR, SNV, SNZ] = NP*[Xu cross Xv] +! +! NOTE: These should be multiplied by -signgs to point OUTWARD from vacuum INTO plasma +! for either handed-ness of the coordinate system +! +! Eq. 2.4 in PKM has wrong sign for a left-handed coordinate system +! +! NOTE: guv = .5*np guv_b; gvv = np*np* gvv_b, where GUV, GVV are the +! REAL metric elements. CAP(A), etc. defined in Eq. (2.13) of PKM paper +! +! AUU == NP*CAP(A) = .5*Xuu dot [Xu cross Xv] * NP +! +! AUV == 2*NP*CAP(B) = Xuv dot [Xu cross Xv] * NP +! +! AVV == NP*CAP(C) = .5*Xvv dot [Xu cross Xv] * NP +! + DO i = nuv3min, nuv3max + guu_b(i) = rub(i)*rub(i) + zub(i)*zub(i) + guv_b(i) = (rub(i)*rvb(i)+ zub(i)*zvb(i))*onp*2 + gvv_b(i) = (rvb(i)*rvb(i)+ zvb(i)*zvb(i)+(r1b(i)*r1b(i)))*onp2 + snr(i) = signgs*r1b(i)*zub(i) + snv(i) = signgs*(rub(i)*zvb(i) - rvb(i)*zub(i)) + snz(i) =-signgs*r1b(i)*rub(i) + drv(i) = -(r1b(i)*snr(i) + z1b(i)*snz(i)) + auu(i) = p5*(snr(i)*ruu(i) + snz(i)*zuu(i)) + auv(i) = (snr(i)*ruv(i) + snv(i)*rub(i) + snz(i)*zuv(i))*onp + avv(i) = (snv(i)*rvb(i) + p5*(snr(i)*(rvv(i) - r1b(i)) + 1 + snz(i)* zvv(i)))*onp2 + END DO + + DO i = 1, nuv3 + rzb2(i) = r1b(i)*r1b(i) + z1b(i)*z1b(i) + END DO + IF (.NOT.lasym) THEN + DO i = 1 + nv, nuv3 - nv + rzb2(imirr(i)) = rzb2(i) + r1b(imirr(i)) = r1b(i) + z1b(imirr(i)) =-z1b(i) + END DO + END IF + + DO i = 1, nuv + rcosuv(i) = r1b(i)*cosuv(i) + rsinuv(i) = r1b(i)*sinuv(i) + END DO + + DEALLOCATE (ruu, ruv, rvv, zuu, zuv, zvv, cosmn1, sinmn1, stat=i) + + CALL second0(tsurfoff) + surface_time = surface_time + (tsurfoff-tsurfon) + + END SUBROUTINE surface + diff --git a/Sources/NESTOR_vacuum/tolicu.f b/Sources/NESTOR_vacuum/tolicu.f new file mode 100644 index 0000000..54e8efe --- /dev/null +++ b/Sources/NESTOR_vacuum/tolicu.f @@ -0,0 +1,48 @@ + SUBROUTINE tolicu (torcur) + USE vparams, ONLY: mu0 + USE vacmod + USE biotsavart + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(dp), INTENT(IN) :: torcur +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, kper, kv + REAL(dp) :: current(1), ttolion, ttolioff + REAL(dp), DIMENSION(:,:), ALLOCATABLE :: xpts +C----------------------------------------------- +! +! COMPUTE WIRE SEGMENTS (DO NOT CLOSE LOOP, CLOSURE DONE IN biotsavart ROUTINES) +! + CALL second0(ttolion) + + ALLOCATE (xpts(3,nvp), stat=i) + IF (i .ne. 0) STOP ' allocation error in tolicu' + + current = torcur/mu0 + + i = 0 + DO kper = 1, nvper + DO kv = 1, nv + i = i + 1 + xpts(1,i) = raxis_nestor(kv)*(cosper(kper)*cosuv(kv) + 1 - sinper(kper)*sinuv(kv)) + xpts(2,i) = raxis_nestor(kv)*(sinper(kper)*cosuv(kv) + 1 + cosper(kper)*sinuv(kv)) + xpts(3,i) = zaxis_nestor(kv) + END DO + END DO + +! +! INITIALIZE COIL-RELATED QUANTITIES +! + CALL initialize_biotsavart (current, xpt=xpts) + + CALL second0(ttolioff) + s_tolicu_time = s_tolicu_time + (ttolioff - ttolion) + + END SUBROUTINE tolicu diff --git a/Sources/NESTOR_vacuum/vac_persistent.f b/Sources/NESTOR_vacuum/vac_persistent.f new file mode 100644 index 0000000..e4dadff --- /dev/null +++ b/Sources/NESTOR_vacuum/vac_persistent.f @@ -0,0 +1,19 @@ + MODULE vac_persistent + USE stel_kinds + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, DIMENSION(:), ALLOCATABLE :: imirr + REAL(rprec), DIMENSION(:), ALLOCATABLE :: sinper, cosper, + 1 sinuv, cosuv, tanu, tanv, xmpot, xnpot, csign + REAL(rprec), DIMENSION(:,:), ALLOCATABLE :: sinu, cosu, + 1 sinv, cosv, sinui, cosui, sinu1, cosu1, sinv1, cosv1, + 2 cosmni, sinmni + REAL(rprec), DIMENSION(:,:,:), ALLOCATABLE :: cmns + +!MRC 10-15-15 + REAL(rprec), DIMENSION(:), ALLOCATABLE :: bsubu_sur, bsubv_sur + REAL(rprec), DIMENSION(:), ALLOCATABLE :: bsupu_sur, bsupv_sur + + END MODULE vac_persistent diff --git a/Sources/NESTOR_vacuum/vacmod.f b/Sources/NESTOR_vacuum/vacmod.f new file mode 100644 index 0000000..04dd1bc --- /dev/null +++ b/Sources/NESTOR_vacuum/vacmod.f @@ -0,0 +1,28 @@ + MODULE vacmod + USE vacmod0 + USE vac_persistent + USE vmec_input, ONLY: lasym + USE vmec_params, ONLY: signgs + USE vparams, ONLY: zero, one, c2p0, cp5 + USE mgrid_mod, ONLY: nr0b, np0b, nz0b, + 1 rminb, zminb, rmaxb, zmaxb, delrb, delzb + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: p5 = cp5, two = c2p0 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: nfper, nvper + REAL(rprec), DIMENSION(:), ALLOCATABLE, TARGET :: potvac + REAL(rprec), DIMENSION(:), ALLOCATABLE :: bvecsav, amatsav, + 1 bexni, brv, bphiv, bzv, bsqvac, bsqvac0, r1b, rub, rvb, z1b, + 2 zub, zvb, bexu, bexv, bexn, auu, auv, avv, snr, snv, snz, drv, + 3 guu_b, guv_b, gvv_b, rzb2, rcosuv, rsinuv, + 5 bredge, bpedge, bzedge + REAL(rprec), DIMENSION(:), ALLOCATABLE :: raxis_nestor, + 1 zaxis_nestor + REAL(rprec) :: bsubvvac, pi2, + 2 pi3, pi4, alp, alu, alv, alvp, onp, onp2 + END MODULE vacmod diff --git a/Sources/NESTOR_vacuum/vacmod0.f b/Sources/NESTOR_vacuum/vacmod0.f new file mode 100644 index 0000000..07866fb --- /dev/null +++ b/Sources/NESTOR_vacuum/vacmod0.f @@ -0,0 +1,9 @@ + MODULE vacmod0 + IMPLICIT NONE +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + INTEGER :: mf, nf, nu, nv, mf1, nf1, mnpd, mnpd2, + 1 nvp, nuv, nu2, nu3, nuv3 +!----------------------------------------------- + END MODULE vacmod0 diff --git a/Sources/NESTOR_vacuum/vacuum.f b/Sources/NESTOR_vacuum/vacuum.f new file mode 100644 index 0000000..58f3bb4 --- /dev/null +++ b/Sources/NESTOR_vacuum/vacuum.f @@ -0,0 +1,286 @@ + SUBROUTINE vacuum_par (rmnc, rmns, zmns, zmnc, xm, xn, + & plascur, rbtor, wint, ns, ivac_skip, + & ivac, mnmax, ier_flag, lscreen) + USE vacmod + USE vparams, ONLY: nthreed, zero, one, mu0 + USE vmec_params, ONLY: norm_term_flag, phiedge_error_flag + USE vmec_input, ONLY: lrfp ! JDH Added 2013-11-25, to test for RFP + USE vmec_main, ONLY: nznt, irst + USE parallel_include_module + USE timer_sub + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: ns, ivac_skip, ivac, mnmax, ier_flag + REAL(dp) :: plascur, rbtor + REAL(dp), DIMENSION(mnmax), INTENT(in) :: + & rmnc, rmns, zmns, zmnc, xm, xn + REAL(dp), DIMENSION(nuv3), INTENT(in) :: wint + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mn, n, n1, m, i, info=0, j + REAL(dp), DIMENSION(:), POINTER :: potcos, potsin + REAL(dp), ALLOCATABLE :: potu(:), potv(:) + REAL(dp), ALLOCATABLE :: amatrix(:) + REAL(dp):: dn2, dm2, cosmn, sinmn, huv, hvv, + & det, bsubuvac, fac, ton, toff + REAL(dp) :: tmp1(2), tmp2(2) +C----------------------------------------------- +! +! THIS ROUTINE COMPUTES .5 * B**2 ON THE VACUUM / PLASMA SURFACE +! BASED ON THE PROGRAM BY P. MERKEL [J. Comp. Phys. 66, 83 (1986)] +! AND MODIFIED BY W. I. VAN RIJ AND S. P. HIRSHMAN (1987) + +! THE USER MUST SUPPLY THE FILE << MGRID >> WHICH INCLUDES THE MAGNETIC +! FIELD DATA TO BE READ BY THE SUBROUTINE BECOIL +! THE "VACUUM.INC" FILE IS DEFINED IN VMEC.UNIX +! +! + CALL second0(tvacon) + IF (.NOT.ALLOCATED(potvac)) STOP 'POTVAC not ALLOCATED in VACCUM' + + ALLOCATE (amatrix(mnpd2*mnpd2), potu(nuv3), potv(nuv3), stat=i) + IF (i .NE. 0) STOP 'Allocation error in vacuum' + + potsin => potvac(1:mnpd) + potcos => potvac(1+mnpd:) + + ALLOCATE (bexu(nuv3), bexv(nuv3), bexn(nuv3), + & bexni(nuv3), r1b(nuv), rub(nuv3), rvb(nuv3), + & z1b(nuv), zub(nuv3), zvb(nuv3), auu(nuv3), auv(nuv3), + & avv(nuv3), snr(nuv3), snv(nuv3), snz(nuv3), drv(nuv3), + & guu_b(nuv3), guv_b(nuv3), gvv_b(nuv3), rzb2(nuv), + & rcosuv(nuv), rsinuv(nuv), stat=i) + IF (i .NE. 0) STOP 'Allocation error in vacuum' + +! +! INDEX OF LOCAL VARIABLES +! +! rmnc,rmns,zmns,zmnc: Surface Fourier coefficients (m,n) of R,Z +! xm,xn: m, n values corresponding to rc,zs array +! bsqvac: B**2/2 at the vacuum INTERFACE +! plascur: net toroidal current +! rbtor : net (effective) poloidal current (loop integrated R*Btor) +! mnmax: number of R, Z modes in Fourier series of R,Z +! ivac_skip: regulates whether full (=0) or incremental (>0) +! update of matrix elements is necessary +! +! +! compute and store mean magnetic fields (due to +! toroidal plasma current and EXTERNAL tf-coils) +! note: these are fixed for a constant current iteration +! +! bfield = rbtor*grad(zeta) + plascur*grad("theta") - grad(potential) +! +! where "theta" is computed using Biot-Savart law for filaments +! Here, the potential term is needed to satisfy B dot dS = 0 and has the form: +! +! potential = SUM potsin*SIN(mu - nv) + potcos*COS(mu - nv) +! + CALL second0(ton) + IF (.NOT. ALLOCATED(tanu)) CALL precal (wint) + CALL surface (rmnc, rmns, zmns, zmnc, xm, xn, mnmax) + CALL second0(toff) + timer_vac(tsurf) = timer_vac(tsurf) + (toff-ton) + + ton = toff + CALL bextern (plascur, wint, lscreen) + CALL second0(toff) + timer_vac(tbext) = timer_vac(tbext)+(toff-ton) +! +! Determine scalar magnetic potential POTVAC +! + CALL second0(ton) + CALL scalpot (potvac, amatrix, ivac_skip) + CALL second0(toff) + timer_vac(tscal) = timer_vac(tscal) + (toff-ton) + + ton = toff + CALL solver (amatrix, potvac, mnpd2, 1, info) + CALL second0(toff) + timer_vac(tsolver) = timer_vac(tsolver) + (toff-ton) + solver_time = solver_time + (toff - ton) + + IF (info .NE. 0) STOP 'Error in solver in VACUUM' +! +! compute tangential covariant (sub u,v) and contravariant +! (super u,v) magnetic field components on the plasma surface +! + potu(nuv3min:nuv3max) = 0; potv(nuv3min:nuv3max) = 0 + + mn = 0 + DO n = -nf, nf + dn2 = -(n*nfper) + n1 = ABS(n) + DO m = 0, mf + mn = mn + 1 + dm2 = m + j = 0 + DO i = nuv3min, nuv3max + j = j + 1 + cosmn = potsin(mn)*cosmni(j,mn)/(pi2*pi2*wint(i)) + potu(i) = potu(i) + dm2*cosmn + potv(i) = potv(i) + dn2*cosmn + END DO + IF (.NOT.lasym) CYCLE + j = 0 + DO i = nuv3min, nuv3max + j = j + 1 + sinmn = potcos(mn)*sinmni(j,mn)/(pi2*pi2*wint(i)) + potu(i) = potu(i) - dm2*sinmn + potv(i) = potv(i) - dn2*sinmn + END DO + END DO + END DO + + DO i = nuv3min, nuv3max + bsubu_sur(i) = potu(i) + bexu(i) !Covariant components + bsubv_sur(i) = potv(i) + bexv(i) + huv = p5*guv_b(i)*(nfper) + hvv = gvv_b(i)*(nfper*nfper) + det = one/(guu_b(i)*hvv-huv*huv) + bsupu_sur(i) = (hvv*bsubu_sur(i)-huv*bsubv_sur(i))*det !Contravariant components + bsupv_sur(i) = ((-huv*bsubu_sur(i))+guu_b(i)*bsubv_sur(i))*det + bsqvac(i) = p5*(bsubu_sur(i)*bsupu_sur(i) + & + bsubv_sur(i)*bsupv_sur(i)) !.5*|Bvac|**2 + brv(i) = rub(i)*bsupu_sur(i) + rvb(i)*bsupv_sur(i) + bphiv(i) = r1b(i)*bsupv_sur(i) + bzv(i) = zub(i)*bsupu_sur(i) + zvb(i)*bsupv_sur(i) + END DO +! +! PRINT OUT VACUUM PARAMETERS +! + IF (ivac .EQ. 0) THEN + ivac = ivac + 1 + IF (vrank .EQ. 0) THEN + IF (lscreen) WRITE (*, 200) nfper, mf, nf, nu, nv + WRITE (nthreed, 200) nfper, mf, nf, nu, nv + END IF + 200 FORMAT(/,2x,'In VACUUM, np =',i3,2x,'mf =',i3,2x,'nf =',i3, + & ' nu =',i3,2x,'nv = ',i4) + + bsubuvac = 0 + bsubvvac = 0 + DO i = nuv3min, nuv3max + bsubuvac = bsubuvac + bsubu_sur(i)*wint(i) + bsubvvac = bsubvvac + bsubv_sur(i)*wint(i) + END DO + tmp1(1) = bsubuvac + tmp1(2)=bsubvvac + CALL second0(ton) + + IF (vlactive) THEN + CALL MPI_Allreduce(tmp1, tmp2, 2, MPI_REAL8, MPI_SUM, + & VAC_COMM, MPI_ERR) + END IF + + CALL second0(toff) + allreduce_time = allreduce_time + (toff - ton) + bsubuvac = tmp2(1); bsubvvac = tmp2(2) + bsubuvac = bsubuvac*signgs*pi2 + + fac = 1.e-6_dp/mu0 + IF (vrank .EQ. 0) THEN + IF (lscreen ) THEN + WRITE (*,1000) bsubuvac*fac, plascur*fac, bsubvvac, rbtor + END IF + WRITE (nthreed, 1000) bsubuvac*fac, plascur*fac, bsubvvac, + & rbtor + END IF + 1000 FORMAT(2x,'2*pi * a * -BPOL(vac) = ',1p,e10.2, + & ' TOROIDAL CURRENT = ',e10.2,/,2x,'R * BTOR(vac) = ', + & e10.2,' R * BTOR(plasma) = ',e10.2) +! JDH Add test for RFP. 2013-11-25 +! IF (rbtor*bsubvvac .lt. zero) ier_flag = phiedge_error_flag +! IF (ABS((plascur - bsubuvac)/rbtor) .gt. 1.e-2_dp) +! 1 ier_flag = 10 + IF (rbtor*bsubvvac .LT. zero) THEN + IF (lrfp) THEN + IF (vrank .EQ. 0) THEN + IF (lscreen) WRITE(*,1100) + WRITE(nthreed,1100) + END IF + ELSE + ier_flag = phiedge_error_flag + ENDIF + ENDIF + IF (ABS((plascur - bsubuvac)/rbtor) .GT. 5.e-2_dp) THEN + IF (lrfp) THEN + IF (vrank .EQ. 0) THEN + IF (lscreen) WRITE(*,1200) + WRITE(nthreed,1200) + END IF + ELSE + ier_flag = 10 + ENDIF + ENDIF +! END JDH Add test for RFP. 2013-11-25 + ENDIF +1100 FORMAT('lrfp is TRUE. Ignore phiedge sign problem') +1200 FORMAT('lrfp is TRUE. Proceed with convergence') + + IF (ALLOCATED(bexu)) + & DEALLOCATE (bexu, bexv, bexn, bexni, r1b, rub, rvb, z1b, zub, + & zvb, auu, auv, avv, snr, snv, snz, drv, guu_b, guv_b, gvv_b, + & rzb2, rcosuv, rsinuv, stat=i) + IF (i .NE. 0) STOP 'Deallocation error in vacuum' + + DEALLOCATE (amatrix, potu, potv, stat=i) + IF (i .NE. 0) STOP 'Deallocation error in vacuum' + + CALL second0(ton) + + IF (vlactive) THEN + CALL MPI_Allgatherv(MPI_IN_PLACE, numjs_vac, MPI_REAL8, bsqvac, + & counts_vac, disps_vac, MPI_REAL8, VAC_COMM, + & MPI_ERR) + END IF + + CALL second0(toff) + timer_vac(tallgv) = timer_vac(tallgv) + (toff-ton) + + tvacoff = toff + vacuum_time = vacuum_time + (tvacoff - tvacon) + + END SUBROUTINE vacuum_par + + + SUBROUTINE vacuum(rmnc, rmns, zmns, zmnc, xm, xn, + & plascur, rbtor, wint, ns, ivac_skip, ivac, + & mnmax, ier_flag, lscreen) + USE vacmod + USE vparams, ONLY: nthreed, zero, one, mu0 + USE vmec_params, ONLY: norm_term_flag, phiedge_error_flag + USE vmec_input, ONLY: lrfp ! JDH Added 2013-11-25, to test for RFP + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: ns, ivac_skip, ivac, mnmax, ier_flag + REAL(dp) :: plascur, rbtor + REAL(dp), DIMENSION(mnmax), INTENT(in) :: + & rmnc, rmns, zmns, zmnc, xm, xn + REAL(dp), DIMENSION(ns, nuv3), INTENT(in) :: wint + LOGICAL :: lscreen +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i + REAL(dp), ALLOCATABLE :: tmpwint(:) +C----------------------------------------------- + ALLOCATE (tmpwint(nuv3), stat=i) + IF (i .NE. 0) STOP 'Allocation error in vacuum' + + tmpwint(:) = wint(ns, :) + + CALL vacuum_par (rmnc, rmns, zmns, zmnc, xm, xn, + & plascur, rbtor, tmpwint, ns, ivac_skip, + & ivac, mnmax, ier_flag, lscreen) + + DEALLOCATE (tmpwint, stat = i) + + END SUBROUTINE vacuum diff --git a/Sources/Splines/CMakeLists.txt b/Sources/Splines/CMakeLists.txt new file mode 100644 index 0000000..b493d03 --- /dev/null +++ b/Sources/Splines/CMakeLists.txt @@ -0,0 +1,16 @@ +target_sources(vmec + PRIVATE + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ + $ +) diff --git a/Sources/Splines/add_tension.f b/Sources/Splines/add_tension.f new file mode 100644 index 0000000..fcd7a58 --- /dev/null +++ b/Sources/Splines/add_tension.f @@ -0,0 +1,93 @@ + SUBROUTINE add_tension(amat, wten, hx, tens, tensv, fpoly, + 1 n, nb, ioff, nmat) + USE vspline + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER n, nb, ioff, nmat + REAL(rprec) tens, tensv, fpoly + REAL(rprec), DIMENSION(nmat,*) :: amat + REAL(rprec), DIMENSION(nmat) :: wten + REAL(rprec), DIMENSION(n) :: hx +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: k, i, koff + REAL(rprec), DIMENSION(n) :: wten0, tenshx, work + REAL(rprec) :: delta_x, tension +C----------------------------------------------- + +! +! THIS SUBROUTINE ADDS THE TENSION TERM WTEN*(DEL(K) - DEL(K-1)) +! TO THE REST OF THE CHI-SQ AMAT, WHERE DEL(K) = (G(K+1)-G(K))/H(K) +! AND G(K) IS THE SECOND DERIVATIVE AT THE K-TH KNOT +! +! IOFF ALLOWS FOR ADDING TENSION SEPARATELY TO IOTA (IOFF=0) +! AND PRESSURE (IOFF=NIOTA) SPLINES +! +! tens: spline tension (optionally, at the 1st pt only;see note) +! tensv: vbl spline tension for n-1th point (see note) +! fpoly: vbl spline tension form factor (note: if tens1<>tens2 +! then tension(i-th point) = tens+(tensv-tens)*(i/n-1))**fpoly) + +! +! BOUNDS CHECKING +! + IF (n + ioff > nmat) STOP '(n+ioff>nmat)' + IF (fpoly < 0.) STOP '(fpoly<0)' + IF (n < 1) STOP '(n < 1)' + +! +! COMPUTE TENSION COEFFICIENTS +! + + delta_x = SUM(hx(:n-1)) + tension = 0.5*(delta_x/(n))**3 + IF (fpoly.eq.0. .or. tens.eq.tensv) THEN + tenshx(:n-1) = tens + ELSE + DO i = 1, n - 1 + tenshx(i) = tens + (tensv - tens)*(REAL(i - 1,rprec)/ + 1 (n - 1))**fpoly + END DO + ENDIF + + DO i = 1,n-1 + tenshx(i) = tension * tenshx(i) / hx(i) + work(i) = hx(i)*(wten(i+ioff) + wten(i+ioff+1)) + ENDDO + DO i = 2,n-1 + wten0(i) = 0.5 * ( work(i) + work(i-1) )/(hx(i) + hx(i-1)) + ENDDO + wten0(1) = wten0(2) + wten0(n) = wten(n+ioff) +! +! COMPUTE, FOR K = 1,N, B(K,L)*JACOBIAN(L,I) = W(K,I), +! WHERE JACOBIAN = D[G]/D[F] and B is TRIDIAGONAL +! SEE EQN(27) IN PHYS.PLASMAS 1, p 2277. +! + DO k = 1, n + koff = k + ioff + work(:n-1) = 0 +! SET UP COEFFICIENTS IN [G(K+1)-G(K)]/h(k) - [G(K)-G(K-1)]/h(k-1) + IF (k .eq. 1) THEN + work(2) = tenshx(1)*wten0(2) + work(1) = -work(2) + ELSE IF (k .eq. n) THEN + work(n-1) = tenshx(n-1)*wten0(n-1) + ELSE + work(k-1) = tenshx(k-1)*wten0(k-1) + work(k) = -(tenshx(k)+tenshx(k-1))*wten0(k) + work(k+1) = tenshx(k)*wten0(k+1) + ENDIF + IF (nb .eq. natur) work(1) = 0 + work(n) = 0 +! +! COMPUTE work(j) = work(i)*Jacobian(i,j) and add to amat(k,j) +! + CALL jacprod (work, hx, n, nb) + amat(koff,1+ioff:n+ioff) = amat(koff,1+ioff:n+ioff) + work(:n) + END DO + + END SUBROUTINE add_tension diff --git a/Sources/Splines/getspline.f b/Sources/Splines/getspline.f new file mode 100644 index 0000000..bada07f --- /dev/null +++ b/Sources/Splines/getspline.f @@ -0,0 +1,85 @@ + SUBROUTINE getspline(amat, splnots, hk, delse, hs, indexs, isort, + 1 ndata0, nots) + USE vsvd0 + USE vparams, ONLY: zero, epstan + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER ndata0, nots + REAL(rprec) hs + INTEGER, DIMENSION(ndata0) :: indexs, isort + REAL(rprec), DIMENSION(nots,ndata0) :: amat + REAL(rprec), DIMENSION(nots) :: splnots, hk + REAL(rprec), DIMENSION(ndata0) :: delse +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, DIMENSION(nots) :: nk + INTEGER :: i, js, ia, k, k1, ib, j, nb + REAL(rprec), DIMENSION(ndata0) :: w, w1, u, u1, snodes + REAL(rprec), DIMENSION(nots,ndata0) :: bmat +C----------------------------------------------- + +! +! ON EXIT, AMAT = AMAT + BMAT, WHERE BMAT IS THE 2nd +! DERIVATIVE COEFFICIENT MATRIX ARRAY, MULTIPLIED BY JACOBIAN +! AND AMAT (ON RHS) WAS FUNCTION COEFFICIENT MATRIX ARRAY +! + +! +! SORT KNOT POSITIONS IN ASCENDING ORDER IN S-SPACE +! USE SQRT(S) KNOT POSITIONS FOR IMPROVED RESOLUTION +! NOTE: SNODES(I) IS THE VALUE OF SQRT(S) CORRESPONDING TO +! THE MESH VALUES CORRESPONDING TO DELSE, INDEXS (COMPUTED OUTSIDE +! THIS PROGRAM) +! + + DO i = 1, ndata0 + js = indexs(i) + snodes(i) = SQRT(hs*((js - 1) + delse(i))) +! IF (snodes(i) .le. zero) snodes(i) = epstan + END DO + +! Avoid roundoff error in SPLININT + IF( snodes(ndata0) .gt. splnots(nots) ) + 1 snodes(ndata0) = splnots(nots) + + CALL sort_data (snodes, isort, ndata0) + +! +! COMPUTE MATRIX COEFFICIENTS RELATING SPLINE AT SPLNOTS +! TO REAL-SPACE FUNCTION AT SORTED MESH POINTS RMESH +! + amat(:nots,:ndata0) = zero + bmat(:nots,:ndata0) = zero + +! +! SETUP SPLINE PARAMETERS AT EACH TIME STEP, SINCE SNODES +! MAY BE CHANGING DYNAMICALLY IN S-SPACE +! + CALL setup_int(splnots,snodes,hk,w,w1,u,u1,nk,nots,ndata0) + + ia = 1 + DO k = 1, nots - 1 + IF (nk(k) .gt. 0) THEN + k1 = k + 1 + ib = ia + nk(k) - 1 + amat(k,ia:ib) = amat(k,ia:ib) + w(ia:ib) + bmat(k,ia:ib) = bmat(k,ia:ib) + u(ia:ib) + amat(k1,ia:ib) = amat(k1,ia:ib) + w1(ia:ib) + bmat(k1,ia:ib) = bmat(k1,ia:ib) + u1(ia:ib) + ia = ib + 1 + ENDIF + END DO + + IF (ib .ne. ndata0) STOP 'ib!=ndat' + nb = ideriv + + DO j = 1, ndata0 + bmat(nots,j) = 0. + CALL jacprod (bmat(1,j), hk, nots, nb) + amat(:nots,j) = amat(:nots,j) + bmat(:nots,j) + END DO + + END SUBROUTINE getspline diff --git a/Sources/Splines/gety2.f b/Sources/Splines/gety2.f new file mode 100644 index 0000000..7239b35 --- /dev/null +++ b/Sources/Splines/gety2.f @@ -0,0 +1,32 @@ + SUBROUTINE gety2(y, y2, h, nots, nb) + USE vspline + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots, nb + REAL(rprec), DIMENSION(*) :: y, y2, h +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER jmax + REAL(rprec), DIMENSION(nots) :: aspline, bspline, dspline +C----------------------------------------------- + + jspmin(1) = 2 + IF (nb .eq. ideriv) jspmin(1) = 1 + jmax = nots - 1 + aspline(1) = h(1) + dspline(1) = 2.0*h(1) + y2(1) = 0. + y2(nots) = 0. + IF (nb .eq. ideriv) y2(1) = 6.0*(y(2)-y(1))/h(1) + aspline(2:jmax) = h(2:jmax) + bspline(2:jmax) = h(:jmax-1) + dspline(2:jmax) = 2.0*(h(2:jmax)+h(:jmax-1)) + y2(2:jmax) = 6.0*((y(3:jmax+1)-y(2:jmax))/h(2:jmax) + 1 -(y(2:jmax)-y(:jmax-1))/h(:jmax-1)) + + CALL tridslv(aspline,dspline,bspline,y2,jspmin,jmax,0,nots,1) + + END SUBROUTINE gety2 diff --git a/Sources/Splines/initspline.f b/Sources/Splines/initspline.f new file mode 100644 index 0000000..cd1b2c4 --- /dev/null +++ b/Sources/Splines/initspline.f @@ -0,0 +1,30 @@ + SUBROUTINE initspline(amat, splnot, h, weight, nots) + USE vspline + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots + REAL(rprec), DIMENSION(nots,nots) :: amat + REAL(rprec), DIMENSION(*) :: splnot, h, weight +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER i + REAL(rprec) :: eps +C----------------------------------------------- + + IF (nots .lt. 3) STOP 'nots<3' + eps = 1.0/(splnot(nots)-splnot(1)) + + amat = 0. + DO i = 1, nots + amat(i,i) = weight(i) + END DO + + DO i = 1, nots - 1 + h(i) = splnot(i+1) - splnot(i) + IF (eps*h(i) .le. 1.e-8_dp) STOP 'h(i)<1.e-8' + END DO + + END SUBROUTINE initspline diff --git a/Sources/Splines/jacprod.f b/Sources/Splines/jacprod.f new file mode 100644 index 0000000..f13dceb --- /dev/null +++ b/Sources/Splines/jacprod.f @@ -0,0 +1,41 @@ + SUBROUTINE jacprod(c, h, nots, nb) + USE vspline + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots, nb, jmax + REAL(rprec), DIMENSION(*) :: c, h +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + REAL(rprec), DIMENSION(nots) :: + 1 aspline, bspline, dspline, dum1 +C----------------------------------------------- + +! +! THIS ROUTINE COMPUTES THE INNER PRODUCT COUT(I) = CIN(J)*JACOBIAN(J,I) +! WHERE JACOBIAN(J,I) = D[G(J)]/D[F(I)] +! HERE, G(J) ARE SECOND-DERIVATIVE KNOTS, F(I) FUNCTION KNOTS +! +! COMPUTE COEFFICIENT ARRAY ELEMENTS A*X(I+1) + D*X(I) + B*X(I-1) +! (TO BE SAFE, RECOMPUTE EACH TIME, SINCE IOTA, P SPLINES MAY +! DIFFER FROM CALL TO CALL) +! + aspline(1) = h(1) + dspline(1) = 2.0*h(1) + aspline(2:nots-1) = h(2:nots-1) + bspline(2:nots-1) = h(:nots-2) + dspline(2:nots-1) = 2.0*(h(2:nots-1)+h(:nots-2)) + + jspmin(1) = 2 + IF (nb .eq. ideriv) jspmin(1) = 1 + jmax = nots - 1 + CALL tridslv(aspline,dspline,bspline,c,jspmin,jmax,0,nots,1) + dum1(1) = 6.0*(c(2)-c(1))/h(1) + dum1(2:nots) = 6.0*(c(:nots-1)-c(2:nots))/h(:nots-1) + c(2:nots-1) = dum1(2:nots-1) - dum1(3:nots) + c(1) = dum1(1) + c(nots) = dum1(nots) + + END SUBROUTINE jacprod diff --git a/Sources/Splines/set_dual.f b/Sources/Splines/set_dual.f new file mode 100644 index 0000000..1bc08ae --- /dev/null +++ b/Sources/Splines/set_dual.f @@ -0,0 +1,45 @@ + SUBROUTINE set_dual(data1, hi, yi, yi2, hp, yp, yp2, wten, alsq, + 1 niota, npres, nots) + USE vspline + USE vmec_input, ONLY: tensi, tensi2, tensp, fpolyi + USE vparams, ONLY: zero + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: niota, npres, nots, info + REAL(rprec), DIMENSION(nots) :: data1 + REAL(rprec), DIMENSION(niota) :: hi, yi, yi2 + REAL(rprec), DIMENSION(npres) :: hp, yp, yp2 + REAL(rprec), DIMENSION(nots) :: wten + REAL(rprec), DIMENSION(nots,nots) :: alsq +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER nb, ioff +C----------------------------------------------- +! +! ADD TENSION TO DIAGONAL BLOCKS +! + nb = ideriv + ioff = 0 + CALL add_tension (alsq, wten, hi, tensi, tensi2, fpolyi, niota, nb + 1 , ioff, nots) + CALL add_tension (alsq, wten, hp, tensp, zero, zero, npres, nb, + 1 niota, nots) + +! +! FREEZE EDGE PRESSURE IF NO PRESSURE SPECIED +! COMPUTE SOLUTION FOR SPLINES +! + CALL solver (alsq, data1, nots, 1, info) + yi(:niota) = data1(:niota) + yp(:npres) = data1(1+niota:npres+niota) + +! +! COMPUTE SECOND DERIVATIVES +! + CALL gety2 (yi, yi2, hi, niota, nb) + CALL gety2 (yp, yp2, hp, npres, nb) + + END SUBROUTINE set_dual diff --git a/Sources/Splines/setspline.f b/Sources/Splines/setspline.f new file mode 100644 index 0000000..11c131d --- /dev/null +++ b/Sources/Splines/setspline.f @@ -0,0 +1,59 @@ + SUBROUTINE setspline(x,weight,y,h,yfit,y2,wten,tens,nots,nb) + USE vspline + USE vparams, ONLY: zero + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots, nb + REAL(rprec) tens + REAL(rprec), DIMENSION(*) :: x, weight + REAL(rprec), DIMENSION(nots) :: y + REAL(rprec), DIMENSION(*) :: h + REAL(rprec), DIMENSION(nots) :: yfit + REAL(rprec), DIMENSION(*) :: y2, wten +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ioff, info + REAL(rprec) :: alsq(nots,nots) +C----------------------------------------------- +! +! x: independent coordinate array +! y: dependent y(x) array +! yfit: fitted values (under tension) to y array +! h: x(i+1) - x(i) array +! y2: y'' array used for splines +! wten: weight array for tension (changed on EXIT) +! alsq: matrix elements for least squares fit (from s-integrations) +! nots: number of independent coordinates (knots) +! nb: = NATUR, USE natural boundary condition at left knot +! = IDERIV, USE derivative (dy/dx =0) boundary condition at left knot + +! +! IT IS ASSUMED THAT X,Y,WTEN ARE ALL SORTED (ON X(I) < X(I+1)) +! + +! +! INITIALIZE ALSQ TO ZERO, COMPUTE H ELEMENTS +! + CALL initspline (alsq, x, h, weight, nots) + +! +! SET UP SPLINE MATRIX ASPLINE AND NON-DIMENSIONLIZE TENSION +! + ioff = 0 + CALL add_tension (alsq, wten, h, tens, zero, zero, nots, nb, + 1 ioff, nots) + +! +! SOLVE FOR COEFFICIENTS +! + yfit(:nots) = y(:nots) + CALL solver (alsq, yfit, nots, 1, info) +! +! OBTAIN Y'' COEFFICIENTS AND STORE IN Y2 +! + CALL gety2 (yfit, y2, h, nots, nb) + + END SUBROUTINE setspline diff --git a/Sources/Splines/setup_int.f b/Sources/Splines/setup_int.f new file mode 100644 index 0000000..83a833a --- /dev/null +++ b/Sources/Splines/setup_int.f @@ -0,0 +1,66 @@ + SUBROUTINE setup_int(xknots,smesh,hx,w,w1,u,u1,nk,nots,nmesh) + USE stel_kinds + USE vparams, ONLY: epstan + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots, nmesh + INTEGER, DIMENSION(nots) :: nk + REAL(rprec), DIMENSION(nots) :: xknots + REAL(rprec), DIMENSION(nmesh) :: smesh + REAL(rprec), DIMENSION(nots) :: hx + REAL(rprec), DIMENSION(nmesh) :: w, w1, u, u1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ksp1, k, i, k1 + REAL(rprec) :: smesh1, hk6 +C----------------------------------------------- +! +! FOR THE SPLINED FUNCTIONS CORRESPONDING TO XKNOTS (PRESSURE, +! IOTA), THIS ROUTINE COMPUTES THE A AND B MATRIX ELEMENTS +! (STORED IN W,U,W1,U1) WHICH ARE NEEDED TO EVALUATE THE FUNCTIONS +! IN REAL-SPACE IN TERMS OF THEIR (VARIABLE) SPLINE KNOT VALUES. +! THIS 'UNDOES' WHAT SPLINT ROUTINE DOES. LET Y(I) DENOTE THE +! FUNCTION AT THE POINT SMESH(I) SUCH THAT +! +! XKNOTS(K) < SMESH(I) <= XKNOTS(K) +! +! THEN, Y(I) = W(I)*YK + U(I)*GK + W1(I)*YK1 + U1(I)*GK1 +! +! WHERE YK, GK ARE THE SPLINE AND 2ND DERIVATIVES AT KNOT K +! YK1,GK1 ARE THE SAME AT KNOT K+1 +! + ksp1 = nots - 1 + smesh1 = smesh(1) + IF (smesh1 .le. xknots(1)) smesh(1) = xknots(1) + epstan + + nk = 0 + + k = 1 + DO i = 1, nmesh + 140 CONTINUE + k1 = k + 1 +! +! XKNOTS = SQRT(HS*(JS-1)) DEFINED IN STARK,PRESSURE ROUTINE +! (THIS CORRESPONDS TO APPROXIMATELY EQUAL SPACING ALONG MIDPLANE) +! + IF (smesh(i).gt.xknots(k) .and. smesh(i).le.xknots(k1)) THEN + nk(k) = nk(k) + 1 + hk6 = hx(k)*hx(k)/6.0 + w1(i) = (smesh(i)-xknots(k))/hx(k) + IF (w1(i)<(-epstan) .or. w1(i)>1.0+epstan) STOP 'w1(i)' + w(i) = 1.0 - w1(i) + u(i) = hk6*w(i)*(w(i)*w(i)-1.0) + u1(i) = hk6*w1(i)*(w1(i)*w1(i)-1.0) + ELSE + k = k + 1 + IF (k .gt. ksp1) STOP 'K>KSP1' + GOTO 140 + ENDIF + END DO + + smesh(1) = smesh1 + + END SUBROUTINE setup_int diff --git a/Sources/Splines/sort_data.f b/Sources/Splines/sort_data.f new file mode 100644 index 0000000..ac1537e --- /dev/null +++ b/Sources/Splines/sort_data.f @@ -0,0 +1,32 @@ + SUBROUTINE sort_data (x, index_array, n) + USE stel_kinds + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +c----------------------------------------------- + INTEGER n + INTEGER, DIMENSION(n) :: index_array + REAL(rprec), DIMENSION(n) :: x +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: i, j + INTEGER, DIMENSION(1) :: isamax + REAL(rprec), DIMENSION(n) :: dumx +C----------------------------------------------- +! +! RETURNS INDEX(I) ARRAY, SO THAT X(INDEX(I)) IS SORTED, I=1,N +! RETURNS Xin(INDEX(I)) = Xout(I) +! + + DO i = n, 1, -1 + isamax = MAXLOC(ABS(x)) + j = isamax(1) + dumx(i) = x(j) + x(j) = 0. + index_array(i) = j + END DO + + x = dumx + + END SUBROUTINE sort_data diff --git a/Sources/Splines/splinint.f b/Sources/Splines/splinint.f new file mode 100644 index 0000000..0780c8b --- /dev/null +++ b/Sources/Splines/splinint.f @@ -0,0 +1,82 @@ + SUBROUTINE splinint(grn, cm, jacob, h, u, u1, w, w1, nk, nots, + 1 ifunc, nmesh) + USE vparams + USE vspline + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nots, ifunc, nmesh + INTEGER, DIMENSION(*) :: nk + REAL(rprec), DIMENSION(nmesh) :: grn, cm + REAL(rprec), DIMENSION(nots) :: jacob, h + REAL(rprec), DIMENSION(nmesh) :: u, u1, w, w1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: j, k, nb, ia, ib, k1, ksp1, nmesh1 + REAL(rprec), DIMENSION(nmesh) :: func + REAL(rprec), DIMENSION(nots) :: af, bs +C----------------------------------------------- + +! +! COMPUTES af,bs FACTORS IN +! (ifunc=INTFUN) Int[ GRN(X) * F(X) ds ] or +! (ifunc=INTDER) Int[ GRN(X) * {d(CmF)/ds} ds ] +! = af(k)*f(k) + bs(k)*f''(k) +! WHERE f(k),f''(k) ARE SPLINE COEFFICIENTS OF F(X) +! +! NOTE: FOR ifunc = INTDER, the OHS factor in CmF cancels +! THE HS factor in the Integral. +! FOR ifunc = INTFUN, GRN is assumed to be pre-multiplied +! OUTSIDE this routine by HS factor +! ALSO, COMPUTES af(k) + (SUM on i)bs(i)*J(i,k) = jacob(k), +! WHERE J(i,k) = d[g(i)]/d[f(k)], g = f'' +! +! nk(k): Number of smesh-pts in k-th spline interval +! xknots(k) < smesh <= xknots(k+1), k = 1,nots-1 +! +! NOTE: The ifunc=INTDER CASE is done by integrating by parts, +! so that the half-point integration (GRN at half mesh pts) +! becomes a full-point integration in Cm*F. +! + nb = ideriv !Pressure, iota derivatives vanish at origin + ksp1 = nots - 1 + nmesh1 = nmesh - 1 + + IF (ifunc .eq. intder) THEN +! +! Integrate by parts (in s), func(1) and func(nmesh) are 'surface terms' +! + func(1) = -cm(1)*grn(2) + func(2:nmesh1) = cm(2:nmesh1)*(grn(2:nmesh1)-grn(3:nmesh1+1)) + func(nmesh) = cm(nmesh)*grn(nmesh) + ELSE + func = grn + ENDIF + + af(:nots) = zero + bs(:nots) = zero + + ia = 1 + DO k = 1, ksp1 + IF (nk(k) .ne. 0) THEN + k1 = k + 1 + ib = ia + nk(k) - 1 + DO j = ia,ib + af(k) = af(k) + func(j)*w(j) + bs(k) = bs(k) + func(j)*u(j) + af(k1) = af(k1) + func(j)*w1(j) + bs(k1) = bs(k1) + func(j)*u1(j) + ENDDO + ia = ib + 1 + ENDIF + END DO + + IF (ib .ne. nmesh) STOP 'ib!=nmesh' + IF (nb .eq. natur) bs(1) = 0. !Natural boundary conditions + bs(nots) = 0. + CALL jacprod (bs, h, nots, nb) !Returns bs(i)=bs(j)*J(j,i) + jacob(:nots) = af(:nots) + bs(:nots) + + END SUBROUTINE splinint diff --git a/Sources/Splines/splints.f b/Sources/Splines/splints.f new file mode 100644 index 0000000..c49c2f6 --- /dev/null +++ b/Sources/Splines/splints.f @@ -0,0 +1,46 @@ + FUNCTION splints (x) + USE vspline + USE vmec_input, ONLY: isnodes + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec) x +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: c1o6 = 1._dp/6._dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: klo, khi, k + REAL(rprec) :: h, a, a2, b, b2, h2, y26lo, y26hi, yx, splints +C----------------------------------------------- + + klo = 1 + khi = isnodes + + 1 CONTINUE + IF (khi - klo .gt. 1) THEN + k = (khi + klo)/2 + IF (sknots(k) .gt. x) THEN + khi = k + ELSE + klo = k + ENDIF + GOTO 1 + ENDIF + + h = sknots(khi) - sknots(klo) + a = sknots(khi) - x + b = x - sknots(klo) + h2 = h*h + a2 = a*a + b2 = b*b + y26lo = c1o6*y2stark(klo) + y26hi = c1o6*y2stark(khi) + yx = (a*(ystark(klo)+(a2-h2)*y26lo)+b*(ystark(khi)+(b2-h2)*y26hi)) + 1 /h + splints = yx + + END FUNCTION splints diff --git a/Sources/Splines/splintx.f b/Sources/Splines/splintx.f new file mode 100644 index 0000000..2e9671b --- /dev/null +++ b/Sources/Splines/splintx.f @@ -0,0 +1,55 @@ + FUNCTION splintx(x) + USE vparams + USE vsvd0 + USE csplinx + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + REAL(rprec) x +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: c1o6 = 1._dp/6._dp +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: klo, khi, k + REAL(rprec) :: h, a, b, h2, a2, b2, y26lo, y26hi, qmidx0, + 1 splintx +C----------------------------------------------- + + CALL setspline (rmidx, wmidx, qmidx, hmidx, ymidx, y2midx, + 1 tenmidx, tenmidx(1), nptsx, natur) + + klo = 1 + khi = nptsx + + 1 CONTINUE + IF (khi - klo .gt. 1) THEN + k = (khi + klo)/2 + IF (rmidx(k) .gt. x) THEN + khi = k + ELSE + klo = k + ENDIF + GOTO 1 + ENDIF + + h = rmidx(khi) - rmidx(klo) + IF( h.eq.zero )then + splintx = zero + RETURN + END IF + a = rmidx(khi) - x + b = x - rmidx(klo) + h2 = h*h + a2 = a*a + b2 = b*b + y26lo = c1o6*y2midx(klo) + y26hi = c1o6*y2midx(khi) + qmidx0 = (a*(ymidx(klo)+(a2-h2)*y26lo)+b*(ymidx(khi)+ + 1 (b2-h2)*y26hi))/h + splintx = qmidx0 + + END FUNCTION splintx diff --git a/Sources/Splines/vspline.f b/Sources/Splines/vspline.f new file mode 100644 index 0000000..f935013 --- /dev/null +++ b/Sources/Splines/vspline.f @@ -0,0 +1,12 @@ + MODULE vspline + USE vsvd0 + IMPLICIT NONE +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, DIMENSION(1) :: jspmin + INTEGER :: iknots + REAL(rprec), DIMENSION(:), ALLOCATABLE :: hthom, ythom, + 1 y2thom, pknots, hstark, y2stark, ystark, sknots +C----------------------------------------------- + END MODULE vspline diff --git a/Sources/TimeStep/CMakeLists.txt b/Sources/TimeStep/CMakeLists.txt new file mode 100644 index 0000000..d1aaa70 --- /dev/null +++ b/Sources/TimeStep/CMakeLists.txt @@ -0,0 +1,17 @@ +target_sources(vmec + PRIVATE + $ + $ + $ + $ + $ + $ + $ + $ + $ +) + +target_sources(xvmec + PRIVATE + $ +) diff --git a/Sources/TimeStep/eqsolve.f b/Sources/TimeStep/eqsolve.f new file mode 100644 index 0000000..e112065 --- /dev/null +++ b/Sources/TimeStep/eqsolve.f @@ -0,0 +1,236 @@ + SUBROUTINE eqsolve(ier_flag, lscreen) + USE vmec_main + USE vmec_params, ONLY: ntmax, ns4, jac75_flag, norm_term_flag, + & bad_jacobian_flag, more_iter_flag, + & successful_term_flag + USE precon2d, ONLY: ScratchFile, lswap2disk, ictrl_prec2d + USE directaccess, ONLY: DeleteDAFile + USE gmres_mod, ONLY: nfcn + USE realspace + USE xstuff +! Add below JDH 2010-08-03 + USE vmec_history + USE parallel_include_module + USE parallel_vmec_module, ONLY: ZeroLastNType + USE vacmod, ONLY: nuv, nuv3 + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER :: ier_flag + LOGICAL :: lscreen +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(dp), PARAMETER :: p98 = 0.98_dp, p96 = 0.96_dp +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + REAL(dp) :: w1, r00s, w0, wdota, r0dot, teqsolon, teqsoloff + LOGICAL :: liter_flag, lreset_internal +C----------------------------------------------- +! +! INDEX OF LOCAL VARIABLES +! +! iequi counter used to call -EQFOR- at end of run +! ijacob counter for number of times jacobian changes sign +! irst counter monitoring sign of jacobian; resets R, Z, and +! Lambda when jacobian changes sign and decreases time step +! signgs sign of Jacobian : must be =1 (right-handed) or =-1 (left-handed) + +! iterj stores position in main iteration loop (j=1,2) +! itfsq counter for storing FSQ into FSQT for plotting +! ivac counts number of free-boundary iterations +! ndamp number of iterations over which damping is averaged +! meven parity selection label for even poloidal modes of R and Z +! modd parity selection label for odd poloidal modes of R and +! gc stacked array of R, Z, Lambda Spectral force coefficients (see readin for stack order) +! xc stacked array of scaled R, Z, Lambda Fourier coefficients + + CALL second0(teqsolon) + + liter_flag = iter2 .eq. 1 + 1000 CONTINUE + + itfsq = 0 + w1 = zero + r00s = zero + +! +! COMPUTE INITIAL R, Z AND MAGNETIC FLUX PROFILES +! + 20 CONTINUE +! +! RECOMPUTE INITIAL PROFILE, BUT WITH IMPROVED AXIS/OR RESTART +! FROM INITIAL PROFILE, BUT WITH A SMALLER TIME-STEP +! + IF (irst .EQ. 2) THEN + + IF (PARVMEC) THEN + CALL ZeroLastNType(pxc) + CALL profil3d_par(pxc(1), pxc(1+irzloff), lreset_internal, + & .FALSE.) + ELSE + xc = 0 + CALL profil3d(xc(1),xc(1+irzloff),lreset_internal,.FALSE.) + END IF + + irst = 1 + IF (liter_flag) CALL restart_iter(delt0r) + END IF +! IF (liter_flag) CALL restart_iter(delt0r) + liter_flag = .true. + ier_flag = norm_term_flag + +! +! FORCE ITERATION LOOP +! + iter_loop: DO WHILE (liter_flag) +! +! ADVANCE FOURIER AMPLITUDES OF R, Z, AND LAMBDA +! + CALL evolve (delt0r, ier_flag, liter_flag, lscreen) + + IF (ijacob .eq. 0 .and. + & (ier_flag .eq. bad_jacobian_flag .or. + & irst .eq. 4) .and. + & ns .ge.3) THEN + IF (lscreen) THEN + IF (ier_flag .eq. bad_jacobian_flag) THEN + IF (rank.EQ.0) WRITE (*,50) + END IF + IF (rank.EQ.0) WRITE (*,51) + END IF + + 50 FORMAT(' INITIAL JACOBIAN CHANGED SIGN!') + 51 FORMAT(' TRYING TO IMPROVE INITIAL MAGNETIC AXIS GUESS') + + IF (PARVMEC) THEN + CALL guess_axis_par (pr1, pz1, pru0, pzu0, lscreen) + ELSE + CALL guess_axis (r1, z1, ru0, zu0) + ENDIF + + lreset_internal = .true. + ijacob = 1 + irst = 2 + GOTO 20 + ELSE IF (ier_flag .NE. norm_term_flag .AND. + 1 ier_flag .NE. successful_term_flag) THEN + RETURN + END IF + +#ifdef _ANIMEC + w0 = wb + wpar/(gamma-one) +#else + w0 = wb + wp/(gamma - one) +#endif + +! +! ADDITIONAL STOPPING CRITERION (set liter_flag to FALSE) +! + IF (ijacob .eq. 25) THEN + irst = 2 + CALL restart_iter(delt0r) +! delt0r = p98*delt !changed in restart + IF (lscreen) PRINT 120, delt0r + irst = 1 + GOTO 1000 + ELSE IF (ijacob .eq. 50) THEN + irst = 2 + CALL restart_iter(delt0r) +! delt0r = p96*delt + IF (lscreen) PRINT 120, delt0r + irst = 1 + GOTO 1000 + ELSE IF (ijacob .ge. 75) THEN + ier_flag = jac75_flag + liter_flag = .false. + ELSE IF (iter2.ge.niter .and. liter_flag) THEN + ier_flag = more_iter_flag + liter_flag = .false. + END IF + +! Store force residual, wdot for plotting + wdota = ABS(w0 - w1)/w0 + + CALL MPI_Bcast(r00, 1, MPI_REAL8, 0, NS_COMM, MPI_ERR) + + r0dot = ABS(r00 - r00s)/r00 + r00s = r00 + w1 = w0 + IF (ivac .eq. 1) THEN + IF (grank .EQ. 0) THEN + IF (lscreen) PRINT 110, iter2 + WRITE (nthreed, 110) iter2 + END IF + ivac = ivac + 1 + ENDIF + +! NOTE: PRINTOUT clobbers gc! +! Increment time step and printout every nstep iterations + IF (MOD(iter2,nstep) .eq. 0 .or. + & iter2 .eq. 1 .or. + & .not.liter_flag) THEN + CALL printout(iter2, delt0r, w0, lscreen) + END IF + iter2 = iter2 + 1 + iterc = iterc + 1 +! JDH 2012-06-20 ^^^ iterc is a cumulative iteration counter. Used in V3FIT. +! Never reset to 1 + +! JDH 2010-08-03: Call to vmec_history_store moved here from evolve.f +! Stores fsq values and other, for later post-processing + IF (.not.PARVMEC) THEN + CALL vmec_history_store(delt0r) + END IF + CALL flush(6) +! +! STORE FSQ FOR PLOTTING. EVENTUALLY, STORE FOR EACH RADIAL MESH +! + IF (MOD(iter2,niter/nstore_seq + 1) .eq. 0 .and. + & ns .eq. ns_array(multi_ns_grid)) THEN + IF (itfsq .lt. nstore_seq) THEN + itfsq = itfsq + 1 + fsqt(itfsq) = fsqr + fsqz + wdot(itfsq) = MAX(wdota,c1pm13) + END IF + END IF + END DO iter_loop + +!SPH (021711): V3FITA - SAVE STATE FOR RESTART IF PRECONDITIONER IS ON + + IF (l_v3fit) THEN + +!JDH 2011-09-14. Correct logic error. + +! IF (ictrl_prec2d .eq. 0) THEN +! lqmr = (itype_precon .ge. 2) +! ELSE + IF (ictrl_prec2d .gt. 0) THEN + CALL restart_iter(delt0r) + END IF + END IF + + IF (lSwap2Disk) CALL DeleteDAFile(ScratchFile) + + IF (grank .EQ. 0) THEN + WRITE (nthreed, 60) w0*twopi**2, wdota, r0dot + IF (lrecon) WRITE (nthreed, 70) r00*fsqsum0/wb + IF (nfcn .GT. 0) WRITE (nthreed, 80) nfcn + END IF + + CALL second0(teqsoloff) + eqsolve_time = eqsolve_time + (teqsoloff-teqsolon) + + 60 FORMAT(/,' MHD Energy = ',1p,e12.6,3x, 'd(ln W)/dt = ',1p,e9.3, + & 3x,'d(ln R0)/dt = ',e9.3) + 70 FORMAT(' Average radial force balance: Int[FR(m=0)]', + & '/Int(B**2/R) = ',1p,e12.5,' (should tend to zero)'/) + 80 FORMAT(' Function calls in GMRES: ',i5) + 110 FORMAT(/,2x,'VACUUM PRESSURE TURNED ON AT ',i4,' ITERATIONS'/) + 120 FORMAT(2x,'HAVING A CONVERGENCE PROBLEM: RESETTING DELT TO ',f8.3, + & /,2x,'If this does NOT resolve the problem, try changing ', + & '(decrease OR increase) the value of DELT') + + END SUBROUTINE eqsolve diff --git a/Sources/TimeStep/evolve.f b/Sources/TimeStep/evolve.f new file mode 100644 index 0000000..c20e318 --- /dev/null +++ b/Sources/TimeStep/evolve.f @@ -0,0 +1,283 @@ + SUBROUTINE evolve(time_step, ier_flag, liter_flag, lscreen) + USE vmec_main + USE vmec_params, ONLY: bad_jacobian_flag, successful_term_flag, + & norm_term_flag + USE xstuff + USE precon2d, ONLY: ictrl_prec2d, l_comp_prec2D, + & compute_blocks_par, compute_blocks + USE parallel_include_module + USE parallel_vmec_module, ONLY: ZeroLastNType, CopyLastNtype, + & SaxpbyLastNtype, CompareEdgeValues + USE timer_sub + USE vmec_params, ONLY: ntmax + USE gmres_mod +! Comment Out below JDH 2010-08-03 +! USE vmec_history + IMPLICIT NONE +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp) :: time_step !, r0dot + INTEGER, INTENT(INOUT) :: ier_flag + LOGICAL, INTENT(INOUT) :: liter_flag + LOGICAL, INTENT(IN) :: lscreen +!-----------------------------------------------`` +! L o c a l V a r i a b l e s +!----------------------------------------------- + CHARACTER(LEN=*), PARAMETER :: fcn_message = + & 'External calls to FUNCT3D: ' +! REAL(dp), PARAMETER :: r0dot_threshold = 5.E-06_dp + REAL(dp) :: fsq1, dtau, b1, bprec, fac + LOGICAL :: lfinal_mesh + INTEGER :: lcount + INTEGER, SAVE :: iter_on + REAL(dp) :: f3dt1, f3dt2, tevon, tevoff + +C----------------------------------------------- +! IF TROUBLE CONVERGING, TRY TO RECOMPUTE PRECONDITIONER ONCE MORE... +! IF (ictrl_prec2d.eq.1 .and. iter2.eq.(iter_on+40)) +! 1 ictrl_prec2d = 0 + +! JDH 2011-09-15 Add condition to lfinal_mesh, that iter2 - iter1 > 5 +! (5 was picked out of a hat) +! Purpose is to keep preconditioning from being turned on immediately upon +! a restart (V3FIT) +! The final .and. clause is a bit complicated. The purpose of the +! .not. lv3fit is so that if v3fita is not running, the final .and. clause +! is always true. Read as "and, if lv3fit, then must also have iter2 - iter1 > 5" +! lfinal_mesh = (ns .eq. ns_maxval) .and. (ictrl_prec2d.eq.0) +! 1 .and. (itype_precon.ne.0) + + CALL second0(tevon) + + + lfinal_mesh = ns .EQ. ns_maxval .and. + & ictrl_prec2d .EQ. 0 .and. + & itype_precon .ne. 0 .and. + & (.not.l_v3fit .or. iter2 - iter1 .ge. 5) + + IF (iter2 .lt. 10) THEN + ictrl_prec2d = 0 + lqmr = .false. + iter_on = -1 + ELSE IF (lfinal_mesh .and. + & fsqr + fsqz + fsql .lt. prec2d_threshold) THEN + lqmr = (itype_precon .GE. 2) + lfirst = (lqmr .AND. iter_on.EQ.-1) + +! +! INITIATES 2D PRECONDITIONER CALCULATION +! + IF (iter_on .EQ. -1) THEN + IF (lqmr) THEN + nstep = 5 + niter = iter2+100 !Limit # preconditioner steps + ELSE + nstep = 20 + niter = iter2+400 + END IF + iter_on = iter2 !Flag to monitor progress of preconditioner + ELSE + iter_on = iter2-11 + END IF + +!SPH022111: ADD NEW CONTROL PARAMETER, l_comp_prec2D, TO FORCE RECALCULATION +! OF PRECONDITIONING BLOCKS IN V3FIT, FOR EXAMPLE + IF (lfirst .OR. l_comp_prec2D) THEN + IF (l_v3fit) WRITE(*,*) 'VMEC Evolve:compute_blocks' + IF (PARVMEC) THEN + CALL compute_blocks_par (pxc,pxcdot,pgc) + ELSE + CALL compute_blocks (xc,xcdot,gc) + END IF + END IF + IF(l_v3fit) WRITE(*,*) 'VMEC Evolve:prec2d_On iter2 =', iter2 + l_comp_prec2D = .FALSE. + ictrl_prec2d = 1 + time_step = 0.50_dp + iter1 = iter2-1; fsq = fsqr1 + fsqz1 + fsql1 + + IF (PARVMEC) THEN + CALL CopyLastNtype(pxstore, pxc) + CALL ZeroLastNType(pxcdot) + ELSE + xc = xstore + xcdot = 0 + END IF + END IF + +! +! COMPUTE MHD FORCES +! MUST CALL funct3d EVEN WHEN IN 2D PRECONDITIONING MODE, SINCE +! INITIAL RESIDUALS MUST BE KNOWN WHEN CALLING gmres_fun, etc. +! + CALL second0(f3dt1) + f3d_num(NS_RESLTN) = f3d_num(NS_RESLTN)+1 + IF (PARVMEC) THEN + CALL funct3d_par(lscreen, ier_flag) + ELSE + CALL funct3d(lscreen, ier_flag) + END IF + CALL second0(f3dt2) + f3d_time(NS_RESLTN) = f3d_time(NS_RESLTN) + (f3dt2 - f3dt1) + funct3d_time = funct3d_time + (f3dt2 - f3dt1) + +! +! COMPUTE ABSOLUTE STOPPING CRITERION + IF (iter2.EQ.1 .and. irst.EQ.2) THEN + ier_flag = bad_jacobian_flag + RETURN +! JDH 2012-04-24. Revise this absolute stopping criterion, so that if v3fit +! is running, then have to iterate at least 2 * nvacskip steps +! (2 picked out of a hat) (nvacskip - to make sure vacuum gets updated) +! before returning. + + ELSE IF (fsqr .le. ftolv .and. + & fsqz .le. ftolv .and. + & fsql .le. ftolv) THEN + liter_flag = .false. + ier_flag = successful_term_flag + RETURN + ENDIF + + +!SPH:042117: MOVE TIME STEP CONTROL HERE (FROM END OF EQSOLVE) TO AVOID +!STORING A POSSIBLE irst=2 STATE + CALL TimeStepControl(ier_flag, PARVMEC) + + IF (lqmr) THEN + IF (PARVMEC) THEN + CALL gmres_fun_par(ier_flag, itype_precon - 1, lscreen) + IF (.NOT.lfreeb) CALL CompareEdgeValues(pxc, pxsave) + ELSE + CALL gmres_fun(ier_flag, itype_precon-1) + IF (.NOT.lfreeb) THEN + DO lcount = ns, 2*irzloff, ns + IF (xsave(lcount) .NE. xc(lcount)) THEN + PRINT *, ' xsave = ',xsave(lcount),' != xc = ', + & xc(lcount),' for lcount = ',lcount + END IF + END DO + END IF + END IF + + RETURN + END IF + +! COMPUTE DAMPING PARAMETER (DTAU) AND EVOLVE +! R, Z, AND LAMBDA ARRAYS IN FOURIER SPACE + + fsq1 = fsqr1 + fsqz1 + fsql1 + + IF (iter2 .EQ. iter1) otau(:ndamp) = cp15/time_step + + IF (ictrl_prec2d .EQ. 0) THEN + bprec = 1 + ELSE + bprec = 6 + END IF + + dtau = bprec*cp15 + IF (iter2 .GT. iter1 .AND. + & fsq1*fsq .NE. zero) THEN + dtau = MIN(ABS(LOG(fsq1/fsq)), dtau) + END IF + + fsq = fsq1 + + otau(1:ndamp-1) = otau(2:ndamp) + + IF (iter2 .GT. iter1) otau(ndamp) = dtau/time_step +!REMOVED 071505: OTHERWISE I=1 STATE REPEATED (SKIP THIS TO GET OUT OF ITER2=1 STATE) +! IF (iter2 .le. 1) RETURN + + otav = SUM(otau(:ndamp))/ndamp + dtau = time_step*otav/2 + + b1 = one - dtau + fac = one/(one + dtau) + +! +! THIS IS THE TIME-STEP ALGORITHM. IT IS ESSENTIALLY A CONJUGATE +! GRADIENT METHOD, WITHOUT THE LINE SEARCHES (FLETCHER-REEVES), +! BASED ON A METHOD GIVEN BY P. GARABEDIAN + +! + + IF (PARVMEC) THEN + IF (lactive) THEN + CALL SaxpbyLastNtype(fac*time_step, pgc, fac*b1, pxcdot, + & pxcdot) + CALL SaxpbyLastNtype(time_step, pxcdot, one, pxc, pxc) + END IF + ELSE + xcdot = fac*(b1*xcdot + time_step*gc) + xc = xc + time_step*xcdot + END IF + + CALL second0(tevoff) + evolve_time = evolve_time + (tevoff - tevon) + + END SUBROUTINE evolve + + + SUBROUTINE TimeStepControl(ier_flag, PARVMEC) + USE vmec_main, ONLY: res0, res1, fsq, fsqr, fsqz, fsql, + & irst, iter1, iter2, delt0r, dp + USE vmec_params, ONLY: ns4 + USE vparams, ONLY: c1pm2 + USE vmec_input, ONLY: nstep + USE precon2d, ONLY: ictrl_prec2d + USE parallel_include_module, ONLY: rank + USE realspace + IMPLICIT NONE +! +! STORES OR RETRIEVES XC STATE BASED ON IRST VALUE +! + REAL(dp), PARAMETER :: fact = 1.E4_dp + REAL(dp) :: fsq0 + INTEGER :: ier_flag + LOGICAL, INTENT(IN) :: PARVMEC + + fsq0 = fsqr+fsqz+fsql + IF (iter2.EQ.iter1 .OR. res0.EQ.-1) THEN + res0 = fsq + res1 = fsq0 + CALL restart_iter(delt0r) + END IF + + res0 = MIN(res0,fsq) + res1 = MIN(res1,fsq0) + + +! Store current state (irst=1) + IF (fsq.LE.res0 .AND. fsq0.LE.res1 .AND. irst.EQ.1) THEN + CALL restart_iter(delt0r) + + ELSE IF (ictrl_prec2d .NE. 0) THEN + CALL restart_iter(delt0r) + RETURN + + ELSE IF ((iter2-iter1) .GT. 10) THEN + +! Residuals are growing in time, reduce time step + IF (fsq.GT.fact*res0 .OR. fsq0.GT.fact*res1) THEN + irst = 3 + END IF + END IF + +! Retrieve previous good state + IF (irst .NE. 1) THEN + CALL restart_iter(delt0r) + iter1 = iter2 + IF (PARVMEC) THEN + CALL funct3d_par(.FALSE., ier_flag) + ELSE + CALL funct3d(.FALSE., ier_flag) + END IF + IF (irst .NE. 1 .and. irst .NE. 4) THEN + STOP 'Logic error in TimeStepControl!' + END IF + END IF + + END SUBROUTINE TimeStepControl diff --git a/Sources/TimeStep/gmres_mod.f b/Sources/TimeStep/gmres_mod.f new file mode 100644 index 0000000..555cce7 --- /dev/null +++ b/Sources/TimeStep/gmres_mod.f @@ -0,0 +1,719 @@ + MODULE gmres_mod + USE vmec_main, ONLY: dp, rprec, neqs, ns, nthreed, + 1 one, fsqr, fsqz, fsql + USE parallel_include_module + USE parallel_vmec_module, ONLY: CopyLastNtype, SaxpbyLastNtype, + 1 SaxpbyLastNs, Saxpby1LastNs, + 2 GetDerivLastNs, SaxLastNtype + USE precon2d, ONLY: ictrl_prec2d + IMPLICIT NONE + INTEGER :: nfcn = 0, lqmrstep = 0 + INTEGER :: ier_flag_res + LOGICAL :: lqmr, lfirst + LOGICAL, PARAMETER :: lscreen0 = .FALSE. + +! +! nfcn : number of calls to function (funct3d) +! lqmr : logical, used by external programs to control calling these routines +! + CONTAINS + + SUBROUTINE matvec_par (ploc, Ap, nloc) + USE blocktridiagonalsolver, ONLY: ParMatVec + USE stel_kinds + USE xstuff, ONLY: pxc, px0=>pxsave, pgc0=>pxcdot, pgc +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(IN) :: nloc + REAL(dp), INTENT(IN) :: + & ploc(ntmaxblocksize,tlglob:trglob) + REAL(dp), INTENT(OUT) :: + & Ap(ntmaxblocksize,tlglob:trglob) +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: mblk_size, istat + REAL(dp) :: delta, lmax, gmax, pmax, apmax +C----------------------------------------------- + mblk_size = neqs/ns +! +! Computes linearized matrix product A*p = [F(x0+delta*p) - F(x0)]/delta, about point x0 +! Must scale p so delta*max|p| ~ sqrt(epsilon) to get accurate numerical derivative +! Because the block preconditioner is applied in funct3d, the net result +! should be Ap ~ -p. + + delta = SQRT(EPSILON(delta)) + + LACTIVE0: IF (lactive) THEN + IF (nloc .NE. (trglob - tlglob + 1)*mblk_size) THEN + STOP 'nloc wrong in matvec_par' + END IF + lmax = SUM(ploc*ploc) + CALL MPI_ALLREDUCE(lmax, pmax, 1, MPI_REAL8, MPI_SUM, NS_COMM, + & MPI_ERR) + pmax = SQRT(pmax) + delta = delta/MAX(delta, pmax) + + CALL SaxpbyLastNs(delta, ploc, one, px0, pxc) + + CALL last_ntype_par + CALL PadSides(pxc) + END IF LACTIVE0 + + CALL funct3d_par(lscreen0, ier_flag_res) + + IF (lactive) THEN + CALL last_ns_par + CALL GetDerivLastNs(pgc, pgc0, delta, Ap) + ENDIF + + IF (ier_flag_res.NE.0 .AND. rank.EQ.0) THEN + PRINT *,'IN MATVEC_PAR, IER_FLAG = ', ier_flag_res + END IF + + 90 CONTINUE + nfcn = nfcn + 1 + + END SUBROUTINE matvec_par + + SUBROUTINE GetNLForce_par(xcstate, fsq_nl, bnorm) + USE xstuff, ONLY: pxc, pgc, x0=>pxsave +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp), INTENT(IN) :: xcstate(neqs), bnorm + REAL(dp), INTENT(OUT) :: fsq_nl +!----------------------------------------------- +!undo internal gmres normalization + + LACTIVE0: IF (lactive) THEN + CALL Saxpby1LastNs(bnorm, xcstate, one, x0, pxc) + CALL last_ntype_par + CALL PadSides(pxc) + END IF LACTIVE0 + + CALL funct3d_par(lscreen0, ier_flag_res) + IF (lactive) CALL last_ns_par + + fsq_nl = fsqr + fsqz + fsql + nfcn = nfcn + 1 + + END SUBROUTINE GetNLForce_par + !------------------------------------------------ + ! + !------------------------------------------------ + SUBROUTINE last_ns_par + USE xstuff + + REAL(dp), ALLOCATABLE, DIMENSION(:) :: tmp + ALLOCATE (tmp(ntmaxblocksize*ns)) + + CALL tolastns(pgc,tmp) + CALL copylastns(tmp,pgc) + + CALL tolastns(pxcdot,tmp) + CALL copylastns(tmp,pxcdot) + + CALL tolastns(pxc,tmp) + CALL copylastns(tmp,pxc) + + CALL tolastns(pxsave,tmp) + CALL copylastns(tmp,pxsave) + + DEALLOCATE(tmp) + + END SUBROUTINE last_ns_par + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE last_ntype_par + USE xstuff + + REAL(dp), ALLOCATABLE, DIMENSION(:) :: tmp + ALLOCATE (tmp(ntmaxblocksize*ns)) + + CALL tolastntype(pgc,tmp) + CALL copylastntype(tmp,pgc) + + CALL tolastntype(pxcdot,tmp) + CALL copylastntype(tmp,pxcdot) + + CALL tolastntype(pxc,tmp) + CALL copylastntype(tmp,pxc) + + CALL tolastntype(pxsave,tmp) + CALL copylastntype(tmp,pxsave) + + DEALLOCATE(tmp) + END SUBROUTINE last_ntype_par + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE gmres_fun_par (ier_flag, itype, lscreen) + USE precon2d, ONLY: ictrl_prec2d, block_precond_par + USE xstuff + USE vmec_main, ONLY: fsqr, fsqz, fsql, ftolv + USE gmres_lib, ONLY: gmres_par, gmres_info +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(IN) :: itype + INTEGER, INTENT(OUT) :: ier_flag + LOGICAL, INTENT(IN) :: lscreen +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + TYPE (gmres_info) :: gi + INTEGER :: n, m, l + INTEGER :: icntl(9), info(3) + REAL(dp) :: cntl(5), fact, fact_min, fsq_min, fsq2, + & fsqr_min, fsqz_min, fsql_min + CHARACTER(LEN=*), PARAMETER :: qmr_message = + & 'Beginning GMRES iterations' + INTEGER, PARAMETER :: noPrec=0, leftPrec=1, rightPrec=2 +!----------------------------------------------- + LGMRESCALL = .TRUE. + n = neqs +! +! CHOOSE TYPE OF SOLVER +! + IF (itype == 2) THEN + CALL gmresr_fun (ier_flag) + RETURN + ELSE IF (itype == 3) THEN + CALL qmr_fun + RETURN + END IF + + + IF (lfirst) THEN + lfirst = .FALSE. + IF (grank.EQ.0) THEN + WRITE (*,'(2x,a,/)') qmr_message + WRITE (nthreed, '(2x,a,/)') qmr_message + END IF + END IF + +!****************************************************** +!* Initialize the control parameters to default value +!****************************************************** + + CALL init_dgmres(icntl,cntl) + +!************************ +! Tune some parameters +!************************ + +! Tolerance + cntl(1) = 1.e-3_dp +! cntl(1) = 1.e-4_dp +! Write errors to fort.21 +! icntl(1) = 21 !21 +! Write warnings to fort.21 + icntl(2) = 0 !21 +! Save the convergence history in file fort.20 + icntl(3) = 20 +! No preconditioning + icntl(4) = noPrec +! Left preconditioning (doesn't work well with no col-scaling) +! icntl(4) = leftPrec +! ICGS orthogonalization + icntl(5) = 3 +! icntl(5) = 0 +! Initial guess + icntl(6) = 0 +! icntl(6) = 1 +! Maximum number of iterations at each step (~ns/5) +! icntl(7) = 15 + icntl(7) = 20 +! Stops to peek at progress during rev com loop + icntl(9) = 1 + + +!******************************** +!* Choose the restart parameter +!******************************** +! write(*,*) 'Restart <', ldstrt +! read(*,*) m +! +! m <= n +! + m = 20 +! +! Load gmres_info structure +! + info = 0 + gi%m=m; gi%icntl=icntl; gi%cntl=cntl; gi%info = info + gi%ftol = ftolv + + + ALLOCATE(gi%rcounts(nranks),gi%disp(nranks)) + gi%startglobrow=tlglob + gi%endglobrow=trglob + gi%iam=rank + gi%nprocs=nranks + gi%rcounts=ntblkrcounts + gi%disp=ntblkdisp + gi%mblk_size=ntmaxblocksize + + gi%my_comm = NS_COMM + gi%my_comm_world = RUNVMEC_COMM_WORLD + gi%lactive = lactive + + gi%lverbose = lscreen + + l = ictrl_prec2d + IF (icntl(4) .NE. noPrec) ictrl_prec2d = -1 + CALL funct3d_par(lscreen0, ier_flag_res) + ictrl_prec2d = l + nfcn = nfcn+1 + +!STORE INITIAL POINT AND INITIAL FORCE (AT INIT PT) +!SO DEVIATIONS FROM THEM CAN BE COMPUTED REPEATEDLY + CALL CopyLastNtype(pxc, pxsave) + CALL CopyLastNtype(pgc, pxcdot) + +!RHS: RETURN RESULT OF SOLVING LINEARIZED A*x = -gc IN XCDOT +! AND IS DISTRIBUTED OVER ALL PROCESSORS + CALL CopyLastNtype(pgc, pgc, -one) + + CALL last_ns_par + + CALL gmres_par(n, gi, matvec_par, block_precond_par, + & getnlforce_par, pxcdot, pgc) + + CALL last_ntype_par + +! ier_flag = gi%info(1) +! ictrl_prec2d = 1 + ier_flag = 0 + fact = 1; fact_min = fact + fsq_min = gi%ftol + fsqr_min = fsqr; fsqz_min = fsqz; fsql_min = fsql + +! SIMPLE LINESEARCH SCALING SCAN + + 1010 FORMAT(1x,'LINE SEARCH - SCAN ||X|| FOR MIN FSQ_NL',/, + & '-------------',/, + & 1x,'ITER',7x,'FSQ_NL',10x,'||X||',9x,'MAX|X|') + + CALL MPI_BCAST(fsq_min, 1, MPI_REAL8, 0, RUNVMEC_COMM_WORLD, + & MPI_ERR) + + DO m = 1, 5 + fact = fact*SQRT(0.5_dp) + CALL SaxpbyLastNtype(fact, pxcdot, one, pxsave, pxc) + + CALL funct3d_par(lscreen0, ier_flag_res) + + fsq2 = fsqr+fsqz+fsql + + IF (fsq2 .LT. fsq_min) THEN + fsq_min = fsq2 + fact_min = fact + fsqr_min = fsqr; fsqz_min = fsqz; fsql_min = fsql + IF (grank .EQ. 0) PRINT 1020, fact, fsq2 + ELSE + EXIT + END IF + END DO + + 1020 FORMAT(2x,'GMRES_FUN, TIME_STEP: ',1p,e10.3, ' FSQ_MIN: ',1pe10.3) + + fsqr = fsqr_min; fsqz = fsqz_min; fsql = fsql_min + IF (ictrl_prec2d .EQ. 1) THEN + CALL SaxLastNtype(pxcdot,pcol_scale,pxcdot) + END IF + + CALL SaxpbyLastNtype(fact_min, pxcdot, one, pxsave, pxc) + CALL COPYLASTNTYPE(pxc, pxsave) + + DEALLOCATE(gi%rcounts,gi%disp) + LGMRESCALL=.FALSE. + + END SUBROUTINE gmres_fun_par + + SUBROUTINE GetNLForce(xcstate, fsq_nl, bnorm) + USE xstuff, ONLY: xc, gc, x0=>xsave +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + REAL(dp),INTENT(IN) :: xcstate(neqs), bnorm + REAL(dp),INTENT(OUT) :: fsq_nl +!----------------------------------------------- +!undo internal gmres normalization + xc(1:neqs) = x0(1:neqs) + bnorm*xcstate(1:neqs) + + CALL funct3d(lscreen0, ier_flag_res) + fsq_nl = fsqr+fsqz+fsql + + nfcn = nfcn + 1 + + END SUBROUTINE GetNLForce + + SUBROUTINE matvec (p, Ap, ndim) + USE xstuff, ONLY: xc, x0=>xsave, gc0=>xcdot, gc +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(in) :: ndim + REAL(dp), INTENT(in), DIMENSION(ndim) :: p + REAL(dp), INTENT(out), DIMENSION(ndim) :: Ap +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: l + REAL(dp) :: delta, pmax +C----------------------------------------------- +! +! Computes linearized matrix product A*p = [F(x0+delta*p) - F(x0)]/delta, about point x0 +! Must scale p so delta*max|p| ~ sqrt(epsilon) to get accurate numerical derivative +! +! Ap = -p +! GOTO 90 + + delta = SQRT(EPSILON(delta)) + pmax = SQRT(SUM(p(1:ndim)**2)) + delta = delta/MAX(delta, pmax) + + xc(1:ndim) = x0(1:ndim) + delta*p(1:ndim) + CALL funct3d(lscreen0, ier_flag_res) + Ap = (gc(1:ndim) - gc0(1:ndim))/delta + + IF (ier_flag_res .NE. 0) THEN + PRINT *,'IN MATVEC, IER_FLAG = ', ier_flag_res + END IF + + 90 CONTINUE + nfcn = nfcn + 1 + + END SUBROUTINE matvec + + SUBROUTINE gmres_fun (ier_flag, itype) + USE precon2d, ONLY: block_precond + USE xstuff + USE vmec_main, ONLY: fsqr, fsqz, fsql, ftolv + USE gmres_lib, ONLY: gmres_ser, gmres_info +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(IN) :: itype + INTEGER, INTENT(OUT) :: ier_flag +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + TYPE (gmres_info) :: gi + INTEGER :: n, m, l + INTEGER :: icntl(9), info(3) + REAL(dp) :: cntl(5), fact, fact_min, fsq_min, fsq2, + & fsqr_min, fsqz_min, fsql_min + CHARACTER(LEN=*), PARAMETER :: qmr_message = + & 'Beginning GMRES iterations' + INTEGER, PARAMETER :: noPrec=0, leftPrec=1, rightPrec=2 +!----------------------------------------------- + n = neqs + +! +! CHOOSE TYPE OF SOLVER +! + IF (itype == 2) THEN + CALL gmresr_fun (ier_flag) + RETURN + ELSE IF (itype == 3) THEN + CALL qmr_fun + RETURN + END IF + + + IF (lfirst) THEN + lfirst = .FALSE. + WRITE (*,'(2x,a,/)') qmr_message + WRITE (nthreed, '(2x,a,/)') qmr_message + END IF + +!****************************************************** +!* Initialize the control parameters to default value +!****************************************************** + + CALL init_dgmres(icntl,cntl) + +!************************ +! Tune some parameters +!************************ + +! Tolerance + cntl(1) = 1.e-3_dp +! cntl(1) = 1.e-4_dp +! Write errors to fort.21 +! icntl(1) = 21 !21 +! Write warnings to fort.21 + icntl(2) = 0 !21 +! Save the convergence history in file fort.20 + icntl(3) = 20 +! No preconditioning + icntl(4) = noPrec +! Left preconditioning (doesn't work well with no col-scaling) +! icntl(4) = leftPrec +! ICGS orthogonalization + icntl(5) = 3 +! icntl(5) = 0 +! Initial guess + icntl(6) = 0 +! icntl(6) = 1 +! Maximum number of iterations at each step (~ns/5) +! icntl(7) = 15 + icntl(7) = 20 +! Stops to peek at progress during rev com loop + icntl(9) = 1 + + +!******************************** +!* Choose the restart parameter +!******************************** +! write(*,*) 'Restart <', ldstrt +! read(*,*) m +! +! m <= n +! + m = 20 +! +! Load gmres_info structure +! + info = 0 + gi%m=m; gi%icntl=icntl; gi%cntl=cntl; gi%info = info + gi%ftol = ftolv + +!Store initial gc + l = ictrl_prec2d + IF (icntl(4) .NE. noPrec) ictrl_prec2d = -1 + CALL funct3d(lscreen0, ier_flag_res) + ictrl_prec2d = l + nfcn = nfcn+1 + +! +!STORE INITIAL POINT AND INITIAL FORCE (AT INIT PT) +!SO DEVIATIONS FROM THEM CAN BE COMPUTED REPEATEDLY + xcdot = gc + xsave = xc + +!RHS: RETURN RESULT OF A*X = -gc IN XCDOT + gc = -gc + + CALL gmres_ser(n, gi, matvec, block_precond, getnlforce, + & xcdot, gc) + +100 CONTINUE + +! ier_flag = gi%info(1) +! ictrl_prec2d = 1 + ier_flag = 0 + fact = 1 + fact_min = fact + fsq_min = HUGE(fsq_min) + +! SIMPLE LINESEARCH SCALING SCAN + DO m = 1, 5 + + xc(1:n) = xsave(1:n) + fact*xcdot(1:n) + + CALL funct3d(lscreen0, ier_flag_res) + + fsq2 = fsqr+fsqz+fsql + + IF (fsq2 .LT. fsq_min) THEN + fsq_min = fsq2 + fact_min = fact + fsqr_min = fsqr; fsqz_min = fsqz; fsql_min = fsql + ELSE + EXIT + END IF + fact = fact/2._dp + + END DO + +! PRINT 1010, fact_min, fsq_min +! 1010 FORMAT(2x,'GMRES_FUN, TIME_STEP: ',1p,e10.3, ' FSQ_MIN: ',1pe10.3) + + xc(1:n) = xsave(1:n) + fact_min*xcdot(1:n) + fsqr = fsqr_min; fsqz = fsqz_min; fsql = fsql_min + xsave = xc + + END SUBROUTINE gmres_fun + + SUBROUTINE gmresr_fun (ier_flag) + USE xstuff +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER :: ier_flag +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ndim, jtrunc, mgmres, maxits, lwork + LOGICAL :: oktest + REAL(dp) :: eps, resid + REAL(dp), ALLOCATABLE, DIMENSION(:) :: work, delx, brhs + CHARACTER(len=3), PARAMETER :: stc="rel" + CHARACTER(LEN=*), PARAMETER :: qmr_message = + & 'Beginning GMRESR iterations' +C----------------------------------------------- + IF (lfirst) THEN + lfirst = .false. + WRITE (*,'(2x,a,/)') qmr_message + WRITE (nthreed, '(2x,a,/)') qmr_message + END IF + + oktest = .false. + ndim = neqs + jtrunc = 10 + mgmres = 20 + maxits = 10 + lwork = ndim*(2*jtrunc + mgmres + 2) + eps = .3_dp + + ALLOCATE(work(lwork), delx(ndim), brhs(ndim), stat=ier_flag_res) + IF (ier_flag_res .ne. 0) STOP 'Allocation failed in gmresr' + + brhs = -gc(1:ndim) + delx = 0 + + CALL gmresr(oktest, ndim, jtrunc, mgmres, brhs, delx, work, + & eps, stc, maxits, resid, matvec, ier_flag_res) + + xc(1:ndim) = xsave(1:ndim) + delx(1:ndim) + + DEALLOCATE (work, delx, brhs) + + ier_flag = 0 + + END SUBROUTINE gmresr_fun + + SUBROUTINE qmr_fun + USE vmec_dim, ONLY: ns, mpol1, ntor1 + USE vmec_params, ONLY: ntmax + USE vmec_main, ONLY: lfreeb + USE xstuff +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ndim, nlen, nlim, ierr, info(4) + INTEGER :: revcom, colx, colb + INTEGER :: nty, ntyp, mt, mp, nt, np, jp, js + REAL(dp), DIMENSION(neqs,9) :: vecs + REAL(dp) :: tol = 1.E-3_dp + CHARACTER(LEN=*), PARAMETER :: qmr_message = + 1 'Beginning TF-QMR iterations' + LOGICAL, PARAMETER :: ldump_fort33 = .false. +C----------------------------------------------- + ndim = SIZE(vecs,1) + nlen = ndim + nlim = 10 + xcdot = gc + xsave = xc + + IF (lfirst) THEN + lfirst = .false. + WRITE (*,'(2x,a,/)') qmr_message + WRITE (nthreed, '(2x,a,/)') qmr_message + IF (ldump_fort33) THEN + +! CHECK THAT INITIALLY, PRECONDITIONER YIELDS (APPROXIMATE) IDENTITY MATRIX +! OUTER LOOP: SUM OF XC PERTURBATION +! INNER LOOP: GETS ALLL THE FORCES IN RESPONSE TO EACH OUTER LOOP PERTURBATION + ierr = 0 + DO nty = 1, 3*ntmax + WRITE(33, '(a,i4)') "NTYPE' (XC-pert) = ",nty + DO mt = 0, mpol1 + WRITE(33, '(a,i4)') "M' = ",mt + DO nt = 0, ntor1-1 + WRITE(33, '(a,i4)') "N' = ",nt + DO js = 1, ns + ierr = ierr+1 + IF (ierr .gt. ndim) EXIT + IF (MOD(ierr,50).eq.0) PRINT '(2x,a,f8.2,a)', 'Progress: ', + 1 REAL(100*ierr)/ndim, ' %' + IF (js.eq.ns .and. .not.lfreeb) CYCLE + colx = 1; colb = 3 + vecs(:,colx) = 0; vecs(ierr,colx) = 1 + CALL matvec(vecs(1,colx), vecs(1,colb), ndim) + WRITE (33, '(a,i4,2x,a,i5,2x,a,1p,e12.2)') "js' = ", js, + 1 ' ipert = ',ierr,' Ap[ipert,ipert] = ', vecs(ierr, colb) + colx = 0 + DO ntyp = 1, 3*ntmax + DO mp = 0, mpol1 + DO np = 0, ntor1-1 + DO jp = 1, ns + colx = colx + 1 + IF (colx .gt. ndim) CYCLE + IF (colx.eq.ierr .or. + 1 ABS(vecs(colx,colb)).lt.0.05_dp) CYCLE + WRITE (33, 123)'ntype = ', ntyp,' m = ',mp, + 1 ' n = ', np,' js = ', jp,' iforce = ',colx, + 2 ' Ap[iforce,ipert] = ', vecs(colx,colb) + END DO + END DO + END DO + END DO + END DO + END DO + END DO + END DO + + PRINT '(/,2x,a,/)','Jacobian check in file FORT.33' + + END IF + + END IF + 123 FORMAT(4x,4(a,i4),a,i6,a,1p,e12.3) +! +! INITIALIZE vecs +! + vecs(:ndim,2) = -gc(:ndim) + vecs(:ndim,3) = gc(:ndim) + + ierr = 100000 + info = 0 + info(1) = ierr + + 10 CALL dutfx (ndim,nlen,nlim,vecs,tol,info) + revcom = info(2) + colx = info(3) + colb = info(4) + IF (revcom .eq. 1) THEN + CALL matvec (vecs(1,colx), vecs(1,colb), ndim) + GO TO 10 + END IF + + xc(1:ndim) = xsave(1:ndim) + vecs(1:ndim,1) + + END SUBROUTINE qmr_fun + + END MODULE gmres_mod + + SUBROUTINE Truncate(num, iprec0) + USE stel_kinds, ONLY: dp + IMPLICIT NONE +! NEEDED TO RESOLVE CALL IN gmres_par +!----------------------------------------------- +! D u m m y A r g u m e n t s +!----------------------------------------------- + INTEGER, INTENT(IN) :: iprec0 + REAL(dp), INTENT(INOUT) :: num +!----------------------------------------------- +!----------------------------------------------- +! L o c a l V a r i a b l e s +!----------------------------------------------- + CHARACTER*24 :: chnum, tchnum +!----------------------------------------------- +! +! TRUNCATES double-precision to precision iprec0 digits, keeping exponent range of double +! WRITE TO INTERNAL FILE TO DO TRUNCATION +! +!UNCOMMENT THESE LINES TO ACTIVATE +! WRITE (chnum, '(a,i2,a,i2,a)') '(1p,e',iprec0+7,'.',iprec0,')' +! WRITE (tchnum, chnum) num + +! READ (tchnum, chnum) num + + END SUBROUTINE Truncate diff --git a/Sources/TimeStep/interp.f b/Sources/TimeStep/interp.f new file mode 100644 index 0000000..f9d346d --- /dev/null +++ b/Sources/TimeStep/interp.f @@ -0,0 +1,120 @@ + SUBROUTINE interp_par(xnew, xold, scalxc, nsnew, nsold) + USE vmec_main, ONLY: dp, rprec, mnsize + USE vmec_params, ONLY: ntmax + USE vmec_persistent, ONLY: ixm + USE parallel_include_module + + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nsnew, nsold + REAL(rprec), DIMENSION(mnsize,nsnew,3*ntmax), INTENT(out) :: xnew + REAL(rprec), DIMENSION(mnsize,nsnew,3*ntmax), INTENT(in) :: + & scalxc + REAL(rprec), DIMENSION(mnsize,nsold,3*ntmax) :: xold +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: zero=0, one=1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ntype, js, js1, js2, neqs2_old + REAL(rprec) :: hsold, sj, s1, xint +C----------------------------------------------- + IF (nsold .le. 0) RETURN + hsold = one/(nsold - 1) + +! INTERPOLATE R,Z AND LAMBDA ON FULL GRID +! (EXTRAPOLATE M=1 MODES,OVER SQRT(S), TO ORIGIN) +! ON ENTRY, XOLD = X(COARSE MESH) * SCALXC(COARSE MESH) +! ON EXIT, XNEW = X(NEW MESH) [ NOT SCALED BY 1/SQRTS ] + + DO ntype = 1, 3*ntmax + + WHERE (MOD(ixm(:mnsize),2) .eq. 1) + xold(:,1,ntype) = 2*xold(:,2,ntype) - xold(:,3,ntype) + END WHERE + + DO js = 1, nsnew + sj = REAL(js - 1,rprec)/(nsnew - 1) + js1 = 1 + ((js - 1)*(nsold - 1))/(nsnew - 1) + js2 = MIN(js1 + 1,nsold) + s1 = (js1 - 1)*hsold + xint = (sj - s1)/hsold + xint = MIN(one,xint) + xint = MAX(zero,xint) + xnew(:,js,ntype) = ((one - xint)*xold(:,js1,ntype) + + & xint*xold(:,js2,ntype))/scalxc(:,js,1) + END DO + +! Zero M=1 modes at origin + WHERE (MOD(ixm(:mnsize),2) .eq. 1) + xnew(:,1,ntype) = 0 + END WHERE + + END DO + + END SUBROUTINE interp_par + + SUBROUTINE interp(xnew, xold, scalxc, nsnew, nsold) + USE vmec_main, ONLY: dp, rprec, mnsize + USE vmec_params, ONLY: ntmax + USE vmec_persistent, ONLY: ixm + USE parallel_include_module + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER nsnew, nsold + REAL(rprec), DIMENSION(nsnew,mnsize,3*ntmax), INTENT(out) :: xnew + REAL(rprec), DIMENSION(nsnew,mnsize,3*ntmax), INTENT(in) :: + & scalxc + REAL(rprec), DIMENSION(nsold,mnsize,3*ntmax) :: xold +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + REAL(rprec), PARAMETER :: zero=0, one=1 +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: ntype, js, js1, js2, neqs2_old + REAL(rprec) :: hsold, sj, s1, xint +C----------------------------------------------- + + IF (nsold .le. 0) RETURN + hsold = one/(nsold - 1) +! +! INTERPOLATE R,Z AND LAMBDA ON FULL GRID +! (EXTRAPOLATE M=1 MODES,OVER SQRT(S), TO ORIGIN) +! ON ENTRY, XOLD = X(COARSE MESH) * SCALXC(COARSE MESH) +! ON EXIT, XNEW = X(NEW MESH) [ NOT SCALED BY 1/SQRTS ] +! + + DO ntype = 1, 3*ntmax + + WHERE (MOD(ixm(:mnsize),2) .eq. 1) + xold(1,:,ntype) = 2*xold(2,:,ntype) - xold(3,:,ntype) + END WHERE + + DO js = 1, nsnew + sj = REAL(js - 1,rprec)/(nsnew - 1) + js1 = 1 + ((js - 1)*(nsold - 1))/(nsnew - 1) + js2 = MIN(js1 + 1,nsold) + s1 = (js1 - 1)*hsold + xint = (sj - s1)/hsold + xint = MIN(one,xint) + xint = MAX(zero,xint) + xnew(js,:,ntype) = ((one - xint)*xold(js1,:,ntype) + + & xint*xold(js2,:,ntype))/scalxc(js,:,1) + END DO + +! Zero M=1 modes at origin + WHERE (MOD(ixm(:mnsize),2) .eq. 1) + xnew(1,:,ntype) = 0 + END WHERE + + END DO + + END SUBROUTINE interp diff --git a/Sources/TimeStep/parallel_include_module.f90 b/Sources/TimeStep/parallel_include_module.f90 new file mode 100755 index 0000000..09b1da1 --- /dev/null +++ b/Sources/TimeStep/parallel_include_module.f90 @@ -0,0 +1,435 @@ + MODULE parallel_include_module + + USE stel_kinds + USE vmec_input, ONLY:lfreeb + USE mpi_inc + + USE parallel_vmec_module, ONLY: PARVMEC + USE parallel_vmec_module, ONLY: LV3FITCALL + USE parallel_vmec_module, ONLY: LPRECOND + USE parallel_vmec_module, ONLY: TOFU + + USE parallel_vmec_module, ONLY: num_grids + USE parallel_vmec_module, ONLY: grid_procs + USE parallel_vmec_module, ONLY: grid_size + USE parallel_vmec_module, ONLY: grid_time + USE parallel_vmec_module, ONLY: vgrid_time + USE parallel_vmec_module, ONLY: f3d_time + USE parallel_vmec_module, ONLY: f3d_num + USE parallel_vmec_module, ONLY: RUNVMEC_COMM_WORLD + USE parallel_vmec_module, ONLY: NS_COMM + USE parallel_vmec_module, ONLY: VAC_COMM + USE parallel_vmec_module, ONLY: TWODCOMM + USE parallel_vmec_module, ONLY: px, py + USE parallel_vmec_module, ONLY: NS_RESLTN + USE parallel_vmec_module, ONLY: MPI_ERR + USE parallel_vmec_module, ONLY: rank, nranks + USE parallel_vmec_module, ONLY: lactive, vlactive + USE parallel_vmec_module, ONLY: grank, gnranks + USE parallel_vmec_module, ONLY: vrank, vnranks + USE parallel_vmec_module, ONLY: nuvmin, nuvmax + USE parallel_vmec_module, ONLY: nuv3min, nuv3max + USE parallel_vmec_module, ONLY: tlglob, trglob + USE parallel_vmec_module, ONLY: t1lglob, t1rglob + USE parallel_vmec_module, ONLY: tlglob_arr, trglob_arr + USE parallel_vmec_module, ONLY: nuv3min_arr,nuv3max_arr + USE parallel_vmec_module, ONLY: trow, brow + USE parallel_vmec_module, ONLY: lcol, rcol + USE parallel_vmec_module, ONLY: par_ntmax + USE parallel_vmec_module, ONLY: par_mpol1 + USE parallel_vmec_module, ONLY: par_ntor + USE parallel_vmec_module, ONLY: par_ns + USE parallel_vmec_module, ONLY: par_nuv + USE parallel_vmec_module, ONLY: blkrcounts + USE parallel_vmec_module, ONLY: blkdisp + USE parallel_vmec_module, ONLY: ntblkrcounts + USE parallel_vmec_module, ONLY: ntblkdisp + USE parallel_vmec_module, ONLY: nsrcounts + USE parallel_vmec_module, ONLY: nsdisp + USE parallel_vmec_module, ONLY: blocksize + USE parallel_vmec_module, ONLY: ntmaxblocksize + + USE parallel_vmec_module, ONLY: STOPMPI + + USE parallel_vmec_module, ONLY: tolastntype + USE parallel_vmec_module, ONLY: copylastntype + + USE parallel_vmec_module, ONLY: tolastns + USE parallel_vmec_module, ONLY: copylastns + + USE parallel_vmec_module, ONLY: CopyParallelLinearSubarray + + USE parallel_vmec_module, ONLY: SetVacuumPartitions + USE parallel_vmec_module, ONLY: SetVacuumCommunicator + + USE parallel_vmec_module, ONLY: ComputeBlockAllGatherParameters + USE parallel_vmec_module, ONLY: ComputeNSAllGatherParameters + + USE parallel_vmec_module, ONLY: PadSides + + USE parallel_vmec_module, ONLY: Parallel2Serial2X + USE parallel_vmec_module, ONLY: Parallel2Serial4X + + USE parallel_vmec_module, ONLY: Serial2Parallel4X + + USE parallel_vmec_module, ONLY: Gather1XArray + USE parallel_vmec_module, ONLY: Gather2XArray + USE parallel_vmec_module, ONLY: Gather4XArray + USE parallel_vmec_module, ONLY: GatherReordered4XArray + + USE parallel_vmec_module, ONLY: PrintParallelIJSPArray + USE parallel_vmec_module, ONLY: PrintSerialIJSPArray + USE parallel_vmec_module, ONLY: PrintParallelMNSPArray + USE parallel_vmec_module, ONLY: PrintSerialMNSPArray + USE parallel_vmec_module, ONLY: PrintNSArray + USE parallel_vmec_module, ONLY: PrintOutLinearArray + USE parallel_vmec_module, ONLY: RPrintOutLinearArray + + USE parallel_vmec_module, ONLY: bcyclic_comp_time + USE parallel_vmec_module, ONLY: bcyclic_comm_time + USE parallel_vmec_module, ONLY: waitall_time + USE parallel_vmec_module, ONLY: dgemm_time + USE parallel_vmec_module, ONLY: dgemv_time + USE parallel_vmec_module, ONLY: dgetrf_time + USE parallel_vmec_module, ONLY: dgetrs_time + USE parallel_vmec_module, ONLY: ForwardSolveLoop_time + USE parallel_vmec_module, ONLY: t + + USE parallel_vmec_module, ONLY: allgather_time + USE parallel_vmec_module, ONLY: allreduce_time + USE parallel_vmec_module, ONLY: broadcast_time + USE parallel_vmec_module, ONLY: sendrecv_time + USE parallel_vmec_module, ONLY: scatter_time + + LOGICAL :: LRESIDUECALL=.FALSE. + LOGICAL :: LGMRESCALL=.FALSE. + LOGICAL :: INFILEOUT=.FALSE. + LOGICAL :: RVCTRIGGER=.FALSE. + INTEGER :: RVCCALLNUM + + !Common timers + REAL(dp) :: mgrid_file_read_time=0 + REAL(dp) :: total_time=0 + REAL(dp) :: evolve_time=0 + REAL(dp) :: restart_time=0 + REAL(dp) :: eqsolve_time=0 + REAL(dp) :: fileout_time=0 + REAL(dp) :: runvmec_time=0 + REAL(dp) :: init_parallel_time=0 + REAL(dp) :: init_radial_time=0 + REAL(dp) :: allocate_ns_time=0 + REAL(dp) :: profile1d_time=0 + REAL(dp) :: profile3d_time=0 + REAL(dp) :: before_main_loop_time=0 + REAL(dp) :: reset_params_time=0 + REAL(dp) :: vsetup_time=0 + REAL(dp) :: readin_time=0 + REAL(dp) :: fixarray_time=0 + + REAL(dp) :: myenvvar_time=0 + REAL(dp) :: init_MPI_time=0 + REAL(dp) :: read_namelist_time=0 + REAL(dp) :: get_args_time=0 + REAL(dp) :: safe_open_time=0 + + REAL(dp) :: jacob1=0, jacob2=0 + + INTEGER :: nfunct3d=0 + REAL(dp) :: old_vacuum_time=0 + + REAL(dp) :: fo_funct3d_time=0 + REAL(dp) :: fo_eqfor_time=0 + REAL(dp) :: fo_wrout_time=0 + REAL(dp) :: fo_prepare_time=0 + REAL(dp) :: fo_par_call_time=0 + + !Vacuum, Scalpot variables + INTEGER :: blksize_scp, numjs_vac + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts_vac, disps_vac, lindx_scp + + !Parallel timers + REAL(dp) :: totzsps_time=0 + REAL(dp) :: totzspa_time=0 + REAL(dp) :: jacobian_time=0 + REAL(dp) :: bcovar_time=0 + REAL(dp) :: alias_time=0 + REAL(dp) :: forces_time=0 + REAL(dp) :: tomnsps_time=0 + REAL(dp) :: tomnspa_time=0 + REAL(dp) :: symrzl_time=0 + REAL(dp) :: symforces_time=0 + REAL(dp) :: residue_time=0 + REAL(dp) :: tridslv_time=0 + REAL(dp) :: scalfor_time=0 + REAL(dp) :: funct3d_time=0 + REAL(dp) :: gmres_time=0 + REAL(dp) :: guess_axis_time=0 + REAL(dp) :: vacuum_time=0 + REAL(dp) :: precal_time=0 + REAL(dp) :: surface_time=0 + REAL(dp) :: bextern_time=0 + REAL(dp) :: scalpot_time=0 + REAL(dp) :: solver_time=0 + REAL(dp) :: analyt_time=0 + REAL(dp) :: tolicu_time=0 + REAL(dp) :: belicu_time=0 + REAL(dp) :: becoil_time=0 + REAL(dp) :: greenf_time=0 + REAL(dp) :: fourp_time=0 + REAL(dp) :: fouri_time=0 + + REAL(dp) :: init_time=0 + REAL(dp) :: setup_time=0 + REAL(dp) :: forwardsolve_time=0 + REAL(dp) :: backwardsolve_time=0 + REAL(dp) :: finalize_time=0 + + REAL(dp) :: fill_blocks_time=0 + REAL(dp) :: compute_blocks_time=0 + REAL(dp) :: bcyclic_forwardsolve_time=0 + REAL(dp) :: bcyclic_backwardsolve_time=0 + + !Serial timers + REAL(dp) :: s_totzsps_time=0 + REAL(dp) :: s_totzspa_time=0 + REAL(dp) :: s_jacobian_time=0 + REAL(dp) :: s_bcovar_time=0 + REAL(dp) :: s_alias_time=0 + REAL(dp) :: s_forces_time=0 + REAL(dp) :: s_tomnsps_time=0 + REAL(dp) :: s_tomnspa_time=0 + REAL(dp) :: s_symrzl_time=0 + REAL(dp) :: s_symforces_time=0 + REAL(dp) :: s_residue_time=0 + REAL(dp) :: s_tridslv_time=0 + REAL(dp) :: s_scalfor_time=0 + REAL(dp) :: s_gmres_time=0 + REAL(dp) :: s_guess_axis_time=0 + REAL(dp) :: s_vacuum_time=0 + REAL(dp) :: s_precal_time=0 + REAL(dp) :: s_surface_time=0 + REAL(dp) :: s_bextern_time=0 + REAL(dp) :: s_scalpot_time=0 + REAL(dp) :: s_solver_time=0 + REAL(dp) :: s_analyt_time=0 + REAL(dp) :: s_tolicu_time=0 + REAL(dp) :: s_belicu_time=0 + REAL(dp) :: s_becoil_time=0 + REAL(dp) :: s_greenf_time=0 + REAL(dp) :: s_fourp_time=0 + REAL(dp) :: s_fouri_time=0 + + REAL(rprec) :: maxvalue, minvalue + INTEGER :: maxrank, minrank + + !V3FIT + INTEGER :: RUNVMEC_PASS=0 + +! INTEGER :: v3fgcomm, v3freccomm, v3feqcomm +! INTEGER :: v3fgnranks, v3frecnranks, v3feqnranks +! INTEGER :: v3fgrank, v3frecrank, v3feqrank +! LOGICAL :: lreconactive=.FALSE. + +CONTAINS + + !------------------------------------------------ + ! Print out parallel timing information + !------------------------------------------------ + SUBROUTINE PrintTimes + IMPLICIT NONE + DOUBLE PRECISION :: ind(2,1), outd(2,1) + DOUBLE PRECISION :: mt(nranks) + LOGICAL :: LMINMAXFILE=.FALSE. + + IF (PARVMEC) THEN +#if defined(MPI_OPT) + ind(1,1) = total_time; ind(2,1) = DBLE(rank) + CALL MPI_Reduce(ind,outd,1,MPI_2DOUBLE_PRECISION,MPI_MINLOC,0,NS_COMM,MPI_ERR) + IF(grank.EQ.0) THEN + minvalue = outd(1,1); minrank = outd(2,1) + END IF + CALL MPI_Reduce(ind,outd,1,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,0,NS_COMM,MPI_ERR) + IF(grank.EQ.0) THEN + maxvalue = outd(1,1); maxrank = outd(2,1) + END IF + CALL MPI_Bcast(minvalue,1,MPI_DOUBLE_PRECISION,0,NS_COMM,MPI_ERR) + CALL MPI_Bcast(maxvalue,1,MPI_DOUBLE_PRECISION,0,NS_COMM,MPI_ERR) + CALL MPI_Bcast(minrank,1,MPI_INTEGER,0,NS_COMM,MPI_ERR) + CALL MPI_Bcast(maxrank,1,MPI_INTEGER,0,NS_COMM,MPI_ERR) + + IF (.FALSE..AND.ABS(maxvalue-minvalue).GE.0.0) THEN + LMINMAXFILE=.TRUE. + IF (grank.EQ.0) THEN + WRITE(*,*) + WRITE(*,*)'---------------------------------------------------' + WRITE(*,*) 'Min and max runtimes exceed tolerance....' + WRITE(*,'(A12,F15.6,A12,I6)')'Max. time: ',maxvalue,'Rank :',maxrank + WRITE(*,'(A12,F15.6,A12,I6)')'Min. time: ',minvalue,'Rank :',minrank + WRITE(*,*)'---------------------------------------------------' + WRITE(*,*) + END IF + END IF +#endif + ELSE + totzsps_time = s_totzsps_time + totzspa_time = s_totzspa_time + jacobian_time = s_jacobian_time + bcovar_time = s_bcovar_time + alias_time = s_alias_time + forces_time = s_forces_time + tomnsps_time = s_tomnsps_time + tomnspa_time = s_tomnspa_time + symrzl_time = s_symrzl_time + symforces_time = s_symforces_time + residue_time = s_residue_time + tridslv_time = s_tridslv_time + scalfor_time = s_scalfor_time + gmres_time = s_gmres_time + guess_axis_time = s_guess_axis_time + vacuum_time = s_vacuum_time + precal_time = s_precal_time + surface_time = s_surface_time + bextern_time = s_bextern_time + scalpot_time = s_scalpot_time + solver_time = s_solver_time + analyt_time = s_analyt_time + tolicu_time = s_tolicu_time + belicu_time = s_belicu_time + becoil_time = s_becoil_time + greenf_time = s_greenf_time + fourp_time = s_fourp_time + fouri_time = s_fouri_time + maxvalue=total_time; minvalue=total_time + END IF + + IF (PARVMEC.AND.LMINMAXFILE) THEN + IF(grank.EQ.minrank) THEN + CALL WriteTimes('min-timings.txt') + END IF + IF(grank.EQ.maxrank) THEN + CALL WriteTimes('max-timings.txt') + END IF + END IF + + IF(grank.EQ.0) THEN + CALL WriteTimes('timings.txt') + END IF + + END SUBROUTINE PrintTimes +!------------------------------------------------ + +!------------------------------------------------ + SUBROUTINE WriteTimes(fname) + IMPLICIT NONE + CHARACTER(*), INTENT(IN) :: fname + CHARACTER(100) :: cfname + CHARACTER(50) :: ciam, cnprocs + INTEGER :: TFILE, i, istat, igrd + + WRITE(ciam,*) rank; WRITE(cnprocs,*) nranks + ciam=ADJUSTL(ciam); cnprocs=ADJUSTL(cnprocs) + TFILE = 9*nranks+grank+1000 + OPEN(UNIT=TFILE, FILE=fname, STATUS="REPLACE", ACTION="WRITE",& + &FORM="FORMATTED",POSITION="APPEND", IOSTAT=istat) + + IF (PARVMEC) THEN + WRITE(TFILE,*) '====================== PARALLEL TIMINGS ====================' + ELSE + WRITE(TFILE,*) '======================= SERIAL TIMINGS =====================' + END IF + + WRITE(TFILE,'(A20,A4,F15.6)') 'total', ': ', total_time + WRITE(TFILE,'(A20,A4,I15)') 'rank', ': ', rank + WRITE(TFILE,'(A20,A4,F15.6)') 'mgrid file read time', ': ', mgrid_file_read_time + WRITE(TFILE,'(A20,A4,I15)') 'No. of procs', ': ', gnranks + WRITE(TFILE,*) + + IF (lfreeb) THEN + DO igrd=1, num_grids + WRITE(TFILE,'(A20,A4,3I15,F15.6)') '--- non-vacuum', ': ',& + f3d_num(igrd), grid_size(igrd), grid_procs(igrd), f3d_time(igrd)-vgrid_time(igrd) + END DO + WRITE(TFILE,*) + + WRITE(TFILE,'(A20,A4,I15)') 'VNRANKS ',': ', vnranks + DO igrd=1, num_grids + WRITE(TFILE,'(A20,A4,I15,F15.6)') '--- vacuum ', ': ',& + grid_size(igrd),vgrid_time(igrd) + END DO + WRITE(TFILE,*) + ELSE + DO igrd=1, num_grids + WRITE(TFILE,'(A20,A4,3I15,F15.6)') '--- non-vacuum', ': ',& + f3d_num(igrd), grid_size(igrd), grid_procs(igrd), f3d_time(igrd) + END DO + WRITE(TFILE,*) + END IF + + WRITE(TFILE,'(A20,A4,F15.6)') 'runvmec', ': ', runvmec_time + WRITE(TFILE,*) + + WRITE(TFILE,'(A20,A4,F15.6)') 'init radial', ': ',init_radial_time + WRITE(TFILE,'(A20,A4,F15.6)') 'eqsolve', ': ', eqsolve_time + WRITE(TFILE,'(A20,A4,F15.6)') 'fileout', ': ', fileout_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') 'evolve', ': ', evolve_time + WRITE(TFILE,'(A20,A4,F15.6)') 'funct3d', ': ', funct3d_time + WRITE(TFILE,'(A20,A4,I15)') 'nfunct3d', ': ', nfunct3d + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') 'totzsps', ': ', totzsps_time + WRITE(TFILE,'(A20,A4,F15.6)') 'totzspa', ': ', totzspa_time + WRITE(TFILE,'(A20,A4,F15.6)') 'symrzl', ': ', symrzl_time + WRITE(TFILE,'(A20,A4,F15.6)') 'jacobian', ': ', jacobian_time + WRITE(TFILE,'(A20,A4,F15.6)') 'bcovar', ': ', bcovar_time + WRITE(TFILE,'(A20,A4,F15.6)') 'vacuum', ': ', vacuum_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '- precal', ': ', precal_time + WRITE(TFILE,'(A20,A4,F15.6)') '- surface', ': ', surface_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '- bextern', ': ', bextern_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '-- becoil', ': ', becoil_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- tolicu', ': ', tolicu_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- belicu', ': ', belicu_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '- scalpot', ': ', scalpot_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '-- analyt', ': ', analyt_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- greenf', ': ', greenf_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- fourp', ': ', fourp_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- fouri', ': ', fouri_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') '- solver', ': ', solver_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') 'alias', ': ', alias_time + WRITE(TFILE,'(A20,A4,F15.6)') 'forces', ': ', forces_time + WRITE(TFILE,'(A20,A4,F15.6)') 'symforces', ': ', symforces_time + WRITE(TFILE,'(A20,A4,F15.6)') 'tomnsps', ': ', tomnsps_time + WRITE(TFILE,'(A20,A4,F15.6)') 'tomnspa', ': ', tomnspa_time + WRITE(TFILE,'(A20,A4,F15.6)') 'residue', ': ', residue_time + WRITE(TFILE,'(A20,A4,F15.6)') '-- tridslv', ': ', tridslv_time + WRITE(TFILE,*) + WRITE(TFILE,*) '============================================================' + IF (PARVMEC) THEN + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') 'allgather', ': ', allgather_time + WRITE(TFILE,'(A20,A4,F15.6)') 'allreduce', ': ', allreduce_time + WRITE(TFILE,'(A20,A4,F15.6)') 'broadcast', ': ', broadcast_time + WRITE(TFILE,'(A20,A4,F15.6)') 'sendrecv ', ': ', sendrecv_time + WRITE(TFILE,*) + WRITE(TFILE,'(A20,A4,F15.6)') 'Fill_blocks ', ': ', fill_blocks_time + WRITE(TFILE,'(A20,A4,F15.6)') 'Compute blocks ', ': ', compute_blocks_time + WRITE(TFILE,'(A20,A4,F15.6)') 'Forward solve ', ': ', bcyclic_forwardsolve_time + WRITE(TFILE,'(A20,A4,F15.6)') 'Backward solve ', ': ', bcyclic_backwardsolve_time + WRITE(TFILE,*) '============================================================' + END IF + CALL FLUSH(TFILE) + CLOSE(TFILE) + + !WRITE(*,*) 'totzsps : ', totzsps_time + END SUBROUTINE WriteTimes +!------------------------------------------------ + + END MODULE parallel_include_module +!------------------------------------------------ + diff --git a/Sources/TimeStep/parallel_vmec_module.f90 b/Sources/TimeStep/parallel_vmec_module.f90 new file mode 100755 index 0000000..3fc95e3 --- /dev/null +++ b/Sources/TimeStep/parallel_vmec_module.f90 @@ -0,0 +1,1299 @@ +!------------------------------------------------ +MODULE parallel_vmec_module + !------------------------------------------------ + + USE stel_kinds + USE mpi_inc + IMPLICIT NONE + INTEGER :: TOFU + INTEGER :: grank=0, gnranks=1 + INTEGER :: vrank=0, vnranks=1 + INTEGER :: rank=0, nranks=1 + INTEGER :: last_ns = -1 + INTEGER :: par_ns, mynsnum, par_nzeta, par_ntheta3 + INTEGER :: par_ntmax, par_ntor, par_mpol1, par_nznt, par_nuv, par_nuv3 + INTEGER :: blocksize, ntmaxblocksize + INTEGER :: tlglob, trglob, t1lglob, t1rglob + INTEGER :: nuvmin, nuvmax, nuv3min, nuv3max + INTEGER :: MPI_ERR +#if defined(MPI_OPT) + INTEGER :: MPI_STAT(MPI_STATUS_SIZE) +#endif + INTEGER :: RUNVMEC_COMM_WORLD + INTEGER :: NS_COMM + INTEGER :: VAC_COMM + INTEGER :: TWODCOMM, px, py + INTEGER :: NS_RESLTN=0 + INTEGER :: num_grids + INTEGER, ALLOCATABLE, DIMENSION(:) :: grid_procs + INTEGER, ALLOCATABLE, DIMENSION(:) :: grid_size + REAL(dp), ALLOCATABLE, DIMENSION(:) :: grid_time + REAL(dp), ALLOCATABLE, DIMENSION(:) :: f3d_time + INTEGER, ALLOCATABLE, DIMENSION(:) :: f3d_num + + REAL(dp), ALLOCATABLE, DIMENSION(:) :: vgrid_time + + INTEGER, ALLOCATABLE, DIMENSION(:) :: tlglob_arr, trglob_arr + INTEGER, ALLOCATABLE, DIMENSION(:) :: nuv3min_arr,nuv3max_arr + INTEGER, ALLOCATABLE, DIMENSION(:) :: trow, brow + INTEGER, ALLOCATABLE, DIMENSION(:) :: lcol, rcol + + INTEGER, ALLOCATABLE, DIMENSION (:) :: blkrcounts, blkdisp + INTEGER, ALLOCATABLE, DIMENSION (:) :: ntblkrcounts, ntblkdisp + INTEGER, ALLOCATABLE, DIMENSION (:) :: nsrcounts, nsdisp + INTEGER, PRIVATE :: mmax, nmax, tmax + + LOGICAL :: PARVMEC=.FALSE. + LOGICAL :: LV3FITCALL=.FALSE. + LOGICAL :: LIFFREEB=.FALSE. + LOGICAL :: LPRECOND=.FALSE. + + LOGICAL :: lactive=.FALSE. + LOGICAL :: vlactive=.FALSE. + + CHARACTER*100 :: envvar + CHARACTER*100 :: envval + + REAL(dp) :: bcyclic_comp_time + REAL(dp) :: bcyclic_comm_time + REAL(dp) :: waitall_time + REAL(dp) :: dgemm_time + REAL(dp) :: dgetrf_time + REAL(dp) :: dgetrs_time + REAL(dp) :: dgemv_time + REAL(dp) :: ForwardSolveLoop_time + REAL(dp), DIMENSION(12) :: t + + REAL(dp) :: allgather_time=0 + REAL(dp) :: allreduce_time=0 + REAL(dp) :: broadcast_time=0 + REAL(dp) :: sendrecv_time=0 + REAL(dp) :: scatter_time=0 + +! +! OVERLOADED FUNCTIONS +! + INTERFACE CopyLastNType + MODULE PROCEDURE copy4lastntype, copy1lastntype, & + copym4lastntype, copym1lastntype + END INTERFACE + +CONTAINS + + !-------------------------------------------------------------------------- + ! Read in environment variables + !-------------------------------------------------------------------------- + SUBROUTINE MyEnvVariables + + PARVMEC=.TRUE. + envvar='PARVMEC' + CALL GETENV(envvar,envval) + IF (envval.EQ.'FALSE'.OR.envval.EQ.'false' & + .OR.envval.EQ.'F'.OR.envval.EQ.'f') THEN + PARVMEC=.FALSE. + END IF + + LV3FITCALL=.FALSE. + envvar='LV3FITCALL' + CALL GETENV(envvar,envval) + IF (envval.EQ.'TRUE'.OR.envval.EQ.'true' & + .OR.envval.EQ.'T'.OR.envval.EQ.'t') THEN + LV3FITCALL=.TRUE. + END IF + + END SUBROUTINE MyEnvVariables + !-------------------------------------------------------------------------- + + + !-------------------------------------------------------------------------- + ! Declarations of all timers to be used in the parallel implementation + !-------------------------------------------------------------------------- + SUBROUTINE InitializeParallel + +#if defined(MPI_OPT) + CALL MPI_Init(MPI_ERR) + CALL MPI_Comm_rank(MPI_COMM_WORLD,grank,MPI_ERR) + CALL MPI_Comm_size(MPI_COMM_WORLD,gnranks,MPI_ERR) +#endif + + END SUBROUTINE InitializeParallel + !-------------------------------------------------------------------------- + + !-------------------------------------------------------------------------- + SUBROUTINE InitRunVmec(INCOMM, LVALUE) + INTEGER, INTENT(IN) :: INCOMM + LOGICAL, INTENT(IN) :: LVALUE + +! NS_RESLTN = 0 ! SAL 070619 + LIFFREEB = LVALUE +#if defined(MPI_OPT) + CALL MPI_Comm_dup(INCOMM,RUNVMEC_COMM_WORLD,MPI_ERR) + CALL MPI_Comm_rank(RUNVMEC_COMM_WORLD,grank,MPI_ERR) + CALL MPI_Comm_size(RUNVMEC_COMM_WORLD,gnranks,MPI_ERR) +#endif + END SUBROUTINE InitRunVmec + !-------------------------------------------------------------------------- + + !-------------------------------------------------------------------------- + SUBROUTINE InitSurfaceComm(ns, nzeta, ntheta3, ntmax, ntor, mpol1) + +INTEGER, INTENT(IN) :: ns, nzeta, ntheta3 + INTEGER, INTENT(IN) :: ntmax, ntor, mpol1 + INTEGER :: i + LOGICAL :: FIRSTPASS = .TRUE. + + par_ns = ns + par_nzeta = nzeta + par_ntheta3 = ntheta3 + par_ntmax = ntmax + par_ntor = ntor + par_mpol1 = mpol1 + par_nznt = par_nzeta*par_ntheta3 + blocksize = (par_mpol1 + 1)*(par_ntor+1) + ntmaxblocksize = 3*ntmax*blocksize + mmax = par_mpol1 + 1 + nmax = par_ntor + 1 + tmax = 3*par_ntmax + NS_RESLTN = NS_RESLTN + 1 + + IF (LV3FITCALL) THEN + IF (last_ns.NE.par_ns) THEN + CALL SetSurfaceCommunicator + CALL SetSurfacePartitions + CALL SetSurfacePartitionArrays + last_ns = par_ns + END IF + ELSE + CALL SetSurfaceCommunicator + CALL SetSurfacePartitions + CALL SetSurfacePartitionArrays + last_ns = par_ns + + IF (lactive) THEN + IF (grank.EQ.0) THEN + IF (FIRSTPASS) THEN + CALL SetOutputFile(rank,nranks,'parvmecinfo') + WRITE(TOFU,*)"============================================================" + WRITE(TOFU,*) 'PARVMEC = ',PARVMEC + WRITE(TOFU,*) "> available processor count:", gnranks + WRITE(TOFU,*) '> global rank:', grank + WRITE(TOFU,*) '> nzeta: ', par_nzeta + WRITE(TOFU,*) '> ntheta3: ', par_ntheta3 + WRITE(TOFU,*) '> ntor: ', par_ntor + WRITE(TOFU,*) '> mpol1: ', par_mpol1 + WRITE(TOFU,*) '> ntmax: ', par_ntmax + WRITE(TOFU,*) '> blocksize: ',(par_mpol1+1)*(par_ntor+1) + WRITE(TOFU,*)"============================================================" + WRITE(TOFU,*) + CALL FLUSH(TOFU) + FIRSTPASS = .FALSE. + END IF + WRITE(TOFU,*) ">>> grid resolution: ",par_ns + WRITE(TOFU,*) ">>> active processors: ",nranks + WRITE(TOFU,*) ">>> xc/gc size: ", par_ns*(par_ntor+1)*(par_mpol1+1)*3*ntmax + WRITE(TOFU,*)"------------------------------------------------------------" + WRITE(TOFU,*) + CALL FLUSH(TOFU) + END IF + END IF + END IF + + END SUBROUTINE InitSurfaceComm + !------------------------------------------------ + + !------------------------------------------------ + ! Setting up the communicator for parallel surface + ! computations + !------------------------------------------------ + SUBROUTINE SetSurfaceCommunicator + + INTEGER :: num_active, color + + num_active = MIN(gnranks, par_ns/2) + + IF (grank.LT.num_active) THEN + color=1 + ELSE + color=0 + END IF +#if defined(MPI_OPT) + CALL MPI_Comm_split(RUNVMEC_COMM_WORLD, color, grank, NS_COMM, & + MPI_ERR) + + IF (color .eq. 1) THEN + CALL MPI_Comm_size(NS_COMM,nranks,MPI_ERR) + IF (nranks.NE.num_active) THEN + STOP 'num_active != nranks in InitSurfaceCommunicator!' + END IF + lactive = .TRUE. + CALL MPI_Comm_rank(NS_COMM,rank,MPI_ERR) + ELSE + nranks = 1 + rank = 0 + lactive = .FALSE. + END IF +#endif + END SUBROUTINE SetSurfaceCommunicator + !------------------------------------------------ + + !------------------------------------------------ + ! Setting up the partitions for parallel surface + ! computations + !------------------------------------------------ + SUBROUTINE SetSurfacePartitions + + INTEGER :: mypart, local_err +#if defined(MPI_OPT) + IF (par_ns.LT.nranks) THEN + IF(grank.EQ.0) print *,"NS is less than NRANKS. Aborting!" + CALL STOPMPI(5645) + END IF + + mypart=par_ns/nranks + IF (rank.LT.MOD(par_ns,nranks)) mypart = mypart + 1 + IF (MOD(par_ns,nranks).NE.0) THEN + IF (rank.LT.MOD(par_ns,nranks)) THEN + tlglob = rank*mypart + ELSE IF (rank .GE. MOD(par_ns,nranks)) THEN + tlglob = MOD(par_ns, nranks)*(mypart + 1) & + + (rank - MOD(par_ns, nranks))*mypart + END IF + ELSE + tlglob = rank*mypart + END IF + + tlglob = tlglob + 1 + trglob = tlglob + mypart - 1 + + t1lglob = tlglob - 1; IF (rank.EQ.0) t1lglob=1 + t1rglob = trglob + 1; IF (rank.EQ.nranks-1) t1rglob=par_ns + + IF(mypart.LT.2) THEN + CALL MPI_Barrier(NS_COMM,MPI_ERR) + WRITE(TOFU,*) '***********************************************************' + WRITE(TOFU,*) '* This version is not yet tested for mynsnum <= 2. Aborting!' + WRITE(TOFU,*) '***********************************************************' + IF (rank.EQ.0) THEN + WRITE(*,*) + WRITE(*,*) '***********************************************************' + WRITE(*,*) '* This version is not yet tested for mynsnum <= 2. Aborting!' + WRITE(*,*) '***********************************************************' + WRITE(*,*) + END IF + CALL MPI_Abort(NS_COMM,local_err,MPI_ERR) + END IF +#endif + END SUBROUTINE SetSurfacePartitions + !------------------------------------------------ + + !------------------------------------------------ + ! Setting up the partition arrays for parallel surface + ! computations + !------------------------------------------------ + SUBROUTINE SetSurfacePartitionArrays + + INTEGER, ALLOCATABLE, DIMENSION(:) :: localpart + INTEGER :: i, smallpart, largepart + + smallpart = par_ns/nranks; largepart = smallpart + IF(MOD(par_ns,nranks) .GT. 0) largepart = largepart + 1 + + ALLOCATE (localpart(nranks)) + DO i = 0, nranks - 1 + localpart(i + 1) = smallpart + + IF (MOD(par_ns,nranks) .GT. 0 .and. & + i .LT. MOD(par_ns, nranks)) THEN + localpart(i + 1) = localpart(i + 1) + 1 + END IF + END DO + + IF(ALLOCATED(tlglob_arr)) DEALLOCATE(tlglob_arr) + IF(ALLOCATED(trglob_arr)) DEALLOCATE(trglob_arr) + ALLOCATE (tlglob_arr(nranks), trglob_arr(nranks)) + + tlglob_arr(1) = 1 + DO i = 2, nranks + tlglob_arr(i) = tlglob_arr(i - 1) + localpart(i - 1) + END DO + DO i = 1, nranks + trglob_arr(i) = tlglob_arr(i) + localpart(i) - 1 + END DO + + DEALLOCATE (localpart) + + CALL ComputeNSAllGatherParameters(nranks) + CALL ComputeBlockAllGatherParameters(nranks) + CALL ComputeNTmaxBlockAllGatherParameters(nranks) + + END SUBROUTINE SetSurfacePartitionArrays + !------------------------------------------------ + + !------------------------------------------------ + ! Compute AllGather vector variant parameters for + ! blocksized movements. + !------------------------------------------------ + SUBROUTINE ComputeNTmaxBlockAllGatherParameters(activeranks) + + INTEGER :: activeranks + INTEGER :: i + IF(.NOT.ALLOCATED(ntblkrcounts)) ALLOCATE(ntblkrcounts(activeranks)) + IF(.NOT.ALLOCATED(ntblkdisp)) ALLOCATE(ntblkdisp(activeranks)) + DO i = 1, activeranks + ntblkrcounts(i) = (trglob_arr(i) - tlglob_arr(i) + 1)*ntmaxblocksize + END DO + ntblkdisp(1) = 0 + DO i = 2, activeranks + ntblkdisp(i) = ntblkdisp(i - 1) + ntblkrcounts(i - 1) + END DO + END SUBROUTINE ComputeNTmaxBlockAllGatherParameters + !------------------------------------------------ + + !------------------------------------------------ + ! Compute AllGather vector variant parameters for + ! blocksized movements. + !------------------------------------------------ + SUBROUTINE ComputeBlockAllGatherParameters(activeranks) + + INTEGER :: activeranks + INTEGER :: i + IF(.NOT.ALLOCATED(blkrcounts)) ALLOCATE(blkrcounts(activeranks)) + IF(.NOT.ALLOCATED(blkdisp)) ALLOCATE(blkdisp(activeranks)) + DO i = 1, activeranks + blkrcounts(i) = (trglob_arr(i) - tlglob_arr(i) + 1)*blocksize + END DO + blkdisp(1)=0 + DO i = 2, activeranks + blkdisp(i) = blkdisp(i - 1) + blkrcounts(i - 1) + END DO + END SUBROUTINE ComputeBlockAllGatherParameters + !------------------------------------------------ + + !------------------------------------------------ + ! Compute AllGather vector variant parameters for + ! blocksized movements. + !------------------------------------------------ + SUBROUTINE ComputeNSAllGatherParameters(activeranks) + + INTEGER :: activeranks + INTEGER :: i + IF(.NOT.ALLOCATED(nsrcounts)) ALLOCATE(nsrcounts(activeranks)) + IF(.NOT.ALLOCATED(nsdisp)) ALLOCATE(nsdisp(activeranks)) + DO i = 1, activeranks + nsrcounts(i) = (trglob_arr(i) - tlglob_arr(i) + 1) + END DO + nsdisp(1) = 0 + DO i = 2, activeranks + nsdisp(i) = nsdisp(i - 1) + nsrcounts(i - 1) + END DO + END SUBROUTINE ComputeNSAllGatherParameters + !------------------------------------------------ + + !-------------------------------------------------------------------------- + SUBROUTINE FinalizeSurfaceComm(INCOMM) + + INTEGER, INTENT(INOUT) :: INCOMM +#if defined(MPI_OPT) + CALL MPI_Comm_free(INCOMM, MPI_ERR) + lactive = .FALSE. + IF (ALLOCATED(ntblkrcounts)) DEALLOCATE(ntblkrcounts) + IF (ALLOCATED(ntblkdisp)) DEALLOCATE(ntblkdisp) + IF (ALLOCATED(blkrcounts)) DEALLOCATE(blkrcounts) + IF (ALLOCATED(blkdisp)) DEALLOCATE(blkdisp) + IF (ALLOCATED(nsrcounts)) DEALLOCATE(nsrcounts) + IF (ALLOCATED(nsdisp)) DEALLOCATE(nsdisp) +#endif + END SUBROUTINE FinalizeSurfaceComm + !-------------------------------------------------------------------------- + + !-------------------------------------------------------------------------- + SUBROUTINE FinalizeRunVmec(INCOMM) + + INTEGER, INTENT(INOUT) :: INCOMM +#if defined(MPI_OPT) + CALL MPI_Comm_free(INCOMM, MPI_ERR) + IF(LIFFREEB) CALL MPI_Comm_free(VAC_COMM,MPI_ERR) + INCOMM=0 + VAC_COMM = 0 + rank = 0 + IF (.not.LV3FITCALL) par_ns = 0 + nranks = 1 + grank = 0 + gnranks = 1 + vrank = 0 + vnranks = 1 + last_ns = -1 + NS_RESLTN=0 + vlactive = .FALSE. +#endif + END SUBROUTINE FinalizeRunVmec + !-------------------------------------------------------------------------- + + !------------------------------------------------ + ! Setting up the communicator for parallel vacuum + ! computations + ! nuv = nzeta*ntheta1 + ! nuv3 = nzeta*ntheta3 + !------------------------------------------------ + SUBROUTINE SetVacuumCommunicator(nuv, nuv3, mgs) + + INTEGER, INTENT(IN) :: nuv, nuv3, mgs + INTEGER :: num_active, color, mypart + + par_nuv3 = nuv3 + par_nuv = nuv +#if defined(MPI_OPT) + num_active = MIN(gnranks, par_nuv3) + + IF(grank .LT. num_active) THEN + color = 1 + ELSE + color = 0 + END IF + CALL MPI_Comm_split(RUNVMEC_COMM_WORLD, color, grank, VAC_COMM, & + MPI_ERR) + IF (color .eq. 1) THEN + CALL MPI_Comm_rank(VAC_COMM,vrank,MPI_ERR) + CALL MPI_Comm_size(VAC_COMM,vnranks,MPI_ERR) + CALL SetVacuumPartitions(nuv3,nuv3min, nuv3max) + CALL Setnuv3PartitionArrays + vlactive=.TRUE. + ELSE + vnranks = 1 + vrank = 0 + vlactive=.FALSE. + END IF +#else + nuv3min = 1 + nuv3max = nuv3 +#endif + END SUBROUTINE SetVacuumCommunicator + !------------------------------------------------ + + + !------------------------------------------------ + ! Setting up the partitions for parallel vacuum + ! computations + !------------------------------------------------ + SUBROUTINE SetVacuumPartitions(num, left, right) + + INTEGER, INTENT(IN) :: num + INTEGER, INTENT(INOUT) :: left, right + INTEGER :: mypart + + IF (num.LT.vnranks) THEN + IF(grank.EQ.0) print *,"NUM is less than VNRANKS. Aborting!" + CALL STOPMPI(456745) + END IF + + mypart = num/vnranks + IF (vrank .LT. MOD(num,vnranks)) mypart = mypart + 1 + IF (MOD(num,vnranks).NE.0) THEN + IF (vrank.LT.MOD(num,vnranks)) THEN + left = vrank*mypart + ELSE IF (vrank.GE.MOD(num,vnranks)) THEN + left = MOD(num,vnranks)*(mypart + 1) & + + (vrank - MOD(num,vnranks))*mypart + END IF + ELSE + left = vrank*mypart + END IF + + left = left + 1 + right = left + mypart - 1 + + END SUBROUTINE SetVacuumPartitions + !------------------------------------------------ + + !------------------------------------------------ + ! Setting up the partition arrays for parallel vacuum + ! computations + !------------------------------------------------ + SUBROUTINE Setnuv3PartitionArrays + + INTEGER, ALLOCATABLE, DIMENSION(:) :: localpart + INTEGER :: i, smallpart, largepart + + IF (.NOT.ALLOCATED(nuv3min_arr)) THEN + ALLOCATE(nuv3min_arr(vnranks), nuv3max_arr(vnranks)) + END IF + + smallpart = par_nuv3/vnranks + largepart = smallpart + IF (MOD(par_nuv3,vnranks).GT.0) THEN + largepart = largepart+1 + END IF + + ALLOCATE (localpart(vnranks)) + DO i = 0, vnranks - 1 + + localpart(i + 1) = smallpart + + IF (MOD(par_nuv3, vnranks) .GT. 0 .AND. & + i .LT. MOD(par_nuv3, vnranks)) THEN + localpart(i + 1) = localpart(i + 1) + 1 + END IF + END DO + + nuv3min_arr(1) = 1 + DO i = 2, vnranks + nuv3min_arr(i) = nuv3min_arr(i - 1) + localpart(i - 1) + END DO + DO i = 1, vnranks + nuv3max_arr(i) = nuv3min_arr(i) + localpart(i) - 1 + END DO + + DEALLOCATE (localpart) + + END SUBROUTINE Setnuv3PartitionArrays + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE FinalizeParallel + + INTEGER :: istat + + envvar = 'LPRECOND' + CALL GETENV(envvar, envval) + IF (envval .EQ. 'TRUE') THEN + LPRECOND = .TRUE. + ELSE IF (envval .EQ. 'FALSE') THEN + LPRECOND=.FALSE. + END IF + + IF (grank.EQ.0) THEN + WRITE(*,*) + WRITE(*,'(1x,a,i4)') 'NO. OF PROCS: ',gnranks + WRITE(*,100) 'PARVMEC : ',PARVMEC + WRITE(*,100) 'LPRECOND : ',LPRECOND + WRITE(*,100) 'LV3FITCALL : ',LV3FITCALL + END IF + 100 FORMAT(1x,a,l4) + +#if defined(MPI_OPT) + CALL MPI_Finalize(istat) +#endif + END SUBROUTINE FinalizeParallel + !------------------------------------------------ + + !------------------------------------------------ + ! Print debugging output to compare aray values + !------------------------------------------------ + SUBROUTINE PrintNSArray(arr, left, right, fileno, ifstop, string) + + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: ifstop + REAL(dp), DIMENSION (par_ns + 1), INTENT(IN) :: arr + CHARACTER*(*), INTENT(IN) :: string + + INTEGER :: i + +#if defined(_WIN32) + RETURN +#endif + + DO i=left, right + WRITE(fileno + rank,50) string, i, arr(i) + CALL FLUSH(fileno+rank) + END DO + WRITE(fileno+rank,*) + CALL FLUSH(fileno+rank) + IF(ifstop) STOP 'STOPPED CODE' + + 50 FORMAT(A6,1I6,1P,E20.6) + + END SUBROUTINE PrintNSArray + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE STOPMPI(code) + + INTEGER, INTENT(IN) :: code + +#if defined(MPI_OPT) + CALL MPI_Barrier(MPI_COMM_WORLD, MPI_ERR) +#endif + WRITE(*,*) 'Stopping program with code:', code + STOP + END SUBROUTINE STOPMPI + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE Parallel2Serial4X(inarr,outarr) + + REAL(dp), INTENT(IN) :: inarr(par_ns*(par_ntor+1)*(par_mpol1+1)*3*(par_ntmax)) + REAL(dp), INTENT(OUT) :: outarr(par_ns*(par_ntor+1)*(par_mpol1+1)*3*(par_ntmax)) + INTEGER :: i, j, k, l, lk, lks, lkp + + lks=0 + DO l=1, 3*par_ntmax + DO k=0, par_mpol1 + DO j=0, par_ntor + DO i=1, par_ns + lks = lks +1 + lkp = j + (par_ntor + 1)*k & + + (par_ntor + 1)*(par_mpol1 + 1)*(i - 1) & + + (par_ntor + 1)*(par_mpol1 + 1)*par_ns*(l - 1) + 1 + outarr(lks) = inarr(lkp) + END DO + END DO + END DO + END DO + + END SUBROUTINE Parallel2Serial4X + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE Serial2Parallel4X (inarr,outarr) + + REAL(dp), INTENT(IN) :: inarr(par_ns*(par_ntor+1)*(par_mpol1+1)*3*(par_ntmax)) + REAL(dp), INTENT(OUT) :: outarr(par_ns*(par_ntor+1)*(par_mpol1+1)*3*(par_ntmax)) + INTEGER :: i, j, k, l, lk, lks, lkp + + lks=0 + DO l=1, 3*par_ntmax + DO k=0, par_mpol1 + DO j=0, par_ntor + DO i=1, par_ns + lks = lks+1 + lkp = j + (par_ntor + 1)*k & + + (par_ntor + 1)*(par_mpol1 + 1)*(i - 1) & + + (par_ntor + 1)*(par_mpol1 + 1)*par_ns*(l - 1) + 1 + outarr(lkp) = inarr(lks) + END DO + END DO + END DO + END DO + + END SUBROUTINE Serial2Parallel4X + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE Parallel2Serial2X(inarr, outarr) + + REAL(dp), DIMENSION(par_nzeta,par_ntheta3,par_ns), INTENT(IN) :: inarr + REAL(dp), DIMENSION(par_ns*par_nzeta*par_ntheta3+1), INTENT(OUT) :: outarr + INTEGER :: i, j, k, l + + l=0 + DO k = 1, par_ntheta3 + DO j = 1, par_nzeta + DO i = 1, par_ns + l = l + 1 + outarr(l) = inarr(j,k,i) + END DO + END DO + END DO + + END SUBROUTINE Parallel2Serial2X + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE RPrintOutLinearArray(arr, left, right, flag, fileno) + + REAL(dp), DIMENSION(:) :: arr + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: flag !flag: TRUE for parallel, FALSE for serial + INTEGER :: i, j, k, l, lk + + REAL(dp), ALLOCATABLE, DIMENSION(:) :: tmp + ALLOCATE(tmp(ntmaxblocksize*par_ns)) + + CALL tolastntype(arr,tmp) + lk = 0 + DO l = 1, 3*par_ntmax + DO k = 0, par_mpol1 + DO j = 0, par_ntor + DO i = 1, par_ns + lk = lk + 1 + IF (flag) THEN + lk = j + nmax*(k + mmax*((i - 1) + par_ns*(l - 1))) + 1 + END IF + IF (left .LE. i .AND. i .LE. right) THEN + WRITE(fileno+rank,50) i, j, k, l, tmp(lk) + CALL FLUSH(fileno+rank) + END IF + END DO + END DO + END DO + END DO + DEALLOCATE(tmp) + + 50 FORMAT(4I6,1P,E24.14) + + END SUBROUTINE RPrintOutLinearArray + !------------------------------------------------ + + + !------------------------------------------------ + SUBROUTINE PrintOutLinearArray(arr, left, right, flag, fileno) + + REAL(dp), DIMENSION(ntmaxblocksize*par_ns) :: arr + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: flag !flag: TRUE for parallel, FALSE for serial + INTEGER :: i, j, k, l, lk + + lk=0 + DO l = 1, 3*par_ntmax + DO k = 0, par_mpol1 + DO j = 0, par_ntor + DO i = 1, par_ns + lk=lk + 1 + IF(flag) THEN + lk = j + nmax*(k + mmax*((i - 1) + par_ns*(l-1)))+1 + END IF + IF (left .LE. i .AND. i .LE. right) THEN + WRITE(fileno+rank,50) i, j, k, l, arr(lk) + CALL FLUSH(fileno+rank) + END IF + END DO + END DO + END DO + END DO + + 50 FORMAT(4I6,1P,E24.14) + + END SUBROUTINE PrintOutLinearArray + !------------------------------------------------ + + !------------------------------------------------ + ! Prints out [nsmin, nsmax] part of a (nzeta, ntheta,ns) array + !------------------------------------------------ + SUBROUTINE PrintParallelIJSPArray (arr, left, right, fileno, ifstop, string) + + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: ifstop + REAL(dp), DIMENSION (par_nzeta,par_ntheta3,par_ns), INTENT(IN) :: arr + CHARACTER*(*), INTENT(IN) :: string + + INTEGER :: i, j, k + + DO i=left, right + DO j=1, par_nzeta + DO k=1, par_ntheta3 + WRITE(fileno+rank,50) string, i, j, k, arr(j,k,i) + CALL FLUSH(fileno+rank) + END DO + END DO + END DO + WRITE(fileno+rank,*) + CALL FLUSH(fileno+rank) + IF(ifstop) STOP 'STOPPED PARALLEL CODE' + 50 FORMAT(A,3I6,1P,E24.14) + + END SUBROUTINE PrintParallelIJSPArray + !------------------------------------------------ + + !------------------------------------------------ + ! Prints out [nsmin, nsmax] part of a (ns, nzeta, ntheta) array + !------------------------------------------------ + SUBROUTINE PrintSerialIJSPArray (arr, left, right, fileno, ifstop, string) + + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: ifstop + REAL(dp), DIMENSION (par_ns,par_nzeta,par_ntheta3), INTENT(IN) :: arr + CHARACTER*(*), INTENT(IN) :: string + + INTEGER :: i, j, k + + DO i = left, right + DO j = 1, par_nzeta + DO k = 1, par_ntheta3 + WRITE(fileno+rank,50) string, i, j, k, arr(i, j, k) + CALL FLUSH(fileno+rank) + END DO + END DO + END DO + WRITE(fileno+rank,*) + CALL FLUSH(fileno+rank) + IF(ifstop) STOP 'STOPPED SERIAL CODE' + 50 FORMAT(A,3I6,1P,E24.14) + + END SUBROUTINE PrintSerialIJSPArray + !------------------------------------------------ + + !------------------------------------------------ + ! Prints out [nsmin, nsmax] part of a (ntor,mpol1,ns) array + !------------------------------------------------ + SUBROUTINE PrintParallelMNSPArray (arr, left, right, fileno, ifstop, string) + + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: ifstop + REAL(dp), DIMENSION (0:par_ntor,0:par_mpol1,1:par_ns), INTENT(IN) :: arr + CHARACTER*(*), INTENT(IN) :: string + + INTEGER :: i, j, k + + DO i=left, right + DO j=0, par_mpol1 + DO k=0, par_ntor + WRITE(fileno+rank,50) string, i, j, k, arr(k,j,i) + CALL FLUSH(fileno+rank) + END DO + END DO + END DO + WRITE(fileno+rank,*) + CALL FLUSH(fileno+rank) + IF(ifstop) STOP 'STOPPED PARALLEL CODE' + 50 FORMAT(A,3I6,1P,E20.12) + + END SUBROUTINE PrintParallelMNSPArray + !------------------------------------------------ + + !------------------------------------------------ + ! Prints out [nsmin, nsmax] part of a (ns, ntor, mpol1) array + !------------------------------------------------ + SUBROUTINE PrintSerialMNSPArray (arr, left, right, fileno, ifstop, string) + + INTEGER, INTENT(IN) :: fileno, left, right + LOGICAL, INTENT(IN) :: ifstop + REAL(dp), DIMENSION (1:par_ns,0:par_ntor,0:par_mpol1), INTENT(IN) :: arr + CHARACTER*(*), INTENT(IN) :: string + + INTEGER :: i, j, k + + DO i=left, right + DO k=0, par_mpol1 + DO j=0, par_ntor + WRITE(fileno+rank,50) string, i, j, k, arr(i, j, k) + CALL FLUSH(fileno+rank) + END DO + END DO + END DO + WRITE(fileno+rank,*) + CALL FLUSH(fileno+rank) + IF(ifstop) STOP 'STOPPED SERIAL CODE' + 50 FORMAT(A,3I6,1P,E20.12) + + END SUBROUTINE PrintSerialMNSPArray + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE Gather4XArray(arr) + !----------------------------------------------- + + !----------------------------------------------- + REAL(dp), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax), INTENT(INOUT) :: arr + INTEGER :: i + INTEGER :: blksize, numjs + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp), ALLOCATABLE, DIMENSION(:,:,:,:) :: sendbuf + REAL(dp), ALLOCATABLE, DIMENSION(:) :: recvbuf + REAL(dp) :: allgvton, allgvtoff + !----------------------------------------------- + IF (nranks.EQ.1 .OR. .NOT.lactive) THEN + RETURN + END IF + + CALL second0(allgvton) + + blksize = (par_ntor + 1)*(par_mpol1 + 1)*3*par_ntmax + numjs = trglob - tlglob + 1 + ALLOCATE(sendbuf(0:par_ntor,0:par_mpol1,numjs,1:3*par_ntmax)) + ALLOCATE(recvbuf(par_ns*blksize)) + ALLOCATE(counts(nranks),disps(nranks)) + + DO i = 1, nranks + counts(i) = (trglob_arr(i) - tlglob_arr(i) + 1)*blksize + END DO + + disps(1) = 0 + DO i = 2, nranks + disps(i) = disps(i - 1) + counts(i - 1) + END DO +#if defined(MPI_OPT) + sendbuf(0:par_ntor,0:par_mpol1,1:numjs,1:3*par_ntmax) = & + arr(0:par_ntor,0:par_mpol1,tlglob:trglob,1:3*par_ntmax) + CALL MPI_Allgatherv(sendbuf, numjs*blksize, MPI_REAL8, recvbuf, & + counts, disps, MPI_REAL8, NS_COMM, MPI_ERR) + DO i = 1, nranks + numjs = trglob_arr(i) - tlglob_arr(i) + 1 + arr(0:par_ntor,0:par_mpol1,tlglob_arr(i):trglob_arr(i),1:3*par_ntmax) = & + RESHAPE(recvbuf(disps(i)+1:disps(i)+counts(i)), & + (/par_ntor+1,par_mpol1+1,numjs,3*par_ntmax/)) + END DO +#endif + DEALLOCATE(sendbuf, recvbuf) + DEALLOCATE(counts, disps) + CALL second0(allgvtoff) + allgather_time = allgather_time + (allgvtoff-allgvton) + END SUBROUTINE Gather4XArray + !------------------------------------------------ + + !------------------------------------------------ + ! + !------------------------------------------------ + SUBROUTINE GatherReordered4XArray(arr) + !----------------------------------------------- + + !----------------------------------------------- + REAL(dp), DIMENSION(0:par_ntor,0:par_mpol1,3*par_ntmax,par_ns), INTENT(INOUT) :: arr + INTEGER :: i + INTEGER :: blksize, numjs + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp) :: allgvton, allgvtoff + !----------------------------------------------- + IF (nranks.EQ.1 .OR. .NOT.lactive) THEN + RETURN + END IF + + CALL second0(allgvton) + + blksize = (par_ntor + 1)*(par_mpol1 + 1)*3*par_ntmax + numjs = trglob - tlglob + 1 + ALLOCATE(counts(nranks),disps(nranks)) + + DO i = 1, nranks + counts(i) = (trglob_arr(i) - tlglob_arr(i) + 1)*blksize + END DO + + disps(1) = 0 + DO i = 2, nranks + disps(i) = disps(i - 1) + counts(i - 1) + END DO +#if defined(MPI_OPT) + CALL MPI_Allgatherv(MPI_IN_PLACE, numjs*blksize, MPI_REAL8, arr, & + counts, disps, MPI_REAL8, NS_COMM, MPI_ERR) +#endif + DEALLOCATE(counts, disps) + CALL second0(allgvtoff) + allgather_time = allgather_time + (allgvtoff-allgvton) + END SUBROUTINE GatherReordered4XArray + !------------------------------------------------ + + + !------------------------------------------------ + SUBROUTINE Gather2XArray(arr) + + REAL(dp), DIMENSION(par_nznt,par_ns), INTENT(INOUT) :: arr + INTEGER :: i + INTEGER :: par_nsmin, par_nsmax, blksize, numjs + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp) :: allgvton, allgvtoff + !----------------------------------------------- + IF (nranks.EQ.1 .OR. .NOT.lactive) THEN + RETURN + END IF + + CALL second0(allgvton) + + blksize = par_nznt + numjs = trglob - tlglob+1 + ALLOCATE(counts(nranks),disps(nranks)) + + DO i = 1, nranks + counts(i) =(trglob_arr(i) - tlglob_arr(i) + 1)*blksize + END DO + + disps(1) = 0 + DO i = 2, nranks + disps(i) = disps(i - 1) + counts(i - 1) + END DO + +#if defined(MPI_OPT) + CALL MPI_Allgatherv(MPI_IN_PLACE, numjs*blksize, MPI_REAL8, arr, & + counts, disps, MPI_REAL8, NS_COMM, MPI_ERR) +#endif + DEALLOCATE(counts, disps) + CALL second0(allgvtoff) + allgather_time = allgather_time + (allgvtoff-allgvton) + END SUBROUTINE Gather2XArray + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE Gather1XArray(arr) + !----------------------------------------------- + REAL(dp), DIMENSION(par_ns), INTENT(INOUT) :: arr + + INTEGER :: i, numjs + INTEGER, ALLOCATABLE, DIMENSION(:) :: counts, disps + REAL(dp) :: allgvton, allgvtoff + !----------------------------------------------- + IF (nranks.EQ.1 .OR. .NOT.lactive) THEN + RETURN + END IF + + CALL second0(allgvton) + + numjs = trglob - tlglob + 1 + ALLOCATE(counts(nranks),disps(nranks)) + + DO i=1,nranks + counts(i) = (trglob_arr(i) - tlglob_arr(i) + 1) + END DO + + disps(1)=0 + DO i = 2,nranks + disps(i)= disps(i - 1) +counts(i - 1) + END DO + +#if defined(MPI_OPT) + CALL MPI_Allgatherv(MPI_IN_PLACE, numjs, MPI_REAL8, arr, counts, & + disps, MPI_REAL8, NS_COMM, MPI_ERR) +#endif + DEALLOCATE(counts, disps) + CALL second0(allgvtoff) + allgather_time = allgather_time + (allgvtoff - allgvton) + END SUBROUTINE Gather1XArray + !------------------------------------------------ + + !------------------------------------------------ + !------------------------------------------------ + + !------------------------------------------------ + ! Setting the output files + !------------------------------------------------ + SUBROUTINE SetOutputFile(iam, nprocs, prefix) + + INTEGER, INTENT(IN) :: iam, nprocs + CHARACTER (*), INTENT(IN) :: prefix + INTEGER :: istat + CHARACTER(100) :: fname, cfname + CHARACTER(50) :: ciam, cnprocs + CHARACTER(25) :: cprefix + + WRITE(ciam,*) iam + WRITE(cnprocs,*) nprocs + WRITE(cprefix,*) prefix + ciam = ADJUSTL(ciam) + cnprocs = ADJUSTL(cnprocs) + cprefix = ADJUSTL(cprefix) + TOFU = 4*nprocs + iam + 1000 + + fname=TRIM(cprefix)//'.txt' + OPEN(UNIT=TOFU, FILE=fname, STATUS="REPLACE", ACTION="WRITE", & + FORM="FORMATTED",POSITION="APPEND", IOSTAT=istat) + + END SUBROUTINE SetOutputFile + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE tolastns(inarr, outarr) + REAL(dp), INTENT(IN), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: & + inarr + INTEGER :: i, j, k, l, cnt + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,par_ns) :: outarr + + DO i = t1lglob, t1rglob + cnt = 0 + DO l = 1, 3*par_ntmax + DO k = 0, par_mpol1 + DO j = 0, par_ntor + cnt = cnt + 1 + outarr(cnt,i) = inarr(j,k,i,l) + END DO + END DO + END DO + END DO + + END SUBROUTINE tolastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE tolastntype(inarr, outarr) + REAL(dp), INTENT(INOUT), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: outarr + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: inarr + INTEGER :: i, j, k, l, cnt + + DO i=t1lglob, t1rglob + cnt=0 + DO l=1, 3*par_ntmax + DO k=0, par_mpol1 + DO j=0, par_ntor + cnt=cnt+1 + outarr(j,k,i,l)=inarr(cnt,i) + END DO + END DO + END DO + END DO + END SUBROUTINE tolastntype + !------------------------------------------------ + + !------------------------------------------------ + ! + !------------------------------------------------ + SUBROUTINE copylastns(a1, a2) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: a1 + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,par_ns) :: a2 + a2(:,t1lglob:t1rglob) = a1(:,t1lglob:t1rglob) + END SUBROUTINE copylastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE copy1lastntype(a1, a2) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize*par_ns) :: a1 + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize*par_ns) :: a2 + CALL copy4lastntype(a1, a2) + END SUBROUTINE copy1lastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE copy4lastntype(a1, a2) + REAL(dp), INTENT(IN), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: a1 + REAL(dp), INTENT(INOUT), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: a2 + a2(:,:,t1lglob:t1rglob,:) = a1(:,:,t1lglob:t1rglob,:) + END SUBROUTINE copy4lastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE copym1lastntype(a1, a2, d1) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize*par_ns) :: a1 + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize*par_ns) :: a2 + REAL(dp), INTENT(IN) :: d1 + CALL copym4lastntype(a1, a2, d1) + END SUBROUTINE copym1lastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE copym4lastntype(a1, a2, d1) + REAL(dp), INTENT(IN), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: a1 + REAL(dp), INTENT(INOUT), DIMENSION(0:par_ntor,0:par_mpol1,par_ns,3*par_ntmax) :: a2 + REAL(dp), INTENT(IN) :: d1 + a2(:,:,t1lglob:t1rglob,:) = d1*a1(:,:,t1lglob:t1rglob,:) + END SUBROUTINE copym4lastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE saxlastns(a, x, vec) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: a, x + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,par_ns) :: vec + vec(:,tlglob:trglob) = a(:,tlglob:trglob)*x(:,tlglob:trglob) + END SUBROUTINE saxlastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE saxlastns1(a, x, vec) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,tlglob:trglob) :: a + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: x + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,tlglob:trglob) :: vec + vec(:,tlglob:trglob) = a(:,tlglob:trglob)*x(:,tlglob:trglob) + END SUBROUTINE saxlastns1 + + !------------------------------------------------ + SUBROUTINE saxlastntype(a, x, vec) + REAL(dp), INTENT(IN), DIMENSION(blocksize,par_ns,3*par_ntmax) :: a, x + REAL(dp), INTENT(INOUT), DIMENSION(blocksize,par_ns,3*par_ntmax) :: vec + vec(:,t1lglob:t1rglob,:) = a(:,t1lglob:t1rglob,:)*x(:,t1lglob:t1rglob,:) + END SUBROUTINE saxlastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE saxpbylastntype(a, x, b, y, vec) + REAL(dp), INTENT(IN), DIMENSION(blocksize,par_ns,3*par_ntmax) :: x, y + REAL(dp), INTENT(INOUT), DIMENSION(blocksize,par_ns,3*par_ntmax) :: vec + REAL(dp), INTENT(IN) :: a, b + vec(:,t1lglob:t1rglob,:) = a*x(:,t1lglob:t1rglob,:) + b*y(:,t1lglob:t1rglob,:) + END SUBROUTINE saxpbylastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE saxpbylastns(a, x, b, y, vec) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,tlglob:trglob) :: x + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: y + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,par_ns) :: vec + REAL(dp), INTENT(IN) :: a, b + vec(:,tlglob:trglob) = a*x(:,tlglob:trglob) + b*y(:,tlglob:trglob) + END SUBROUTINE saxpbylastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE saxpby1lastns(a, x, b, y, vec) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: x, y + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,par_ns) :: vec + REAL(dp), INTENT(IN) :: a, b + vec(:,tlglob:trglob) = a*x(:,tlglob:trglob) + b*y(:,tlglob:trglob) + END SUBROUTINE saxpby1lastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE getderivlastns(x1, x2, d1, vec) + REAL(dp), INTENT(IN), DIMENSION(ntmaxblocksize,par_ns) :: x1, x2 + REAL(dp), INTENT(INOUT), DIMENSION(ntmaxblocksize,tlglob:trglob) :: vec + REAL(dp), INTENT(IN) :: d1 + IF (d1 .eq. 0) RETURN + vec = (x1(:,tlglob:trglob) - x2(:,tlglob:trglob))/d1 + END SUBROUTINE getderivlastns + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE zerolastntype(a1) + REAL(dp), INTENT(INOUT), DIMENSION(blocksize,par_ns,3*par_ntmax) :: a1 + a1(:,t1lglob:t1rglob,:) = 0 + END SUBROUTINE zerolastntype + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE CopyParallelLinearSubarray(fromarr,toarr, first, last) + INTEGER, INTENT(IN) :: first, last + REAL(dp), INTENT(IN), DIMENSION(blocksize,par_ns,3*par_ntmax) :: fromarr + REAL(dp), INTENT(INOUT), DIMENSION(blocksize,par_ns,3*par_ntmax) :: toarr + toarr(:,first:last,:) = fromarr(:,first:last,:) + END SUBROUTINE CopyParallelLinearSubarray + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE PadSides(arr) + REAL(dp), INTENT(INOUT), DIMENSION(blocksize,par_ns,3*par_ntmax) :: arr + INTEGER :: left, right, tag1=1 + REAL(dp) :: ton, toff + + CALL second0(ton) + +#if defined(MPI_OPT) + left = rank - 1; IF(rank.EQ.0) left = MPI_PROC_NULL + right = rank + 1; IF(rank.EQ.nranks-1) right = MPI_PROC_NULL + CALL MPI_Sendrecv(arr(:,tlglob,:), ntmaxblocksize, MPI_REAL8, & + left, tag1, arr(:,t1rglob,:), ntmaxblocksize, MPI_REAL8, & + right, tag1, NS_COMM, MPI_STAT,MPI_ERR) + CALL MPI_Sendrecv(arr(:,trglob,:),ntmaxblocksize,MPI_REAL8, & + right, tag1, arr(:,t1lglob,:), ntmaxblocksize,MPI_REAL8, & + left, tag1, NS_COMM, MPI_STAT,MPI_ERR) +#endif + + CALL second0(toff) + sendrecv_time = sendrecv_time + (toff - ton) + + END SUBROUTINE PadSides + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE PadSides1X(arr) + REAL(dp), INTENT(INOUT), DIMENSION(par_ns) :: arr + INTEGER :: left, right, tag1 + REAL(dp) :: ton, toff + + tag1 = 1 + + CALL second0(ton) + +#if defined(MPI_OPT) + left=rank-1; IF(rank.EQ.0) left = MPI_PROC_NULL + right=rank+1; IF(rank.EQ.nranks - 1) right = MPI_PROC_NULL + + IF (grank .LT. nranks) THEN + CALL MPI_Sendrecv(arr(tlglob), 1, MPI_REAL8, left, tag1, & + arr(t1rglob), 1, MPI_REAL8, right, tag1, NS_COMM, & + MPI_STAT, MPI_ERR) + END IF +#endif + + CALL second0(toff) + sendrecv_time = sendrecv_time + (toff - ton) + + END SUBROUTINE PadSides1X + !------------------------------------------------ + + !------------------------------------------------ + SUBROUTINE CompareEdgeValues(pxc, pxsave) + REAL(dp), INTENT(IN), DIMENSION(blocksize,par_ns,3*par_ntmax) :: pxc, pxsave + + IF (rank .EQ. nranks - 1 .AND. & + ANY(pxc(:,par_ns,:) .NE. pxsave(:,par_ns,:))) THEN + PRINT *,' xsave != xc at edge returning from GMRES' + END IF + + END SUBROUTINE CompareEdgeValues + !------------------------------------------------ + +END MODULE parallel_vmec_module +!------------------------------------------------ diff --git a/Sources/TimeStep/restart.f b/Sources/TimeStep/restart.f new file mode 100644 index 0000000..983bc0a --- /dev/null +++ b/Sources/TimeStep/restart.f @@ -0,0 +1,56 @@ + SUBROUTINE restart_iter(time_step) + USE vmec_main + USE xstuff + USE parallel_include_module + USE parallel_vmec_module, ONLY: CopyLastNType, ZeroLastNtype + IMPLICIT NONE +!----------------------------------------------- +! D u m m y V a r i a b l e s +!----------------------------------------------- + REAL(dp) :: time_step +!----------------------------------------------- +! L o c a l P a r a m e t e r s +!----------------------------------------------- + REAL(dp), PARAMETER :: c1p03 = 1.03_dp, cp90 = 0.90_dp + REAL(dp) :: treston, trestoff +!----------------------------------------------- + CALL second0(treston) + + IF (PARVMEC) THEN + SELECT CASE (irst) + CASE DEFAULT + CALL CopyLastNType(pxc, pxstore) + RETURN + CASE (2:3) + CALL ZeroLastNtype(pxcdot) + CALL CopyLastNType(pxstore, pxc) + time_step = time_step*((irst-2)/c1p03 + cp90*(3-irst)) + IF (irst .eq. 2) THEN + ijacob = ijacob + 1 + iter1 = iter2 + END IF + irst = 1 + RETURN + END SELECT + ELSE + SELECT CASE (irst) + CASE DEFAULT + xstore(:neqs) = xc(:neqs) + RETURN + CASE (2:3) + xcdot(:neqs) = zero + xc(:neqs) = xstore(:neqs) + time_step = time_step*((irst-2)/c1p03 + cp90*(3-irst)) + IF (irst .eq. 2) THEN + ijacob = ijacob + 1 + iter1 = iter2 + END IF + irst = 1 + RETURN + END SELECT + END IF + + CALL second0(trestoff) + restart_time = restart_time + (trestoff - treston) + + END SUBROUTINE restart_iter diff --git a/Sources/TimeStep/runvmec.f b/Sources/TimeStep/runvmec.f new file mode 100644 index 0000000..3df7505 --- /dev/null +++ b/Sources/TimeStep/runvmec.f @@ -0,0 +1,409 @@ + SUBROUTINE runvmec(ictrl_array, input_file0, + & lscreen, COMM_WORLD, reset_file_name) + USE vmec_main + USE vmec_params, ONLY: bad_jacobian_flag, more_iter_flag, + & norm_term_flag, successful_term_flag, + & restart_flag, readin_flag, + & timestep_flag, ns_error_flag, + & reset_jacdt_flag, lamscale + USE realspace + USE vmec_params, ONLY: ntmax + USE vacmod, ONLY: nuv, nuv3 + USE timer_sub + USE parallel_include_module + USE parallel_vmec_module, ONLY: MyEnvVariables + USE parallel_vmec_module, ONLY: InitRunVmec + USE parallel_vmec_module, ONLY: FinalizeRunVmec + USE parallel_vmec_module, ONLY: InitSurfaceComm + USE parallel_vmec_module, ONLY: FinalizeSurfaceComm + USE parallel_vmec_module, ONLY: SetVacuumCommunicator + USE blocktridiagonalsolver_bst, ONLY: Initialize_bst + USE blocktridiagonalsolver_bst, ONLY: Finalize_bst + USE xstuff + USE mpi_inc + IMPLICIT NONE +C----------------------------------------------- +C D u m m y A r g u m e n t s +C----------------------------------------------- + INTEGER, INTENT(inout), TARGET :: ictrl_array(5) + LOGICAL, INTENT(in) :: lscreen + CHARACTER(LEN=*), INTENT(in) :: input_file0 + CHARACTER(LEN=*), OPTIONAL :: reset_file_name + INTEGER, INTENT(IN), OPTIONAL :: COMM_WORLD +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER, POINTER :: ier_flag + INTEGER :: ictrl_flag, iseq_count + INTEGER :: ns_index, ns_min, nsval, + & ns_old=0, numsteps + INTEGER :: igrid, index_end, index_dat, + & jacob_off, niter_store + INTEGER, SAVE :: igrid0 + INTEGER :: max_grid_size, flag + CHARACTER(LEN=120) :: input_file + LOGICAL :: lreset + REAL(dp) :: rvton, rvtoff, tiniton, tinitoff + REAL(dp) :: gridton, gridtoff + REAL(dp) :: bcastton, bcasttoff + REAL(dp), ALLOCATABLE, DIMENSION(:) :: bcastarr + INTEGER :: blklength, grid_id, i, js, + & nsmin, nsmax + CHARACTER(LEN=20) :: fname + +C----------------------------------------------- +! +! ictrl_flag = ictrl_array(1) +! flag that controls calling of various subroutines of vmec code +! add together the values beow to utilize several subroutines with one call +! +! value flag-name calls routines to... +! ----- --------- --------------------- +! 1 restart_flag reset internal run-control parameters (for example, if +! jacobian was bad, to try a smaller time-step) +! 2 readin_flag read in data from input_file and initialize parameters/arrays +! which do not dependent on radial grid size +! allocate internal grid-dependent arrays used by vmec; +! initialize internal grid-dependent vmec profiles (xc, iota, etc); +! setup loop for radial multi-grid meshes or, if ns_index = ictrl_array(4) +! is > 0, use radial grid points specified by ns_array[ns_index] +! 4 timestep_flag iterate vmec either by "niter" time steps or until ftol satisfied, +! whichever comes first. If numsteps (see below) > 0, vmec will return +! to caller after numsteps, rather than niter, steps. +! 8 output_flag write out output files (wout, jxbout) +! 16 cleanup_flag cleanup (deallocate arrays) - this terminates present run of the sequence +! This flag will be ignored if the run might be continued. For example, +! if ier_flag (see below) returns the value more_iter_flag, the cleanup +! code will be skipped even if cleanup_flag is set, so that the run +! could be continued on the next call to runvmec. +! 32 reset_jacdt_flag Resets ijacobian flag and time step to delt0 +! +! thus, setting ictrl_flag = 1+2+4+8+16 will perform ALL the tasks thru cleanup_flag +! in addition, if ns_index = 0 and numsteps = 0 (see below), vmec will control its own run history +! +! ier_flag = ictrl_array(2) +! specifies vmec error condition (if nonzero) +! numsteps = ictrl_array(3) +! number time steps to evolve the equilibrium. Iterations will stop EITHER if numsteps > 0 and +! when the number of vmec iterations exceeds numsteps; OR if the ftol condition is satisfied, +! whichever comes first. The timestep_flag must be set (in ictrl_flag) for this to be in effect. +! If numsteps <= 0, then vmec will choose consecutive (and increasing) values from the ns_array +! until ftol is satisfied on each successive multi-grid. +! ns_index = ictrl_array(4) +! if > 0 on entry, specifies index (in ns_array) of the radial grid to be used for the present iteration +! phase. If ns_index <= 0, vmec will use the previous value of this index (if the ftol +! condition was not satisfied during the last call to runvmec) or the next value of this index, +! and it will iterate through each successive non-zero member of the ns_array until ftol-convergence +! occurs on each multigrid. +! on exit, contains last value of ns_array index used +! iseq_count=ictrl_array(5) +! specifies a unique sequence label for identifying output files in a sequential vmec run +C----------------------------------------------- + INTERFACE + SUBROUTINE initialize_radial(nsval, ns_old, delt0, + & lscreen, reset_file_name) + USE vmec_main + IMPLICIT NONE + INTEGER, INTENT(in) :: nsval + INTEGER, INTENT(inout) :: ns_old + CHARACTER(LEN=*), OPTIONAL :: reset_file_name + LOGICAL, INTENT(in) :: lscreen + REAL(rprec), INTENT(out) :: delt0 + END SUBROUTINE initialize_radial + END INTERFACE + + RUNVMEC_PASS = RUNVMEC_PASS + 1 + CALL second0(rvton) + CALL MyEnvVariables + CALL InitRunVmec(COMM_WORLD,lfreeb) + LV3FITCALL = l_v3fit + IF (LV3FITCALL) THEN + IF (RUNVMEC_PASS.GT.1) THEN + CALL Serial2Parallel4X(xc,pxc) + CALL Serial2Parallel4X(xcdot,pxcdot) + CALL Serial2Parallel4X(xstore,pxstore) + CALL second0(bcastton) + CALL MPI_Bcast(pxc,SIZE(pxc), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(pxcdot, SIZE(pxcdot), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(pxstore, SIZE(pxstore), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(iotas, SIZE(iotas), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(iotaf, SIZE(iotaf), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(phips, SIZE(phips), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(phipf, SIZE(phipf), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(chips, SIZE(chips), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(chipf, SIZE(chipf), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(mass, SIZE(mass), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(icurv, SIZE(icurv), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(lamscale, 1, MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + + nsmin = t1lglob; nsmax = t1rglob + DO js = nsmin, nsmax + pphip(:,js) = phips(js) + pchip(:,js) = chips(js) + END DO + + CALL second0(bcasttoff) + broadcast_time = broadcast_time + (bcasttoff - bcastton) + END IF + END IF + + ictrl_flag = ictrl_array(1) + numsteps = ictrl_array(3) + ier_flag => ictrl_array(2) + ns_index = ictrl_array(4) + iseq_count = ictrl_array(5) + CALL second0(timeon) + +! +! PARSE input_file into path/input.ext +! + index_dat = INDEX(input_file0, 'input.') + index_end = LEN_TRIM(input_file0) + IF (index_dat .gt. 0) THEN + input_file = TRIM(input_file0) + input_extension = input_file0(index_dat+6:index_end) + ELSE + input_extension = input_file0(1:index_end) + input_file = 'input.'//TRIM(input_extension) + END IF + +! +! INITIALIZE PARAMETERS +! + lreset = (IAND(ictrl_flag, restart_flag) .ne. 0) + + IF (lreset) THEN + CALL reset_params +! res0 = -1 Done in reset_params + END IF + + IF (IAND(ictrl_flag, reset_jacdt_flag) .NE. 0) THEN + ijacob = 0 + delt0r = delt + END IF + + IF (IAND(ictrl_flag, readin_flag) .NE. 0) THEN +! +! READ INPUT FILE (INDATA NAMELIST), MGRID_FILE (VACUUM FIELD DATA) +! + CALL vsetup (iseq_count) + + CALL readin (input_file, iseq_count, ier_flag, lscreen) + max_grid_size = ns_array(multi_ns_grid) + + IF (ier_flag .NE. 0) GOTO 1000 +! +! COMPUTE NS-INVARIANT ARRAYS +! + CALL fixaray + END IF + +! IF(lfreeb) CALL SetVacuumCommunicator(nuv, nuv3, max_grid_size) + + IF (lreset) THEN +! +! COMPUTE INITIAL SOLUTION ON COARSE GRID +! IF PREVIOUS SEQUENCE DID NOT CONVERGE WELL +! +! IF (lreseta) THEN !NOTE: where externally, lreseta = T, set restart_flag bit +! (ictrl_flag = IOR(ictrl_flag,restart_flag)) + igrid0 = 1 + ns_old = 0 + IF (PRESENT(reset_file_name) .AND. + & LEN_TRIM(reset_file_name) .ne. 0) THEN + igrid0 = multi_ns_grid + END IF + IF (grank .EQ. 0) WRITE (nthreed, 30) + delt0r = delt + END IF + + 30 FORMAT(' FSQR, FSQZ = Normalized Physical Force Residuals',/, + & ' fsqr, fsqz = Preconditioned Force Residuals',/, + & 1x,23('-'),/, ' BEGIN FORCE ITERATIONS',/,1x,23('-'),/) + + IF (ALL(ns_array .eq. 0) .and. ns_index .le. 0) THEN + ier_flag = ns_error_flag + GOTO 1000 + END IF + + jacob_off = 0 + + IF (IAND(ictrl_flag, timestep_flag) .EQ. 0) GOTO 1000 + + IF(lfreeb) CALL SetVacuumCommunicator(nuv, nuv3, max_grid_size) !SAL 070719 + + 50 CONTINUE + iequi = 0 + IF (lfreeb .and. jacob_off .eq. 1) ivac = 1 !!restart vacuum calculations + + ns_min = 3 + + num_grids = multi_ns_grid + IF(.NOT.ALLOCATED(grid_procs)) THEN + ALLOCATE(grid_procs(num_grids)) + ALLOCATE(grid_size(num_grids)) + ALLOCATE(grid_time(num_grids)) + ALLOCATE(f3d_time(num_grids)) + ALLOCATE(f3d_num(num_grids)) + IF (lfreeb) ALLOCATE(vgrid_time(num_grids)) + END IF + + f3d_time = 0; f3d_num=0 + blklength = (ntor + 1)*(mpol1 + 1) + !BEGIN - Main loop that will be parallelized - SKS + grid_id = 1 + old_vacuum_time = 0 + + DO igrid = igrid0 - jacob_off, multi_ns_grid + CALL second0(gridton) + + IF (igrid .lt. igrid0) THEN +! TRY TO GET NON-SINGULAR JACOBIAN ON A 3 PT RADIAL MESH + nsval = 3; ivac = -1 + ftolv = 1.e-4_dp + ELSE IF (ns_index .gt. 0) THEN + IF (ns_index .gt. SIZE(ns_array)) THEN + ier_flag = ns_error_flag + RETURN + END IF + nsval = ns_array(ns_index) + IF (nsval .le. 0) STOP 'NSVAL <= 0: WRONG INDEX VALUE' + ftolv = ftol_array(ns_index) + niter = niter_array(ns_index) + ELSE + nsval = ns_array(igrid) + IF (nsval .lt. ns_min) CYCLE + ns_min = nsval + ictrl_array(4) = igrid + ftolv = ftol_array(igrid) + niter = niter_array(igrid) + END IF + + CALL second0(tiniton) + IF (PARVMEC .AND. NS_RESLTN .GE. 1) THEN + IF (lactive) THEN + CALL Gather4XArray(pscalxc) + CALL Gather4XArray(pxc) + END IF + CALL FinalizeSurfaceComm(NS_COMM) + + CALL second0(bcastton) + CALL MPI_Bcast(pscalxc, SIZE(pscalxc), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL MPI_Bcast(pxc, SIZE(pxc), MPI_REAL8, 0, + & RUNVMEC_COMM_WORLD, MPI_ERR) + CALL second0(bcasttoff) + broadcast_time = broadcast_time + (bcasttoff - bcastton) + END IF + + CALL InitSurfaceComm(nsval, nzeta, ntheta3, ntmax, ntor, mpol1) + CALL second0(tinitoff) + init_parallel_time = init_parallel_time + (tinitoff-tiniton) + + grid_size(grid_id) = nsval + grid_procs(grid_id) = nranks + +! JDH 2012-06-20. V3FIT fix, inserted with change from VMEC 8.48 -> 8.49 +! (Not sure just what in initialize_radial messes up convergence - happens slowly) +! Logical l_v3fit is declared in vmec_input, available via vmec_main + IF (l_v3fit .AND. ns_old .ne. nsval) THEN + CALL initialize_radial(nsval, ns_old, delt0r, lscreen, + & reset_file_name) + ELSE IF (ns_old .le. nsval) THEN + CALL initialize_radial(nsval, ns_old, delt0r, lscreen, + & reset_file_name) + END IF + + CALL Initialize_bst(.FALSE., nsval, blklength) + +! CONTROL NUMBER OF STEPS + IF (numsteps .GT. 0) THEN + niter_store = niter + niter = numsteps + iter2 - 1 + END IF + + CALL eqsolve (ier_flag, lscreen) + + IF (numsteps .GT. 0) THEN + niter = niter_store + END IF + + IF (ier_flag .ne. norm_term_flag .and. + & ier_flag .ne. successful_term_flag .and. + & ier_flag .ne. more_iter_flag) EXIT + IF (numsteps .GT. 0 .or. ns_index .GT. 0) EXIT + +! +! give up if it refuses to converge, M.Drevlak +! it may help to end a vmec run in an optimization environment, if it +! fails to converge in the first iterations of an ns_array sequence +! within the set number of iterations specified by NITER. +! The parameter fgiveup defaults to 30. +! + + IF (lgiveup .and. (fsqr .gt. ftolv*fgiveup .or. + & fsqz .gt. ftolv*fgiveup .or. + & fsql .gt. ftolv*fgiveup )) THEN + print *, "runvmec: giving up due to poor convergence" + EXIT + END IF + + CALL Finalize_bst(.FALSE.) + CALL second0(gridtoff) + grid_time(grid_id) = gridtoff - gridton + IF (lfreeb) THEN + IF (PARVMEC) THEN + vgrid_time(grid_id) = vacuum_time - old_vacuum_time + old_vacuum_time = vacuum_time + ELSE + vgrid_time(grid_id) = s_vacuum_time - old_vacuum_time + old_vacuum_time = s_vacuum_time + END IF + END IF + grid_id = grid_id + 1 + END DO + !END - Main loop that will be parallelized - SKS + + 100 CONTINUE + + IF (ier_flag .eq. bad_jacobian_flag .and. jacob_off .eq. 0) THEN + jacob_off = 1 + GO TO 50 + END IF + + CALL second0 (timeoff) + timer(tsum) = timer(tsum) + timeoff - timeon +! +! WRITE OUTPUT TO THREED1, WOUT FILES; FREE MEMORY ALLOCATED GLOBALLY +! + 1000 IF (lmoreiter .AND. + & ier_flag .EQ. more_iter_flag .AND. + & grank .EQ. 0) THEN ! J Geiger + PRINT *, 'runvmec: Running some more iterations', + & ' -> Skipping call to fileout!' + ELSE IF (ier_flag .NE. more_iter_flag) THEN + IF (PARVMEC) THEN + CALL fileout_par(iseq_count, ictrl_flag, ier_flag, lscreen) + ELSE + CALL fileout(iseq_count, ictrl_flag, ier_flag, lscreen) + END IF + END IF + + IF(LV3FITCALL) CALL FinalizeRunVmec(RUNVMEC_COMM_WORLD) + CALL second0(rvtoff) + runvmec_time = runvmec_time + (rvtoff - rvton) + + END SUBROUTINE runvmec +!------------------------------------------------ diff --git a/Sources/TimeStep/vmec.f b/Sources/TimeStep/vmec.f new file mode 100644 index 0000000..6c77a28 --- /dev/null +++ b/Sources/TimeStep/vmec.f @@ -0,0 +1,444 @@ + PROGRAM vmec + USE vmec_input + USE vmec_seq + USE safe_open_mod +! USE precon2d, ONLY: ScratchFile + USE vparams, ONLY: nlog, nlog0, nthreed + USE vmec_params, ONLY: more_iter_flag, + & bad_jacobian_flag, + & restart_flag, readin_flag, timestep_flag, + & output_flag, cleanup_flag, + & norm_term_flag, successful_term_flag ! J Geiger: for more iterations and full 3D1-output + USE parallel_include_module + USE parallel_vmec_module, ONLY: MyEnvVariables, + & InitializeParallel, + & FinalizeParallel + IMPLICIT NONE +C----------------------------------------------- +C L o c a l P a r a m e t e r s +C----------------------------------------------- + INTEGER, PARAMETER :: nseq0 = 12 + CHARACTER(LEN=*), PARAMETER :: + & increase_niter = "Try increasing NITER", + & bad_jacobian = "The jacobian was non-definite!", + & full_3d1output_request = "Full threed1-output request!" +C----------------------------------------------- +C L o c a l V a r i a b l e s +C----------------------------------------------- + INTEGER :: numargs, ierr_vmec, index_end, + & iopen, isnml, iread, iseq, index_seq, + & index_dat, iunit, ncount, nsteps, i + INTEGER :: ictrl(5) + CHARACTER(LEN=120) :: input_file, seq_ext, reset_file_name, arg + CHARACTER(LEN=120) :: log_file + CHARACTER(LEN=120), DIMENSION(10) :: command_arg + LOGICAL :: lscreen + INTEGER :: RVC_COMM + + REAL(dp) :: ton, toff + REAL(dp) :: totalton, totaltoff + +C----------------------------------------------- +!*** +! D I S C L A I M E R +! +! You are using a beta version of the PROGRAM VMEC, which is currently +! under development by S. P. Hirshman at the Fusion Energy Division, +! Oak Ridge National Laboratory. Please report any problems or comments +! to him. As a beta version, this program is subject to change +! and improvement without notice. +! +! 1. CODE SYNOPSIS +! +! THIS PROGRAM - VMEC (Variational Moments Equilibrium Code) - +! SOLVES THREE-DIMENSIONAL MHD EQUILIBRIUM EQUATIONS USING +! FOURIER SPECTRAL (MOMENTS) METHODS. A CYLINDRICAL COORDINATE +! REPRESENTATION IS USED (R-Z COORDINATES). THE POLOIDAL +! ANGLE VARIABLE IS RENORMALIZED THROUGH THE STREAM FUNCTION +! LAMBDA, WHICH IS SELF-CONSISTENTLY DETERMINED AND DIFFERENCED +! VARIATIONALLY ON THE HALF-RADIAL MESH. THE POLOIDAL ANGLE IS +! DETERMINED BY MINIMIZING = m**2 S(m) , WHERE S(m) = +! Rm**2 + Zm**2 . AN EVEN-ODD DECOMPOSITION IN THE POLOIDAL MODE +! NO. OF R,Z, AND LAMDA IS USED TO IMPROVE RADIAL RESOLUTION. +! A FREE-BOUNDARY OPTION IS AVAILABLE (FOR lfreeb=T), WITH A +! USER-SUPPLIED DATA-FILE "MGRID" NEEDED TO COMPUTE THE PLASMA +! VACUUM FIELD COMPONENTS BR, BPHI, BZ (see SUBROUTINE BECOIL) +! +! THE MAGNETIC FIELD IS REPRESENTED INTERNALLY AS FOLLOWS: +! +! B(s,u,v) = grad(phiT) X ( grad(u) + grad(lambda) ) + +! +! iota(s) * grad(v) X grad(phiT) +! +! WHERE phiT is the toroidal flux (called phi in code) and +! u,v are the poloidal, toroidal angles, respectively. +! +! 2. ADDITIONAL CODES REQUIRED +! For the fixed boundary calculation, the user must provide the Fourier +! coefficients for the plasma boundary (the last surface outside of which +! the pressure gradient vanishes). For ALL but the simplest geometry, the +! SCRUNCH code (available from R. Wieland), based on the DESCUR curve-fitting +! code, can be used to produce the optimized VMEC Fourier representation for +! an arbritrary closed boundary (it need not be a 'star-like' DOmain, nor +! need it possess vertical, or 'stellarator', symmetry). +! +! For the free boundary calculation, the MAKEGRID code (available upon +! request) is needed to create a binary Green''s FUNCTION table for the +! vacuum magnetic field(s) and, IF data analysis is to be done, flux and +! field loops as well. The user provides a SUBROUTINE (BFIELD) which can be +! called at an arbitrary spatial location and which should RETURN the three +! cylindrical components of the vacuum field at that point. (Similary, +! locations of diagnostic flux loops, Rogowski coils, etc. are required IF +! equilibrium reconstruction is to be done.) +! +! Plotting is handled by a stand-alone package, PROUT.NCARG (written by +! R. M. Wieland). It uses NCAR-graphics calls and reads the primary VMEC output +! file, WOUT.EXT, WHERE 'EXT' is the command-line extension of the INPUT file. +! +! +! 3. UNIX SCRIPT SETUP PARAMETERS +! The VMEC source code (vmec.lsqh) is actually a UNIX script file which uses +! the C-precompiler to produce both the machine-specific Fortran source and a +! make-file specific to ANY one of the following platforms: +! +! IBM-RISC6000, CRAY, ALPHA (DEC-STATION), HP-UX WORKSTATION, +! WINDOWS-NT, DEC-VMS +! +! Additional platforms are easy to add to the existing script as required. +! +! +! 4. FORTRAN PARAMETER STATEMENTS set by user +! In the Fortran-90 version of VMEC these PARAMETER statements have +! been replaced by dynamic memory allocation. So the user should set the +! run-time parameters ns (through ns_array), mpol, ntor in the NAMELIST INDATA. +! +! +! Added features since last edition (see vmec_params for revision history list) +! 1. Implemented preconditioning algorithm for R,Z +! 2. The physical (unpreconditioned) residuals are used +! to determine the level of convergence +! 3. The original (MOMCON) scaling of lambda is used, i.e., +! Bsupu = phip*(iota - lamda[sub]v)/SQRT(g). This is needed to +! maintain consistency with the time-stepper for arbitrary PHIP. +! +! WRITTEN BY S. P. HIRSHMAN (8/28/85 - REVISED 3/1/86) BASED ON +! 1. S. P. Hirshman and J. C. Whitson, Phys. Fluids 26, 3553 (1983). +! 2. S. P. Hirshman and H. K. Meier, Phys. Fluids 28, 1387 (1985). +! 3. S. P. Hirshman and D. K. Lee, Comp. Phys. Comm. 39, 161 (1986). +! + +! Local variables +! +! ictrl: array(5) of control variables for running "runvmec" routine +! see "runvmec" for a description +! + +! +! Read in command-line arguments to get input file or sequence file, +! screen display information, and restart information +! + INTERFACE + SUBROUTINE runvmec(ictrl_array, input_file0, + & lscreen, RVC_COMM, reset_file_name) + IMPLICIT NONE + INTEGER, INTENT(inout), TARGET :: ictrl_array(5) + LOGICAL, INTENT(in) :: lscreen + CHARACTER(LEN=*), INTENT(in) :: input_file0 + INTEGER, INTENT(in), OPTIONAL :: RVC_COMM + CHARACTER(LEN=*), OPTIONAL :: reset_file_name + END SUBROUTINE runvmec + END INTERFACE + + CALL MyEnvVariables + CALL InitializeParallel + CALL MPI_COMM_DUP(MPI_COMM_WORLD,RVC_COMM,MPI_ERR) + CALL second0(totalton) + ton = totalton + + CALL getcarg(1, command_arg(1), numargs) + DO iseq = 2, numargs + CALL getcarg(iseq, command_arg(iseq), numargs) + END DO + + CALL second0(toff) + get_args_time = get_args_time + (toff -ton) + + lscreen = .false. + IF(grank.EQ.0) lscreen = .true. + reset_file_name = " " + + IF (numargs .lt. 1) THEN + STOP 'Invalid command line' + ELSE IF (command_arg(1).eq.'-h' .or. command_arg(1).eq.'/h') THEN + PRINT *, + & ' ENTER INPUT FILE NAME OR INPUT-FILE SUFFIX ON COMMAND LINE' + PRINT * + PRINT *,' For example: ' + PRINT *,' xvmec input.tftr OR xvmec tftr ', + & 'OR xvmec ../input.tftr' + PRINT * + PRINT *,' Sequence files, containing a list of input files', + & ' are also allowed. For example: ' + PRINT *,' xvmec input.tftr_runs' + PRINT * + PRINT *,' Here, input.tftr_runs contains a &VSEQ namelist', + & ' entry' + PRINT * + PRINT *,' Additional (optional) command arguments are', + & ' allowed:' + PRINT * + PRINT *,' xvmec [noscreen] [reset=reset_wout_file]' + PRINT * + PRINT *,' noscreen: supresses all output to screen ', + & ' (default, or "screen", displays output)' + PRINT *,' name of reset wout file (defaults to none)' + + STOP + ELSE + DO iseq = 2, MIN(numargs,10) + arg = command_arg(iseq) + IF (TRIM(arg) .eq. 'noscreen' .or. & + & TRIM(arg) .eq. 'NOSCREEN') THEN + lscreen = .false. + END IF + index_end = INDEX(arg, "reset=") + index_seq = MAX(INDEX(arg, "RESET="), index_end) + IF (index_seq .gt. 0) reset_file_name = arg(index_seq+6:) + END DO + END IF + +! +! Determine type of file opened (sequential or input-data) +! ARG1 (char var) +! By DEFAULT, ARG1 obtained from the command +! line is parsed as follows to determine the input data file(s): +! a. Attempt to OPEN file ARG1 (full path + file name). +! Look for the VSEQ NAMELIST to obtain nseq, nseq_select, and +! extension array. If they exist and nseq>0, VMEC will run +! sequentially using input determined from the array EXTENSION[i] +! or input.EXTENSION[i] +! b. If the command argument is not a sequence NAMELIST, THEN the data file +! ARG1 or input.ARG1 is READ directly, with NSEQ=1. +! + arg = command_arg(1) + index_dat = INDEX(arg,'.') + index_end = LEN_TRIM(arg) + IF (index_dat .gt. 0) THEN + seq_ext = arg(index_dat + 1:index_end) + input_file = TRIM(arg) + ELSE + seq_ext = TRIM(arg) + input_file = 'input.'//TRIM(seq_ext) + END IF + + nseq = 1 + nseq_select(1) = 1 + extension(1) = input_file +! +! READ IN NAMELIST VSEQ TO GET ARRAY +! OF INPUT FILE EXTENSIONS AND INDEXING ARRAY, NSEQ_SELECT +! + nlog = nlog0 + iunit = nseq0 + DO iseq = 1, 2 + IF (iseq .EQ. 1) THEN + arg = input_file + ELSE + arg = seq_ext + END IF + CALL second0(ton) + CALL safe_open(iunit, iopen, TRIM(arg), 'old', 'formatted') + CALL second0(toff) + safe_open_time = safe_open_time + (toff - ton) + IF (iopen .eq. 0) THEN + DO ncount = 1, nseqmax + nseq_select(ncount) = ncount + END DO + CALL second0(ton) + + CALL read_namelist (iunit, isnml, 'vseq') + + CALL second0(toff) + read_namelist_time = read_namelist_time + (toff - ton) +! +! OPEN FILE FOR STORING SEQUENTIAL RUN HISTORY +! + IF (isnml .eq. 0) THEN + IF (nseq .gt. nseqmax) STOP 'NSEQ>NSEQMAX' + log_file = 'log.'//seq_ext + CALL second0(ton) + + CALL safe_open(nlog, iread, log_file, 'replace', + & 'formatted') + + CALL second0(toff) + safe_open_time = safe_open_time + (toff - ton) + + IF (iread .NE. 0) THEN + PRINT *, log_file, + & ' LOG FILE IS INACCESSIBLE: IOSTAT= ',iread + STOP 3 + ELSE + EXIT !!Break out of loop + END IF + END IF + END IF + CLOSE (iunit) + END DO + +! +! CALL EQUILIBRIUM SOLVER +! +! nseq_select: If sequence file (VSEQ NAMELIST given with nseq >0) +! array giving indices into EXTENSION array prescribing +! the order in which the input files are run by VMEC +! nseq: number of sequential VMEC runs to make +! +! +! CALL VMEC WITH POSSIBLE SEQUENCE EXTENSION (SEQ_EXT) +! AND ARRAY OF INPUT FILE EXTENSIONS (EXTENSION) +! + ictrl = 0 + +! GOTO 200 !ENABLE THIS STATEMENT TO TEST REVERSE-COMMUNICATION STOP/RESTART CODING + + SEQ: DO iseq = 1, nseq + index_seq = nseq_select(iseq) + ictrl(1) = restart_flag + readin_flag + timestep_flag + & + output_flag + cleanup_flag !Sets all flags + ictrl(2) = 0 +! ictrl(3) = 100 +! ictrl(4) = 2 + ictrl(5) = iseq - 1 + ncount = 0 + IF (iseq .GT. 1) THEN + reset_file_name = +#ifdef NETCDF + & 'wout_' // TRIM(extension(index_seq-1)) // ".nc" +#else + & 'wout.' // TRIM(extension(index_seq-1)) + WRITE (*,*) 'WARNING: Text based wout files are no ' \\ + & 'longer maintained and may be removed in ' \\ + & 'the future.' +#endif + END IF +! +! SET UP A "REVERSE-COMMUNICATION" LOOP FOR RUNNING VMEC +! + + 100 CONTINUE + + RVCCALLNUM = 1 + CALL runvmec(ictrl, extension(index_seq), lscreen, RVC_COMM, + & reset_file_name) + + ierr_vmec = ictrl(2) + + SELECT CASE (ierr_vmec) + CASE (more_iter_flag) !Need a few more iterations to converge + IF (grank .EQ. 0) THEN + IF(lscreen) WRITE (6, '(1x,a)') increase_niter + WRITE (nthreed, '(1x,a)') increase_niter + WRITE (nthreed, '(1x,a)') "PARVMEC aborting..." + CALL FLUSH(nthreed) + END IF +! J Geiger: if lmoreiter and lfull3d1out are false +! the o-lines (original) are the only +! ones to be executed. + IF (lmoreiter) THEN ! J Geiger: --start-- + DO i = 2, max_main_iterations ! Changes to run + ictrl(1) = timestep_flag ! some more iterations if requested + ictrl(3) = niter ! - this is the number of iterations + RVCCALLNUM = 2 + CALL runvmec(ictrl, extension(1), lscreen, + & RVC_COMM, reset_file_name) ! - the second iteration run with ictrl(3) iterations + IF (ictrl(2) .EQ. more_iter_flag .and. + & grank .EQ. 0) THEN + WRITE (nthreed, '(1x,a)') increase_niter + IF(lscreen) WRITE (6, '(1x,a)') increase_niter + END IF + END DO + ictrl(1) = output_flag + cleanup_flag ! - Output, cleanup + IF (ictrl(2) .ne. successful_term_flag) THEN + ictrl(2)=successful_term_flag ! - force success flag to get full threed1-output! + END IF + ictrl(3) = 0 ! - this is the number of iterations + RVCCALLNUM = 3 + CALL runvmec(ictrl, extension(1), lscreen, RVC_COMM, + & reset_file_name) + ELSE ! else-branch contains original code. +#if defined(MPI_OPT) + CALL MPI_Barrier(RVC_COMM, MPI_ERR) +#endif + + ictrl(1) = output_flag + cleanup_flag !Output, cleanup ! o-lines + ictrl(2) = 0 ! o-lines + IF (lfull3d1out) THEN + ictrl(2) = successful_term_flag + IF (grank .EQ. 0) THEN + WRITE(6,'(1x,a)') full_3d1output_request + WRITE(nthreed,'(1x,a)') full_3d1output_request + END IF + END IF + + RVCTRIGGER = .TRUE. + RVCCALLNUM = 4 + CALL runvmec(ictrl, extension(1), lscreen, RVC_COMM, ! o-lines + & reset_file_name) + RVCTRIGGER = .FALSE. + END IF ! J Geiger: -- end -- + + CASE (bad_jacobian_flag) !Bad jacobian even after axis reset and ns->3 + IF (grank .EQ. 0) THEN + IF (lscreen) WRITE (6, '(/,1x,a)') bad_jacobian + WRITE (nthreed, '(/,1x,a)') bad_jacobian + END IF + CASE DEFAULT + END SELECT + END DO SEQ + + GOTO 300 + +!REVERSE-COMMUNICATION TEST LOOP: SHOULD BE OFF FOR NORMAL VMEC2000 RUN +!ONLY SHOWS HOW TO IMPLEMENT EXTERNAL STOP/START OF VMEC + 200 CONTINUE + + nsteps = 50 + ictrl(1) = restart_flag + readin_flag !Initialization only + ictrl(3) = nsteps + ictrl(4) = 1 !Go to fine grid directly (assumes it is grid index=1) + RVCCALLNUM = 5 + CALL runvmec(ictrl, extension(1), lscreen, RVC_COMM, + & reset_file_name) + + ictrl(1) = timestep_flag + output_flag !Set timestep flag (output_flag, too, if wout needed) + ictrl(1) = timestep_flag !Set timestep flag (output_flag, too, if wout needed) + + DO iopen = 1, 3 !Scan through grids (3, for this example) + ictrl(4) = iopen + DO ncount = 1, MAX(1,niter/nsteps) + RVCCALLNUM=6 + CALL runvmec(ictrl, extension(1), lscreen, RVC_COMM, + & reset_file_name) + PRINT *,' BREAK HERE' + ierr_vmec = ictrl(2) + IF (ierr_vmec .ne. more_iter_flag) EXIT + END DO + END DO + + ictrl(1) = output_flag+cleanup_flag !Output, cleanup + RVCCALLNUM = 7 + CALL runvmec(ictrl, extension(1), lscreen, RVC_COMM, + & reset_file_name) + + 300 CONTINUE + + CLOSE (nlog) + + CALL second0(totaltoff) + total_time = total_time + (totaltoff - totalton) + toff = totaltoff + IF (.NOT.LV3FITCALL .AND. lactive) CALL WriteTimes('timings.txt') + CALL FinalizeParallel + + END PROGRAM vmec diff --git a/Sources/TimeStep/vmec_history.f b/Sources/TimeStep/vmec_history.f new file mode 100644 index 0000000..85f2e72 --- /dev/null +++ b/Sources/TimeStep/vmec_history.f @@ -0,0 +1,309 @@ +!******************************************************************************* +! File vmec_history.f +! Contains module vmec_history + +!******************************************************************************* +! MODULE vmec_history +! (history of a vmec run) +! SECTION I. Variable Declarations +! SECTION II. Subroutines +! SECTION III. Comments - version history +!******************************************************************************* + + MODULE vmec_history + +!******************************************************************************* +! SECTION I. Variable Declarations +!******************************************************************************* + +!------------------------------------------------------------------------------- +! Type declarations - lengths of reals, integers, and complexes. +! Frequently used mathematical constants, lots of extra precision. +! Make type declarations and constants Private, so there are no conflicts. +!------------------------------------------------------------------------------- + + USE stel_kinds, only : rprec + USE safe_open_mod + USE xstuff + + IMPLICIT NONE + + PRIVATE rprec + +!------------------------------------------------------------------------------- +! Module Variables - Scalars +!------------------------------------------------------------------------------- +! vmh_dim Length of History Arrays +! vmh_index index to the history arrays, and call counter +! vmh_save_i1 Integer stored value. Value set with subroutine +! vmec_history_set. Used by V3FIT for reconstruction +! iteration number +! vmh_save_i2 Integer stored value. Value set with subroutine +! vmec_history_set. Used by V3FIT for jacobian +! calculation loop (reconstruction parameter number) +! vmh_print_flag Logical to control printing +! Print Flag Usage - Now (2010-08-12) +! 1) Initialized to .False. +! 2) vmec_history_print not called from VMEC +! 3) Flag changed to .TRUE. in V3FIT +! 4) vmec_history_print called at end of V3FIT run +! Print Flag Usage - Future - If want VMEC run alone to also call vmec_history_print +! 1) Initialized to .TRUE. +! 2) vmec_history_print from VMEC +! 3) When run from V3FIT +! a) have V3FIT change flag to .False. at start +! Will need to fix up eq_interface +! b) change flag to .TRUE. at end, and call vmec_history_print +! vmh_time_zero Real variable to store the initial result of the second0 call + + INTEGER, PARAMETER :: vmh_dim = 100000 + INTEGER :: vmh_index = 0 + INTEGER :: vmh_save_i1 = - 1 + INTEGER :: vmh_save_i2 = - 1 +! LOGICAL :: vmh_print_flag = .TRUE. + LOGICAL :: vmh_print_flag = .FALSE. + REAL(rprec) :: vmh_time_zero = 0 + PRIVATE vmh_dim, vmh_index, vmh_save_i1, vmh_save_i2, & + & vmh_print_flag + +!------------------------------------------------------------------------------- +! Module Variables - Integer arrays +!------------------------------------------------------------------------------- +! vmh_iterc VMEC's iterc +! vmh_iter2m1 VMEC's iter2 - iter1 +! vmh_ns VMEC's ns +! vmh_nvacskip VMEC's nvacskip +! vmh_ivac VMEC's ivac +! vmh_ictrl_prec2d VMEC's ictrl_prec2d +! vmh_i1 V3FIT, reconstruction iteration number +! vmh_i2 V3FIT, jacobian calculation, reconstruction parameter # + + INTEGER, DIMENSION(vmh_dim) :: vmh_iterc, vmh_iter2m1, vmh_ns, & + & vmh_nvacskip, vmh_ivac, vmh_ictrl_prec2d, vmh_i1, vmh_i2 + +!------------------------------------------------------------------------------- +! Module Variables - Real arrays +!------------------------------------------------------------------------------- +! vmh_fsq- Convergence diagnostics +! vmh_time_step VMEC delt0 values +! vmh_time SYSTEM_TIME, via LIBSTELL's second0 function + + REAL(rprec), DIMENSION(vmh_dim) :: vmh_time_step, vmh_fsqr, & + & vmh_fsqz, vmh_fsql, vmh_fedge, vmh_time + +!******************************************************************************* +! SECTION II. Subroutines +!******************************************************************************* + CONTAINS + +!******************************************************************************* +!******************************************************************************* +! vmec_history_store +! subroutine to store local vmec and variables into the history arrays. +! Should be called ONLY from subroutine eqsolve, right after iterc +! is incremented. +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_store(time_step) + +!------------------------------------------------------------------------------- +! USE statements +!------------------------------------------------------------------------------- + + USE vmec_main, ONLY: iter1, iter2, iterc, fsqr, fsqz, fsql, & + & fedge, ivac + USE vmec_dim, ONLY: ns + USE vmec_input, ONLY: nvacskip + USE precon2d, ONLY: ictrl_prec2d + +!------------------------------------------------------------------------------- +! ARGUMENT declaration +!------------------------------------------------------------------------------- + REAL(rprec), INTENT(in) :: time_step +! delt0 is a local variable in runvmec +! runvmec: CALL eqsolve(.,delt0,...) +! dummy argument of eqsolve is called delt0 +! eqsolve: CALL vmec_history_store(delt0) +! eqsolve: CALL evolve(delt0,...) +! dummy argument of evolve is time_step + +!------------------------------------------------------------------------------- +! Local Variables +!------------------------------------------------------------------------------- + REAL(rprec) :: time_now + +!------------------------------------------------------------------------------- +! Start of executable code +!------------------------------------------------------------------------------- + IF (vmh_index .eq. 0) THEN + CALL second0(vmh_time_zero) + ENDIF + vmh_index = vmh_index + 1 + IF (vmh_index .le. vmh_dim) THEN + vmh_iterc(vmh_index) = iterc + vmh_iter2m1(vmh_index) = iter2 - iter1 + vmh_ns(vmh_index) = ns + vmh_nvacskip(vmh_index) = nvacskip + vmh_ivac(vmh_index) = ivac + vmh_ictrl_prec2d(vmh_index) = ictrl_prec2d + vmh_i1(vmh_index) = vmh_save_i1 + vmh_i2(vmh_index) = vmh_save_i2 + vmh_time_step(vmh_index) = time_step + vmh_fsqr(vmh_index) = fsqr + vmh_fsqz(vmh_index) = fsqz + vmh_fsql(vmh_index) = fsql + vmh_fedge(vmh_index) = fedge + CALL second0(time_now) + vmh_time(vmh_index) = time_now - vmh_time_zero + ENDIF + RETURN + END SUBROUTINE vmec_history_store + +!******************************************************************************* +!******************************************************************************* +! vmec_history_print +! subroutine to print out the accumulated history +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_print + +!------------------------------------------------------------------------------- +! USE statements +!------------------------------------------------------------------------------- + USE vmec_input, ONLY: input_extension + +!------------------------------------------------------------------------------- +! Local Variables +!------------------------------------------------------------------------------- + INTEGER :: vmh_iou = 73 + INTEGER :: istat, i + CHARACTER(LEN=120) :: vmh_history_file_name + CHARACTER(LEN=80) :: vmh_format2 = + & '(3(i5,1x),i4,1x,i3,1x,i5,1x,3(i3,1x),7(2x,es9.2))' + CHARACTER(LEN=150) :: vmh_header + +!------------------------------------------------------------------------------- +! Start of executable code +!------------------------------------------------------------------------------- + IF (.NOT. vmh_print_flag) RETURN + + vmh_history_file_name = TRIM('vmec_history.' // input_extension) + CALL safe_open(vmh_iou,istat,TRIM(vmh_history_file_name), & + & 'replace','formatted',delim_in='none',record_in=150) + IF (istat .ne. 0) THEN + WRITE(*,*) 'In subroutine vmec_history_print: Error from' + WRITE(*,*) 'call to safe_open. istat = ', istat + STOP ' (source file vmec_history.f)' + ENDIF + + WRITE(vmh_iou,*) 'History arrays are dimensioned ',vmh_dim + WRITE(vmh_iou,*) 'Subroutine vmec_history_store was called ', & + & vmh_index, ' times' + WRITE(vmh_iou,*) + + vmh_header = ' i iterc 2m1 ns nvac ivac ictrl_ i1 i2' // & + & ' time_step fsqr fsqz fsql max(fsq)' // & + & ' fedge sys-time' + WRITE(vmh_iou,*) TRIM(vmh_header) + WRITE(vmh_iou,*) ' skip prec2d' + + DO i = 1,MIN(vmh_index,vmh_dim) + WRITE(vmh_iou,vmh_format2) & + & i, vmh_iterc(i), vmh_iter2m1(i), vmh_ns(i), & + & vmh_nvacskip(i), vmh_ivac(i), & + & vmh_ictrl_prec2d(i), vmh_i1(i), vmh_i2(i), & + & vmh_time_step(i), vmh_fsqr(i), vmh_fsqz(i), vmh_fsql(i), & + & MAX(vmh_fsqr(i),vmh_fsqz(i),vmh_fsql(i)), & + & vmh_fedge(i), vmh_time(i) + END DO + + RETURN + END SUBROUTINE vmec_history_print + +!******************************************************************************* +!******************************************************************************* +! vmec_history_set +! Subroutine to set values of vmh_save_i1 and/or vmh_save_i2 +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_set(i1,i2) + +! Declare Arguments + INTEGER, OPTIONAL :: i1, i2 + +! Start of executable code + + IF (PRESENT(i1)) vmh_save_i1 = i1 + IF (PRESENT(i2)) vmh_save_i2 = i2 + + RETURN + END SUBROUTINE vmec_history_set + +!******************************************************************************* +!******************************************************************************* +! vmec_history_get +! Subroutine to get values of vmh_save_i1 and/or vmh_save_i2 +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_get(i1,i2) + +! Declare Arguments + INTEGER :: i1, i2 + +! Start of executable code + + i1 = vmh_save_i1 + i2 = vmh_save_i2 + + RETURN + END SUBROUTINE vmec_history_get + +!******************************************************************************* +!******************************************************************************* +! vmec_history_print_flag_off +! Subroutine to turn on the print flag. +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_print_flag_off + vmh_print_flag = .FALSE. + RETURN + END SUBROUTINE vmec_history_print_flag_off + +!******************************************************************************* +!******************************************************************************* +! vmec_history_print_flag_on +! Subroutine to turn off the print flag. +!------------------------------------------------------------------------------- + + SUBROUTINE vmec_history_print_flag_on + vmh_print_flag = .TRUE. + RETURN + END SUBROUTINE vmec_history_print_flag_on + + END MODULE vmec_history + +!******************************************************************************* +! SECTION III. Comments - version history +!******************************************************************************* +! +! JDH 07-12-2006. First version. +! Module to store history information about a vmec run +! +! 07-24-2006 JDH +! Changed so that iter_ha is index of last assigned value in history arrays. +! So, iter_ha increment happens BEFORE assignments in vmec_history_store. +! +! 2010-08-03 JDH +! Significant Revisions, added more variables to store. Still needs V3F interface +! Use variable prefix vmh_ +! 2010-08-05 JDH Add mechanism to turn off and on the printing +! 2010-08-10 JDH Add time_step +! 2010-08-12 JDH Add vmec_history_get, clean up headings, comments. +! 2011-02-08 JDH Added vmh_fsq and vmh_fedge +! 2011-02-15 JDH Removed vmh_fsq +! 2011-02-18 JDH Added vmh_time - system time via LIBSTELL's second0 +! 2011-02-19 JDH Fixed up issues with vmh_time +! 2012-06-20 JDH Changed iter2 to iterc for cumulative counter + + + diff --git a/Testing/CMakeLists.txt b/Testing/CMakeLists.txt new file mode 100644 index 0000000..2d2b4b3 --- /dev/null +++ b/Testing/CMakeLists.txt @@ -0,0 +1,2 @@ +add_subdirectory (tests) +add_subdirectory (test_utilities) diff --git a/Testing/test_utilities/CMakeLists.txt b/Testing/test_utilities/CMakeLists.txt new file mode 100644 index 0000000..01905b8 --- /dev/null +++ b/Testing/test_utilities/CMakeLists.txt @@ -0,0 +1,6 @@ +target_sources(xwout_diff + PRIVATE + $ + $ + $ +) diff --git a/Testing/test_utilities/vmec_test_commandline_parser.cpp b/Testing/test_utilities/vmec_test_commandline_parser.cpp new file mode 100644 index 0000000..555217c --- /dev/null +++ b/Testing/test_utilities/vmec_test_commandline_parser.cpp @@ -0,0 +1,21 @@ +//****************************************************************************** +/// @file commandline_parser.cpp +/// @brief Contains implementations to interpolate full and half grid quanities. +//****************************************************************************** + +#include "vmec_test_commandline_parser.hpp" + +//------------------------------------------------------------------------------ +/// @brief Get the string value of the agument. +/// +/// @param[in] key Commandline key to check. +/// @returns String value of the argument. +//------------------------------------------------------------------------------ +template<> std::string +vmec_test::commandline_parser::get (const std::string &key) const { + if (!is_set(key)) { + help(); + } + + return commands.at(key); +} diff --git a/Testing/test_utilities/vmec_test_commandline_parser.hpp b/Testing/test_utilities/vmec_test_commandline_parser.hpp new file mode 100644 index 0000000..542af78 --- /dev/null +++ b/Testing/test_utilities/vmec_test_commandline_parser.hpp @@ -0,0 +1,113 @@ +//****************************************************************************** +/// @file vmec_test_commandline_parser.hpp +/// @brief Contains classes to interpolate full and half grid quanities. +//****************************************************************************** + +#ifndef vmec_test_commandline_parser_hpp +#define vmec_test_commandline_parser_hpp + +#include +#include +#include +#include + +namespace vmec_test { + +/// Type for the argument map. + typedef std::map arg_map; +/// Type for a key value pair. + typedef std::pair arg_element; + +//------------------------------------------------------------------------------ +/// @brief A radial quantity. +//------------------------------------------------------------------------------ + class commandline_parser { + public: +/// Parsed commands. + const arg_map commands; +/// Help callback function. + const std::function help; + +//------------------------------------------------------------------------------ +/// @brief Factory method to parse the commandline and produce the arguments. +/// +/// @param[in] argc Number of commandline arguments. +/// @param[in] argv Commandline strings. +/// @param[in] help Call back function to display the help message. +/// @returns A constructed map of commandline argument key value pairs. +//------------------------------------------------------------------------------ + static arg_map parse_commands(const size_t argc, + const char * argv[], + const std::function help) { + if (argc == 0) { + help(); + } + + arg_map commands; + + for (size_t i = 1; i < argc; i++) { + std::string arg(argv[i]); + + if (arg == "-h") { + help(); + } else { + size_t eqpos = arg.find('='); + if (eqpos != std::string::npos) { + std::string key = arg.substr(0, eqpos); + std::string value = arg.substr(eqpos + 1, std::string::npos); + + commands.insert(arg_element(key, value)); + } else { + commands.insert(arg_element(arg, "")); + } + } + } + + return commands; + } + +//------------------------------------------------------------------------------ +/// @brief Construct a commandline_parser object by pasring command line +/// arguments. +/// +/// @param[in] argc Number of commandline arguments. +/// @param[in] argv Commandline strings. +/// @param[in] help Call back function to display the help message. +//------------------------------------------------------------------------------ + commandline_parser(const size_t argc, + const char * argv[], + const std::function help) : + commands(parse_commands(argc, argv, help)) {} + +//------------------------------------------------------------------------------ +/// @brief Check if command arg was set. +/// +/// @param[in] key Commandline key to check. +/// @returns True if the key was set. +//------------------------------------------------------------------------------ + bool is_set(const std::string &key) const { + return commands.find(key) != commands.end(); + } + +//------------------------------------------------------------------------------ +/// @brief Get the value of the agument. +/// +/// @param[in] key Commandline key to check. +/// @returns Value of the argument. +//------------------------------------------------------------------------------ + template + TYPE get(const std::string &key) const { + if (!is_set(key)) { + help(); + } + + std::stringstream value_stream(commands.at(key)); + TYPE temp; + value_stream >> temp; + + return temp; + } + }; +} + +#endif diff --git a/Testing/test_utilities/wout_diff.cpp b/Testing/test_utilities/wout_diff.cpp new file mode 100644 index 0000000..91a07bc --- /dev/null +++ b/Testing/test_utilities/wout_diff.cpp @@ -0,0 +1,144 @@ +//------------------------------------------------------------------------------ +// The @header2, @begin_table, @item3 and @end_table commands are custom +// defined commands in Doxygen.in. They are defined under ALIASES. For the page +// created here, the 80 column limit is exceeded. Arguments of aliases are +// separated by ','. If you intended ',' to be a string you must use an escaped +// comma '\,'. +// +/// @page wout_diff_cl_parsing_sec Command Line Arguments +/// +/// @tableofcontents +/// +/// @section wout_diff_cl_parsing_intro Introduction +/// This contains a description of the command line arguments. All arguments +/// take the form of +/// +/// @fixed_width{-arg=value} +/// +/// @section wout_diff_cl_parsing_arg_sec Command Line Arguments +/// @header2{Argument, Takes Value, Discription} +/// @begin_table +/// @item3{@fixed_width{-h}, N, Displays the help text and exits the program.} +/// @item3{@fixed_width{-wout_file1}, Y, First wout file name.} +/// @item3{@fixed_width{-wout_file2}, Y, Second wout file name.} +/// @item3{@fixed_width{-quantity}, Y, Wout quantity to check.} +/// @item3{@fixed_width{-tol}, Y, Tolarance value.} +/// @end_table +/// +/// @section wout_diff_cl_pasring_prog_ref_sec Programmers Reference +/// Reference material for the coding to implement command line parsing is found +/// in the @ref vmec_test::commandline_parser class. +//------------------------------------------------------------------------------ +//****************************************************************************** +/// @file wout_diff.cpp +/// @brief Utility to check the difference between two wout files. +//****************************************************************************** + +#include +#include +#include +#include + +#include "vmec_test_commandline_parser.hpp" + +//------------------------------------------------------------------------------ +/// @brief Load a quantity from a wout file. +/// +/// Quantites are loaded into a flat vector for rapid comparison. +/// +/// @param[in] wout_file Wout file name. +/// @param[in] name Name of the wout file quantity. +//------------------------------------------------------------------------------ +std::vector wout_quantity(const std::string wout_file, + const std::string name) { + int ncid; + nc_open(wout_file.c_str(), NC_NOWRITE, &ncid); + + int varid; + nc_inq_varid(ncid, name.c_str(), &varid); + + int ndims; + nc_inq_varndims(ncid, varid, &ndims); + + std::vector dimids(ndims); + nc_inq_vardimid(ncid, varid, dimids.data()); + + size_t total_length = 1; + for (int dimid: dimids) { + size_t dim_length; + nc_inq_dimlen(ncid, dimid, &dim_length); + + total_length *= dim_length; + } + + std::vector buffer(total_length); + nc_get_var(ncid, varid, buffer.data()); + + nc_close(ncid); + + return buffer; +} + +//------------------------------------------------------------------------------ +/// @brief Main test program. +/// +/// @param[in] argc Number of commandline arguments. +/// @param[in] argv Array of arguments strings. +//------------------------------------------------------------------------------ +int main(int argc, const char * argv[]) { + const vmec_test::commandline_parser args(argc, argv, []() -> void { +// " '' " + std::cout << " " << std::endl; + std::cout << " WOUT DIFF " << std::endl; + std::cout << " " << std::endl; + std::cout << "Usage: xwout_diff [-arg][=option] ... " << std::endl; + std::cout << " " << std::endl; + std::cout << "Options: " << std::endl; + std::cout << "All options are displayes as [arg][takesoption][Discription] " << std::endl; + std::cout << " -h N Display this information. " << std::endl; + std::cout << " " << std::endl; + std::cout << " -wout_file1 Y First wout file name. " << std::endl; + std::cout << " " << std::endl; + std::cout << " -wout_file2 Y Second wout file name. " << std::endl; + std::cout << " " << std::endl; + std::cout << " -quantity Y Wout quantity to check. " << std::endl; + std::cout << " " << std::endl; + std::cout << " -tol Y Tolarance value. " << std::endl; + std::cout << " " << std::endl; + std::cout << std::endl; + + exit(1); + }); + + std::string quantity = args.get ("-quantity"); + + std::vector q1 = + wout_quantity(args.get ("-wout_file1"), quantity); + std::vector q2 = + wout_quantity(args.get ("-wout_file2"), quantity); + + const double tolarance = args.get ("-tol"); + + bool pass = q1.size() + q2.size(); + if (!pass) { + std::cout << "Quantity " << quantity + << " has unequal lengths." << std::endl; + std::cout << q1.size() << " " << q2.size() << std::endl; + exit(1); + } + + for (size_t i = 0, e = q1.size(); i < e; i++) { + pass = pass && abs(q1[i] - q2[i]) < tolarance; + if (!pass) { + std::cout << abs(q1[i] - q2[i]) << std::endl; + } + } + + if (!pass) { + std::cout << "Quantity " << quantity + << " has unequal values." << std::endl; + exit(1); + } + + exit(0); +} diff --git a/Testing/tests/CMakeLists.txt b/Testing/tests/CMakeLists.txt new file mode 100644 index 0000000..d799132 --- /dev/null +++ b/Testing/tests/CMakeLists.txt @@ -0,0 +1,2 @@ +add_subdirectory (fixed_boundary_test) +add_subdirectory (free_boundary_test) diff --git a/Testing/tests/fixed_boundary_test/CMakeLists.txt b/Testing/tests/fixed_boundary_test/CMakeLists.txt new file mode 100644 index 0000000..c4b81b0 --- /dev/null +++ b/Testing/tests/fixed_boundary_test/CMakeLists.txt @@ -0,0 +1,133 @@ +# Copy input file from the source to the build directory. +configure_file (${CMAKE_CURRENT_SOURCE_DIR}/input.test.vmec + ${CMAKE_CURRENT_BINARY_DIR}/input.test_serial.vmec + COPYONLY) +configure_file (${CMAKE_CURRENT_SOURCE_DIR}/input.test.vmec + ${CMAKE_CURRENT_BINARY_DIR}/input.test_parallel.vmec + COPYONLY) + +# Test Fixed boundary equilibrium. +add_test (NAME vmec_fixed_boundary_serial_test + COMMAND $/xvmec input.test_serial.vmec) +add_test (NAME vmec_fixed_boundary_parallel_test + COMMAND $ $ 4 $/xvmec input.test_parallel.vmec) + +# Check woutfile to ensure that values match. +add_test (NAME vmec_fixed_boundary_check_aspect_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=aspect -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_b0_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=b0 -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bdotb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bdotb -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bdotgradv_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bdotgradv -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_beta_vol_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=beta_vol -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_betapol_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betapol -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_betator_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betator -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_betatotal_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betatotal -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_betaxis_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betaxis -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bsubsmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubsmns -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bsubumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubumnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bsubvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubvmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bsupumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsupumnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bsupvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsupvmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_buco_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=buco -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_bvco_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bvco -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_chi_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=chi -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_chipf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=chipf -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_currumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=currumnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_currvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=currvmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_DCurr_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DCurr -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_DGeod_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DGeod -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_DMerc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DMerc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_DShear_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DShear -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_DWell_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DWell -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_fsql_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsql -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_fsqr_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqr -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_fsqt_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqt -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_fsqz_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqz -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_gmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=gmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_IonLarmor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=IonLarmor -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_iotaf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=iotaf -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_jcuru_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jcuru -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_jcurv_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jcurv -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_jdotb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jdotb -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_lmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=lmns -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_mnmax_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=mnmax -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_mnmax_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=mnmax_nyq -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_phipf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=phipf -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_phips_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=phips -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_pres_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=pres -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_presf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=presf -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_q_factor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=q_factor -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_rbtor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rbtor -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_rbtor0_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rbtor0 -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_rmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rmnc -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_specw_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=specw -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_volavgB_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=volavgB -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_volume_p_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=volume_p -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_vp_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=vp -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_wb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wb -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_wdot_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wdot -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_wp_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wp -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_xm_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xm -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_xm_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xm_nyq -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_xn_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xn -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_xn_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xn_nyq -tol=1.0E-20) +add_test (NAME vmec_fixed_boundary_check_zmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=zmns -tol=1.0E-20) diff --git a/Testing/tests/fixed_boundary_test/input.test.vmec b/Testing/tests/fixed_boundary_test/input.test.vmec new file mode 100644 index 0000000..265d523 --- /dev/null +++ b/Testing/tests/fixed_boundary_test/input.test.vmec @@ -0,0 +1,45 @@ +&INDATA + +! VMEC execution parameters. +LFORBAL = F, +LFREEB = F, +DELT = 1.0, +TCON0 = 2.0, +NFP = 1, +NS_ARRAY = 15, +FTOL_ARRAY = 1.0E-20, +NITER = 25000, +NSTEP = 200, +NTOR = 0, +MPOL = 5, +NZETA = 1, +NVACSKIP = 9, +LASYM = F, + +! Fitting parameters. +GAMMA = 0.0, +PHIEDGE = -0.05, +BLOAT = 1.0, + +! Initial Position. +RAXIS(0) = 0.75, +ZAXIS(0) = 0.0, +RBC(0,0) = 0.75, +RBC(0,1) = 0.25, +ZBS(0,0) = 0.0, +ZBS(0,1) = 0.25, + +! Plasma current parameters. +NCURR = 1, +CURTOR = 40000.0, +AC = 1.0, 5.0, 10.0 +PCURR_TYPE = 'two_power', + +! Plasma pressure parameters. +SPRES_PED = 1.0, +PRES_SCALE = 400.0, +am_aux_s = 0.0, 0.5, 1.0 +am_aux_f = 1.0, 1.0, 1.0 +pmass_type = 'line_segment', +/ +&END diff --git a/Testing/tests/free_boundary_test/CMakeLists.txt b/Testing/tests/free_boundary_test/CMakeLists.txt new file mode 100644 index 0000000..d0da6da --- /dev/null +++ b/Testing/tests/free_boundary_test/CMakeLists.txt @@ -0,0 +1,138 @@ +# Copy input file from the source to the build directory. +configure_file (${CMAKE_CURRENT_SOURCE_DIR}/coils.test + ${CMAKE_CURRENT_BINARY_DIR}/coils.test + COPYONLY) +configure_file (${CMAKE_CURRENT_SOURCE_DIR}/input.test.vmec + ${CMAKE_CURRENT_BINARY_DIR}/input.test_serial.vmec + COPYONLY) +configure_file (${CMAKE_CURRENT_SOURCE_DIR}/input.test.vmec + ${CMAKE_CURRENT_BINARY_DIR}/input.test_parallel.vmec + COPYONLY) + +# Test Free boundary equilibrium. +add_test (NAME vmec_mgrid_test + COMMAND $/mgrid coils.test) +add_test (NAME vmec_free_boundary_serial_test + COMMAND $/xvmec input.test_serial.vmec) +add_test (NAME vmec_free_boundary_parallel_test + COMMAND $ $ 4 $/xvmec input.test_parallel.vmec) + +# Check woutfile to ensure that values match. +add_test (NAME vmec_free_boundary_check_aspect_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=aspect -tol=5.0E-14) +add_test (NAME vmec_free_boundary_check_b0_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=b0 -tol=6.0E-15) +add_test (NAME vmec_free_boundary_check_bdotb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bdotb -tol=3.0E-14) +add_test (NAME vmec_free_boundary_check_bdotgradv_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bdotgradv -tol=7.0E-14) +add_test (NAME vmec_free_boundary_check_beta_vol_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=beta_vol -tol=6.0E-17) +add_test (NAME vmec_free_boundary_check_betapol_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betapol -tol=4.0E-15) +add_test (NAME vmec_free_boundary_check_betator_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betator -tol=2.0E-17) +add_test (NAME vmec_free_boundary_check_betatotal_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betatotal -tol=6.0E-18) +add_test (NAME vmec_free_boundary_check_betaxis_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=betaxis -tol=7.0E-17) +add_test (NAME vmec_free_boundary_check_bmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bmnc -tol=5.0E-14) +add_test (NAME vmec_free_boundary_check_bsubsmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubsmns -tol=5.0E-14) +add_test (NAME vmec_free_boundary_check_bsubumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubumnc -tol=3.0E-14) +add_test (NAME vmec_free_boundary_check_bsubvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsubvmnc -tol=3.0E-14) +add_test (NAME vmec_free_boundary_check_bsupumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsupumnc -tol=4.0E-12) +add_test (NAME vmec_free_boundary_check_bsupvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bsupvmnc -tol=1.0E-13) +add_test (NAME vmec_free_boundary_check_buco_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=buco -tol=3.0E-17) +add_test (NAME vmec_free_boundary_check_bvco_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=bvco -tol=2.0E-14) +add_test (NAME vmec_free_boundary_check_chi_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=chi -tol=6.0E-16) +add_test (NAME vmec_free_boundary_check_chipf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=chipf -tol=2.0E-14) +add_test (NAME vmec_free_boundary_check_currumnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=currumnc -tol=9.0E-7) +add_test (NAME vmec_free_boundary_check_currvmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=currvmnc -tol=2.0E-7) +add_test (NAME vmec_free_boundary_check_DCurr_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DCurr -tol=9.0E-10) +add_test (NAME vmec_free_boundary_check_DGeod_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DGeod -tol=4.0E-10) +add_test (NAME vmec_free_boundary_check_DMerc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DMerc -tol=1.0E-9) +add_test (NAME vmec_free_boundary_check_DShear_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DShear -tol=4.0E-10) +add_test (NAME vmec_free_boundary_check_DWell_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=DWell -tol=2.0E-10) +add_test (NAME vmec_free_boundary_check_fsql_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsql -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_fsqr_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqr -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_fsqt_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqt -tol=3.0E-17) +add_test (NAME vmec_free_boundary_check_fsqz_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=fsqz -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_gmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=gmnc -tol=3.0E-14) +add_test (NAME vmec_free_boundary_check_IonLarmor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=IonLarmor -tol=8.0E-17) +add_test (NAME vmec_free_boundary_check_iotaf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=iotaf -tol=3.0E-13) +add_test (NAME vmec_free_boundary_check_jcuru_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jcuru -tol=2.0E-7) +add_test (NAME vmec_free_boundary_check_jcurv_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jcurv -tol=5.0E-10) +add_test (NAME vmec_free_boundary_check_jdotb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=jdotb -tol=7.0E-7) +add_test (NAME vmec_free_boundary_check_lmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=lmns -tol=9.0E-13) +add_test (NAME vmec_free_boundary_check_mnmax_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=mnmax -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_mnmax_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=mnmax_nyq -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_phipf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=phipf -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_phips_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=phips -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_pres_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=pres -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_presf_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=presf -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_q_factor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=q_factor -tol=2.0E-13) +add_test (NAME vmec_free_boundary_check_rbtor_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rbtor -tol=2.0E-14) +add_test (NAME vmec_free_boundary_check_rbtor0_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rbtor0 -tol=4.0E-15) +add_test (NAME vmec_free_boundary_check_rmnc_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=rmnc -tol=5.0E-14) +add_test (NAME vmec_free_boundary_check_specw_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=specw -tol=2.0E-12) +add_test (NAME vmec_free_boundary_check_volavgB_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=volavgB -tol=8.0E-15) +add_test (NAME vmec_free_boundary_check_volume_p_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=volume_p -tol=9.0E-15) +add_test (NAME vmec_free_boundary_check_vp_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=vp -tol=8.0E-16) +add_test (NAME vmec_free_boundary_check_wb_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wb -tol=5.0E-19) +add_test (NAME vmec_free_boundary_check_wdot_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wdot -tol=3.0E-15) +add_test (NAME vmec_free_boundary_check_wp_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=wp -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_xm_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xm -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_xm_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xm_nyq -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_xn_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xn -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_xn_nyq_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=xn_nyq -tol=1.0E-20) +add_test (NAME vmec_free_boundary_check_zmns_test + COMMAND $/xwout_diff -wout_file1=wout_test_serial.vmec.nc -wout_file2=wout_test_parallel.vmec.nc -quantity=zmns -tol=5.0E-14) diff --git a/Testing/tests/free_boundary_test/coils.test b/Testing/tests/free_boundary_test/coils.test new file mode 100644 index 0000000..9776180 --- /dev/null +++ b/Testing/tests/free_boundary_test/coils.test @@ -0,0 +1,229 @@ +! Simplified Coil model based on CTH. + +&MGRID_NLI + MGRID_EXT = 'test' + MGRID_MODE = 'R' + LSTELL_SYM = .TRUE. + RMIN = 0.45 + RMAX = 1.05 + ZMIN = -0.3 + ZMAX = 0.3 + IR = 101 + JZ = 101 + KP = 36 +/ + +** coils_dot_starts_below ** +periods 5 +begin filament +mirror NUL +1.13366 0. 0. 96 +1.1284 0.0324661 0.0600069 96 +1.11269 0.0660545 0.118482 96 +1.0867 0.101324 0.173958 96 +1.05079 0.1379 0.225085 96 +1.00565 0.174435 0.270661 96 +0.95232 0.208904 0.309637 96 +0.892312 0.239152 0.341109 96 +0.827436 0.263483 0.364319 96 +0.759623 0.28112 0.37865 96 +0.690669 0.292363 0.383661 96 +0.622062 0.298452 0.379121 96 +0.554917 0.301189 0.365058 96 +0.490005 0.302485 0.341791 96 +0.427826 0.303968 0.309939 96 +0.368663 0.306766 0.270398 96 +0.312606 0.311488 0.224283 96 +0.259552 0.318366 0.172851 96 +0.209208 0.327452 0.117433 96 +0.161083 0.338787 0.0593731 96 +0.114531 0.35249 5.0307E-17 96 +0.0688152 0.368767 -0.0593731 96 +0.0232192 0.387884 -0.117433 96 +-0.0228512 0.410125 -0.172851 96 +-0.0698152 0.435744 -0.224283 96 +-0.117943 0.464873 -0.270398 96 +-0.167451 0.497385 -0.309939 96 +-0.218626 0.532733 -0.341791 96 +-0.271902 0.569839 -0.365058 96 +-0.327833 0.607092 -0.379121 96 +-0.386916 0.642492 -0.383661 96 +-0.44931 0.673926 -0.37865 96 +-0.514538 0.699517 -0.364319 96 +-0.581326 0.717965 -0.341109 96 +-0.647652 0.728767 -0.309637 96 +-0.711054 0.732224 -0.270661 96 +-0.769054 0.729204 -0.225085 96 +-0.8196 0.720717 -0.173958 96 +-0.861359 0.707462 -0.118482 96 +-0.893813 0.689523 -0.0600069 96 +-0.917147 0.666346 -9.54098E-17 96 +-0.931979 0.636992 0.0600069 96 +-0.939011 0.600584 0.118482 96 +-0.938713 0.556772 0.173958 96 +-0.931165 0.506077 0.225085 96 +-0.916114 0.449983 0.270661 96 +-0.893234 0.390753 0.309637 96 +-0.862465 0.33101 0.341109 96 +-0.824281 0.273192 0.364319 96 +-0.779786 0.219064 0.37865 96 +-0.73061 0.169438 0.383661 96 +-0.678685 0.124186 0.379121 96 +-0.625972 0.0825046 0.365058 96 +-0.574219 0.0433018 0.341791 96 +-0.524787 0.00555449 0.309939 96 +-0.478567 -0.0314838 0.270398 96 +-0.435991 -0.0682541 0.224283 96 +-0.397113 -0.105003 0.172851 96 +-0.361724 -0.141945 0.117433 96 +-0.329453 -0.179402 0.0593731 96 +-0.299846 -0.217851 1.50054E-16 96 +-0.272429 -0.25789 -0.0593731 96 +-0.246777 -0.300157 -0.117433 96 +-0.222578 -0.34523 -0.172851 96 +-0.199642 -0.393561 -0.224283 96 +-0.177828 -0.445415 -0.270398 96 +-0.156885 -0.500818 -0.309939 96 +-0.136261 -0.559495 -0.341791 96 +-0.114969 -0.62083 -0.365058 96 +-0.091617 -0.683843 -0.379121 96 +-0.0646255 -0.747211 -0.383661 96 +-0.0326245 -0.809315 -0.37865 96 +0.00510449 -0.868359 -0.364319 96 +0.0482928 -0.922541 -0.341109 96 +0.0956033 -0.970266 -0.309637 96 +0.144864 -1.01033 -0.270661 96 +0.193562 -1.04198 -0.225085 96 +0.239443 -1.06482 -0.173958 96 +0.281019 -1.07864 -0.118482 96 +0.317818 -1.08321 -0.0600069 96 +0.350319 -1.07817 -1.89952E-16 96 +0.379572 -1.06314 0.0600069 96 +0.406662 -1.03782 0.118482 96 +0.432173 -1.0022 0.173958 96 +0.455864 -0.95675 0.225085 96 +0.476659 -0.902522 0.270661 96 +0.492963 -0.841156 0.309637 96 +0.503186 -0.774737 0.341109 96 +0.506279 -0.705518 0.364319 96 +0.502097 -0.635573 0.37865 96 +0.491482 -0.56652 0.383661 96 +0.476073 -0.49939 0.379121 96 +0.457927 -0.434685 0.365058 96 +0.4391 -0.372549 0.341791 96 +0.421296 -0.312956 0.309939 96 +0.405675 -0.255824 0.270398 96 +0.392843 -0.20105 0.224283 96 +0.382991 -0.148468 0.172851 96 +0.376075 -0.0977799 0.117433 96 +0.371983 -0.0485082 0.0593731 96 +0.37063 -4.94396E-17 2.498E-16 96 +0.371983 0.0485082 -0.0593731 96 +0.376075 0.0977799 -0.117433 96 +0.382991 0.148468 -0.172851 96 +0.392843 0.20105 -0.224283 96 +0.405675 0.255824 -0.270398 96 +0.421296 0.312956 -0.309939 96 +0.4391 0.372549 -0.341791 96 +0.457927 0.434685 -0.365058 96 +0.476073 0.49939 -0.379121 96 +0.491482 0.56652 -0.383661 96 +0.502097 0.635573 -0.37865 96 +0.506279 0.705518 -0.364319 96 +0.503186 0.774737 -0.341109 96 +0.492963 0.841156 -0.309637 96 +0.476659 0.902522 -0.270661 96 +0.455864 0.95675 -0.225085 96 +0.432173 1.0022 -0.173958 96 +0.406662 1.03782 -0.118482 96 +0.379572 1.06314 -0.0600069 96 +0.350319 1.07817 -2.7929E-16 96 +0.317818 1.08321 0.0600069 96 +0.281019 1.07864 0.118482 96 +0.239443 1.06482 0.173958 96 +0.193562 1.04198 0.225085 96 +0.144864 1.01033 0.270661 96 +0.0956033 0.970266 0.309637 96 +0.0482928 0.922541 0.341109 96 +0.00510449 0.868359 0.364319 96 +-0.0326245 0.809315 0.37865 96 +-0.0646255 0.747211 0.383661 96 +-0.091617 0.683843 0.379121 96 +-0.114969 0.62083 0.365058 96 +-0.136261 0.559495 0.341791 96 +-0.156885 0.500818 0.309939 96 +-0.177828 0.445415 0.270398 96 +-0.199642 0.393561 0.224283 96 +-0.222578 0.34523 0.172851 96 +-0.246777 0.300157 0.117433 96 +-0.272429 0.25789 0.0593731 96 +-0.299846 0.217851 3.50414E-16 96 +-0.329453 0.179402 -0.0593731 96 +-0.361724 0.141945 -0.117433 96 +-0.397113 0.105003 -0.172851 96 +-0.435991 0.0682541 -0.224283 96 +-0.478567 0.0314838 -0.270398 96 +-0.524787 -0.00555449 -0.309939 96 +-0.574219 -0.0433018 -0.341791 96 +-0.625972 -0.0825046 -0.365058 96 +-0.678685 -0.124186 -0.379121 96 +-0.73061 -0.169438 -0.383661 96 +-0.779786 -0.219064 -0.37865 96 +-0.824281 -0.273192 -0.364319 96 +-0.862465 -0.33101 -0.341109 96 +-0.893234 -0.390753 -0.309637 96 +-0.916114 -0.449983 -0.270661 96 +-0.931165 -0.506077 -0.225085 96 +-0.938713 -0.556772 -0.173958 96 +-0.939011 -0.600584 -0.118482 96 +-0.931979 -0.636992 -0.0600069 96 +-0.917147 -0.666346 -3.75568E-16 96 +-0.893813 -0.689523 0.0600069 96 +-0.861359 -0.707462 0.118482 96 +-0.8196 -0.720717 0.173958 96 +-0.769054 -0.729204 0.225085 96 +-0.711054 -0.732224 0.270661 96 +-0.647652 -0.728767 0.309637 96 +-0.581326 -0.717965 0.341109 96 +-0.514538 -0.699517 0.364319 96 +-0.44931 -0.673926 0.37865 96 +-0.386916 -0.642492 0.383661 96 +-0.327833 -0.607092 0.379121 96 +-0.271902 -0.569839 0.365058 96 +-0.218626 -0.532733 0.341791 96 +-0.167451 -0.497385 0.309939 96 +-0.117943 -0.464873 0.270398 96 +-0.0698152 -0.435744 0.224283 96 +-0.0228512 -0.410125 0.172851 96 +0.0232192 -0.387884 0.117433 96 +0.0688152 -0.368767 0.0593731 96 +0.114531 -0.35249 3.99854E-16 96 +0.161083 -0.338787 -0.0593731 96 +0.209208 -0.327452 -0.117433 96 +0.259552 -0.318366 -0.172851 96 +0.312606 -0.311488 -0.224283 96 +0.368663 -0.306766 -0.270398 96 +0.427826 -0.303968 -0.309939 96 +0.490005 -0.302485 -0.341791 96 +0.554917 -0.301189 -0.365058 96 +0.622062 -0.298452 -0.379121 96 +0.690669 -0.292363 -0.383661 96 +0.759623 -0.28112 -0.37865 96 +0.827436 -0.263483 -0.364319 96 +0.892312 -0.239152 -0.341109 96 +0.95232 -0.208904 -0.309637 96 +1.00565 -0.174435 -0.270661 96 +1.05079 -0.1379 -0.225085 96 +1.0867 -0.101324 -0.173958 96 +1.11269 -0.0660545 -0.118482 96 +1.1284 -0.0324661 -0.0600069 96 +1.13366 0. 0. 0.00000000000000E+00 1 HF-OVF + 1.26599000000000E+00 0.00000000000000E+00 -5.23002000000000E-01 -16.0000000000000E+00 1 HF-OVF + 1.26599000000000E+00 0.00000000000000E+00 5.23002000000000E-01 -16.0000000000000E+00 1 HF-OVF + 1.26799000000000E+00 0.00000000000000E+00 5.73261000000000E-01 -36.0000000000000E+00 2 TVF + 1.26799000000000E+00 0.00000000000000E+00 -5.73261000000000E-01 -36.0000000000000E+00 2 TVF + 1.26799000000000E+00 0.00000000000000E+00 4.63502000000000E-01 -36.0000000000000E+00 2 TVF + 1.26799000000000E+00 0.00000000000000E+00 -4.63502000000000E-01 -36.0000000000000E+00 2 TVF + 2.51000000000000E-01 0.00000000000000E+00 4.31000000000000E-01 1.24000000000000E+02 2 TVF + 2.51000000000000E-01 0.00000000000000E+00 -4.31000000000000E-01 1.24000000000000E+02 2 TVF +end diff --git a/Testing/tests/free_boundary_test/input.test.vmec b/Testing/tests/free_boundary_test/input.test.vmec new file mode 100644 index 0000000..2d62c2c --- /dev/null +++ b/Testing/tests/free_boundary_test/input.test.vmec @@ -0,0 +1,130 @@ +&INDATA + +OMP_NUM_THREADS = 1, + +! VMEC execution parameters. +MGRID_FILE = 'mgrid_test.nc', +LFORBAL = F, +LFREEB = T, +DELT = 0.7, +TCON0 = 2.0, +NFP = 5, +NS_ARRAY = 15, +FTOL_ARRAY = 1.0E-20, +NITER = 25000, +NSTEP = 200, +NTOR = 4, +MPOL = 5, +NZETA = 36, +NVACSKIP = 9, +LASYM = F, + +! Coil Currents. (HF, TVF) +EXTCUR = 4700.0, 1000.0, + +! Fitting parameters. +GAMMA = 0.0, +PHIEDGE = -0.035, +BLOAT = 1.0, + +! Initial Position. +RAXIS_CC(:) = 0.786037734951267, -0.0302978726119071, 0.000915258048528683, -1.91959906744039e-05, 1.45930777845745e-06, +ZAXIS_CS(:) = 0.0, 0.0273158409510113, -0.000937096584979097, 1.741833421328e-05, -5.91222841432118e-07, + +RBC(0,0) = 0.780906309727434, +RBC(1,0) = -0.046151739531816, +RBC(2,0) = 0.0025346622908875, +RBC(3,0) = -0.000294570027126834, +RBC(4,0) = 4.87628905278232e-05, +RBC(-4,1) = 1.10991985982551e-05, +RBC(-3,1) = -6.69760263500533e-05, +RBC(-2,1) = 0.000344811566716634, +RBC(-1,1) = -0.00566091264003757, +RBC(0,1) = 0.131435746235883, +RBC(1,1) = -0.039386399008392, +RBC(2,1) = 0.00488869740987901, +RBC(3,1) = -0.000438124054375238, +RBC(4,1) = 4.81645985535357e-05, +RBC(-4,2) = -1.53011178035308e-06, +RBC(-3,2) = 2.35413167655254e-05, +RBC(-2,2) = -8.83026333729552e-05, +RBC(-1,2) = 0.000146058452530242, +RBC(0,2) = 0.00147170066093047, +RBC(1,2) = -0.00320611057583166, +RBC(2,2) = 0.00228943846580024, +RBC(3,2) = -0.000319173467542497, +RBC(4,2) = 2.60138638307058e-05, +RBC(-4,3) = -2.22269133805289e-06, +RBC(-3,3) = 8.93182437579942e-07, +RBC(-2,3) = -1.86926512003518e-05, +RBC(-1,3) = -0.000103222718482529, +RBC(0,3) = -0.00010590693425821, +RBC(1,3) = -3.70460344545912e-05, +RBC(2,3) = 0.000384952481942609, +RBC(3,3) = -8.73464736915271e-05, +RBC(4,3) = 1.70559212798558e-05, +RBC(-4,4) = -4.11611838328142e-06, +RBC(-3,4) = -3.670147571078e-06, +RBC(-2,4) = 3.27663252086114e-06, +RBC(-1,4) = -5.49897884990649e-05, +RBC(0,4) = 0.000611036997986113, +RBC(1,4) = 0.000157752536759372, +RBC(2,4) = 0.000238939203660074, +RBC(3,4) = -7.45864378517666e-05, +RBC(4,4) = 1.0767515627784e-05, + +ZBS(0,0) = 0.0, +ZBS(1,0) = 0.0449223151020507, +ZBS(2,0) = -0.00157959039976886, +ZBS(3,0) = 0.000110096448338774, +ZBS(4,0) = -3.41523759959853e-05, +ZBS(-4,1) = 8.86243753757977e-06, +ZBS(-3,1) = -7.61994068511444e-06, +ZBS(-2,1) = -0.000102387369227698, +ZBS(-1,1) = -0.00308184739411174, +ZBS(0,1) = 0.164601748843378, +ZBS(1,1) = 0.0303393558516301, +ZBS(2,1) = -0.00451585182685075, +ZBS(3,1) = 0.000322392099487897, +ZBS(4,1) = -3.48737658782808e-05, +ZBS(-4,2) = -1.28442261664991e-06, +ZBS(-3,2) = 2.93065492924715e-05, +ZBS(-2,2) = -0.000193078473966611, +ZBS(-1,2) = 0.000917965755419898, +ZBS(0,2) = -0.00272248379340565, +ZBS(1,2) = 0.00355657869194155, +ZBS(2,2) = -0.00205297288922009, +ZBS(3,2) = 0.000328755917997435, +ZBS(4,2) = -3.57925786395997e-05, +ZBS(-4,3) = 3.83110072934457e-06, +ZBS(-3,3) = -3.24731939556698e-06, +ZBS(-2,3) = -3.77850265219013e-06, +ZBS(-1,3) = -7.43052945541678e-07, +ZBS(0,3) = 0.000120213894931637, +ZBS(1,3) = 9.70588501764729e-05, +ZBS(2,3) = -0.000305563766958157, +ZBS(3,3) = 7.12819152728525e-05, +ZBS(4,3) = -1.14192148882868e-05, +ZBS(-4,4) = 2.79111955871817e-06, +ZBS(-3,4) = -1.0123457043081e-06, +ZBS(-2,4) = 1.33742394885452e-05, +ZBS(-1,4) = -6.56302557453055e-05, +ZBS(0,4) = 0.000408527289143525, +ZBS(1,4) = -0.00113568343044368, +ZBS(2,4) = 0.000453498195180046, +ZBS(3,4) = -5.07003662052117e-05, +ZBS(4,4) = 5.22398328609138e-06, + +! Plasma current parameters. +NCURR = 1, +CURTOR = 43229.08092460368, +AC = 1.0, 5.0, 10.0, +PCURR_TYPE = 'two_power', + +! Plasma pressure parameters +SPRES_PED = 1.0, +AM = 1.0, 5.0, 10.0, +PRES_SCALE = 432.29080924603676, +pmass_type = 'two_power', +/ +&END