1 SUBROUTINE fileout_par(iseq, ictrl_flag, ier_flag, lscreen)
2 USE vmec_main,
ONLY: ns, ntheta1, ntheta2, nzeta, bdamp,
4 USE parallel_include_module
5 USE xstuff,
ONLY: pxc, pgc, pxsave, pscalxc
6 USE xstuff,
ONLY: xc, gc, xsave, scalxc
7 USE vmec_main,
ONLY: vp, iotas, phips, chips, mass, icurv
8 USE vmec_main,
ONLY: ireflect, nznt, phipf, specw, sp, sm
9 USE vmec_params,
ONLY: uminus, output_flag
10 USE realspace,
ONLY: phip, sqrts, shalf, wint
11 USE realspace,
ONLY: pphip, psqrts, pshalf, pwint
12 USE vacmod,
ONLY: bsqvac, brv, bphiv, bzv, nv, nuv3,
13 & bsupu_sur, bsupv_sur, bsubu_sur, bsubv_sur
18 INTEGER,
INTENT(in) :: iseq, ictrl_flag
19 INTEGER,
INTENT(inout) :: ier_flag
22 INTEGER :: i, j, ij, k, js, jk, lk, lt, lz, jcount
23 REAL(dp) :: tfileon, tfileoff
24 REAL(dp),
ALLOCATABLE :: buffer(:,:), tmp(:,:)
28 loutput = (iand(ictrl_flag, output_flag) .ne. 0)
30 IF (lfreeb .AND. vlactive .AND. loutput)
THEN
31 ALLOCATE(buffer(numjs_vac, 7), tmp(nznt, 7),stat=i)
32 IF (i .NE. 0)
CALL stopmpi(440)
33 buffer(:,1) = brv(nuv3min:nuv3max)
34 buffer(:,2) = bphiv(nuv3min:nuv3max)
35 buffer(:,3) = bzv(nuv3min:nuv3max)
36 buffer(:,4) = bsupu_sur(nuv3min:nuv3max)
37 buffer(:,5) = bsupv_sur(nuv3min:nuv3max)
38 buffer(:,6) = bsubu_sur(nuv3min:nuv3max)
39 buffer(:,7) = bsubv_sur(nuv3min:nuv3max)
42 CALL mpi_allgatherv(buffer(:,i), numjs_vac, mpi_real8,
43 & tmp(:,i), counts_vac, disps_vac,
44 & mpi_real8, vac_comm,mpi_err)
66 ireflect(jcount) = js+ns*(jk - 1)
72 IF (.NOT.
ALLOCATED(uminus))
ALLOCATE (uminus(nznt))
82 IF (grank.LT.nranks .AND.
83 & iand(ictrl_flag, output_flag).NE.0)
THEN
84 CALL gather1xarray(vp)
85 CALL gather1xarray(iotas)
86 CALL gather1xarray(phips)
87 CALL gather1xarray(phipf)
88 CALL gather1xarray(chips)
89 CALL gather1xarray(mass)
90 CALL gather1xarray(icurv)
91 CALL gather1xarray(specw)
92 CALL gather1xarray(bdamp)
93 CALL gather1xarray(sm)
94 CALL gather1xarray(sp)
96 CALL gather2xarray(pphip)
97 CALL parallel2serial2x(pphip, phip)
98 CALL gather2xarray(psqrts)
99 CALL parallel2serial2x(psqrts, sqrts)
100 CALL gather2xarray(pshalf)
101 CALL parallel2serial2x(pshalf, shalf)
102 CALL gather2xarray(pwint)
103 CALL parallel2serial2x(pwint, wint)
105 CALL gather4xarray(pxc)
106 CALL parallel2serial4x(pxc,xc)
107 CALL gather4xarray(pscalxc)
108 CALL parallel2serial4x(pscalxc,scalxc)
109 CALL second0(tfileoff)
111 fo_prepare_time = fo_prepare_time + (tfileoff-tfileon)
115 IF (grank .EQ. 0)
THEN
116 CALL fileout(iseq, ictrl_flag, ier_flag, lscreen)
119 CALL second0(tfileoff)
120 fileout_time = fileout_time + (tfileoff-tfileon)
121 fo_par_call_time = fileout_time
123 END SUBROUTINE fileout_par
125 SUBROUTINE fileout(iseq, ictrl_flag, ier_flag, lscreen)
129 USE vmec_params,
ONLY: mscale, nscale, signgs, uminus,
130 & norm_term_flag, more_iter_flag, output_flag,
131 & cleanup_flag, successful_term_flag
133 USE xstuff,
ONLY: xc, gc, xsave, scalxc
134 USE precon2d,
ONLY: ictrl_prec2d
137 USE angle_constraints,
ONLY: free_multipliers, getrz
139 USE parallel_include_module
145 INTEGER,
INTENT(in) :: iseq, ictrl_flag
146 INTEGER,
INTENT(inout) :: ier_flag
151 INTEGER :: istat, loc_ier_flag
152 LOGICAL,
PARAMETER :: lreset_xc = .false.
156 INTEGER :: js, istat1=0, irst0, ofu
157 REAL(dp),
DIMENSION(:),
POINTER :: lu, lv
158 REAL(dp),
ALLOCATABLE :: br_out(:), bz_out(:)
159 CHARACTER(LEN=*),
PARAMETER,
DIMENSION(0:14) :: werror = (/
160 &
'EXECUTION TERMINATED NORMALLY ',
161 &
'INITIAL JACOBIAN CHANGED SIGN (IMPROVE INITIAL GUESS) ',
162 &
'FORCE RESIDUALS EXCEED FTOL: MORE ITERATIONS REQUIRED ',
163 & .ne..ne.
'VMEC INDATA ERROR: NCURR1 but BLOAT1. ',
164 &
'MORE THAN 75 JACOBIAN ITERATIONS (DECREASE DELT) ',
165 &
'ERROR READING INPUT FILE OR NAMELIST ',
166 &
'NEW AXIS GUESS STILL FAILED TO GIVE GOOD JACOBIAN ',
167 &
'PHIEDGE HAS WRONG SIGN IN VACUUM SUBROUTINE ',
168 &
'NS ARRAY MUST NOT BE ALL ZEROES ',
169 &
'ERROR READING MGRID FILE ',
170 &
'VAC-VMEC I_TOR MISMATCH : BOUNDARY MAY ENCLOSE EXT. COIL ',
171 &
'SUCCESSFUL VMEC CONVERGENCE ',
172 &
'BSUBU OR BSUBV JS=1 COMPONENT NON-ZERO ',
173 &
'RMNC N=0, M=1 IS ZERO ',
174 &
'ARNORM OR AZNORM EQUAL ZERO IN BCOVAR '
176 CHARACTER(LEN=*),
PARAMETER ::
177 & Warning =
" Error deallocating global memory FILEOUT"
178 LOGICAL :: lwrite, loutput, lterm
179 REAL(dp) :: tmpxc, rmssum
184 lu => czmn; lv => crmn
193 lterm = ier_flag .eq. norm_term_flag .or.
194 & ier_flag .eq. successful_term_flag
195 lwrite = lterm .or. ier_flag.eq.more_iter_flag
196 loutput = (iand(ictrl_flag, output_flag) .ne. 0)
197 loc_ier_flag = ier_flag
198 if (ier_flag .eq. successful_term_flag)
THEN
199 loc_ier_flag = norm_term_flag
202 IF (lwrite .AND. loutput)
THEN
209 phi(js) = phi(js-1) + phip(js)
211 phi = (signgs*twopi*hs)*phi
215 CALL funct3d (lscreen, istat)
216 fo_funct3d_time = timer(tfun)
224 ALLOCATE(br_out(nrzt), bz_out(nrzt), stat=istat)
229 CALL eqfor(br_out, bz_out, clmn, blmn, rcon(1,1),
238 IF (loutput .AND.
ASSOCIATED(bzmn_o))
THEN
239 CALL wrout(bzmn_o, azmn_o, clmn, blmn, crmn_o, czmn_e,
240 & crmn_e, xsave, gc, loc_ier_flag, lwrite
242 & ,brmn_o, sigma_an, ppar, pperp, onembc, pp1, pp2,
247 IF (ntor .EQ. 0)
THEN
251 IF (lscreen .and. ier_flag.ne.more_iter_flag)
252 & print 120, trim(werror(loc_ier_flag))
253 IF (lscreen .and. lterm)
THEN
255 print 10, trim(input_extension), ijacob
259 IF (nthreed .gt. 0)
THEN
260 WRITE (nthreed,120) trim(werror(loc_ier_flag))
261 IF (.not. lterm)
GOTO 1000
262 WRITE (nthreed, 10) trim(input_extension), ijacob
264 CALL write_times(nthreed, lscreen, lfreeb, lrecon,
265 & ictrl_prec2d .ne. 0)
269 WRITE(nthreed,
'(1x,a,i4)')
'NO. OF PROCS: ',gnranks
270 WRITE(nthreed,101)
'PARVMEC : ',parvmec
271 WRITE(nthreed,101)
'LPRECOND : ',lprecond
272 WRITE(nthreed,101)
'LV3FITCALL : ',lv3fitcall
279 10
FORMAT(
' FILE : ',a,/,
' NUMBER OF JACOBIAN RESETS = ',i4,/)
285 IF (
ALLOCATED(br_out))
THEN
287 DEALLOCATE (br_out, bz_out)
297 IF (iand(ictrl_flag, cleanup_flag) .eq. 0 .or.
298 & ier_flag .eq. more_iter_flag)
THEN
302 IF (
ALLOCATED(cosmu))
303 &
DEALLOCATE(cosmu, sinmu, cosmum, sinmum, cosmui, cosmumi,
304 & sinmui, sinmumi, cosnv, sinnv, cosnvn, sinnvn,
305 & cosmui3, cosmumi3, cos01, sin01, stat=istat1)
306 IF (istat1 .ne. 0) print *, warning //
"#1"
308 CALL free_multipliers
311 IF (
ALLOCATED(xm))
DEALLOCATE (xm, xn, ixm, xm_nyq, xn_nyq,
312 & jmin3, mscale, nscale, uminus, stat=istat1)
313 IF (istat1 .ne. 0) print *, warning //
"#2"
316 &
DEALLOCATE(tanu, tanv, sinper, cosper, sinuv, cosuv, sinu,
317 & cosu, sinv, cosv, sinui, cosui, cmns, csign, sinu1,
318 & cosu1, sinv1, cosv1, imirr, xmpot, xnpot,
320 IF (istat1 .ne. 0) print *, warning //
"#3"
322 CALL free_mem_funct3d
323 CALL free_mem_ns (lreset_xc)
325 CALL free_persistent_mem
329 END SUBROUTINE fileout