1 SUBROUTINE equalarc(psivin,ipsi)
12 INTEGER :: ipsi, icount=0
14 INTEGER is,js,npc,ntw,npco,npcm1
16 REAL(rprec) :: xp(nxzd),zp(nxzd),bpsqp(nxzd),tp(nxzd)
18 REAL(rprec) :: csx(nxzd),csz(nxzd),csbp(nxzd)
19 REAL(rprec) :: arc(nxzd)
20 REAL(rprec) :: dl,ds,bpsqval
27 REAL(rprec) :: xemin,xemax
28 REAL(rprec) :: yemin,yemax
29 REAL(rprec) :: yxmin,yxmax
30 REAL(rprec) :: xymin,xymax
31 REAL(rprec) :: xaxd,yaxd
32 REAL(rprec) :: dang,arcl,bperr
33 REAL(rprec) :: xmin,xmax
34 REAL(rprec) :: ymin,ymax
35 common/cntd/xaxd,yaxd,
36 $ xemin,xemax,yemin,yemax,yxmin,yxmax,xymin,xymax,
37 $ dang,arcl,bperr,xmin,xmax,ymin,ymax
46 IF(ipsi .eq. 2222)
THEN
47 print*,
" shape(psixz) ",shape(psixz)
48 print*,
" shape(bpsq) ",shape(bpsq)
49 print*,
" shape(xgrid) ",shape(xgrid)
50 print*,
" shape(zgrid) ",shape(zgrid)
51 print*,
" shape(psivin) ",shape(psivin)
52 print*,
" shape(xp) ",shape(xp)
53 print*,
" shape(zp) ",shape(zp)
54 print*,
" shape(bpsqp) ",shape(bpsqp)
55 print*,
"npc,nx,nz,ntw,nxd,nzd,is,js=",
56 & npc,nx,nz,ntw,nxd,nzd,is,js
58 CALL furplm(psixz,bpsq,xgrid,zgrid,psivin,xp,zp,bpsqp,npc,
59 $ nx,nz,ntw,nxd,nzd,is,js)
60 IF(ipsi .eq. 2222)
THEN
61 print*,npc,psivin, maxval(psixz),minval(psixz)
62 print*,(psivin > maxval(psixz)).and.(psivin > minval(psixz))
81 arcl=arcsur(ipsi-1,nthet)/npfit
85 CALL cntourp(xgrid,nx,zgrid,nz,csplpsi,xp,zp,bpsqp,
86 $ npc,dx,dz,nxzd,psivin,nxd)
87 CALL sortr(xp,zp,bpsqp,npc,xaxis,zaxis,xaxis,zaxis,0,1)
89 IF(xp(1).ne.xp(npc).or.zp(1).ne.zp(npc))
THEN
90 WRITE(6,
'("error in equalarc finding contour ",
91 $ i3," of ",i3)') ipsi,npsi
92 WRITE(6,
'("IF this is final contour,"
93 $ ," try reducing percenflux")')
96 CALL sortr(xp,zp,bpsqp,npc,xaxis,zaxis,xaxis,zaxis,0,1)
97 delxz=0.20*min(xgrid(2)-xgrid(1),zgrid(2)-zgrid(1))
98 CALL packk(bpsqp,xp,zp,npc,delxz)
101 WRITE(6,
'("error in equalarc--npc too small=")') npc
111 tp(j)=tp(j-1)+sqrt((xp(j)-xp(j-1))**2+(zp(j)-zp(j-1))**2)
116 CALL spline(tp,xp,npc,-1.e31_dbl,-1.e31_dbl,csx)
120 CALL spline(tp,zp,npc,-1.e31_dbl,-1.e31_dbl,csz)
124 CALL garc(tp,xp,zp,csx,csz,nxzd,arc,npc)
128 CALL spline(arc,xp,npc,-1.e31_dbl,-1.e31_dbl,csx)
132 CALL spline(arc,zp,npc,-1.e31_dbl,-1.e31_dbl,csz)
136 CALL spline(arc,bpsqp,npc,-1.e31_dbl,-1.e31_dbl,csbp)
140 ds=arc(npc)/(nthet-1.)
144 CALL splint(arc,xp,csx,npc,dl,xs(ipsi,j),nlow)
145 CALL splint(arc,zp,csz,npc,dl,zs(ipsi,j),nlow)
146 CALL splint(arc,bpsqp,csbp,npc,dl,bpsqval,nlow)
147 IF(bpsqval.gt.0.)
THEN
148 bps(ipsi,j)=sqrt(bpsqval)
154 xs(ipsi,nthet)=xs(ipsi,1)
155 zs(ipsi,nthet)=zs(ipsi,1)
156 bps(ipsi,nthet)=bps(ipsi,1)
157 arcsur(ipsi,nthet)=arc(npc)
158 END SUBROUTINE equalarc