V3FIT
fileout.f
1  SUBROUTINE fileout_par(iseq, ictrl_flag, ier_flag, lscreen)
2  USE vmec_main, ONLY: ns, ntheta1, ntheta2, nzeta, bdamp,
3  & lfreeb
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
14  IMPLICIT NONE
15 C-----------------------------------------------
16 C D u m m y A r g u m e n t s
17 C-----------------------------------------------
18  INTEGER, INTENT(in) :: iseq, ictrl_flag
19  INTEGER, INTENT(inout) :: ier_flag
20  LOGICAL :: lscreen
21  LOGICAL :: loutput !SAL 070719
22  INTEGER :: i, j, ij, k, js, jk, lk, lt, lz, jcount
23  REAL(dp) :: tfileon, tfileoff
24  REAL(dp), ALLOCATABLE :: buffer(:,:), tmp(:,:)
25 C-----------------------------------------------
26  CALL second0(tfileon)
27 
28  loutput = (iand(ictrl_flag, output_flag) .ne. 0) !SAL 070719
29 
30  IF (lfreeb .AND. vlactive .AND. loutput) THEN !SAL070719
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)
40 
41  DO i = 1, 7
42  CALL mpi_allgatherv(buffer(:,i), numjs_vac, mpi_real8,
43  & tmp(:,i), counts_vac, disps_vac,
44  & mpi_real8, vac_comm,mpi_err)
45  END DO
46  DEALLOCATE(buffer)
47 
48  brv = tmp(:,1);
49  bphiv = tmp(:,2);
50  bzv = tmp(:,3)
51  bsupu_sur = tmp(:,4);
52  bsupv_sur = tmp(:,5)
53  bsubu_sur = tmp(:,6);
54  bsubv_sur = tmp(:,7)
55  DEALLOCATE(tmp)
56  END IF
57 !
58 ! COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym)
59 !
60  jcount = 0
61  DO k = 1, nzeta
62  jk = nzeta + 2 - k
63  IF (k .eq. 1) jk = 1
64  DO js = 1,ns
65  jcount = jcount + 1
66  ireflect(jcount) = js+ns*(jk - 1) !Index for -zeta[k]
67  ENDDO
68  END DO
69 
70 ! INDEX FOR u = -u (need for lasym integration in wrout)
71  lk = 0
72  IF (.NOT.ALLOCATED(uminus)) ALLOCATE (uminus(nznt))
73  DO lt = 1, ntheta2
74  k = ntheta1-lt+2
75  IF (lt .eq. 1) k = 1 !u=-0 => u=0
76  DO lz = 1, nzeta
77  lk = lk + 1
78  uminus(lk) = k !(-u), for u = 0,pi
79  END DO
80  END DO
81 
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)
95 
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)
104 
105  CALL gather4xarray(pxc)
106  CALL parallel2serial4x(pxc,xc)
107  CALL gather4xarray(pscalxc)
108  CALL parallel2serial4x(pscalxc,scalxc)
109  CALL second0(tfileoff)
110  END IF
111  fo_prepare_time = fo_prepare_time + (tfileoff-tfileon)
112 
113 ! ORIGPARVMEC=PARVMEC
114 ! PARVMEC=.FALSE.
115  IF (grank .EQ. 0) THEN
116  CALL fileout(iseq, ictrl_flag, ier_flag, lscreen)
117  ENDIF
118  !CALL MPI_Barrier(NS_COMM, MPI_ERR) !SAL 070719
119  CALL second0(tfileoff)
120  fileout_time = fileout_time + (tfileoff-tfileon)
121  fo_par_call_time = fileout_time
122 
123  END SUBROUTINE fileout_par
124 
125  SUBROUTINE fileout(iseq, ictrl_flag, ier_flag, lscreen)
126  USE vmec_main
127  USE vac_persistent
128  USE realspace
129  USE vmec_params, ONLY: mscale, nscale, signgs, uminus,
130  & norm_term_flag, more_iter_flag, output_flag,
131  & cleanup_flag, successful_term_flag
132  USE vforces
133  USE xstuff, ONLY: xc, gc, xsave, scalxc
134  USE precon2d, ONLY: ictrl_prec2d
135  USE timer_sub
136 #ifdef _HBANGLE
137  USE angle_constraints, ONLY: free_multipliers, getrz
138 #endif
139  USE parallel_include_module
140 
141  IMPLICIT NONE
142 C-----------------------------------------------
143 C D u m m y A r g u m e n t s
144 C-----------------------------------------------
145  INTEGER, INTENT(in) :: iseq, ictrl_flag
146  INTEGER, INTENT(inout) :: ier_flag
147  LOGICAL :: lscreen
148 C-----------------------------------------------
149 C L o c a l P a r a m e t e r s
150 C-----------------------------------------------
151  INTEGER :: istat, loc_ier_flag
152  LOGICAL, PARAMETER :: lreset_xc = .false.
153 C-----------------------------------------------
154 C L o c a l V a r i a b l e s
155 C-----------------------------------------------
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 ', ! norm_term_flag
161  & 'INITIAL JACOBIAN CHANGED SIGN (IMPROVE INITIAL GUESS) ', ! bad_jacobian_flag
162  & 'FORCE RESIDUALS EXCEED FTOL: MORE ITERATIONS REQUIRED ', ! more_iter_flag
163  & .ne..ne.'VMEC INDATA ERROR: NCURR1 but BLOAT1. ', !
164  & 'MORE THAN 75 JACOBIAN ITERATIONS (DECREASE DELT) ', ! jac75_flag
165  & 'ERROR READING INPUT FILE OR NAMELIST ', ! input_error_flag
166  & 'NEW AXIS GUESS STILL FAILED TO GIVE GOOD JACOBIAN ', !
167  & 'PHIEDGE HAS WRONG SIGN IN VACUUM SUBROUTINE ', ! phiedge_error_flag
168  & 'NS ARRAY MUST NOT BE ALL ZEROES ', ! ns_error_flag
169  & 'ERROR READING MGRID FILE ', ! misc_error_flag
170  & 'VAC-VMEC I_TOR MISMATCH : BOUNDARY MAY ENCLOSE EXT. COIL ', !
171  & 'SUCCESSFUL VMEC CONVERGENCE ', ! successful_term_flag
172  & 'BSUBU OR BSUBV JS=1 COMPONENT NON-ZERO ', ! bsub_bad_js1_flag
173  & 'RMNC N=0, M=1 IS ZERO ', ! r01_bad_value_flag
174  & 'ARNORM OR AZNORM EQUAL ZERO IN BCOVAR ' ! arz_bad_value_flag
175  & /)
176  CHARACTER(LEN=*), PARAMETER ::
177  & Warning = " Error deallocating global memory FILEOUT"
178  LOGICAL :: lwrite, loutput, lterm
179  REAL(dp) :: tmpxc, rmssum
180 C-----------------------------------------------
181 
182  infileout=.true.
183 
184  lu => czmn; lv => crmn
185 
186 !
187 ! COMPUTE REMAINING COVARIANT COMPONENT OF B (BSUBS),
188 ! CYLINDRICAL COMPONENTS OF B (BR, BPHI, BZ), AND
189 ! AVERAGE EQUILIBRIUM PROPERTIES AT END OF RUN
190 !
191 
192  iequi = 1
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
200  end if
201 
202  IF (lwrite .AND. loutput) THEN
203 !
204 ! The sign of the jacobian MUST multiply phi to get the physically
205 ! correct toroidal flux
206 !
207  phi(1) = zero
208  DO js = 2, ns
209  phi(js) = phi(js-1) + phip(js)
210  END DO
211  phi = (signgs*twopi*hs)*phi
212 
213 ! Must save irst value if in "restart" mode
214  irst0 = irst
215  CALL funct3d (lscreen, istat)
216  fo_funct3d_time = timer(tfun)
217 
218 
219 ! Write out any special files here
220 ! CALL dump_special
221 
222  irst = irst0
223 
224  ALLOCATE(br_out(nrzt), bz_out(nrzt), stat=istat)
225  gc = xc
226 #ifdef _HBANGLE
227  CALL getrz(gc)
228 #endif
229  CALL eqfor(br_out, bz_out, clmn, blmn, rcon(1,1),
230  & gc, ier_flag)
231  END IF
232 
233 ! CALL free_mem_precon
234 !
235 ! Call WROUT to write output or error message if lwrite = false
236 !
237 
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
241 #ifdef _ANIMEC
242  & ,brmn_o, sigma_an, ppar, pperp, onembc, pp1, pp2,
243  & pp3
244 #endif
245  & )
246 
247  IF (ntor .EQ. 0) THEN
248  CALL write_dcon (xc)
249  END IF
250 
251  IF (lscreen .and. ier_flag.ne.more_iter_flag)
252  & print 120, trim(werror(loc_ier_flag))
253  IF (lscreen .and. lterm) THEN
254  IF (grank.EQ.0) THEN
255  print 10, trim(input_extension), ijacob
256  END IF
257  END IF
258 
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
263  IF (rank.EQ.0) THEN
264  CALL write_times(nthreed, lscreen, lfreeb, lrecon,
265  & ictrl_prec2d .ne. 0)
266 
267  IF (grank.EQ.0) THEN
268  WRITE(nthreed,*)
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
273  END IF
274  101 FORMAT(1x,a,l4)
275  END IF
276  END IF
277  END IF
278 
279  10 FORMAT(' FILE : ',a,/,' NUMBER OF JACOBIAN RESETS = ',i4,/)
280  120 FORMAT(/1x,a,/)
281 
282 !
283 ! TESTING READ_WOUT MODULE WRITING ROUTINES
284 !
285  IF (ALLOCATED(br_out)) THEN
286 ! IF (lscreen) CALL TestWout(xc, br_out, bz_out, crmn_e, czmn_e)
287  DEALLOCATE (br_out, bz_out)
288  END IF
289 
290 ! END TEST
291 
292  1000 CONTINUE
293 
294 !
295 ! DEALLOCATE GLOBAL MEMORY AND CLOSE FILES
296 !
297  IF (iand(ictrl_flag, cleanup_flag) .eq. 0 .or.
298  & ier_flag .eq. more_iter_flag) THEN
299  RETURN
300  END IF
301 
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"
307 #ifdef _HBANGLE
308  CALL free_multipliers
309 #endif
310 
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"
314 
315  IF (ALLOCATED(tanu))
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,
319  & stat=istat1)
320  IF (istat1 .ne. 0) print *, warning // "#3"
321 
322  CALL free_mem_funct3d
323  CALL free_mem_ns (lreset_xc)
324  CALL free_mem_nunv
325  CALL free_persistent_mem
326 
327  CALL close_all_files
328 
329  END SUBROUTINE fileout
330 !------------------------------------------------
Generated on Thu Mar 5 2020 15:49:27 for V3FIT by   doxygen 1.8.17