16 REAL(rprec),
DIMENSION(:),
ALLOCATABLE :: s2, f2
29 LOGICAL :: lexist=.false.
30 INTEGER :: numarg, iargc, id0, id1, id, np, pgopen, ier=0, m
31 INTEGER :: nlo, nfit, l1, l2, i, ix, ierr=0, ipos, mp=11
32 INTEGER :: kkac=99, kkai=99, kkam=99, count
37 LOGICAL :: exist, afile=.true.
38 CHARACTER*12 USErnm,pname*31,ident*172,formats*99
39 CHARACTER*12 idents1*72,idents2*72,formats1*80,formats2*80
40 CHARACTER(len=22) :: arg2
41 CHARACTER*24 datebuf, fdate, onechr*2, porder*2, cim*6
42 CHARACTER*90 geqdskfile, aeqdskfile
43 real*4,
DIMENSION(:),
allocatable :: xpl, xpl2, ypl, ypl2
44 REAL(rprec) :: cutoff = 3e-8, cutin, addv, phiedg, rcentr = 1.6955
45 REAL(rprec) :: tol = 1e-3, flux_fraction
46 REAL(rprec),
DIMENSION(:),
allocatable :: s , a0
47 REAL(rprec),
POINTER :: yfit(:),yfit2(:)
48 REAL(rprec),
DIMENSION(:),
ALLOCATABLE :: xin,yin,b1,b2,b3,b4
49 INTEGER,
DIMENSION(:),
allocatable :: thinner
50 CHARACTER*90 dul1, formatstring*100
51 CHARACTER*63 vmecinput
52 CHARACTER,
DIMENSION (100) :: line*60
53 CHARACTER(len=5) :: device=
'/cps'
54 CHARACTER*20 xlabel, ylabel, slabel*60, mlabel*70
65 WRITE(6,
'("CALL for g-file")')
67 CALL getarg(1,filename)
68 INQUIRE(file = trim(filename),exist = lexist)
70 IF(numarg == 0 .or. trim(filename).eq.
'-h')
then
71 WRITE(*,*)
"(1) Arguments are g-file name ",
72 .
"[, flux_fraction [,graphics-device],[klm]]"
74 .
"A zero for flux_fraction will select the default."
75 WRITE(*,*)
"(3) Devices uaualy available are: ",
76 .
" '/xs','/xw/,'/ps','/cps'"
77 WRITE(*,*)
"(4) Polynomial orders in format 3I2.2 ",
78 .
"Alphebetical ordering: AC, AI, AM."
80 .
" Use any of AC, AI, AM = 00 to invoke Akima splines!"
81 IF (trim(filename).eq.
'-h') stop
'help'
84 WRITE(*,*)
"Enter file name: "
85 READ(*,fmt=
'(a)')filename
86 WRITE(*,*)
"Enter flux fraction: "
87 READ(*,fmt=
'(f6.14)')flux_fraction
88 IF((flux_fraction.ge.0.9).AND.(flux_fraction.lt.1.0))
then
89 percenflux = flux_fraction
91 print*,
'NOT IN RANGE: flux_fraction=',percenflux
93 WRITE(*,*)
"plot device: "
94 READ(*,fmt=
'(a)')device
95 INQUIRE(file = trim(filename),exist = lexist)
97 INQUIRE(file = trim(filename),exist = lexist)
98 IF(.NOT.lexist)print*,lexist, trim(filename)
99 IF(.NOT.lexist) stop
"STOP on nofile"
102 READ(arg2,fmt=
'(f6.14)')flux_fraction
103 IF((flux_fraction.ge.0.9).AND.(flux_fraction.lt.1.0))
then
104 percenflux = flux_fraction
106 print*,
'NOT IN RANGE: flux_fraction=',percenflux
109 if (numarg >= 3)
CALL getarg (3, device)
110 if (numarg == 4)
then
112 read(cim,fmt=
'(3i2.2)')kkac, kkai, kkam
113 write(*,fmt=
'("kkac, kkai, kkam:",3(x,i2.2))')kkac, kkai, kkam
115 geqdskfile = trim(filename)
116 slabel = trim(filename)
117 ipos = index(geqdskfile,
'g',.true.)
119 & geqdskfile(1:ipos-1)//
'a'//geqdskfile(ipos+1:len(geqdskfile))
120 vmecinput =
'input.vmec.'//geqdskfile(ipos+1:)
121 if(kkac == 0 .OR. kkam == 0 .OR. kkai == 0)
122 & vmecinput =
'input.akima.'//geqdskfile(ipos+1:)
123 INQUIRE(file = trim(geqdskfile),exist = exist)
124 IF(.not.exist)stop
'no geqdskfile'
125 INQUIRE(file = trim(aeqdskfile),exist = exist)
127 IF(.not.exist) afile=.false.
128 id0 = pgopen(trim(device))
130 .
WRITE(*,*)
'Fail to Open Graphics Device',
131 . trim(device),
' with code ',id0
132 if (id0.le.0) stop
'PGPLOT device unavailable'
137 WRITE(6,
'("begin mapping")')
139 WRITE(6,
'("finished mapping")')
142 WRITE(6,
'("finished writing")')
148 .
' MGRID_FILE = ''/home/lazarus/mgrids/mgrid_d3d_ef.nc'''
150 .
' LFREEB = F LASYM = T'
154 .
' TCON0 = 2.00E+00'
160 .
' NTOR = 0 NTHETA = 00 NZETA = 1'
162 .
' NS_ARRAY = 13 25 49 97'
164 .
' NITER_ARRAY = 1500 2500 3500 5000'
170 .
' GAMMA = 0.000000E+00'
172 .
' FTOL_ARRAY = 1.e-6 1.e-8 1.e-11 1.e-12'
173 WRITE(xlabel,fmt=
'(es14.8)')g2%fraction_bndry
175 .
'! mapcode boundary fraction is '//trim(xlabel)
176 OPEN (unit = 67, file = vmecinput , status =
'UNKNOWN')
180 DO i = len(ident),1,-1
181 IF(l2.eq.0.and.ident(i:i).ne.
' ')l2 = i
182 IF(l1.eq.0.and.ident(i:i).eq.
'/')l1 = i
184 l2 = min(l2,len(pname))
185 pname = ident(l1+1:l2)
188 formats =
'(6h! file,x,a'
189 WRITE(onechr(1:2),fmt =
'(i2.2)')len_trim(vmecinput)
190 formats = formats(1:len_trim(formats))//onechr(1:2)
192 formats = formats(1:len_trim(formats))//
',14h generated by ,'
193 formats1 = formats1(1:len_trim(formats))//
',14h generated by )'
194 formats = formats(1:len_trim(formats))//
'/,2h! ,'
195 WRITE(onechr(1:2),fmt =
'(i2.2)')len_trim(pname)
197 formats = formats(1:len_trim(formats))//
'a'//onechr(1:2)
198 formats2 = formats2(1:len_trim(formats2))//
'a'//onechr(1:2)
199 formats = formats(1:len_trim(formats))//
',5h for ,'
200 formats2 = formats2(1:len_trim(formats2))//
',5h for ,'
201 WRITE(onechr(1:2),fmt =
'(i2.2)')len_trim(usernm)
202 formats = formats(1:len_trim(formats))//
'a'//onechr(1:2)
203 formats2 = formats2(1:len_trim(formats2))//
'a'//onechr(1:2)
204 formats = formats(1:len_trim(formats))//
',4h on ,a24,1h!)'
205 formats2 = formats2(1:len_trim(formats2))//
',4h on ,a24)'
206 WRITE(idents1,fmt = formats1)vmecinput
207 WRITE(idents2,fmt = formats2)pname,usernm,datebuf
208 line(15) = trim(idents1)
209 line(16) = trim(idents2)
212 WRITE(67, fmt=
'(a)')trim(line(i))
215 phiedg = g2%phi(g2%npsi)
216 IF (g1%bcentr < 0. ) phiedg = -phiedg
217 WRITE(67, fmt=
'('' PHIEDGE = '',es14.7)')phiedg
220 CALL getd3dcur(aeqdskfile ,1,1,ierr)
221 IF(ierr .ne. 0) stop
'getd3dcur'
223 write(67, fmt=
'('' CURTOR = '',1pe14.6)')g1%cpasma
228 ALLOCATE(s(m),yfit(m),yfit2(m),xin(m),yin(m),b4(mp))
229 ALLOCATE(thinner(m)); thinner=0
230 ALLOCATE(xpl(m), xpl2(m), ypl(m), ypl2(m))
233 if(index(trim(device),
'p')/=0)
CALL pgpap(8.,1.)
237 xlabel =
"\gr \(2240) \(2255)"//
"s"
238 nfit = 11;cutin = cutoff*0.03_dbl;nlo = 0;b4 = 0
239 if(kkai > 0 .AND. kkai < nfit) nfit = kkai
241 WRITE(porder,fmt=
'(i2.2)')nfit
242 mlabel =
'mapping & svd['//porder//
'] of iota(s) vs sqrt(s)'
243 IF (kkai .EQ. 0) mlabel = trim(mlabel)//
" - NOT USED"
245 IF(.not.
ALLOCATED(a0))
ALLOCATE(a0(nlo+1));a0 = 0.
246 CALL svdfit(nfit,nlo,cutin,a0,s,yin,m,b4)
247 yfit => polyval(b4,
SIZE(b4),s,
SIZE(s))
248 xpl = sqrt(s); ypl = yin;ypl2 = yfit
249 WRITE(slabel,fmt=
'("eqdsk = ",a," ; <% error>=",es9.2)')
250 . trim(geqdskfile), 200*sum(abs(yin-yfit))/sum(abs(yin+yfit))/nfit
252 & (xpl,xpl,ypl,ypl2,m,xlabel,ylabel,
' ',mlabel,slabel)
253 formatstring=
'('' AI = '',1pe14.6,2(/,2x,5(x,1pe14.6)))'
254 WRITE(67,fmt=formatstring)b4
257 formats=trim(formats)//
',5(1pe11.4,",")," $",/," "'
258 formats=trim(formats)//
'5(1pe11.4,",")'
259 formats=trim(formats)//
',"$",/," ",1pe11.4,"]")'
260 open(138,file=
"fort."//geqdskfile(ipos+1:),form=
"formatted")
261 write(138,*)
"; ",trim(slabel)
262 write(138,fmt=trim(formats))(b4(i),i=1,11)
263 write(*,fmt=trim(formats))(b4(i),i=1,11)
264 ylabel=
'd(curint)/ds'
265 m=g2%npsi;xin=g2%phi;yin=g2%curintp
266 nfit=mp;cutin=cutoff*0.03_dbl;nlo=0;b4=0
267 if(kkac > 0 .AND. kkac < nfit) nfit=kkac
268 IF(.not.
ALLOCATED(a0))
ALLOCATE(a0(nlo+1));a0=0.
269 CALL svdfit(nfit,nlo,cutin,a0,s,yin,m,b4)
270 yfit => polyval(b4,
SIZE(b4),s,
SIZE(s))
271 xpl = sqrt(s); ypl = yin; ypl2 = yfit
272 WRITE(porder,fmt=
'(i2.2)')nfit
273 xlabel =
"\gr \(2240) \(2255)"//
"s"
275 &
'mapping & svd['//porder//
'] of dI\dtor\u(s)/ds vs sqrt(s)'
276 IF ( kkac .EQ. 0) mlabel = trim(mlabel)//
" - NOT USED"
277 WRITE(slabel,fmt=
'("eqdsk = ",a," ; <% error>=",es9.2)')
278 . trim(geqdskfile), 200*sum(abs(yin-yfit))/sum(abs(yin+yfit))/nfit
280 & (xpl,xpl,ypl,ypl2,m,xlabel,ylabel,
' ',mlabel,slabel)
281 ylabel =
'd(curint)/ds'
283 CALL pgpt1(0.1,real(maxval(yin))/5,5)
284 CALL pgtext (0.18, real(maxval(yin))/5,
"mapped values")
286 CALL pgpt1(0.1,real(maxval(yin))/4,4)
287 CALL pgtext (0.18, real(maxval(yin))/4,
"polynomial fit")
288 formatstring =
'('' AC = '',es14.7,2(/,2x,5(x,es14.7)))'
289 WRITE(67,fmt=formatstring)b4
292 formats=trim(formats)//
',5(1pe11.4,",")," $",/," "'
293 formats=trim(formats)//
'5(1pe11.4,",")'
294 formats=trim(formats)//
',"$",/," ",1pe11.4,"]")'
295 write(138,*)
"; ",trim(slabel)
296 write(138,fmt=trim(formats))(b4(i),i=1,11)
297 write(*,fmt=trim(formats))(b4(i)/b4(1),i=1,11)
298 write(*,*)
"Ienclosed=",real(itor(
size(itor)))
299 yfit2=>polyint(b4,
SIZE(b4),s,
SIZE(s))
301 m=g2%npsi;xin=g2%phi;yin=g2%curint
302 nfit=mp;cutin=cutoff*0.03_dbl;nlo=1;b4=0
303 IF(.not.
ALLOCATED(a0))
ALLOCATE(a0(nlo+1));a0=0.
304 CALL svdfit(nfit,nlo,cutin,a0,s,yin,m,b4)
305 yfit => polyval(b4,
SIZE(b4),s,
SIZE(s))
306 xpl = sqrt(s); ypl = yin; ypl2 = yfit
307 WRITE(porder,fmt=
'(i2.2)')nfit
308 mlabel =
'mapping & svd['//porder//
'] of Itor(s) vs sqrt(s)'
309 slabel = trim(filename)
310 WRITE(slabel,fmt=
'(a," DFF=",1pe12.6)')trim(geqdskfile),
311 . 2*sum(abs(yfit2-yfit))/sum(abs(yfit2+yfit))
313 & (xpl,xpl,ypl,ypl2,m,xlabel,ylabel,
' ',mlabel,slabel)
317 if(index(trim(device),
'p')/=0)
call pgslw(2)
319 call pgline(m,xpl,ypl)
320 mlabel=
"Solid Line is analytic integral of AC array"
322 CALL pgmtxt(
'T',0.3724,0.5,0.5,trim(mlabel))
325 nfit=mp;cutin=cutoff*0.03_dbl;nlo=0;b4=0
326 if(kkam > 0 .AND. kkam < nfit) nfit=kkam
328 IF(.not.
ALLOCATED(a0))
ALLOCATE(a0(nlo+1));a0=0.
329 CALL svdfit(nfit,nlo,cutin,a0,s,yin,m,b4)
330 yfit => polyval(b4,
SIZE(b4),s,
SIZE(s))
332 IF(addv .lt. 0 .AND. nfit == 11)
THEN
335 yfit => polyval(b4,
SIZE(b4),s,
SIZE(s))
336 xpl = sqrt(s); ypl = yin; ypl2 = yfit
337 WRITE(porder,fmt=
'(i2.2)')nfit
338 mlabel =
'mapping & svd['//porder//
'] of pressure(s) vs sqrt(s)'
339 IF (kkam .EQ. 0) mlabel = trim(mlabel)//
" - NOT USED"
340 WRITE(slabel,fmt=
'("eqdsk = ",a," ; <% error>=",es9.2)')
341 . trim(geqdskfile), 200*sum(abs(yin-yfit))/sum(abs(yin+yfit))/nfit
343 & (xpl,xpl,ypl,ypl2,m,xlabel,ylabel,
' ',mlabel,slabel)
345 CALL pgpt1(0.1,real(maxval(yin))/5,5)
346 CALL pgtext (0.18, real(maxval(yin))/5,
"mapped values")
348 CALL pgpt1(0.1,real(maxval(yin))/4,4)
349 CALL pgtext (0.18, real(maxval(yin))/4,
"polynomial fit")
350 formatstring =
'('' AM = '',es14.7,2(/,2x,5(x,es14.7)))'
351 WRITE(67,fmt=formatstring)b4
355 formats = trim(formats)//
',5(1pe11.4,",")," $",/," "'
356 formats = trim(formats)//
'5(1pe11.4,",")'
357 formats = trim(formats)//
',"$",/," ",1pe11.4,"]")'
358 WRITE(138,*)
"; ",trim(slabel)
359 WRITE(138,fmt=trim(formats))(b4(i),i=1,11)
360 WRITE(138,*)
"p[0]=",b4(1),
" & p[1]=",sum(b4)
361 WRITE(*,fmt=trim(formats))(b4(i)/b4(1),i=1,11)
362 WRITE(*,*)
"p[0]=",b4(1),
" & p[1]=",sum(b4)
363 IF ( kkam .EQ. 0 )
THEN
367 CALL doakima(s, yin, m, ier, trim(ylabel))
368 if(ier < 0) print*,
'# knots :',-ier
369 formatstring =
'(" pmass_type=''Akima_spline''")'
370 WRITE(67,fmt=trim(formatstring))
371 formatstring =
'('' am_aux_s = '',es14.7,/,(2x,4es15.7)))'
372 WRITE(67,fmt=trim(formatstring))s2(1:n2)
373 formatstring =
'('' am_aux_f = '',es14.7,/,(2x,4es15.7)))'
374 WRITE(67,fmt=trim(formatstring))f2(1:n2)
378 IF ( kkac .EQ. 0 )
THEN
382 CALL doakima(s, yin, m, ier, trim(ylabel))
383 if(ier < 0) print*,
'# knots :', -ier
384 formatstring =
'(" pcurr_type=''Akima_spline_Ip''")'
385 WRITE(67,fmt=trim(formatstring))
386 formatstring =
'('' ac_aux_s = '',es14.7,/,(2x,4es15.7)))'
387 WRITE(67,fmt=trim(formatstring))s2(1:n2)
388 formatstring =
'('' ac_aux_f = '',es14.7,/,(2x,4es15.7)))'
389 WRITE(67,fmt=trim(formatstring))f2(1:n2)
393 IF ( kkai .EQ. 0 )
THEN
397 CALL doakima(s, yin, m, ier, trim(ylabel))
398 if(ier < 0) print*,
'# knots :', -ier
399 formatstring =
'(" piota_type=''Akima_spline''")'
400 WRITE(67,fmt=trim(formatstring))
401 formatstring =
'('' ai_aux_s = '',es14.7,/,(2x,4es15.7)))'
402 WRITE(67,fmt=trim(formatstring))s2(1:n2)
403 formatstring =
'('' ai_aux_f = '',es14.7,/,(2x,4es15.7)))'
404 WRITE(67,fmt=trim(formatstring))f2(1:n2)
409 WRITE (67,fmt=
'(a,f8.4)')
' RAXIS = ',g1%rmaxis
410 WRITE (67,fmt=
'(a,f8.4)')
' ZAXIS = ',g1%zmaxis
411 CALL descur_sub(g1,g2)
412 CALL surfaces_plot(g1,g2,device)
414 WRITE(67,fmt=
'(1h/)')
415 WRITE(67,fmt=
'(1h/)')
417 WRITE(67, fmt=
'(a)')trim(line(i))
419 WRITE(67,*)
'!Coil ordering for VMEC differs from that for EFIT'
420 WRITE(67,*)
'! 1: f1a 2: f1b'
421 WRITE(67,*)
'! 3: f2a 4: f2b '
422 WRITE(67,*)
'! 5: f3a 6: f3b '
423 WRITE(67,*)
'! 7: f4a 8: f4b '
424 WRITE(67,*)
'! 9: f5a 10: f5b '
425 WRITE(67,*)
'! 11: f6a 12: f6b '
426 WRITE(67,*)
'! 13: f7a 14: f7b '
427 WRITE(67,*)
'! 15: f8a 16: f8b '
428 WRITE(67,*)
'! 17: f9a 18: f9b '
429 WRITE(67,*)
'! 19: 1oR '
430 WRITE(67,*)
'! 20: eca 21: ecb'
431 WRITE(67,*)
'! 22: iu330 23: iu270'
432 WRITE(67,*)
'! 24: iu210 25: iu150'
433 WRITE(67,*)
'! 26: iu90 27: iu30'
434 WRITE(67,*)
'! 28: il330 29: il270'
435 WRITE(67,*)
'! 30: il210 31: il150'
436 WRITE(67,*)
'! 32: il90 33: il30'
437 WRITE(67,*)
'! 34: ccoil79'
438 WRITE(67,*)
'! 35: ccoil139'
439 WRITE(67,*)
'! 36: ccoil199'
442 WRITE(138,fmt=trim(formats))
443 46 stop
'normal termination'