diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..db3080b --- /dev/null +++ b/Makefile @@ -0,0 +1,46 @@ +# Executable name +EXE=gray + +# Objects list +OBJ=gray.o grayl.o green_func_p.o const_and_precisions.o itm_constants.o itm_types.o + +# Alternative search paths +vpath %.f90 src +vpath %.f src + +# Fortran compiler name and flags +FC=gfortran +FFLAGS=-O3 + +all: $(EXE) + +# Build executable from object files +$(EXE): $(OBJ) + $(FC) $(FFLAGS) -o $@ $^ + +# Dependencies on modules +green_func_p.o: const_and_precisions.o +const_and_precisions.o: itm_types.o itm_constants.o +itm_constants.o: itm_types.o + +# General object compilation command +%.o: %.f90 + $(FC) $(FFLAGS) -c $< + +gray.o:gray.f green_func_p.o + $(FC) $(FFLAGS) -c $< + +grayl.o:grayl.f + $(FC) $(FFLAGS) -c $^ + +.PHONY: clean install +# Remove output files +clean: + rm -rf *.o *.mod $(EXE) + +install: + @if [ -f $(EXE) ]; then \ + cp $(EXE) ~/bin/; \ + else \ + echo File $(EXE) does not exist. Run \'make\' first; \ + fi diff --git a/src/const_and_precisions.f90 b/src/const_and_precisions.f90 new file mode 100755 index 0000000..26ce054 --- /dev/null +++ b/src/const_and_precisions.f90 @@ -0,0 +1,105 @@ +!########################################################################! + + MODULE const_and_precisions + use itm_types, only : wp_ => r8 + use itm_constants, only : pi => itm_pi, e_ => itm_qe, me_ => itm_me, c_ => itm_c +!########################################################################! + IMPLICIT NONE + PUBLIC +!------------------------------------------------------------------------ +! common precisions +!------------------------------------------------------------------------ +! INTEGER, PARAMETER :: sp_ = 4 ! single precision +! INTEGER, PARAMETER :: dp_ = 8 ! double precision +! INTEGER, PARAMETER :: wp_ = dp_ ! work-precision +! INTEGER, PARAMETER :: odep_ = dp_ ! ODE-solver precision +! INTEGER, PARAMETER :: xp_ = wp_ ! for ext. modules if necessary +!------------------------------------------------------------------------ +! precisions which are in use in CONFIG_yat +!------------------------------------------------------------------------ +! INTEGER, PARAMETER :: ypi_ = 4 ! <- direct precision def. +! INTEGER, PARAMETER :: ypd_ = 8 ! <- direct precision def. +!------------------------------------------------------------------------ +! length of the file names +!------------------------------------------------------------------------ + !INTEGER, PARAMETER :: lfn_ = 256 ! <- requested for yat +!!======================================================================== +! Arithmetic constants +!======================================================================== + REAL(wp_), PARAMETER :: zero = 0.0_wp_ + REAL(wp_), PARAMETER :: unit = 1.0_wp_ +! REAL(wp_), PARAMETER :: pi = 3.141592653589793_wp_ +! REAL(wp_), PARAMETER :: sqrt_pi = 1.772453850905516_wp_ +! REAL(wp_), PARAMETER :: sqrt_2 = 1.414213562373095_wp_ +! REAL(wp_), PARAMETER :: rad = pi/180.0_wp_ +!--- +! REAL(wp_), PARAMETER :: ex(1:3) = (/unit,zero,zero/) +! REAL(wp_), PARAMETER :: ey(1:3) = (/zero,unit,zero/) +! REAL(wp_), PARAMETER :: ez(1:3) = (/zero,zero,unit/) +!--- +! REAL(wp_), PARAMETER :: kron(3,3) = reshape((/unit,zero,zero, & +! zero,unit,zero, & +! zero,zero,unit/),(/3,3/)) +! COMPLEX(wp_), PARAMETER :: im = (0.0_wp_,1.0_wp_) +! COMPLEX(wp_), PARAMETER :: czero = (0.0_wp_,0.0_wp_) +! COMPLEX(wp_), PARAMETER :: cunit = (1.0_wp_,0.0_wp_) +! COMPLEX(wp_), PARAMETER :: ctwo = (2.0_wp_,0.0_wp_) +!======================================================================== +! Computer constants +!======================================================================== + REAL(wp_), PARAMETER :: comp_eps = EPSILON(unit) +! REAL(wp_), PARAMETER :: comp_eps2 = comp_eps**2 +! REAL(wp_), PARAMETER :: comp_tiny = TINY(unit) +! REAL(wp_), PARAMETER :: comp_huge = HUGE(unit) +! REAL(wp_), PARAMETER :: comp_tinylog =-200 ! LOG10(comp_tiny) +! REAL(wp_), PARAMETER :: comp_hugelog =+200 ! LOG10(comp_huge) +! REAL(wp_), PARAMETER :: comp_tiny1 = 1d+50*comp_tiny +! REAL(wp_), PARAMETER :: comp_huge1 = 1d-50*comp_huge +! REAL(wp_), PARAMETER :: comp_tiny1log = LOG10(comp_tiny1) +! REAL(wp_), PARAMETER :: comp_huge1log = LOG10(comp_huge1) +!------------------------------------------------------------------------ +! Conventional constants +!------------------------------------------------------------------------ +! REAL(wp_), PARAMETER :: output_tiny = 1.0d-66 +! REAL(wp_), PARAMETER :: output_huge = 1.0d+66 +!======================================================================== +! Physical constants (SI) +!======================================================================== +! REAL(wp_), PARAMETER :: e_ = 1.602176487d-19 ! [C] +! REAL(wp_), PARAMETER :: me_ = 9.10938215d-31 ! [kg] +! REAL(wp_), PARAMETER :: mp_ = 1.672621637d-27 ! [kg] +! REAL(wp_), PARAMETER :: rmpe_ = mp_/me_ +! REAL(wp_), PARAMETER :: c_ = 2.99792458d+08 ! [m/s] +! REAL(wp_), PARAMETER :: eps0_ = 8.854187817d-12 ! [F/m] +!------------------------------------------------------------------------ +! Useful definitions +!------------------------------------------------------------------------ + REAL(wp_), PARAMETER :: keV_ = 1000*e_ ! [J] + REAL(wp_), PARAMETER :: mc2_SI = me_*c_**2 ! [J] + REAL(wp_), PARAMETER :: mc2_ = mc2_SI/keV_ ! [keV] +! REAL(wp_), PARAMETER :: mc_ = me_*c_ ! [kg*m/s] +! ! f_ce = fce1_*B (B in Tesla): ! +! REAL(wp_), PARAMETER :: wce1_ = e_/me_ ! [rad/s] +! REAL(wp_), PARAMETER :: fce1_ = wce1_/(2*pi) ! [1/s] +! ! f_pl = fpe1_*sqrt(Ne) (Ne in 1/m**3): ! +! REAL(wp_), PARAMETER :: wpe1_ = 56.4049201 ! [rad/s] +! REAL(wp_), PARAMETER :: fpe1_ = wpe1_/(2*pi) ! [1/s] +! REAL(wp_), PARAMETER :: wpe12_ = wpe1_**2 ! +! ! vte = vte1_*sqrt(Te) (Te in keV): ! +! REAL(wp_), PARAMETER :: vte1_ = 1.8755328e7 ! [m/s] +! ! je = curr1_*sqrt(Te)*Ne (Ne in 1/m**3): ! +! REAL(wp_), PARAMETER :: curr1_ = e_*vte1_ ! [A/m**2] +!!======================================================================== +!! Upper limit for the momentum value for integration +!!======================================================================== +! REAL(wp_), PARAMETER :: umax_ = 7.0d0 ! max of (p/pth) +! INTEGER, PARAMETER :: nu_ = 700 ! size of upar-array +!======================================================================== +! minimal value of Nparallel +!======================================================================== +! REAL(wp_), PARAMETER :: Npar_min = 1.0d-3 +!########################################################################! + + END MODULE const_and_precisions + +!########################################################################! diff --git a/src/gray.f b/src/gray.f new file mode 100644 index 0000000..06f65ac --- /dev/null +++ b/src/gray.f @@ -0,0 +1,6488 @@ + implicit real*8 (a-h,o-z) + common/istop/istop + common/ierr/ierr + common/igrad/igrad + common/iovmin/iovmin + common/mode/sox + common/p0/p0mw + common/powrfl/powrfl + common/index_rt/index_rt + common/taumnx/taumn,taumx,pabstot,currtot + common/ipass/ipass + +c read data plus initialization + + index_rt=1 + call prfile + call paraminit + call read_data + call vectinit + if(igrad.eq.0) call ic_rt + if(igrad.gt.0) call ic_gb + if(ierr.gt.0) go to 999 + +c beam/ray propagation + call gray_integration + +c postprocessing + + call after_gray_integration + + pabstott=pabstot + currtott=currtot + powtr=p0mw-pabstot + + if (iovmin.eq.3.and.istop.eq.1.and.ipass.gt.1) then +c second pass into plasma + p0mw1=p0mw + igrad=0 + + index_rt=2 + p0mw=p0mw1*powrfl + call prfile + call vectinit2 + call paraminit + call ic_rt0 + call gray_integration + call after_gray_integration + pabstott=pabstott+pabstot + currtott=currtott+currtot + + index_rt=3 + sox=-sox + p0mw=p0mw1*(1.0d0-powrfl) + call prfile + call vectinit2 + call paraminit + call ic_rt0 + call gray_integration + call after_gray_integration + pabstott=pabstott+pabstot + currtott=currtott+currtot + end if + +999 continue + print*,' ' + print*,' IERR = ', ierr + print*,'Pabs (MW), Icd (kA) = ', pabstott,currtott*1.0d+3 + stop + end + + + subroutine gray_integration + implicit real*8 (a-h,o-z) + + common/ss/st + common/dsds/dst + common/istep/istep + common/nstep/nstep + common/istop/istop + common/strfl11/strfl11 + common/index_rt/index_rt + +c ray integration: begin + st0=0.0d0 + if(index_rt.gt.1) st0=strfl11 + do i=1,nstep + istep=i + st=i*dst+st0 + +c advance one step + + call rkint4 + +c calculations after one step: + + call after_onestep(istep,istop) + if(istop.eq.1) exit +c + end do + +c ray integration: end + + return + end + + + subroutine after_gray_integration + implicit real*8 (a-h,o-z) + parameter(zero=0.0d0) + character*24 filenmeqq,filenmprf,filenmbm +c + common/ss/st + common/ibeam/ibeam + common/warm/iwarm,ilarm + common/filesn/filenmeqq,filenmprf,filenmbm + common/nrayktx/nray,ktx + common/iieq/iequil + common/iipr/iprof + common/index_rt/index_rt +c + common/p0/p0mw + common/factb/factb + common/taumnx/taumn,taumx,pabstot,currtot + common/scal/iscal + common/facttn/factt,factn +c +c print all ray positions in local reference system +c + if(nray.gt.1) then + iproj=1 + nfilp=9 + call projxyzt(iproj,nfilp) + end if +c +c print final results on screen +c + print*,' ' + print'(a,f9.4)','final step (s, ct, Sr) = ',st + if(iwarm.gt.0) then + print '(a,2e12.5)','taumn, taumx = ', taumn,taumx + else + print '(a,2f9.4)','taumn, taumx = ', zero,zero + end if +c + print'(a,f9.4)','Pabs_tot (MW) = ',pabstot + currtka =currtot*1.0d3 + print'(a,f9.4)','I_tot (kA) = ',currtka +c + if (index_rt.eq.1) then + if(iequil.eq.2) write(6,*) 'EQUILIBRIUM CASE : ',filenmeqq + if(iequil.eq.1) write(6,*) 'ANALTYCAL EQUILIBRIUM' + if(iprof.eq.1) write(6,*) 'PROFILE file : ',filenmprf + if(iprof.eq.0) write(6,*) 'ANALTYCAL PROFILES' + if(ibeam.ge.1) write(6,*) 'LAUNCHER CASE : ',filenmbm + + write(49,*) 'factb, iscal, factT factn = ',factb,iscal, + . factt,factn + end if + write(49,*) ' ' + write(49,*) 'P0 (MW), Pabs (MW), I_cd (kA)' + write(49,99) p0mw,pabstot,currtka +c +c compute power and current density profiles for all rays +c + pabs=pabstot + currt=currtot + call pec(pabs,currt) +c + return + 99 format(20(1x,e16.8e3)) + end +c +c +c + subroutine after_onestep(i,istop) + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36,nmx=8000) + parameter(taucr=12.0d0,pi=3.14159265358979d0,cvdr=pi/180.0d0) + dimension psjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension iiv(jmx,kmx),tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx) + dimension iov(jmx,kmx),tau1v(jmx,kmx),yyrfl(jmx,kmx,6) + dimension xv(3),anv(3),xvrfl(3),anvrfl(3) + + common/pcjki/ppabs,ccci + common/atjki/tauv,alphav + common/tau1v/tau1v +c + common/warm/iwarm,ilarm + common/nrayktx/nray,ktx + common/ist/istpr0,istpl0 + common/istgr/istpr,istpl +c + common/iiv/iiv + common/iov/iov + common/psjki/psjki + common/psival/psinv + common/psinv11/psinv11 + common/ierr/ierr + common/taumnx/taumn,taumx,pabstot,currtot + common/xv/xv + common/anv/anv + common/cent/btrcen,rcen +c + common/p0/p0mw + common/pola/psipola,chipola + common/ipol/ipolc + common/iovmin/iovmin + common/densbnd/psdbnd + common/yyrfl/yyrfl + common/powrfl/powrfl + common/dstvac/dstvac + common/strfl11/strfl11 + common/dsds/dst + common/index_rt/index_rt + common/ipass/ipass +c + pabstot=0.0d0 + currtot=0.0d0 + taumn=1d+30 + taumx=-1d+30 + psinv11=1.0d0 + iovmin=100 +c + do j=1,nray + kktx=ktx + if(j.eq.1) kktx=1 + do k=1,kktx + call gwork(j,k) +c + if(ierr.gt.0) then + print*,' IERR = ', ierr + if(ierr.eq.97) then +c igrad=0 +c ierr=0 + else + istop=1 + exit + end if + end if + + psjki(j,k,i)=psinv + rrm=sqrt(xv(1)**2+xv(2)**2)/100.d0 + + if (iwarm.gt.0.and.i.gt.1) then + if(psinv.ge.0.and.psinv.le.1.0d0) then + call pabs_curr(i,j,k) + iiv(j,k)=i + else + if(iiv(j,k).gt.1) tauv(j,k,i)=tauv(j,k,i-1) + end if + if(tauv(j,k,i).le.taumn) taumn=tauv(j,k,i) + if(tauv(j,k,i).ge.taumx) taumx=tauv(j,k,i) + pabstot=pabstot+ppabs(j,k,iiv(j,k)) + currtot=currtot+ccci(j,k,iiv(j,k)) + end if + call print_output(i,j,k) + + if(i.gt.1.and.psinv.ge.0.and.psinv.lt.psdbnd) + . iov(j,k)=1 + if(iov(j,k).eq.1.and.psinv.ge.psdbnd) iov(j,k)=2 +c iov=0 initially, iov=1 first entrance in plasma, +c iov=2 first exit from plasma, iov=3 after 2nd entrance into plasma + + if(index_rt.eq.1) then + if(j.eq.1) then + psinv11=psinv + if(ipolc.eq.0.and.iov(j,k).eq.1) then + call pol_limit(qqin,uuin,vvin) + ipolc=1 + qqa=cos(2.0d0*psipola*cvdr)*cos(2.0d0*chipola*cvdr) + uua=sin(2.0d0*psipola*cvdr)*cos(2.0d0*chipola*cvdr) + vva=sin(2.0d0*chipola*cvdr) + powa=0.5d0*(1.0d0+vva*vvin+uua*uuin+qqa*qqin) +c p0mw=p0mw*powa +c print*,' ' +c print*,'Coupled power fraction =',powa +c print*,' ' +c print*,'Input coupled power (MW) =',p0mw +c print*,' ' + end if + if (ipass.gt.1) then + if(ipolc.eq.1.and.iov(j,k).eq.2.and.rrm.le.rcen) then + call pol_limit(qqout,uuout,vvout) + ipolc=2 + call wall_refl(xvrfl,anvrfl,qqrfl,uurfl,vvrfl,irfl) + strfl11=i*dst+dstvac + call pol_limit(qqin2,uuin2,vvin2) + if(irfl.gt.0) then + powrfl=0.5d0*(1.0d0+vvrfl*vvin2+uurfl*uuin2+qqrfl*qqin2) + else + powrfl=0.5d0*(1.0d0+vvout*vvin2+uuout*uuin2+qqout*qqin2) + end if + print*,'Reflected power fraction =',powrfl + iov(j,k)=3 + yyrfl(j,k,1)=xvrfl(1) + yyrfl(j,k,2)=xvrfl(2) + yyrfl(j,k,3)=xvrfl(3) + yyrfl(j,k,4)=anvrfl(1) + yyrfl(j,k,5)=anvrfl(2) + yyrfl(j,k,6)=anvrfl(3) + tau1v(j,k)=tauv(j,k,iiv(j,k)) + end if + end if + else + if(iov(j,k).eq.2.and.rrm.le.rcen.and.ipass.gt.1) then + call wall_refl(xvrfl,anvrfl,qqrfl,uurfl,vvrfl,irfl) + iov(j,k)=3 + yyrfl(j,k,1)=xvrfl(1) + yyrfl(j,k,2)=xvrfl(2) + yyrfl(j,k,3)=xvrfl(3) + yyrfl(j,k,4)=anvrfl(1) + yyrfl(j,k,5)=anvrfl(2) + yyrfl(j,k,6)=anvrfl(3) + tau1v(j,k)=tauv(j,k,iiv(j,k)) + end if + end if + end if + + if(iov(j,k).lt.iovmin) iovmin=iov(j,k) + + end do + end do + + if(iwarm.gt.0.and.taumn.lt.1d+30.and.taumn.gt.taucr) istop=1 + + psimin=psjki(1,1,i) + if(nray.gt.1) psimin=min(psimin,minval(psjki(2:nray,1:ktx,i))) + if(psimin.gt.1.0d0.and.rrm.gt.rcen.and.index_rt.gt.1) + . istop=1 + + if(iovmin.eq.3) istop=1 + +c print ray positions for j=nray in local reference system + + istpr=istpr+1 + if (istpr.eq.istpr0) then +c print*,'istep = ',i + if(nray.gt.1) then + iproj=0 + nfilp=8 + call projxyzt(iproj,nfilp) + end if + istpr=0 + end if +c + if (istpl.eq.istpl0) istpl=0 + istpl=istpl+1 + return + end +c +c +c + subroutine print_output(i,j,k) + implicit real*8 (a-h,o-z) + parameter(ndim=6,jmx=31,kmx=36,nmx=8000) + parameter(taucr=12.0d0) + parameter(pi=3.14159265358979d0) + dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx) + dimension psjki(jmx,kmx,nmx) + dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx) + dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx) + dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension q(jmx),tau1v(jmx,kmx) + complex*16 ex,ey,ez + +c + common/psjki/psjki + common/atjki/tauv,alphav + common/dpjjki/pdjki,currj + common/pcjki/ppabs,ccci + common/dcjki/didst + common/nhn/nhn + common/iokh/iohkawa + common/p0/p0mw + common/tau1v/tau1v + common/qw/q + common/index_rt/index_rt + + common/ss/st + common/nrayktx/nray,ktx + common/istgr/istpr,istpl + common/ist/istpr0,istpl0 + common/iieq/iequil +c + common/parpl/brr,bphi,bzz,ajphi + common/btot/btot + common/xgxg/xg + common/ygyg/yg + common/dens/dens,ddens + common/tete/tekev + common/absor/alpha,effjcd,akim,tau0 + common/densbnd/psdbnd + common/epolar/ex,ey,ez +c + common/nplr/anpl,anpr + common/ddd/dd,an2s,an2,fdia,bdotgr,ddi + common/nprw/anprr,anpri +c + common/wrk/ywrk,ypwrk +c + x=ywrk(1,j,k) + y=ywrk(2,j,k) + z=ywrk(3,j,k) + rr=sqrt(x*x+y*y) +c + anx=ywrk(4,j,k) + any=ywrk(5,j,k) + anz=ywrk(6,j,k) + anr=(anx*x+any*y)/rr + anphi=(any*x-anx*y)/rr + cnphi=(any*x-anx*y) +c + rrm=rr*1.0d-2 + zzm=z*1.0d-2 + stm=st*1.0d-2 + xxm=x*1.0d-2 + yym=y*1.0d-2 +c +c central ray only begin +c + if(index_rt.gt.1) then + taujk=tauv(j,k,i)+tau1v(j,k) + else + taujk=tauv(j,k,i) + end if + + if(j.eq.1) then + phi=acos(x/sqrt(y*y+x*x)) + if(y.lt.0.0d0) phi=-phi + phideg=phi*180.0d0/pi + psi=psjki(j,k,i) + rhot=1.0d0 + bbr=0.0d0 + bbz=0.0d0 + bpol=0.0d0 + rhot=1.0d0 + dens11=0.0d0 + if(psi.ge.0.0d0) then + if(iequil.eq.2) then + if (psi.le.1.0d0) rhot=frhotor(psi) + bbr=brr + bbz=bzz + bpol=sqrt(bbr**2+bbz**2) + else + rhot=sqrt(psi) + end if + else + tekev=0.0d0 + akim=0.0d0 + end if + pt11=exp(-tauv(j,k,i)) + cutoff=xg-(1-yg)*(1-anpl**2) +c +c write(16,99) st,x,y,z,rr,phideg,anx,any,anz,anr,anphi + write(17,99) st,x,y,z,rr,dd,cnphi,ddi + write(18,99) st,rr,z,psjki(j,k,i),dens,tekev,xg,yg,btot,anpl + . ,ddens,bbr,bphi,bbz,bpol,ajphi +c write(19,99) st,rr,z,psjki(j,k,i),anpl,anr,anz,anphi +c . ,brr,bzz,bphi +c +c print dIds in A/m/W, Jphi and Jt in MA/m2, ki in m^-1 +c + if(psi.le.psdbnd.and.psi.ge.0.0d0) dens11=dens + dids11=didst(j,k,i)*1.0d2/(p0mw*q(j)) +c + write(4,99) stm,rrm,zzm,phideg,psjki(j,k,i),rhot,dens11,tekev, + . bphi,ajphi*1.0d-6,sqrt(an2),anpl, + . akim*100,pt11,dids11,dble(nhn),dble(iohkawa),cutoff,xg,yg +c + call polarcold(exf,eyif,ezf,elf,etf) +c write(24,99) stm,rrm,zzm,phideg,psjki(j,k,i),sqrt(an2),anpl, +c . akim*100,ex,ey,ez,exf,eyif,ezf,elf,etf,xg +c print dIds in MA/m, Jcd in MA/m^2, ppabs and pdjki in MW/m^3 +c in the absorption region, tau>0 +c + + if(tauv(j,k,i).le.taucr) then + alph=alphav(j,k,i) + if(istpl.eq.istpl0) write(31,111) i,j,k,st,xxm,yym,rrm,zzm, + . psjki(j,k,i),taujk,anpl,alph,currj(j,k,i) + if(tauv(j,k,i).gt.0) + . write(23,99) st,rr,z,psjki(j,k,i),alphav(j,k,i),taujk, + . ppabs(j,k,i),pdjki(j,k,i),currj(j,k,i),didst(j,k,i)*1.0d2 + end if +c + end if +c +c central ray only end +c + if(k.eq.1.and.j.eq.nray) write(27,99) st,x,y,z,rr,dd,ddi +c + if(j.eq.nray) then + if(tauv(j,k,i).le.taucr) then + alph=alphav(j,k,i) + if(istpl.eq.istpl0) write(33,111) i,j,k,st,xxm,yym,rrm,zzm, + . psjki(j,k,i),taujk,anpl,alph,currj(j,k,i) + if(k.eq.ktx) write(33,*) ' ' + end if + end if +c + return + 99 format(20(1x,e16.8e3)) +111 format(3i5,16(1x,e16.8e3)) + end +c +c +c + subroutine prfile + implicit none + integer*4 index_rt + common/index_rt/index_rt + If(index_rt.eq.1) then + write(4,*)'#sst R z phi psi rhot ne Te Bphi Jphi N Npl ki Pt'// + .' dIds nh iohkw cutoff xg yg' +c write(24,*)'#sst R z phi psi rhot N Npl ki +c . exr exi eyr eyi ezr ezi exf eyif ezf elf etf xg' + write(8,*) ' #istep j k xt yt zt rt xdps ydps zdps vxp vyp vzp'// + .' rhop11' + write(9,*) ' #istep j k xt yt zt rt xdps ydps zdps vxp vyp vzp'// + .' rhop11' + write(17,*) ' #sst x y z rr dd cnphi ddi' + write(18,*)' #sst rr z psi dens temp xg yg bt N//'// + .' ddens Br Bphi Bz Bp Jphi' +c write(19,*) ' #sst rr z psi anpl anr anz anphi br bz bphi' + write(23,*) ' #sst R z psi alpha tau Pabs dPdV J dIds' + write(27,*) ' #sst x y z rr dd ddi' + write(31,*) ' #i j k sst x y R z psi tauv Npl alpha Jcd' + write(33,*) ' #i j k sst x y R z psi tauv Npl alpha Jcd' + write(12,*) ' #i sst rhop w1 w2 w1a w2a' + write(29,*) '#beta alfa qqom uuom vvom psiom chiom'// + .' qqxm uuxm vvxm psixm chixm' + write(28,*) '#beta alfa anpl -gam ffo ffx xe2om xe2xm' + else + If(index_rt.eq.3) then + write(4,*) ' ' + write(8,*) ' ' + write(9,*) ' ' + write(17,*) ' ' + write(18,*) ' ' + write(23,*) ' ' + write(27,*) ' ' +c write(31,*) ' ' +c write(33,*) ' ' + write(12,*) ' ' + end if + end if + return + end +c +c +c + subroutine read_data + use green_func_p, only:Setup_SpitzFunc + implicit real*8 (a-h,o-z) + real*8 me + character*24 filenmeqq,filenmprf,filenmbm + parameter(qe=4.8032d-10,me=9.1095d-28,vc=2.9979d+10) + parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) +c + common/xgcn/xgcn + + common/ipec/ipec,nnd + common/nstep/nstep + common/ibeam/ibeam + common/ist/istpr0,istpl0 + common/warm/iwarm,ilarm + common/ieccd/ieccd + common/idst/idst +c + common/filesn/filenmeqq,filenmprf,filenmbm +c + common/nrayktx/nray,ktx + common/rhomx/rmx + common/dsds/dst + common/igrad/igrad + common/ipass/ipass + common/rwallm/rwallm + common/iieq/iequil + common/icocos/icocos + common/ixp/ixp + common/ipsn/ipsinorm + common/sspl/sspl + common/iipr/iprof + common/factb/factb + common/facttn/factt,factn + common/cent/btrcen,rcen +c + common/parwv/ak0,akinv,fhz + common/parbeam/wxt,wyt,rcixt,rciyt,phiw,phir + common/anic/anx0c,any0c,anz0c + common/mirr/x00,y00,z00 + common/pola/psipola,chipola +c + common/pardens/dens0,aln1,aln2 + common/parban/b0,rr0m,zr0m,rpam + common/parqq/q0,qa,alq + common/parqte/te0,dte0,alt1,alt2 + common/zz/Zeff +c + common/parbres/bres + common/densbnd/psdbnd + common/nfile/neqdsk,nprof + common/sgnib/sgnbphi,sgniphi + common/p0/p0mw +c + common/mode/sox + common/angles/alfac,betac + common/scal/iscal +c + open(2,file='gray.data',status= 'unknown') +c +c alfac, betac (cartesian) launching angles +c fghz wave frequency (GHz) +c p0mw injected power (MW) +c + read(2,*) alfac,betac + read(2,*) fghz + read(2,*) p0mw +c +c nray number of rays in radial direction +c ktx number of rays in angular direction +c rmx normalized maximum radius of beam power +c rmx=1 -> last ray at radius = waist +c + read(2,*) nray,ktx,rmx + if(nray.eq.1) ktx=1 +c +c x00,y00,z00 coordinates of launching point +c + read(2,*) x00,y00,z00 +c +c beams parameters in local reference system +c w0t -> waist, pw0 -> waist distance from launching point +c awr angle of beam ellipse +c + read(2,*) w0xt,w0yt,pw0xt,pw0yt,awr +c +c ibeam=0 :read data for beam as above +c ibeam=1 :read data from file simple astigmatic beam +c ibeam=2 :read data from file general astigmatic beam + read(2,*) ibeam + read(2,*) filenmbm +c +c iequil=0 :vacuum +c iequil=1 :analytical equilibrium +c iequil=2 :read eqdsk +c ixp=0,-1,+1 : no X point , bottom/up X point +c + read(2,*) iequil,ixp +c +c iprof=0 :analytical density and temp. profiles +c iprof>0 :numerical density and temp. profiles +c + read(2,*) iprof +c +c iwarm=0 :no absorption and cd +c iwarm=1 :weakly relativistic absorption +c iwarm=2 :relativistic absorption, n<1 asymptotic expansion +c iwarm=3 :relativistic absorption, numerical integration +c ilarm :order of larmor expansion +c + read(2,*) iwarm,ilarm +c if(iwarm.gt.2) iwarm=2 +c +c ieccd 0/1 NO/YES ECCD calculation ieccd>0 different CD models +c + read(2,*) ieccd + if (ieccd.ge.10) call Setup_SpitzFunc +c +c ipec=0/1 :pec profiles grid in psi/rhop +c nnd :number of grid steps for pec profiles +1 +c + read(2,*) ipec,nnd +c +c dst integration step +c nstep maximum number of integration steps +c istpr0 projection step = dsdt*istprj +c istpl0 plot step = dsdt*istpl +c igrad=0 optical ray-tracing, initial conditions as for beam +c igrad=1 quasi-optical ray-tracing +c igrad=-1 ray-tracing, init. condit. +c from center of mirror and with angular spread +c ipass=1/2 1 or 2 passes into plasma +c iox=1/2 OM/XM +c idst=0/1/2 0 integration in s, 1 integr. in ct, 2 integr. in Sr +c + read(2,*) dst,nstep,istpr0,istpl0,idst + read(2,*) igrad,ipass,rwallm + read(2,*) iox, psipola,chipola +c +c ipsinorm 0 standard EQDSK format, 1 format Portone summer 2004 +c sspl spline parameter for psi interpolation +c + read(2,*) filenmeqq + read(2,*) ipsinorm,sspl +c +c factb factor for magnetic field (only for numerical equil) +c scaling adopted: beta=const, qpsi=const, nustar=const +c iscal ne Te scaling 0: nustar=const, 1: n_greenw=const; 2 no rescaling +c factT factn factor for Te&ne scaling +c + read(2,*) factb, iscal,factt,factn + if (factb.eq.0.0d0) factb=1.0d0 +c +c psbnd value of psi ( > 1 ) of density boundary +c + read(2,*) filenmprf + read(2,*) psdbnd + if(iprof.eq.0) psdbnd=1.0d0 +c +c signum of toroidal B and I +c icocos index for equilibrium from COCOS - O. Sauter Feb 2012 + read(2,*) sgnbphi,sgniphi,icocos +c +c read parameters for analytical density and temperature +c profiles if iprof=0 +c + if(iprof.eq.0) then + read(2,*) dens0,aln1,aln2 + read(2,*) te0,dte0,alt1,alt2 + else + read(2,*) dummy,dummy,dummy + read(2,*) dummy,dummy,dummy,dummy + end if + read(2,*) zeff +c +c read parameters for analytical simple cylindical equilibrium +c if iequil=0,1 + + if(iequil.lt.2) then + read(2,*) rr0,zr0,rpa + read(2,*) b0 + read(2,*) q0,qa,alq + rr0m=rr0/1.0d2 + zr0m=zr0/1.0d2 + rpam=rpa/1.0d2 + else + read(2,*) dummy,dummy,dummy + read(2,*) dummy + read(2,*) dummy,dummy,dummy + end if +c + close(unit=2) +c + if(nray.eq.1) igrad=0 + if (nray.lt.5) then + igrad=0 + print*,' nray < 5 ! => OPTICAL CASE ONLY' + print*,' ' + end if +c + fhz=fghz*1.0d9 + ak0=2.0d9*pi*fghz/vc + akinv=1.0d0/ak0 +c + bresg=2.0d0*pi*fhz*me*vc/qe + bres=bresg*1.0d-4 +c +c xg=xgcn*dens19 +c + xgcn=1.0d-5*qe**2/(pi*me*fghz**2) +c + sox=-1.0d0 + if(iox.eq.2) sox=1.0d0 +c +c read data for beam from file if ibeam>0 +c + if(ibeam.gt.0) then + call read_beams + else + zrxt=0.5d0*ak0*w0xt**2 + zryt=0.5d0*ak0*w0yt**2 + if(igrad.gt.0) then + wxt=w0xt*sqrt(1.0d0+(pw0xt/zrxt)**2) + wyt=w0yt*sqrt(1.0d0+(pw0yt/zryt)**2) + rcixt=-pw0xt/(pw0xt**2+zrxt**2) + rciyt=-pw0yt/(pw0yt**2+zryt**2) + phiw=awr + phir=awr + else + pw0yt=pw0xt + wxt=w0xt*abs(pw0xt/zrxt) + wyt=w0yt*abs(pw0yt/zryt) + rcixt=w0xt/zrxt + rciyt=w0yt/zryt + if(pw0xt.gt.0) then + rcixt=-rcixt + rciyt=-rciyt + end if + phiw=awr + phir=awr + end if + end if +c + print'(a,2f8.3)','alfac, betac = ',alfac,betac +c + r00=sqrt(x00**2+y00**2) + phi0=acos(x00/r00) + if(y00.lt.0) phi0=-phi0 + print'(a,4f8.3)','x00, y00, R00, z00 = ',x00,y00,r00,z00 + print*,' ' +c +c anx0c=(anr0c*x00-anphi0c*y00)/r00 +c any0c=(anr0c*y00+anphi0c*x00)/r00 +c +c anr0c=(anx0c*x00+any0c*y00)/r00 +c anphi0c=(any0c*x00-anx0c*y00)/r00 +c +c angles alfac, betac in a local reference system as proposed by Gribov et al +c +c anr0c=-cos(cvdr*betac)*cos(cvdr*alfac) +c anphi0c=sin(cvdr*betac) +c anz0c=-cos(cvdr*betac)*sin(cvdr*alfac) + + anr0c=-cos(cvdr*betac)*cos(cvdr*alfac) + anphi0c=sin(cvdr*betac) + anz0c=-cos(cvdr*betac)*sin(cvdr*alfac) + + anx0c=(anr0c*x00-anphi0c*y00)/r00 + any0c=(anr0c*y00+anphi0c*x00)/r00 +c +c read data for Te , ne , Zeff from file if iprof>0 +c + + if (iprof.eq.1) then + nprof=98 + lprf=length(filenmprf) + open(file=filenmprf(1:lprf)//'.prf', + . status= 'unknown',unit=nprof) + call profdata + close(nprof) + end if +c +c read equilibrium data from file if iequil=2 +c + if (iequil.eq.2) then + neqdsk=99 + leqq=length(filenmeqq) + open(file=filenmeqq(1:leqq)//'.eqdsk', + . status= 'unknown', unit=neqdsk) + call equidata + close(neqdsk) +c +c print density, temperature, safecty factor, toroidal current dens +c versus psi, rhop, rhot +c + call print_prof + end if +c + if(iequil.eq.2) write(49,*) 'EQUILIBRIUM CASE : ',filenmeqq + if(iequil.eq.1) write(49,*) 'ANALYTICAL EQUILIBRIUM' + if(iprof.eq.1) write(49,*) 'PROFILE file : ',filenmprf + if(iprof.eq.0) write(49,*) 'ANALYTICAL PROFILES' + if(ibeam.ge.1) write(49,*) 'LAUNCHER CASE : ',filenmbm + write(49,*) 'nray, ktx, igrad: ',nray, ktx, igrad +c + write(49,*) 'X Y Z launching point (cm) ' + write(49,*) x00,y00,z00 + write(49,*) 'waist widths (cm), rot angle' + write(49,*) w0xt,w0yt,awr + write(49,*) 'waist locations (cm)' + write(49,*) pw0xt,pw0yt +c + write(49,*) 'alfac, betac' + write(49,99) alfac,betac +c + open(77,status='unknown',file='tit.gnu') + if (iequil.eq.2) then +c write (77,707) filenmeqq,alfac,betac +c707 format('set title "',a16,' alpha =',f6.2,' beta =',f6.2,'"') + write (77,707) filenmeqq,factb,alfac,betac +707 format('set title "',a16,f8.3,2f7.2,'"') + end if + close(77) +c + if (iequil.eq.1) call surf_anal +c + if (iequil.eq.2.and.iprof.eq.1) then + nfil=78 + open(nfil,file='tit.txt',status= 'unknown') + write(nfil,905) filenmeqq + write(nfil,907) filenmprf + write(nfil,911) fghz + write(nfil,914) btrcen, sgnbphi,sgniphi,icocos + write(nfil,900) nray, ktx, rmx + write(nfil,902) x00,y00,z00 + if(ibeam.ge.1) write(nfil,909) filenmbm + if(ibeam.eq.0) write(nfil,903) w0xt,w0yt,pw0xt,pw0yt,awr + write(nfil,901) igrad,iwarm,ilarm,ieccd,idst + if(ieccd.eq.1) write(nfil,912) + if(ieccd.eq.11) write(nfil,913) + write(nfil,904) p0mw,iox + write(nfil,906) factb,factt,factn,iscal + write(nfil,910) ipec,nnd,ipsinorm,sspl,psdbnd +c write(nfil,915) psi15,sqrt(psi15),rhot15 +c write(nfil,920) psi2,sqrt(psi2),rhot2 + write(nfil,*) ' ' + close(nfil) + end if + + return + +900 format('# Nray ktx rmx',2i5,1x,e12.5) +901 format('# igrad iwarm ilarm ieccd idst',6i5) +902 format('# X Y Z launching point (cm) : ',3(1x,e12.5)) +903 format('# w0xt w0yt pw0xt pw0yt (cm) delta (deg) : ',5(1x,e12.5)) +904 format('# P0 IOX ',(1x,e12.5,i5)) +906 format('# fact_B fact_T fact_n iscal',(3(1x,e12.5),i5)) +905 format('# EQUILIBRIUM CASE : ',a24) +907 format('# PROFILE file : ',a24) +909 format('# LAUNCHER CASE : ',a24) +910 format('# ipec nd ipsinorm sspl psdbnd : ',3i5,2(1x,e12.5)) +914 format('# |BT0| , sgnB_phi, sgnI_phi, icocos : ',3(1x,e12.5),i5) +915 format('# psi_1.5 rhop_1.5 rhot_1.5 : ',3(1x,e12.5)) +920 format('# psi_2 rhop_2 rhot_2 : ',3(1x,e12.5)) +911 format('# fghz : ',(1x,e12.5)) +912 format('# Cohen model') +913 format('# Momentum conservation model') + + 99 format(20(1x,e16.8e3)) + end +c +c +c + subroutine surf_anal + implicit real*8(a-h,o-z) + parameter(pi=3.14159265358979d0) + common/parban/b0,rr0m,zr0m,rpam + common/parbres/bres +c +c print circular magnetic surfaces iequil=1 +c + write(71,*) '#i psi R z' + dal=2.0d-2*pi + drn=0.1d0 + do i=1,10 + rni=i*drn + do k=1,101 + drrm=rpam*rni*cos((k-1)*dal) + dzzm=rpam*rni*sin((k-1)*dal) + rrm=rr0m+drrm + zzm=zr0m+dzzm + write(71,111) i,rni,rrm,zzm + end do + write(71,*) ' ' + write(71,*) ' ' + end do +c +c print resonant B iequil=1 +c + write(70,*)'#i Btot R z' + rres=bres*rr0m/b0 + zmx=zr0m+rpam + zmn=zr0m-rpam + do i=1,21 + zzres=zmn+(i-1)*(zmx-zmn)/2.0d1 + write(70,111) i,bres,rres,zzres + end do + + return +111 format(i4,20(1x,e16.8e3)) + end +c +c + subroutine read_beams + implicit real*8(a-h,o-z) + character*24 filenmeqq,filenmprf,filenmbm + parameter(nstrmx=50) +c + dimension alphastv(nstrmx),betastv(nstrmx),cbeta(nstrmx,4) + dimension x00v(nstrmx),y00v(nstrmx),z00v(nstrmx) + dimension cx0(nstrmx,4),cy0(nstrmx,4),cz0(nstrmx,4) + dimension waist1v(nstrmx),waist2v(nstrmx) + dimension rci1v(nstrmx),rci2v(nstrmx) + dimension cwaist1(nstrmx,4),cwaist2(nstrmx,4) + dimension crci1(nstrmx,4),crci2(nstrmx,4) + dimension phi1v(nstrmx),phi2v(nstrmx) + dimension cphi1(nstrmx,4),cphi2(nstrmx,4) +c + common/ibeam/ibeam + common/filesn/filenmeqq,filenmprf,filenmbm + common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir + common/mirr/x00,y00,z00 + common/angles/alfac,betac + common/parwv/ak0,akinv,fhz +c +c for given alfac -> betac + beam parameters +c +c ibeam=1 simple astigmatic beam +c ibeam=2 general astigmatic beam +c +c initial beam data are measured in mm -> transformed to cm +c + nfbeam=97 + lbm=length(filenmbm) + open(file=filenmbm(1:lbm)//'.txt',status= 'unknown',unit=nfbeam) +c + read(nfbeam,*) nisteer + do i=1,nisteer + if(ibeam.eq.1) then + read(nfbeam,*) steer,alphast,betast,x00mm,y00mm,z00mm, + . waist1,dvir1,waist2,dvir2,delta + phi1=delta + phi2=delta + zr1=0.5d-1*ak0*waist1**2 + zr2=0.5d-1*ak0*waist2**2 + w1=waist1*sqrt(1.0d0+(dvir1/zr1)**2) + w2=waist2*sqrt(1.0d0+(dvir2/zr2)**2) + rci1=-dvir1/(dvir1**2+zr1**2) + rci2=-dvir2/(dvir2**2+zr2**2) + else + read(nfbeam,*) steer,alphast,betast,x00mm,y00mm,z00mm, + . w1,w2,rci1,rci2,phi1,phi2 + end if + x00v(i)=0.1d0*x00mm + y00v(i)=0.1d0*y00mm + z00v(i)=0.1d0*z00mm + alphastv(i)=alphast + betastv(i)=betast + waist1v(i)=0.1d0*w1 + rci1v(i)=1.0d1*rci1 + waist2v(i)=0.1d0*w2 + rci2v(i)=1.0d1*rci2 + phi1v(i)=phi1 + phi2v(i)=phi2 + end do +c + iopt=0 + call difcs(alphastv,betastv,nisteer,iopt,cbeta,ier) + call difcs(alphastv,waist1v,nisteer,iopt,cwaist1,ier) + call difcs(alphastv,rci1v,nisteer,iopt,crci1,ier) + call difcs(alphastv,waist2v,nisteer,iopt,cwaist2,ier) + call difcs(alphastv,rci2v,nisteer,iopt,crci2,ier) + call difcs(alphastv,phi1v,nisteer,iopt,cphi1,ier) + call difcs(alphastv,phi2v,nisteer,iopt,cphi2,ier) + call difcs(alphastv,x00v,nisteer,iopt,cx0,ier) + call difcs(alphastv,y00v,nisteer,iopt,cy0,ier) + call difcs(alphastv,z00v,nisteer,iopt,cz0,ier) +c + if(alfac.gt.alphastv(1).and.alfac.lt.alphastv(nisteer)) then + call locate(alphastv,nisteer,alfac,k) + dal=alfac-alphastv(k) + betst=spli(cbeta,nisteer,k,dal) + x00=spli(cx0,nisteer,k,dal) + y00=spli(cy0,nisteer,k,dal) + z00=spli(cz0,nisteer,k,dal) + wcsi=spli(cwaist1,nisteer,k,dal) + weta=spli(cwaist2,nisteer,k,dal) + rcicsi=spli(crci1,nisteer,k,dal) + rcieta=spli(crci2,nisteer,k,dal) + phiw=spli(cphi1,nisteer,k,dal) + phir=spli(cphi2,nisteer,k,dal) + else + print*,' alfac outside table range !!!' + if(alfac.ge.alphastv(nisteer)) ii=nisteer + if(alfac.le.alphastv(1)) ii=1 + betst=betastv(ii) + x00=x00v(ii) + y00=y00v(ii) + z00=z00v(ii) + wcsi=waist1v(ii) + weta=waist2v(ii) + rcicsi=rci1v(ii) + rcieta=rci2v(ii) + phiw=phi1v(ii) + phir=phi2v(ii) + end if + betac=betst +c + close(nfbeam) +c + return + end +c +c +c + subroutine equidata + implicit real*8 (a-h,o-z) + parameter(nnw=501,nnh=501) + parameter(pi=3.14159265358979d0) + parameter(nbb=1000) + character*48 stringa + dimension fpol(nnw),pres(nnw),qpsi(nnw) + dimension ffprim(nnw),pprim(nnw) + dimension psi(nnw,nnh),rv(nnw),zv(nnh),psin(nnw,nnh),psinr(nnw) + dimension rbbbs(nbb),zbbbs(nbb) +c + parameter(nrest=nnw+4,nzest=nnh+4) + parameter(lwrk=4*(nnw+nnh)+11*(nrest+nzest)+nrest*nnh+nzest+54) + parameter(liwrk=nnh+nnw+nrest+nzest+3,kspl=3) + dimension fvpsi(nnw*nnh),cc(nnw*nnh),ffvpsi(nnw*nnh) + dimension tr(nrest),tz(nzest),wrk(lwrk),iwrk(liwrk) + parameter(lwrkbsp=4*(nnw+nnh),liwrkbsp=nnw+nnh) + dimension wrkbsp(lwrkbsp),iwrkbsp(liwrkbsp) + parameter(lw10=nnw*3+nnh*4+nnw*nnh,lw01=nnw*4+nnh*3+nnw*nnh) + parameter(lw20=nnw*2+nnh*4+nnw*nnh,lw02=nnw*4+nnh*2+nnw*nnh) + parameter(lw11=nnw*3+nnh*3+nnw*nnh,ldiwrk=nnw+nnh) + dimension cc01(lw01),cc10(lw10),cc02(lw02),cc20(lw20),cc11(lw11) + dimension iwrkd(ldiwrk) + parameter(lwrkf=nnw*4+nrest*16) + dimension tfp(nrest),cfp(nrest),wrkf(lwrkf),iwrkf(nrest),wf(nnw) + dimension fpoli(nnw) +c + common/pareq1/psia + common/pareq1a/psiaxis0 + common/cent/btrcen,rcen + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + common/psinr/psinr + common/qpsi/qpsi + common/cpsin/rv,zv,psin + common/cpsi/psi + common/eqnn/nr,nz,npp,nintp + common/ipsn/ipsinorm + common/sspl/sspl + common/nfile/neqdsk,nprof + common/bound/zbmin,zbmax + common/sgnib/sgnbphi,sgniphi + common/factb/factb + common/ixp/ixp + common/icocos/icocos + + common/coffeqt/tr,tz + common/coffeqtp/tfp + common/coffeq/cc + common/coffeqd/cc01,cc10,cc20,cc02,cc11 + common/coffeqn/nsrt,nszt,nsft + common/cofffp/cfp + common/fpas/fpolas + common/rhotsx/rhotsx + common/rrtor/rrtor + common/cnt/rup,zup,rlw,zlw +c +c read from file eqdsk +c (see http://fusion.gat.com/efit/g_eqdsk.html) +c +c spline interpolation of psi and derivatives +c + if(icocos.gt.0) then + read (neqdsk,'(a48,3i4)') stringa,idum,nr,nz + else + read (neqdsk,*) nr,nz + end if + if(ipsinorm.eq.0) then + read (neqdsk,2020) drnr1,dznz1,rcen,rleft,zmid + read (neqdsk,2020) rmaxis,zmaxis,psiax,psiedge,btrcen + read (neqdsk,2020) current,simag,xdum,rmaxis,xdum + read (neqdsk,2020) zmaxis,xdum,sibry,xdum,xdum + read (neqdsk,2020) (fpol(i),i=1,nr) + read (neqdsk,2020) (pres(i),i=1,nr) + read (neqdsk,2020) (ffprim(i),i=1,nr) + read (neqdsk,2020) (pprim(i),i=1,nr) + read (neqdsk,2020) ((psi(i,j),i=1,nr),j=1,nz) + read (neqdsk,2020) (qpsi(i),i=1,nr) + else + read (neqdsk,*) drnr1,dznz1,rcen,rleft,zmid + read (neqdsk,*) rmaxis,zmaxis,psiax,psiedge,btrcen + read (neqdsk,*) current,simag,xdum,rmaxis,xdum + read (neqdsk,*) zmaxis,xdum,sibry,xdum,xdum + read (neqdsk,*) (fpol(i),i=1,nr) + read (neqdsk,*) (pres(i),i=1,nr) + read (neqdsk,*) (ffprim(i),i=1,nr) + read (neqdsk,*) (pprim(i),i=1,nr) + read (neqdsk,*) ((psin(i,j),i=1,nr),j=1,nz) + read (neqdsk,*) (qpsi(i),i=1,nr) + end if +2020 format (5e16.9) + +c +c compensate for different reference systems +c + icocosmod=mod(icocos,10) + + if (mod(icocos,2).eq.0.and.icocosmod.gt.0) then +c icocos mod 2 = 0: toroidal angle phi CW (opposite to gray convention) + btrcen=-btrcen + current=-current + do i=1,nr + fpol(i)=-fpol(i) + end do + end if +c + if (icocosmod.eq.1 .or. icocosmod.eq.4 .or. + & icocosmod.eq.5 .or. icocosmod.eq.8) then +c icocos mod 10 = 1,4,5,8: psi increasing with CCW Ip +c icocos mod 10 = 2,3,6,7: psi decreasing with CCW Ip + psiedge=-psiedge + psiax=-psiax + if (ipsinorm.eq.0) then + do j=1,nz + do i=1,nr + psi(i,j)=-psi(i,j) + end do + end do + end if + end if + +c +c add check for Ip/psi and B0/Fpol sign consistency? +c + current=sign(current,psiax-psiedge) + btrcen=sign(btrcen,fpol(nr)) + +c +c length in m !!! +c + dr=drnr1/dble(nr-1) + dz=dznz1/dble(nz-1) + rv(1)=rleft + zv(1)=zmid-dznz1/2.0d0 + dpsinr=1.0d0/dble(nr-1) +c + do i=1,nr + psinr(i)=(i-1)*dpsinr + rv(i)=rv(1)+(i-1)*dr + end do +c + do j=1,nz + zv(j)=zv(1)+(j-1)*dz + end do +c + rmnm=rv(1) + rmxm=rv(nr) + zmnm=zv(1) + zmxm=zv(nz) +c +c psi function +c +c + + psia0=psiedge-psiax +c icocos=0: adapt psi to force Ip sign, otherwise maintain psi + if (icocosmod.ne.0) sgniphi=sign(1.0d0,-psia0) + current=sign(current,sgniphi) + + psia=-sgniphi*abs(psia0)*factb +c icocos>10: input psi is in Wb +c icocos<10: input psi is in Wb/rad (gray convention) + if (icocos.ge.10) psia=psia/(2.0d0*pi) + + psiaxis0=0.0d0 + do j=1,nz + do i=1,nr + if(ipsinorm.eq.0) then + psin(i,j)=abs(psi(i,j)-psiax)/abs(psia0) + psi(i,j)=psin(i,j)*psia + else + psi(i,j)=psin(i,j)*psia + end if + ij=nz*(i-1)+j + fvpsi(ij)=psin(i,j) + enddo + enddo +c +c spline interpolation of psi(i,j) and derivatives +c + iopt=0 + call regrid(iopt,nr,rv,nz,zv,fvpsi,rmnm,rmxm,zmnm,zmxm, + . kspl,kspl,sspl,nrest,nzest,nsr,tr,nsz,tz,cc,fp, + . wrk,lwrk,iwrk,liwrk,ier) + nsrt=nsr + nszt=nsz + if (sspl.gt.0.0d0) then + call bispev(tr,nsr,tz,nsz,cc,kspl,kspl,rv,nr,zv,nz,ffvpsi, + . wrkbsp,lwrkbsp,iwrkbsp,liwrkbsp,ier) +c + do j=1,nz + do i=1,nr + ij=nz*(i-1)+j + psin(i,j)=ffvpsi(ij) + psi(i,j)=psin(i,j)*psia +c write(79,2021) rv(i),zv(j),psin(i,j) + enddo +c write(79,*) ' ' + enddo + end if +2021 format(5(1x,e16.9)) +c + nur=1 + nuz=0 + call parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,rv,nr,zv,nz, + . ffvpsi,cc10,lw10,iwrkd,ldiwrk,ier) +c + nur=0 + nuz=1 + call parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,rv,nr,zv,nz, + . ffvpsi,cc01,lw01,iwrkd,ldiwrk,ier) +c + nur=2 + nuz=0 + call parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,rv,nr,zv,nz, + . ffvpsi,cc20,lw20,iwrkd,ldiwrk,ier) +c + nur=0 + nuz=2 + call parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,rv,nr,zv,nz, + . ffvpsi,cc02,lw02,iwrkd,ldiwrk,ier) +c + nur=1 + nuz=1 + call parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz,rv,nr,zv,nz, + . ffvpsi,cc11,lw11,iwrkd,ldiwrk,ier) +c + if(ixp.ne.0) then + read (neqdsk,*) nbbbs,limitr + if(nbbbs.gt.0) then + if(ipsinorm.eq.1) + . read (neqdsk,*) (rbbbs(i),zbbbs(i),i=1,nbbbs) + if(ipsinorm.eq.0) + . read (neqdsk,2020) (rbbbs(i),zbbbs(i),i=1,nbbbs) + end if +c +c compute max and min z of last closed surface +c + zbmin=1.0d+30 + zbmax=-1.0d+30 + if (nbbbs.gt.1) then + do i=1,nbbbs + if(zbbbs(i).le.zbmin) then + zbmin=zbbbs(i) + rbmin=rbbbs(i) + end if + if(zbbbs(i).ge.zbmax) then + zbmax=zbbbs(i) + rbmax=rbbbs(i) + end if + end do + end if + if(zbmin.eq.zmnm) zbmin=zbmin+dz + if(rbmin.eq.rmnm) rbmin=rbmin+dr + if(zbmax.eq.zmxm) zbmax=zbmax-dz + if(rbmax.eq.rmxm) rbmax=rbmax-dr + else + zbmin=zmnm+dz + rbmin=rmnm+dr + zbmax=zmxm-dz + rbmax=rmxm-dr + end if +c +c scaling of f_poloidal +c +c icocos=0: adapt fpol to force Ip sign, otherwise maintain fpol + if (icocosmod.ne.0) sgnbphi=sign(1.0d0,fpol(nr)) + btrcen=sign(btrcen,sgnbphi) + + do i=1,nr + fpol(i)=sgnbphi*abs(fpol(i))*factb + wf(i)=1.0d0 + end do + wf(nr)=1.0d2 + +c +c spline interpolation of fpol(i) +c + iopt=0 + xb=0.0d0 + xe=1.0d0 + ssfp=0.01d0 + call curfit(iopt,nr,psinr,fpol,wf,xb,xe,kspl,ssfp,nrest,nsft, + . tfp,cfp,fp,wrkf,lwrkf,iwrkf,ier) +c + call splev(tfp,nsft,cfp,3,psinr,fpoli,nr,ier) + fpolas=fpoli(nr) +c +c search for O-point +c + call points_ox(rmaxis,zmaxis,rmop,zmop,psinop,info) + rmaxis=rmop + zmaxis=zmop + print'(a,2f8.4,e12.5)','O-point',rmop,zmop,psinop +c +c search for X-point if ixp not = 0 +c + if(ixp.ne.0) then + if(ixp.lt.0) then + r10=rbmin + z10=zbmin + call points_ox(r10,z10,rxp,zxp,psinxp,info) + if(psinxp.ne.-1.0d0) then + print'(a,2f8.4,e12.5)','X-point',rxp,zxp,psinxp + rbmin=rxp + zbmin=zxp + delpsinox=(psinxp-psinop) + psia=psia*delpsinox + deltapsi=abs(psia) + psiaxis0=psia*psinop + psin1=1.0d0 + r10=rmaxis + z10=(zbmax+zmaxis)/2.0d0 + call points_tgo(r10,z10,r1,z1,psin1,info) + rbmax=r1 + zbmax=z1 + else + ixp=0 +c print'(a)','no X-point' + end if + else + r10=rmop + z10=zbmax + call points_ox(r10,z10,rxp,zxp,psinxp,info) + if(psinxp.ne.-1.0d0) then + print'(a,2f8.4,e16.8)','X-point',rxp,zxp,psinxp + zbmax=zxp + delpsinox=(psinxp-psinop) + psia=psia*delpsinox + deltapsi=abs(psia) + psiaxis0=psia*psinop + psin1=1.0d0 + z10=(zbmin+zmaxis)/2.0d0 + call points_tgo(r10,z10,r1,z1,psin1,info) + zbmin=z1 + else + ixp=0 +c print'(a)','no X-point' + end if + end if + end if +c + if (ixp.eq.0) then + psin1=1.0d0 + delpsinox=(psin1-psinop) + psia=psia*delpsinox + deltapsi=abs(psia) + psiaxis0=psia*psinop + r10=rmaxis + z10=(zbmax+zmaxis)/2.0d0 + call points_tgo(r10,z10,r1,z1,psin1,info) + zbmax=z1 + rbmax=r1 + z10=(zbmin+zmaxis)/2.0d0 + call points_tgo(r10,z10,r1,z1,psin1,info) + zbmin=z1 + rbmin=r1 + print'(a,4f8.4)','no X-point ',rbmin,zbmin,rbmax,zbmax + end if + print*,' ' + +c +c compute B_toroidal on axis +c + btaxis=fpol(1)/rmaxis + btrcen=abs(btrcen)*factb + print'(a,f8.4)','factb = ',factb + print'(a,f8.4)','|BT_centr|= ',btrcen + print'(a,f8.4)','|BT_axis| = ',abs(btaxis) +c +c compute normalized rho_tor from eqdsk q profile +c + call rhotor(nr) +c phitedge=deltapsi*rhotsx*2*pi +c rrtor=sqrt(phitedge/abs(btrcen)/pi) +c +c compute flux surface averaged quantities +c + rup=rmaxis + rlw=rmaxis + zup=(zbmax+zmaxis)/2.0d0 + zlw=(zmaxis+zbmin)/2.0d0 + call flux_average +c +c locate psi surface for q=1.5 and q=2 +c + rup=rmaxis + rlw=rmaxis + zup=(zbmax+zmaxis)/2.0d0 + zlw=(zmaxis+zbmin)/2.0d0 + q2=2.0d0 + q15=1.5d0 + call vmaxmini(qpsi,nr,qmin,qmax,iqmn,iqmx) + if (q15.gt.qmin.and.q15.lt.qmax) then + call surfq(q15,psi15) + rhot15=frhotor(psi15) + print'(3(a,f8.5))','psi_1.5 = ',psi15,' rhop_1.5 = ' + . ,sqrt(psi15),' rhot_1.5 = ',rhot15 + end if + if (q2.gt.qmin.and.q2.lt.qmax) then + call surfq(q2,psi2) + rhot2=frhotor(psi2) + print'(3(a,f8.5))','psi_2 = ',psi2,' rhop_2 = ' + . ,sqrt(psi2),' rhot_2 = ',rhot2 + end if +c +c locate btot=bres +c + call bfield_res +c + return + end +c +c +c + subroutine points_ox(rz,zz,rf,zf,psinvf,info) + implicit real*8 (a-h,o-z) + parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2) + dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcnox + common/psival/psinv + xvec(1)=rz + xvec(2)=zz + tol = sqrt(dpmpar(1)) + call hybrj1(fcnox,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa) + if(info.gt.1) then + print'(a,i2,a,2f8.4)',' info subr points_ox =',info, + . ' O/X coord.',xvec + end if + rf=xvec(1) + zf=xvec(2) + psinvf=psinv + return + end +c +c +c + subroutine fcnox(n,x,fvec,fjac,ldfjac,iflag) + implicit real*8 (a-h,o-z) + dimension x(n),fvec(n),fjac(ldfjac,n) + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + common/pareq1/psia + call equinum(x(1),x(2)) + if (iflag.ne.2) then + fvec(1) = dpsidr/psia + fvec(2) = dpsidz/psia + else + fjac(1,1) = ddpsidrr/psia + fjac(1,2) = ddpsidrz/psia + fjac(2,1) = ddpsidrz/psia + fjac(2,2) = ddpsidzz/psia + end if + return + end +c +c +c + subroutine points_tgo(rz,zz,rf,zf,psin,info) + implicit real*8 (a-h,o-z) + parameter(n=2,ldfjac=n,lwa=(n*(n+13))/2) + dimension xvec(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcntgo + common/cnpsi/h + h=psin + xvec(1)=rz + xvec(2)=zz + tol = sqrt(dpmpar(1)) + call hybrj1(fcntgo,n,xvec,fvec,fjac,ldfjac,tol,info,wa,lwa) + if(info.gt.1) then +c print*,' subr points_tgo: info=',info + end if + rf=xvec(1) + zf=xvec(2) + return + end +c +c +c + subroutine fcntgo(n,x,fvec,fjac,ldfjac,iflag) + implicit real*8 (a-h,o-z) + dimension x(n),fvec(n),fjac(ldfjac,n) + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + common/psival/psinv + common/cnpsi/h + common/pareq1/psia + call equinum(x(1),x(2)) + if (iflag.ne.2) then + fvec(1) = psinv-h + fvec(2) = dpsidr/psia + else + fjac(1,1) = dpsidr/psia + fjac(1,2) = dpsidz/psia + fjac(2,1) = ddpsidrr/psia + fjac(2,2) = ddpsidrz/psia + end if + return + end +c +c +c + subroutine print_prof + implicit real*8 (a-h,o-z) + parameter(nnw=501,eps=1.d-4) + dimension psinr(nnw),qpsi(nnw) +c + common/psinr/psinr + common/qpsi/qpsi + common/eqnn/nr,nz,npp,nintp + common/dens/dens,ddens +c + write(55,*) ' #psi rhop rhot ne Te q Jphi' + psin=0.0d0 + rhop=0.0d0 + rhot=0.0d0 + call density(psin) + call tor_curr_psi(eps,ajphi) + te=temp(psin) + qq=qpsi(1) +c + write(55,111) psin,rhop,rhot,dens,te,qq,ajphi*1.d-6 +c + nst=nr + do i=2,nst + psin=dble(i-1)/dble(nst-1) + rhop=sqrt(psin) +c + call density(psin) + te=temp(psin) +c + ips=int((nr-1)*psin+1) + if(i.lt.nst) then + call intlin(psinr(ips),qpsi(ips),psinr(ips+1),qpsi(ips+1), + . psin,qq) + else + qq=qpsi(nr) + end if + rhot=frhotor(psin) + call tor_curr_psi(psin,ajphi) + write(55,111) psin,rhop,rhot,dens,te,qq,ajphi*1.d-6 + end do +c + return + 111 format(12(1x,e12.5)) + end +c +c +c + subroutine surfq(qval,psival) + implicit real*8 (a-h,o-z) + parameter(nnw=501) + parameter(ncnt=100,ncntt=2*ncnt+1) + dimension psinr(nnw),qpsi(nnw) + dimension rcon(ncntt),zcon(ncntt) +c + common/psinr/psinr + common/qpsi/qpsi + common/eqnn/nr,nz,npp,nintp +c +c locate psi surface for q=qval +c + call locate(qpsi,nr,qval,i1) + call intlin(qpsi(i1),psinr(i1),qpsi(i1+1),psinr(i1+1), + . qval,psival) + ipr=1 + call contours_psi(psival,ncnt,rcon,zcon,ipr) + return + end +c +c +c + subroutine bfield_res + implicit real*8 (a-h,o-z) + parameter(nnw=501,nnh=501) + dimension rv(nnw),zv(nnh),psin(nnw,nnh) + dimension btotal(nnw,nnh) + parameter(icmx=2002) + dimension rrcb(icmx),zzcb(icmx),ncpts(10) +c + common/cpsin/rv,zv,psin + common/eqnn/nr,nz,npp,nintp + common/parbres/bres + common/btt/btotal +c +c Btotal on psi grid +c + btmx=-1.0d30 + btmn=1.0d30 + do j=1,nr + rrj=rv(j) + do k=1,nz + zzk=zv(k) + call bfield(rrj,zzk,bbphi,bbr,bbz) + btotal(j,k)=sqrt(bbr**2+bbz**2+bbphi**2) + if(btotal(j,k).ge.btmx) btmx=btotal(j,k) + if(btotal(j,k).le.btmn) btmn=btotal(j,k) +c write(90,113) j,rrj,zzk,btotal(j,k) + enddo +c write(90,*) ' ' + enddo +c +c compute Btot=Bres and Btot=Bres/2 +c + write(70,*)'#i Btot R z' + do n=1,5 + bbb=bres/dble(n) + if (bbb.ge.btmn.and.bbb.le.btmx) then + call cniteq(bbb,nconts,ncpts,nctot,rrcb,zzcb,1) + do inc=1,nctot + write(70,113) inc,bbb,rrcb(inc),zzcb(inc) + end do + end if + write(70,*) ' ' + end do +c + return + 113 format(i6,12(1x,e12.5)) + end +c +c + subroutine profdata + implicit real*8 (a-h,o-z) + parameter(npmx=250,npest=npmx+4) + dimension psrad(npmx),terad(npmx),derad(npmx),zfc(npmx) + dimension ct(npmx,4),cz(npmx,4) + parameter(lwrkf=npmx*4+npest*16) + dimension tfn(npest),cfn(npest),wrkf(lwrkf),iwrkf(npest),wf(npmx) + dimension densi(npest),ddensi(npest),d2densi(npest),wrkfd(npest) +c + common/densbnd/psdbnd + common/denspp/psnpp,aa,bb,cc + common/eqnn/nr,nz,npp,nintp + common/iipr/iprof + common/nfile/neqdsk,nprof + common/crad/psrad,derad,terad,zfc + common/coffte/ct + common/coffz/cz + common/factb/factb + common/coffdt/tfn + common/coffdnst/nsfd + common/cofffn/cfn + common/scal/iscal + common/facttn/factt,factn +c +c read plasma profiles from file if iprof>0 +c + if (iscal.eq.0) then + aat=2.0d0/3.0d0 + aan=4.0d0/3.0d0 + else + aat=1.0d0 + aan=1.0d0 + end if + ffact=factb + if(iscal.eq.2) ffact=1.0d0 +c + if (iprof.gt.0) then + read(nprof,*) npp + read(nprof,*) psrad0,terad0,derad0,zfc0 + if(psrad0.ne.0.0d0) psrad0=0.0d0 + psrad(1)=psrad0 + terad(1)=terad0*ffact**aat*factt + derad(1)=derad0*ffact**aan*factn + zfc(1)=zfc0 + wf(1)=1.0d0 + do i=2,npp + read(nprof,*) psradi,teradi,deradi,zfci + psrad(i)=psradi + terad(i)=teradi*ffact**aat*factt + derad(i)=deradi*ffact**aan*factn + zfc(i)=zfci + wf(i)=1.0d0 + end do +c +c spline approximation of temperature and Zeff +c + iopt=0 + call difcsn(psrad,terad,npmx,npp,iopt,ct,ier) +c + iopt=0 + call difcsn(psrad,zfc,npmx,npp,iopt,cz,ier) +c +c spline approximation of density +c + iopt=0 + xb=0.0d0 + xe=psrad(npp) + kspl=3 + sspl=.001d0 +c + call curfit(iopt,npp,psrad,derad,wf,xb,xe,kspl,sspl,npest,nsfd, + . tfn,cfn,fp,wrkf,lwrkf,iwrkf,ier) +c + call splev(tfn,nsfd,cfn,3,psrad,densi,npp,ier) + nu=1 + call splder(tfn,nsfd,cfn,3,nu,psrad,ddensi,npp,wrkfd,ier) + dnpp=densi(npp) + ddnpp=ddensi(npp) +c + nu=2 + call splder(tfn,nsfd,cfn,3,nu,psrad,d2densi,npp,wrkfd,ier) + d2dnpp=d2densi(npp) + + if(derad(npp).eq.0.0d0) then + psdbnd=psrad(npp) + else + psnpp=psrad(npp) + dpsb=-psnpp+psdbnd + nn=3 + nn1=nn+1 + nn2=nn+2 + aa=(nn1*nn2*dnpp+2*nn1*ddnpp*dpsb+d2dnpp*dpsb**2) + aa=aa/(-dpsb)**nn/2.0d0 + bb=-(nn*nn2*dnpp+(2*nn+1)*ddnpp*dpsb+d2dnpp*dpsb**2) + bb=bb/(-dpsb)**nn1 + cc=(nn1*nn*dnpp+2*nn*ddnpp*dpsb+d2dnpp*dpsb**2) + cc=cc/(-dpsb)**nn2/2.0d0 + end if +c + end if +c + return + end +c +c +c + subroutine rhotor(nr) + implicit real*8(a-h,o-z) + parameter(nnw=501) + dimension psinr(nnw),qpsi(nnw),rhotnr(nnw),cq(nnw,4),crhot(nnw,4) + common/psinr/psinr + common/qpsi/qpsi + common/rhotsx/rhotsx + common/crhot/crhot +c +c normalized toroidal rho : ~ Integral q(psi) dpsi +c + iopt=0 + call difcsn(psinr,qpsi,nnw,nr,iopt,cq,ier) +c + rhotnr(1)=0.0d0 + do k=1,nr-1 + dx=psinr(k+1)-psinr(k) + drhot=dx*(cq(k,1)+dx*(cq(k,2)/2.0d0+dx*(cq(k,3)/3.0d0 + . +dx*cq(k,4)/4.0d0))) + rhotnr(k+1)=rhotnr(k)+drhot + end do + rhotsx=rhotnr(nr) + do k=1,nr + rhotnr(k)=sqrt(rhotnr(k)/rhotnr(nr)) + end do +c +c spline interpolation of rhotor +c + iopt=0 + call difcs(psinr,rhotnr,nr,iopt,crhot,ier) + return + end + + function frhotor_eq(psi) + implicit real*8(a-h,o-z) + parameter(nnw=501) + dimension psinr(nnw),crhot(nnw,4) + common/psinr/psinr + common/eqnn/nr,nz,npp,nintp + common/crhot/crhot +c + irt=int((nr-1)*psi+1) + if(irt.eq.0) irt=1 + if(irt.eq.nr) irt=nr-1 + dps=psi-psinr(irt) + frhotor_eq=spli(crhot,nr,irt,dps) + return + end + + function frhotor(psi) + implicit real*8(a-h,o-z) + frhotor=frhotor_eq(psi) + return + end + + function frhotor_av(psi) + implicit real*8(a-h,o-z) + parameter(nnintp=101) + dimension rpstab(nnintp),crhotq(nnintp,4) + common/pstab/rpstab + common/eqnn/nr,nz,npp,nintp + common/crhotq/crhotq + + rpsi=sqrt(psi) + ip=int((nintp-1)*rpsi+1) + if(ip.eq.0) ip=1 + if(ip.eq.nintp) ip=nintp-1 + dps=rpsi-rpstab(ip) + frhotor_av=spli(crhotq,nintp,ip,dps) + + return + end + + subroutine cniteq(h, ncon, npts, icount, rcon, zcon,ichoi) + implicit real*8 (a-h,o-z) +c +c v2.01 12/07/95 -- written by d v bartlett, jet joint undertaking. +c (based on an older code) +c + parameter(nnw=501,nnh=501,icmx=2002,nna=nnw*nnh) + dimension a(nna),ja(3,2),lx(1000),npts(10) + dimension rcon(icmx),zcon(icmx) + dimension rqgrid(nnw),zqgrid(nnh),psin(nnw,nnh),btotal(nnw,nnh) +c + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + common/cpsin/rqgrid,zqgrid,psin + common/btt/btotal + common/eqnn/nr,nz,npp,nintp +c + data px/0.5d0/ +c + if(ichoi.eq.0) then + do j=1,nz + do i=1,nr + a(nr*(j-1)+i)=psin(i,j) + enddo + enddo + endif +c + if(ichoi.eq.1) then + do j=1,nz + do i=1,nr + a(nr*(j-1)+i)=btotal(i,j) + enddo + enddo + endif +c + do ico=1,icmx + rcon(ico)=0.0d0 + zcon(ico)=0.0d0 + enddo +c + nrqmax=nr + nreq=nr + nzeq=nz + drgrd=dr + dzgrd=dz +c + ncon = 0 + do i=1,10 + npts(i) = 0 + end do + iclast = 0 + icount = 0 + mpl=0 + ix=0 + mxr = nrqmax * (nzeq - 1) + n1 = nreq - 1 +c + do 3 jx=2,n1 + do 3 jm=jx,mxr,nrqmax + j = jm + nrqmax + ah=a(j)-h + if(ah) 60,60,61 + 60 if(a(jm)-h) 62,62,1 + 61 if(a(jm)-h) 1,1,63 + 1 ix=ix+1 + lx(ix)=-j + if(ah) 62,62,63 + 62 if(a(j-1)-h) 3,3,4 + 63 if(a(j-1)-h) 4,4,3 + 4 ix=ix+1 + lx(ix)=j + 3 continue +c + do 79 jm=nreq,mxr,nrqmax + j = jm + nrqmax + ah=a(j)-h + if(ah) 64,64,65 + 64 if(a(j-1)-h) 66,66,76 + 65 if(a(j-1)-h) 76,76,67 + 76 ix=ix+1 + lx(ix)=j + if(ah) 66,66,67 + 66 if(a(jm)-h) 79,79,78 + 67 if(a(jm)-h) 78,78,79 + 78 ix=ix+1 + lx(ix)=-j + 79 continue +c + do 75 jm=1,mxr,nrqmax + j = jm + nrqmax + if(a(j)-h) 68,68,69 + 68 if(a(jm)-h)75,75,71 + 69 if(a(jm)-h)71,71,75 + 71 ix=ix+1 + lx(ix) =-j + 75 continue +c + do 73 j=2,nreq + if(a(j)-h) 58,58,59 + 58 if(a(j-1)-h) 73,73,72 + 59 if(a(j-1)-h) 72,72,73 + 72 ix=ix+1 + lx(ix)=j + 73 continue +c + if(ix) 50,50,8 + 108 if(mpl.lt.4) go to 8 + ncon = ncon + 1 + npts(ncon) = icount - iclast + iclast = icount + 8 in=ix + jx=lx(in) + jfor=0 + lda=1 + ldb=2 + 30 if(jx) 21,22,22 + 21 jabs=-jx + jnb = jabs - nrqmax + go to 23 + 22 jabs=jx + jnb=jabs-1 + 23 adn=a(jabs)-a(jnb) + if(adn) 24,9,24 + 24 px=(a(jabs)-h)/adn + 9 kx = (jabs - 1) / nrqmax + ikx = jabs - nrqmax * kx - 1 + if(jx) 25,26,26 + 25 x = drgrd * ikx + y = dzgrd * (kx - px) + go to 27 + 26 x = drgrd * (ikx - px) + y = dzgrd * kx + 27 continue + icount = icount + 1 + rcon(icount) = x + rqgrid(1) + zcon(icount) = y + zqgrid(1) + mpl= icount + itm = 1 + ja(1,1) = jabs + nrqmax + j=1 + if(jx) 10,10,11 + 10 ja(1,1) = -jabs-1 + j=2 + 11 ja(2,1)=-ja(1,1) + ja(3,1) = -jx + 1 - nrqmax + ja(3,2) = -jx + ja(j,2) = jabs - nrqmax + k= 3-j + ja(k,2) = 1-jabs + if (kx) 14,14,39 + 39 if(ikx) 14,14,36 + 36 if(ikx + 1 - nreq) 35, 37, 37 + 37 if(jx) 38,38,35 + 35 if(jfor) 28,29,28 + 28 do 13 i=1,3 + if(jfor-ja(i,2)) 13,14,13 + 13 continue + 38 lda=2 + go to 15 + 14 lda=1 + 15 ldb=lda + 29 do 18 k=1,3 + do 18 l=lda,ldb + do 16 i=1,ix + if(lx(i)-ja(k,l)) 16,17,16 + 16 continue + go to 18 + 17 itm=itm+1 + inext= i + if(jfor) 19,33,19 + 33 if(itm .gt. 3) goto 20 + 18 continue + 19 lx(in)=0 + if(itm .eq. 1) goto 6 + 20 jfor=jx + jx=lx(inext) + in = inext + go to 30 + 6 if(lx(ix)) 108,7,108 + 7 ix= ix-1 + if(ix) 51,51,6 + 51 if(mpl.lt.4) go to 50 + ncon = ncon + 1 + npts(ncon) = icount - iclast + iclast = icount + 50 continue +c + return + end +c +c +c + subroutine contours_psi(h,np,rcn,zcn,ipr) + implicit real*8 (a-h,o-z) + parameter(pi=3.14159265358979d0) + parameter(mest=4,kspl=3) + parameter(nnw=501,nnh=501) + parameter(nrest=nnw+4,nzest=nnh+4) + dimension rcn(2*np+1),zcn(2*np+1) + dimension cc(nnw*nnh),tr(nrest),tz(nzest) + dimension czc(nrest),zeroc(mest) +c + common/pareq1/psia + common/pareq1a/psiaxis0 + common/coffeqn/nsr,nsz,nsft + common/coffeq/cc + common/coffeqt/tr,tz + common/cnt/rup,zup,rlw,zlw + common/rwallm/rwallm +c + ra=rup + rb=rlw + za=zup + zb=zlw + call points_tgo(ra,za,rup,zup,h,info) + call points_tgo(rb,zb,rlw,zlw,h,info) + + th=pi/dble(np) + rcn(1)=rlw + zcn(1)=zlw + rcn(2*np+1)=rlw + zcn(2*np+1)=zlw + rcn(np+1)=rup + zcn(np+1)=zup + do ic=2,np + zc=zlw+(zup-zlw)*(1.0d0-cos(th*(ic-1)))/2.0d0 + iopt=1 + call profil(iopt,tr,nsr,tz,nsz,cc,kspl,kspl,zc,nsr,czc,ier) + if(ier.gt.0) print*,' profil =',ier + val=h+psiaxis0/psia + call sproota(val,tr,nsr,czc,zeroc,mest,m,ier) + + if (zeroc(1).gt.rwallm) then + rcn(ic)=zeroc(1) + zcn(ic)=zc + rcn(2*np+2-ic)=zeroc(2) + zcn(2*np+2-ic)=zc + else + rcn(ic)=zeroc(2) + zcn(ic)=zc + rcn(2*np+2-ic)=zeroc(3) + zcn(2*np+2-ic)=zc + end if + end do + if (ipr.gt.0) then + do ii=1,2*np+1 + write(71,111) ii,h,rcn(ii),zcn(ii) + end do + write(71,*) + write(71,*) + end if + return +111 format(i6,12(1x,e12.5)) +99 format(2i6,12(1x,e16.8e3)) + end +c +c +c + subroutine flux_average + implicit real*8 (a-h,o-z) + real*8 lam + + parameter(nnintp=101,ncnt=100,ncntt=2*ncnt+1,nlam=101) + parameter(zero=0.0d0,one=1.0d0) + parameter(pi=3.14159265358979d0,ccj=1.0d+7/(4.0d0*pi)) + parameter(ksp=3,njest=nnintp+ksp+1,nlest=nlam+ksp+1) + parameter(lwrk=4*(nnintp+nlam)+11*(njest+nlest)+ + . njest*nnintp+nlest+54) + parameter(kwrk=nnintp+nlam+njest+nlest+3) + parameter(lw01=nnintp*4+nlam*3+nnintp*nlam) + + dimension pstab(nnintp),varea(nnintp),vvol(nnintp),rpstab(nnintp) + dimension rri(nnintp),rbav(nnintp),bav(nnintp),rhotqv(nnintp) + dimension bmxpsi(nnintp),bmnpsi(nnintp),ffc(nnintp) + dimension vcurrp(nnintp),vajphiav(nnintp),qqv(nnintp) + dimension rcon(2*ncnt+1),zcon(2*ncnt+1) + dimension dlpv(2*ncnt),bv(2*ncnt+1),bpv(2*ncnt+1) + dimension cbmx(nnintp,4),cbmn(nnintp,4),crbav(nnintp,4) + dimension cvol(nnintp,4),crri(nnintp,4),carea(nnintp,4) + dimension cratj1(nnintp,4),cratj2(nnintp,4),cfc(nnintp,4) + dimension vratj1(nnintp),vratj2(nnintp),crhotq(nnintp,4) + dimension alam(nlam),fhlam(nnintp,nlam) + dimension ffhlam(nnintp*nlam),dffhlam(nnintp*nlam) + dimension tjp(njest),tlm(nlest),ch((njest-4)*(nlest-4)) + dimension iwrk(kwrk),wrk(lwrk) + dimension ch01(lw01),weights(nlam) +c + common/cent/btrcen,rcen + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + common/eqnn/nr,nz,npp,nintp + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv +c + common/pstab/rpstab + common/flav/vvol,rri,rbav,bmxpsi,bmnpsi + common/cflav/cvol,crri,crbav,cbmx,cbmn,carea,cfc + common/cratj/cratj1,cratj2 + common/crhotq/crhotq + common/cnt/rup,zup,rlw,zlw + common/bound/zbmin,zbmax + common/rarea/rarea +c + common/coffvl/ch + common/coffdvl/ch01 + common/coffvlt/tjp,tlm + common/coffvln/njpt,nlmt + +c computation of flux surface averaged quantities + + write(71,*)' #i rhop R z' + + nintp=nnintp + ninpr=(nintp-1)/10 + + dlam=1.0d0/dble(nlam-1) + do l=1,nlam-1 + alam(l)=dble(l-1)*dlam + fhlam(1,l)=sqrt(1.0d0-alam(l)) + ffhlam(l)=fhlam(1,l) + dffhlam(l)=-0.5d0/sqrt(1.0d0-alam(l)) + weights(l)=1.0d0 + end do + weights(1)=0.5d0 + weights(nlam)=0.5d0 + alam(nlam)=1.0d0 + fhlam(1,nlam)=0.0d0 + ffhlam(nlam)=0.0d0 + dffhlam(nlam)=-99999.0d0 + + jp=1 + anorm=2.0d0*pi*rmaxis/abs(btaxis) + b2av=btaxis**2 + dvdpsi=2.0d0*pi*anorm + dadpsi=2.0d0*pi/abs(btaxis) + ratio_cdator=abs(btaxis/btrcen) + ratio_pltor=1.0d0 + qq=1.0d0 + fc=1.0d0 + + pstab(1)=0.0d0 + rpstab(1)=0.0d0 + rhotqv(1)=0.0d0 + vcurrp(1)=0.0d0 + vajphiav(1)=0.0d0 + bmxpsi(1)=abs(btaxis) + bmnpsi(1)=abs(btaxis) + bav(1)=abs(btaxis) + rbav(1)=1.0d0 + rri(1)=rmaxis + varea(1)=0.0d0 + vvol(1)=0.0d0 + vratj1(1)=ratio_pltor + vratj2(1)=ratio_cdator + ffc(1)=fc + rhot2q=0.0d0 + + rup=rmaxis + rlw=rmaxis + zup=(zbmax+zmaxis)/2.0d0 + zlw=(zmaxis+zbmin)/2.0d0 + + do jp=2,nintp + height=dble(jp-1)/dble(nintp-1) + if(jp.eq.nintp) height=0.9999d0 + ipr=0 + jpr=mod(jp,ninpr) + if(jpr.eq.1) ipr=1 + height2=height*height + call contours_psi(height2,ncnt,rcon,zcon,ipr) +c + r2iav=0.0d0 + anorm=0.0d0 + dadpsi=0.0d0 + currp=0.0d0 + b2av=0.0d0 + area=0.0d0 + volume=0.0d0 + ajphiav=0.0d0 + bbav=0.0d0 + bmmx=-1.0d+30 + bmmn=1.0d+30 + + call bfield(rcon(1),zcon(1),bphi,brr,bzz) + call tor_curr(rcon(1),zcon(1),ajphi0) + btot0=sqrt(bphi**2+brr**2+bzz**2) + bpoloid0=sqrt(brr**2+bzz**2) + bv(1)=btot0 + bpv(1)=bpoloid0 + rpsim0=rcon(1) + + do inc=1,ncntt-1 + inc1=inc+1 + dla=sqrt((rcon(inc)-rmaxis)**2+(zcon(inc)-zmaxis)**2) + dlb=sqrt((rcon(inc1)-rmaxis)**2+(zcon(inc1)-zmaxis)**2) + dlp=sqrt((rcon(inc1)-rcon(inc))**2+ + . (zcon(inc1)-zcon(inc))**2) + drc=(rcon(inc1)-rcon(inc)) +c +c compute length, area and volume defined by psi=height^2 +c + ph=0.5d0*(dla+dlb+dlp) + area2=ph*(ph-dla)*(ph-dlb)*(ph-dlp) + area=area+sqrt(area2) + rzp=rcon(inc1)*zcon(inc1) + rz=rcon(inc)*zcon(inc) + volume=pi*(rzp+rz)*drc+volume +c +c compute line integral on the contour psi=height^2 +c + rpsim=rcon(inc1) + zpsim=zcon(inc1) + call bfield(rpsim,zpsim,bphi,brr,bzz) + call tor_curr(rpsim,zpsim,ajphi) +c + btot=sqrt(bphi**2+brr**2+bzz**2) + bpoloid=sqrt(brr**2+bzz**2) + dlpv(inc)=dlp + bv(inc1)=btot + bpv(inc1)=bpoloid + + dlph=0.5d0*dlp + anorm=anorm+dlph*(1.0d0/bpoloid+1.0d0/bpoloid0) + dadpsi=dadpsi+dlph* + . (1.0d0/(bpoloid*rpsim)+1.0d0/(bpoloid0*rpsim0)) + currp=currp+dlph*(bpoloid+bpoloid0) + b2av=b2av+dlph*(btot0**2/bpoloid0+btot**2/bpoloid) + bbav=bbav+dlph*(btot/bpoloid+btot0/bpoloid0) + r2iav=r2iav+dlph* + . (1.0d0/(bpoloid*rpsim**2)+1.0d0/(bpoloid0*rpsim0**2)) + ajphiav=ajphiav+dlph* + . (ajphi0/(bpoloid0*rpsim0)+ajphi/(bpoloid*rpsim)) + + ajphi0=ajphi + rpsim0=rpsim + bpoloid0=bpoloid + btot0=btot +c +c computation maximum/minimum B values on given flux surface +c + if(btot.le.bmmn) bmmn=btot + if(btot.ge.bmmx) bmmx=btot + end do +c +c bav= [T] , b2av= [T^2] , rbav=/b_min +c anorm = int d l_p/B_p = dV/dpsi/(2pi) +c r2iav=<1/R^2> [m^-2] , +c riav=<1/R> [m^-1] = dA/dpsi/(dV/dpsi/(2pi)), +c rri = /(|R B_tor|<1/R^2>) , used to compute I_tor [m^-1] +c currp = plasma current within psi=const +c + bbav=bbav/anorm + r2iav=r2iav/anorm + dvdpsi=2.0d0*pi*anorm + riav=dadpsi/anorm + b2av=b2av/anorm + vcurrp(jp)=ccj*currp + vajphiav(jp)=ajphiav/dadpsi +c +c area == varea, volume == vvol +c flux surface minor radius == (area/pi)^1/2 +c + pstab(jp)=height2 + rpstab(jp)=height + vvol(jp)=abs(volume) + varea(jp)=area + bav(jp)=bbav + rbav(jp)=bbav/bmmn + bmxpsi(jp)=bmmx + bmnpsi(jp)=bmmn + rri(jp)=bav(jp)/abs(fpolv*r2iav) + ratio_cdator=abs(b2av*riav/(fpolv*r2iav*btrcen)) + ratio_pltor=abs(bbav*riav/(fpolv*r2iav)) + vratj1(jp)=ratio_pltor + vratj2(jp)=ratio_cdator + qq=abs(dvdpsi*fpolv*r2iav/(4*pi*pi)) + qqv(jp)=qq +c +c computation of rhot from calculated q profile +c + rhot2q=rhot2q+(qqv(jp)*rpstab(jp)+qqv(jp-1)*rpstab(jp-1)) + . /dble(nintp-1) + rhotqv(jp)=sqrt(rhot2q) + +c computation of fraction of circulating/trapped fraction fc, ft +c and of function H(lambda,rhop) +c ffhlam = Bmn/Bmx/fc integral_lambda^1 dlam/ +c + fc=0.0d0 + shlam=0.0d0 + do l=nlam,1,-1 + lam=alam(l) + srl=0.0d0 + rl2=1.0d0-lam*bv(1)/bmmx + if(rl2.gt.0) rl0=sqrt(rl2) + do inc=1,ncntt-1 + rl2=1.0d0-lam*bv(inc+1)/bmmx + if(rl2.gt.0) rl=sqrt(rl2) + srl=srl+0.5d0*dlpv(inc)*(rl/bpv(inc+1)+rl0/bpv(inc)) + rl0=rl + end do + srl=srl/anorm + dhlam=0.5d0/srl + fc=fc+lam/srl*weights(l) + if(l.eq.nlam) then + fhlam(jp,l)=0.0d0 + ffhlam(nlam*(jp-1)+l)=0.0d0 + dffhlam(nlam*(jp-1)+l)=-dhlam + dhlam0=dhlam + else + shlam=shlam+0.5d0*(dhlam+dhlam0)*dlam + fhlam(jp,l)=shlam + dffhlam(nlam*(jp-1)+l)=-dhlam + dhlam0=dhlam + end if + end do + fc=0.75d0*b2av/bmmx**2*fc*dlam + ffc(jp)=fc + + ccfh=bmmn/bmmx/fc +c cca= (b2av/bmmx**2)/(bmmn/bmmx) + do l=1,nlam + ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l) + dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l) +c write(68,99) rhop,alam(l),cca*ffhlam(nlam*(jp-1)+l), +c . cca*dffhlam(nlam*(jp-1)+l) + end do +c write(68,*) ' ' + end do + + write(56,*)'#psi rhop rhot || |Bmx| |Bmn| Area Vol R_i'// + .' |I_pl| qq fc' + + qqv(1)=qqv(2) + vajphiav(1)=vajphiav(2) + do jp=1,nintp + rhotqv(jp)=rhotqv(jp)/rhotqv(nintp) + if(jp.eq.nintp) then + rhotqv(jp)=1.0d0 + rpstab(jp)=1.0d0 + pstab(jp)=1.0d0 + end if + write(56,99) pstab(jp),rpstab(jp),rhotqv(jp) + . ,bav(jp),bmxpsi(jp),bmnpsi(jp),varea(jp),vvol(jp) + . ,rri(jp),vcurrp(jp),vajphiav(jp),qqv(jp),ffc(jp) + end do +c + rarea=sqrt(varea(nintp)/pi) +c +c spline coefficients of vvol,rbav,rri,bmxpsi,bmnpsi +c used for computations of dP/dV and J_cd +c spline coefficients of rhot +c + iopt=0 + call difcs(rpstab,vvol,nintp,iopt,cvol,ier) + iopt=0 + call difcs(rpstab,rbav,nintp,iopt,crbav,ier) + iopt=0 + call difcs(rpstab,rri,nintp,iopt,crri,ier) + iopt=0 + call difcs(rpstab,bmxpsi,nintp,iopt,cbmx,ier) + iopt=0 + call difcs(rpstab,bmnpsi,nintp,iopt,cbmn,ier) + iopt=0 + call difcs(rpstab,vratj1,nintp,iopt,cratj1,ier) + iopt=0 + call difcs(rpstab,vratj2,nintp,iopt,cratj2,ier) + iopt=0 + call difcs(rpstab,varea,nintp,iopt,carea,ier) + iopt=0 + call difcs(rpstab,ffc,nintp,iopt,cfc,ier) + iopt=0 + call difcs(rpstab,rhotqv,nintp,iopt,crhotq,ier) + +c spline interpolation of H(lambda,rhop) and dH/dlambda + + iopt=0 + s=0.0d0 + call regrid(iopt,nintp,rpstab,nlam,alam,ffhlam, + . zero,one,zero,one,ksp,ksp,s, + . njest,nlest,njp,tjp,nlm,tlm,ch,fp,wrk,lwrk,iwrk,kwrk,ier) + njpt=njp + nlmt=nlm + + call coeff_parder(tjp,njp,tlm,nlm,ch,ksp,ksp,0,1, + . ch01,lw01,ier) + + + return + 99 format(20(1x,e12.5)) + end +c +c +c + subroutine vectinit + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36,nmx=8000) + dimension psjki(jmx,kmx,nmx) + dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx) + dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx) + dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension iiv(jmx,kmx),iov(jmx,kmx),tau1v(jmx,kmx) + parameter(tmax=5,npts=500) + real*8 ttv(npts+1),extv(npts+1) + common/ttex/ttv,extv +c + common/warm/iwarm,ilarm + common/iiv/iiv + common/iov/iov + common/psjki/psjki + common/atjki/tauv,alphav + common/dpjjki/pdjki,currj + common/pcjki/ppabs,ccci + common/dcjki/didst + common/nrayktx/nray,ktx + common/nstep/nstep + common/tau1v/tau1v +c + if(nstep.gt.nmx) nstep=nmx + if(nray.gt.jmx) nray=jmx + if(ktx.gt.kmx) ktx=kmx + +c + do i=1,nstep + do k=1,ktx + do j=1,nray + psjki(j,k,i)=0.0d0 + tauv(j,k,i)=0.0d0 + alphav(j,k,i)=0.0d0 + pdjki(j,k,i)=0.0d0 + ppabs(j,k,i)=0.0d0 + didst(j,k,i)=0.0d0 + ccci(j,k,i)=0.0d0 + currj(j,k,i)=0.0d0 + iiv(j,k)=1 + iov(j,k)=0 + tau1v(j,k)=0.0d0 + end do + end do + end do +c + if(iwarm.gt.1) then + dt=2.0d0*tmax/dble(npts) + do i = 1, npts+1 + ttv(i) = -tmax+dble(i-1)*dt + extv(i)=exp(-ttv(i)*ttv(i)) + end do + end if +c + return + end + + + + subroutine vectinit2 + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36,nmx=8000) + dimension psjki(jmx,kmx,nmx) + dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx) + dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx) + dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension iiv(jmx,kmx),iov(jmx,kmx),tau1v(jmx,kmx) + + common/iiv/iiv + common/iov/iov + common/psjki/psjki + common/atjki/tauv,alphav + common/dpjjki/pdjki,currj + common/pcjki/ppabs,ccci + common/dcjki/didst + common/nrayktx/nray,ktx + common/nstep/nstep + + do i=1,nstep + do k=1,ktx + do j=1,nray + psjki(j,k,i)=0.0d0 + tauv(j,k,i)=0.0d0 + alphav(j,k,i)=0.0d0 + pdjki(j,k,i)=0.0d0 + ppabs(j,k,i)=0.0d0 + didst(j,k,i)=0.0d0 + ccci(j,k,i)=0.0d0 + currj(j,k,i)=0.0d0 + iiv(j,k)=1 + iov(j,k)=0 + end do + end do + end do + + return + end +c +c +c + subroutine paraminit + implicit real*8(a-h,o-z) +c + common/istep/istep + common/istgr/istpr,istpl + common/ierr/ierr + common/istop/istop + common/ipol/ipolc +c + istpr=0 + istpl=1 + ierr=0 + istep=0 + istop=0 + ipolc=0 +c + return + end +c +c + subroutine updatepos + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36) + dimension xc(3,jmx,kmx),xco(3,jmx,kmx) + dimension du1(3,jmx,kmx),du1o(3,jmx,kmx) + dimension ywrk(6,jmx,kmx),ypwrk(6,jmx,kmx) +c + common/nrayktx/nray,ktx + common/grco/xco,du1o + common/grc/xc,du1 + common/wrk/ywrk,ypwrk +c + do j=1,nray + do k=1,ktx + if(j.eq.1.and.k.gt.1) then + xco(1,j,k)=xco(1,j,1) + xco(2,j,k)=xco(2,j,1) + xco(3,j,k)=xco(3,j,1) + xc(1,j,k)=xc(1,j,1) + xc(2,j,k)=xc(2,j,1) + xc(3,j,k)=xc(3,j,1) + else + xco(1,j,k)=xc(1,j,k) + xco(2,j,k)=xc(2,j,k) + xco(3,j,k)=xc(3,j,k) + xc(1,j,k)=ywrk(1,j,k) + xc(2,j,k)=ywrk(2,j,k) + xc(3,j,k)=ywrk(3,j,k) + end if + du1o(1,j,k)=du1(1,j,k) + du1o(2,j,k)=du1(2,j,k) + du1o(3,j,k)=du1(3,j,k) + end do + end do +c + return + end +c +c +c + subroutine gradi + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36) + dimension dffiu(jmx),ddffiu(jmx) + dimension xc(3,jmx,kmx),xco(3,jmx,kmx) + dimension du1(3,jmx,kmx),du1o(3,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) + dimension dgrad2v(3,jmx,kmx) + dimension grad2(jmx,kmx) + dimension dxv1(3),dxv2(3),dxv3(3),dgu(3) + dimension dgg1(3),dgg2(3),dgg3(3) + dimension df1(3),df2(3),df3(3) +c + common/nrayktx/nray,ktx + common/fi/dffiu,ddffiu + common/grco/xco,du1o + common/grc/xc,du1 + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri +c +c compute grad u and grad(S_I) +c + do k=1,ktx + do j=1,nray + if(j.eq.1) then + gri(1,j,k)=0.0d0 + gri(2,j,k)=0.0d0 + gri(3,j,k)=0.0d0 + jp=j+1 + km=k-1 + if(k.eq.1) km=ktx + kp=k+1 + if(k.eq.ktx) kp=1 + do iv=1,3 + dxv1(iv)=xc(iv,jp,k)-xc(iv,j,k) + dxv2(iv)=xc(iv,jp,kp)-xc(iv,jp,km) + dxv3(iv)=xc(iv,j,k)-xco(iv,j,k) + end do + call solg0(dxv1,dxv2,dxv3,dgu) + else + jm=j-1 + km=k-1 + if(k.eq.1) km=ktx + kp=k+1 + if(k.eq.ktx) kp=1 + do iv=1,3 + dxv1(iv)=xc(iv,j,k)-xc(iv,jm,k) + dxv2(iv)=xc(iv,j,kp)-xc(iv,j,km) + dxv3(iv)=xc(iv,j,k)-xco(iv,j,k) + end do + call solg0(dxv1,dxv2,dxv3,dgu) + end if + du1(1,j,k)=dgu(1) + du1(2,j,k)=dgu(2) + du1(3,j,k)=dgu(3) + gri(1,j,k)=dgu(1)*dffiu(j) + gri(2,j,k)=dgu(2)*dffiu(j) + gri(3,j,k)=dgu(3)*dffiu(j) + grad2(j,k)=gri(1,j,k)**2+gri(2,j,k)**2+gri(3,j,k)**2 + end do + end do +c +c compute derivatives of grad u and grad(S_I) +c + do k=1,ktx + do j=1,nray + if(j.eq.1) then + jp=j+1 + km=k-1 + if(k.eq.1) km=ktx + kp=k+1 + if(k.eq.ktx) kp=1 + do iv=1,3 + dxv1(iv)=xc(iv,jp,kp)-xc(iv,jp,km) + dxv2(iv)=xc(iv,jp,k)-xc(iv,j,k) + dxv3(iv)=xc(iv,j,k)-xco(iv,j,k) + end do + df1(1)=du1(1,jp,kp)-du1(1,jp,km) + df1(2)=du1(1,jp,k)-du1(1,j,k) + df1(3)=du1(1,j,k)-du1o(1,j,k) + df2(1)=du1(2,jp,kp)-du1(2,jp,km) + df2(2)=du1(2,jp,k)-du1(2,j,k) + df2(3)=du1(2,j,k)-du1o(2,j,k) + df3(1)=du1(3,jp,kp)-du1(3,jp,km) + df3(2)=du1(3,jp,k)-du1(3,j,k) + df3(3)=du1(3,j,k)-du1o(3,j,k) + call solg3(dxv1,dxv2,dxv3,df1,df2,df3,dgg1,dgg2,dgg3) + else + jm=j-1 + km=k-1 + if(k.eq.1) km=ktx + kp=k+1 + if(k.eq.ktx) kp=1 + do iv=1,3 + dxv1(iv)=xc(iv,j,k)-xc(iv,jm,k) + dxv2(iv)=xc(iv,j,kp)-xc(iv,j,km) + dxv3(iv)=xc(iv,j,k)-xco(iv,j,k) + end do + df1(1)=du1(1,j,k)-du1(1,jm,k) + df1(2)=du1(1,j,kp)-du1(1,j,km) + df1(3)=du1(1,j,k)-du1o(1,j,k) + df2(1)=du1(2,j,k)-du1(2,jm,k) + df2(2)=du1(2,j,kp)-du1(2,j,km) + df2(3)=du1(2,j,k)-du1o(2,j,k) + df3(1)=du1(3,j,k)-du1(3,jm,k) + df3(2)=du1(3,j,kp)-du1(3,j,km) + df3(3)=du1(3,j,k)-du1o(3,j,k) + call solg3(dxv1,dxv2,dxv3,df1,df2,df3,dgg1,dgg2,dgg3) + end if +c +c derivatives of u +c + ux=du1(1,j,k) + uy=du1(2,j,k) + uz=du1(3,j,k) + uxx=dgg1(1) + uyy=dgg2(2) + uzz=dgg3(3) + uxy=(dgg1(2)+dgg2(1))/2.0d0 + uxz=(dgg1(3)+dgg3(1))/2.0d0 + uyz=(dgg2(3)+dgg3(2))/2.0d0 +c +c derivatives of S_I and Grad(S_I) +c + dfu=dffiu(j) + dfuu=ddffiu(j) + gx=ux*dfu + gy=uy*dfu + gz=uz*dfu + gxx=dfuu*ux*ux+dfu*uxx + gyy=dfuu*uy*uy+dfu*uyy + gzz=dfuu*uz*uz+dfu*uzz + gxy=dfuu*ux*uy+dfu*uxy + gxz=dfuu*ux*uz+dfu*uxz + gyz=dfuu*uy*uz+dfu*uyz +c + ggri(1,1,j,k)=gxx + ggri(2,2,j,k)=gyy + ggri(3,3,j,k)=gzz + ggri(1,2,j,k)=gxy + ggri(2,1,j,k)=gxy + ggri(1,3,j,k)=gxz + ggri(3,1,j,k)=gxz + ggri(2,3,j,k)=gyz + ggri(3,2,j,k)=gyz +c +c derivatives of |Grad(S_I)|^2 +c + dgrad2v(1,j,k)=2.0d0*(gx*gxx+gy*gxy+gz*gxz) + dgrad2v(2,j,k)=2.0d0*(gx*gxy+gy*gyy+gz*gyz) + dgrad2v(3,j,k)=2.0d0*(gx*gxz+gy*gyz+gz*gzz) + end do + end do +c + return + end +c +c solution of the linear system of 3 eqs : dgg . dxv = dff +c input vectors : dxv1, dxv2, dxv3, dff +c output vector : dgg +c +c dff=(1,0,0) +c + subroutine solg0(dxv1,dxv2,dxv3,dgg) + double precision denom,aa1,aa2,aa3 + double precision dxv1(3),dxv2(3),dxv3(3),dgg(3) + aa1=(dxv2(2)*dxv3(3)-dxv3(2)*dxv2(3)) + aa2=(dxv1(2)*dxv3(3)-dxv1(3)*dxv3(2)) + aa3=(dxv1(2)*dxv2(3)-dxv1(3)*dxv2(2)) + denom = dxv1(1)*aa1-dxv2(1)*aa2+dxv3(1)*aa3 + dgg(1) = aa1/denom + dgg(2) = -(dxv2(1)*dxv3(3)-dxv3(1)*dxv2(3))/denom + dgg(3) = (dxv2(1)*dxv3(2)-dxv3(1)*dxv2(2))/denom + return + end +c +c three rhs vectors df1, df2, df3 +c + subroutine solg3(dxv1,dxv2,dxv3,df1,df2,df3,dg1,dg2,dg3) + double precision denom,a11,a21,a31,a12,a22,a32,a13,a23,a33 + double precision dxv1(3),dxv2(3),dxv3(3) + double precision df1(3),df2(3),df3(3) + double precision dg1(3),dg2(3),dg3(3) + a11=(dxv2(2)*dxv3(3)-dxv3(2)*dxv2(3)) + a21=(dxv1(2)*dxv3(3)-dxv1(3)*dxv3(2)) + a31=(dxv1(2)*dxv2(3)-dxv1(3)*dxv2(2)) + a12=(dxv2(1)*dxv3(3)-dxv3(1)*dxv2(3)) + a22=(dxv1(1)*dxv3(3)-dxv1(3)*dxv3(1)) + a32=(dxv1(1)*dxv2(3)-dxv1(3)*dxv2(1)) + a13=(dxv2(1)*dxv3(2)-dxv3(1)*dxv2(2)) + a23=(dxv1(1)*dxv3(2)-dxv1(2)*dxv3(1)) + a33=(dxv1(1)*dxv2(2)-dxv1(2)*dxv2(1)) + denom = dxv1(1)*a11-dxv2(1)*a21+dxv3(1)*a31 + dg1(1) = (df1(1)*a11-df1(2)*a21+df1(3)*a31)/denom + dg1(2) = -(df1(1)*a12-df1(2)*a22+df1(3)*a32)/denom + dg1(3) = (df1(1)*a13-df1(2)*a23+df1(3)*a33)/denom + dg2(1) = (df2(1)*a11-df2(2)*a21+df2(3)*a31)/denom + dg2(2) = -(df2(1)*a12-df2(2)*a22+df2(3)*a32)/denom + dg2(3) = (df2(1)*a13-df2(2)*a23+df2(3)*a33)/denom + dg3(1) = (df3(1)*a11-df3(2)*a21+df3(3)*a31)/denom + dg3(2) = -(df3(1)*a12-df3(2)*a22+df3(3)*a32)/denom + dg3(3) = (df3(1)*a13-df3(2)*a23+df3(3)*a33)/denom + return + end +c +c Runge-Kutta integrator +c + subroutine rkint4 + implicit real*8 (a-h,o-z) + parameter(ndim=6,jmx=31,kmx=36) + dimension y(ndim),yy(ndim) + dimension fk1(ndim),fk2(ndim),fk3(ndim),fk4(ndim) + dimension dgr2(3),dgr(3),ddgr(3,3) + dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx) + dimension grad2(jmx,kmx),dgrad2v(3,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) +c + common/nrayktx/nray,ktx + common/dsds/dst +c + common/wrk/ywrk,ypwrk + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri + common/gr/gr2 + common/dgr/dgr2,dgr,ddgr + common/igrad/igrad +c + h=dst + hh=h*0.5d0 + h6=h/6.0d0 +c + do j=1,nray + kktx=ktx + if(j.eq.1) kktx=1 + do k=1,kktx + do ieq=1,ndim + y(ieq)=ywrk(ieq,j,k) + fk1(ieq)=ypwrk(ieq,j,k) + yy(ieq)=y(ieq)+fk1(ieq)*hh + end do + gr2=grad2(j,k) + do iv=1,3 + dgr2(iv)=dgrad2v(iv,j,k) + dgr(iv)=gri(iv,j,k) + do jv=1,3 + ddgr(iv,jv)=ggri(iv,jv,j,k) + end do + end do + call fwork(yy,fk2) +c + do ieq=1,ndim + yy(ieq)=y(ieq)+fk2(ieq)*hh + end do + call fwork(yy,fk3) +c + do ieq=1,ndim + yy(ieq)=y(ieq)+fk3(ieq)*h + end do + call fwork(yy,fk4) +c + do ieq=1,ndim + ywrk(ieq,j,k)=y(ieq) + . +h6*(fk1(ieq)+2.0d0*fk2(ieq)+2.0d0*fk3(ieq)+fk4(ieq)) + end do + end do + end do +c + call updatepos +c + if(igrad.eq.1) call gradi +c + return + end +c +c +c + subroutine gwork(j,k) + implicit real*8 (a-h,o-z) + parameter(ndim=6,jmx=31,kmx=36) + dimension yy(ndim),yyp(ndim) + dimension dgr2(3),dgr(3),ddgr(3,3) + dimension ywrk(ndim,jmx,kmx),ypwrk(ndim,jmx,kmx) + dimension grad2(jmx,kmx),dgrad2v(3,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) +c + common/igrad/igrad +c + common/wrk/ywrk,ypwrk + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri + common/gr/gr2 + common/dgr/dgr2,dgr,ddgr +c +c begin --- update vector yy +c + do ieq=1,ndim + yy(ieq)=ywrk(ieq,j,k) + end do +c + if(igrad.eq.1) then + gr2=grad2(j,k) + do iv=1,3 + dgr2(iv)=dgrad2v(iv,j,k) + dgr(iv)=gri(iv,j,k) + do jv=1,3 + ddgr(iv,jv)=ggri(iv,jv,j,k) + end do + end do + end if +c + call fwork(yy,yyp) +c + do ieq=1,ndim + ypwrk(ieq,j,k)=yyp(ieq) + end do +c +c end --- update vector yy +c + return + end +c +c +c + subroutine fwork(y,dery) + implicit real*8 (a-h,o-z) + parameter(ndim=6) + dimension y(ndim),dery(ndim) + dimension xv(3),anv(3),vgv(3),bv(3),derbv(3,3),derxg(3),deryg(3) + dimension derdxv(3),danpldxv(3),derdnv(3) + dimension dgr2(3),dgr(3),ddgr(3,3),dbgr(3) +c + common/gr/gr2 + common/dgr/dgr2,dgr,ddgr + common/ddd/dd,an2s,an2,fdia,bdotgr,ddi + common/mode/sox + common/nplr/anpl,anpr + common/bb/bv + common/dbb/derbv + common/igrad/igrad + common/xgxg/xg + common/ygyg/yg + common/dxgyg/derxg,deryg + common/vgv/vgm,derdnm + common/dersdst/dersdst + common/ierr/ierr + common/anv/anv + common/xv/xv + common/idst/idst +c + xx=y(1) + yy=y(2) + zz=y(3) + + xv(1)=y(1) + xv(2)=y(2) + xv(3)=y(3) +c + anv(1) = y(4) + anv(2) = y(5) + anv(3) = y(6) +c +C rr=sqrt(xx**2+yy**2) +C phi=acos(xx/rr) +C if (yy.lt.0.0d0) then +C phi=-phi +C end if +c + call plas_deriv(xx,yy,zz) +c + an2=anv(1)*anv(1)+anv(2)*anv(2)+anv(3)*anv(3) + anpl=anv(1)*bv(1)+anv(2)*bv(2)+anv(3)*bv(3) +c + if(abs(anpl).gt.0.99d0) then +c print*,' |Nparallel| > 1 !', sqrt(an2),anpl + if(abs(anpl).le.1.05d0) then + ierr=97 + else + ierr=98 + end if + end if +c + anpl2=anpl*anpl + dnl=1.0d0-anpl2 + anpr2=an2-anpl2 + anpr=0.0d0 + if(anpr2.gt.0.0d0) anpr=sqrt(anpr2) + yg2=yg**2 +c + an2s=1.0d0 + dan2sdxg=0.0d0 + dan2sdyg=0.0d0 + dan2sdnpl=0.0d0 + del=0.0d0 + fdia=0.0d0 + dfdiadnpl=0.0d0 + dfdiadxg=0.0d0 + dfdiadyg=0.0d0 +c + duh=1.0d0-xg-yg2 + if(xg.gt.0.0d0) then + del=sqrt(dnl*dnl+4.0d0*anpl*anpl*(1.0d0-xg)/yg2) + an2s=1.0d0-xg -xg*yg2*(1.0d0+anpl2+sox*del)/duh/2.0d0 +c + dan2sdxg=-yg2*(1.0d0-yg2)*(1.0d0+anpl2+sox*del)/duh**2/2.0d0 + . +sox*xg*anpl2/(del*duh)-1.0d0 + dan2sdyg=-xg*yg*(1.0d0-xg)*(1.0d0+anpl2+sox*del)/duh**2 + . +2.0d0*sox*xg*(1.0d0-xg)*anpl2/(yg*del*duh) + dan2sdnpl=-xg*yg2*anpl/duh + . -sox*xg*anpl*(2.0d0*(1.0d0-xg)-yg2*dnl)/(del*duh) +c + if(igrad.gt.0) then + ddelnpl2=2.0d0*(2.0d0*(1.0d0-xg)*(1.0d0+3.0d0*anpl2**2) + . -yg2*dnl**3)/yg2/del**3 + fdia=-xg*yg2*(1.0d0+sox*ddelnpl2/2.0d0)/duh + derdel=2.0d0*(1.0d0-xg)*anpl2*(1.0d0+3.0d0*anpl2**2) + . -dnl**2*(1.0d0+3.0d0*anpl2)*yg2 + derdel=4.0d0*derdel/(yg**5*del**5) + ddelnpl2y=2.0d0*(1.0d0-xg)*derdel + ddelnpl2x=yg*derdel + dfdiadnpl=24.0d0*sox*xg*(1.0d0-xg)*anpl*(1.0d0-anpl**4) + . /(yg2*del**5) + dfdiadxg=-yg2*(1.0d0-yg2)/duh**2-sox*yg2*((1.0d0-yg2)*ddelnpl2 + . +xg*duh*ddelnpl2x)/(2.0d0*duh**2) + dfdiadyg=-2.0d0*yg*xg*(1.0d0-xg)/duh**2 + . -sox*xg*yg*(2.0d0*(1.0d0-xg)*ddelnpl2 + . +yg*duh*ddelnpl2y)/(2.0d0*duh**2) +c + end if + end if +c + bdotgr=0.0d0 + do iv=1,3 + bdotgr=bdotgr+bv(iv)*dgr(iv) + dbgr(iv)=0.0d0 + do jv=1,3 + dbgr(iv)=dgr(jv)*derbv(jv,iv)+bv(jv)*ddgr(jv,iv) + end do + end do +c + derdnm=0.0d0 +c + do iv=1,3 + danpldxv(iv)=anv(1)*derbv(1,iv)+anv(2)*derbv(2,iv) + . +anv(3)*derbv(3,iv) + derdxv(iv)=-(derxg(iv)*dan2sdxg + . +deryg(iv)*dan2sdyg+danpldxv(iv)*dan2sdnpl) + derdxv(iv)=derdxv(iv)-igrad*dgr2(iv) +c + derdxv(iv)=derdxv(iv)+fdia*bdotgr*dbgr(iv)+0.5d0*bdotgr**2* + . (derxg(iv)*dfdiadxg+deryg(iv)*dfdiadyg+danpldxv(iv)*dfdiadnpl) +c + derdnv(iv)=2.0d0*anv(iv)-bv(iv)*dan2sdnpl + . +0.5d0*bdotgr**2*bv(iv)*dfdiadnpl +c + derdnm=derdnm+derdnv(iv)**2 + end do +c + derdnm=sqrt(derdnm) +c + derdom=-2.0d0*an2+2.0d0*xg*dan2sdxg+yg*dan2sdyg+anpl*dan2sdnpl + . +2.0d0*igrad*gr2 + . -bdotgr**2*(fdia+xg*dfdiadxg+yg*dfdiadyg/2.0d0 + . +anpl*dfdiadnpl/2.0d0) +c + if (idst.eq.0) then +c integration variable: s + denom=-derdnm + else if (idst.eq.1) then +c integration variable: c*t + denom=derdom + else +c integration variable: Sr + denom=-(anv(1)*derdnv(1)+anv(2)*derdnv(2)+anv(3)*derdnv(3)) + end if +c +c coefficient for integration in s +c ds/dst, where st is the integration variable + dersdst=-derdnm/denom +c + dery(1) = -derdnv(1)/denom + dery(2) = -derdnv(2)/denom + dery(3) = -derdnv(3)/denom + dery(4) = derdxv(1)/denom + dery(5) = derdxv(2)/denom + dery(6) = derdxv(3)/denom +c +c vgv : ~ group velocity +c + vgm=0 + do iv=1,3 + vgv(iv)=-derdnv(iv)/derdom + vgm=vgm+vgv(iv)**2 + end do + vgm=sqrt(vgm) +c +c dd : dispersion relation (real part) +c ddi : dispersion relation (imaginary part) +c + dd=an2-an2s-igrad*(gr2-0.5d0*bdotgr**2*fdia) + ddi=derdnv(1)*dgr(1)+derdnv(2)*dgr(2)+derdnv(3)*dgr(3) +c + return + end +c +c +c + subroutine plas_deriv(xx,yy,zz) + implicit real*8 (a-h,o-z) + parameter(pi=3.14159265358979d0) + dimension bv(3),derxg(3),deryg(3),derbv(3,3),dbtot(3) + dimension bvc(3),dbvcdc(3,3),dbvdc(3,3),dbv(3,3) +c + common/parbres/bres + common/parpl/brr,bphi,bzz,ajphi + common/btot/btot + common/bb/bv + common/dbb/derbv + common/xgxg/xg + common/dxgdps/dxgdpsi + common/ygyg/yg + common/dxgyg/derxg,deryg + common/iieq/iequil + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + common/psival/psinv + common/sgnib/sgnbphi,sgniphi +c + xg=0.0d0 + yg=9.9d1 +c + do iv=1,3 + derxg(iv)=0.0d0 + deryg(iv)=0.0d0 + bv(iv)=0.0d0 + dbtot(iv)=0.0d0 + do jv=1,3 + dbv(iv,jv)=0.0d0 + derbv(iv,jv)=0.0d0 + dbvcdc(iv,jv)=0.0d0 + dbvcdc(iv,jv)=0.0d0 + dbvdc(iv,jv)=0.0d0 + end do + end do +c + if(iequil.eq.0) return +c +c cylindrical coordinates +c + rr2=xx**2+yy**2 + rr=sqrt(rr2) + csphi=xx/rr + snphi=yy/rr +c + bv(1)=-snphi*sgnbphi + bv(2)=csphi*sgnbphi +c +c convert from cm to meters +c + zzm=1.0d-2*zz + rrm=1.0d-2*rr +c + if(iequil.eq.1) then + call equian(rrm,zzm) + yg=fpolv/(rrm*bres) + end if +c + if(iequil.eq.2) then + call equinum(rrm,zzm) + call sub_xg_derxg + yg=fpolv/(rrm*bres) + bphi=fpolv/rrm + btot=abs(bphi) + if(psinv.lt.0.0d0) return + end if +c +c B = f(psi)/R e_phi+ grad psi x e_phi/R +c +c bvc(i) = B_i in cylindrical coordinates +c bv(i) = B_i in cartesian coordinates +c + bphi=fpolv/rrm + brr=-dpsidz/rrm + bzz= dpsidr/rrm +c + dfpolv=ffpv/fpolv +c + bvc(1)=brr + bvc(2)=bphi + bvc(3)=bzz +c + bv(1)=bvc(1)*csphi-bvc(2)*snphi + bv(2)=bvc(1)*snphi+bvc(2)*csphi + bv(3)=bvc(3) +c + b2tot=bv(1)**2+bv(2)**2+bv(3)**2 + btot=sqrt(b2tot) +c +c dbvcdc(iv,jv) = d Bcil(iv) / dxvcil(jv) +c + dbvcdc(1,1)=-ddpsidrz/rrm-brr/rrm + dbvcdc(1,3)=-ddpsidzz/rrm + dbvcdc(2,1)= dfpolv*dpsidr/rrm-bphi/rrm + dbvcdc(2,3)= dfpolv*dpsidz/rrm + dbvcdc(3,1)= ddpsidrr/rrm-bzz/rrm + dbvcdc(3,3)= ddpsidrz/rrm +c +c dbvdc(iv,jv) = d Bcart(iv) / dxvcil(jv) +c + dbvdc(1,1) = dbvcdc(1,1)*csphi-dbvcdc(2,1)*snphi + dbvdc(1,2) = -bv(2) + dbvdc(1,3) = dbvcdc(1,3)*csphi-dbvcdc(2,3)*snphi + dbvdc(2,1) = dbvcdc(1,1)*snphi+dbvcdc(2,1)*csphi + dbvdc(2,2) = bv(1) + dbvdc(2,3) = dbvcdc(1,3)*snphi+dbvcdc(2,3)*csphi + dbvdc(3,1) = dbvcdc(3,1) + dbvdc(3,2) = dbvcdc(3,2) + dbvdc(3,3) = dbvcdc(3,3) +c + drrdx=csphi + drrdy=snphi + dphidx=-snphi/rrm + dphidy=csphi/rrm +c +c dbv(iv,jv) = d Bcart(iv) / dxvcart(jv) +c + dbv(1,1)=drrdx*dbvdc(1,1)+dphidx*dbvdc(1,2) + dbv(1,2)=drrdy*dbvdc(1,1)+dphidy*dbvdc(1,2) + dbv(1,3)=dbvdc(1,3) + dbv(2,1)=drrdx*dbvdc(2,1)+dphidx*dbvdc(2,2) + dbv(2,2)=drrdy*dbvdc(2,1)+dphidy*dbvdc(2,2) + dbv(2,3)=dbvdc(2,3) + dbv(3,1)=drrdx*dbvdc(3,1)+dphidx*dbvdc(3,2) + dbv(3,2)=drrdy*dbvdc(3,1)+dphidy*dbvdc(3,2) + dbv(3,3)=dbvdc(3,3) +c + dbtot(1)=(bv(1)*dbv(1,1)+bv(2)*dbv(2,1)+bv(3)*dbv(3,1))/btot + dbtot(2)=(bv(1)*dbv(1,2)+bv(2)*dbv(2,2)+bv(3)*dbv(3,2))/btot + dbtot(3)=(bv(1)*dbv(1,3)+bv(2)*dbv(2,3)+bv(3)*dbv(3,3))/btot +c + yg=btot/Bres +c +c convert spatial derivatives from dummy/m -> dummy/cm +c to be used in fwork +c +c bv(i) = B_i / B ; derbv(i,j) = d (B_i / B) /d x,y,z +c + do iv=1,3 + deryg(iv)=1.0d-2*dbtot(iv)/Bres + bv(iv)=bv(iv)/btot + do jv=1,3 + derbv(iv,jv)=1.0d-2*(dbv(iv,jv)-bv(iv)*dbtot(jv))/btot + end do + end do +c + derxg(1)=1.0d-2*drrdx*dpsidr*dxgdpsi + derxg(2)=1.0d-2*drrdy*dpsidr*dxgdpsi + derxg(3)=1.0d-2*dpsidz*dxgdpsi +c +c current density computation in Ampere/m^2 +c ccj==1/mu_0 +c + ccj=1.0d+7/(4.0d0*pi) + ajphi=ccj*(dbvcdc(1,3)-dbvcdc(3,1)) +c ajr=ccj*(dbvcdc(3,2)/rrm-dbvcdc(2,3)) +c ajz=ccj*(bvc(2)/rrm+dbvcdc(2,1)-dbvcdc(1,2)) +c + return + end +c +c +c + subroutine equian(rrm,zzm) + implicit real*8 (a-h,o-z) +c + common/parqq/q0,qa,alq + common/parban/b0,rr0m,zr0m,rpam + common/psival/psinv + common/pareq1/psia + common/densbnd/psdbnd + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + common/xgxg/xg + common/dxgdps/dxgdpsi + common/xgcn/xgcn + common/dens/dens,ddens + common/sgnib/sgnbphi,sgniphi + common/bmxmn/bmxi,bmni + common/fc/fci + common/iipr/iprof +c + if(iprof.eq.0) psdbnd=1.0d0 +c + dpsidrp=0.0d0 + d2psidrp=0.0d0 +c +c simple model for equilibrium +c + rpm=sqrt((rrm-rr0m)**2+(zzm-zr0m)**2) + rn=rpm/rpam +c + snt=0.0d0 + cst=1.0d0 + if (rpm.gt.0.0d0) then + snt=(zzm-zr0m)/rpm + cst=(rrm-rr0m)/rpm + end if +c +c valore fittizio di psinv e di psia: + psinv=rn**2 + psia=sgniphi +c + sgn=sgniphi*sgnbphi + if(rn.le.1.0d0) then + qq=q0+(qa-q0)*rn**alq + dpsidrp=B0*rpam*rn/qq*sgn + dqq=alq*(qa-q0)*rn**(alq-1.0d0) + d2psidrp=B0*(1.0d0-rn*dqq/qq)/qq*sgn + else + dpsidrp=B0*rpam/qa/rn*sgn + d2psidrp=-B0/qa/rn**2 *sgn + end if +c + fpolv=sgnbphi*b0*rr0m + dfpolv=0.0d0 + ffpv=sgniphi*fpolv*dfpolv +c + dpsidr=dpsidrp*cst + dpsidz=dpsidrp*snt + ddpsidrr=dpsidrp*snt**2/rpm+cst**2*d2psidrp + ddpsidrz=cst*snt*(d2psidrp-dpsidrp/rpm) + ddpsidzz=dpsidrp*cst**2/rpm+snt**2*d2psidrp +c + dens=0.0d0 + xg=0.0d0 + dxgdpsi=0.0d0 + if(psinv.lt.psdbnd) then + call density(psinv) + end if + xg=xgcn*dens + ddensdrp=2.0d0*rn*ddens + if(dpsidrp.ne.0.0d0) dxgdpsi=xgcn*ddensdrp/(dpsidrp*rpam) +c + bmax=sqrt(fpolv**2+dpsidrp**2)/(rr0m-rpam*rn) + bmin=sqrt(fpolv**2+dpsidrp**2)/(rr0m+rpam*rn) +c + return + end +c +c +c + subroutine equinum(rpsim,zpsim) + implicit real*8 (a-h,o-z) + parameter(nnw=501,nnh=501) + parameter(nrest=nnw+4,nzest=nnh+4) + parameter(lwrk=8,liwrk=2) + dimension ccspl(nnw*nnh) + dimension tr(nrest),tz(nzest),wrk(lwrk),iwrk(liwrk) + dimension rrs(1),zzs(1),ffspl(1) + parameter(lw10=nnw*3+nnh*4+nnw*nnh,lw01=nnw*4+nnh*3+nnw*nnh) + parameter(lw20=nnw*2+nnh*4+nnw*nnh,lw02=nnw*4+nnh*2+nnw*nnh) + parameter(lw11=nnw*3+nnh*3+nnw*nnh) + parameter(nrs=1,nzs=1) + dimension cc01(lw10),cc10(lw01),cc02(lw02),cc20(lw20),cc11(lw11) + dimension tfp(nrest),cfp(nrest),wrkfd(nrest) +c + common/eqnn/nr,nz,npp,nintp + common/psival/psinv + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + common/pareq1/psia + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + common/pareq1a/psiaxis0 +c + common/coffeqt/tr,tz + common/coffeqtp/tfp + common/coffeq/ccspl + common/coffeqd/cc01,cc10,cc20,cc02,cc11 + common/coffeqn/nsrt,nszt,nsft + common/cofffp/cfp + common/fpas/fpolas +c + psinv=-1.0d0 +c + dpsidr=0.0d0 + dpsidz=0.0d0 + ddpsidrr=0.0d0 + ddpsidzz=0.0d0 + ddpsidrz=0.0d0 +c +c here lengths are measured in meters +c + fpolv=fpolas + ffpv=0.0d0 +c + if (rpsim.gt.rmxm.or.rpsim.lt.rmnm) return + if (zpsim.gt.zmxm.or.zpsim.lt.zmnm) return +c + rrs(1)=rpsim + zzs(1)=zpsim + nsr=nsrt + nsz=nszt + call fpbisp(tr,nsr,tz,nsz,ccspl,3,3, + . rrs,nrs,zzs,nzs,ffspl,wrk(1),wrk(5),iwrk(1),iwrk(2)) + psinv=ffspl(1)-psiaxis0/psia +c if(psinv.lt.0.0d0) +c . print'(a,3e12.4)', ' psin < 0 , R, z ',psinv,rpsim,zpsim +c + nur=1 + nuz=0 + kkr=3-nur + kkz=3-nuz + iwr=1+(nr-nur-4)*(nz-nuz-4) + iwz=iwr+4-nur + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc10,kkr,kkz, + . rrs,nrs,zzs,nzs,ffspl,cc10(iwr),cc10(iwz),iwrk(1),iwrk(2)) + dpsidr= ffspl(1)*psia +c + nur=0 + nuz=1 + kkr=3-nur + kkz=3-nuz + iwr=1+(nr-nur-4)*(nz-nuz-4) + iwz=iwr+4-nur + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc01,kkr,kkz, + . rrs,nrs,zzs,nzs,ffspl,cc01(iwr),cc01(iwz),iwrk(1),iwrk(2)) + dpsidz= ffspl(1)*psia +c + nur=2 + nuz=0 + kkr=3-nur + kkz=3-nuz + iwr=1+(nr-nur-4)*(nz-nuz-4) + iwz=iwr+4-nur + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc20,kkr,kkz, + . rrs,nrs,zzs,nzs,ffspl,cc20(iwr),cc20(iwz),iwrk(1),iwrk(2)) + ddpsidrr= ffspl(1)*psia +c + nur=0 + nuz=2 + kkr=3-nur + kkz=3-nuz + iwr=1+(nr-nur-4)*(nz-nuz-4) + iwz=iwr+4-nur + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc02,kkr,kkz, + . rrs,nrs,zzs,nzs,ffspl,cc02(iwr),cc02(iwz),iwrk(1),iwrk(2)) + ddpsidzz= ffspl(1)*psia +c + nur=1 + nuz=1 + kkr=3-nur + kkz=3-nuz + iwr=1+(nr-nur-4)*(nz-nuz-4) + iwz=iwr+4-nur + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc11,kkr,kkz, + . rrs,nrs,zzs,nzs,ffspl,cc11(iwr),cc11(iwz),iwrk(1),iwrk(2)) + ddpsidrz= ffspl(1)*psia +c + if(psinv.le.1.0d0.and.psinv.gt.0.0d0) then + rrs(1)=psinv + call splev(tfp,nsft,cfp,3,rrs,ffspl,1,ier) + fpolv=ffspl(1) + nu=1 + call splder(tfp,nsft,cfp,3,nu,rrs,ffspl,1,wrkfd,ier) + dfpolv=ffspl(1) + ffpv=fpolv*dfpolv/psia + end if +c + return + end +c +c +c + subroutine bfield(rpsim,zpsim,bphi,brr,bzz) + implicit real*8 (a-h,o-z) + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + call equinum(rpsim,zpsim) + bphi=fpolv/rpsim + brr=-dpsidz/rpsim + bzz= dpsidr/rpsim + return + end +c + subroutine tor_curr_psi(h,ajphi) + implicit real*8 (a-h,o-z) + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + call psi_raxis(h,r1,r2) + call tor_curr(r2,zmaxis,ajphi) + return + end + +c + subroutine tor_curr(rpsim,zpsim,ajphi) + implicit real*8 (a-h,o-z) + parameter(pi=3.14159265358979d0,ccj=1.0d+7/(4.0d0*pi)) + common/derip/dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,ffpv + call equinum(rpsim,zpsim) + bzz= dpsidr/rpsim + dbvcdc13=-ddpsidzz/rpsim + dbvcdc31= ddpsidrr/rpsim-bzz/rpsim + ajphi=ccj*(dbvcdc13-dbvcdc31) + return + end +c + subroutine psi_raxis(h,r1,r2) + implicit real*8 (a-h,o-z) + parameter(mest=4,kspl=3) + parameter(nnw=501,nnh=501) + parameter(nrest=nnw+4,nzest=nnh+4) + dimension cc(nnw*nnh),tr(nrest),tz(nzest) + dimension czc(nrest),zeroc(mest) +c + common/pareq1/psia + common/pareq1a/psiaxis0 + common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz + common/coffeqn/nsr,nsz,nsft + common/coffeq/cc + common/coffeqt/tr,tz +c + iopt=1 + zc=zmaxis + call profil(iopt,tr,nsr,tz,nsz,cc,kspl,kspl,zc,nsr,czc,ier) + if(ier.gt.0) print*,' profil =',ier + val=h+psiaxis0/psia + call sproota(val,tr,nsr,czc,zeroc,mest,m,ier) + r1=zeroc(1) + r2=zeroc(2) + return + end +c +c +c + subroutine sub_xg_derxg + implicit real*8 (a-h,o-z) + common/psival/psinv + common/pareq1/psia + common/xgxg/xg + common/dxgdps/dxgdpsi + common/xgcn/xgcn + common/dens/dens,ddenspsin + xg=0.0d0 + dxgdpsi=0.0d0 +c if(psinv.le.psdbnd.and.psinv.ge.0) then + call density(psinv) + xg=xgcn*dens + dxgdpsi=xgcn*ddenspsin/psia +c end if + return + end +c +c +c + subroutine density(arg) + implicit real*8 (a-h,o-z) + parameter(npmx=250,npest=npmx+4) + dimension xxs(1),ffs(1) + dimension tfn(npest),cfn(npest),wrkfd(npest) +c + common/densbnd/psdbnd + common/denspp/psnpp,aad,bbd,ccd + common/iipr/iprof + common/pardens/dens0,aln1,aln2 + common/dens/dens,ddens + common/coffdt/tfn + common/coffdnst/nsfd + common/cofffn/cfn +c +c computation of density [10^19 m^-3] and derivative wrt psi +c + dens=0.0d0 + ddens=0.0d0 + if(arg.gt.psdbnd.or.arg.lt.0.0d0) return +c + if(iprof.eq.0) then + if(arg.gt.1.0d0) return + profd=(1.0d0-arg**aln1)**aln2 + dens=dens0*profd + dprofd=-aln1*aln2*arg**(aln1-1.0d0) + . *(1.0d0-arg**aln1)**(aln2-1.0d0) + ddens=dens0*dprofd + else + if(arg.le.psdbnd.and.arg.gt.psnpp) then +c +c cubic interpolation for 1 < psi < psdbnd +c + nn=3 + nn1=nn+1 + nn2=nn+2 + dpsib=arg-psdbnd + dens=aad*dpsib**nn+bbd*dpsib**nn1+ccd*dpsib**nn2 + ddens=nn*aad*dpsib**(nn-1)+nn1*bbd*dpsib**nn + . +nn2*ccd*dpsib**nn1 + else + xxs(1)=arg + ier=0 + call splev(tfn,nsfd,cfn,3,xxs,ffs,1,ier) + dens=ffs(1) + nu=1 + ier=0 + call splder(tfn,nsfd,cfn,3,nu,xxs,ffs,1,wrkfd,ier) + ddens=ffs(1) + if(ier.gt.0) print*,ier + if(abs(dens).lt.1.0d-10) dens=0.0d0 + end if + if(dens.lt.0.0d0) print*,' DENSITY NEGATIVE',dens +c + end if + return + end +c +c +c + function temp(arg) + implicit real*8 (a-h,o-z) + parameter(npmx=250) + dimension psrad(npmx),derad(npmx),terad(npmx),zfc(npmx),ct(npmx,4) +c + common/parqte/te0,dte0,alt1,alt2 + common/iipr/iprof + common/crad/psrad,derad,terad,zfc + common/coffte/ct + common/eqnn/nr,nz,npp,nintp +c + temp=0.0d0 + if(arg.ge.1.0d0.or.arg.lt.0.0d0) return + if(iprof.eq.0) then + proft=(1.0d0-arg**alt1)**alt2 + temp=(te0-dte0)*proft+dte0 + else + call locate(psrad,npp,arg,k) + if(k.eq.0) k=1 + if(k.eq.npp) k=npp-1 + dps=arg-psrad(k) + temp=spli(ct,npmx,k,dps) + endif + return + end +c +c +c + function fzeff(arg) + implicit real*8 (a-h,o-z) + parameter(npmx=250) + dimension psrad(npmx),derad(npmx),terad(npmx),zfc(npmx),cz(npmx,4) +c + common/iipr/iprof + common/crad/psrad,derad,terad,zfc + common/coffz/cz + common/eqnn/nr,nz,npp,nintp + common/zz/Zeff +c + fzeff=1 + ps=arg + if(ps.gt.1.0d0.and.ps.lt.0.0d0) return + if(iprof.eq.0) then + fzeff=zeff + else + call locate(psrad,npp,ps,k) + if(k.eq.0) k=1 + if(k.eq.npp) k=npp-1 + dps=ps-psrad(k) + fzeff=spli(cz,npmx,k,dps) + endif + return + end +c +c beam tracing initial conditions igrad=1 +c + subroutine ic_gb + implicit real*8 (a-h,o-z) + parameter(ndim=6,ndimm=3) + parameter(jmx=31,kmx=36,zero=0.0d0,izero=0) + parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) + dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) + dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx) + dimension dffiu(jmx),ddffiu(jmx) + dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) + complex*16 ui,sss,ddd,phic,qi1,qi2,tc,ts,qqxx,qqxy,qqyy + complex*16 dqi1,dqi2,dqqxx,dqqyy,dqqxy + complex*16 d2qi1,d2qi2,d2qqxx,d2qqyy,d2qqxy + complex*16 catand + external catand +c parameter(ui=(0.0d0,1.0d0)) +c + common/nrayktx/nray,ktx + common/rhomx/rmx + common/parwv/ak0,akinv,fhz + common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir + common/anic/anx0c,any0c,anz0c + common/wrk/ywrk0,ypwrk0 + common/grc/xc0,du10 + common/fi/dffiu,ddffiu + common/mirr/x00,y00,z00 + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri + common/ddd/dd,an2s,an2,fdia,bdotgr,ddi +c + ui=(0.0d0,1.0d0) + csth=anz0c + snth=sqrt(1.0d0-csth**2) + csps=1.0d0 + snps=0.0d0 + if(snth.gt.0.0d0) then + csps=any0c/snth + snps=anx0c/snth + end if +c + phiwrad=phiw*cvdr + phirrad=phir*cvdr + csphiw=cos(phiwrad) + snphiw=sin(phiwrad) +c csphir=cos(phirrad) +c snphir=sin(phirrad) +c + wwcsi=2.0d0*akinv/wcsi**2 + wweta=2.0d0*akinv/weta**2 +c + if(phir.ne.phiw) then + sk=(rcicsi+rcieta) + sw=(wwcsi+wweta) + dk=(rcicsi-rcieta) + dw=(wwcsi-wweta) + ts=-(dk*sin(2.0d0*phirrad)-ui*dw*sin(2.0d0*phiwrad)) + tc=(dk*cos(2.0d0*phirrad)-ui*dw*cos(2.0d0*phiwrad)) + phic=0.5d0*catand(ts/tc) + ddd=dk*cos(2*(phirrad+phic))-ui*dw*cos(2*(phiwrad+phic)) + sss=sk-ui*sw + qi1=0.5d0*(sss+ddd) + qi2=0.5d0*(sss-ddd) + rci1=dble(qi1) + ww1=-dimag(qi1) + rci2=dble(qi2) + ww2=-dimag(qi2) + else + rci1=rcicsi + rci2=rcieta + ww1=wwcsi + ww2=wweta + phic=-phiwrad + qi1=rci1-ui*ww1 + qi2=rci2-ui*ww2 + end if +c w01=sqrt(2.0d0*akinv/ww1) +c z01=-rci1/(rci1**2+ww1**2) +c w02=sqrt(2.0d0*akinv/ww2) +c z02=-rci2/(rci2**2+ww2**2) +c +c spostare nel do???? +c + + qqxx=qi1*cos(phic)**2+qi2*sin(phic)**2 + qqyy=qi1*sin(phic)**2+qi2*cos(phic)**2 + qqxy=-(qi1-qi2)*sin(2.0d0*phic) + wwxx=-dimag(qqxx) + wwyy=-dimag(qqyy) + wwxy=-dimag(qqxy)/2.0d0 + rcixx=dble(qqxx) + rciyy=dble(qqyy) + rcixy=dble(qqxy)/2.0d0 + +C d2ww1=-2.0d0*(dww1*rci1+ww1*drci1) +C d2ww2=-2.0d0*(dww2*rci2+ww2*drci2) +C d2rci1=2.0d0*(ww1*dww1-rci1*drci1) +C d2rci2=2.0d0*(ww2*dww2-rci2*drci2) +C dqi1=drci1-ui*dww1 +C dqi2=drci2-ui*dww2 +C d2qi1=d2rci1-ui*d2ww1 +C d2qi2=d2rci2-ui*d2ww2 +c + dqi1=-qi1**2 + dqi2=-qi2**2 + d2qi1=2*qi1**3 + d2qi2=2*qi2**3 + dqqxx=dqi1*cos(phic)**2+dqi2*sin(phic)**2 + dqqyy=dqi1*sin(phic)**2+dqi2*cos(phic)**2 + dqqxy=-(dqi1-dqi2)*sin(2.0d0*phic) + d2qqxx=d2qi1*cos(phic)**2+d2qi2*sin(phic)**2 + d2qqyy=d2qi1*sin(phic)**2+d2qi2*cos(phic)**2 + d2qqxy=-(d2qi1-d2qi2)*sin(2.0d0*phic) +c + dwwxx=-dimag(dqqxx) + dwwyy=-dimag(dqqyy) + dwwxy=-dimag(dqqxy)/2.0d0 + d2wwxx=-dimag(d2qqxx) + d2wwyy=-dimag(d2qqyy) + d2wwxy=-dimag(d2qqxy)/2.0d0 + drcixx=dble(dqqxx) + drciyy=dble(dqqyy) + drcixy=dble(dqqxy)/2.0d0 + + dr=1.0d0 + if(nray.gt.1) dr=rmx/dble(nray-1) + da=2.0d0*pi/dble(ktx) +c + ddfu=2.0d0*dr**2*akinv + do j=1,nray + u=dble(j-1) +c ffi=u**2*ddfu/2.0d0 + dffiu(j)=u*ddfu + ddffiu(j)=ddfu + do k=1,ktx + alfak=(k-1)*da + dcsiw=dr*cos(alfak)*wcsi + detaw=dr*sin(alfak)*weta + dx0t=dcsiw*csphiw-detaw*snphiw + dy0t=dcsiw*snphiw+detaw*csphiw + x0t=u*dx0t + y0t=u*dy0t + z0t=-0.5d0*(rcixx*x0t**2+rciyy*y0t**2+2*rcixy*x0t*y0t) +c +c csiw=u*dcsiw +c etaw=u*detaw +c csir=x0t*csphir+y0t*snphir +c etar=-x0t*snphir+y0t*csphir +c + dx0= x0t*csps+snps*(y0t*csth+z0t*snth) + dy0=-x0t*snps+csps*(y0t*csth+z0t*snth) + dz0= z0t*csth-y0t*snth +c + x0=x00+dx0 + y0=y00+dy0 + z0=z00+dz0 + + gxt=x0t*wwxx+y0t*wwxy + gyt=x0t*wwxy+y0t*wwyy + gzt=0.5d0*(x0t**2*dwwxx+y0t**2*dwwyy)+x0t*y0t*dwwxy + gr2=gxt*gxt+gyt*gyt+gzt*gzt + gxxt=wwxx + gyyt=wwyy + gzzt=0.5d0*(x0t**2*d2wwxx+y0t**2*d2wwyy)+x0t*y0t*d2wwxy + gxyt=wwxy + gxzt=x0t*dwwxx+y0t*dwwxy + gyzt=x0t*dwwxy+y0t*dwwyy + dgr2xt=2.0d0*(gxt*gxxt+gyt*gxyt+gzt*gxzt) + dgr2yt=2.0d0*(gxt*gxyt+gyt*gyyt+gzt*gyzt) + dgr2zt=2.0d0*(gxt*gxzt+gyt*gyzt+gzt*gzzt) + dgr2x= dgr2xt*csps+snps*(dgr2yt*csth+dgr2zt*snth) + dgr2y=-dgr2xt*snps+csps*(dgr2yt*csth+dgr2zt*snth) + dgr2z= dgr2zt*csth-dgr2yt*snth + gri(1,j,k)=gxt*csps+snps*(gyt*csth+gzt*snth) + gri(2,j,k)=-gxt*snps+csps*(gyt*csth+gzt*snth) + gri(3,j,k)=gzt*csth-gyt*snth + ggri(1,1,j,k)=gxxt*csps**2+ + . snps**2*(gyyt*csth**2+gzzt*snth**2+2.0d0*snth*csth*gyzt)+ + . 2.0d0*snps*csps*(gxyt*csth+gxzt*snth) + ggri(2,2,j,k)=gxxt*snps**2+ + . csps**2*(gyyt*csth**2+gzzt*snth**2+2.0d0*snth*csth*gyzt)- + . 2.0d0*snps*csps*(gxyt*csth+gxzt*snth) + ggri(3,3,j,k)=gzzt*csth**2+gyyt*snth**2-2.0d0*csth*snth*gyzt + ggri(1,2,j,k)=csps*snps*(-gxxt+csth**2*gyyt+snth**2*gzzt + . +2.0d0*csth*snth*gyzt) + . +(csps**2-snps**2)*(snth*gxzt+csth*gxyt) + ggri(1,3,j,k)=csth*snth*snps*(gzzt-gyyt) + . +(csth**2-snth**2)*snps*gyzt+csps*(csth*gxzt-snth*gxyt) + ggri(2,3,j,k)=csth*snth*csps*(gzzt-gyyt) + . +(csth**2-snth**2)*csps*gyzt+snps*(snth*gxyt-csth*gxzt) + ggri(2,1,j,k)=ggri(1,2,j,k) + ggri(3,1,j,k)=ggri(1,3,j,k) + ggri(3,2,j,k)=ggri(2,3,j,k) +c + du1tx=(dx0t*wwxx+dy0t*wwxy)/ddfu + du1ty=(dx0t*wwxy+dy0t*wwyy)/ddfu + du1tz=0.5d0*u*(dx0t**2*dwwxx+dy0t**2*dwwyy+ + . 2.0d0*dx0t*dy0t*dwwxy)/ddfu +c + ppx=x0t*rcixx+y0t*rcixy + ppy=x0t*rcixy+y0t*rciyy + anzt=sqrt((1.0d0+gr2)/(1.0d0+ppx**2+ppy**2)) + anxt=ppx*anzt + anyt=ppy*anzt +c + anx= anxt*csps+snps*(anyt*csth+anzt*snth) + any=-anxt*snps+csps*(anyt*csth+anzt*snth) + anz= anzt*csth-anyt*snth +c + an20=1.0d0+gr2 + an0=sqrt(an20) + anx0=anx + any0=any + anz0=anz +c + xc0(1,j,k)=x0 + xc0(2,j,k)=y0 + xc0(3,j,k)=z0 +c + ywrk0(1,j,k)=x0 + ywrk0(2,j,k)=y0 + ywrk0(3,j,k)=z0 + ywrk0(4,j,k)=anx0 + ywrk0(5,j,k)=any0 + ywrk0(6,j,k)=anz0 +c + ypwrk0(1,j,k) = anx0/an0 + ypwrk0(2,j,k) = any0/an0 + ypwrk0(3,j,k) = anz0/an0 + ypwrk0(4,j,k) = dgr2x/an0/2.0d0 + ypwrk0(5,j,k) = dgr2y/an0/2.0d0 + ypwrk0(6,j,k) = dgr2z/an0/2.0d0 +c + grad2(j,k)=gr2 + dgrad2v(1,j,k)=dgr2x + dgrad2v(2,j,k)=dgr2y + dgrad2v(3,j,k)=dgr2z +c + du10(1,j,k)= du1tx*csps+snps*(du1ty*csth+du1tz*snth) + du10(2,j,k)=-du1tx*snps+csps*(du1ty*csth+du1tz*snth) + du10(3,j,k)= du1tz*csth-du1ty*snth +c + dd=anx0**2+any0**2+anz0**2-an20 + vgradi=anxt*gxt+anyt*gyt+anzt*gzt + ddi=2.0d0*vgradi +c + write(11,111) izero,j,k,x0,y0,z0,anx0/an0,any0/an0,anz0/an0,gr2 + if(j.eq.nray.or.j.eq.1) then + r0=sqrt(x0**2+y0**2) + x0m=x0/1.0d2 + y0m=y0/1.0d2 + r0m=r0/1.0d2 + z0m=z0/1.0d2 + if(j.eq.nray) write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m + * ,zero,zero,zero,zero,zero + if(j.eq.1.and.k.eq.1) + * write(31,111) izero,j,k,zero,x0m,y0m,r0m,z0m,zero,zero + * ,zero,zero,zero + end if + if(k.eq.1.and.j.eq.nray) + * write(27,99) zero,x0,y0,z0,r0,dd,vgradi + end do + end do +c + call pweigth +c + if(nray.gt.1) then + iproj=0 + nfilp=8 + call projxyzt(iproj,nfilp) + end if +c + return + 99 format(12(1x,e16.8e3)) +111 format(3i5,20(1x,e16.8e3)) + end +c +c ray tracing initial conditions igrad=0 +c + subroutine ic_rt + implicit real*8 (a-h,o-z) + parameter(ndim=6,ndimm=3) + parameter(jmx=31,kmx=36,zero=0.0d0,izero=0) + parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) + dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) + dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx) + dimension dffiu(jmx),ddffiu(jmx) + dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) +c + common/nrayktx/nray,ktx + common/rhomx/rmx + common/parbeam/wcsi,weta,rcicsi,rcieta,phiw,phir + common/anic/anx0c,any0c,anz0c + common/wrk/ywrk0,ypwrk0 + common/grc/xc0,du10 + common/fi/dffiu,ddffiu + common/mirr/x00,y00,z00 + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri + common/ddd/dd,an2s,an2,fdia,bdotgr,ddi +c + csth=anz0c + snth=sqrt(1.0d0-csth**2) + csps=1.0d0 + snps=0.0d0 + if(snth.gt.0.0d0) then + csps=any0c/snth + snps=anx0c/snth + end if +c + phiwrad=phiw*cvdr + csphiw=cos(phiwrad) + snphiw=sin(phiwrad) +c + dr=1.0d0 + if(nray.gt.1) dr=rmx/dble(nray-1) + da=2.0d0*pi/dble(ktx) + z0t=0.0d0 +c + do j=1,nray + u=dble(j-1) + dffiu(j)=0.0d0 + ddffiu(j)=0.0d0 + do k=1,ktx + alfak=(k-1)*da + dcsiw=dr*cos(alfak)*wcsi + detaw=dr*sin(alfak)*weta + dx0t=dcsiw*csphiw-detaw*snphiw + dy0t=dcsiw*snphiw+detaw*csphiw + x0t=u*dx0t + y0t=u*dy0t +c +c csiw=u*dcsiw +c etaw=u*detaw +c csir=csiw +c etar=etaw +c + dx0= x0t*csps+snps*(y0t*csth+z0t*snth) + dy0=-x0t*snps+csps*(y0t*csth+z0t*snth) + dz0= z0t*csth-y0t*snth +c + x0=x00+dx0 + y0=y00+dy0 + z0=z00+dz0 +c + ppcsi=u*dr*cos(alfak)*rcicsi + ppeta=u*dr*sin(alfak)*rcieta +c + anzt=1.0d0/sqrt(1.0d0+ppcsi**2+ppeta**2) + ancsi=ppcsi*anzt + aneta=ppeta*anzt +c + anxt=ancsi*csphiw-aneta*snphiw + anyt=ancsi*snphiw+aneta*csphiw +c + anx= anxt*csps+snps*(anyt*csth+anzt*snth) + any=-anxt*snps+csps*(anyt*csth+anzt*snth) + anz= anzt*csth-anyt*snth +c + an20=1.0d0 + an0=sqrt(an20) + anx0=anx + any0=any + anz0=anz +c + xc0(1,j,k)=x0 + xc0(2,j,k)=y0 + xc0(3,j,k)=z0 +c + ywrk0(1,j,k)=x0 + ywrk0(2,j,k)=y0 + ywrk0(3,j,k)=z0 + ywrk0(4,j,k)=anx0 + ywrk0(5,j,k)=any0 + ywrk0(6,j,k)=anz0 +c + ypwrk0(1,j,k) = anx0/an0 + ypwrk0(2,j,k) = any0/an0 + ypwrk0(3,j,k) = anz0/an0 + ypwrk0(4,j,k) = 0.0d0 + ypwrk0(5,j,k) = 0.0d0 + ypwrk0(6,j,k) = 0.0d0 +c + do iv=1,3 + gri(iv,j,k)=0.0d0 + dgrad2v(iv,j,k)=0.0d0 + du10(iv,j,k)=0.0d0 + do jv=1,3 + ggri(iv,jv,j,k)=0.0d0 + end do + end do + grad2(j,k)=0.0d0 +c + dd=anx0**2+any0**2+anz0**2-an20 + vgradi=0.0d0 + ddi=2.0d0*vgradi +c + if(j.eq.nray.or.j.eq.1) then + r0=sqrt(x0**2+y0**2) + x0m=x0/1.0d2 + y0m=y0/1.0d2 + r0m=r0/1.0d2 + z0m=z0/1.0d2 + if(j.eq.nray) write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m + * ,zero,zero,zero,zero,zero + if(j.eq.1.and.k.eq.1) + * write(31,111) izero,j,k,zero,x0m,y0m,r0m,z0m,zero,zero + * ,zero,zero,zero + end if + if(k.eq.1.and.j.eq.nray) + * write(27,99) zero,x0,y0,z0,r0,dd,vgradi + end do + end do +c + call pweigth +c + if(nray.gt.1) then + iproj=0 + nfilp=8 + call projxyzt(iproj,nfilp) + end if +c + return + 99 format(12(1x,e16.8e3)) +111 format(3i5,20(1x,e16.8e3)) + end + + + + subroutine ic_rt0 + implicit real*8 (a-h,o-z) + parameter(ndim=6,ndimm=3) + parameter(jmx=31,kmx=36,zero=0.0d0,izero=0) + parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) + dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) + dimension yyrfl(jmx,kmx,ndim) + dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx) + dimension dffiu(jmx),ddffiu(jmx) + dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx) + dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) +c + common/nrayktx/nray,ktx + common/wrk/ywrk0,ypwrk0 + common/grc/xc0,du10 + common/grad2jk/grad2 + common/dgrad2jk/dgrad2v + common/gradjk/gri + common/ggradjk/ggri + common/ddd/dd,an2s,an2,fdia,bdotgr,ddi + common/yyrfl/yyrfl + + do j=1,nray + do k=1,ktx + x0=yyrfl(j,k,1) + y0=yyrfl(j,k,2) + z0=yyrfl(j,k,3) + anx0=yyrfl(j,k,4) + any0=yyrfl(j,k,5) + anz0=yyrfl(j,k,6) + an20=anx0*anx0+any0*any0+anz0*anz0 + an0=sqrt(an20) +c + xc0(1,j,k)=x0 + xc0(2,j,k)=y0 + xc0(3,j,k)=z0 +c + ywrk0(1,j,k)=x0 + ywrk0(2,j,k)=y0 + ywrk0(3,j,k)=z0 + ywrk0(4,j,k)=anx0/an0 + ywrk0(5,j,k)=any0/an0 + ywrk0(6,j,k)=anz0/an0 +c + ypwrk0(1,j,k) = anx0/an0 + ypwrk0(2,j,k) = any0/an0 + ypwrk0(3,j,k) = anz0/an0 + ypwrk0(4,j,k) = 0.0d0 + ypwrk0(5,j,k) = 0.0d0 + ypwrk0(6,j,k) = 0.0d0 +c + do iv=1,3 + gri(iv,j,k)=0.0d0 + dgrad2v(iv,j,k)=0.0d0 + du10(iv,j,k)=0.0d0 + do jv=1,3 + ggri(iv,jv,j,k)=0.0d0 + end do + end do + grad2(j,k)=0.0d0 +c + dd=anx0**2+any0**2+anz0**2-an20 + vgradi=0.0d0 + ddi=2.0d0*vgradi +c + if(j.eq.nray.or.j.eq.1) then + r0=sqrt(x0**2+y0**2) + x0m=x0/1.0d2 + y0m=y0/1.0d2 + r0m=r0/1.0d2 + z0m=z0/1.0d2 + if(j.eq.nray) write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m + * ,zero,zero,zero,zero,zero + if(j.eq.1.and.k.eq.1) + * write(31,111) izero,j,k,zero,x0m,y0m,r0m,z0m,zero,zero + * ,zero,zero,zero + end if + if(k.eq.1.and.j.eq.nray) + * write(27,99) zero,x0,y0,z0,r0,dd,vgradi + end do + end do +c + call pweigth +c + if(nray.gt.1) then + iproj=0 + nfilp=8 + call projxyzt(iproj,nfilp) + end if +c + return + 99 format(12(1x,e16.8e3)) +111 format(3i5,20(1x,e16.8e3)) + end +c +c ray power weigth coefficient q(j) +c + subroutine pweigth + implicit real*8(a-h,o-z) + parameter(jmx=31) + dimension q(jmx) + common/qw/q + common/nrayktx/nray,ktx + common/rhomx/rmx +c + dr=1.0d0 + if(nray.gt.1) dr=rmx/dble(nray-1) + r1=0.0d0 + summ=0.0d0 + q(1)=1.0d0 + if(nray.gt.1) then + do j=1,nray + r2=(dble(j)-0.5d0)*dr + q(j)=(exp(-2.0d0*r1**2)-exp(-2.0d0*r2**2)) + r1=r2 + summ=summ+q(j) + end do +c + q(1)=q(1)/summ + sm=q(1) + j=1 + k=1 + do j=2,nray + q(j)=q(j)/ktx/summ + do k=1,ktx + sm=sm+q(j) + end do + end do + end if +c + return + end +c +c +c + subroutine valpsispl(rpsi,voli,dervoli,areai,rrii,rbavi, + . bmxi,bmni,fci,intp) + implicit real*8 (a-h,o-z) + parameter(nnintp=101) + dimension rpstab(nnintp),cbmx(nnintp,4),cbmn(nnintp,4) + dimension cvol(nnintp,4),crri(nnintp,4),crbav(nnintp,4) + dimension carea(nnintp,4),cfc(nnintp,4) +c + common/cflav/cvol,crri,crbav,cbmx,cbmn,carea,cfc + common/pstab/rpstab + common/eqnn/nr,nz,npp,nintp +c + ip=int((nintp-1)*rpsi+1) + if(ip.eq.0) ip=1 + if(ip.eq.nintp) ip=nintp-1 +c + dps=rpsi-rpstab(ip) +c + areai=spli(carea,nintp,ip,dps) + voli=spli(cvol,nintp,ip,dps) + dervoli=splid(cvol,nintp,ip,dps) + rrii=spli(crri,nintp,ip,dps) +c + if(intp.eq.0) return +c + rbavi=spli(crbav,nintp,ip,dps) + bmxi=spli(cbmx,nintp,ip,dps) + bmni=spli(cbmn,nintp,ip,dps) + fci=spli(cfc,nintp,ip,dps) +c + return + end +c +c +c + subroutine ratioj(rpsi,ratj1i,ratj2i) + implicit real*8 (a-h,o-z) + parameter(nnintp=101) + dimension rpstab(nnintp),cratj1(nnintp,4),cratj2(nnintp,4) + common/pstab/rpstab + common/eqnn/nr,nz,npp,nintp + common/cratj/cratj1,cratj2 + ip=int((nintp-1)*rpsi+1) + if(ip.eq.0) ip=1 + if(ip.eq.nintp) ip=nintp-1 + dps=rpsi-rpstab(ip) + ratj1i=spli(cratj1,nintp,ip,dps) + ratj2i=spli(cratj2,nintp,ip,dps) + return + end +c +c +c + subroutine pabs_curr(i,j,k) + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36,nmx=8000) + parameter(pi=3.14159265358979d0) + dimension psjki(jmx,kmx,nmx) + dimension tauv(jmx,kmx,nmx),alphav(jmx,kmx,nmx) + dimension pdjki(jmx,kmx,nmx),ppabs(jmx,kmx,nmx) + dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension q(jmx),tau1v(jmx,kmx) +c + common/psjki/psjki + common/atjki/tauv,alphav + common/dpjjki/pdjki,currj + common/pcjki/ppabs,ccci + common/dcjki/didst + common/tau1v/tau1v +c + common/qw/q + common/p0/p0mw +c + common/dsds/dst + common/dersdst/dersdst + common/iieq/iequil +c + common/parban/b0,rr0m,zr0m,rpam + common/absor/alpha,effjcd,akim,tau0 +c + common/psival/psinv + common/sgnib/sgnbphi,sgniphi + common/bmxmn/bmxi,bmni + common/fc/fci +c + dvvl=1.0d0 + rbavi=1.0d0 + rrii=rr0m + rhop0=sqrt(psjki(j,k,i-1)) + if(iequil.eq.2) then + intp=1 + psinv=psjki(j,k,i) + rhop=sqrt(psinv) + call valpsispl(rhop,voli,dervoli,area,rrii, + . rbavi,bmxi,bmni,fci,intp) + dvvl=dervoli*abs(rhop-rhop0) + else + dvvl=4.0d0*pi*rr0m*pi*abs(rhop*rhop-rhop0*rhop0)*rpam**2 + rbavi=b0/bmni + fci=1.0d0-1.469d0*sqrt(rpam/rr0m) + end if + if(dvvl.le.0.0d0) dvvl=1.0d0 +c + adnm=2.0d0*pi*rrii +c +c calcolo della corrente cohen: currtot [MA] +c calcolo della densita' corrente cohen: currj [MA/m^2] +c calcolo della densita' potenza: pdjki [MW/m^3] +c calcolo della efficienza : effjcdav [A m/W ] +c + tau0=tauv(j,k,i-1) +c + call ecrh_cd +c + alphav(j,k,i)=alpha + dtau=(alphav(j,k,i)+alphav(j,k,i-1))*dersdst*dst/2.0d0 + tauv(j,k,i)=tauv(j,k,i-1)+dtau + dpdst=p0mw*q(j)*exp(-tauv(j,k,i)-tau1v(j,k))* + . alphav(j,k,i)*dersdst + pdjki(j,k,i)=dpdst*dst/dvvl + ppabs(j,k,i)=p0mw*q(j)*exp(-tau1v(j,k))* + . (1.0d0-exp(-tauv(j,k,i))) + effjcdav=rbavi*effjcd + currj(j,k,i)=sgnbphi*effjcdav*pdjki(j,k,i) + didst(j,k,i)=sgnbphi*effjcdav*dpdst/adnm + dcidst=(didst(j,k,i)+didst(j,k,i-1))/2.0d0 + ccci(j,k,i)=ccci(j,k,i-1)+dcidst*dst + return + end +c +c +c + subroutine ecrh_cd + implicit real*8 (a-h,o-z) + real*8 mc2,mesi + parameter(taucr=12.0d0,xxcr=16.0d0,eps=1.d-8) + parameter(qesi=1.602176487d-19,mesi=9.10938215d-31) + parameter(vcsi=2.99792458d+8) + parameter(mc2 = mesi*vcsi*vcsi/qesi*1d-3) +c + common/ithn/ithn + common/nharm/nharm,nhf + common/warm/iwarm,ilarm + common/ieccd/ieccd +c + common/ygyg/yg + common/nplr/anpl,anpr + common/vgv/vgm,derdnm + common/parwv/ak0,akinv,fhz +c + common/nprw/anprre,anprim +c + common/absor/alpha,effjcd,akim,tau +c + common/psival/psinv + common/tete/tekev + common/amut/amu + common/zz/Zeff +c +c absorption computation +c + alpha=0.0d0 + akim=0.0d0 + effjcd=0.0d0 +c + tekev=temp(psinv) + amu=mc2/tekev + zeff=fzeff(psinv) +c + if(tekev.le.0.0d0.or.tau.gt.taucr) return +c + dnl=1.0d0-anpl*anpl + if(iwarm.eq.1) then + ygc=1.0d0-anpl**2/2.0d0 + else + ygc=sqrt(1.0d0-anpl**2) + end if +c + nharm=int(ygc/yg-eps)+1 +c + if(nharm.eq.0) return +c + nhf=0 + do nn=nharm,nharm+4 + ygn=nn*yg + if(iwarm.eq.1) then + rdu2=2.0d0*(ygn-ygc) + u1=anpl+sqrt(rdu2) + u2=anpl-sqrt(rdu2) + uu2=min(u1*u1,u2*u2) + argex=amu*uu2/2.0d0 + else + rdu2=ygn**2-ygc**2 + g1=(ygn+anpl*sqrt(rdu2))/dnl + g2=(ygn-anpl*sqrt(rdu2))/dnl + gg=min(g1,g2) + argex=amu*(gg-1.0d0) + u1=(ygn*anpl+sqrt(rdu2))/dnl + u2=(ygn*anpl-sqrt(rdu2))/dnl + end if + if(argex.le.xxcr) nhf=nn + end do + if(nhf.eq.0) return +c + lrm=ilarm + if(lrm.lt.nhf) lrm=nhf + call dispersion(lrm) +c + akim=ak0*anprim + ratiovgr=2.0d0*anpr/derdnm +c ratiovgr=2.0d0*anpr/derdnm*vgm + alpha=2.0d0*akim*ratiovgr + if(alpha.lt.0.0d0) then + ierr=94 + print*,' IERR = ', ierr,' alpha negative' + end if +c + ithn=1 + if(lrm.gt.nharm) ithn=2 + if(ieccd.gt.0) call eccd(effjcd) + + return +999 format(12(1x,e12.5)) + end +c +c +c + subroutine dispersion(lrm) + implicit real*8(a-h,o-z) + parameter(imx=20) + complex*16 cc0,cc2,cc4,rr + complex*16 anpr2a,anpra + complex*16 anpr,anpr2,ex,ey,ez,den + complex*16 epsl(3,3,lrm),sepsl(3,3),e330 + complex*16 e11,e22,e12,e13,e23 +c complex*16 e33,e21,e31,e32 + complex*16 a13,a31,a23,a32,a33 +c + common/ygyg/yg + common/nplr/anpl,anprf +c + common/mode/sox + common/warm/iwarm,ilarm +c + common/nprw/anprr,anpri + common/epolar/ex,ey,ez + common/amut/amu +c + errnpr=1.0d0 + anpr2a=anprf**2 + anpl2=anpl*anpl +c + if (iwarm.eq.1) then + call diel_tens_wr(e330,epsl,lrm) + else + call diel_tens_fr(e330,epsl,lrm) + end if +c + do i=1,imx +c + do j=1,3 + do k=1,3 + sepsl(k,j)=dcmplx(0.0d0,0.0d0) + do ilrm=1,lrm + sepsl(k,j)=sepsl(k,j)+epsl(k,j,ilrm)*anpr2a**(ilrm-1) + end do + end do + end do +c + anpra=sqrt(anpr2a) +c + e11=sepsl(1,1) + e22=sepsl(2,2) + e12=sepsl(1,2) + a33=sepsl(3,3) + a13=sepsl(1,3) + a23=sepsl(2,3) + a31=a13 + a32=-a23 +c e33=e330+anpr2a*a33 + e13=anpra*a13 + e23=anpra*a23 +c e21=-e12 +c e31=e13 +c e32=-e23 +c + if(i.gt.2.and.errnpr.lt.1.0d-3) go to 999 +c + cc4=(e11-anpl2)*(1.0d0-a33)+(a13+anpl)*(a31+anpl) + cc2=-e12*e12*(1.0d0-a33) + . -a32*e12*(a13+anpl)+a23*e12*(a31+anpl) + . -(a23*a32+e330+(e22-anpl2)*(1.0d0-a33))*(e11-anpl2) + . -(a13+anpl)*(a31+anpl)*(e22-anpl2) + cc0=e330*((e11-anpl2)*(e22-anpl2)+e12*e12) +c + rr=cc2*cc2-4.0d0*cc0*cc4 +c + if(yg.gt.1.0d0) then + s=sox + if(dimag(rr).LE.0.0d0) s=-s + else + s=-sox + if(dble(rr).le.0.d0.and.dimag(rr).ge.0.d0) s=-s + end if +c + anpr2=(-cc2+s*sqrt(rr))/(2.0d0*cc4) +c + if(dble(anpr2).lt.0.0d0.and.dimag(anpr2).lt.0.0d0) then + anpr2=0.0d0 + print*,' Y =',yg,' nperp2 < 0' +c ierr=99 + go to 999 + end if +c + errnpr=abs(1.0d0-abs(anpr2)/abs(anpr2a)) + anpr2a=anpr2 + end do +c + 999 continue + if(i.gt.imx) print*,' i>imx ',yg,errnpr,i +c + anpr=sqrt(anpr2) + anprr=dble(anpr) + anpri=dimag(anpr) +99 format(20(1x,e12.5)) +c + ex=dcmplx(0.0d0,0.0d0) + ey=dcmplx(0.0d0,0.0d0) + ez=dcmplx(0.0d0,0.0d0) +c + if (abs(anpl).gt.1.0d-6) then + den=e12*e23-(e13+anpr*anpl)*(e22-anpr2-anpl2) + ey=-(e12*(e13+anpr*anpl)+(e11-anpl2)*e23)/den + ez=(e12*e12+(e22-anpr2-anpl2)*(e11-anpl2))/den + ez2=abs(ez)**2 + ey2=abs(ey)**2 + enx2=1.0d0/(1.0d0+ey2+ez2) + ex=dcmplx(sqrt(enx2),0.0d0) + ez2=ez2*enx2 + ey2=ey2*enx2 + ez=ez*ex + ey=ey*ex + else + if(sox.lt.0.0d0) then + ez=dcmplx(1.0d0,0.0d0) + ez2=abs(ez)**2 + else + ex2=1.0d0/(1.0d0+abs(-e11/e12)**2) + ex=sqrt(ex2) + ey=-ex*e11/e12 + ey2=abs(ey)**2 + ez2=0.0d0 + end if + end if +c + return + end +c +c Fully relativistic case +c computation of dielectric tensor elements +c up to third order in Larmor radius for hermitian part +c + subroutine diel_tens_fr(e330,epsl,lrm) + implicit real*8(a-h,o-z) + complex*16 ui + complex*16 e330,epsl(3,3,lrm) + complex*16 ca11,ca12,ca22,ca13,ca23,ca33 + complex*16 cq0p,cq0m,cq1p,cq1m,cq2p + parameter(pi=3.14159265358979d0,rpi=1.77245385090552d0) + parameter(ui=(0.0d0,1.0d0)) + dimension rr(-lrm:lrm,0:2,0:lrm),ri(lrm,0:2,lrm) +c + common/xgxg/xg + common/ygyg/yg + common/amut/amu + common/nplr/anpl,anpr + common/resah/anpl2,dnl +c + common/cri/cr,ci +c + anpl2=anpl**2 + dnl=1.0d0-anpl2 +c + cmxw=1.0d0+15.0d0/(8.0d0*amu)+105.0d0/(128.0d0*amu**2) + cr=-amu*amu/(rpi*cmxw) + ci=sqrt(2.0d0*pi*amu)*amu**2/cmxw +c + do l=1,lrm + do j=1,3 + do i=1,3 + epsl(i,j,l)=dcmplx(0.0d0,0.0d0) + end do + end do + end do +c + call hermitian(rr,lrm) +c + call antihermitian(ri,lrm) +c + do l=1,lrm + lm=l-1 + fal=-0.25d0**l*fact(2*l)/(fact(l)**2*yg**(2*lm)) + ca11=(0.0d0,0.0d0) + ca12=(0.0d0,0.0d0) + ca13=(0.0d0,0.0d0) + ca22=(0.0d0,0.0d0) + ca23=(0.0d0,0.0d0) + ca33=(0.0d0,0.0d0) + do is=0,l + k=l-is + w=(-1.0d0)**k +c + asl=w/(fact(is+l)*fact(l-is)) + bsl=asl*(is*is+dble(2*k*lm*(l+is))/(2.0d0*l-1.0d0)) +c + if(is.gt.0) then + cq0p=rr(is,0,l)+rr(-is,0,l)+ui*ri(is,0,l) + cq0m=rr(is,0,l)-rr(-is,0,l)+ui*ri(is,0,l) + cq1p=rr(is,1,l)+rr(-is,1,l)+ui*ri(is,1,l) + cq1m=rr(is,1,l)-rr(-is,1,l)+ui*ri(is,1,l) + cq2p=rr(is,2,l)+rr(-is,2,l)+ui*ri(is,2,l) + else + cq0p=rr(is,0,l) + cq0m=rr(is,0,l) + cq1p=rr(is,1,l) + cq1m=rr(is,1,l) + cq2p=rr(is,2,l) + end if +c + ca11=ca11+is**2*asl*cq0p + ca12=ca12+is*l*asl*cq0m + ca22=ca22+bsl*cq0p + ca13=ca13+is*asl*cq1m/yg + ca23=ca23+l*asl*cq1p/yg + ca33=ca33+asl*cq2p/yg**2 + end do + epsl(1,1,l) = - xg*ca11*fal + epsl(1,2,l) = + ui*xg*ca12*fal + epsl(2,2,l) = - xg*ca22*fal + epsl(1,3,l) = - xg*ca13*fal + epsl(2,3,l) = - ui*xg*ca23*fal + epsl(3,3,l) = - xg*ca33*fal + end do +c + cq2p=rr(0,2,0) + e330=1.0d0+xg*cq2p +c + epsl(1,1,1) = 1.d0 + epsl(1,1,1) + epsl(2,2,1) = 1.d0 + epsl(2,2,1) +c + do l=1,lrm + epsl(2,1,l) = - epsl(1,2,l) + epsl(3,1,l) = epsl(1,3,l) + epsl(3,2,l) = - epsl(2,3,l) + end do +c + return + end +c +c +c + subroutine hermitian(rr,lrm) + implicit real*8(a-h,o-z) + parameter(tmax=5,npts=500) + dimension rr(-lrm:lrm,0:2,0:lrm) + real*8 ttv(npts+1),extv(npts+1) +c + common/ttex/ttv,extv +c + common/ygyg/yg + common/amut/amu + common/nplr/anpl,anpr + common/warm/iwarm,ilarm + common/cri/cr,ci +c + do n=-lrm,lrm + do k=0,2 + do m=0,lrm + rr(n,k,m)=0.0d0 + end do + end do + end do +c + llm=min(3,lrm) +c + dt=2.0d0*tmax/dble(npts) + bth2=2.0d0/amu + bth=sqrt(bth2) + amu2=amu*amu + amu4=amu2*amu2 + amu6=amu4*amu2 +c + do i = 1, npts+1 + t = ttv(i) + rxt=sqrt(1.0d0+t*t/(2.0d0*amu)) + x = t*rxt + upl2=bth2*x**2 + upl=bth*x + gx=1.0d0+t*t/amu + exdx=cr*extv(i)*gx/rxt*dt +c + n1=1 + if(iwarm.gt.2) n1=-llm +c + do n=n1,llm + nn=abs(n) + gr=anpl*upl+n*yg + zm=-amu*(gx-gr) + s=amu*(gx+gr) + zm2=zm*zm + zm3=zm2*zm + call calcei3(zm,fe0m) +c + do m=nn,llm + if(n.eq.0.and.m.eq.0) then + rr(0,2,0) = rr(0,2,0) - exdx*fe0m*upl2 + else + if(m.eq.1) ffe=(1.0d0+s*(1.0d0-zm*fe0m))/amu2 + if(m.eq.2) ffe=(6.0d0-2.0d0*zm+4.0d0*s + . +s*s*(1.0d0+zm-zm2*fe0m))/amu4 + if(m.eq.3) ffe=(18.0d0*s*(s+4.0d0-zm)+6.0d0* + . (20.0d0-8.0d0*zm+zm2)+s**3*(2.0d0+zm+zm2-zm3*fe0m))/amu6 +c + rr(n,0,m) = rr(n,0,m) + exdx*ffe + rr(n,1,m) = rr(n,1,m) + exdx*ffe*upl + rr(n,2,m) = rr(n,2,m) + exdx*ffe*upl2 + end if +c + end do + end do + end do +c + if(iwarm.gt.2) return +c + sy1=1.0d0+yg + sy2=1.0d0+yg*2.0d0 + sy3=1.0d0+yg*3.0d0 +c + bth4=bth2*bth2 + bth6=bth4*bth2 +c + anpl2=anpl*anpl +c + rr(0,2,0) = -(1.0d0+bth2*(-1.25d0+1.5d0*anpl2) + . +bth4*(1.71875d0-6.0d0*anpl2+3.75d0*anpl2*anpl2)) + rr(0,1,1) = -anpl*bth2*(1.0d0+bth2*(-2.25d0+1.5d0*anpl2)) + rr(0,2,1) = -bth2*(1.0d0+bth2*(-0.5d0+1.5d0*anpl2)) + rr(-1,0,1) = -2.0d0/sy1*(1.0d0+bth2/sy1*(-1.25d0+0.5d0*anpl2 + . /sy1)+bth4/sy1*(-0.46875d0+(2.1875d0+0.625d0*anpl2)/ + . sy1-2.625d0*anpl2/sy1**2+0.75d0*anpl2*anpl2/sy1**3)) + rr(-1,1,1) = -anpl*bth2/sy1**2*(1.0d0+bth2*(1.25d0-3.5d0/sy1+ + . 1.5d0*anpl2/sy1**2)) + rr(-1,2,1) = -bth2/sy1*(1.0d0+bth2*(1.25d0-1.75d0/sy1+1.5d0* + . anpl2/sy1**2)) +c + if(llm.gt.1) then +c + rr(0,0,2) = -4.0d0*bth2*(1.0d0+bth2*(-0.5d0+0.5d0*anpl2)+ + . bth4*(1.125d0-1.875d0*anpl2+0.75d0*anpl2*anpl2)) + rr(0,1,2) = -2.0d0*anpl*bth4*(1.0d0+bth2*(-1.5d0+1.5d0*anpl2)) + rr(0,2,2) = -2.0d0*bth4*(1.0d0+bth2*(0.75d0+1.5d0*anpl2)) + rr(-1,0,2) = -4.0d0*bth2/sy1*(1.0d0+bth2* + . (1.25d0-1.75d0/sy1+0.5d0*anpl2/sy1**2)+bth4* + . (0.46875d0-3.28125d0/sy1+(3.9375d0+1.5d0*anpl2)/sy1**2 + . -3.375d0*anpl2/sy1**3+0.75d0*anpl2*anpl2/sy1**4)) + rr(-1,1,2) = -2.0d0*bth4*anpl/sy1**2*(1.0d0+bth2* + . (3.0d0-4.5d0/sy1+1.5d0*anpl2/sy1**2)) + rr(-1,2,2) = -2.0d0*bth4/sy1*(1.0d0+bth2* + . (3.0d0-2.25d0/sy1+1.5d0*anpl2/sy1**2)) + rr(-2,0,2) = -4.0d0*bth2/sy2*(1.0d0+bth2* + . (1.25d0-1.75d0/sy2+0.5d0*anpl2/sy2**2)+bth4* + . (0.46875d0-3.28125d0/sy2+(3.9375d0+1.5d0*anpl2)/sy2**2 + . -3.375d0*anpl2/sy2**3+0.75d0*anpl2*anpl2/sy2**4)) + rr(-2,1,2) =-2.0d0*bth4*anpl/sy2**2*(1.0d0+bth2* + . (3.0d0-4.5d0/sy2+1.5d0*anpl2/sy2**2)) + rr(-2,2,2) = -2.0d0*bth4/sy2*(1.0d0+bth2* + . (3.0d0-2.25d0/sy2+1.5d0*anpl2/sy2**2)) +c + if(llm.gt.2) then +c + rr(0,0,3) = -12.0d0*bth4*(1+bth2*(0.75d0+0.5d0*anpl2)+bth4* + . (1.21875d0-1.5d0*anpl2+0.75d0*anpl2*anpl2)) + rr(0,1,3) = -6.0d0*anpl*bth6*(1+bth2*(-0.25d0+1.5d0*anpl2)) + rr(0,2,3) = -6.0d0*bth6*(1+bth2*(2.5d0+1.5d0*anpl2)) + rr(-1,0,3) = -12.0d0*bth4/sy1* + . (1.0d0+bth2*(3.0d0-2.25d0/sy1+0.5d0*anpl2/sy1**2)+ + . bth4*(3.75d0-8.71875d0/sy1+(6.1875d0+2.625d0*anpl2) + . /sy1**2-4.125d0*anpl2/sy1**3+0.75d0*anpl2*anpl2/sy1**4)) + rr(-1,1,3) = -6.0d0*anpl*bth6/sy1**2* + . (1.0d0+bth2*(5.25d0-5.5d0/sy1+1.5d0*anpl2/sy1**2)) + rr(-1,2,3) = -6.0d0*bth6/sy1* + . (1.0d0+bth2*(5.25d0-2.75d0/sy1+1.5d0*anpl2/sy1**2)) +c + rr(-2,0,3) = -12.0d0*bth4/sy2* + . (1.0d0+bth2*(3.0d0-2.25d0/sy2+0.5d0*anpl2/sy2**2)+ + . bth4*(3.75d0-8.71875d0/sy2+(6.1875d0+2.625d0*anpl2) + . /sy2**2-4.125d0*anpl2/sy2**3+0.75d0*anpl2*anpl2/sy2**4)) + rr(-2,1,3) = -6.0d0*anpl*bth6/sy2**2* + . (1.0d0+bth2*(5.25d0-5.5d0/sy2+1.5d0*anpl2/sy2**2)) + rr(-2,2,3) = -6.0d0*bth6/sy2* + . (1.0d0+bth2*(5.25d0-2.75d0/sy2+1.5d0*anpl2/sy2**2)) +c + rr(-3,0,3) = -12.0d0*bth4/sy3* + . (1.0d0+bth2*(3.0d0-2.25d0/sy3+0.5d0*anpl2/sy3**2)+ + . bth4*(3.75d0-8.71875d0/sy3+(6.1875d0+2.625d0*anpl2) + . /sy3**2-4.125d0*anpl2/sy3**3+0.75d0*anpl2*anpl2/sy3**4)) + rr(-3,1,3) = -6.0d0*anpl*bth6/sy3**2* + . (1.0d0+bth2*(5.25d0-5.5d0/sy3+1.5d0*anpl2/sy3**2)) + rr(-3,2,3) = -6.0d0*bth6/sy3* + . (1.0d0+bth2*(5.25d0-2.75d0/sy3+1.5d0*anpl2/sy3**2)) +c + end if + end if +c + return + end +c +c +c + subroutine antihermitian(ri,lrm) + implicit none + integer lmx,nmx,lrm,n,k,m,mm + real*8 rpi + parameter(rpi=1.77245385090552d0) + parameter(lmx=20,nmx=lmx+2) + real*8 fsbi(nmx) + real*8 ri(lrm,0:2,lrm) + real*8 yg,amu,anpl,cmu,anpl2,dnl,cr,ci,ygn,rdu2,rdu,anpr + real*8 du,ub,aa,up,um,gp,gm,xp,xm,eep,eem,ee,cm,cim + real*8 fi0p0,fi1p0,fi2p0,fi0m0,fi1m0,fi2m0 + real*8 fi0p1,fi1p1,fi2p1,fi0m1,fi1m1,fi2m1,fi0m,fi1m,fi2m + real*8 fact +c + common/ygyg/yg + common/amut/amu + common/nplr/anpl,anpr + common/uu/ub,cmu + common/resah/anpl2,dnl +c + common/cri/cr,ci +c + do n=1,lrm + do k=0,2 + do m=1,lrm + ri(n,k,m)=0.0d0 + end do + end do + end do +c + dnl=1.0d0-anpl2 + cmu=anpl*amu +c + do n=1,lrm + ygn=n*yg + rdu2=ygn**2-dnl + if(rdu2.gt.0.0d0) then + rdu=sqrt(rdu2) + du=rdu/dnl + ub=anpl*ygn/dnl + aa=amu*anpl*du + if (abs(aa).gt.5.0d0) then + up=ub+du + um=ub-du + gp=anpl*up+ygn + gm=anpl*um+ygn + xp=up+1.0d0/cmu + xm=um+1.0d0/cmu + eem=exp(-amu*(gm-1.0d0)) + eep=exp(-amu*(gp-1.0d0)) + fi0p0=-1.0d0/cmu + fi1p0=-xp/cmu + fi2p0=-(1.0d0/cmu**2+xp*xp)/cmu + fi0m0=-1.0d0/cmu + fi1m0=-xm/cmu + fi2m0=-(1.0d0/cmu**2+xm*xm)/cmu + do m=1,lrm + fi0p1=-2.0d0*m*(fi1p0-ub*fi0p0)/cmu + fi0m1=-2.0d0*m*(fi1m0-ub*fi0m0)/cmu + fi1p1=-((1.0d0+2.0d0*m)*fi2p0-2.0d0*(m+1.0d0)*ub*fi1p0 + . +up*um*fi0p0)/cmu + fi1m1=-((1.0d0+2.0d0*m)*fi2m0-2.0d0*(m+1.0d0)*ub*fi1m0 + . +up*um*fi0m0)/cmu + fi2p1=(2.0d0*(1.0d0+m)*fi1p1-2.0d0*m* + . (ub*fi2p0-up*um*fi1p0))/cmu + fi2m1=(2.0d0*(1.0d0+m)*fi1m1-2.0d0*m* + . (ub*fi2m0-up*um*fi1m0))/cmu + if(m.ge.n) then + ri(n,0,m)=0.5d0*ci*dnl**m*(fi0p1*eep-fi0m1*eem) + ri(n,1,m)=0.5d0*ci*dnl**m*(fi1p1*eep-fi1m1*eem) + ri(n,2,m)=0.5d0*ci*dnl**m*(fi2p1*eep-fi2m1*eem) + end if + fi0p0=fi0p1 + fi1p0=fi1p1 + fi2p0=fi2p1 + fi0m0=fi0m1 + fi1m0=fi1m1 + fi2m0=fi2m1 + end do + else + ee=exp(-amu*(ygn-1.0d0+anpl*ub)) + call ssbi(aa,n,lrm,fsbi) + do m=n,lrm + cm=rpi*fact(m)*du**(2*m+1) + cim=0.5d0*ci*dnl**m + mm=m-n+1 + fi0m=cm*fsbi(mm) + fi1m=-0.5d0*aa*cm*fsbi(mm+1) + fi2m=0.5d0*cm*(fsbi(mm+1)+0.5d0*aa*aa*fsbi(mm+2)) + ri(n,0,m)=cim*ee*fi0m + ri(n,1,m)=cim*ee*(du*fi1m+ub*fi0m) + ri(n,2,m)=cim*ee*(du*du*fi2m+2.0d0*du*ub*fi1m+ub*ub*fi0m) + end do + end if + end if + end do +c + return + end +c + subroutine ssbi(zz,n,l,fsbi) + implicit none + integer n,l,nmx,lmx,k,m,mm + real*8 eps,c0,c1,sbi,zz + real*8 gamm + parameter(eps=1.0d-10,lmx=20,nmx=lmx+2) + real*8 fsbi(nmx) + do m=n,l+2 + c0=1.0d0/gamm(dble(m)+1.5d0) + sbi=c0 + do k=1,50 + c1=c0*0.25d0*zz**2/(dble(m+k)+0.5d0)/dble(k) + sbi=sbi+c1 + if(c1/sbi.lt.eps) exit + c0=c1 + end do + mm=m-n+1 + fsbi(mm)=sbi + end do + return + end +c +c Weakly relativistic dielectric tensor +c computation of dielectric tensor elements +c Krivenki and Orefice, JPP 30,125 (1983) +c + subroutine diel_tens_wr(ce330,cepsl,lrm) + implicit real*8 (a-b,d-h,o-z) + implicit complex*16 (c) + dimension cefp(0:lrm,0:2),cefm(0:lrm,0:2),cepsl(3,3,lrm) + parameter(cui=(0.0d0,1.0d0)) +c + common/xgxg/xg + common/ygyg/yg + common/nplr/anpl,anprf + common/amut/amu +c + anpl2=anpl*anpl +c + call fsup(cefp,cefm,lrm) +c + do l=1,lrm + lm=l-1 + fcl=0.5d0**l*((1.0d0/yg)**2/amu)**lm*fact(2*l)/fact(l) + ca11=(0.d0,0.d0) + ca12=(0.d0,0.d0) + ca13=(0.d0,0.d0) + ca22=(0.d0,0.d0) + ca23=(0.d0,0.d0) + ca33=(0.d0,0.d0) + do is=0,l + k=l-is + w=(-1.0d0)**k +c + asl=w/(fact(is+l)*fact(l-is)) + bsl=asl*(is*is+dble(2*k*lm*(l+is))/(2.0d0*l-1.0d0)) +c + cq0p=amu*cefp(is,0) + cq0m=amu*cefm(is,0) + cq1p=amu*anpl*(cefp(is,0)-cefp(is,1)) + cq1m=amu*anpl*(cefm(is,0)-cefm(is,1)) + cq2p=cefp(is,1)+amu*anpl2*(cefp(is,2) + . +cefp(is,0)-2.0d0*cefp(is,1)) +c + ca11=ca11+is**2*asl*cq0p + ca12=ca12+is*l*asl*cq0m + ca22=ca22+bsl*cq0p + ca13=ca13+is*asl*cq1m/yg + ca23=ca23+l*asl*cq1p/yg + ca33=ca33+asl*cq2p/yg**2 + end do + cepsl(1,1,l) = - xg*ca11*fcl + cepsl(1,2,l) = + cui*xg*ca12*fcl + cepsl(2,2,l) = - xg*ca22*fcl + cepsl(1,3,l) = - xg*ca13*fcl + cepsl(2,3,l) = - cui*xg*ca23*fcl + cepsl(3,3,l) = - xg*ca33*fcl + end do +c + cq2p=cefp(0,1)+amu*anpl2*(cefp(0,2)+cefp(0,0)-2.0d0*cefp(0,1)) + ce330=1.0d0-xg*amu*cq2p +c + cepsl(1,1,1) = 1.d0 + cepsl(1,1,1) + cepsl(2,2,1) = 1.d0 + cepsl(2,2,1) +c + do l=1,lrm + cepsl(2,1,l) = - cepsl(1,2,l) + cepsl(3,1,l) = cepsl(1,3,l) + cepsl(3,2,l) = - cepsl(2,3,l) + end do +c + return + end +c +c +c + subroutine fsup(cefp,cefm,lrm) + implicit real*8 (a-b,d-h,o-z) + implicit complex*16 (c) + parameter(apsicr=0.7d0) + parameter(cui=(0.0d0,1.0d0)) + dimension cefp(0:lrm,0:2),cefm(0:lrm,0:2) +c + common/ygyg/yg + common/nplr/anpl,anprf + common/amut/amu +c + psi=sqrt(0.5d0*amu)*anpl + apsi=abs(psi) +c + do is=0,lrm + alpha=anpl*anpl/2.0d0+is*yg-1.0d0 + phi2=amu*alpha + phim=sqrt(abs(phi2)) + if (alpha.ge.0) then + xp=psi-phim + yp=0.0d0 + xm=-psi-phim + ym=0.0d0 + x0=-phim + y0=0.0d0 + else + xp=psi + yp=phim + xm=-psi + ym=phim + x0=0.0d0 + y0=phim + end if + call zetac (xp,yp,zrp,zip,iflag) + call zetac (xm,ym,zrm,zim,iflag) +c + czp=dcmplx(zrp,zip) + czm=dcmplx(zrm,zim) + cf12=(0.0d0,0.0d0) + if (alpha.ge.0) then + if (alpha.ne.0) cf12=-(czp+czm)/(2.0d0*phim) + else + cf12=-cui*(czp+czm)/(2.0d0*phim) + end if +c + if(apsi.gt.apsicr) then + cf32=-(czp-czm)/(2.0d0*psi) + else + cphi=phim + if(alpha.lt.0) cphi=-cui*phim + call zetac (x0,y0,zr0,zi0,iflag) + cz0=dcmplx(zr0,zi0) + cdz0=2.0d0*(1.0d0-cphi*cz0) + cf32=cdz0 + end if +c + cf0=cf12 + cf1=cf32 + cefp(is,0)=cf32 + cefm(is,0)=cf32 + do l=1,is+2 + iq=l-1 + if(apsi.gt.apsicr) then + cf2=(1.0d0+phi2*cf0-(iq+0.5d0)*cf1)/psi**2 + else + cf2=(1.0d0+phi2*cf1)/dble(iq+1.5d0) + end if + ir=l-is + if(ir.ge.0) then + cefp(is,ir)=cf2 + cefm(is,ir)=cf2 + end if + cf0=cf1 + cf1=cf2 + end do +c + if(is.ne.0) then +c + alpha=anpl*anpl/2.0d0-is*yg-1.0d0 + phi2=amu*alpha + phim=sqrt(abs(phi2)) + if (alpha.ge.0.0d0) then + xp=psi-phim + yp=0.0d0 + xm=-psi-phim + ym=0.0d0 + x0=-phim + y0=0.0d0 + else + xp=psi + yp=phim + xm=-psi + ym=phim + x0=0.0d0 + y0=phim + end if + call zetac (xp,yp,zrp,zip,iflag) + call zetac (xm,ym,zrm,zim,iflag) +c + czp=dcmplx(zrp,zip) + czm=dcmplx(zrm,zim) +c + cf12=(0.0d0,0.0d0) + if (alpha.ge.0) then + if (alpha.ne.0.0d0) cf12=-(czp+czm)/(2.0d0*phim) + else + cf12=-cui*(czp+czm)/(2.0d0*phim) + end if + if(apsi.gt.apsicr) then + cf32=-(czp-czm)/(2.0d0*psi) + else + cphi=phim + if(alpha.lt.0) cphi=-cui*phim + call zetac (x0,y0,zr0,zi0,iflag) + cz0=dcmplx(zr0,zi0) + cdz0=2.0d0*(1.0d0-cphi*cz0) + cf32=cdz0 + end if +c + cf0=cf12 + cf1=cf32 + do l=1,is+2 + iq=l-1 + if(apsi.gt.apsicr) then + cf2=(1.0d0+phi2*cf0-(iq+0.5d0)*cf1)/psi**2 + else + cf2=(1.0d0+phi2*cf1)/dble(iq+1.5d0) + end if + ir=l-is + if(ir.ge.0) then + cefp(is,ir)=cefp(is,ir)+cf2 + cefm(is,ir)=cefm(is,ir)-cf2 + end if + cf0=cf1 + cf1=cf2 + end do +c + end if +c + end do +c + return + end + + + + subroutine eccd(effjcd) + use green_func_p + implicit none + real*8 anum,denom,resp,resj,effjcd,coullog,dens,tekev + real*8 anucc,canucc,ddens + real*8 qesi,mesi,vcsi,qe,me,vc,ceff,Zeff + real*8 rbn,rbx,btot,bmin,bmax,alams,fp0s,pa,fc + real*8 fjch,fjncl,fjch0,fconic + real*8 cst,cst2 + integer ieccd,nharm,nhf,nhn + external fjch,fjncl,fjch0 + + parameter(qesi=1.602176487d-19,mesi=9.10938215d-31) + parameter(vcsi=2.99792458d+8) + parameter(qe=4.8032068d-10,me=mesi*1.d3,vc=vcsi*1.d2) + parameter(canucc=4.0d13*pi*qe**4/(me**2*vc**3)) + parameter(ceff=qesi/(mesi*vcsi)) + + common/nharm/nharm,nhf + common/nhn/nhn + + common/ieccd/ieccd + common/tete/tekev + common/dens/dens,ddens + common/zz/Zeff + common/btot/btot + common/bmxmn/bmax,bmin + common/fc/fc + common/ncl/rbx + common/cohen/rbn,alams,pa,fp0s + common/cst/cst,cst2 + + anum=0.0d0 + denom=0.0d0 + effjcd=0.0d0 + + coullog=24.0d0-log(1.0d4*sqrt(0.1d0*dens)/tekev) + anucc=canucc*dens*coullog + +c nhf=nharm + + select case(ieccd) + + case(1) +c cohen model +c rbn=B/B_min +c rbx=B/B_max +c cst2=1.0d0-B/B_max +c alams=sqrt(1-B_min/B_max) +c Zeff < 31 !!! +c fp0s= P_a (alams) + rbn=btot/bmin + rbx=btot/bmax + cst2=1.0d0-rbx + if(cst2.lt.1d-6) cst2=0.0d0 + cst=sqrt(cst2) + alams=sqrt(1.0d0-bmin/bmax) + pa=sqrt(32.0d0/(Zeff+1.0d0)-1.0d0)/2.0d0 + fp0s=fconic(alams,pa,0) + do nhn=nharm,nhf + call curr_int(fjch,resj,resp) + anum=anum+resj + denom=denom+resp + end do + + case(2:9) + cst=0.0d0 + cst2=0.0d0 + do nhn=nharm,nhf + call curr_int(fjch0,resj,resp) + anum=anum+resj + denom=denom+resp + end do + + case(10:11) +c neoclassical model: +c ft=1-fc trapped particle fraction +c rzfc=(1+Zeff)/fc + rbn=btot/bmin + rbx=btot/bmax + cst2=1.0d0-rbx + if(cst2.lt.1d-6) cst2=0.0d0 + cst=sqrt(cst2) + call SpitzFuncCoeff(Tekev,Zeff,fc) + do nhn=nharm,nhf + call curr_int(fjncl,resj,resp) + anum=anum+resj + denom=denom+resp + end do + nhn=nhn-1 + + CASE DEFAULT + print*,'ieccd undefined' + + end select +c +c effjpl = / /(B_min/) [A m /W] +c + if(denom.gt.0.0d0) effjcd=-ceff*anum/(anucc*denom) + return + end +c +c +c + subroutine curr_int(fcur,resj,resp) + implicit real*8(a-h,o-z) + parameter(epsa=0.0d0,epsr=1.0d-2) + parameter(xxcr=16.0d0) + parameter (lw=5000,liw=lw/4) + dimension w(lw),iw(liw) + external fcur,fpp + + common/nhn/nhn + common/ygyg/yg + common/nplr/anpl,anpr + common/amut/amu + common/gg/uplp,uplm,ygn + common/ierr/ierr + common/iokh/iokhawa + common/cst/cst,cst2 + +c EC power and current densities + + anpl2=anpl*anpl + dnl=1.0d0-anpl2 + ygn=nhn*yg + ygn2=ygn*ygn + + resj=0.0d0 + resj1=0.0d0 + resj2=0.0d0 + resp=0.0d0 +c + rdu2=anpl2+ygn2-1.0d0 + uplp=0.0d0 + uplm=0.0d0 + upltp=0.0d0 + upltm=0.0d0 +c + if (rdu2.ge.0.0d0) then + rdu=sqrt(rdu2) + uplp=(anpl*ygn+rdu)/dnl + uplm=(anpl*ygn-rdu)/dnl +c + uu1=uplm + uu2=uplp + xx1=amu*(anpl*uu1+ygn-1.0d0) + xx2=amu*(anpl*uu2+ygn-1.0d0) +c + if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl + if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl + duu=abs(uu1-uu2) +c + if(duu.gt.1.d-6) then + call dqags(fpp,uu1,uu2,epsa,epsr,resp,epp,neval,ier, + . liw,lw,last,iw,w) + if (ier.gt.0) ierr=90 + end if +c + rdu2t=cst2*anpl2+ygn2-1.0d0 +c + if (rdu2t.lt.0.0d0.or.cst2.eq.0.0d0) then +c +c resonance curve does not cross the trapping region +c + iokhawa=0 + if(duu.gt.1.d-4) then + call dqags(fcur,uu1,uu2,epsa,epsr, + . resj,ej,neval,ier,liw,lw,last,iw,w) + if (ier.gt.0) ierr=91 + end if + else +c +c resonance curve crosses the trapping region +c + iokhawa=1 + rdut=sqrt(rdu2t) + upltm=(cst2*anpl*ygn-cst*rdut)/(1.0d0-cst2*anpl2) + upltp=(cst2*anpl*ygn+cst*rdut)/(1.0d0-cst2*anpl2) +c + uu1=uplm + uu2=upltm + xx1=amu*(anpl*uu1+ygn-1.0d0) + xx2=amu*(anpl*uu2+ygn-1.0d0) + if(xx1.lt.xxcr.or.xx2.lt.xxcr) then + if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl + if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl + duu=abs(uu1-uu2) + if(duu.gt.1.d-6) then + call dqags(fcur,uu1,uu2,epsa,epsr, + . resj1,ej1,neval,ier,liw,lw,last,iw,w) + if (ier.gt.0) then + if (abs(resj1).lt.1.0d-10) then + resj1=0.0d0 + else + ierr=92 + end if + end if + end if + end if +c + uu1=upltp + uu2=uplp + xx1=amu*(anpl*uu1+ygn-1.0d0) + xx2=amu*(anpl*uu2+ygn-1.0d0) + if(xx1.lt.xxcr.or.xx2.lt.xxcr) then + if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0d0)/anpl + if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0d0)/anpl + duu=abs(uu1-uu2) + if(duu.gt.1.d-6) then + call dqags(fcur,uu1,uu2,epsa,epsr, + . resj2,ej2,neval,ier,liw,lw,last,iw,w) + if (ier.gt.0) then + if(ier.ne.2) ierr=93 + end if + end if + end if + resj=resj1+resj2 + end if + end if + + return + end +c +c computation of integral for power density, integrand function fpp +c +c ith=0 : polarization term = const +c ith=1 : polarization term Larmor radius expansion to lowest order +c ith=2 : full polarization term (J Bessel) +c + function fpp(upl) + implicit real*8 (a-h,o-z) + complex*16 ex,ey,ez,ui,emxy,epxy + parameter(ui=(0.0d0,1.0d0)) + + common/ygyg/yg + common/nplr/anpl,anpr + common/amut/amu + common/gg/uplp,uplm,ygn + common/epolar/ex,ey,ez + common/nprw/anprre,anprim + common/ithn/ithn + common/nhn/nhn + + upr2=(1.0d0-anpl**2)*(uplp-upl)*(upl-uplm) + gam=anpl*upl+ygn + ee=exp(-amu*(gam-1)) + + thn2=1.0d0 + thn2u=upr2*thn2 + if(ithn.gt.0) then + emxy=ex-ui*ey + epxy=ex+ui*ey + if(upr2.gt.0.0d0) then + upr=sqrt(upr2) + bb=anprre*upr/yg + if(ithn.eq.1) then +c Larmor radius expansion polarization term at lowest order + cth=1.0d0 + if(nhn.gt.1) cth=(0.5d0*bb)**(nhn-1)*nhn/fact(nhn) + thn2=(0.5d0*cth*abs(emxy+ez*anprre*upl/ygn))**2 + thn2u=upr2*thn2 + else +c Full polarization term + nm=nhn-1 + np=nhn+1 + ajbnm=dbesjn(nm, bb) + ajbnp=dbesjn(np, bb) + ajbn=dbesjn(nhn, bb) + thn2u=(abs(ez*ajbn*upl+upr*(ajbnp*epxy+ajbnm*emxy)/2.0d0))**2 + end if + end if + end if + + fpp=ee*thn2u + return + end + +c computation of integral for current density +c fjch integrand for Cohen model with trapping +c fjch0 integrand for Cohen model without trapping +c fjncl integrand for momentum conserv. model K(u) from Maruschenko +c gg=F(u)/u with F(u) as in Cohen paper + + function fjch(upl) + implicit real*8 (a-h,o-z) + + common/gg/uplp,uplm,ygn + common/nplr/anpl,anpr + common/zz/Zeff + common/cohen/rb,alams,pa,fp0s + + upr2=(1.0d0-anpl**2)*(uplp-upl)*(upl-uplm) + gam=anpl*upl+ygn + u2=gam*gam-1.0d0 + u=sqrt(u2) + z5=Zeff+5.0d0 + xi=1.0d0/z5**2 + xib=1.0d0-xi + xibi=1.0d0/xib + fu2b=1.0d0+xib*u2 + fu2=1.0d0+xi*u2 + gu=(1.0d0-1.0d0/fu2b**xibi)/sqrt(fu2) + gg=u*gu/z5 + dgg=(gu+u2*(2.0d0/fu2b**(1.0d0+xibi)/sqrt(fu2)-xi*gu/fu2))/z5 + + alam=sqrt(1.0d0-upr2/u2/rb) + fp0=fconic(alam,pa,0) + dfp0=-(pa*pa/2.0d0+0.125d0) + if (alam.lt.1.0d0) then + dfp0=-fconic(alam,pa,1)/sqrt(1.0d0-alam**2) + end if + fh=alam*(1.0d0-alams*fp0/(alam*fp0s)) + dfhl=1.0d0-alams*dfp0/fp0s + + eta=gam*fh*(gg/u+dgg)+upl*(anpl*u2-upl*gam)*gg*dfhl/(u2*u*rb*alam) + + if(upl.lt.0.0d0) eta=-eta + fjch=eta*fpp(upl) + return + end + + + + function fjch0(upl) + implicit real*8 (a-h,o-z) + common/gg/uplp,uplm,ygn + common/nplr/anpl,anpr + common/zz/Zeff + gam=anpl*upl+ygn + u2=gam*gam-1.0d0 + u=sqrt(u2) + z5=Zeff+5.0d0 + xi=1.0d0/z5**2 + xib=1.0d0-xi + xibi=1.0d0/xib + fu2b=1.0d0+xib*u2 + fu2=1.0d0+xi*u2 + gu=(1.0d0-1.0d0/fu2b**xibi)/sqrt(fu2) + gg=u*gu/z5 + dgg=(gu+u2*(2.0d0/fu2b**(1.0d0+xibi)/sqrt(fu2)-xi*gu/fu2))/z5 + eta=anpl*gg+gam*upl*dgg/u + fjch0=eta*fpp(upl) + return + end + + + + function fjncl(upl) + use green_func_p + implicit real*8 (a-h,o-z) + + common/gg/uplp,uplm,ygn + common/nplr/anpl,anpr + common/fc/fc + common/ncl/hb + common/psival/psinv + common/amut/amu + common/tete/tekev + common/zz/Zeff + + gam=anpl*upl+ygn + u2=gam*gam-1.0d0 + u=sqrt(u2) + upr2=u2-upl*upl + bth=sqrt(2.0d0/amu) + uth=u/bth + call GenSpitzFunc(Tekev,Zeff,fc,uth,u,gam,fk,dfk) + fk=fk*(4.0d0/amu**2) + dfk=dfk*(2.0d0/amu)*bth + + alam=upr2/u2/hb + psi=psinv + call vlambda(alam,psi,fu,dfu) + + eta=gam*fu*dfk/u-2.0d0*(anpl-gam*upl/u2)*fk*dfu*upl/u2/hb + if(upl.lt.0) eta=-eta + fjncl=eta*fpp(upl) + return + end + + subroutine vlambda(alam,psi,fv,dfv) + implicit real*8 (a-h,o-z) + parameter (nnintp=101,nlam=101) + parameter(ksp=3,njest=nnintp+ksp+1,nlest=nlam+ksp+1) + parameter(lwrk=4*(nnintp+nlam)+11*(njest+nlest)+ + . njest*nnintp+nlest+54) + parameter(kwrk=nnintp+nlam+njest+nlest+3) + parameter(lw01=nnintp*4+nlam*3+nnintp*nlam) + + external fpbisp + + dimension xxs(1),yys(1),ffs(1) + dimension ch01(lw01),ch((njest-4)*(nlest-4)) + dimension tjp(njest),tlm(nlest) + dimension iwrk(kwrk),wrk(lwrk) + + common/coffvl/ch + common/coffdvl/ch01 + common/coffvlt/tjp,tlm + common/coffvln/njpt,nlmt + + njp=njpt + nlm=nlmt + xxs(1)=sqrt(psi) + yys(1)=alam + + call fpbisp(tjp,njp,tlm,nlm,ch,ksp,ksp,xxs,1,yys,1,ffs, + . wrk(1),wrk(5),iwrk(1),iwrk(2)) + fv=ffs(1) + + iwp=1+(njp-4)*(nlm-5) + iwl=iwp+4 + call fpbisp(tjp(1),njp,tlm(2),nlm-2,ch01,3,2, + . xxs,1,yys,1,ffs,ch01(iwp),ch01(iwl),iwrk(1),iwrk(2)) + dfv=ffs(1) + + return + end + + + subroutine projxyzt(iproj,nfile) + implicit real*8 (a-h,o-z) + parameter(jmx=31,kmx=36) + dimension ywrk(6,jmx,kmx),ypwrk(6,jmx,kmx) +c + common/nrayktx/nray,ktx + common/wrk/ywrk,ypwrk + common/psinv11/psinv11 + common/istep/istep + common/ss/st +c + rtimn=1.d+30 + rtimx=-1.d-30 +c + jd=1 + if(iproj.eq.0) jd=nray-1 + do j=1,nray,jd + kktx=ktx + if(j.eq.1) kktx=1 + do k=1,kktx +c + dx=ywrk(1,j,k)-ywrk(1,1,1) + dy=ywrk(2,j,k)-ywrk(2,1,1) + dz=ywrk(3,j,k)-ywrk(3,1,1) +c + dirx=ywrk(4,j,k) + diry=ywrk(5,j,k) + dirz=ywrk(6,j,k) + dir=sqrt(dirx*dirx+diry*diry+dirz*dirz) +c + if(j.eq.1.and.k.eq.1) then + csth1=dirz/dir + snth1=sqrt(1.0d0-csth1**2) + csps1=1.0d0 + snps1=0.0d0 + if(snth1.gt.0.0d0) then + csps1=diry/(dir*snth1) + snps1=dirx/(dir*snth1) + end if + end if + xti= dx*csps1-dy*snps1 + yti=(dx*snps1+dy*csps1)*csth1-dz*snth1 + zti=(dx*snps1+dy*csps1)*snth1+dz*csth1 + rti=sqrt(xti**2+yti**2) +c + dirxt= (dirx*csps1-diry*snps1)/dir + diryt=((dirx*snps1+diry*csps1)*csth1-dirz*snth1)/dir + dirzt=((dirx*snps1+diry*csps1)*snth1+dirz*csth1)/dir +c + if(k.eq.1) then + xti1=xti + yti1=yti + zti1=zti + rti1=rti + end if +c + if(istep.eq.0) + . write(10,111) istep,j,k,xti,yti,zti,dirxt,diryt,dirzt,dir + + if(.not.(iproj.eq.0.and.j.eq.1)) + . write(nfile,111) istep,j,k,xti,yti,zti,rti, + . sqrt(psinv11) +c + if(rti.ge.rtimx.and.j.eq.nray) rtimx=rti + if(rti.le.rtimn.and.j.eq.nray) rtimn=rti +c + end do +c + if(.not.(iproj.eq.0.and.j.eq.1)) + . write(nfile,111) istep,j,k,xti1,yti1,zti1,rti1, + . sqrt(psinv11) + if(iproj.eq.1) write(nfile,*) ' ' + end do +c + write(nfile,*) ' ' +c + write(12,99) istep,st,sqrt(abs(psinv11)),rtimn,rtimx + return + 99 format(i5,12(1x,e16.8e3)) +111 format(3i5,12(1x,e16.8e3)) + end +c +c +c + subroutine pec(pabs,currt) + implicit real*8(a-h,o-z) + parameter(nndmx=5001,jmx=31,kmx=36,nmx=8000) + parameter(rtbc=1.0d0) + parameter(pi=3.14159265358979d0) + dimension psjki(jmx,kmx,nmx),iiv(jmx,kmx) + dimension ppabs(jmx,kmx,nmx),ccci(jmx,kmx,nmx) + dimension pdjki(jmx,kmx,nmx),currj(jmx,kmx,nmx) + dimension xxi(nmx),ypt(nmx),yamp(nmx) + dimension rtab(nndmx),rhotv(nndmx) + dimension rtab1(0:nndmx) + dimension ajphiv(nndmx),dpdv(nndmx) + dimension dvolt(nndmx),darea(nndmx) + dimension ratj1v(nndmx),ratj2v(nndmx) + dimension ajplv(nndmx),ajcdv(nndmx) + dimension pins(nndmx),currins(nndmx),fi(nndmx) + parameter(llmx=21) + dimension isev(llmx) +c + common/nrayktx/nray,ktx + common/istep/istep + common/dsds/dst + common/ipec/ipec,nnd + common/ieccd/ieccd + common/index_rt/index_rt +c + common/iiv/iiv + common/psjki/psjki + common/pcjki/ppabs,ccci + common/dpjjki/pdjki,currj +c + common/cent/btrcen,rcen + common/angles/alfac,betac + common/iieq/iequil + common/parban/b0,rr0m,zr0m,rpam + common/taumnx/taumn,taumx,pabstot,currtot + common/jmxmn/rhot1,rhot2,aj1,aj2 +c + common/polcof/psipol,chipol +c + stf=istep*dst + nd=nnd + + if(pabstot.gt.0.0d0) then + do ll=1,llmx + isev(ll)=0 + end do + + intp=0 + voli0=0.0d0 + areai0=0.0d0 + rtab1(0)=0.0d0 + do it=1,nd + drt=1.0d0/dble(nd-1) + rt=dble(it-1)*drt + if(it.lt.nd) then + rt1=rt+drt/2.0d0 + else + rt1=rt + end if + rtab(it)=rt + rtab1(it)=rt1 + dpdv(it)=0.0d0 + ajphiv(it)=0.0d0 + if (ipec.eq.0) then + psit=rt + psit1=rt1 + else + psit=rt**2 + psit1=rt1**2 + end if + if(iequil.eq.2) then + rhotv(it)=frhotor(psit) + call valpsispl(sqrt(psit1),voli1,dervoli,areai1,rrii, + . rbavi,bmxi,bmni,fci,intp) + dvolt(it)=abs(voli1-voli0) + darea(it)=abs(areai1-areai0) + voli0=voli1 + areai0=areai1 + call ratioj(sqrt(psit),ratj1i,ratj2i) + ratj1v(it)=ratj1i + ratj2v(it)=ratj2i + else + rhotv(it)=sqrt(psit) + area1=pi*psit1*rpam**2 + voli1=2.0d0*pi*rr0m*area1 + dvolt(it)=abs(voli1-voli0) + darea(it)=abs(areai1-areai0) + voli0=voli1 + areai0=areai1 + end if + end do + + kkk=1 + do j=1,nray + if(j.gt.1) kkk=ktx + do k=1,kkk + ise0=0 + ii=iiv(j,k) + if (ii.lt.nmx.and.psjki(j,k,ii+1).ne.0.0d0) ii=ii+1 + idecr=-1 + is=1 + do i=1,ii + if(ipec.eq.0) xxi(i)=abs(psjki(j,k,i)) + if(ipec.eq.1) xxi(i)=sqrt(abs(psjki(j,k,i))) + if(psjki(j,k,i).ge.0.and.psjki(j,k,i).le.rtbc) then + ypt(i)=ppabs(j,k,i) + yamp(i)=ccci(j,k,i) + else + ypt(i)=0.0d0 + yamp(i)=0.0d0 + end if + if(ise0.eq.0) then + if(xxi(i).lt.rtbc) then + ise0=i + isev(is)=i-1 + is=is+1 + end if + else + if (idecr.eq.-1) then + if(xxi(i).gt.xxi(i-1)) then + isev(is)=i-1 + is=is+1 + idecr=1 + end if + else + if(xxi(i).gt.rtbc) exit + if(xxi(i).lt.xxi(i-1)) then + isev(is)=i + is=is+1 + idecr=-1 + end if + end if + end if + end do +c + isev(is)=i-1 + ppa1=0.0d0 + cci1=0.0d0 + do iis=1,is-1 + iis1=iis+1 + iise0=isev(iis) + iise=isev(iis1) + if (mod(iis,2).ne.0) then + idecr=-1 + ind1=nd + ind2=2 + iind=-1 + else + idecr=1 + ind1=1 + ind2=nd + iind=1 + end if + do ind=ind1,ind2,iind + iind=ind + if (idecr.eq.-1) iind=ind-1 + rt1=rtab1(iind) + call locatex(xxi,iise,iise0,iise,rt1,itb1) + if(itb1.gt.iise0.and.itb1.lt.iise) then + call intlin(xxi(itb1),ypt(itb1),xxi(itb1+1), + . ypt(itb1+1),rt1,ppa2) + call intlin(xxi(itb1),yamp(itb1),xxi(itb1+1), + . yamp(itb1+1),rt1,cci2) + dppa=ppa2-ppa1 + dpdv(ind)=dpdv(ind)+dppa + didst=(cci2-cci1) + ajphiv(ind)=ajphiv(ind)+didst + ppa1=ppa2 + cci1=cci2 + end if + end do + end do + end do + end do + + h=1.0d0/dble(nd-1) + rhotpav=0.0d0 + drhotpav=0.0d0 + rhotjav=0.0d0 + rhotjava=0.0d0 + rhot2java=0.0d0 + + fi=dpdv/h + call simpson (nd,h,fi,spds) + fi=rhotv*dpdv/h + call simpson (nd,h,fi,rhotpav) + fi=rhotv*rhotv*dpdv/h + call simpson (nd,h,fi,rhot2pav) + rhotpav=rhotpav/spds + rhot2pav=rhot2pav/spds + + if (ieccd.ne.0) then + fi=ajphiv/h + call simpson (nd,h,fi,sccs) + fi=rhotv*ajphiv/h + call simpson (nd,h,fi,rhotjav) + fi=abs(ajphiv)/h + call simpson (nd,h,fi,sccsa) + fi=rhotv*abs(ajphiv)/h + call simpson (nd,h,fi,rhotjava) + fi=rhotv*rhotv*abs(ajphiv)/h + call simpson (nd,h,fi,rhot2java) + rhotjav=rhotjav/sccs + rhotjava=rhotjava/sccsa + rhot2java=rhot2java/sccsa + end if + +c factor sqrt(8)=2 sqrt(2) to match with full width +c of gaussian profile + drhot2pav=rhot2pav-rhotpav**2 + drhotpav=sqrt(8.d0*drhot2pav) + drhot2java=rhot2java-rhotjava**2 + drhotjava=sqrt(8.d0*drhot2java) + + spds=0.0d0 + sccs=0.0d0 + do i=1,nd + spds=spds+dpdv(i) + sccs=sccs+ajphiv(i) + pins(i)=spds + currins(i)=sccs + dpdv(i)=dpdv(i)/dvolt(i) + ajphiv(i)=ajphiv(i)/darea(i) + end do + + facpds=1.0d0 + facjs=1.0d0 + if(spds.gt.0.0d0) facpds=pabs/spds + if(sccs.ne.0.0d0) facjs=currt/sccs +c + do i=1,nd + dpdv(i)=facpds*dpdv(i) + ajphiv(i)=facjs*ajphiv(i) + ajcdv(i)=ajphiv(i)*ratj2v(i) + ajplv(i)=ajphiv(i)*ratj1v(i) + end do + + call profwidth(nd,rtab,dpdv,rhotp,rhopp,dpdvmx, + . drhotp,drhopp) + if(ieccd.ne.0) then + call profwidth(nd,rtab,ajphiv,rhotjfi,rhopfi,ajmxfi, + . drhotjfi,drhopfi) + xps=rhopfi + else + rhotjfi=0.0d0 + rhopfi=0.0d0 + ajmxfi=0.0d0 + drhotjfi=0.0d0 + drhopfi=0.0d0 + xps=rhopp + end if + + iif1=iiv(1,1) + istmx=1 + do i=2,iif1 + if(psjki(1,1,i).ge.0.0d0) then + if(pdjki(1,1,i).gt.pdjki(1,1,i-1)) istmx=i + end if + end do + stmx=istmx*dst + + pins_02=0.0d0 + pins_05=0.0d0 + pins_085=0.0d0 + + xrhot=0.2d0 + call locate(rhotv,nd,xrhot,i1) + call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1), + . xrhot,pins_02) + xrhot=0.5d0 + call locate(rhotv,nd,xrhot,i1) + call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1), + . xrhot,pins_05) + xrhot=0.85d0 + call locate(rhotv,nd,xrhot,i1) + call intlin(rhotv(i1),pins(i1),rhotv(i1+1),pins(i1+1), + . xrhot,pins_085) + + else + ajmxfi=0.0d0 + dpdvmx=0.0d0 + rhotjfi=1.0d0 + rhotjav=1.0d0 + rhotjava=1.0d0 + rhotp=1.0d0 + rhotpav=1.0d0 + drhotjfi=0.0d0 + drhotjava=0.0d0 + drhotp=0.0d0 + drhotpav=0.0d0 + taumn=0 + taumx=0 + stmx=stf + pins_02=0.0d0 + pins_05=0.0d0 + pins_085=0.0d0 +c end of pabstot > 0 + end if +c +c dPdV [MW/m^3], Jcd [MA/m^2] +c + if(ieccd.eq.0) currt=0.0d0 + currtka=currt*1.0d3 +c + if(index_rt.eq.1) then + write(7,*)'#B0 beta alpha Icd Pa Jphi '// + .'rhotj drhotj rhotjav rhotjava drhotjava dpdvmx rhotp drhotp '// + .'rhotpav drhotpav taumn taumx smx sf polpsi polchi index_rt' + write(48,*) '#B0 beta alpha rhop rhot dPdV Jphi Jcda P% Pins'// + . 'Icdins index_rt' +c else +c write(48,*) ' ' + end if + + write(6,*)' ' + write(6,*)'#beta alpha Icd Pa Jphi rhotj drhotj '// + .'rhotjav rhotjava drhotjava dpdvmx rhotp drhotp rhotpav '// + .'drhotpav taumn taumx sf Pins_02 Pins_05 Pins_085' + write(6,99) betac,alfac,currtka,pabstot,ajmxfi,rhotjfi,drhotjfi, + . rhotjav,rhotjava,drhotjava, + . dpdvmx,rhotp,drhotp,rhotpav,drhotpav, + . taumn,taumx,stf,pins_02,pins_05,pins_085 + + write(7,99) btrcen,betac,alfac,currtka,pabstot, + . ajmxfi,rhotjfi, + . drhotjfi,rhotjav,rhotjava,drhotjava, + . dpdvmx,rhotp,drhotp,rhotpav,drhotpav, + . taumn,taumx,stf,psipol,chipol,real(index_rt) +c +c if (iwarm.eq.0) return + write(49,*) 'Jphi (MA/m2) ' + write(49,99) ajmxfi + write(49,*) 'rhotmx drho_tor rhotjava drhotjava' + write(49,99) rhotjfi,drhotjfi,rhotjava,drhotjava +c + write(49,*) ' ' + write(49,*) 'i psi rhop rhot dPdV Jphi Jcda Pins Icdins' +c + do i=1,nd + if (ipec.eq.0) then + psip=rtab(i) + rhop=sqrt(rtab(i)) + else + psip=rtab(i)**2 + rhop=rtab(i) + end if + pinsr=0.0d0 + if(pabstot.gt.0) pinsr=pins(i)/pabstot + write(49,49) i,psip,rhop,rhotv(i),dpdv(i),ajphiv(i) + . ,ajcdv(i),pins(i),currins(i) + write(48,99) btrcen,betac,alfac,rhop,rhotv(i),dpdv(i),ajphiv(i) + . ,ajcdv(i),pinsr,pins(i),currins(i),real(index_rt) + end do +c + return + 49 format(i5,20(1x,e12.5)) + 99 format(30(1x,e12.5)) + end +c +c +c + subroutine profwidth(nd,xx,yy,rhotmx,rhopmx,ypk,drhot,drhop) + implicit real*8(a-h,o-z) + parameter(emn1=0.367879441171442d0) + dimension xx(nd),yy(nd) + common/jmxmn/rhotp,rhotm,ypkp,ypkm + common/ipec/ipec,nnd + common/iieq/iequil +c + call vmaxmini(yy,nd,ymn,ymx,imn,imx) + ypk=0.0d0 + xmx=xx(imx) + xmn=xx(imn) + if (abs(ymx).gt.abs(ymn)) then + ipk=imx + ypkp=ymx + xpkp=xmx + if(abs(ymn/ymx).lt.1d-2) ymn=0.0d0 + ypkm=ymn + xpkm=xmn + else + ipk=imn + ypkp=ymn + xpkp=xmn + if(abs(ymx/ymn).lt.1d-2) ymx=0.0d0 + ypkm=ymx + xpkm=xmx + end if + if(xpkp.gt.0.0d0) then + xpk=xpkp + ypk=ypkp + yye=ypk*emn1 + call locatex(yy,nd,1,ipk,yye,ie1) + if(ie1.gt.0.and.ie1.lt.nd) then + call intlin(yy(ie1),xx(ie1),yy(ie1+1),xx(ie1+1),yye,rte1) + else + rte1=0.0d0 + end if + call locatex(yy,nd,ipk,nd,yye,ie2) + call intlin(yy(ie2),xx(ie2),yy(ie2+1),xx(ie2+1),yye,rte2) + else + ipk=2 + xpk=xx(2) + ypk=yy(2) + rte1=0.0d0 + yye=ypk*emn1 + call locate(yy,nd,yye,ie2) + call intlin(yy(ie2),xx(ie2),yy(ie1+2),xx(ie1+2),yye,rte2) + end if +c + ipk=1 + if(ymx.ne.0.and.ymn.ne.0) ipk=2 +c + drhop=0.0d0 + drhot=0.0d0 + if (ie1.gt.0.or.ie2.gt.0) then + if(ipec.eq.0) then + rhopmx=sqrt(xpkp) + rhopmn=sqrt(xpkm) + psie2=rte2 + psie1=rte1 + drhop=sqrt(rte2)-sqrt(rte1) + else + rhopmx=xpkp + rhopmn=xpkm + drhop=rte2-rte1 + psie2=rte2**2 + psie1=rte1**2 + end if + end if +c + if(iequil.eq.2) then + rhotmx=frhotor(rhopmx**2) + rhotmn=frhotor(rhopmn**2) + rhote2=frhotor(psie2) + rhote1=frhotor(psie1) + drhot=rhote2-rhote1 + else + rhotmx=rhopmx + rhotmn=rhopmn + drhot=drhop + end if +c + if(ipk.eq.2) then + drhop=-drhop + drhot=-drhot + end if + + ypk=ypkp + rhotp=rhotmx + rhotm=rhotmn +c + return + end +c + subroutine polarcold(exf,eyif,ezf,elf,etf) + implicit real*8(a-h,o-z) + common/nplr/anpl,anpr + common/xgxg/xg + common/ygyg/yg + common/mode/sox +c +c dcold dispersion +c dielectric tensor (transposed) +c +c exf=0.0d0 +c eyif=0.0d0 +c ezf=0.0d0 +c if(xg.le.0) return +c + anpl2=anpl*anpl + anpr2=anpr*anpr + an2=anpl2+anpr2 + yg2=yg**2 + dy2=1.0d0-yg2 + aa=1.0d0-xg-yg2 + e3=1.0d0-xg +c + if(xg.gt.0.0d0) then + if (anpl.ne.0.0d0) then + qq=xg*yg/(an2*dy2-aa) + p=(anpr2-e3)/(anpl*anpr) + ezf=1.0d0/sqrt(1.0d0+p*p*(1.0d0+qq*qq)) + exf=p*ezf + eyif=qq*exf + else + if(sox.lt.0.d0) then + ezf=1 + exf=0 + eyif=0 + else + ezf=0 + qq=-aa/(xg*yg) + exf=1.0d0/sqrt(1.0d0+qq*qq) + eyif=qq*exf + end if + end if + elf=(anpl*ezf+anpr*exf)/sqrt(an2) + etf=sqrt(1.0d0-elf*elf) + else + if(sox.lt.0.0d0) then + ezf=1 + exf=0 + eyif=0 + else + ezf=0 + exf=0.0d0 + eyif=1.0d0 + end if + elf=0 + etf=1 + end if +c + return + end + + subroutine pol_limit(qq,uu,vv) + implicit none + integer*4 ipolc + real*8 bv(3),anv(3) + real*8 anx,any,anz,anpl,anpr,yg,xe2om,ye2om,xe2xm,ye2xm + real*8 an2,an,anxy,sngam,csgam,csg2,sng2,ffo,ffx,ffo2,ffx2 + real*8 deno,denx,anpl2,dnl,del0 + real*8 uuom,vvom,qqom,uuxm,vvxm,qqxm,ellom,ellxm,qq,uu,vv + real*8 aaom,bbom,llmom,aaxm,bbxm,llmxm,psiom,psixm,chiom,chixm + real*8 pi,beta,alfa,gam + real*8 sox,psipol,chipol + complex*16 ui,exom,eyom,exxm,eyxm,ext,eyt + parameter(ui=(0.0d0,1.0d0),pi=3.14159265358979d0) +c + common/anv/anv + common/nplr/anpl,anpr + common/ygyg/yg + common/bb/bv + common/angles/alfa,beta + common/mode/sox + common/polcof/psipol,chipol + common/ipol/ipolc + common/evt/ext,eyt +c + anx=anv(1) + any=anv(2) + anz=anv(3) + anpl2=anpl*anpl + dnl=1.0d0-anpl2 + del0=sqrt(dnl**2+4.0d0*anpl2/yg**2) + ffo=0.5d0*yg*(dnl+del0) + ffx=0.5d0*yg*(dnl-del0) + an2=anx*anx+any*any+anz*anz + an=sqrt(an2) + anxy=sqrt(anx*anx+any*any) + sngam=(anz*anpl-an2*bv(3))/(an*anxy*anpr) + csgam=-(any*bv(1)-anx*bv(2))/anxy/anpr + csg2=csgam**2 + sng2=sngam**2 + ffo2=ffo*ffo + ffx2=ffx*ffx + deno=ffo2+anpl2 + denx=ffx2+anpl2 + xe2om=(ffo2*csg2+anpl2*sng2)/deno + ye2om=(ffo2*sng2+anpl2*csg2)/deno + xe2xm=(ffx2*csg2+anpl2*sng2)/denx + ye2xm=(ffx2*sng2+anpl2*csg2)/denx +c + exom=(ffo*csgam-ui*anpl*sngam)/sqrt(deno) + eyom=(-ffo*sngam-ui*anpl*csgam)/sqrt(deno) + qqom=abs(exom)**2-abs(eyom)**2 + uuom=2.0d0*dble(exom*dconjg(eyom)) + vvom=2.0d0*dimag(exom*dconjg(eyom)) + llmom=sqrt(qqom**2+uuom**2) + aaom=sqrt((1+llmom)/2.0d0) + bbom=sqrt((1-llmom)/2.0d0) + ellom=bbom/aaom + psiom=0.5d0*atan2(uuom,qqom)*180.d0/pi + chiom=0.5d0*asin(vvom)*180.d0/pi +c + exxm=(ffx*csgam-ui*anpl*sngam)/sqrt(denx) + eyxm=(-ffx*sngam-ui*anpl*csgam)/sqrt(denx) + qqxm=abs(exxm)**2-abs(eyxm)**2 + uuxm=2.0d0*dble(exxm*dconjg(eyxm)) + vvxm=2.0d0*dimag(exxm*dconjg(eyxm)) + llmxm=sqrt(qqxm**2+uuxm**2) + aaxm=sqrt((1+llmxm)/2.0d0) + bbxm=sqrt((1-llmxm)/2.0d0) + ellxm=bbxm/aaxm + psixm=0.5d0*atan2(uuxm,qqxm)*180.d0/pi + chixm=0.5d0*asin(vvxm)*180.d0/pi +c + if (sox.lt.0.0d0) then + psipol=psiom + chipol=chiom + ext=exom + eyt=eyom + qq=qqom + vv=vvom + uu=uuom + else + psipol=psixm + chipol=chixm + ext=exxm + eyt=eyxm + qq=qqxm + vv=vvxm + uu=uuxm + endif + gam=atan(sngam/csgam)*180.d0/pi + + if(ipolc.eq.0.or.ipolc.eq.1) then + write(28,111) beta,alfa,anpl,-gam,ffo,ffx,xe2om,xe2xm + write(29,111) beta,alfa,qqom,uuom,vvom,psiom,chiom, + . qqxm,uuxm,vvxm,psixm,chixm + end if + + return + 111 format(20(1x,e12.5)) + end + + + + subroutine wall_refl(xvrfl,anvrfl,qqtr,uutr,vvtr,irfl) + implicit none + integer*4 ivac,irfl + real*8 anv(3),xv(3),xvrfl(3) + real*8 walln(3),anvrfl(3),vv1(3),vv2(3),vv3(3),xvout(3) + real*8 uutr,vvtr,qqtr,qq,uu,vv + real*8 pi + real*8 psipol,chipol,psitr,chitr + complex*16 ui,extr,eytr,eztr,ext,eyt + complex*16 evin(3),evrfl(3) + parameter(ui=(0.0d0,1.0d0),pi=3.14159265358979d0) + + common/xv/xv + common/anv/anv + common/polcof/psipol,chipol + common/evt/ext,eyt + common/wrefl/walln + + anv=anv/sqrt(anv(1)**2+anv(2)**2+anv(3)**2) + +c computation of reflection coordinates and normal to the wall + irfl=1 + ivac=1 + call vacuum_rt(xv,xvout,ivac) + + if(ivac.lt.0) then + irfl=0 + xvrfl=xvout + xv=xvout + anvrfl=anv + return + end if + +c rotation matrix from local to lab frame + vv1(1)=anv(2) + vv1(2)=-anv(1) + vv1(3)=0.0d0 + vv2(1)=anv(1)*anv(3) + vv2(2)=anv(2)*anv(3) + vv2(3)=-anv(1)*anv(1)-anv(2)*anv(2) + vv1=vv1/sqrt(vv1(1)**2+vv1(2)**2+vv1(3)**2) + vv2=vv2/sqrt(vv2(1)**2+vv2(2)**2+vv2(3)**2) + vv3=anv + + evin=ext*vv1+eyt*vv2 + +c wave vector and electric field after reflection in lab frame + anvrfl=anv-2.0d0* + . (anv(1)*walln(1)+anv(2)*walln(2)+anv(3)*walln(3))*walln + evrfl=-evin+2.0d0* + . (evin(1)*walln(1)+evin(2)*walln(2)+evin(3)*walln(3))*walln + + vv1(1)=anvrfl(2) + vv1(2)=-anvrfl(1) + vv1(3)=0.0d0 + vv2(1)=anvrfl(1)*anvrfl(3) + vv2(2)=anvrfl(2)*anvrfl(3) + vv2(3)=-anvrfl(1)*anvrfl(1)-anvrfl(2)*anvrfl(2) + vv1=vv1/sqrt(vv1(1)**2+vv1(2)**2+vv1(3)**2) + vv2=vv2/sqrt(vv2(1)**2+vv2(2)**2+vv2(3)**2) + vv3=anvrfl/sqrt(anvrfl(1)**2+anvrfl(2)**2+anvrfl(3)**2) + + extr=dot_product(vv1,evrfl) + eytr=dot_product(vv2,evrfl) + eztr=dot_product(vv3,evrfl) + + qqtr=abs(extr)**2-abs(eytr)**2 + uutr=2.0d0*dble(extr*dconjg(eytr)) + vvtr=2.0d0*dimag(extr*dconjg(eytr)) + psitr=0.5d0*atan2(uutr,qqtr)*180.d0/pi + chitr=0.5d0*asin(vvtr)*180.d0/pi + + ivac=2 + anv=anvrfl + xvrfl=xvout + xv=xvout + + call vacuum_rt(xv,xvout,ivac) + xv=xvout + +c write(32,111) xvrfl(1),xvrfl(2),xvrfl(3), +c . anvrfl(1),anvrfl(2),anvrfl(3) + + return + 111 format(20(1x,e12.5)) + end + + subroutine vacuum_rt(xvstart,xvend,ivac) + implicit none + integer*4 ivac + real*8 st,rs,rrm,psinv,rwallm,pi,dst,psdbnd,dstvac,deltawall + real*8 anv(3),xvstart(3),xvend(3),walln(3),y(6),dery(6) + + common/rwallm/rwallm + common/wrefl/walln + common/anv/anv + common/dsds/dst + common/psival/psinv + common/densbnd/psdbnd + common/dstvac/dstvac +c ivac=1 first interface plasma-vacuum +c ivac=2 second interface vacuum-plasma after wall reflection +c ivac=-1 second interface vacuum-plasma WITHOUT wall reflection + +c simplified case: plasma wall CYLINDER with radius rwallm +c test on occurrence wall reflection + deltawall=(anv(1)**2+anv(2)**2)*rwallm**2*1d+4- + . (anv(2)*xvstart(1)-anv(1)*xvstart(2))**2 + if (deltawall.le.0) ivac=-1 + + st=0.0d0 + do + xvend=xvstart+st*anv + if(ivac.eq.1) then + rs=sqrt(xvend(1)**2+xvend(2)**2) + rrm=rs/100.0d0 + if(rrm.le.rwallm) then + walln(1)=xvend(1)/rs + walln(2)=xvend(2)/rs + walln(3)=0.0d0 + dstvac=st + exit + end if + else + y(1)=xvend(1) + y(2)=xvend(2) + y(3)=xvend(3) + y(4)=anv(1) + y(5)=anv(2) + y(6)=anv(3) + call fwork(y,dery) + if(psinv.gt.0.0d0.and.psinv.lt.psdbnd) exit + end if + st=st+dst + end do + + return + 111 format(20(1x,e12.5)) + end diff --git a/src/grayl.f b/src/grayl.f new file mode 100644 index 0000000..d1aa7b9 --- /dev/null +++ b/src/grayl.f @@ -0,0 +1,10904 @@ + subroutine locate(xx,n,x,j) + implicit real*8(a-h,o-z) + dimension xx(n) +c +c Given an array xx(n), and a value x +c returns a value j such that xx(j) < x < xx(j+1) +c xx(n) must be monotonic, either increasing or decreasing. +c j=0 or j=n indicate that x is out of range (Numerical Recipes) +c + jl=0 + ju=n+1 + do while ((ju-jl).gt.1) + jm=(ju+jl)/2 + if((xx(n).gt.xx(1)). eqv .(x.gt.xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + return + end +c +c +c + subroutine locatex(xx,n,n1,n2,x,j) + implicit real*8(a-h,o-z) + dimension xx(n) +c +c Given an array xx(n), and a value x +c returns a value j such that xx(j) < x < xx(j+1) +c xx(n) must be monotonic, either increasing or decreasing. +c j=n1-1or j=n2+1 indicate that x is out of range +c modified from subr. locate (Numerical Recipes) +c + jl=n1-1 + ju=n2+1 + do while ((ju-jl).gt.1) + jm=(ju+jl)/2 + if((xx(n2).gt.xx(n1)). eqv .(x.gt.xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + return + end +c +c +c + subroutine intlin(x1,y1,x2,y2,x,y) + implicit real*8 (a-h,o-z) +c +c linear interpolation +c (x1,y1) < (x,y) < (x2,y2) +c + dx=x2-x1 + if(dx.eq.0.d0) then + print*,'ERROR in INTLIN',x1,x2,y1,y2 + else + aa=(x2-x)/dx + bb=1.0d0-aa + y=aa*y1+bb*y2 + endif +c + return + end + +c + subroutine vmax(x,n,xmax,imx) + implicit real*8 (a-h,o-z) + dimension x(n) + xmax=-1d+30 + do i=1,n + if(x(i).ge.xmax) then + xmax=x(i) + imx=i + end if + end do + return + end +c +c +c + subroutine vmin(x,n,xmin,imn) + implicit real*8 (a-h,o-z) + dimension x(n) + xmin=1d+30 + do i=1,n + if(x(i).le.xmin) then + xmin=x(i) + imn=i + end if + end do + return + end +c +c +c + subroutine vmaxmini(x,n,xmin,xmax,imn,imx) + implicit real*8 (a-h,o-z) + dimension x(n) + xmin=1d+30 + xmax=-1d+30 + do i=2,n + if(x(i).le.xmin) then + xmin=x(i) + imn=i + end if + if(x(i).ge.xmax) then + xmax=x(i) + imx=i + end if + end do + return + end +c +c +c + subroutine vmaxmin(x,n,xmin,xmax) + implicit real*8 (a-h,o-z) + dimension x(n) + xmin=1d+30 + xmax=-1d+30 + do i=2,n + if(x(i).le.xmin) xmin=x(i) + if(x(i).ge.xmax) xmax=x(i) + end do + return + end +c +c +c +c +c +c catand : double complex version of catan from slatec library +*deck catan + double complex function catand (z) +c***begin prologue catan +c***purpose compute the complex arc tangent. +c***library slatec (fnlib) +c***category c4a +c***type complex (catan-c) +c***keywords arc tangent, elementary functions, fnlib, trigonometric +c***author fullerton, w., (lanl) +c***description +c +c catan(z) calculates the complex trigonometric arc tangent of z. +c the result is in units of radians, and the real part is in the first +c or fourth quadrant. +c +c***references (none) +c***routines called d1mach, xermsg +c***revision history (yymmdd) +c 770801 date written +c 890531 changed all specific intrinsics to generic. (wrb) +c 890531 revision date from version 3.2 +c 891214 prologue converted to version 4.0 format. (bab) +c 900315 calls to xerror changed to calls to xermsg. (thj) +c 900326 removed duplicate information from description section. +c (wrb) +c***end prologue catan + implicit real*8(a-h,o-z) + complex*16 z, z2 + logical first + save pi2, nterms, sqeps, rmin, rmax, first + data pi2 / 1.5707963267 9489661923d0 / + data first /.true./ +c***first executable statement catan + if (first) then +c nterms = log(eps)/log(rbnd) where rbnd = 0.1 + nterms = -0.4343d0*log(d1mach(3)) + 1.0d0 + sqeps = sqrt(d1mach(4)) + rmin = sqrt (3.0d0*d1mach(3)) + rmax = 1.0d0/d1mach(3) + endif + first = .false. +c + r = abs(z) + if (r.gt.0.1d0) go to 30 +c + catand = z + if (r.lt.rmin) return +c + catand = (0.0d0, 0.0d0) + z2 = z*z + do 20 i=1,nterms + twoi = 2*(nterms-i) + 1 + catand = 1.0d0/twoi - z2*catand + 20 continue + catand = z*catand + return +c + 30 if (r.gt.rmax) go to 50 + x = dble(z) + y = dimag(z) + r2 = r*r + if (r2.eq.1.0d0.and.x.eq. 0.0d0) print*,'catand, z is +i or -i' + if (abs(r2-1.0d0).gt.sqeps) go to 40 + if (abs(dcmplx(1.0d0, 0.0d0)+z*z) .lt. sqeps) + . print*,'catand, answer lt half precision, z**2 close to -1' +c + 40 xans = 0.5d0*atan2(2.0d0*x, 1.0d0-r2) + yans = 0.25d0*log((r2+2.0d0*y+1.0d0)/(r2-2.0d0*y+1.0d0)) + catand = dcmplx(xans, yans) + return +c + 50 catand = dcmplx (pi2, 0.0d0) + if (dble(z).lt.0.0d0) catand = dcmplx(-pi2,0.0d0) + return +c + end +c +c +c + integer function length(string) +*returns length of string ignoring trailing blanks + character*(*) string + do 15, i = len(string), 1, -1 + if(string(i:i) .ne. ' ') go to 20 +15 continue +20 length = i + end + +c +c +c + subroutine simpson (n,h,fi,s) +c +c subroutine for integration over f(x) with the simpson rule. fi: +c integrand f(x); h: interval; s: integral. copyright (c) tao pang 1997. +c + implicit none + integer n + integer i + real*8 h + real*8 s0,s1,s2 + real*8 s + real*8 fi(n) + + s = 0.0d0 + s0 = 0.0d0 + s1 = 0.0d0 + s2 = 0.0d0 + do i = 2, n-1, 2 + s1 = s1+fi(i-1) + s0 = s0+fi(i) + s2 = s2+fi(i+1) + end do + s = h*(s1+4.0d0*s0+s2)/3.0d0 +c +c if n is even, add the last slice separately +c + if (mod(n,2).eq.0) s = s + . +h*(5.0d0*fi(n)+8.0d0*fi(n-1)-fi(n-2))/12.0d0 + end subroutine simpson +c +c +c spline routines: begin +c +c + function spli(cspli,n,k,dx) + implicit real*8(a-h,o-z) + dimension cspli(n,4) + spli=cspli(k,1)+dx*(cspli(k,2)+dx*(cspli(k,3)+dx*cspli(k,4))) + return + end +c +c +c + function splid(cspli,n,k,dx) + implicit real*8(a-h,o-z) + dimension cspli(n,4) + splid=cspli(k,2)+dx*(2.0d0*cspli(k,3)+3.0d0*dx*cspli(k,4)) + return + end +c +c +c + subroutine difcs(x,y,n,iopt,c,ier) + implicit real*8(a-h,o-z) + dimension x(n),y(n),c(n*4) + jmp =1 + ner =1000 + if (n-1) 16,16,1 +c +c initialization +c + 1 xc =x(1) + yb =y(1) + h =0.0d0 + a =0.0d0 + r =0.0d0 + dyb =0.0d0 + ner =2000 +c +c iol=0 - given derivative at first point +c ioh=0 - given derivative at last point +c + iol =iopt-1 + ioh =iopt-2 + if (ioh-1) 3,2,3 + 2 iol =0 + ioh =0 + 3 dy2 =c(2) +c +c form the system of linear equations +c and eliminate subsequentially +c + j =1 + do 14 i=1,n + j2 =n+i + j3 =j2+n + a =h*(2.0d0-a) + dya =dyb+h*r + if (i-n) 6,4,4 +c +c set derivative dy2 at last point +c + 4 dyb =dy2 + h =0.0d0 + if (ioh) 5,11,5 + 5 dyb =dya + goto 13 + 6 j =j+jmp + xb =xc + xc =x(j) + h =xc-xb +c +c ii=0 - increasing abscissae +c ii=1 - decreasing abscissae +c + ii =0 + if (h) 7,16,8 + 7 ii =1 + 8 ya =yb + yb =y(j) + dyb =(yb-ya)/h + if (i-1) 9,9,11 + 9 j1 =ii + if (iol) 13,10,13 + 10 dya =c(1) + 11 if (j1-ii) 16,12,16 + 12 a =1.0d0/(h+h+a) + 13 r =a*(dyb-dya) + c(j3)=r + a =h*a + c(j2)=a + 14 c(i) =dyb +c +c back substitution of the system of linear equations +c and computation of the other coefficients +c + a =1.0d0 + j1 =j3+n+ii-ii*n + i =n + do 15 iol=1,n + xb =x(j) + h =xc-xb + xc =xb + a =a+h + yb =r + r =c(j3)-r*c(j2) + ya =r+r + c(j3)=ya+r + c(j2)=c(i)-h*(ya+yb) + c(j1)=(yb-r)/a + c(i) =y(j) + a =0.0d0 + j =j-jmp + i =i-1 + j2 =j2-1 + j3 =j3-1 + 15 j1 =j3+n+ii + ier =0 + return + 16 continue + return + end +c +c +c + subroutine difcsn(xx,yy,nmx,n,iopt,cc,ier) +c +c same as difcs but with dimension(xx,yy) = nmx > n +c + implicit real*8(a-h,o-z) +c + dimension xx(nmx),yy(nmx),cc(nmx,4) + dimension x(n),y(n),c(n*4) +c + do i=1,n + x(i)=xx(i) + y(i)=yy(i) + end do + ii=0 + do j=1,4 + do i=1,n + ii=ii+1 + c(ii)=cc(i,j) + end do + end do +c + jmp =1 + ner =1000 + if (n-1) 16,16,1 +c +c initialization +c + 1 xc =x(1) + yb =y(1) + h =0.0d0 + a =0.0d0 + r =0.0d0 + dyb =0.0d0 + ner =2000 +c +c iol=0 - given derivative at first point +c ioh=0 - given derivative at last point +c + iol =iopt-1 + ioh =iopt-2 + if (ioh-1) 3,2,3 + 2 iol =0 + ioh =0 + 3 dy2 =c(2) +c +c form the system of linear equations +c and eliminate subsequentially +c + j =1 + do 14 i=1,n + j2 =n+i + j3 =j2+n + a =h*(2.0d0-a) + dya =dyb+h*r + if (i-n) 6,4,4 +c +c set derivative dy2 at last point +c + 4 dyb =dy2 + h =0.0d0 + if (ioh) 5,11,5 + 5 dyb =dya + goto 13 + 6 j =j+jmp + xb =xc + xc =x(j) + h =xc-xb +c +c ii=0 - increasing abscissae +c ii=1 - decreasing abscissae +c + ii =0 + if (h) 7,16,8 + 7 ii =1 + 8 ya =yb + yb =y(j) + dyb =(yb-ya)/h + if (i-1) 9,9,11 + 9 j1 =ii + if (iol) 13,10,13 + 10 dya =c(1) + 11 if (j1-ii) 16,12,16 + 12 a =1.0d0/(h+h+a) + 13 r =a*(dyb-dya) + c(j3)=r + a =h*a + c(j2)=a + 14 c(i) =dyb +c +c back substitution of the system of linear equations +c and computation of the other coefficients +c + a =1.0d0 + j1 =j3+n+ii-ii*n + i =n + do 15 iol=1,n + xb =x(j) + h =xc-xb + xc =xb + a =a+h + yb =r + r =c(j3)-r*c(j2) + ya =r+r + c(j3)=ya+r + c(j2)=c(i)-h*(ya+yb) + c(j1)=(yb-r)/a + c(i) =y(j) + a =0.0d0 + j =j-jmp + i =i-1 + j2 =j2-1 + j3 =j3-1 + 15 j1 =j3+n+ii + ier =0 +c + 16 continue + ii=0 + do j=1,4 + do i=1,nmx + if(i.le.n) then + ii=ii+1 + cc(i,j)=c(ii) + else + cc(i,j)=0.0d0 + end if + end do + end do +c + return + end +c +c +c spline routines: end +c +c +c routines for conical function: begin +c + function fconic(x,tau,m) +c +c this function subprogram computes the conical functions of the +c first kind P sub(-1/2 + i*tau) (x) for m = 0 and m = 1. +c Ref. in Kolbig, Comp. Phys. Commun. 23 (1981) 51 +c + implicit double precision (a-h,o-z) + dimension t(7),h(9),v(11) +c + double complex a,b,c,ti,r,rr,q,u,u0,u1,u2,uu + double complex v0,v1,v2,vv,w(19),clogam +c + logical lm0,lm1,lta +c + data rpi /1.7724 53850 9055d0/, pi2 /0.63661 97723 6758d0/ + data eps /1.0d-14/, nmax /200/, nout /2/ + + fconic=0.0d0 + lm0=m .eq. 0 + lm1=m .eq. 1 + if(.not.(lm0 .or. lm1)) go to 99 + fm=m + fconic=1.0d0-fm + if(x .eq. 1.0d0) return +c + fconic=0.0d0 + if(tau .eq. 0.0d0 .and. abs(x-1.0d0) .gt. 0.01d0) go to 60 + ti=dcmplx(0.d0,tau) +c + if(-1.d0 .lt. x .and. x .le. 0.0d0) go to 11 + if(0.0d0 .lt. x .and. x .le. 0.1d0 .and.tau.le. 17.0d0) go to 11 + if(0.1d0 .lt. x .and. x .le. 0.2d0 .and.tau.le. 5.0d0) go to 11 + if(0.1d0 .lt. x .and. x .le. 0.2d0 .and.tau.le. 17.0d0) go to 12 + if(0.2d0 .lt. x .and. x .le. 1.5d0 .and.tau.le. 20.0d0) go to 12 + if(1.5d0 .lt. x .and. tau .le. max(20.0d0,x)) go to 13 + go to 50 +c + 11 lta=tau .le. 10.0d0 + x1=x**2 + a=0.5d0*(0.5d0-fm-ti) + b=0.5d0*(0.5d0-fm+ti) + c=0.5d0 + assign 30 to jp + go to 100 + 30 r1=dble(r)/abs(exp(clogam(a+0.5d0)))**2 + a=0.5d0*(1.5d0-fm-ti) + b=0.5d0*(1.5d0-fm+ti) + c=1.5d0 + assign 31 to jp + go to 100 + 31 r2=dble(r)/abs(exp(clogam(a-0.5d0)))**2 + fconic=rpi*(r1-2.0d0*x*r2) + if(lm1) fconic=(2.0d0/sqrt(1.0d0-x1))*fconic + return +c + 12 lta=x .gt. 1.0d0 .or. x .le. 1.0d0 .and. tau .le. 5.0d0 + x1=(1.0d0-x)/2.d0 + a=0.5d0+fm-ti + b=0.5d0+fm+ti + c=fm+1.0d0 + assign 32 to jp + go to 100 + 32 fconic=dble(r) + if(lm0) return + fconic=0.5d0*(tau**2+0.25d0)*sqrt(abs(x**2-1.0d0))*fconic + if(x .gt. 1.0d0) fconic=-fconic + return +c + 13 lta=.true. + x1=1.0d0/x**2 + u=exp((-0.5d0+ti)*log(2.0d0*x)+clogam(1.0d0+ti) + . -clogam(1.5d0-fm+ti)) + a=0.5d0*(0.5d0-fm-ti) + b=0.5d0*(1.5d0-fm-ti) + c=1.0d0-ti + assign 33 to jp + go to 100 + 33 fconic=2.0d0*dble(u*r*(0.5d0-fm+ti)/ti)/rpi + if(lm1) fconic=fconic/sqrt(1.0d0-x1) + return +c + 100 if(lta) go to 110 + r=1.0d0 + q=1.0d0 + do 101 n = 1,nmax + fn=n + fn1=fn-1.0d0 + rr=r + q=q*x1*(a+fn1)*(b+fn1)/((c+fn1)*fn) + r=r+q + if(abs(r-rr) .lt. eps) go to 102 + 101 continue + go to 98 +c + 110 y=-x1 + y2=y**2 + y3=y**3 + w(1)=a+1.0d0 + w(2)=a+2.0d0 + w(3)=b+1.0d0 + w(4)=b+2.0d0 + w(5)=c+1.0d0 + w(6)=c*w(5) + w(7)=a+b + w(8)=a*b + w(9)=(w(8)/c)*y + w(10)=w(1)*w(3) + w(11)=w(2)*w(4) + w(12)=1.0d0+(w(11)/(2.0d0*w(5)))*y + w(13)=w(7)-6.0d0 + w(14)=w(7)+6.0d0 + w(15)=2.0d0-w(8) + w(16)=w(15)-2.0d0*w(7) +c + v0=1.0d0 + v1=1.0d0+(w(10)/(2.0d0*c))*y + v2=w(12)+(w(10)*w(11)/(12.0d0*w(6)))*y2 + u0=1.0d0 + u1=v1-w(9) + u2=v2-w(9)*w(12)+(w(8)*w(10)/(2.0d0*w(6)))*y2 +c + r=1.0d0 + n=2 + 111 n=n+1 + if(n .gt. nmax) go to 98 + rr=r + fn=n + h(1)=fn-1.0d0 + h(2)=fn-2.0d0 + h(3)=fn-3.0d0 + h(4)=2.0d0*fn + h(5)=h(4)-3.0d0 + h(6)=2.0d0*h(5) + h(7)=4.0d0*(h(4)-1.0d0)*h(5) + h(8)=8.0d0*h(5)**2*(h(4)-5.0d0) + h(9)=3.0d0*fn**2 + w(1)=a+h(1) + w(2)=a+h(2) + w(3)=b+h(1) + w(4)=b+h(2) + w(5)=c+h(1) + w(6)=c+h(2) + w(7)=c+h(3) + w(8)=h(2)-a + w(9)=h(2)-b + w(10)=h(1)-c + w(11)=w(1)*w(3) + w(12)=w(5)*w(6) +c + w(17)=1.0d0+((h(9)+w(13)*fn+w(16))/(h(6)*w(5)))*y + w(18)=-((w(11)*w(10)/h(6)+(h(9)-w(14)*fn+w(15))*w(11)*y/h(7))/ + 1 w(12))*y + w(19)=(w(2)*w(11)*w(4)*w(8)*w(9)/(h(8)*w(7)*w(12)))*y3 + vv=w(17)*v2+w(18)*v1+w(19)*v0 + uu=w(17)*u2+w(18)*u1+w(19)*u0 + r=uu/vv + if(abs(r-rr) .lt. eps) go to 102 + v0=v1 + v1=v2 + v2=vv + u0=u1 + u1=u2 + u2=uu + go to 111 + 102 go to jp, (30,31,32,33) +c + 50 if(x .gt. 1.0d0) go to 2 + s=sqrt(1.0d0-x**2) + t(1)=acos(x) + h(1)=tau*t(1) + b0=besi0(h(1)) + b1=besi1(h(1)) + z=-1.0d0 + go to 3 +c + 2 s=sqrt(x**2-1.0d0) + t(1)=log(x+s) + h(1)=tau*t(1) + b0=besj0l(h(1)) + b1=besj1l(h(1)) + z=1.0d0 +c + 3 h(1)=t(1)*x/s + v(1)=tau + do 20 j = 2,7 + t(j)=t(j-1)*t(1) + 20 h(j)=h(j-1)*h(1) + do 21 j = 2,11 + 21 v(j)=v(j-1)*v(1) +c + if(lm1) go to 51 + aa=0.0d0 + a0=1.0d0 + a1=(h(1)-1.0d0)/(8.0d0*t(1)) + a2=(9.0d0*h(2)+6.0d0*h(1)-15.0d0-z*8.0d0*t(2))/(128.0d0*t(2)) + a3=5.0d0*(15.0d0*h(3)+27.0d0*h(2)+21.0d0*h(1)-63.0d0 + . -z*t(2)*(16.0d0*h(1)+24.0d0) + 1 )/(1024.0d0*t(3)) + a4=7.0d0*(525.0d0*h(4)+1500.0d0*h(3)+2430.0d0*h(2)+1980.0d0*h(1) + . -6435.0d0+192.0d0*t(4) + 1-z*t(2)*(720.0d0*h(2)+1600.0d0*h(1)+2160.0d0))/(32768.0d0*t(4)) + a5=21.0d0*(2835.0d0*h(5)+11025.0d0*h(4)+24750.0d0*h(3) + 1 +38610.0d0*h(2)+32175.0d0*h(1)-109395.0d0+t(4) + . *(1984.0d0*h(1)+4032.0d0) + 2 -z*t(2)*(4800.0d0*h(3)+15120.0d0*h(2)+26400.0d0*h(1)+34320.0d0)) + 3 /(262144.0d0*t(5)) + a6=11.0d0*(218295.0d0*h(6)+1071630.0d0*h(5)+3009825.0d0*h(4) + . +6142500.0d0* + 1 h(3)+9398025.0d0*h(2)+7936110.0d0*h(1)-27776385.0d0 + . +t(4)*(254016.0d0*h(2) + 2 +749952.0d0*h(1)+1100736.0d0)-z*t(2)*(441000.0d0*h(4) + . +1814400.0d0*h(3) + 3 +4127760.0d0*h(2)+6552000.0d0*h(1)+8353800.0d0+31232.0d0*t(4)))/ + 4 (4194304.0d0*t(6)) + go to 52 +c + 51 aa=-1.0d0 + a0=3.0d0*(1.0d0-h(1))/(8.0d0*t(1)) + a1=(-15.0d0*h(2)+6.0d0*h(1)+9.0d0+z*8.0d0*t(2))/(128.0d0*t(2)) + a2=3.0d0*(-35.0d0*h(3)-15.0d0*h(2)+15.0d0*h(1)+35.0d0 + 1 +z*t(2)*(32.0d0*h(1)+8.0d0))/(1024.0d0*t(3)) + a3=(-4725.0d0*h(4)-6300.0d0*h(3)-3150.0d0*h(2)+3780.0d0*h(1) + 1 +10395.0d0-1216.0d0*t(4)+z*t(2)*(6000.0d0*h(2) + 2 +5760.0d0*h(1)+1680.0d0)) /(32768.0d0*t(4)) + a4=7.0d0*(-10395.0d0*h(5)-23625.0d0*h(4)-28350.0d0*h(3) + . -14850.0d0*h(2)+19305.0d0*h(1)+57915.0d0 + 1 -t(4)*(6336.0d0*h(1)+6080.0d0)+z*t(2)*(16800.0d0* + 2 h(3)+30000.0d0*h(2)+25920.0d0*h(1)+7920.0d0))/(262144.0d0*t(5)) + a5=(-2837835.0d0*h(6)-9168390.0d0*h(5)-16372125.0d0*h(4) + . -18918900*h(3) -10135125.0d0*h(2)+13783770.0d0*h(1) + 1 +43648605.0d0-t(4)*(3044160.0d0*h(2)+5588352.0d0*h(1) + 2 +4213440.0d0)+z*t(2)*(5556600.0d0*h(4)+14817600.0d0*h(3) + 3 +20790000.0d0*h(2)+17297280.0d0*h(1)+5405400.0d0 + 4 +323072.0d0*t(4)))/ (4194304.0d0*t(6)) + a6=0.0d0 +c + 52 s0=a0+(-4.0d0*a3/t(1)+a4)/v(4)+(-192.0d0*a5/t(3)+144.0d0*a6/t(2)) + 1 /v(8)+z*(-a2/v(2)+(-24.0d0*a4/t(2)+12.0d0*a5/t(1)-a6)/v(6) + 2 +(-1920.0d0*a6/t(4))/v(10)) + s1=a1/v(1)+(8.0d0*(a3/t(2)-a4/t(1))+a5)/v(5)+(384.0d0*a5/t(4) + 1 -768.0d0*a6/t(3))/v(9) + 2 +z*(aa*v(1)+(2.0d0*a2/t(1)-a3)/v(3)+(48.0d0*a4/t(3)-72.0d0*a5 + 3 /t(2)+18.0d0*a6/t(1))/v(7)+(3840.0d0*a6/t(5))/v(11)) + fconic=sqrt(t(1)/s)*(b0*s0+b1*s1) + return +c + 60 if(x .gt. 1.0d0) go to 61 + y=sqrt(0.5d0*(1.0d0-x)) + z=ellick(y) + if(lm0) fconic=pi2*z + if(lm1) fconic=pi2*(ellice(y)-0.5d0*(1.0d0+x)*z)/sqrt(1.0d0-x**2) + return + 61 y=sqrt((x-1.0d0)/(x+1.0d0)) + z=ellick(y) + s=sqrt(0.5d0*(x+1.0d0)) + if(lm0) fconic=pi2*z/s + if(lm1) fconic=pi2*s*(ellice(y)-z)/sqrt(x**2-1.0d0) + return +c + 98 write(nout,200) x,tau,m + return + 99 write(nout,201) m + return +c + 200 format(1x,'fconic ... convergence difficulties for + 1c function, x = ',e12.4,5x,'tau = ',e12.4,5x,'m = ',i5) + 201 format(1x,33hfconic ... illegal value for m = ,i4) +c + end +c +c +c + double complex function clogam(z) +c + implicit double precision (a-h,o-z) + double complex z,v,h,r +c + dimension b(10) +c + data nout /2/ + data pi /3.14159 26535 898d0/ + data b(1),b(2),b(3),b(4),b(5),b(6),b(7),b(8),b(9),b(10) + 1 /+8.33333 33333 333 d-2, -2.77777 77777 778 d-3, + 1 +7.93650 79365 079 d-4, -5.95238 09523 810 d-4, + 2 +8.41750 84175 084 d-4, -1.91752 69175 269 d-3, + 3 +6.41025 64102 564 d-3, -2.95506 53594 771 d-2, + 4 +1.79644 37236 883 d-1, -1.39243 22169 059 d+0/ +c + x=dble(z) + t=dimag(z) + if(-abs(x) .eq. aint(x) .and. t .eq. 0.0d0) go to 5 + f=abs(t) + v=dcmplx(x,f) + if(x .lt. 0.0d0) v=1.0d0-v + h=(0.0d0,0.0d0) + c=dble(v) + if(c .ge. 7.0d0) go to 3 + n=6-int(c) + h=v + d=dimag(v) + a=atan2(d,c) + if(n .eq. 0) go to 2 + do 1 i = 1,n + c=c+1.0d0 + v=dcmplx(c,d) + h=h*v + 1 a=a+atan2(d,c) + 2 h=dcmplx(0.5d0*log(dble(h)**2+dimag(h)**2),a) + v=v+1.0d0 + 3 r=1.0d0/v**2 + clogam=0.91893853320467d0+(v-0.5d0)*log(v)-v+(b(1)+r*(b(2)+r*(b(3) + 1 +r*(b(4)+r*(b(5)+r*(b(6)+r*(b(7)+r*(b(8)+r*(b(9)+r*b(10)))))))))) + 2 /v-h + if(x .ge. 0.0d0) go to 4 +c + a=aint(x)-1.0d0 + c=pi*(x-a) + d=pi*f + e=exp(-2.0d0*d) + f=sin(c) + e=d+0.5d0*log(e*f**2+0.25d0*(1.0d0-e)**2) + f=atan2(cos(c)*tanh(d),f)-a*pi + clogam=1.1447298858494d0-dcmplx(e,f)-clogam +c + 4 if(t .lt. 0.0d0) clogam=dconjg(clogam) + return + + 5 write(nout,100) x + clogam=(0.0d0,0.0d0) + return +c + 100 format(1x,f20.2) +c + end +c +c +c + function ellick(xk) +c + implicit double precision (a-h,o-z) + dimension a(10),b(10),c(10),d(10) +c + data a(1)/9.65735 90280 856 d-2/ + data a(2)/3.08851 46271 305 d-2/ + data a(3)/1.49380 13532 687 d-2/ + data a(4)/8.78980 18745 551 d-3/ + data a(5)/6.17962 74460 533 d-3/ + data a(6)/6.84790 92826 245 d-3/ + data a(7)/9.84892 93221 769 d-3/ + data a(8)/8.00300 39806 500 d-3/ + data a(9)/2.29663 48983 970 d-3/ + data a(10)/1.39308 78570 066 d-4/ +c + data b(1)/1.24999 99999 991 d-1/ + data b(2)/7.03124 99739 038 d-2/ + data b(3)/4.88280 41906 862 d-2/ + data b(4)/3.73777 39758 624 d-2/ + data b(5)/3.01248 49012 899 d-2/ + data b(6)/2.39319 13323 111 d-2/ + data b(7)/1.55309 41631 977 d-2/ + data b(8)/5.97390 42991 554 d-3/ + data b(9)/9.21554 63496 325 d-4/ + data b(10)/2.97002 80966 556 d-5/ +c + data c(1)/4.43147 18056 089 d-1/ + data c(2)/5.68051 94567 559 d-2/ + data c(3)/2.18318 11676 130 d-2/ + data c(4)/1.15695 95745 295 d-2/ + data c(5)/7.59509 34225 594 d-3/ + data c(6)/7.82040 40609 596 d-3/ + data c(7)/1.07706 35039 866 d-2/ + data c(8)/8.63844 21736 041 d-3/ + data c(9)/2.46850 33304 607 d-3/ + data c(10)/1.49466 21757 181 d-4/ +c + data d(1)/2.49999 99999 990 d-1/ + data d(2)/9.37499 99721 203 d-2/ + data d(3)/5.85936 61255 531 d-2/ + data d(4)/4.27178 90547 383 d-2/ + data d(5)/3.34789 43665 762 d-2/ + data d(6)/2.61450 14700 314 d-2/ + data d(7)/1.68040 23346 363 d-2/ + data d(8)/6.43214 65864 383 d-3/ + data d(9)/9.89833 28462 254 d-4/ + data d(10)/3.18591 95655 502 d-5/ +c + if(abs(xk) .ge. 1.0d0) go to 10 + eta=1.0d0-xk**2 + pa=a(10) + do 1 i = 1,9 + 1 pa=pa*eta+a(10-i) + pa=pa*eta + pb=b(10) + do 2 i = 1,9 + 2 pb=pb*eta+b(10-i) + pb=pb*eta + ellick=1.3862943611199d0+pa-log(eta)*(0.5d0+pb) + return +c + 10 ellick=0.0d0 + return + 9 ellick=1.0d0 + return +c + entry ellice(xk) +c + if(abs(xk)-1.0d0) 8,9,10 + 8 eta=1.0d0-xk**2 + pc=c(10) + do 3 i = 1,9 + 3 pc=pc*eta+c(10-i) + pc=pc*eta + pd=d(10) + do 4 i = 1,9 + 4 pd=pd*eta+d(10-i) + pd=pd*eta + ellick=1.0d0+pc-log(eta)*pd + return + end +c +c +c + function besjy(x) +c + implicit double precision (a-h,o-z) + logical l +c + data nout /2/ +c + entry besj0l(x) +c + l=.true. + v=abs(x) + if(v .ge. 8.0d0) go to 4 + 8 f=0.0625d0*x**2-2.0d0 + a = - 0.00000 00000 000008d0 + b = f * a + 0.00000 00000 000413d0 + a = f * b - a - 0.00000 00000 019438d0 + b = f * a - b + 0.00000 00000 784870d0 + a = f * b - a - 0.00000 00026 792535d0 + b = f * a - b + 0.00000 00760 816359d0 + a = f * b - a - 0.00000 17619 469078d0 + b = f * a - b + 0.00003 24603 288210d0 + a = f * b - a - 0.00046 06261 662063d0 + b = f * a - b + 0.00481 91800 694676d0 + a = f * b - a - 0.03489 37694 114089d0 + b = f * a - b + 0.15806 71023 320973d0 + a = f * b - a - 0.37009 49938 726498d0 + b = f * a - b + 0.26517 86132 033368d0 + a = f * b - a - 0.00872 34423 528522d0 + a = f * a - b + 0.31545 59429 497802d0 + besjy=0.5d0*(a-b) + if(l) return +c + a = + 0.00000 00000 000016d0 + b = f * a - 0.00000 00000 000875d0 + a = f * b - a + 0.00000 00000 040263d0 + b = f * a - b - 0.00000 00001 583755d0 + a = f * b - a + 0.00000 00052 487948d0 + b = f * a - b - 0.00000 01440 723327d0 + a = f * b - a + 0.00000 32065 325377d0 + b = f * a - b - 0.00005 63207 914106d0 + a = f * b - a + 0.00075 31135 932578d0 + b = f * a - b - 0.00728 79624 795521d0 + a = f * b - a + 0.04719 66895 957634d0 + b = f * a - b - 0.17730 20127 811436d0 + a = f * b - a + 0.26156 73462 550466d0 + b = f * a - b + 0.17903 43140 771827d0 + a = f * b - a - 0.27447 43055 297453d0 + a = f * a - b - 0.06629 22264 065699d0 + besjy=0.636619772367581d0*log(x)*besjy+0.5d0*(a-b) + return +c + 4 f=256.0d0/x**2-2.0d0 + b = + 0.00000 00000 000007 d0 + a = f * b - 0.00000 00000 000051 d0 + b = f * a - b + 0.00000 00000 000433 d0 + a = f * b - a - 0.00000 00000 004305 d0 + b = f * a - b + 0.00000 00000 051683 d0 + a = f * b - a - 0.00000 00000 786409 d0 + b = f * a - b + 0.00000 00016 306465 d0 + a = f * b - a - 0.00000 00517 059454 d0 + b = f * a - b + 0.00000 30751 847875 d0 + a = f * b - a - 0.00053 65220 468132 d0 + a = f * a - b + 1.99892 06986 950373 d0 + p=a-b + b = - 0.00000 00000 000006 d0 + a = f * b + 0.00000 00000 000043 d0 + b = f * a - b - 0.00000 00000 000334 d0 + a = f * b - a + 0.00000 00000 003006 d0 + b = f * a - b - 0.00000 00000 032067 d0 + a = f * b - a + 0.00000 00000 422012 d0 + b = f * a - b - 0.00000 00007 271916 d0 + a = f * b - a + 0.00000 00179 724572 d0 + b = f * a - b - 0.00000 07414 498411 d0 + a = f * b - a + 0.00006 83851 994261 d0 + a = f * a - b - 0.03111 17092 106740 d0 + q=8.0d0*(a-b)/v + f=v-0.785398163397448d0 + a=cos(f) + b=sin(f) + f=0.398942280401432d0/sqrt(v) + if(l) go to 6 + besjy=f*(q*a+p*b) + return + 6 besjy=f*(p*a-q*b) + return +c + entry besj1l(x) +c + l=.true. + v=abs(x) + if(v .ge. 8.0d0) go to 5 + 3 f=0.0625d0*x**2-2.0d0 + b = + 0.00000 00000 000114 d0 + a = f * b - 0.00000 00000 005777 d0 + b = f * a - b + 0.00000 00000 252812 d0 + a = f * b - a - 0.00000 00009 424213 d0 + b = f * a - b + 0.00000 00294 970701 d0 + a = f * b - a - 0.00000 07617 587805 d0 + b = f * a - b + 0.00001 58870 192399 d0 + a = f * b - a - 0.00026 04443 893486 d0 + b = f * a - b + 0.00324 02701 826839 d0 + a = f * b - a - 0.02917 55248 061542 d0 + b = f * a - b + 0.17770 91172 397283 d0 + a = f * b - a - 0.66144 39341 345433 d0 + b = f * a - b + 1.28799 40988 576776 d0 + a = f * b - a - 1.19180 11605 412169 d0 + a = f * a - b + 1.29671 75412 105298 d0 + besjy=0.0625d0*(a-b)*x + if(l) return +c + b = - 0.00000 00000 000244 d0 + a = f * b + 0.00000 00000 012114 d0 + b = f * a - b - 0.00000 00000 517212 d0 + a = f * b - a + 0.00000 00018 754703 d0 + b = f * a - b - 0.00000 00568 844004 d0 + a = f * b - a + 0.00000 14166 243645 d0 + b = f * a - b - 0.00002 83046 401495 d0 + a = f * b - a + 0.00044 04786 298671 d0 + b = f * a - b - 0.00513 16411 610611 d0 + a = f * b - a + 0.04231 91803 533369 d0 + b = f * a - b - 0.22662 49915 567549 d0 + a = f * b - a + 0.67561 57807 721877 d0 + b = f * a - b - 0.76729 63628 866459 d0 + a = f * b - a - 0.12869 73843 813500 d0 + a = f * a - b + 0.04060 82117 718685 d0 + besjy=0.636619772367581d0*log(x)*besjy-0.636619772367581d0/x + 1 +0.0625d0*(a-b)*x + return +c + 5 f=256.0d0/x**2-2.0d0 + b = - 0.00000 00000 000007 d0 + a = f * b + 0.00000 00000 000055 d0 + b = f * a - b - 0.00000 00000 000468 d0 + a = f * b - a + 0.00000 00000 004699 d0 + b = f * a - b - 0.00000 00000 057049 d0 + a = f * b - a + 0.00000 00000 881690 d0 + b = f * a - b - 0.00000 00018 718907 d0 + a = f * b - a + 0.00000 00617 763396 d0 + b = f * a - b - 0.00000 39872 843005 d0 + a = f * b - a + 0.00089 89898 330859 d0 + a = f * a - b + 2.00180 60817 200274 d0 + p=a-b + b = + 0.00000 00000 000007 d0 + a = f * b - 0.00000 00000 000046 d0 + b = f * a - b + 0.00000 00000 000360 d0 + a = f * b - a - 0.00000 00000 003264 d0 + b = f * a - b + 0.00000 00000 035152 d0 + a = f * b - a - 0.00000 00000 468636 d0 + b = f * a - b + 0.00000 00008 229193 d0 + a = f * b - a - 0.00000 00209 597814 d0 + b = f * a - b + 0.00000 09138 615258 d0 + a = f * b - a - 0.00009 62772 354916 d0 + a = f * a - b + 0.09355 55741 390707 d0 + q=8.0d0*(a-b)/v + f=v-2.356194490192345d0 + a=cos(f) + b=sin(f) + f=0.398942280401432d0/sqrt(v) + if(l) go to 7 + besjy=f*(q*a+p*b) + return + 7 besjy=f*(p*a-q*b) + if(x .lt. 0.0d0) besjy=-besjy + return +c + entry besy0(x) +c + if(x .le. 0.0d0) go to 9 + l=.false. + v=x + if(v .ge. 8.0d0) go to 4 + go to 8 + entry besy1(x) +c + if(x .le. 0.0d0) go to 9 + l=.false. + v=x + if(v .ge. 8.0d0) go to 5 + go to 3 +c + 9 besjy=0.0d0 + write(nout,100) x + return + 100 format(1x,36hbesjy ... non-positive argument x = ,e15.4) +c + end +c +c +c + function besik(x) +c + implicit double precision (a-h,o-z) + logical l,e +c + data nout /2/ +c + entry ebesi0(x) +c + e=.true. + go to 1 +c + entry besi0(x) +c + e=.false. + 1 l=.true. + v=abs(x) + if(v .ge. 8.0d0) go to 4 + 8 f=0.0625d0*x**2-2.0d0 + a = 0.00000 00000 00002 d0 + b = f * a + 0.00000 00000 00120 d0 + a = f * b - a + 0.00000 00000 06097 d0 + b = f * a - b + 0.00000 00002 68828 d0 + a = f * b - a + 0.00000 00101 69727 d0 + b = f * a - b + 0.00000 03260 91051 d0 + a = f * b - a + 0.00000 87383 15497 d0 + b = f * a - b + 0.00019 24693 59688 d0 + a = f * b - a + 0.00341 63317 66012 d0 + b = f * a - b + 0.04771 87487 98174 d0 + a = f * b - a + 0.50949 33654 39983 d0 + b = f * a - b + 4.01167 37601 79349 d0 + a = f * b - a + 22.27481 92424 62231 d0 + b = f * a - b + 82.48903 27440 24100 d0 + a = f * b - a + 190.49432 01727 42844 d0 + a = f * a - b + 255.46687 96243 62167 d0 + besik=0.5d0*(a-b) + if(l .and. e) besik=exp(-v)*besik + if(l) return +c + a = + 0.00000 00000 00003 d0 + b = f * a + 0.00000 00000 00159 d0 + a = f * b - a + 0.00000 00000 07658 d0 + b = f * a - b + 0.00000 00003 18588 d0 + a = f * b - a + 0.00000 00112 81211 d0 + b = f * a - b + 0.00000 03351 95256 d0 + a = f * b - a + 0.00000 82160 25940 d0 + b = f * a - b + 0.00016 27083 79043 d0 + a = f * b - a + 0.00253 63081 88086 d0 + b = f * a - b + 0.03008 07224 20512 d0 + a = f * b - a + 0.25908 44324 34900 d0 + b = f * a - b + 1.51153 56760 29228 d0 + a = f * b - a + 5.28363 28668 73920 d0 + b = f * a - b + 8.00536 88687 00334 d0 + a = f * b - a - 4.56343 35864 48395 d0 + a = f * a - b - 21.05766 01774 02440 d0 + besik=-log(0.125d0*x)*besik+0.5d0*(a-b) + if(e) besik=exp(x)*besik + return +c + 4 f=32.0d0/v-2.0d0 + b = - 0.00000 00000 00001 d0 + a = f * b - 0.00000 00000 00001 d0 + b = f * a - b + 0.00000 00000 00004 d0 + a = f * b - a + 0.00000 00000 00010 d0 + b = f * a - b - 0.00000 00000 00024 d0 + a = f * b - a - 0.00000 00000 00104 d0 + b = f * a - b + 0.00000 00000 00039 d0 + a = f * b - a + 0.00000 00000 00966 d0 + b = f * a - b + 0.00000 00000 01800 d0 + a = f * b - a - 0.00000 00000 04497 d0 + b = f * a - b - 0.00000 00000 33127 d0 + a = f * b - a - 0.00000 00000 78957 d0 + b = f * a - b + 0.00000 00000 29802 d0 + a = f * b - a + 0.00000 00012 38425 d0 + b = f * a - b + 0.00000 00085 13091 d0 + a = f * b - a + 0.00000 00568 16966 d0 + b = f * a - b + 0.00000 05135 87727 d0 + a = f * b - a + 0.00000 72475 91100 d0 + b = f * a - b + 0.00017 27006 30778 d0 + a = f * b - a + 0.00844 51226 24921 d0 + a = f * a - b + 2.01655 84109 17480 d0 + besik=0.199471140200717d0*(a-b)/sqrt(v) + if(e) return + besik=exp(v)*besik + return +c + entry ebesi1(x) +c + e=.true. + go to 2 +c + entry besi1(x) +c + e=.false. + 2 l=.true. + v=abs(x) + if(v .ge. 8.0d0) go to 3 + 7 f=0.0625d0*x**2-2.0d0 + a = + 0.00000 00000 00001 d0 + b = f * a + 0.00000 00000 00031 d0 + a = f * b - a + 0.00000 00000 01679 d0 + b = f * a - b + 0.00000 00000 79291 d0 + a = f * b - a + 0.00000 00032 27617 d0 + b = f * a - b + 0.00000 01119 46285 d0 + a = f * b - a + 0.00000 32641 38122 d0 + b = f * a - b + 0.00007 87567 85754 d0 + a = f * b - a + 0.00154 30190 15627 d0 + b = f * a - b + 0.02399 30791 47841 d0 + a = f * b - a + 0.28785 55118 04672 d0 + b = f * a - b + 2.57145 99063 47755 d0 + a = f * b - a + 16.33455 05525 22066 d0 + b = f * a - b + 69.39591 76337 34448 d0 + a = f * b - a + 181.31261 60405 70265 d0 + a = f * a - b + 259.89023 78064 77292 d0 + besik=0.0625d0*(a-b)*x + if(l .and. e) besik=exp(-v)*besik + if(l) return +c + a = + 0.00000 00000 00001 d0 + b = f * a + 0.00000 00000 00042 d0 + a = f * b - a + 0.00000 00000 02163 d0 + b = f * a - b + 0.00000 00000 96660 d0 + a = f * b - a + 0.00000 00036 96783 d0 + b = f * a - b + 0.00000 01193 67971 d0 + a = f * b - a + 0.00000 32025 10692 d0 + b = f * a - b + 0.00007 00106 27855 d0 + a = f * b - a + 0.00121 70569 94516 d0 + b = f * a - b + 0.01630 00492 89816 d0 + a = f * b - a + 0.16107 43016 56148 d0 + b = f * a - b + 1.10146 19930 04852 d0 + a = f * b - a + 4.66638 70268 62842 d0 + b = f * a - b + 9.36161 78313 95389 d0 + a = f * b - a - 1.83923 92242 86199 d0 + a = f * a - b - 26.68809 54808 62668 d0 + besik=log(0.125d0*x)*besik+1.0d0/x-0.0625d0*(a-b)*x + if(e) besik=exp(x)*besik + return +c + 3 f=32.0d0/v-2.0d0 + b = + 0.00000 00000 00001 d0 + a = f * b + 0.00000 00000 00001 d0 + b = f * a - b - 0.00000 00000 00005 d0 + a = f * b - a - 0.00000 00000 00010 d0 + b = f * a - b + 0.00000 00000 00026 d0 + a = f * b - a + 0.00000 00000 00107 d0 + b = f * a - b - 0.00000 00000 00053 d0 + a = f * b - a - 0.00000 00000 01024 d0 + b = f * a - b - 0.00000 00000 01804 d0 + a = f * b - a + 0.00000 00000 05103 d0 + b = f * a - b + 0.00000 00000 35408 d0 + a = f * b - a + 0.00000 00000 81531 d0 + b = f * a - b - 0.00000 00000 47563 d0 + a = f * b - a - 0.00000 00014 01141 d0 + b = f * a - b - 0.00000 00096 13873 d0 + a = f * b - a - 0.00000 00659 61142 d0 + b = f * a - b - 0.00000 06297 24239 d0 + a = f * b - a - 0.00000 97321 46728 d0 + b = f * a - b - 0.00027 72053 60764 d0 + a = f * b - a - 0.02446 74429 63276 d0 + a = f * a - b + 1.95160 12046 52572 d0 + besik=0.199471140200717d0*(a-b)/sqrt(v) + if(x .lt. 0.0d0) besik=-besik + if(e) return + besik=exp(v)*besik + return +c + entry ebesk0 (x) +c + e=.true. + go to 11 +c + entry besk0(x) +c + e=.false. + 11 if(x .le. 0.0d0) go to 9 + l=.false. + v=x + if(x .lt. 5.0d0) go to 8 + f=20.0d0/x-2.0d0 + a = - 0.00000 00000 00002 d0 + b = f * a + 0.00000 00000 00011 d0 + a = f * b - a - 0.00000 00000 00079 d0 + b = f * a - b + 0.00000 00000 00581 d0 + a = f * b - a - 0.00000 00000 04580 d0 + b = f * a - b + 0.00000 00000 39044 d0 + a = f * b - a - 0.00000 00003 64547 d0 + b = f * a - b + 0.00000 00037 92996 d0 + a = f * b - a - 0.00000 00450 47338 d0 + b = f * a - b + 0.00000 06325 75109 d0 + a = f * b - a - 0.00001 11066 85197 d0 + b = f * a - b + 0.00026 95326 12763 d0 + a = f * b - a - 0.01131 05046 46928 d0 + a = f * a - b + 1.97681 63484 61652 d0 + besik=0.626657068657750d0*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0d0 + if(x .lt. 180.0d0) besik=exp(-x)*z + return +c + entry ebesk1(x) +c + e=.true. + go to 12 +c + entry besk1(x) +c + e=.false. + 12 if(x .le. 0.0d0) go to 9 + l=.false. + v=x + if(x .lt. 5.0d0) go to 7 + f=20.0d0/x-2.0d0 + a = + 0.00000 00000 00002 d0 + b = f * a - 0.00000 00000 00013 d0 + a = f * b - a + 0.00000 00000 00089 d0 + b = f * a - b - 0.00000 00000 00663 d0 + a = f * b - a + 0.00000 00000 05288 d0 + b = f * a - b - 0.00000 00000 45757 d0 + a = f * b - a + 0.00000 00004 35417 d0 + b = f * a - b - 0.00000 00046 45555 d0 + a = f * b - a + 0.00000 00571 32218 d0 + b = f * a - b - 0.00000 08451 72048 d0 + a = f * b - a + 0.00001 61850 63810 d0 + b = f * a - b - 0.00046 84750 28167 d0 + a = f * b - a + 0.03546 52912 43331 d0 + a = f * a - b + 2.07190 17175 44716 d0 + besik=0.626657068657750d0*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0d0 + if(x .lt. 180.0d0) besik=exp(-x)*z + return + 9 besik=0.0d0 + write(nout,100) x + 100 format(1x,'besik ... non-positive argument x = ',e15.4) + return +c + end +c +c +c routines for conical function: end +c +c +c factorial function +c + function fact(k) + real*8 fact + fact=0.0d0 + if(k.lt.0) return + fact=1.0d0 + if(k.eq.0) return + do i=1,k + fact=fact*i + end do + return + end +c + FUNCTION gamm(xx) + DOUBLE PRECISION gamm,xx +c Returns the value Gamma(xx) for xx > 0. + INTEGER j + DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, + * 24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, + * -.5395239384953d-5,2.5066282746310005d0/ + x=xx + y=x + tmp=x+5.5d0 + tmp=(x+0.5d0)*log(tmp)-tmp + ser=1.000000000190015d0 + do j=1,6 + y=y+1.d0 + ser=ser+cof(j)/y + end do + gamm=exp(tmp)*(stp*ser/x) + return + END +c +c +c +c PLASMA DISPERSION FUNCTION Z of complex argument +c Z(z) = i sqrt(pi) w(z) +c Function w(z) from: +c algorithm 680, collected algorithms from acm. +c this work published in transactions on mathematical software, +c vol. 16, no. 1, pp. 47. +c + subroutine zetac (xi, yi, zr, zi, iflag) +c +c given a complex number z = (xi,yi), this subroutine computes +c the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z), +c where erfc is the complex complementary error-function and i +c means sqrt(-1). +c the accuracy of the algorithm for z in the 1st and 2nd quadrant +c is 14 significant digits; in the 3rd and 4th it is 13 significant +c digits outside a circular region with radius 0.126 around a zero +c of the function. +c all real variables in the program are double precision. +c +c +c the code contains a few compiler-dependent parameters : +c rmaxreal = the maximum value of rmaxreal equals the root of +c rmax = the largest number which can still be +c implemented on the computer in double precision +c floating-point arithmetic +c rmaxexp = ln(rmax) - ln(2) +c rmaxgoni = the largest possible argument of a double precision +c goniometric function (dcos, dsin, ...) +c the reason why these parameters are needed as they are defined will +c be explained in the code by means of comments +c +c +c parameter list +c xi = real part of z +c yi = imaginary part of z +c u = real part of w(z) +c v = imaginary part of w(z) +c iflag = an error flag indicating whether overflow will +c occur or not; type integer; +c the values of this variable have the following +c meaning : +c iflag=0 : no error condition +c iflag=1 : overflow will occur, the routine +c becomes inactive +c xi, yi are the input-parameters +c u, v, iflag are the output-parameters +c +c furthermore the parameter factor equals 2/sqrt(pi) +c +c the routine is not underflow-protected but any variable can be +c put to 0 upon underflow; +c +c reference - gpm poppe, cmj wijers; more efficient computation of +c the complex error-function, acm trans. math. software. +c +* +* +* +* + implicit double precision (a-h, o-z) +* + parameter (factor = 1.12837916709551257388d0, + * rpi = 2.0d0/factor, + * rmaxreal = 0.5d+154, + * rmaxexp = 708.503061461606d0, + * rmaxgoni = 3.53711887601422d+15) +* + iflag=0 +* + xabs = dabs(xi) + yabs = dabs(yi) + x = xabs/6.3d0 + y = yabs/4.4d0 +* +c +c the following if-statement protects +c qrho = (x**2 + y**2) against overflow +c + if ((xabs.gt.rmaxreal).or.(yabs.gt.rmaxreal)) goto 100 +* + qrho = x**2 + y**2 +* + xabsq = xabs**2 + xquad = xabsq - yabs**2 + yquad = 2*xabs*yabs +* + if (qrho.lt.0.085264d0) then +c +c if (qrho.lt.0.085264d0) then the faddeeva-function is evaluated +c using a power-series (abramowitz/stegun, equation (7.1.5), p.297) +c n is the minimum number of terms needed to obtain the required +c accuracy +c + qrho = (1-0.85d0*y)*dsqrt(qrho) + n = idnint(6 + 72*qrho) + j = 2*n+1 + xsum = 1.0d0/j + ysum = 0.0d0 + do 10 i=n, 1, -1 + j = j - 2 + xaux = (xsum*xquad - ysum*yquad)/i + ysum = (xsum*yquad + ysum*xquad)/i + xsum = xaux + 1.0d0/j + 10 continue + u1 = -factor*(xsum*yabs + ysum*xabs) + 1.0d0 + v1 = factor*(xsum*xabs - ysum*yabs) + daux = dexp(-xquad) + u2 = daux*dcos(yquad) + v2 = -daux*dsin(yquad) +* + u = u1*u2 - v1*v2 + v = u1*v2 + v1*u2 +* + else +c +c if (qrho.gt.1.o) then w(z) is evaluated using the laplace +c continued fraction +c nu is the minimum number of terms needed to obtain the required +c accuracy +c +c if ((qrho.gt.0.085264d0).and.(qrho.lt.1.0)) then w(z) is evaluated +c by a truncated taylor expansion, where the laplace continued fraction +c is used to calculate the derivatives of w(z) +c kapn is the minimum number of terms in the taylor expansion needed +c to obtain the required accuracy +c nu is the minimum number of terms of the continued fraction needed +c to calculate the derivatives with the required accuracy +c +* + if (qrho.gt.1.0d0) then + h = 0.0d0 + kapn = 0 + qrho = dsqrt(qrho) + nu = idint(3 + (1442/(26*qrho+77))) + else + qrho = (1-y)*dsqrt(1-qrho) + h = 1.88d0*qrho + h2 = 2*h + kapn = idnint(7 + 34*qrho) + nu = idnint(16 + 26*qrho) + endif +* + if (h.gt.0.0d0) qlambda = h2**kapn +* + rx = 0.0d0 + ry = 0.0d0 + sx = 0.0d0 + sy = 0.0d0 +* + do 11 n=nu, 0, -1 + np1 = n + 1 + tx = yabs + h + np1*rx + ty = xabs - np1*ry + c = 0.5d0/(tx**2 + ty**2) + rx = c*tx + ry = c*ty + if ((h.gt.0.0d0).and.(n.le.kapn)) then + tx = qlambda + sx + sx = rx*tx - ry*sy + sy = ry*tx + rx*sy + qlambda = qlambda/h2 + endif + 11 continue +* + if (h.eq.0.0d0) then + u = factor*rx + v = factor*ry + else + u = factor*sx + v = factor*sy + end if +* + if (yabs.eq.0.0d0) u = dexp(-xabs**2) +* + end if +* +* +c +c evaluation of w(z) in the other quadrants +c +* + if (yi.lt.0.0d0) then +* + if (qrho.lt.0.085264d0) then + u2 = 2*u2 + v2 = 2*v2 + else + xquad = -xquad +* +c +c the following if-statement protects 2*exp(-z**2) +c against overflow +c + if ((yquad.gt.rmaxgoni).or. + * (xquad.gt.rmaxexp)) goto 100 +* + w1 = 2.0d0*dexp(xquad) + u2 = w1*dcos(yquad) + v2 = -w1*dsin(yquad) + end if +* + u = u2 - u + v = v2 - v + if (xi.gt.0.0d0) v = -v + else + if (xi.lt.0.0d0) v = -v + end if +* + zr = -v*rpi + zi = u*rpi +* + + return +* + 100 iflag=1 +* + return +* + end +c +c +c +* ====================================================================== +* nist guide to available math software. +* fullsource for module ei from package specfun. +* retrieved from netlib on fri mar 26 05:52:39 1999. +* ====================================================================== + subroutine calcei(arg,result,int) +c---------------------------------------------------------------------- +c +c this fortran 77 packet computes the exponential integrals ei(x), +c e1(x), and exp(-x)*ei(x) for real arguments x where +c +c integral (from t=-infinity to t=x) (exp(t)/t), x > 0, +c ei(x) = +c -integral (from t=-x to t=infinity) (exp(t)/t), x < 0, +c +c and where the first integral is a principal value integral. +c the packet contains three function type subprograms: ei, eone, +c and expei; and one subroutine type subprogram: calcei. the +c calling statements for the primary entries are +c +c y = ei(x), where x .ne. 0, +c +c y = eone(x), where x .gt. 0, +c and +c y = expei(x), where x .ne. 0, +c +c and where the entry points correspond to the functions ei(x), +c e1(x), and exp(-x)*ei(x), respectively. the routine calcei +c is intended for internal packet use only, all computations within +c the packet being concentrated in this routine. the function +c subprograms invoke calcei with the fortran statement +c call calcei(arg,result,int) +c where the parameter usage is as follows +c +c function parameters for calcei +c call arg result int +c +c ei(x) x .ne. 0 ei(x) 1 +c eone(x) x .gt. 0 -ei(-x) 2 +c expei(x) x .ne. 0 exp(-x)*ei(x) 3 +c---------------------------------------------------------------------- + integer i,int + double precision + 1 a,arg,b,c,d,exp40,e,ei,f,four,fourty,frac,half,one,p, + 2 plg,px,p037,p1,p2,q,qlg,qx,q1,q2,r,result,s,six,sump, + 3 sumq,t,three,twelve,two,two4,w,x,xbig,xinf,xmax,xmx0, + 4 x0,x01,x02,x11,y,ysq,zero + dimension a(7),b(6),c(9),d(9),e(10),f(10),p(10),q(10),r(10), + 1 s(9),p1(10),q1(9),p2(10),q2(9),plg(4),qlg(4),px(10),qx(10) +c---------------------------------------------------------------------- +c mathematical constants +c exp40 = exp(40) +c x0 = zero of ei +c x01/x11 + x02 = zero of ei to extra precision +c---------------------------------------------------------------------- + data zero,p037,half,one,two/0.0d0,0.037d0,0.5d0,1.0d0,2.0d0/, + 1 three,four,six,twelve,two4/3.0d0,4.0d0,6.0d0,12.d0,24.0d0/, + 2 fourty,exp40/40.0d0,2.3538526683701998541d17/, + 3 x01,x11,x02/381.5d0,1024.0d0,-5.1182968633365538008d-5/, + 4 x0/3.7250741078136663466d-1/ +c---------------------------------------------------------------------- +c machine-dependent constants +c---------------------------------------------------------------------- + data xinf/1.79d+308/,xmax/716.351d0/,xbig/701.84d0/ +c---------------------------------------------------------------------- +c coefficients for -1.0 <= x < 0.0 +c---------------------------------------------------------------------- + data a/1.1669552669734461083368d2, 2.1500672908092918123209d3, + 1 1.5924175980637303639884d4, 8.9904972007457256553251d4, + 2 1.5026059476436982420737d5,-1.4815102102575750838086d5, + 3 5.0196785185439843791020d0/ + data b/4.0205465640027706061433d1, 7.5043163907103936624165d2, + 1 8.1258035174768735759855d3, 5.2440529172056355429883d4, + 2 1.8434070063353677359298d5, 2.5666493484897117319268d5/ +c---------------------------------------------------------------------- +c coefficients for -4.0 <= x < -1.0 +c---------------------------------------------------------------------- + data c/3.828573121022477169108d-1, 1.107326627786831743809d+1, + 1 7.246689782858597021199d+1, 1.700632978311516129328d+2, + 2 1.698106763764238382705d+2, 7.633628843705946890896d+1, + 3 1.487967702840464066613d+1, 9.999989642347613068437d-1, + 4 1.737331760720576030932d-8/ + data d/8.258160008564488034698d-2, 4.344836335509282083360d+0, + 1 4.662179610356861756812d+1, 1.775728186717289799677d+2, + 2 2.953136335677908517423d+2, 2.342573504717625153053d+2, + 3 9.021658450529372642314d+1, 1.587964570758947927903d+1, + 4 1.000000000000000000000d+0/ +c---------------------------------------------------------------------- +c coefficients for x < -4.0 +c---------------------------------------------------------------------- + data e/1.3276881505637444622987d+2,3.5846198743996904308695d+4, + 1 1.7283375773777593926828d+5,2.6181454937205639647381d+5, + 2 1.7503273087497081314708d+5,5.9346841538837119172356d+4, + 3 1.0816852399095915622498d+4,1.0611777263550331766871d03, + 4 5.2199632588522572481039d+1,9.9999999999999999087819d-1/ + data f/3.9147856245556345627078d+4,2.5989762083608489777411d+5, + 1 5.5903756210022864003380d+5,5.4616842050691155735758d+5, + 2 2.7858134710520842139357d+5,7.9231787945279043698718d+4, + 3 1.2842808586627297365998d+4,1.1635769915320848035459d+3, + 4 5.4199632588522559414924d+1,1.0d0/ +c---------------------------------------------------------------------- +c coefficients for rational approximation to ln(x/a), |1-x/a| < .1 +c---------------------------------------------------------------------- + data plg/-2.4562334077563243311d+01,2.3642701335621505212d+02, + 1 -5.4989956895857911039d+02,3.5687548468071500413d+02/ + data qlg/-3.5553900764052419184d+01,1.9400230218539473193d+02, + 1 -3.3442903192607538956d+02,1.7843774234035750207d+02/ +c---------------------------------------------------------------------- +c coefficients for 0.0 < x < 6.0, +c ratio of chebyshev polynomials +c---------------------------------------------------------------------- + data p/-1.2963702602474830028590d01,-1.2831220659262000678155d03, + 1 -1.4287072500197005777376d04,-1.4299841572091610380064d06, + 2 -3.1398660864247265862050d05,-3.5377809694431133484800d08, + 3 3.1984354235237738511048d08,-2.5301823984599019348858d10, + 4 1.2177698136199594677580d10,-2.0829040666802497120940d11/ + data q/ 7.6886718750000000000000d01,-5.5648470543369082846819d03, + 1 1.9418469440759880361415d05,-4.2648434812177161405483d06, + 2 6.4698830956576428587653d07,-7.0108568774215954065376d08, + 3 5.4229617984472955011862d09,-2.8986272696554495342658d10, + 4 9.8900934262481749439886d10,-8.9673749185755048616855d10/ +c---------------------------------------------------------------------- +c j-fraction coefficients for 6.0 <= x < 12.0 +c---------------------------------------------------------------------- + data r/-2.645677793077147237806d00,-2.378372882815725244124d00, + 1 -2.421106956980653511550d01, 1.052976392459015155422d01, + 2 1.945603779539281810439d01,-3.015761863840593359165d01, + 3 1.120011024227297451523d01,-3.988850730390541057912d00, + 4 9.565134591978630774217d00, 9.981193787537396413219d-1/ + data s/ 1.598517957704779356479d-4, 4.644185932583286942650d00, + 1 3.697412299772985940785d02,-8.791401054875438925029d00, + 2 7.608194509086645763123d02, 2.852397548119248700147d01, + 3 4.731097187816050252967d02,-2.369210235636181001661d02, + 4 1.249884822712447891440d00/ +c---------------------------------------------------------------------- +c j-fraction coefficients for 12.0 <= x < 24.0 +c---------------------------------------------------------------------- + data p1/-1.647721172463463140042d00,-1.860092121726437582253d01, + 1 -1.000641913989284829961d01,-2.105740799548040450394d01, + 2 -9.134835699998742552432d-1,-3.323612579343962284333d01, + 3 2.495487730402059440626d01, 2.652575818452799819855d01, + 4 -1.845086232391278674524d00, 9.999933106160568739091d-1/ + data q1/ 9.792403599217290296840d01, 6.403800405352415551324d01, + 1 5.994932325667407355255d01, 2.538819315630708031713d02, + 2 4.429413178337928401161d01, 1.192832423968601006985d03, + 3 1.991004470817742470726d02,-1.093556195391091143924d01, + 4 1.001533852045342697818d00/ +c---------------------------------------------------------------------- +c j-fraction coefficients for x .ge. 24.0 +c---------------------------------------------------------------------- + data p2/ 1.75338801265465972390d02,-2.23127670777632409550d02, + 1 -1.81949664929868906455d01,-2.79798528624305389340d01, + 2 -7.63147701620253630855d00,-1.52856623636929636839d01, + 3 -7.06810977895029358836d00,-5.00006640413131002475d00, + 4 -3.00000000320981265753d00, 1.00000000000000485503d00/ + data q2/ 3.97845977167414720840d04, 3.97277109100414518365d00, + 1 1.37790390235747998793d02, 1.17179220502086455287d02, + 2 7.04831847180424675988d01,-1.20187763547154743238d01, + 3 -7.99243595776339741065d00,-2.99999894040324959612d00, + 4 1.99999999999048104167d00/ +c---------------------------------------------------------------------- + x = arg + if (x .eq. zero) then + ei = -xinf + if (int .eq. 2) ei = -ei + else if ((x .lt. zero) .or. (int .eq. 2)) then +c---------------------------------------------------------------------- +c calculate ei for negative argument or for e1. +c---------------------------------------------------------------------- + y = abs(x) + if (y .le. one) then + sump = a(7) * y + a(1) + sumq = y + b(1) + do 110 i = 2, 6 + sump = sump * y + a(i) + sumq = sumq * y + b(i) + 110 continue + ei = log(y) - sump / sumq + if (int .eq. 3) ei = ei * exp(y) + else if (y .le. four) then + w = one / y + sump = c(1) + sumq = d(1) + do 130 i = 2, 9 + sump = sump * w + c(i) + sumq = sumq * w + d(i) + 130 continue + ei = - sump / sumq + if (int .ne. 3) ei = ei * exp(-y) + else + if ((y .gt. xbig) .and. (int .lt. 3)) then + ei = zero + else + w = one / y + sump = e(1) + sumq = f(1) + do 150 i = 2, 10 + sump = sump * w + e(i) + sumq = sumq * w + f(i) + 150 continue + ei = -w * (one - w * sump / sumq ) + if (int .ne. 3) ei = ei * exp(-y) + end if + end if + if (int .eq. 2) ei = -ei + else if (x .lt. six) then +c---------------------------------------------------------------------- +c to improve conditioning, rational approximations are expressed +c in terms of chebyshev polynomials for 0 <= x < 6, and in +c continued fraction form for larger x. +c---------------------------------------------------------------------- + t = x + x + t = t / three - two + px(1) = zero + qx(1) = zero + px(2) = p(1) + qx(2) = q(1) + do 210 i = 2, 9 + px(i+1) = t * px(i) - px(i-1) + p(i) + qx(i+1) = t * qx(i) - qx(i-1) + q(i) + 210 continue + sump = half * t * px(10) - px(9) + p(10) + sumq = half * t * qx(10) - qx(9) + q(10) + frac = sump / sumq + xmx0 = (x - x01/x11) - x02 + if (abs(xmx0) .ge. p037) then + ei = log(x/x0) + xmx0 * frac + if (int .eq. 3) ei = exp(-x) * ei + else +c---------------------------------------------------------------------- +c special approximation to ln(x/x0) for x close to x0 +c---------------------------------------------------------------------- + y = xmx0 / (x + x0) + ysq = y*y + sump = plg(1) + sumq = ysq + qlg(1) + do 220 i = 2, 4 + sump = sump*ysq + plg(i) + sumq = sumq*ysq + qlg(i) + 220 continue + ei = (sump / (sumq*(x+x0)) + frac) * xmx0 + if (int .eq. 3) ei = exp(-x) * ei + end if + else if (x .lt. twelve) then + frac = zero + do 230 i = 1, 9 + frac = s(i) / (r(i) + x + frac) + 230 continue + ei = (r(10) + frac) / x + if (int .ne. 3) ei = ei * exp(x) + else if (x .le. two4) then + frac = zero + do 240 i = 1, 9 + frac = q1(i) / (p1(i) + x + frac) + 240 continue + ei = (p1(10) + frac) / x + if (int .ne. 3) ei = ei * exp(x) + else + if ((x .ge. xmax) .and. (int .lt. 3)) then + ei = xinf + else + y = one / x + frac = zero + do 250 i = 1, 9 + frac = q2(i) / (p2(i) + x + frac) + 250 continue + frac = p2(10) + frac + ei = y + y * y * frac + if (int .ne. 3) then + if (x .le. xmax-two4) then + ei = ei * exp(x) + else +c---------------------------------------------------------------------- +c calculation reformulated to avoid premature overflow +c---------------------------------------------------------------------- + ei = (ei * exp(x-fourty)) * exp40 + end if + end if + end if + end if + result = ei + return +c---------- last line of calcei ---------- + end + function ei(x) +c-------------------------------------------------------------------- +c +c this function program computes approximate values for the +c exponential integral ei(x), where x is real. +c +c author: w. j. cody +c +c latest modification: january 12, 1988 +c +c-------------------------------------------------------------------- + integer int + double precision ei, x, result +c-------------------------------------------------------------------- + int = 1 + call calcei(x,result,int) + ei = result + return +c---------- last line of ei ---------- + end + function expei(x) +c-------------------------------------------------------------------- +c +c this function program computes approximate values for the +c function exp(-x) * ei(x), where ei(x) is the exponential +c integral, and x is real. +c +c author: w. j. cody +c +c latest modification: january 12, 1988 +c +c-------------------------------------------------------------------- + integer int + double precision expei, x, result +c-------------------------------------------------------------------- + int = 3 + call calcei(x,result,int) + expei = result + return +c---------- last line of expei ---------- + end + function eone(x) +c-------------------------------------------------------------------- +c +c this function program computes approximate values for the +c exponential integral e1(x), where x is real. +c +c author: w. j. cody +c +c latest modification: january 12, 1988 +c +c-------------------------------------------------------------------- + integer int + double precision eone, x, result +c-------------------------------------------------------------------- + int = 2 + call calcei(x,result,int) + eone = result + return +c---------- last line of eone ---------- + end +c +c calcei3 = calcei for int=3 +c +* ====================================================================== + subroutine calcei3(arg,result) +c---------------------------------------------------------------------- +c +c this fortran 77 packet computes the exponential integrals ei(x), +c e1(x), and exp(-x)*ei(x) for real arguments x where +c +c integral (from t=-infinity to t=x) (exp(t)/t), x > 0, +c ei(x) = +c -integral (from t=-x to t=infinity) (exp(t)/t), x < 0, +c +c and where the first integral is a principal value integral. +c the packet contains three function type subprograms: ei, eone, +c and expei; and one subroutine type subprogram: calcei. the +c calling statements for the primary entries are +c +c y = ei(x), where x .ne. 0, +c +c y = eone(x), where x .gt. 0, +c and +c y = expei(x), where x .ne. 0, +c +c and where the entry points correspond to the functions ei(x), +c e1(x), and exp(-x)*ei(x), respectively. the routine calcei +c is intended for internal packet use only, all computations within +c the packet being concentrated in this routine. the function +c subprograms invoke calcei with the fortran statement +c call calcei(arg,result,int) +c where the parameter usage is as follows +c +c function parameters for calcei +c call arg result int +c +c ei(x) x .ne. 0 ei(x) 1 +c eone(x) x .gt. 0 -ei(-x) 2 +c expei(x) x .ne. 0 exp(-x)*ei(x) 3 +c---------------------------------------------------------------------- + integer i,int + double precision + 1 a,arg,b,c,d,exp40,e,ei,f,four,fourty,frac,half,one,p, + 2 plg,px,p037,p1,p2,q,qlg,qx,q1,q2,r,result,s,six,sump, + 3 sumq,t,three,twelve,two,two4,w,x,xbig,xinf,xmax,xmx0, + 4 x0,x01,x02,x11,y,ysq,zero + dimension a(7),b(6),c(9),d(9),e(10),f(10),p(10),q(10),r(10), + 1 s(9),p1(10),q1(9),p2(10),q2(9),plg(4),qlg(4),px(10),qx(10) +c---------------------------------------------------------------------- +c mathematical constants +c exp40 = exp(40) +c x0 = zero of ei +c x01/x11 + x02 = zero of ei to extra precision +c---------------------------------------------------------------------- + data zero,p037,half,one,two/0.0d0,0.037d0,0.5d0,1.0d0,2.0d0/, + 1 three,four,six,twelve,two4/3.0d0,4.0d0,6.0d0,12.d0,24.0d0/, + 2 fourty,exp40/40.0d0,2.3538526683701998541d17/, + 3 x01,x11,x02/381.5d0,1024.0d0,-5.1182968633365538008d-5/, + 4 x0/3.7250741078136663466d-1/ +c---------------------------------------------------------------------- +c machine-dependent constants +c---------------------------------------------------------------------- + data xinf/1.79d+308/,xmax/716.351d0/,xbig/701.84d0/ +c---------------------------------------------------------------------- +c coefficients for -1.0 <= x < 0.0 +c---------------------------------------------------------------------- + data a/1.1669552669734461083368d2, 2.1500672908092918123209d3, + 1 1.5924175980637303639884d4, 8.9904972007457256553251d4, + 2 1.5026059476436982420737d5,-1.4815102102575750838086d5, + 3 5.0196785185439843791020d0/ + data b/4.0205465640027706061433d1, 7.5043163907103936624165d2, + 1 8.1258035174768735759855d3, 5.2440529172056355429883d4, + 2 1.8434070063353677359298d5, 2.5666493484897117319268d5/ +c---------------------------------------------------------------------- +c coefficients for -4.0 <= x < -1.0 +c---------------------------------------------------------------------- + data c/3.828573121022477169108d-1, 1.107326627786831743809d+1, + 1 7.246689782858597021199d+1, 1.700632978311516129328d+2, + 2 1.698106763764238382705d+2, 7.633628843705946890896d+1, + 3 1.487967702840464066613d+1, 9.999989642347613068437d-1, + 4 1.737331760720576030932d-8/ + data d/8.258160008564488034698d-2, 4.344836335509282083360d+0, + 1 4.662179610356861756812d+1, 1.775728186717289799677d+2, + 2 2.953136335677908517423d+2, 2.342573504717625153053d+2, + 3 9.021658450529372642314d+1, 1.587964570758947927903d+1, + 4 1.000000000000000000000d+0/ +c---------------------------------------------------------------------- +c coefficients for x < -4.0 +c---------------------------------------------------------------------- + data e/1.3276881505637444622987d+2,3.5846198743996904308695d+4, + 1 1.7283375773777593926828d+5,2.6181454937205639647381d+5, + 2 1.7503273087497081314708d+5,5.9346841538837119172356d+4, + 3 1.0816852399095915622498d+4,1.0611777263550331766871d03, + 4 5.2199632588522572481039d+1,9.9999999999999999087819d-1/ + data f/3.9147856245556345627078d+4,2.5989762083608489777411d+5, + 1 5.5903756210022864003380d+5,5.4616842050691155735758d+5, + 2 2.7858134710520842139357d+5,7.9231787945279043698718d+4, + 3 1.2842808586627297365998d+4,1.1635769915320848035459d+3, + 4 5.4199632588522559414924d+1,1.0d0/ +c---------------------------------------------------------------------- +c coefficients for rational approximation to ln(x/a), |1-x/a| < .1 +c---------------------------------------------------------------------- + data plg/-2.4562334077563243311d+01,2.3642701335621505212d+02, + 1 -5.4989956895857911039d+02,3.5687548468071500413d+02/ + data qlg/-3.5553900764052419184d+01,1.9400230218539473193d+02, + 1 -3.3442903192607538956d+02,1.7843774234035750207d+02/ +c---------------------------------------------------------------------- +c coefficients for 0.0 < x < 6.0, +c ratio of chebyshev polynomials +c---------------------------------------------------------------------- + data p/-1.2963702602474830028590d01,-1.2831220659262000678155d03, + 1 -1.4287072500197005777376d04,-1.4299841572091610380064d06, + 2 -3.1398660864247265862050d05,-3.5377809694431133484800d08, + 3 3.1984354235237738511048d08,-2.5301823984599019348858d10, + 4 1.2177698136199594677580d10,-2.0829040666802497120940d11/ + data q/ 7.6886718750000000000000d01,-5.5648470543369082846819d03, + 1 1.9418469440759880361415d05,-4.2648434812177161405483d06, + 2 6.4698830956576428587653d07,-7.0108568774215954065376d08, + 3 5.4229617984472955011862d09,-2.8986272696554495342658d10, + 4 9.8900934262481749439886d10,-8.9673749185755048616855d10/ +c---------------------------------------------------------------------- +c j-fraction coefficients for 6.0 <= x < 12.0 +c---------------------------------------------------------------------- + data r/-2.645677793077147237806d00,-2.378372882815725244124d00, + 1 -2.421106956980653511550d01, 1.052976392459015155422d01, + 2 1.945603779539281810439d01,-3.015761863840593359165d01, + 3 1.120011024227297451523d01,-3.988850730390541057912d00, + 4 9.565134591978630774217d00, 9.981193787537396413219d-1/ + data s/ 1.598517957704779356479d-4, 4.644185932583286942650d00, + 1 3.697412299772985940785d02,-8.791401054875438925029d00, + 2 7.608194509086645763123d02, 2.852397548119248700147d01, + 3 4.731097187816050252967d02,-2.369210235636181001661d02, + 4 1.249884822712447891440d00/ +c---------------------------------------------------------------------- +c j-fraction coefficients for 12.0 <= x < 24.0 +c---------------------------------------------------------------------- + data p1/-1.647721172463463140042d00,-1.860092121726437582253d01, + 1 -1.000641913989284829961d01,-2.105740799548040450394d01, + 2 -9.134835699998742552432d-1,-3.323612579343962284333d01, + 3 2.495487730402059440626d01, 2.652575818452799819855d01, + 4 -1.845086232391278674524d00, 9.999933106160568739091d-1/ + data q1/ 9.792403599217290296840d01, 6.403800405352415551324d01, + 1 5.994932325667407355255d01, 2.538819315630708031713d02, + 2 4.429413178337928401161d01, 1.192832423968601006985d03, + 3 1.991004470817742470726d02,-1.093556195391091143924d01, + 4 1.001533852045342697818d00/ +c---------------------------------------------------------------------- +c j-fraction coefficients for x .ge. 24.0 +c---------------------------------------------------------------------- + data p2/ 1.75338801265465972390d02,-2.23127670777632409550d02, + 1 -1.81949664929868906455d01,-2.79798528624305389340d01, + 2 -7.63147701620253630855d00,-1.52856623636929636839d01, + 3 -7.06810977895029358836d00,-5.00006640413131002475d00, + 4 -3.00000000320981265753d00, 1.00000000000000485503d00/ + data q2/ 3.97845977167414720840d04, 3.97277109100414518365d00, + 1 1.37790390235747998793d02, 1.17179220502086455287d02, + 2 7.04831847180424675988d01,-1.20187763547154743238d01, + 3 -7.99243595776339741065d00,-2.99999894040324959612d00, + 4 1.99999999999048104167d00/ +c---------------------------------------------------------------------- + data int/ 3/ + x = arg + if (x .eq. zero) then + ei = -xinf + else if ((x .lt. zero)) then +c---------------------------------------------------------------------- +c calculate ei for negative argument or for e1. +c---------------------------------------------------------------------- + y = abs(x) + if (y .le. one) then + sump = a(7) * y + a(1) + sumq = y + b(1) + do 110 i = 2, 6 + sump = sump * y + a(i) + sumq = sumq * y + b(i) + 110 continue + ei = (log(y) - sump / sumq ) * exp(y) + else if (y .le. four) then + w = one / y + sump = c(1) + sumq = d(1) + do 130 i = 2, 9 + sump = sump * w + c(i) + sumq = sumq * w + d(i) + 130 continue + ei = - sump / sumq + else + w = one / y + sump = e(1) + sumq = f(1) + do 150 i = 2, 10 + sump = sump * w + e(i) + sumq = sumq * w + f(i) + 150 continue + ei = -w * (one - w * sump / sumq ) + end if + else if (x .lt. six) then +c---------------------------------------------------------------------- +c to improve conditioning, rational approximations are expressed +c in terms of chebyshev polynomials for 0 <= x < 6, and in +c continued fraction form for larger x. +c---------------------------------------------------------------------- + t = x + x + t = t / three - two + px(1) = zero + qx(1) = zero + px(2) = p(1) + qx(2) = q(1) + do 210 i = 2, 9 + px(i+1) = t * px(i) - px(i-1) + p(i) + qx(i+1) = t * qx(i) - qx(i-1) + q(i) + 210 continue + sump = half * t * px(10) - px(9) + p(10) + sumq = half * t * qx(10) - qx(9) + q(10) + frac = sump / sumq + xmx0 = (x - x01/x11) - x02 + if (abs(xmx0) .ge. p037) then + ei = exp(-x) * ( log(x/x0) + xmx0 * frac ) + else +c---------------------------------------------------------------------- +c special approximation to ln(x/x0) for x close to x0 +c---------------------------------------------------------------------- + y = xmx0 / (x + x0) + ysq = y*y + sump = plg(1) + sumq = ysq + qlg(1) + do 220 i = 2, 4 + sump = sump*ysq + plg(i) + sumq = sumq*ysq + qlg(i) + 220 continue + ei = exp(-x) * (sump / (sumq*(x+x0)) + frac) * xmx0 + end if + else if (x .lt. twelve) then + frac = zero + do 230 i = 1, 9 + frac = s(i) / (r(i) + x + frac) + 230 continue + ei = (r(10) + frac) / x + else if (x .le. two4) then + frac = zero + do 240 i = 1, 9 + frac = q1(i) / (p1(i) + x + frac) + 240 continue + ei = (p1(10) + frac) / x + else + y = one / x + frac = zero + do 250 i = 1, 9 + frac = q2(i) / (p2(i) + x + frac) + 250 continue + frac = p2(10) + frac + ei = y + y * y * frac + end if + result = ei + return +c---------- last line of calcei ---------- + end +c +c +c +c + subroutine calerf(arg,result,jint) +c------------------------------------------------------------------ +c +c this packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) +c for a real argument x. it contains three function type +c subprograms: erf, erfc, and erfcx (or derf, derfc, and derfcx), +c and one subroutine type subprogram, calerf. the calling +c statements for the primary entries are: +c +c y=erf(x) (or y=derf(x)), +c +c y=erfc(x) (or y=derfc(x)), +c and +c y=erfcx(x) (or y=derfcx(x)). +c +c the routine calerf is intended for internal packet use only, +c all computations within the packet being concentrated in this +c routine. the function subprograms invoke calerf with the +c statement +c +c call calerf(arg,result,jint) +c +c where the parameter usage is as follows +c +c function parameters for calerf +c call arg result jint +c +c erf(arg) any real argument erf(arg) 0 +c erfc(arg) abs(arg) .lt. xbig erfc(arg) 1 +c erfcx(arg) xneg .lt. arg .lt. xmax erfcx(arg) 2 +c +c******************************************************************* +c +c error returns +c +c the program returns erfc = 0 for arg .ge. xbig; +c +c erfcx = xinf for arg .lt. xneg; +c and +c erfcx = 0 for arg .ge. xmax. +c +c +c intrinsic functions required are: +c +c abs, aint, exp +c +c +c author: w. j. cody +c mathematics and computer science division +c argonne national laboratory +c argonne, il 60439 +c +c latest modification: march 19, 1990 +c +c------------------------------------------------------------------ + integer i,jint + double precision + 1 a,arg,b,c,d,del,four,half,p,one,q,result,sixten,sqrpi, + 2 two,thresh,x,xbig,xden,xhuge,xinf,xmax,xneg,xnum,xsmall, + 3 y,ysq,zero + dimension a(5),b(4),c(9),d(8),p(6),q(5) +c------------------------------------------------------------------ +c mathematical constants +c------------------------------------------------------------------ + data four,one,half,two,zero/4.0d0,1.0d0,0.5d0,2.0d0,0.0d0/, + 1 sqrpi/5.6418958354775628695d-1/,thresh/0.46875d0/, + 2 sixten/16.0d0/ +c------------------------------------------------------------------ +c machine-dependent constants +c------------------------------------------------------------------ + data xinf,xneg,xsmall/1.79d308,-26.628d0,1.11d-16/, + 1 xbig,xhuge,xmax/26.543d0,6.71d7,2.53d307/ +c------------------------------------------------------------------ +c coefficients for approximation to erf in first interval +c------------------------------------------------------------------ + data a/3.16112374387056560d00,1.13864154151050156d02, + 1 3.77485237685302021d02,3.20937758913846947d03, + 2 1.85777706184603153d-1/ + data b/2.36012909523441209d01,2.44024637934444173d02, + 1 1.28261652607737228d03,2.84423683343917062d03/ +c------------------------------------------------------------------ +c coefficients for approximation to erfc in second interval +c------------------------------------------------------------------ + data c/5.64188496988670089d-1,8.88314979438837594d0, + 1 6.61191906371416295d01,2.98635138197400131d02, + 2 8.81952221241769090d02,1.71204761263407058d03, + 3 2.05107837782607147d03,1.23033935479799725d03, + 4 2.15311535474403846d-8/ + data d/1.57449261107098347d01,1.17693950891312499d02, + 1 5.37181101862009858d02,1.62138957456669019d03, + 2 3.29079923573345963d03,4.36261909014324716d03, + 3 3.43936767414372164d03,1.23033935480374942d03/ +c------------------------------------------------------------------ +c coefficients for approximation to erfc in third interval +c------------------------------------------------------------------ + data p/3.05326634961232344d-1,3.60344899949804439d-1, + 1 1.25781726111229246d-1,1.60837851487422766d-2, + 2 6.58749161529837803d-4,1.63153871373020978d-2/ + data q/2.56852019228982242d00,1.87295284992346047d00, + 1 5.27905102951428412d-1,6.05183413124413191d-2, + 2 2.33520497626869185d-3/ +c------------------------------------------------------------------ + x = arg + y = abs(x) + if (y .le. thresh) then +c------------------------------------------------------------------ +c evaluate erf for |x| <= 0.46875 +c------------------------------------------------------------------ + ysq = zero + if (y .gt. xsmall) ysq = y * y + xnum = a(5)*ysq + xden = ysq + do 20 i = 1, 3 + xnum = (xnum + a(i)) * ysq + xden = (xden + b(i)) * ysq + 20 continue + result = x * (xnum + a(4)) / (xden + b(4)) + if (jint .ne. 0) result = one - result + if (jint .eq. 2) result = exp(ysq) * result + go to 800 +c------------------------------------------------------------------ +c evaluate erfc for 0.46875 <= |x| <= 4.0 +c------------------------------------------------------------------ + else if (y .le. four) then + xnum = c(9)*y + xden = y + do 120 i = 1, 7 + xnum = (xnum + c(i)) * y + xden = (xden + d(i)) * y + 120 continue + result = (xnum + c(8)) / (xden + d(8)) + if (jint .ne. 2) then + ysq = aint(y*sixten)/sixten + del = (y-ysq)*(y+ysq) + result = exp(-ysq*ysq) * exp(-del) * result + end if +c------------------------------------------------------------------ +c evaluate erfc for |x| > 4.0 +c------------------------------------------------------------------ + else + result = zero + if (y .ge. xbig) then + if ((jint .ne. 2) .or. (y .ge. xmax)) go to 300 + if (y .ge. xhuge) then + result = sqrpi / y + go to 300 + end if + end if + ysq = one / (y * y) + xnum = p(6)*ysq + xden = ysq + do 240 i = 1, 4 + xnum = (xnum + p(i)) * ysq + xden = (xden + q(i)) * ysq + 240 continue + result = ysq *(xnum + p(5)) / (xden + q(5)) + result = (sqrpi - result) / y + if (jint .ne. 2) then + ysq = aint(y*sixten)/sixten + del = (y-ysq)*(y+ysq) + result = exp(-ysq*ysq) * exp(-del) * result + end if + end if +c------------------------------------------------------------------ +c fix up for negative argument, erf, etc. +c------------------------------------------------------------------ + 300 if (jint .eq. 0) then + result = (half - result) + half + if (x .lt. zero) result = -result + else if (jint .eq. 1) then + if (x .lt. zero) result = two - result + else + if (x .lt. zero) then + if (x .lt. xneg) then + result = xinf + else + ysq = aint(x*sixten)/sixten + del = (x-ysq)*(x+ysq) + y = exp(ysq*ysq) * exp(del) + result = (y+y) - result + end if + end if + end if + 800 return +c---------- last card of calerf ---------- + end +c + double precision function derf(x) +c-------------------------------------------------------------------- +c +c this subprogram computes approximate values for erf(x). +c (see comments heading calerf). +c +c author/date: w. j. cody, january 8, 1985 +c +c-------------------------------------------------------------------- + integer jint + double precision x, result +c------------------------------------------------------------------ + jint = 0 + call calerf(x,result,jint) + derf = result + return +c---------- last card of derf ---------- + end +c + double precision function derfc(x) +c-------------------------------------------------------------------- +c +c this subprogram computes approximate values for erfc(x). +c (see comments heading calerf). +c +c author/date: w. j. cody, january 8, 1985 +c +c-------------------------------------------------------------------- + integer jint + double precision x, result +c------------------------------------------------------------------ + jint = 1 + call calerf(x,result,jint) + derfc = result + return +c---------- last card of derfc ---------- + end +c + double precision function derfcx(x) +c------------------------------------------------------------------ +c +c this subprogram computes approximate values for exp(x*x) * erfc(x). +c (see comments heading calerf). +c +c author/date: w. j. cody, march 30, 1987 +c +c------------------------------------------------------------------ + double precision x, result + integer jint +c------------------------------------------------------------------ + jint = 2 + call calerf(x,result,jint) + derfcx = result + return +c---------- last card of derfcx ---------- + end +c +c +c Integration routine dqags.f from quadpack and dependencies: BEGIN +c +c + subroutine dqags(f,a,b,epsabs,epsrel,result,abserr,neval,ier, + * limit,lenw,last,iwork,work) +c***begin prologue dqags +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c (end-point) singularities, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & prog. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for integral and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more sub- +c divisions by increasing the value of limit +c (and taking the according dimension +c adjustments into account. however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is detec- +c ted, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour +c occurs at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. it is presumed that +c the requested tolerance cannot be +c achieved, and that the returned result is +c the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28) +c or limit.lt.1 or lenw.lt.limit*4. +c result, abserr, neval, last are set to +c zero.except when limit or lenw is invalid, +c iwork(1), work(limit*2+1) and +c work(limit*3+1) are set to zero, work(1) +c is set to a and work(limit+1) to b. +c +c dimensioning parameters +c limit - integer +c dimensioning parameter for iwork +c limit determines the maximum number of subintervals +c in the partition of the given integration interval +c (a,b), limit.ge.1. +c if limit.lt.1, the routine will end with ier = 6. +c +c lenw - integer +c dimensioning parameter for work +c lenw must be at least limit*4. +c if lenw.lt.limit*4, the routine will end +c with ier = 6. +c +c last - integer +c on return, last equals the number of subintervals +c produced in the subdivision process, detemines the +c number of significant elements actually in the work +c arrays. +c +c work arrays +c iwork - integer +c vector of dimension at least limit, the first k +c elements of which contain pointers +c to the error estimates over the subintervals +c such that work(limit*3+iwork(1)),... , +c work(limit*3+iwork(k)) form a decreasing +c sequence, with k = last if last.le.(limit/2+2), +c and k = limit+1-last otherwise +c +c work - double precision +c vector of dimension at least lenw +c on return +c work(1), ..., work(last) contain the left +c end-points of the subintervals in the +c partition of (a,b), +c work(limit+1), ..., work(limit+last) contain +c the right end-points, +c work(limit*2+1), ..., work(limit*2+last) contain +c the integral approximations over the subintervals, +c work(limit*3+1), ..., work(limit*3+last) +c contain the error estimates. +c +c***references (none) +c***routines called dqagse,xerror +c***end prologue dqags +c +c + double precision a,abserr,b,epsabs,epsrel,f,result,work + integer ier,iwork,last,lenw,limit,lvl,l1,l2,l3,neval +c + dimension iwork(limit),work(lenw) +c + external f +c +c check validity of limit and lenw. +c +c***first executable statement dqags + ier = 6 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +c +c prepare call for dqagse. +c + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +c + call dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, + * ier,work(1),work(l1),work(l2),work(l3),iwork,last) +c +c call error handler if necessary. +c + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) print*,'habnormal return from dqags',ier,lvl + return + end +c + subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, + * ier,alist,blist,rlist,elist,iord,last) +c***begin prologue dqagse +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c (end point) singularities, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c limit - integer +c gives an upperbound on the number of subintervals +c in the partition of (a,b) +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for integral and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more sub- +c divisions by increasing the value of limit +c (and taking the according dimension +c adjustments into account). however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is detec- +c ted, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour +c occurs at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is presumed that the requested +c tolerance cannot be achieved, and that the +c returned result is the best which can be +c obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28). +c result, abserr, neval, last, rlist(1), +c iord(1) and elist(1) are set to zero. +c alist(1) and blist(1) are set to a and b +c respectively. +c +c alist - double precision +c vector of dimension at least limit, the first +c last elements of which are the left end points +c of the subintervals in the partition of the +c given integration range (a,b) +c +c blist - double precision +c vector of dimension at least limit, the first +c last elements of which are the right end points +c of the subintervals in the partition of the given +c integration range (a,b) +c +c rlist - double precision +c vector of dimension at least limit, the first +c last elements of which are the integral +c approximations on the subintervals +c +c elist - double precision +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension at least limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., elist(iord(k)) +c form a decreasing sequence, with k = last +c if last.le.(limit/2+2), and k = limit+1-last +c otherwise +c +c last - integer +c number of subintervals actually produced in the +c subdivision process +c +c***references (none) +c***routines called d1mach,dqelg,dqk21,dqpsrt +c***end prologue dqagse +c + double precision a,abseps,abserr,alist,area,area1,area12,area2,a1, + * a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,d1mach,dmax1, + * dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, + * error1,error2,erro12,errsum,ertest,f,oflow,resabs,reseps,result, + * res3la,rlist,rlist2,small,uflow + integer id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, + * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 + logical extrap,noext +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * res3la(3),rlist(limit),rlist2(52) +c + external f +c +c the dimension of rlist2 is determined by the value of +c limexp in subroutine dqelg (rlist2 should be of dimension +c (limexp+2) at least). +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c rlist2 - array of dimension at least limexp+2 containing +c the part of the epsilon table which is still +c needed for further computations +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest error +c estimate +c errmax - elist(maxerr) +c erlast - error on the interval currently subdivided +c (before that subdivision has taken place) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left interval +c *****2 - variable for the right interval +c last - index for subdivision +c nres - number of calls to the extrapolation routine +c numrl2 - number of elements currently in rlist2. if an +c appropriate approximation to the compounded +c integral has been obtained it is put in +c rlist2(numrl2) after numrl2 has been increased +c by one. +c small - length of the smallest interval considered up +c to now, multiplied by 1.5 +c erlarg - sum of the errors over the intervals larger +c than the smallest interval considered up to now +c extrap - logical variable denoting that the routine is +c attempting to perform extrapolation i.e. before +c subdividing the smallest interval we try to +c decrease the value of erlarg. +c noext - logical variable denoting that extrapolation +c is no longer allowed (true value) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c oflow is the largest positive magnitude. +c +c***first executable statement dqagse + epmach = d1mach(4) +c +c test on validity of parameters +c ------------------------------ + ier = 0 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0d+00 + elist(1) = 0.0d+00 + if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) + * ier = 6 + if(ier.eq.6) go to 999 +c +c first approximation to the integral +c ----------------------------------- +c + uflow = d1mach(1) + oflow = d1mach(2) + ierro = 0 + call dqk21(f,a,b,result,abserr,defabs,resabs) +c +c test on accuracy. +c + dres = dabs(result) + errbnd = dmax1(epsabs,epsrel*dres) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. + * abserr.eq.0.0d+00) go to 140 +c +c initialization +c -------------- +c + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + numrl2 = 2 + ktmin = 0 + extrap = .false. + noext = .false. + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 +c +c main do-loop +c ------------ +c + do 90 last = 2,limit +c +c bisect the subinterval with the nrmax-th largest error +c estimate. +c + a1 = alist(maxerr) + b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk21(f,a1,b1,area1,error1,resabs,defab1) + call dqk21(f,a2,b2,area2,error2,resabs,defab2) +c +c improve previous approximations to integral +c and error and test for accuracy. +c + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 15 + if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) + * .or.erro12.lt.0.99d+00*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) +c +c test for roundoff error and eventually set error flag. +c + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +c +c set error flag in the case that the number of subintervals +c equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behaviour +c at a point of the integration range. +c + if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* + * (dabs(a2)+0.1d+04*uflow)) ier = 4 +c +c append the newly-created intervals to the list. +c + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine dqpsrt to maintain the descending ordering +c in the list of error estimates and select the subinterval +c with nrmax-th largest error estimate (to be bisected next). +c + 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +c ***jump out of do-loop + if(errsum.le.errbnd) go to 115 +c ***jump out of do-loop + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 +c +c test whether the interval to be bisected next is the +c smallest interval. +c + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 +c +c the smallest interval has the largest error. +c before bisecting decrease the sum of the errors over the +c larger intervals (erlarg) and perform extrapolation. +c + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do 50 k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +c ***jump out of do-loop + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + 50 continue +c +c perform extrapolation. +c + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = dmax1(epsabs,epsrel*dabs(reseps)) +c ***jump out of do-loop + if(abserr.le.ertest) go to 100 +c +c prepare bisection of the smallest interval. +c + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5d+00 + erlarg = errsum + go to 90 + 80 small = dabs(b-a)*0.375d+00 + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue +c +c set final result and error estimate. +c ------------------------------------ +c + 100 if(abserr.eq.oflow) go to 115 + if(ier+ierro.eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0d+00.and.area.ne.0.0d+00) go to 105 + if(abserr.gt.errsum) go to 115 + if(area.eq.0.0d+00) go to 130 + go to 110 + 105 if(abserr/dabs(result).gt.errsum/dabs(area)) go to 115 +c +c test on divergence. +c + 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. + * defabs*0.1d-01) go to 130 + if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03 + * .or.errsum.gt.dabs(area)) ier = 6 + go to 130 +c +c compute global integral sum. +c + 115 result = 0.0d+00 + do 120 k = 1,last + result = result+rlist(k) + 120 continue + abserr = errsum + 130 if(ier.gt.2) ier = ier-1 + 140 neval = 42*last-21 + 999 return + end +c + subroutine dqelg(n,epstab,result,abserr,res3la,nres) +c***begin prologue dqelg +c***refer to dqagie,dqagoe,dqagpe,dqagse +c***routines called d1mach +c***revision date 830518 (yymmdd) +c***keywords epsilon algorithm, convergence acceleration, +c extrapolation +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math & progr. div. - k.u.leuven +c***purpose the routine determines the limit of a given sequence of +c approximations, by means of the epsilon algorithm of +c p.wynn. an estimate of the absolute error is also given. +c the condensed epsilon table is computed. only those +c elements needed for the computation of the next diagonal +c are preserved. +c***description +c +c epsilon algorithm +c standard fortran subroutine +c double precision version +c +c parameters +c n - integer +c epstab(n) contains the new element in the +c first column of the epsilon table. +c +c epstab - double precision +c vector of dimension 52 containing the elements +c of the two lower diagonals of the triangular +c epsilon table. the elements are numbered +c starting at the right-hand corner of the +c triangle. +c +c result - double precision +c resulting approximation to the integral +c +c abserr - double precision +c estimate of the absolute error computed from +c result and the 3 previous results +c +c res3la - double precision +c vector of dimension 3 containing the last 3 +c results +c +c nres - integer +c number of calls to the routine +c (should be zero at first call) +c +c***end prologue dqelg +c + double precision abserr,dabs,delta1,delta2,delta3,dmax1,d1mach, + * epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, + * oflow,res,result,res3la,ss,tol1,tol2,tol3 + integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm,nres,num + dimension epstab(52),res3la(3) +c +c list of major variables +c ----------------------- +c +c e0 - the 4 elements on which the computation of a new +c e1 element in the epsilon table is based +c e2 +c e3 e0 +c e3 e1 new +c e2 +c newelm - number of elements to be computed in the new +c diagonal +c error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) +c result - the element in the new diagonal with least value +c of error +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c oflow is the largest positive magnitude. +c limexp is the maximum number of elements the epsilon +c table can contain. if this number is reached, the upper +c diagonal of the epsilon table is deleted. +c +c***first executable statement dqelg + epmach = d1mach(4) + oflow = d1mach(2) + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n.lt.3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + do 40 i = 1,newelm + k2 = k1-1 + k3 = k1-2 + res = epstab(k1+2) + e0 = epstab(k3) + e1 = epstab(k2) + e2 = res + e1abs = dabs(e1) + delta2 = e2-e1 + err2 = dabs(delta2) + tol2 = dmax1(dabs(e2),e1abs)*epmach + delta3 = e1-e0 + err3 = dabs(delta3) + tol3 = dmax1(e1abs,dabs(e0))*epmach + if(err2.gt.tol2.or.err3.gt.tol3) go to 10 +c +c if e0, e1 and e2 are equal to within machine +c accuracy, convergence is assumed. +c result = e2 +c abserr = abs(e1-e0)+abs(e2-e1) +c + result = res + abserr = err2+err3 +c ***jump out of do-loop + go to 100 + 10 e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = dabs(delta1) + tol1 = dmax1(e1abs,dabs(e3))*epmach +c +c if two elements are very close to each other, omit +c a part of the table by adjusting the value of n +c + if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 + ss = 0.1d+01/delta1+0.1d+01/delta2-0.1d+01/delta3 + epsinf = dabs(ss*e1) +c +c test to detect irregular behaviour in the table, and +c eventually omit a part of the table adjusting the value +c of n. +c + if(epsinf.gt.0.1d-03) go to 30 + 20 n = i+i-1 +c ***jump out of do-loop + go to 50 +c +c compute a new element and eventually adjust +c the value of result. +c + 30 res = e1+0.1d+01/ss + epstab(k1) = res + k1 = k1-2 + error = err2+dabs(res-e2)+err3 + if(error.gt.abserr) go to 40 + abserr = error + result = res + 40 continue +c +c shift the table. +c + 50 if(n.eq.limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2.eq.num) ib = 2 + ie = newelm+1 + do 60 i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + 60 continue + if(num.eq.n) go to 80 + indx = num-n+1 + do 70 i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + 70 continue + 80 if(nres.ge.4) go to 90 + res3la(nres) = result + abserr = oflow + go to 100 +c +c compute error estimate +c + 90 abserr = dabs(result-res3la(3))+dabs(result-res3la(2)) + * +dabs(result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result + 100 abserr = dmax1(abserr,0.5d+01*epmach*dabs(result)) + return + end +c + subroutine dqk21(f,a,b,result,abserr,resabs,resasc) +c***begin prologue dqk21 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 21-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b), with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 21-point +c kronrod rule (resk) obtained by optimal addition +c of abscissae to the 10-point gauss rule (resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk21 +c + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, + * resg,resk,reskh,result,uflow,wg,wgk,xgk + integer j,jtw,jtwm1 + external f +c + dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 21-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 10-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 10-point gauss rule +c +c wgk - weights of the 21-point kronrod rule +c +c wg - weights of the 10-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0666713443 0868813759 3568809893 332 d0 / + data wg ( 2) / 0.1494513491 5058059314 5776339657 697 d0 / + data wg ( 3) / 0.2190863625 1598204399 5534934228 163 d0 / + data wg ( 4) / 0.2692667193 0999635509 1226921569 469 d0 / + data wg ( 5) / 0.2955242247 1475287017 3892994651 338 d0 / +c + data xgk ( 1) / 0.9956571630 2580808073 5527280689 003 d0 / + data xgk ( 2) / 0.9739065285 1717172007 7964012084 452 d0 / + data xgk ( 3) / 0.9301574913 5570822600 1207180059 508 d0 / + data xgk ( 4) / 0.8650633666 8898451073 2096688423 493 d0 / + data xgk ( 5) / 0.7808177265 8641689706 3717578345 042 d0 / + data xgk ( 6) / 0.6794095682 9902440623 4327365114 874 d0 / + data xgk ( 7) / 0.5627571346 6860468333 9000099272 694 d0 / + data xgk ( 8) / 0.4333953941 2924719079 9265943165 784 d0 / + data xgk ( 9) / 0.2943928627 0146019813 1126603103 866 d0 / + data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 / + data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0116946388 6737187427 8064396062 192 d0 / + data wgk ( 2) / 0.0325581623 0796472747 8818972459 390 d0 / + data wgk ( 3) / 0.0547558965 7435199603 1381300244 580 d0 / + data wgk ( 4) / 0.0750396748 1091995276 7043140916 190 d0 / + data wgk ( 5) / 0.0931254545 8369760553 5065465083 366 d0 / + data wgk ( 6) / 0.1093871588 0229764189 9210590325 805 d0 / + data wgk ( 7) / 0.1234919762 6206585107 7958109831 074 d0 / + data wgk ( 8) / 0.1347092173 1147332592 8054001771 707 d0 / + data wgk ( 9) / 0.1427759385 7706008079 7094273138 717 d0 / + data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 / + data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 10-point gauss formula +c resk - result of the 21-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk21 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 21-point kronrod approximation to +c the integral, and estimate the absolute error. +c + resg = 0.0d+00 + fc = f(centr) + resk = wgk(11)*fc + resabs = dabs(resk) + do 10 j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc) + fval2 = f(centr+absc) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(11)*dabs(fc-reskh) + do 20 j=1,10 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end +c + subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) +c***begin prologue dqpsrt +c***refer to dqage,dqagie,dqagpe,dqawse +c***routines called (none) +c***revision date 810101 (yymmdd) +c***keywords sequential sorting +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose this routine maintains the descending ordering in the +c list of the local error estimated resulting from the +c interval subdivision process. at each call two error +c estimates are inserted using the sequential search +c method, top-down for the largest error estimate and +c bottom-up for the smallest error estimate. +c***description +c +c ordering routine +c standard fortran subroutine +c double precision version +c +c parameters (meaning at output) +c limit - integer +c maximum number of error estimates the list +c can contain +c +c last - integer +c number of error estimates currently in the list +c +c maxerr - integer +c maxerr points to the nrmax-th largest error +c estimate currently in the list +c +c ermax - double precision +c nrmax-th largest error estimate +c ermax = elist(maxerr) +c +c elist - double precision +c vector of dimension last containing +c the error estimates +c +c iord - integer +c vector of dimension last, the first k elements +c of which contain pointers to the error +c estimates, such that +c elist(iord(1)),..., elist(iord(k)) +c form a decreasing sequence, with +c k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c nrmax - integer +c maxerr = iord(nrmax) +c +c***end prologue dqpsrt +c + double precision elist,ermax,errmax,errmin + integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, + * nrmax + dimension elist(last),iord(last) +c +c check whether the list contains more than +c two error estimates. +c +c***first executable statement dqpsrt + if(last.gt.2) go to 10 + iord(1) = 1 + iord(2) = 2 + go to 90 +c +c this part of the routine is only executed if, due to a +c difficult integrand, subdivision increased the error +c estimate. in the normal case the insert procedure should +c start after the nrmax-th largest error estimate. +c + 10 errmax = elist(maxerr) + if(nrmax.eq.1) go to 30 + ido = nrmax-1 + do 20 i = 1,ido + isucc = iord(nrmax-1) +c ***jump out of do-loop + if(errmax.le.elist(isucc)) go to 30 + iord(nrmax) = isucc + nrmax = nrmax-1 + 20 continue +c +c compute the number of elements in the list to be maintained +c in descending order. this number depends on the number of +c subdivisions still allowed. +c + 30 jupbn = last + if(last.gt.(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) +c +c insert errmax by traversing the list top-down, +c starting comparison from the element elist(iord(nrmax+1)). +c + jbnd = jupbn-1 + ibeg = nrmax+1 + if(ibeg.gt.jbnd) go to 50 + do 40 i=ibeg,jbnd + isucc = iord(i) +c ***jump out of do-loop + if(errmax.ge.elist(isucc)) go to 60 + iord(i-1) = isucc + 40 continue + 50 iord(jbnd) = maxerr + iord(jupbn) = last + go to 90 +c +c insert errmin by traversing the list bottom-up. +c + 60 iord(i-1) = maxerr + k = jbnd + do 70 j=i,jbnd + isucc = iord(k) +c ***jump out of do-loop + if(errmin.lt.elist(isucc)) go to 80 + iord(k+1) = isucc + k = k-1 + 70 continue + iord(i) = last + go to 90 + 80 iord(k+1) = last +c +c set maxerr and ermax. +c + 90 maxerr = iord(nrmax) + ermax = elist(maxerr) + return + end +c + subroutine dqagi(f,bound,inf,epsabs,epsrel,result,abserr,neval, + * ier,limit,lenw,last,iwork,work) +c***begin prologue dqagi +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a1,h2a4a1 +c***keywords automatic integrator, infinite intervals, +c general-purpose, transformation, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. -k.u.leuven +c***purpose the routine calculates an approximation result to a given +c integral i = integral of f over (bound,+infinity) +c or i = integral of f over (-infinity,bound) +c or i = integral of f over (-infinity,+infinity) +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)). +c***description +c +c integration over infinite intervals +c standard fortran subroutine +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c bound - double precision +c finite bound of integration range +c (has no meaning if interval is doubly-infinite) +c +c inf - integer +c indicating the kind of integration range involved +c inf = 1 corresponds to (bound,+infinity), +c inf = -1 to (-infinity,bound), +c inf = 2 to (-infinity,+infinity). +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c - ier.gt.0 abnormal termination of the routine. the +c estimates for result and error are less +c reliable. it is assumed that the requested +c accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however, if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. if +c the position of a local difficulty can be +c determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is assumed that the requested tolerance +c cannot be achieved, and that the returned +c result is the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +c or limit.lt.1 or leniw.lt.limit*4. +c result, abserr, neval, last are set to +c zero. exept when limit or leniw is +c invalid, iwork(1), work(limit*2+1) and +c work(limit*3+1) are set to zero, work(1) +c is set to a and work(limit+1) to b. +c +c dimensioning parameters +c limit - integer +c dimensioning parameter for iwork +c limit determines the maximum number of subintervals +c in the partition of the given integration interval +c (a,b), limit.ge.1. +c if limit.lt.1, the routine will end with ier = 6. +c +c lenw - integer +c dimensioning parameter for work +c lenw must be at least limit*4. +c if lenw.lt.limit*4, the routine will end +c with ier = 6. +c +c last - integer +c on return, last equals the number of subintervals +c produced in the subdivision process, which +c determines the number of significant elements +c actually in the work arrays. +c +c work arrays +c iwork - integer +c vector of dimension at least limit, the first +c k elements of which contain pointers +c to the error estimates over the subintervals, +c such that work(limit*3+iwork(1)),... , +c work(limit*3+iwork(k)) form a decreasing +c sequence, with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c work - double precision +c vector of dimension at least lenw +c on return +c work(1), ..., work(last) contain the left +c end points of the subintervals in the +c partition of (a,b), +c work(limit+1), ..., work(limit+last) contain +c the right end points, +c work(limit*2+1), ...,work(limit*2+last) contain the +c integral approximations over the subintervals, +c work(limit*3+1), ..., work(limit*3) +c contain the error estimates. +c***references (none) +c***routines called dqagie,xerror +c***end prologue dqagi +c + double precision abserr,bound,epsabs,epsrel,f,result,work + integer ier,inf,iwork,last,lenw,limit,lvl,l1,l2,l3,neval +c + dimension iwork(limit),work(lenw) +c + external f +c +c check validity of limit and lenw. +c +c***first executable statement dqagi + ier = 6 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +c +c prepare call for dqagie. +c + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +c + call dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, + * neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +c +c call error handler if necessary. +c + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) print*,'habnormal return from dqagi' + return + end +c + subroutine dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, + * neval,ier,alist,blist,rlist,elist,iord,last) +c***begin prologue dqagie +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a1,h2a4a1 +c***keywords automatic integrator, infinite intervals, +c general-purpose, transformation, extrapolation, +c globally adaptive +c***author piessens,robert,appl. math & progr. div - k.u.leuven +c de doncker,elise,appl. math & progr. div - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c integral i = integral of f over (bound,+infinity) +c or i = integral of f over (-infinity,bound) +c or i = integral of f over (-infinity,+infinity), +c hopefully satisfying following claim for accuracy +c abs(i-result).le.max(epsabs,epsrel*abs(i)) +c***description +c +c integration over infinite intervals +c standard fortran subroutine +c +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c bound - double precision +c finite bound of integration range +c (has no meaning if interval is doubly-infinite) +c +c inf - double precision +c indicating the kind of integration range involved +c inf = 1 corresponds to (bound,+infinity), +c inf = -1 to (-infinity,bound), +c inf = 2 to (-infinity,+infinity). +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c limit - integer +c gives an upper bound on the number of subintervals +c in the partition of (a,b), limit.ge.1 +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c - ier.gt.0 abnormal termination of the routine. the +c estimates for result and error are less +c reliable. it is assumed that the requested +c accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however,if +c this yields no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulties. +c if the position of a local difficulty can +c be determined (e.g. singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used, which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c the error may be under-estimated. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 4 the algorithm does not converge. +c roundoff error is detected in the +c extrapolation table. +c it is assumed that the requested tolerance +c cannot be achieved, and that the returned +c result is the best which can be obtained. +c = 5 the integral is probably divergent, or +c slowly convergent. it must be noted that +c divergence can occur with any other value +c of ier. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c result, abserr, neval, last, rlist(1), +c elist(1) and iord(1) are set to zero. +c alist(1) and blist(1) are set to 0 +c and 1 respectively. +c +c alist - double precision +c vector of dimension at least limit, the first +c last elements of which are the left +c end points of the subintervals in the partition +c of the transformed integration range (0,1). +c +c blist - double precision +c vector of dimension at least limit, the first +c last elements of which are the right +c end points of the subintervals in the partition +c of the transformed integration range (0,1). +c +c rlist - double precision +c vector of dimension at least limit, the first +c last elements of which are the integral +c approximations on the subintervals +c +c elist - double precision +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., elist(iord(k)) +c form a decreasing sequence, with k = last +c if last.le.(limit/2+2), and k = limit+1-last +c otherwise +c +c last - integer +c number of subintervals actually produced +c in the subdivision process +c +c***references (none) +c***routines called d1mach,dqelg,dqk15i,dqpsrt +c***end prologue dqagie + double precision abseps,abserr,alist,area,area1,area12,area2,a1, + * a2,blist,boun,bound,b1,b2,correc,dabs,defabs,defab1,defab2, + * dmax1,dres,d1mach,elist,epmach,epsabs,epsrel,erlarg,erlast, + * errbnd,errmax,error1,error2,erro12,errsum,ertest,f,oflow,resabs, + * reseps,result,res3la,rlist,rlist2,small,uflow + integer id,ier,ierro,inf,iord,iroff1,iroff2,iroff3,jupbnd,k,ksgn, + * ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2 + logical extrap,noext +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * res3la(3),rlist(limit),rlist2(52) +c + external f +c +c the dimension of rlist2 is determined by the value of +c limexp in subroutine dqelg. +c +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c rlist2 - array of dimension at least (limexp+2), +c containing the part of the epsilon table +c wich is still needed for further computations +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest error +c estimate +c errmax - elist(maxerr) +c erlast - error on the interval currently subdivided +c (before that subdivision has taken place) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c nres - number of calls to the extrapolation routine +c numrl2 - number of elements currently in rlist2. if an +c appropriate approximation to the compounded +c integral has been obtained, it is put in +c rlist2(numrl2) after numrl2 has been increased +c by one. +c small - length of the smallest interval considered up +c to now, multiplied by 1.5 +c erlarg - sum of the errors over the intervals larger +c than the smallest interval considered up to now +c extrap - logical variable denoting that the routine +c is attempting to perform extrapolation. i.e. +c before subdividing the smallest interval we +c try to decrease the value of erlarg. +c noext - logical variable denoting that extrapolation +c is no longer allowed (true-value) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c oflow is the largest positive magnitude. +c +c***first executable statement dqagie + epmach = d1mach(4) +c +c test on validity of parameters +c ----------------------------- +c + ier = 0 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + alist(1) = 0.0d+00 + blist(1) = 0.1d+01 + rlist(1) = 0.0d+00 + elist(1) = 0.0d+00 + iord(1) = 0 + if(epsabs.le.0.0d+00.and.epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) + * ier = 6 + if(ier.eq.6) go to 999 +c +c +c first approximation to the integral +c ----------------------------------- +c +c determine the interval to be mapped onto (0,1). +c if inf = 2 the integral is computed as i = i1+i2, where +c i1 = integral of f over (-infinity,0), +c i2 = integral of f over (0,+infinity). +c + boun = bound + if(inf.eq.2) boun = 0.0d+00 + call dqk15i(f,boun,inf,0.0d+00,0.1d+01,result,abserr, + * defabs,resabs) +c +c test on accuracy +c + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + dres = dabs(result) + errbnd = dmax1(epsabs,epsrel*dres) + if(abserr.le.1.0d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. + * abserr.eq.0.0d+00) go to 130 +c +c initialization +c -------------- +c + uflow = d1mach(1) + oflow = d1mach(2) + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + ktmin = 0 + numrl2 = 2 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1d+01-0.5d+02*epmach)*defabs) ksgn = 1 +c +c main do-loop +c ------------ +c + do 90 last = 2,limit +c +c bisect the subinterval with nrmax-th largest error estimate. +c + a1 = alist(maxerr) + b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk15i(f,boun,inf,a1,b1,area1,error1,resabs,defab1) + call dqk15i(f,boun,inf,a2,b2,area2,error2,resabs,defab2) +c +c improve previous approximations to integral +c and error and test for accuracy. +c + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2)go to 15 + if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) + * .or.erro12.lt.0.99d+00*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) +c +c test for roundoff error and eventually set error flag. +c + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +c +c set error flag in the case that the number of +c subintervals equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behaviour +c at some points of the integration range. +c + if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* + * (dabs(a2)+0.1d+04*uflow)) ier = 4 +c +c append the newly-created intervals to the list. +c + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine dqpsrt to maintain the descending ordering +c in the list of error estimates and select the subinterval +c with nrmax-th largest error estimate (to be bisected next). +c + 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 115 + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 +c +c test whether the interval to be bisected next is the +c smallest interval. +c + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 +c +c the smallest interval has the largest error. +c before bisecting decrease the sum of the errors over the +c larger intervals (erlarg) and perform extrapolation. +c + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do 50 k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + 50 continue +c +c perform extrapolation. +c + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1d-02*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = dmax1(epsabs,epsrel*dabs(reseps)) + if(abserr.le.ertest) go to 100 +c +c prepare bisection of the smallest interval. +c + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5d+00 + erlarg = errsum + go to 90 + 80 small = 0.375d+00 + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue +c +c set final result and error estimate. +c ------------------------------------ +c + 100 if(abserr.eq.oflow) go to 115 + if((ier+ierro).eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0d+00.and.area.ne.0.0d+00)go to 105 + if(abserr.gt.errsum)go to 115 + if(area.eq.0.0d+00) go to 130 + go to 110 + 105 if(abserr/dabs(result).gt.errsum/dabs(area))go to 115 +c +c test on divergence +c + 110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. + * defabs*0.1d-01) go to 130 + if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03. + *or.errsum.gt.dabs(area)) ier = 6 + go to 130 +c +c compute global integral sum. +c + 115 result = 0.0d+00 + do 120 k = 1,last + result = result+rlist(k) + 120 continue + abserr = errsum + 130 neval = 30*last-15 + if(inf.eq.2) neval = 2*neval + if(ier.gt.2) ier=ier-1 + 999 return + end +c + subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc) +c***begin prologue dqk15i +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a3a2,h2a4a2 +c***keywords 15-point transformed gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the original (infinite integration range is mapped +c onto the interval (0,1) and (a,b) is a part of (0,1). +c it is the purpose to compute +c i = integral of transformed integrand over (a,b), +c j = integral of abs(transformed integrand) over (a,b). +c***description +c +c integration rule +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c fuction subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c boun - double precision +c finite bound of original integration +c range (set to zero if inf = +2) +c +c inf - integer +c if inf = -1, the original interval is +c (-infinity,bound), +c if inf = +1, the original interval is +c (bound,+infinity), +c if inf = +2, the original interval is +c (-infinity,+infinity) and +c the integral is computed as the sum of two +c integrals, one over (-infinity,0) and one over +c (0,+infinity). +c +c a - double precision +c lower limit for integration over subrange +c of (0,1) +c +c b - double precision +c upper limit for integration over subrange +c of (0,1) +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 15-point +c kronrod rule(resk) obtained by optimal addition +c of abscissae to the 7-point gauss rule(resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of +c abs((transformed integrand)-i/(b-a)) over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk15i +c + double precision a,absc,absc1,absc2,abserr,b,boun,centr,dabs,dinf, + * dmax1,dmin1,d1mach,epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth, + * resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,uflow,wg,wgk, + * xgk + integer inf,j + external f +c + dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8) +c +c the abscissae and weights are supplied for the interval +c (-1,1). because of symmetry only the positive abscissae and +c their corresponding weights are given. +c +c xgk - abscissae of the 15-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 7-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 7-point gauss rule +c +c wgk - weights of the 15-point kronrod rule +c +c wg - weights of the 7-point gauss rule, corresponding +c to the abscissae xgk(2), xgk(4), ... +c wg(1), wg(3), ... are set to zero. +c + data wg(1) / 0.0d0 / + data wg(2) / 0.1294849661 6886969327 0611432679 082d0 / + data wg(3) / 0.0d0 / + data wg(4) / 0.2797053914 8927666790 1467771423 780d0 / + data wg(5) / 0.0d0 / + data wg(6) / 0.3818300505 0511894495 0369775488 975d0 / + data wg(7) / 0.0d0 / + data wg(8) / 0.4179591836 7346938775 5102040816 327d0 / +c + data xgk(1) / 0.9914553711 2081263920 6854697526 329d0 / + data xgk(2) / 0.9491079123 4275852452 6189684047 851d0 / + data xgk(3) / 0.8648644233 5976907278 9712788640 926d0 / + data xgk(4) / 0.7415311855 9939443986 3864773280 788d0 / + data xgk(5) / 0.5860872354 6769113029 4144838258 730d0 / + data xgk(6) / 0.4058451513 7739716690 6606412076 961d0 / + data xgk(7) / 0.2077849550 0789846760 0689403773 245d0 / + data xgk(8) / 0.0000000000 0000000000 0000000000 000d0 / +c + data wgk(1) / 0.0229353220 1052922496 3732008058 970d0 / + data wgk(2) / 0.0630920926 2997855329 0700663189 204d0 / + data wgk(3) / 0.1047900103 2225018383 9876322541 518d0 / + data wgk(4) / 0.1406532597 1552591874 5189590510 238d0 / + data wgk(5) / 0.1690047266 3926790282 6583426598 550d0 / + data wgk(6) / 0.1903505780 6478540991 3256402421 014d0 / + data wgk(7) / 0.2044329400 7529889241 4161999234 649d0 / + data wgk(8) / 0.2094821410 8472782801 2999174891 714d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc* - abscissa +c tabsc* - transformed abscissa +c fval* - function value +c resg - result of the 7-point gauss formula +c resk - result of the 15-point kronrod formula +c reskh - approximation to the mean value of the transformed +c integrand over (a,b), i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk15i + epmach = d1mach(4) + uflow = d1mach(1) + dinf = min0(1,inf) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + tabsc1 = boun+dinf*(0.1d+01-centr)/centr + fval1 = f(tabsc1) + if(inf.eq.2) fval1 = fval1+f(-tabsc1) + fc = (fval1/centr)/centr +c +c compute the 15-point kronrod approximation to +c the integral, and estimate the error. +c + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = dabs(resk) + do 10 j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1d+01-absc1)/absc1 + tabsc2 = boun+dinf*(0.1d+01-absc2)/absc2 + fval1 = f(tabsc1) + fval2 = f(tabsc2) + if(inf.eq.2) fval1 = fval1+f(-tabsc1) + if(inf.eq.2) fval2 = fval2+f(-tabsc2) + fval1 = (fval1/absc1)/absc1 + fval2 = (fval2/absc2)/absc2 + fv1(j) = fval1 + fv2(j) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(j)*fsum + resabs = resabs+wgk(j)*(dabs(fval1)+dabs(fval2)) + 10 continue + reskh = resk*0.5d+00 + resasc = wgk(8)*dabs(fc-reskh) + do 20 j=1,7 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.d0) abserr = resasc* + * dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end +c +c + double precision function d1mach(i) + integer i +c +c double-precision machine constants +c d1mach( 1) = b**(emin-1), the smallest positive magnitude. +c d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude. +c d1mach( 3) = b**(-t), the smallest relative spacing. +c d1mach( 4) = b**(1-t), the largest relative spacing. +c d1mach( 5) = log10(b) +c + integer small(2) + integer large(2) + integer right(2) + integer diver(2) + integer log10(2) + integer sc, cray1(38), j + common /d9mach/ cray1 + save small, large, right, diver, log10, sc + double precision dmach(5) + equivalence (dmach(1),small(1)) + equivalence (dmach(2),large(1)) + equivalence (dmach(3),right(1)) + equivalence (dmach(4),diver(1)) + equivalence (dmach(5),log10(1)) +c this version adapts automatically to most current machines. +c r1mach can handle auto-double compiling, but this version of +c d1mach does not, because we do not have quad constants for +c many machines yet. +c to compile on older machines, add a c in column 1 +c on the next line + data sc/0/ +c and remove the c from column 1 in one of the sections below. +c constants for even older machines can be obtained by +c mail netlib@research.bell-labs.com +c send old1mach from blas +c please send corrections to dmg or ehg@bell-labs.com. +c +c machine constants for the honeywell dps 8/70 series. +c data small(1),small(2) / o402400000000, o000000000000 / +c data large(1),large(2) / o376777777777, o777777777777 / +c data right(1),right(2) / o604400000000, o000000000000 / +c data diver(1),diver(2) / o606400000000, o000000000000 / +c data log10(1),log10(2) / o776464202324, o117571775714 /, sc/987/ +c +c machine constants for pdp-11 fortrans supporting +c 32-bit integers. +c data small(1),small(2) / 8388608, 0 / +c data large(1),large(2) / 2147483647, -1 / +c data right(1),right(2) / 612368384, 0 / +c data diver(1),diver(2) / 620756992, 0 / +c data log10(1),log10(2) / 1067065498, -2063872008 /, sc/987/ +c +c machine constants for the univac 1100 series. +c data small(1),small(2) / o000040000000, o000000000000 / +c data large(1),large(2) / o377777777777, o777777777777 / +c data right(1),right(2) / o170540000000, o000000000000 / +c data diver(1),diver(2) / o170640000000, o000000000000 / +c data log10(1),log10(2) / o177746420232, o411757177572 /, sc/987/ +c +c on first call, if no data uncommented, test machine types. + if (sc .ne. 987) then + dmach(1) = 1.d13 + if ( small(1) .eq. 1117925532 + * .and. small(2) .eq. -448790528) then +* *** ieee big endian *** + small(1) = 1048576 + small(2) = 0 + large(1) = 2146435071 + large(2) = -1 + right(1) = 1017118720 + right(2) = 0 + diver(1) = 1018167296 + diver(2) = 0 + log10(1) = 1070810131 + log10(2) = 1352628735 + else if ( small(2) .eq. 1117925532 + * .and. small(1) .eq. -448790528) then +* *** ieee little endian *** + small(2) = 1048576 + small(1) = 0 + large(2) = 2146435071 + large(1) = -1 + right(2) = 1017118720 + right(1) = 0 + diver(2) = 1018167296 + diver(1) = 0 + log10(2) = 1070810131 + log10(1) = 1352628735 + else if ( small(1) .eq. -2065213935 + * .and. small(2) .eq. 10752) then +* *** vax with d_floating *** + small(1) = 128 + small(2) = 0 + large(1) = -32769 + large(2) = -1 + right(1) = 9344 + right(2) = 0 + diver(1) = 9472 + diver(2) = 0 + log10(1) = 546979738 + log10(2) = -805796613 + else if ( small(1) .eq. 1267827943 + * .and. small(2) .eq. 704643072) then +* *** ibm mainframe *** + small(1) = 1048576 + small(2) = 0 + large(1) = 2147483647 + large(2) = -1 + right(1) = 856686592 + right(2) = 0 + diver(1) = 873463808 + diver(2) = 0 + log10(1) = 1091781651 + log10(2) = 1352628735 + else if ( small(1) .eq. 1120022684 + * .and. small(2) .eq. -448790528) then +* *** convex c-1 *** + small(1) = 1048576 + small(2) = 0 + large(1) = 2147483647 + large(2) = -1 + right(1) = 1019215872 + right(2) = 0 + diver(1) = 1020264448 + diver(2) = 0 + log10(1) = 1072907283 + log10(2) = 1352628735 + else if ( small(1) .eq. 815547074 + * .and. small(2) .eq. 58688) then +* *** vax g-floating *** + small(1) = 16 + small(2) = 0 + large(1) = -32769 + large(2) = -1 + right(1) = 15552 + right(2) = 0 + diver(1) = 15568 + diver(2) = 0 + log10(1) = 1142112243 + log10(2) = 2046775455 + else + dmach(2) = 1.d27 + 1 + dmach(3) = 1.d27 + large(2) = large(2) - right(2) + if (large(2) .eq. 64 .and. small(2) .eq. 0) then + cray1(1) = 67291416 + do 10 j = 1, 20 + cray1(j+1) = cray1(j) + cray1(j) + 10 continue + cray1(22) = cray1(21) + 321322 + do 20 j = 22, 37 + cray1(j+1) = cray1(j) + cray1(j) + 20 continue + if (cray1(38) .eq. small(1)) then +* *** cray *** + call i1mcry(small(1), j, 8285, 8388608, 0) + small(2) = 0 + call i1mcry(large(1), j, 24574, 16777215, 16777215) + call i1mcry(large(2), j, 0, 16777215, 16777214) + call i1mcry(right(1), j, 16291, 8388608, 0) + right(2) = 0 + call i1mcry(diver(1), j, 16292, 8388608, 0) + diver(2) = 0 + call i1mcry(log10(1), j, 16383, 10100890, 8715215) + call i1mcry(log10(2), j, 0, 16226447, 9001388) + else + write(*,9000) + stop 779 + end if + else + write(*,9000) + stop 779 + end if + end if + sc = 987 + end if +* sanity check + if (dmach(4) .ge. 1.0d0) stop 778 + if (i .lt. 1 .or. i .gt. 5) then + write(*,*) 'd1mach(i): i =',i,' is out of bounds.' + stop + end if + d1mach = dmach(i) + return + 9000 format(/' adjust d1mach by uncommenting data statements'/ + *' appropriate for your machine.') + end +c + subroutine i1mcry(a, a1, b, c, d) +**** special computation for old cray machines **** + integer a, a1, b, c, d + a1 = 16777216*b + c + a = 16777216*a1 + d + end +c +c +c + subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, + * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) +c given the set of data points (x(i),y(i),z(i)) and the set of positive +c numbers w(i),i=1,...,m, subroutine surfit determines a smooth bivar- +c iate spline approximation s(x,y) of degrees kx and ky on the rect- +c angle xb <= x <= xe, yb <= y <= ye. +c if iopt = -1 surfit calculates the weighted least-squares spline +c according to a given set of knots. +c if iopt >= 0 the total numbers nx and ny of these knots and their +c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +c ally by the routine. the smoothness of s(x,y) is then achieved by +c minimalizing the discontinuity jumps in the derivatives of s(x,y) +c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +c the amounth of smoothness is determined by the condition that f(p) = +c sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg- +c ative constant, called the smoothing factor. +c the fit is given in the b-spline representation (b-spline coefficients +c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +c uated by means of subroutine bispev. +c +c calling sequence: +c call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, +c * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline (iopt=-1) or a smoothing spline (iopt=0 +c or 1) must be determined. +c if iopt=0 the routine will start with an initial set of knots +c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +c 1,...,ky+1. if iopt=1 the routine will continue with the set +c of knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately pre- +c ceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m >= (kx+1)*(ky+1). unchanged on exit. +c x : real array of dimension at least (m). +c y : real array of dimension at least (m). +c z : real array of dimension at least (m). +c before entry, x(i),y(i),z(i) must be set to the co-ordinates +c of the i-th data point, for i=1,...,m. the order of the data +c points is immaterial. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) must +c be set to the i-th value in the set of weights. the w(i) must +c be strictly positive. unchanged on exit. +c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +c yb,ye aries of the rectangular approximation domain. +c xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit. +c kx,ky : integer values. on entry kx and ky must specify the degrees +c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +c (kx=ky=3) splines. unchanged on exit. +c s : real. on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nxest : integer. unchanged on exit. +c nyest : integer. unchanged on exit. +c on entry, nxest and nyest must specify an upper bound for the +c number of knots required in the x- and y-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +c in most practical situation nxest = kx+1+sqrt(m/2), nyest = +c ky+1+sqrt(m/2) will be sufficient. see also further comments. +c nmax : integer. on entry nmax must specify the actual dimension of +c the arrays tx and ty. nmax >= nxest, nmax >=nyest. +c unchanged on exit. +c eps : real. +c on entry, eps must specify a threshold for determining the +c effective rank of an over-determined linear system of equat- +c ions. 0 < eps < 1. if the number of decimal digits in the +c computer representation of a real number is q, then 10**(-q) +c is a suitable value for eps in most practical applications. +c unchanged on exit. +c nx : integer. +c unless ier=10 (in case iopt >=0), nx will contain the total +c number of knots with respect to the x-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of nx should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of nx should be specified on entry +c tx : real array of dimension nmax. +c on succesful exit, this array will contain the knots of the +c spline with respect to the x-variable, i.e. the position of +c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +c position of the additional knots tx(1)=...=tx(kx+1)=xb and +c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of tx(1), +c ...,tx(nx) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tx(kx+2), +c ...tx(nx-kx-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c ny : integer. +c unless ier=10 (in case iopt >=0), ny will contain the total +c number of knots with respect to the y-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of ny should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of ny should be specified on entry +c ty : real array of dimension nmax. +c on succesful exit, this array will contain the knots of the +c spline with respect to the y-variable, i.e. the position of +c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +c position of the additional knots ty(1)=...=ty(ky+1)=yb and +c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of ty(1), +c ...,ty(ny) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values ty(ky+2), +c ...ty(ny-ky-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +c on succesful exit, c contains the coefficients of the spline +c approximation s(x,y) +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk1 : real array of dimension (lwrk1). used as workspace. +c if the computation mode iopt=1 is used the value of wrk1(1) +c should be left unchanged between subsequent calls. +c on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will +c contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1) +c with d(i) the i-th diagonal element of the reduced triangular +c matrix for calculating the b-spline coefficients. it includes +c those elements whose square is less than eps,which are treat- +c ed as 0 in the case of presumed rank deficiency (ier<-2). +c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of +c the array wrk1 as declared in the calling (sub)program. +c lwrk1 must not be too small. let +c u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1, +c ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1, +c if(bx.le.by) b1 = bx, b2 = b1+v-ky +c if(bx.gt.by) b1 = by, b2 = b1+u-kx then +c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +c wrk2 : real array of dimension (lwrk2). used as workspace, but +c only in the case a rank deficient system is encountered. +c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of +c the array wrk2 as declared in the calling (sub)program. +c lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2 +c where u,v and b2 are as above. if there are enough data +c points, scattered uniformly over the approximation domain +c and if the smoothing factor s is not too small, there is a +c good chance that this extra workspace is not needed. a lot +c of memory might therefore be saved by setting lwrk2=1. +c (see also ier > 10) +c iwrk : integer array of dimension (kwrk). used as workspace. +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1). +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares polynomial of degrees kx and ky. in this extreme +c case fp gives the upper bound for the smoothing factor s. +c ier<-2 : warning. the coefficients of the spline returned have been +c computed as the minimal norm least-squares solution of a +c (numerically) rank deficient system. (-ier) gives the rank. +c especially if the rank deficiency which can be computed as +c (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac- +c curate. they could also seriously depend on the value of +c eps. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nxest and +c nyest. +c probably causes : nxest or nyest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration proces for finding a smoothing spline with +c fp = s. probably causes : s too small or badly chosen eps. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=4 : error. no more knots can be added because the number of +c b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds +c the number of data points m. +c probably causes : either s or m too small. +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=5 : error. no more knots can be added because the additional +c knot would (quasi) coincide with an old one. +c probably causes : s too small or too large a weight to an +c inaccurate data point. +c the approximation returned is the weighted least-squares +c spline according to the current set of knots. +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2, +c nyest>=2*ky+2, 0=nxest, nmax>=nyest, +c xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m +c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1) +c if iopt=-1: 2*kx+2<=nx<=nxest +c xb=0: s>=0 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- +c space for computing the minimal least-squares solution of +c a rank deficient system of linear equations. ier gives the +c requested value for lwrk2. there is no approximation re- +c turned but, having saved the information contained in nx, +c ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and +c the dimension of the array wrk2 accordingly, the user can +c continue at the point the program was left, by calling +c surfit with iopt=1. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in z(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to choose s very small is strongly discouraged. this considerably +c increases computation time and memory requirements. it may also +c cause rank-deficiency (ier<-2) and endager numerical stability. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if surfit is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c surfit once more with the selected value for s but now with iopt=0. +c indeed, surfit may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nxest and +c nyest. indeed, if at a certain stage in surfit the number of knots +c in one direction (say nx) has reached the value of its upper bound +c (nxest), then from that moment on all subsequent knots are added +c in the other (y) direction. this may indicate that the value of +c nxest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nxest=2*kx+2 (the lowest allowable value for +c nxest), the user can indicate that he wants an approximation which +c is a simple polynomial of degree kx in the variable x. +c +c other subroutines required: +c fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde +c +c references: +c dierckx p. : an algorithm for surface fitting with spline functions +c ima j. numer. anal. 1 (1981) 267-283. +c dierckx p. : an algorithm for surface fitting with spline functions +c report tw50, dept. computer science,k.u.leuven, 1980. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,eps,fp + integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier +c ..array arguments.. + real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax), + * c((nxest-kx-1)*(nyest-ky-1)),wrk1(lwrk1),wrk2(lwrk2) + integer iwrk(kwrk) +c ..local scalars.. + real*8 tol + integer i,ib1,ib3,jb1,ki,kmax,km1,km2,kn,kwest,kx1,ky1,la,lbx, + * lby,lco,lf,lff,lfp,lh,lq,lsx,lsy,lwest,maxit,ncest,nest,nek, + * nminx,nminy,nmx,nmy,nreg,nrint,nxk,nyk +c ..function references.. + integer max0 +c ..subroutine references.. +c fpsurf +c .. +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +c before starting computations a data check is made. if the input data +c are invalid,control is immediately repassed to the calling program. + ier = 10 + if(eps.le.0. .or. eps.ge.1.) go to 70 + if(kx.le.0 .or. kx.gt.5) go to 70 + kx1 = kx+1 + if(ky.le.0 .or. ky.gt.5) go to 70 + ky1 = ky+1 + kmax = max0(kx,ky) + km1 = kmax+1 + km2 = km1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 70 + if(m.lt.(kx1*ky1)) go to 70 + nminx = 2*kx1 + if(nxest.lt.nminx .or. nxest.gt.nmax) go to 70 + nminy = 2*ky1 + if(nyest.lt.nminy .or. nyest.gt.nmax) go to 70 + nest = max0(nxest,nyest) + nxk = nxest-kx1 + nyk = nyest-ky1 + ncest = nxk*nyk + nmx = nxest-nminx+1 + nmy = nyest-nminy+1 + nrint = nmx+nmy + nreg = nmx*nmy + ib1 = kx*nyk+ky1 + jb1 = ky*nxk+kx1 + ib3 = kx1*nyk+1 + if(ib1.le.jb1) go to 10 + ib1 = jb1 + ib3 = ky1*nxk+1 + 10 lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3 + kwest = m+nreg + if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 70 + if(xb.ge.xe .or. yb.ge.ye) go to 70 + do 20 i=1,m + if(w(i).le.0.) go to 70 + if(x(i).lt.xb .or. x(i).gt.xe) go to 70 + if(y(i).lt.yb .or. y(i).gt.ye) go to 70 + 20 continue + if(iopt.ge.0) go to 50 + if(nx.lt.nminx .or. nx.gt.nxest) go to 70 + nxk = nx-kx1 + tx(kx1) = xb + tx(nxk+1) = xe + do 30 i=kx1,nxk + if(tx(i+1).le.tx(i)) go to 70 + 30 continue + if(ny.lt.nminy .or. ny.gt.nyest) go to 70 + nyk = ny-ky1 + ty(ky1) = yb + ty(nyk+1) = ye + do 40 i=ky1,nyk + if(ty(i+1).le.ty(i)) go to 70 + 40 continue + go to 60 + 50 if(s.lt.0.) go to 70 + 60 ier = 0 +c we partition the working space and determine the spline approximation + kn = 1 + ki = kn+m + lq = 2 + la = lq+ncest*ib3 + lf = la+ncest*ib1 + lff = lf+ncest + lfp = lff+ncest + lco = lfp+nrint + lh = lco+nrint + lbx = lh+ib3 + nek = nest*km2 + lby = lbx+nek + lsx = lby+nek + lsy = lsx+m*km1 + call fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, + * eps,tol,maxit,nest,km1,km2,ib1,ib3,ncest,nrint,nreg,nx,tx, + * ny,ty,c,fp,wrk1(1),wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff), + * wrk1(la),wrk1(lq),wrk1(lbx),wrk1(lby),wrk1(lsx),wrk1(lsy), + * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) + 70 return + end + + + subroutine fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kxx,kyy,s,nxest, + * nyest,eta,tol,maxit,nmax,km1,km2,ib1,ib3,nc,intest,nrest, + * nx0,tx,ny0,ty,c,fp,fp0,fpint,coord,f,ff,a,q,bx,by,spx,spy,h, + * index,nummer,wrk,lwrk,ier) +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,eta,tol,fp,fp0 + integer iopt,m,kxx,kyy,nxest,nyest,maxit,nmax,km1,km2,ib1,ib3, + * nc,intest,nrest,nx0,ny0,lwrk,ier +c ..array arguments.. + real*8 x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),c(nc),fpint(intest), + * coord(intest),f(nc),ff(nc),a(nc,ib1),q(nc,ib3),bx(nmax,km2), + * by(nmax,km2),spx(m,km1),spy(m,km1),h(ib3),wrk(lwrk) + integer index(nrest),nummer(m) +c ..local scalars.. + real*8 acc,arg,cos,dmax,fac1,fac2,fpmax,fpms,f1,f2,f3,hxi,p,pinv, + * piv,p1,p2,p3,sigma,sin,sq,store,wi,x0,x1,y0,y1,zi,eps, + * rn,one,con1,con9,con4,half,ten + integer i,iband,iband1,iband3,iband4,ibb,ichang,ich1,ich3,ii, + * in,irot,iter,i1,i2,i3,j,jrot,jxy,j1,kx,kx1,kx2,ky,ky1,ky2,l, + * la,lf,lh,lwest,lx,ly,l1,l2,n,ncof,nk1x,nk1y,nminx,nminy,nreg, + * nrint,num,num1,nx,nxe,nxx,ny,nye,nyy,n1,rank +c ..local arrays.. + real*8 hx(6),hy(6) +c ..function references.. + real*8 abs,fprati,sqrt + integer min0 +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota +c .. +c set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + half = 0.5e0 + ten = 0.1e+02 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 1: determination of the number of knots and their position. c +c **************************************************************** c +c given a set of knots we compute the least-squares spline sinf(x,y), c +c and the corresponding weighted sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(x,y) is the requested approximation. c +c if iopt=0 or iopt=1 we check whether we can accept the knots: c +c if fp <=s we will continue with the current set of knots. c +c if fp > s we will increase the number of knots and compute the c +c corresponding least-squares spline until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if iopt=0 we first compute the least-squares polynomial of degree c +c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nminy=2*ky+2. c +c fp0=f(0) denotes the corresponding weighted sum of squared c +c residuals c +c if iopt=1 we start with the knots found at the last call of the c +c routine, except for the case that s>=fp0; then we can compute c +c the least-squares polynomial directly. c +c eventually the independent variables x and y (and the corresponding c +c parameters) will be switched if this can reduce the bandwidth of the c +c system to be solved. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c ichang denotes whether(1) or not(-1) the directions have been inter- +c changed. + ichang = -1 + x0 = xb + x1 = xe + y0 = yb + y1 = ye + kx = kxx + ky = kyy + kx1 = kx+1 + ky1 = ky+1 + nxe = nxest + nye = nyest + eps = sqrt(eta) + if(iopt.lt.0) go to 20 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s + if(iopt.eq.0) go to 10 + if(fp0.gt.s) go to 20 +c initialization for the least-squares polynomial. + 10 nminx = 2*kx1 + nminy = 2*ky1 + nx = nminx + ny = nminy + ier = -2 + go to 30 + 20 nx = nx0 + ny = ny0 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 30 do 420 iter=1,m +c find the position of the additional knots which are needed for the +c b-spline representation of s(x,y). + l = nx + do 40 i=1,kx1 + tx(i) = x0 + tx(l) = x1 + l = l-1 + 40 continue + l = ny + do 50 i=1,ky1 + ty(i) = y0 + ty(l) = y1 + l = l-1 + 50 continue +c find nrint, the total number of knot intervals and nreg, the number +c of panels in which the approximation domain is subdivided by the +c intersection of knots. + nxx = nx-2*kx1+1 + nyy = ny-2*ky1+1 + nrint = nxx+nyy + nreg = nxx*nyy +c find the bandwidth of the observation matrix a. +c if necessary, interchange the variables x and y, in order to obtain +c a minimal bandwidth. + iband1 = kx*(ny-ky1)+ky + l = ky*(nx-kx1)+kx + if(iband1.le.l) go to 130 + iband1 = l + ichang = -ichang + do 60 i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + 60 continue + store = x0 + x0 = y0 + y0 = store + store = x1 + x1 = y1 + y1 = store + n = min0(nx,ny) + do 70 i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + 70 continue + n1 = n+1 + if(nx-ny) 80,120,100 + 80 do 90 i=n1,ny + tx(i) = ty(i) + 90 continue + go to 120 + 100 do 110 i=n1,nx + ty(i) = tx(i) + 110 continue + 120 l = nx + nx = ny + ny = l + l = nxe + nxe = nye + nye = l + l = nxx + nxx = nyy + nyy = l + l = kx + kx = ky + ky = l + kx1 = kx+1 + ky1 = ky+1 + 130 iband = iband1+1 +c arrange the data points according to the panel they belong to. + call fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg) +c find ncof, the number of b-spline coefficients. + nk1x = nx-kx1 + nk1y = ny-ky1 + ncof = nk1x*nk1y +c initialize the observation matrix a. + do 140 i=1,ncof + f(i) = 0. + do 140 j=1,iband + a(i,j) = 0. + 140 continue +c initialize the sum of squared residuals. + fp = 0. +c fetch the data points in the new order. main loop for the +c different panels. + do 250 num=1,nreg +c fix certain constants for the current panel; jrot records the column +c number of the first non-zero element in a row of the observation +c matrix according to a data point of the panel. + num1 = num-1 + lx = num1/nyy + l1 = lx+kx1 + ly = num1-lx*nyy + l2 = ly+ky1 + jrot = lx*nk1y+ly +c test whether there are still data points in the panel. + in = index(num) + 150 if(in.eq.0) go to 250 +c fetch a new data point. + wi = w(in) + zi = z(in)*wi +c evaluate for the x-direction, the (kx+1) non-zero b-splines at x(in). + call fpbspl(tx,nx,kx,x(in),l1,hx) +c evaluate for the y-direction, the (ky+1) non-zero b-splines at y(in). + call fpbspl(ty,ny,ky,y(in),l2,hy) +c store the value of these b-splines in spx and spy respectively. + do 160 i=1,kx1 + spx(in,i) = hx(i) + 160 continue + do 170 i=1,ky1 + spy(in,i) = hy(i) + 170 continue +c initialize the new row of observation matrix. + do 180 i=1,iband + h(i) = 0. + 180 continue +c calculate the non-zero elements of the new row by making the cross +c products of the non-zero b-splines in x- and y-direction. + i1 = 0 + do 200 i=1,kx1 + hxi = hx(i) + j1 = i1 + do 190 j=1,ky1 + j1 = j1+1 + h(j1) = hxi*hy(j)*wi + 190 continue + i1 = i1+nk1y + 200 continue +c rotate the row into triangle by givens transformations . + irot = jrot + do 220 i=1,iband + irot = irot+1 + piv = h(i) + if(piv.eq.0.) go to 220 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),cos,sin) +c apply that transformation to the right hand side. + call fprota(cos,sin,zi,f(irot)) + if(i.eq.iband) go to 230 +c apply that transformation to the left hand side. + i2 = 1 + i3 = i+1 + do 210 j=i3,iband + i2 = i2+1 + call fprota(cos,sin,h(j),a(irot,i2)) + 210 continue + 220 continue +c add the contribution of the row to the sum of squares of residual +c right hand sides. + 230 fp = fp+zi**2 +c find the number of the next data point in the panel. + 240 in = nummer(in) + go to 150 + 250 continue +c find dmax, the maximum value for the diagonal elements in the reduced +c triangle. + dmax = 0. + do 260 i=1,ncof + if(a(i,1).le.dmax) go to 260 + dmax = a(i,1) + 260 continue +c check whether the observation matrix is rank deficient. + sigma = eps*dmax + do 270 i=1,ncof + if(a(i,1).le.sigma) go to 280 + 270 continue +c backward substitution in case of full rank. + call fpback(a,f,ncof,iband,c,nc) + rank = ncof + do 275 i=1,ncof + q(i,1) = a(i,1)/dmax + 275 continue + go to 300 +c in case of rank deficiency, find the minimum norm solution. +c check whether there is sufficient working space + 280 lwest = ncof*iband+ncof+iband + if(lwrk.lt.lwest) go to 780 + do 290 i=1,ncof + ff(i) = f(i) + do 290 j=1,iband + q(i,j) = a(i,j) + 290 continue + lf =1 + lh = lf+ncof + la = lh+iband + call fprank(q,ff,ncof,iband,nc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + do 295 i=1,ncof + q(i,1) = q(i,1)/dmax + 295 continue +c add to the sum of squared residuals, the contribution of reducing +c the rank. + fp = fp+sq + 300 if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) go to 820 + fpms = fp-s + if(abs(fpms).le.acc) if(fp) 815,815,820 +c test whether we can accept the choice of knots. + if(fpms.lt.0.) go to 430 +c test whether we cannot further increase the number of knots. + if(ncof.gt.m) go to 790 + ier = 0 +c search where to add a new knot. +c find for each interval the sum of squared residuals fpint for the +c data points having the coordinate belonging to that knot interval. +c calculate also coord which is the same sum, weighted by the position +c of the data points considered. + 310 do 320 i=1,nrint + fpint(i) = 0. + coord(i) = 0. + 320 continue + do 360 num=1,nreg + num1 = num-1 + lx = num1/nyy + l1 = lx+1 + ly = num1-lx*nyy + l2 = ly+1+nxx + jrot = lx*nk1y+ly + in = index(num) + 330 if(in.eq.0) go to 360 + store = 0. + i1 = jrot + do 350 i=1,kx1 + hxi = spx(in,i) + j1 = i1 + do 340 j=1,ky1 + j1 = j1+1 + store = store+hxi*spy(in,j)*c(j1) + 340 continue + i1 = i1+nk1y + 350 continue + store = (w(in)*(z(in)-store))**2 + fpint(l1) = fpint(l1)+store + coord(l1) = coord(l1)+store*x(in) + fpint(l2) = fpint(l2)+store + coord(l2) = coord(l2)+store*y(in) + in = nummer(in) + go to 330 + 360 continue +c find the interval for which fpint is maximal on the condition that +c there still can be added a knot. + 370 l = 0 + fpmax = 0. + l1 = 1 + l2 = nrint + if(nx.eq.nxe) l1 = nxx+1 + if(ny.eq.nye) l2 = nxx + if(l1.gt.l2) go to 810 + do 380 i=l1,l2 + if(fpmax.ge.fpint(i)) go to 380 + l = i + fpmax = fpint(i) + 380 continue +c test whether we cannot further increase the number of knots. + if(l.eq.0) go to 785 +c calculate the position of the new knot. + arg = coord(l)/fpint(l) +c test in what direction the new knot is going to be added. + if(l.gt.nxx) go to 400 +c addition in the x-direction. + jxy = l+kx1 + fpint(l) = 0. + fac1 = tx(jxy)-arg + fac2 = arg-tx(jxy-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 + j = nx + do 390 i=jxy,nx + tx(j+1) = tx(j) + j = j-1 + 390 continue + tx(jxy) = arg + nx = nx+1 + go to 420 +c addition in the y-direction. + 400 jxy = l+ky1-nxx + fpint(l) = 0. + fac1 = ty(jxy)-arg + fac2 = arg-ty(jxy-1) + if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 + j = ny + do 410 i=jxy,ny + ty(j+1) = ty(j) + j = j-1 + 410 continue + ty(jxy) = arg + ny = ny+1 +c restart the computations with the new set of knots. + 420 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 430 if(ier.eq.(-2)) go to 830 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x,y) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(x,y). c +c the observation matrix a is extended by the rows of a matrix, c +c expressing that sp(x,y) must be a polynomial of degree kx in x and c +c ky in y. the corresponding weights of these additional rows are set c +c to 1./p. iteratively we than have to determine the value of p c +c such that f(p)=sum((w(i)*(z(i)-sp(x(i),y(i))))**2) be = s. c +c we already know that the least-squares polynomial corresponds to c +c p=0 and that the least-squares spline corresponds to p=infinity. c +c the iteration process which is proposed here makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function r(p)= c +c (u*p+v)/(p+w). three values of p(p1,p2,p3) with corresponding values c +c of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the c +c new value of p such that r(p)=s. convergence is guaranteed by taking c +c f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + kx2 = kx1+1 +c test whether there are interior knots in the x-direction. + if(nk1x.eq.kx1) go to 440 +c evaluate the discotinuity jumps of the kx-th order derivative of +c the b-splines at the knots tx(l),l=kx+2,...,nx-kx-1. + call fpdisc(tx,nx,kx2,bx,nmax) + 440 ky2 = ky1 + 1 +c test whether there are interior knots in the y-direction. + if(nk1y.eq.ky1) go to 450 +c evaluate the discontinuity jumps of the ky-th order derivative of +c the b-splines at the knots ty(l),l=ky+2,...,ny-ky-1. + call fpdisc(ty,ny,ky2,by,nmax) +c initial value for p. + 450 p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do 460 i=1,ncof + p = p+a(i,1) + 460 continue + rn = ncof + p = rn/p +c find the bandwidth of the extended observation matrix. + iband3 = kx1*nk1y + iband4 = iband3 +1 + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 770 iter=1,maxit + pinv = one/p +c store the triangularized observation matrix into q. + do 480 i=1,ncof + ff(i) = f(i) + do 470 j=1,iband + q(i,j) = a(i,j) + 470 continue + ibb = iband+1 + do 480 j=ibb,iband4 + q(i,j) = 0. + 480 continue + if(nk1y.eq.ky1) go to 560 +c extend the observation matrix with the rows of a matrix, expressing +c that for x=cst. sp(x,y) must be a polynomial in y of degree ky. + do 550 i=ky2,nk1y + ii = i-ky1 + do 550 j=1,nk1x +c initialize the new row. + do 490 l=1,iband + h(l) = 0. + 490 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + do 500 l=1,ky2 + h(l) = by(ii,l)*pinv + 500 continue + zi = 0. + jrot = (j-1)*nk1y+ii +c rotate the new row into triangle by givens transformations without +c square roots. + do 540 irot=jrot,ncof + piv = h(1) + i2 = min0(iband1,ncof-irot) + if(piv.eq.0.) if(i2) 550,550,520 +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cos,sin) +c apply that givens transformation to the right hand side. + call fprota(cos,sin,zi,ff(irot)) + if(i2.eq.0) go to 550 +c apply that givens transformation to the left hand side. + do 510 l=1,i2 + l1 = l+1 + call fprota(cos,sin,h(l1),q(irot,l1)) + 510 continue + 520 do 530 l=1,i2 + h(l) = h(l+1) + 530 continue + h(i2+1) = 0. + 540 continue + 550 continue + 560 if(nk1x.eq.kx1) go to 640 +c extend the observation matrix with the rows of a matrix expressing +c that for y=cst. sp(x,y) must be a polynomial in x of degree kx. + do 630 i=kx2,nk1x + ii = i-kx1 + do 630 j=1,nk1y +c initialize the new row + do 570 l=1,iband4 + h(l) = 0. + 570 continue +c fill in the non-zero elements of the row. jrot records the column +c number of the first non-zero element in the row. + j1 = 1 + do 580 l=1,kx2 + h(j1) = bx(ii,l)*pinv + j1 = j1+nk1y + 580 continue + zi = 0. + jrot = (i-kx2)*nk1y+j +c rotate the new row into triangle by givens transformations . + do 620 irot=jrot,ncof + piv = h(1) + i2 = min0(iband3,ncof-irot) + if(piv.eq.0.) if(i2) 630,630,600 +c calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cos,sin) +c apply that givens transformation to the right hand side. + call fprota(cos,sin,zi,ff(irot)) + if(i2.eq.0) go to 630 +c apply that givens transformation to the left hand side. + do 590 l=1,i2 + l1 = l+1 + call fprota(cos,sin,h(l1),q(irot,l1)) + 590 continue + 600 do 610 l=1,i2 + h(l) = h(l+1) + 610 continue + h(i2+1) = 0. + 620 continue + 630 continue +c find dmax, the maximum value for the diagonal elements in the +c reduced triangle. + 640 dmax = 0. + do 650 i=1,ncof + if(q(i,1).le.dmax) go to 650 + dmax = q(i,1) + 650 continue +c check whether the matrix is rank deficient. + sigma = eps*dmax + do 660 i=1,ncof + if(q(i,1).le.sigma) go to 670 + 660 continue +c backward substitution in case of full rank. + call fpback(q,ff,ncof,iband4,c,nc) + rank = ncof + go to 675 +c in case of rank deficiency, find the minimum norm solution. + 670 lwest = ncof*iband4+ncof+iband4 + if(lwrk.lt.lwest) go to 780 + lf = 1 + lh = lf+ncof + la = lh+iband4 + call fprank(q,ff,ncof,iband4,nc,sigma,c,sq,rank,wrk(la), + * wrk(lf),wrk(lh)) + 675 do 680 i=1,ncof + q(i,1) = q(i,1)/dmax + 680 continue +c compute f(p). + fp = 0. + do 720 num = 1,nreg + num1 = num-1 + lx = num1/nyy + ly = num1-lx*nyy + jrot = lx*nk1y+ly + in = index(num) + 690 if(in.eq.0) go to 720 + store = 0. + i1 = jrot + do 710 i=1,kx1 + hxi = spx(in,i) + j1 = i1 + do 700 j=1,ky1 + j1 = j1+1 + store = store+hxi*spy(in,j)*c(j1) + 700 continue + i1 = i1+nk1y + 710 continue + fp = fp+(w(in)*(z(in)-store))**2 + in = nummer(in) + go to 690 + 720 continue +c test whether the approximation sp(x,y) is an acceptable solution. + fpms = fp-s + if(abs(fpms).le.acc) go to 820 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 795 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 740 + if((f2-f3).gt.acc) go to 730 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 770 + 730 if(f2.lt.0.) ich3 = 1 + 740 if(ich1.ne.0) go to 760 + if((f1-f2).gt.acc) go to 750 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.) go to 770 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 770 + 750 if(f2.gt.0.) ich1 = 1 +c test whether the iteration process proceeds as theoretically +c expected. + 760 if(f2.ge.f1 .or. f2.le.f3) go to 800 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 770 continue +c error codes and messages. + 780 ier = lwest + go to 830 + 785 ier = 5 + go to 830 + 790 ier = 4 + go to 830 + 795 ier = 3 + go to 830 + 800 ier = 2 + go to 830 + 810 ier = 1 + go to 830 + 815 ier = -1 + fp = 0. + 820 if(ncof.ne.rank) ier = -rank +c test whether x and y are in the original order. + 830 if(ichang.lt.0) go to 930 +c if not, interchange x and y once more. + l1 = 1 + do 840 i=1,nk1x + l2 = i + do 840 j=1,nk1y + f(l2) = c(l1) + l1 = l1+1 + l2 = l2+nk1x + 840 continue + do 850 i=1,ncof + c(i) = f(i) + 850 continue + do 860 i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + 860 continue + n = min0(nx,ny) + do 870 i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + 870 continue + n1 = n+1 + if(nx-ny) 880,920,900 + 880 do 890 i=n1,ny + tx(i) = ty(i) + 890 continue + go to 920 + 900 do 910 i=n1,nx + ty(i) = tx(i) + 910 continue + 920 l = nx + nx = ny + ny = l + 930 if(iopt.lt.0) go to 940 + nx0 = nx + ny0 = ny + 940 return + end + + subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h) +c subroutine fprank finds the minimum norm solution of a least- +c squares problem in case of rank deficiency. +c +c input parameters: +c a : array, which contains the non-zero elements of the observation +c matrix after triangularization by givens transformations. +c f : array, which contains the transformed right hand side. +c n : integer,wich contains the dimension of a. +c m : integer, which denotes the bandwidth of a. +c tol : real value, giving a threshold to determine the rank of a. +c +c output parameters: +c c : array, which contains the minimum norm solution. +c sq : real value, giving the contribution of reducing the rank +c to the sum of squared residuals. +c rank : integer, which contains the rank of matrix a. +c +c ..scalar arguments.. + integer n,m,na,rank + real*8 tol,sq +c ..array arguments.. + real*8 a(na,m),f(n),c(n),aa(n,m),ff(n),h(m) +c ..local scalars.. + integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl + real*8 cos,fac,piv,sin,yi + double precision store,stor1,stor2,stor3 +c ..function references.. + integer min0 +c ..subroutine references.. +c fpgivs,fprota +c .. + m1 = m-1 +c the rank deficiency nl is considered to be the number of sufficient +c small diagonal elements of a. + nl = 0 + sq = 0. + do 90 i=1,n + if(a(i,1).gt.tol) go to 90 +c if a sufficient small diagonal element is found, we put it to +c zero. the remainder of the row corresponding to that zero diagonal +c element is then rotated into triangle by givens rotations . +c the rank deficiency is increased by one. + nl = nl+1 + if(i.eq.n) go to 90 + yi = f(i) + do 10 j=1,m1 + h(j) = a(i,j+1) + 10 continue + h(m) = 0. + i1 = i+1 + do 60 ii=i1,n + i2 = min0(n-ii,m1) + piv = h(1) + if(piv.eq.0.) go to 30 + call fpgivs(piv,a(ii,1),cos,sin) + call fprota(cos,sin,yi,f(ii)) + if(i2.eq.0) go to 70 + do 20 j=1,i2 + j1 = j+1 + call fprota(cos,sin,h(j1),a(ii,j1)) + h(j) = h(j1) + 20 continue + go to 50 + 30 if(i2.eq.0) go to 70 + do 40 j=1,i2 + h(j) = h(j+1) + 40 continue + 50 h(i2+1) = 0. + 60 continue +c add to the sum of squared residuals the contribution of deleting +c the row with small diagonal element. + 70 sq = sq+yi**2 + 90 continue +c rank denotes the rank of a. + rank = n-nl +c let b denote the (rank*n) upper trapezoidal matrix which can be +c obtained from the (n*n) upper triangular matrix a by deleting +c the rows and interchanging the columns corresponding to a zero +c diagonal element. if this matrix is factorized using givens +c transformations as b = (r) (u) where +c r is a (rank*rank) upper triangular matrix, +c u is a (rank*n) orthonormal matrix +c then the minimal least-squares solution c is given by c = b' v, +c where v is the solution of the system (r) (r)' v = g and +c g denotes the vector obtained from the old right hand side f, by +c removing the elements corresponding to a zero diagonal element of a. +c initialization. + do 100 i=1,rank + do 100 j=1,m + aa(i,j) = 0. + 100 continue +c form in aa the upper triangular matrix obtained from a by +c removing rows and columns with zero diagonal elements. form in ff +c the new right hand side by removing the elements of the old right +c hand side corresponding to a deleted row. + ii = 0 + do 120 i=1,n + if(a(i,1).le.tol) go to 120 + ii = ii+1 + ff(ii) = f(i) + aa(ii,1) = a(i,1) + jj = ii + kk = 1 + j = i + j1 = min0(j-1,m1) + if(j1.eq.0) go to 120 + do 110 k=1,j1 + j = j-1 + if(a(j,1).le.tol) go to 110 + kk = kk+1 + jj = jj-1 + aa(jj,kk) = a(j,k+1) + 110 continue + 120 continue +c form successively in h the columns of a with a zero diagonal element. + ii = 0 + do 200 i=1,n + ii = ii+1 + if(a(i,1).gt.tol) go to 200 + ii = ii-1 + if(ii.eq.0) go to 200 + jj = 1 + j = i + j1 = min0(j-1,m1) + do 130 k=1,j1 + j = j-1 + if(a(j,1).le.tol) go to 130 + h(jj) = a(j,k+1) + jj = jj+1 + 130 continue + do 140 kk=jj,m + h(kk) = 0. + 140 continue +c rotate this column into aa by givens transformations. + jj = ii + do 190 i1=1,ii + j1 = min0(jj-1,m1) + piv = h(1) + if(piv.ne.0.) go to 160 + if(j1.eq.0) go to 200 + do 150 j2=1,j1 + j3 = j2+1 + h(j2) = h(j3) + 150 continue + go to 180 + 160 call fpgivs(piv,aa(jj,1),cos,sin) + if(j1.eq.0) go to 200 + kk = jj + do 170 j2=1,j1 + j3 = j2+1 + kk = kk-1 + call fprota(cos,sin,h(j3),aa(kk,j3)) + h(j2) = h(j3) + 170 continue + 180 jj = jj-1 + h(j3) = 0. + 190 continue + 200 continue +c solve the system (aa) (f1) = ff + ff(rank) = ff(rank)/aa(rank,1) + i = rank-1 + if(i.eq.0) go to 230 + do 220 j=2,rank + store = ff(i) + i1 = min0(j-1,m1) + k = i + do 210 ii=1,i1 + k = k+1 + stor1 = ff(k) + stor2 = aa(i,ii+1) + store = store-stor1*stor2 + 210 continue + stor1 = aa(i,1) + ff(i) = store/stor1 + i = i-1 + 220 continue +c solve the system (aa)' (f2) = f1 + 230 ff(1) = ff(1)/aa(1,1) + if(rank.eq.1) go to 260 + do 250 j=2,rank + store = ff(j) + i1 = min0(j-1,m1) + k = j + do 240 ii=1,i1 + k = k-1 + stor1 = ff(k) + stor2 = aa(k,ii+1) + store = store-stor1*stor2 + 240 continue + stor1 = aa(j,1) + ff(j) = store/stor1 + 250 continue +c premultiply f2 by the transpoze of a. + 260 k = 0 + do 280 i=1,n + store = 0. + if(a(i,1).gt.tol) k = k+1 + j1 = min0(i,m) + kk = k + ij = i+1 + do 270 j=1,j1 + ij = ij-1 + if(a(ij,1).le.tol) go to 270 + stor1 = a(ij,j) + stor2 = ff(kk) + store = store+stor1*stor2 + kk = kk-1 + 270 continue + c(i) = store + 280 continue +c add to the sum of squared residuals the contribution of putting +c to zero the small diagonal elements of matrix (a). + stor3 = 0. + do 310 i=1,n + if(a(i,1).gt.tol) go to 310 + store = f(i) + i1 = min0(n-i,m1) + if(i1.eq.0) go to 300 + do 290 j=1,i1 + ij = i+j + stor1 = c(ij) + stor2 = a(i,j+1) + store = store-stor1*stor2 + 290 continue + 300 fac = a(i,1)*c(i) + stor1 = a(i,1) + stor2 = c(i) + stor1 = stor1*stor2 + stor3 = stor3+stor1*(stor1-store-store) + 310 continue + fac = stor3 + sq = sq+fac + return + end + + subroutine fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg) +c subroutine fporde sorts the data points (x(i),y(i)),i=1,2,...,m +c according to the panel tx(l)<=x=1. +c y : real array of dimension (my). +c before entry y(j) must be set to the y co-ordinate of the +c j-th grid point along the y-axis. +c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +c my : on entry my must specify the number of grid points along +c the y-axis. my >=1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= mx*(kx+1)+my*(ky+1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (mx*my). +c on succesful exit z(my*(i-1)+j) contains the value of s(x,y) +c at the point (x(i),y(j)),i=1,...,mx;j=1,...,my. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,mx,my,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wrk(lwrk) +c ..local scalars.. + integer i,iw,lwest +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + lwest = (kx+1)*mx+(ky+1)*my + if(lwrk.lt.lwest) go to 100 + if(kwrk.lt.(mx+my)) go to 100 + if(mx-1) 100,30,10 + 10 do 20 i=2,mx + if(x(i).lt.x(i-1)) go to 100 + 20 continue + 30 if(my-1) 100,60,40 + 40 do 50 i=2,my + if(y(i).lt.y(i-1)) go to 100 + 50 continue + 60 ier = 0 + iw = mx*(kx+1)+1 + call fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk(1),wrk(iw), + * iwrk(1),iwrk(mx+1)) + 100 return + end +c + subroutine fpback(a,z,n,k,c,nest) +c subroutine fpback calculates the solution of the system of +c equations a*c = z with a a n x n upper triangular matrix +c of bandwidth k. +c .. +c ..scalar arguments.. + integer n,k,nest +c ..array arguments.. + real*8 a(nest,k),z(n),c(n) +c ..local scalars.. + real*8 store + integer i,i1,j,k1,l,m +c .. + k1 = k-1 + c(n) = z(n)/a(n,1) + i = n-1 + if(i.eq.0) go to 30 + do 20 j=2,n + store = z(i) + i1 = k1 + if(j.le.k1) i1 = j-1 + m = i + do 10 l=1,i1 + m = m+1 + store = store-c(m)*a(i,l+1) + 10 continue + c(i) = store/a(i,1) + i = i-1 + 20 continue + 30 return + end +c + + subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wx,wy,lx,ly) +c ..scalar arguments.. + integer nx,ny,kx,ky,mx,my +c ..array arguments.. + integer lx(mx),ly(my) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wx(mx,kx+1),wy(my,ky+1) +c ..local scalars.. + integer kx1,ky1,l,l1,l2,m,nkx1,nky1 + real*8 arg,sp,tb,te +c ..local arrays.. + real*8 h(6) +c ..subroutine references.. +c fpbspl +c .. + kx1 = kx+1 + nkx1 = nx-kx1 + tb = tx(kx1) + te = tx(nkx1+1) + l = kx1 + l1 = l+1 + do 40 i=1,mx + arg = x(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 10 if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20 + l = l1 + l1 = l+1 + go to 10 + 20 call fpbspl(tx,nx,kx,arg,l,h) + lx(i) = l-kx1 + do 30 j=1,kx1 + wx(i,j) = h(j) + 30 continue + 40 continue + ky1 = ky+1 + nky1 = ny-ky1 + tb = ty(ky1) + te = ty(nky1+1) + l = ky1 + l1 = l+1 + do 80 i=1,my + arg = y(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te + 50 if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60 + l = l1 + l1 = l+1 + go to 50 + 60 call fpbspl(ty,ny,ky,arg,l,h) + ly(i) = l-ky1 + do 70 j=1,ky1 + wy(i,j) = h(j) + 70 continue + 80 continue + m = 0 + do 130 i=1,mx + l = lx(i)*nky1 + do 90 i1=1,kx1 + h(i1) = wx(i,i1) + 90 continue + do 120 j=1,my + l1 = l+ly(j) + sp = 0.0d0 + do 110 i1=1,kx1 + l2 = l1 + do 100 j1=1,ky1 + l2 = l2+1 + sp = sp+c(l2)*h(i1)*wy(j,j1) + 100 continue + l1 = l1+nky1 + 110 continue + m = m+1 + z(m) = sp + 120 continue + 130 continue + return + end + + subroutine fpbspl(t,n,k,x,l,h) +c subroutine fpbspl evaluates the (k+1) non-zero b-splines of +c degree k at t(l) <= x < t(l+1) using the stable recurrence +c relation of de boor and cox. +c .. +c ..scalar arguments.. + real*8 x + integer n,k,l +c ..array arguments.. + real*8 t(n),h(6) +c ..local scalars.. + real*8 f,one + integer i,j,li,lj +c ..local arrays.. + real*8 hh(5) +c .. + parameter(one = 0.1d+01) + h(1) = one + do 20 j=1,k + do 10 i=1,j + hh(i) = h(i) + 10 continue + h(1) = 0.0d0 + do 20 i=1,j + li = l+i + lj = li-j + f = hh(i)/(t(li)-t(lj)) + h(i) = h(i)+f*(t(li)-x) + h(i+1) = f*(x-t(lj)) + 20 continue + return + end +c + + subroutine fpchec(x,m,t,n,k,ier) +c subroutine fpchec verifies the number and the position of the knots +c t(j),j=1,2,...,n of a spline of degree k, in relation to the number +c and the position of the data points x(i),i=1,2,...,m. if all of the +c following conditions are fulfilled, the error parameter ier is set +c to zero. if one of the conditions is violated ier is set to ten. +c 1) k+1 <= n-k-1 <= m +c 2) t(1) <= t(2) <= ... <= t(k+1) +c t(n-k) <= t(n-k+1) <= ... <= t(n) +c 3) t(k+1) < t(k+2) < ... < t(n-k) +c 4) t(k+1) <= x(i) <= t(n-k) +c 5) the conditions specified by schoenberg and whitney must hold +c for at least one subset of data points, i.e. there must be a +c subset of data points y(j) such that +c t(j) < y(j) < t(j+k+1), j=1,2,...,n-k-1 +c .. +c ..scalar arguments.. + integer m,n,k,ier +c ..array arguments.. + real*8 x(m),t(n) +c ..local scalars.. + integer i,j,k1,k2,l,nk1,nk2,nk3 + real*8 tj,tl +c .. + k1 = k+1 + k2 = k1+1 + nk1 = n-k1 + nk2 = nk1+1 + ier = 10 +c check condition no 1 + if(nk1.lt.k1 .or. nk1.gt.m) go to 80 +c check condition no 2 + j = n + do 20 i=1,k + if(t(i).gt.t(i+1)) go to 80 + if(t(j).lt.t(j-1)) go to 80 + j = j-1 + 20 continue +c check condition no 3 + do 30 i=k2,nk2 + if(t(i).le.t(i-1)) go to 80 + 30 continue +c check condition no 4 + if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80 +c check condition no 5 + if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80 + i = 1 + l = k2 + nk3 = nk1-1 + if(nk3.lt.2) go to 70 + do 60 j=2,nk3 + tj = t(j) + l = l+1 + tl = t(l) + 40 i = i+1 + if(i.ge.m) go to 80 + if(x(i).le.tj) go to 40 + if(x(i).ge.tl) go to 80 + 60 continue + 70 ier = 0 + 80 return + end +c + subroutine fpdisc(t,n,k2,b,nest) +c subroutine fpdisc calculates the discontinuity jumps of the kth +c derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1) +c ..scalar arguments.. + integer n,k2,nest +c ..array arguments.. + real*8 t(n),b(nest,k2) +c ..local scalars.. + real*8 an,fac,prod + integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint +c ..local array.. + real*8 h(12) +c .. + k1 = k2-1 + k = k1-1 + nk1 = n-k1 + nrint = nk1-k + an = nrint + fac = an/(t(nk1+1)-t(k1)) + do 40 l=k2,nk1 + lmk = l-k1 + do 10 j=1,k1 + ik = j+k1 + lj = l+j + lk = lj-k2 + h(j) = t(l)-t(lk) + h(ik) = t(l)-t(lj) + 10 continue + lp = lmk + do 30 j=1,k2 + jk = j + prod = h(j) + do 20 i=1,k + jk = jk+1 + prod = prod*h(jk)*fac + 20 continue + lk = lp+k1 + b(lmk,j) = (t(lk)-t(lp))/prod + lp = lp+1 + 30 continue + 40 continue + return + end +c + + subroutine fpgivs(piv,ww,cos,sin) +c subroutine fpgivs calculates the parameters of a givens +c transformation . +c .. +c ..scalar arguments.. + real*8 piv,ww,cos,sin +c ..local scalars.. + real*8 dd,one,store +c .. + parameter(one = 0.1d+01) + store = abs(piv) + if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2) + if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2) + cos = ww/dd + sin = piv/dd + ww = dd + return + end + subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx, + * ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2,spx,spy,right,q, + * ax,ay,bx,by,nrx,nry) +c .. +c ..scalar arguments.. + real*8 p,fp + integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx, + * kx1,kx2,ky1,ky2 +c ..array arguments.. + real*8 x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1), + * spy(my,ky1),right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2), + * ay(ny,ky2),by(ny,ky2),fpx(nx),fpy(ny) + integer nrx(mx),nry(my) +c ..local scalars.. + real*8 arg,cos,fac,pinv,piv,sin,term,one,half + integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l, + * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1, + * numy,numy1,n1 +c ..local arrays.. + real*8 h(7) +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fprota +c .. +c the b-spline coefficients of the smoothing spline are calculated as +c the least-squares solution of the over-determined linear system of +c equations (ay) c (ax)' = q where +c +c | (spx) | | (spy) | +c (ax) = | ---------- | (ay) = | ---------- | +c | (1/p) (bx) | | (1/p) (by) | +c +c | z ' 0 | +c q = | ------ | +c | 0 ' 0 | +c +c with c : the (ny-ky-1) x (nx-kx-1) matrix which contains the +c b-spline coefficients. +c z : the my x mx matrix which contains the function values. +c spx,spy: the mx x (nx-kx-1) and my x (ny-ky-1) observation +c matrices according to the least-squares problems in +c the x- and y-direction. +c bx,by : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1) +c matrices which contain the discontinuity jumps of the +c derivatives of the b-splines in the x- and y-direction. + parameter(one = 1.0d0,half = 0.5d0) + nk1x = nx-kx1 + nk1y = ny-ky1 + if(p.gt.0.0d0) pinv = one/p +c it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on +c the value of p whether the matrices (spx),(spy),(bx) and (by) still +c must be determined. + if(ifsx.ne.0) go to 50 +c calculate the non-zero elements of the matrix (spx) which is the +c observation matrix according to the least-squares spline approximat- +c ion problem in the x-direction. + l = kx1 + l1 = kx2 + number = 0 + do 40 it=1,mx + arg = x(it) + 10 if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20 + l = l1 + l1 = l+1 + number = number+1 + go to 10 + 20 call fpbspl(tx,nx,kx,arg,l,h) + do 30 i=1,kx1 + spx(it,i) = h(i) + 30 continue + nrx(it) = number + 40 continue + ifsx = 1 + 50 if(ifsy.ne.0) go to 100 +c calculate the non-zero elements of the matrix (spy) which is the +c observation matrix according to the least-squares spline approximat- +c ion problem in the y-direction. + l = ky1 + l1 = ky2 + number = 0 + do 90 it=1,my + arg = y(it) + 60 if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70 + l = l1 + l1 = l+1 + number = number+1 + go to 60 + 70 call fpbspl(ty,ny,ky,arg,l,h) + do 80 i=1,ky1 + spy(it,i) = h(i) + 80 continue + nry(it) = number + 90 continue + ifsy = 1 + 100 if(p.le.0.0d0) go to 120 +c calculate the non-zero elements of the matrix (bx). + if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110 + call fpdisc(tx,nx,kx2,bx,nx) + ifbx = 1 +c calculate the non-zero elements of the matrix (by). + 110 if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120 + call fpdisc(ty,ny,ky2,by,ny) + ifby = 1 +c reduce the matrix (ax) to upper triangular form (rx) using givens +c rotations. apply the same transformations to the rows of matrix q +c to obtain the my x (nx-kx-1) matrix g. +c store matrix (rx) into (ax) and g into q. + 120 l = my*nk1x +c initialization. + do 130 i=1,l + q(i) = 0.0d0 + 130 continue + do 140 i=1,nk1x + do 140 j=1,kx2 + ax(i,j) = 0.0d0 + 140 continue + l = 0 + nrold = 0 +c ibandx denotes the bandwidth of the matrices (ax) and (rx). + ibandx = kx1 + do 270 it=1,mx + number = nrx(it) + 150 if(nrold.eq.number) go to 180 + if(p.le.0.0d0) go to 260 + ibandx = kx2 +c fetch a new row of matrix (bx). + n1 = nrold+1 + do 160 j=1,kx2 + h(j) = bx(n1,j)*pinv + 160 continue +c find the appropriate column of q. + do 170 j=1,my + right(j) = 0.0d0 + 170 continue + irot = nrold + go to 210 +c fetch a new row of matrix (spx). + 180 h(ibandx) = 0.0d0 + do 190 j=1,kx1 + h(j) = spx(it,j) + 190 continue +c find the appropriate column of q. + do 200 j=1,my + l = l+1 + right(j) = z(l) + 200 continue + irot = number +c rotate the new row of matrix (ax) into triangle. + 210 do 240 i=1,ibandx + irot = irot+1 + piv = h(i) + if(piv.eq.0.0d0) go to 240 +c calculate the parameters of the givens transformation. + call fpgivs(piv,ax(irot,1),cos,sin) +c apply that transformation to the rows of matrix q. + iq = (irot-1)*my + do 220 j=1,my + iq = iq+1 + call fprota(cos,sin,right(j),q(iq)) + 220 continue +c apply that transformation to the columns of (ax). + if(i.eq.ibandx) go to 250 + i2 = 1 + i3 = i+1 + do 230 j=i3,ibandx + i2 = i2+1 + call fprota(cos,sin,h(j),ax(irot,i2)) + 230 continue + 240 continue + 250 if(nrold.eq.number) go to 270 + 260 nrold = nrold+1 + go to 150 + 270 continue +c reduce the matrix (ay) to upper triangular form (ry) using givens +c rotations. apply the same transformations to the columns of matrix g +c to obtain the (ny-ky-1) x (nx-kx-1) matrix h. +c store matrix (ry) into (ay) and h into c. + ncof = nk1x*nk1y +c initialization. + do 280 i=1,ncof + c(i) = 0.0d0 + 280 continue + do 290 i=1,nk1y + do 290 j=1,ky2 + ay(i,j) = 0.0d0 + 290 continue + nrold = 0 +c ibandy denotes the bandwidth of the matrices (ay) and (ry). + ibandy = ky1 + do 420 it=1,my + number = nry(it) + 300 if(nrold.eq.number) go to 330 + if(p.le.0.0d0) go to 410 + ibandy = ky2 +c fetch a new row of matrix (by). + n1 = nrold+1 + do 310 j=1,ky2 + h(j) = by(n1,j)*pinv + 310 continue +c find the appropiate row of g. + do 320 j=1,nk1x + right(j) = 0.0d0 + 320 continue + irot = nrold + go to 360 +c fetch a new row of matrix (spy) + 330 h(ibandy) = 0.0d0 + do 340 j=1,ky1 + h(j) = spy(it,j) + 340 continue +c find the appropiate row of g. + l = it + do 350 j=1,nk1x + right(j) = q(l) + l = l+my + 350 continue + irot = number +c rotate the new row of matrix (ay) into triangle. + 360 do 390 i=1,ibandy + irot = irot+1 + piv = h(i) + if(piv.eq.0.0d0) go to 390 +c calculate the parameters of the givens transformation. + call fpgivs(piv,ay(irot,1),cos,sin) +c apply that transformation to the colums of matrix g. + ic = irot + do 370 j=1,nk1x + call fprota(cos,sin,right(j),c(ic)) + ic = ic+nk1y + 370 continue +c apply that transformation to the columns of matrix (ay). + if(i.eq.ibandy) go to 400 + i2 = 1 + i3 = i+1 + do 380 j=i3,ibandy + i2 = i2+1 + call fprota(cos,sin,h(j),ay(irot,i2)) + 380 continue + 390 continue + 400 if(nrold.eq.number) go to 420 + 410 nrold = nrold+1 + go to 300 + 420 continue +c backward substitution to obtain the b-spline coefficients as the +c solution of the linear system (ry) c (rx)' = h. +c first step: solve the system (ry) (c1) = h. + k = 1 + do 450 i=1,nk1x + call fpback(ay,c(k),nk1y,ibandy,c(k),ny) + k = k+nk1y + 450 continue +c second step: solve the system c (rx)' = (c1). + k = 0 + do 480 j=1,nk1y + k = k+1 + l = k + do 460 i=1,nk1x + right(i) = c(l) + l = l+nk1y + 460 continue + call fpback(ax,right,nk1x,ibandx,right,nx) + l = k + do 470 i=1,nk1x + c(l) = right(i) + l = l+nk1y + 470 continue + 480 continue +c calculate the quantities +c res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my +c fp = sumi=1,mx(sumj=1,my(res(i,j))) +c fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1 +c tx(r+kx) <= x(i) <= tx(r+kx+1) +c fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1 +c ty(r+ky) <= y(j) <= ty(r+ky+1) + fp = 0.0d0 + do 490 i=1,nx + fpx(i) = 0.0d0 + 490 continue + do 500 i=1,ny + fpy(i) = 0.0d0 + 500 continue + nk1y = ny-ky1 + iz = 0 + nroldx = 0 +c main loop for the different grid points. + do 550 i1=1,mx + numx = nrx(i1) + numx1 = numx+1 + nroldy = 0 + do 540 i2=1,my + numy = nry(i2) + numy1 = numy+1 + iz = iz+1 +c evaluate s(x,y) at the current grid point by making the sum of the +c cross products of the non-zero b-splines at (x,y), multiplied with +c the appropiate b-spline coefficients. + term = 0.0d0 + k1 = numx*nk1y+numy + do 520 l1=1,kx1 + k2 = k1 + fac = spx(i1,l1) + do 510 l2=1,ky1 + k2 = k2+1 + term = term+fac*spy(i2,l2)*c(k2) + 510 continue + k1 = k1+nk1y + 520 continue +c calculate the squared residual at the current grid point. + term = (z(iz)-term)**2 +c adjust the different parameters. + fp = fp+term + fpx(numx1) = fpx(numx1)+term + fpy(numy1) = fpy(numy1)+term + fac = term*half + if(numy.eq.nroldy) go to 530 + fpy(numy1) = fpy(numy1)-fac + fpy(numy) = fpy(numy)+fac + 530 nroldy = numy + if(numx.eq.nroldx) go to 540 + fpx(numx1) = fpx(numx1)-fac + fpx(numx) = fpx(numx)+fac + 540 continue + nroldx = numx + 550 continue + return + end +c + subroutine fpknot(x,m,t,n,fpint,nrdata,nrint,nest,istart) +c subroutine fpknot locates an additional knot for a spline of degree +c k and adjusts the corresponding parameters,i.e. +c t : the position of the knots. +c n : the number of knots. +c nrint : the number of knotintervals. +c fpint : the sum of squares of residual right hand sides +c for each knot interval. +c nrdata: the number of data points inside each knot interval. +c istart indicates that the smallest data point at which the new knot +c may be added is x(istart+1) +c .. +c ..scalar arguments.. + integer m,n,nrint,nest,istart +c ..array arguments.. + real*8 x(m),t(nest),fpint(nest) + integer nrdata(nest) +c ..local scalars.. + real*8 an,am,fpmax + integer ihalf,j,jbegin,jj,jk,jpoint,k,maxbeg,maxpt, + * next,nrx,number +c .. + k = (n-nrint-1)/2 +c search for knot interval t(number+k) <= x <= t(number+k+1) where +c fpint(number) is maximal on the condition that nrdata(number) +c not equals zero. + fpmax = 0.0d0 + jbegin = istart + do 20 j=1,nrint + jpoint = nrdata(j) + if(fpmax.ge.fpint(j) .or. jpoint.eq.0) go to 10 + fpmax = fpint(j) + number = j + maxpt = jpoint + maxbeg = jbegin + 10 jbegin = jbegin+jpoint+1 + 20 continue +c let coincide the new knot t(number+k+1) with a data point x(nrx) +c inside the old knot interval t(number+k) <= x <= t(number+k+1). + ihalf = maxpt/2+1 + nrx = maxbeg+ihalf + next = number+1 + if(next.gt.nrint) go to 40 +c adjust the different parameters. + do 30 j=next,nrint + jj = next+nrint-j + fpint(jj+1) = fpint(jj) + nrdata(jj+1) = nrdata(jj) + jk = jj+k + t(jk+1) = t(jk) + 30 continue + 40 nrdata(number) = ihalf-1 + nrdata(next) = maxpt-ihalf + am = maxpt + an = nrdata(number) + fpint(number) = fpmax*an/am + an = nrdata(next) + fpint(next) = fpmax*an/am + jk = next+k + t(jk) = x(nrx) + n = n+1 + nrint = nrint+1 + return + end +c + + subroutine fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s, + * nxest,nyest,tol,maxit,nc,nx,tx,ny,ty,c,fp,fp0,fpold,reducx, + * reducy,fpintx,fpinty,lastdi,nplusx,nplusy,nrx,nry,nrdatx,nrdaty, + * wrk,lwrk,ier) +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,tol,fp,fp0,fpold,reducx,reducy + integer iopt,mx,my,mz,kx,ky,nxest,nyest,maxit,nc,nx,ny,lastdi, + * nplusx,nplusy,lwrk,ier +c ..array arguments.. + real*8 x(mx),y(my),z(mz),tx(nxest),ty(nyest),c(nc),fpintx(nxest), + * fpinty(nyest),wrk(lwrk) + integer nrdatx(nxest),nrdaty(nyest),nrx(mx),nry(my) +c ..local scalars + real*8 acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,half,con1,con9,con4 + integer i,ich1,ich3,ifbx,ifby,ifsx,ifsy,iter,j,kx1,kx2,ky1,ky2, + * k3,l,lax,lay,lbx,lby,lq,lri,lsx,lsy,mk1,mm,mpm,mynx,ncof, + * nk1x,nk1y,nmaxx,nmaxy,nminx,nminy,nplx,nply,npl1,nrintx, + * nrinty,nxe,nxk,nye +c + real*8 fprati + +c ..subroutine references.. +c fpgrre,fpknot +c .. +c set constants + parameter(one = 1.0d0,half = 0.5d0) + parameter(con1 = 0.1d0,con9 = 0.9d0,con4 = 0.4d-01) +c we partition the working space. + kx1 = kx+1 + ky1 = ky+1 + kx2 = kx1+1 + ky2 = ky1+1 + lsx = 1 + lsy = lsx+mx*kx1 + lri = lsy+my*ky1 + mm = max(nxest,my) + lq = lri+mm + mynx = nxest*my + lax = lq+mynx + nxk = nxest*kx2 + lbx = lax+nxk + lay = lbx+nxk + lby = lay+nyest*ky2 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 1: determination of the number of knots and their position. c +c **************************************************************** c +c given a set of knots we compute the least-squares spline sinf(x,y), c +c and the corresponding sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(x,y) is the requested approximation. c +c if iopt=0 or iopt=1 we check whether we can accept the knots: c +c if fp <=s we will continue with the current set of knots. c +c if fp > s we will increase the number of knots and compute the c +c corresponding least-squares spline until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmaxx = mx+kx+1 and nmaxy = my+ky+1. c +c if s>0 and c +c *iopt=0 we first compute the least-squares polynomial of degree c +c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2. c +c *iopt=1 we start with the knots found at the last call of the c +c routine, except for the case that s > fp0; then we can compute c +c the least-squares polynomial directly. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine the number of knots for polynomial approximation. + nminx = 2*kx1 + nminy = 2*ky1 + if(iopt.lt.0) go to 120 +c acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +c find nmaxx and nmaxy which denote the number of knots in x- and y- +c direction in case of spline interpolation. + nmaxx = mx+kx1 + nmaxy = my+ky1 +c find nxe and nye which denote the maximum number of knots +c allowed in each direction + nxe = min(nmaxx,nxest) + nye = min(nmaxy,nyest) + if(s.gt.0.0d0) go to 100 +c if s = 0, s(x,y) is an interpolating spline. + nx = nmaxx + ny = nmaxy +c test whether the required storage space exceeds the available one. + if(ny.gt.nyest .or. nx.gt.nxest) go to 420 +c find the position of the interior knots in case of interpolation. +c the knots in the x-direction. + mk1 = mx-kx1 + if(mk1.eq.0) go to 60 + k3 = kx/2 + i = kx1+1 + j = k3+2 + if(k3*2.eq.kx) go to 40 + do 30 l=1,mk1 + tx(i) = x(j) + i = i+1 + j = j+1 + 30 continue + go to 60 + 40 do 50 l=1,mk1 + tx(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + 50 continue +c the knots in the y-direction. + 60 mk1 = my-ky1 + if(mk1.eq.0) go to 120 + k3 = ky/2 + i = ky1+1 + j = k3+2 + if(k3*2.eq.ky) go to 80 + do 70 l=1,mk1 + ty(i) = y(j) + i = i+1 + j = j+1 + 70 continue + go to 120 + 80 do 90 l=1,mk1 + ty(i) = (y(j)+y(j-1))*half + i = i+1 + j = j+1 + 90 continue + go to 120 +c if s > 0 our initial choice of knots depends on the value of iopt. + 100 if(iopt.eq.0) go to 115 + if(fp0.le.s) go to 115 +c if iopt=1 and fp0 > s we start computing the least- squares spline +c according to the set of knots found at the last call of the routine. +c we determine the number of grid coordinates x(i) inside each knot +c interval (tx(l),tx(l+1)). + l = kx2 + j = 1 + nrdatx(1) = 0 + mpm = mx-1 + do 105 i=2,mpm + nrdatx(j) = nrdatx(j)+1 + if(x(i).lt.tx(l)) go to 105 + nrdatx(j) = nrdatx(j)-1 + l = l+1 + j = j+1 + nrdatx(j) = 0 + 105 continue +c we determine the number of grid coordinates y(i) inside each knot +c interval (ty(l),ty(l+1)). + l = ky2 + j = 1 + nrdaty(1) = 0 + mpm = my-1 + do 110 i=2,mpm + nrdaty(j) = nrdaty(j)+1 + if(y(i).lt.ty(l)) go to 110 + nrdaty(j) = nrdaty(j)-1 + l = l+1 + j = j+1 + nrdaty(j) = 0 + 110 continue + go to 120 +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial of degree kx in x and ky in y (which is a spline without +c interior knots). + 115 nx = nminx + ny = nminy + nrdatx(1) = mx-2 + nrdaty(1) = my-2 + lastdi = 0 + nplusx = 0 + nplusy = 0 + fp0 = 0.0d0 + fpold = 0.0d0 + reducx = 0.0d0 + reducy = 0.0d0 + 120 mpm = mx+my + ifsx = 0 + ifsy = 0 + ifbx = 0 + ifby = 0 + p = -one +c main loop for the different sets of knots.mpm=mx+my is a save upper +c bound for the number of trials. + do 250 iter=1,mpm + if(nx.eq.nminx .and. ny.eq.nminy) ier = -2 +c find nrintx (nrinty) which is the number of knot intervals in the +c x-direction (y-direction). + nrintx = nx-nminx+1 + nrinty = ny-nminy+1 +c find ncof, the number of b-spline coefficients for the current set +c of knots. + nk1x = nx-kx1 + nk1y = ny-ky1 + ncof = nk1x*nk1y +c find the position of the additional knots which are needed for the +c b-spline representation of s(x,y). + i = nx + do 130 j=1,kx1 + tx(j) = xb + tx(i) = xe + i = i-1 + 130 continue + i = ny + do 140 j=1,ky1 + ty(j) = yb + ty(i) = ye + i = i-1 + 140 continue +c find the least-squares spline sinf(x,y) and calculate for each knot +c interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum +c of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2, +c ...,ny-2*ky-1) for the data points having their absciss (ordinate)- +c value belonging to that interval. +c fp gives the total sum of squared residuals. + call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, + * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), + * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), + * nrx,nry) + if(ier.eq.(-2)) fp0 = fp +c test whether the least-squares spline is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms) .lt. acc) go to 440 +c if f(p=inf) < s, we accept the choice of knots. + if(fpms.lt.0.0d0) go to 300 +c if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline. + if(nx.eq.nmaxx .and. ny.eq.nmaxy) go to 430 +c increase the number of knots. +c if nx=nxe and ny=nye we cannot further increase the number of knots +c because of the storage capacity limitation. + if(nx.eq.nxe .and. ny.eq.nye) go to 420 + ier = 0 +c adjust the parameter reducx or reducy according to the direction +c in which the last added knots were located. + if(lastdi) 150,170,160 + 150 reducx = fpold-fp + go to 170 + 160 reducy = fpold-fp +c store the sum of squared residuals for the current set of knots. + 170 fpold = fp +c find nplx, the number of knots we should add in the x-direction. + nplx = 1 + if(nx.eq.nminx) go to 180 + npl1 = nplusx*2 + rn = nplusx + if(reducx.gt.acc) npl1 = rn*fpms/reducx + nplx = min(nplusx*2,max(npl1,nplusx/2,1)) +c find nply, the number of knots we should add in the y-direction. + 180 nply = 1 + if(ny.eq.nminy) go to 190 + npl1 = nplusy*2 + rn = nplusy + if(reducy.gt.acc) npl1 = rn*fpms/reducy + nply = min0(nplusy*2,max0(npl1,nplusy/2,1)) + 190 if(nplx-nply) 210,200,230 + 200 if(lastdi.lt.0) go to 230 + 210 if(nx.eq.nxe) go to 230 +c addition in the x-direction. + lastdi = -1 + nplusx = nplx + ifsx = 0 + do 220 l=1,nplusx +c add a new knot in the x-direction + call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1) +c test whether we cannot further increase the number of knots in the +c x-direction. + if(nx.eq.nxe) go to 250 + 220 continue + go to 250 + 230 if(ny.eq.nye) go to 210 +c addition in the y-direction. + lastdi = 1 + nplusy = nply + ifsy = 0 + do 240 l=1,nplusy +c add a new knot in the y-direction. + call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1) +c test whether we cannot further increase the number of knots in the +c y-direction. + if(ny.eq.nye) go to 250 + 240 continue +c restart the computations with the new set of knots. + 250 continue +c test whether the least-squares polynomial is a solution of our +c approximation problem. + 300 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x,y) c +c ***************************************************** c +c we have determined the number of knots and their position. we now c +c compute the b-spline coefficients of the smoothing spline sp(x,y). c +c this smoothing spline varies with the parameter p in such a way thatc +c f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2) c +c is a continuous, strictly decreasing function of p. moreover the c +c least-squares polynomial corresponds to p=0 and the least-squares c +c spline to p=infinity. iteratively we then have to determine the c +c positive value of p such that f(p)=s. the process which is proposed c +c here makes use of rational interpolation. f(p) is approximated by a c +c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +c are used to calculate the new value of p such that r(p)=s. c +c convergence is guaranteed by taking f1 > 0 and f3 < 0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c initial value for p. + p1 = 0.0d0 + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + ich1 = 0 + ich3 = 0 +c iteration process to find the root of f(p)=s. + do 350 iter = 1,maxit +c find the smoothing spline sp(x,y) and the corresponding sum of +c squared residuals fp. + call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, + * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), + * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), + * nrx,nry) +c test whether the approximation sp(x,y) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximum allowable number of iterations has been +c reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 320 + if((f2-f3).gt.acc) go to 310 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p = p1*con9 + p2*con1 + go to 350 + 310 if(f2.lt.0.0d0) ich3 = 1 + 320 if(ich1.ne.0) go to 340 + if((f1-f2).gt.acc) go to 330 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.0d0) go to 350 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 350 +c test whether the iteration process proceeds as theoretically +c expected. + 330 if(f2.gt.0.0d0) ich1 = 1 + 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 350 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + fp = 0.0d0 + 440 return + end +c + subroutine fprota(cos,sin,a,b) +c subroutine fprota applies a givens rotation to a and b. +c .. +c ..scalar arguments.. + real*8 cos,sin,a,b +c ..local scalars.. + real*8 stor1,stor2 +c .. + stor1 = a + stor2 = b + b = cos*stor2+sin*stor1 + a = cos*stor1-sin*stor2 + return + end +c +c +c + double precision function fprati(p1,f1,p2,f2,p3,f3) +c given three points (p1,f1),(p2,f2) and (p3,f3), function fprati +c gives the value of p such that the rational interpolating function +c of the form r(p) = (u*p+v)/(p+w) equals zero at p. +c .. +c ..scalar arguments.. + real*8 p1,f1,p2,f2,p3,f3 +c ..local scalars.. + real*8 h1,h2,h3,p +c .. + if(p3.gt.0.0d0) go to 10 +c value of p in case p3 = infinity. + p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3) + go to 20 +c value of p in case p3 ^= infinity. + 10 h1 = f1*(f2-f3) + h2 = f2*(f3-f1) + h3 = f3*(f1-f2) + p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3) +c adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0. + 20 if(f2.lt.0.0d0) go to 30 + p1 = p2 + f1 = f2 + go to 40 + 30 p3 = p2 + f3 = f2 + 40 fprati = p + return + end +c + subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s, + * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c given the set of values z(i,j) on the rectangular grid (x(i),y(j)), +c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar- +c iate spline approximation s(x,y) of degrees kx and ky on the rect- +c angle xb <= x <= xe, yb <= y <= ye. +c if iopt = -1 regrid calculates the least-squares spline according +c to a given set of knots. +c if iopt >= 0 the total numbers nx and ny of these knots and their +c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +c ally by the routine. the smoothness of s(x,y) is then achieved by +c minimalizing the discontinuity jumps in the derivatives of s(x,y) +c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +c the amounth of smoothness is determined by the condition that f(p) = +c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative +c constant, called the smoothing factor. +c the fit is given in the b-spline representation (b-spline coefficients +c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +c uated by means of subroutine bispev. +c +c calling sequence: +c call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest, +c * nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a least- +c squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1) +c must be determined. +c if iopt=0 the routine will start with an initial set of knots +c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +c 1,...,ky+1. if iopt=1 the routine will continue with the set +c of knots found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately pre- +c ceded by another call with iopt=1 or iopt=0 and +c s.ne.0. +c unchanged on exit. +c mx : integer. on entry mx must specify the number of grid points +c along the x-axis. mx > kx . unchanged on exit. +c x : real array of dimension at least (mx). before entry, x(i) +c must be set to the x-co-ordinate of the i-th grid point +c along the x-axis, for i=1,2,...,mx. these values must be +c supplied in strictly ascending order. unchanged on exit. +c my : integer. on entry my must specify the number of grid points +c along the y-axis. my > ky . unchanged on exit. +c y : real array of dimension at least (my). before entry, y(j) +c must be set to the y-co-ordinate of the j-th grid point +c along the y-axis, for j=1,2,...,my. these values must be +c supplied in strictly ascending order. unchanged on exit. +c z : real array of dimension at least (mx*my). +c before entry, z(my*(i-1)+j) must be set to the data value at +c the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my. +c unchanged on exit. +c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +c yb,ye aries of the rectangular approximation domain. +c xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my. +c unchanged on exit. +c kx,ky : integer values. on entry kx and ky must specify the degrees +c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +c (kx=ky=3) splines. unchanged on exit. +c s : real. on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments +c nxest : integer. unchanged on exit. +c nyest : integer. unchanged on exit. +c on entry, nxest and nyest must specify an upper bound for the +c number of knots required in the x- and y-directions respect. +c these numbers will also determine the storage space needed by +c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +c in most practical situation nxest = mx/2, nyest=my/2, will +c be sufficient. always large enough are nxest=mx+kx+1, nyest= +c my+ky+1, the number of knots needed for interpolation (s=0). +c see also further comments. +c nx : integer. +c unless ier=10 (in case iopt >=0), nx will contain the total +c number of knots with respect to the x-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of nx should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of nx should be specified on entry +c tx : real array of dimension nmax. +c on succesful exit, this array will contain the knots of the +c spline with respect to the x-variable, i.e. the position of +c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +c position of the additional knots tx(1)=...=tx(kx+1)=xb and +c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of tx(1), +c ...,tx(nx) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values tx(kx+2), +c ...tx(nx-kx-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c ny : integer. +c unless ier=10 (in case iopt >=0), ny will contain the total +c number of knots with respect to the y-variable, of the spline +c approximation returned. if the computation mode iopt=1 is +c used, the value of ny should be left unchanged between sub- +c sequent calls. +c in case iopt=-1, the value of ny should be specified on entry +c ty : real array of dimension nmax. +c on succesful exit, this array will contain the knots of the +c spline with respect to the y-variable, i.e. the position of +c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +c position of the additional knots ty(1)=...=ty(ky+1)=yb and +c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +c if the computation mode iopt=1 is used, the values of ty(1), +c ...,ty(ny) should be left unchanged between subsequent calls. +c if the computation mode iopt=-1 is used, the values ty(ky+2), +c ...ty(ny-ky-1) must be supplied by the user, before entry. +c see also the restrictions (ier=10). +c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +c on succesful exit, c contains the coefficients of the spline +c approximation s(x,y) +c fp : real. unless ier=10, fp contains the sum of squared +c residuals of the spline approximation returned. +c wrk : real array of dimension (lwrk). used as workspace. +c if the computation mode iopt=1 is used the values of wrk(1), +c ...,wrk(4) should be left unchanged between subsequent calls. +c lwrk : integer. on entry lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program. +c lwrk must not be too small. +c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +c my*(ky+1) +u +c where u is the larger of my and nxest. +c iwrk : integer array of dimension (kwrk). used as workspace. +c if the computation mode iopt=1 is used the values of iwrk(1), +c ...,iwrk(3) should be left unchanged between subsequent calls +c kwrk : integer. on entry kwrk must specify the actual dimension of +c the array iwrk as declared in the calling (sub)program. +c kwrk >= 3+mx+my+nxest+nyest. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the least-squares +c polynomial of degrees kx and ky. in this extreme case fp +c gives the upper bound for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameters nxest and +c nyest. +c probably causes : nxest or nyest too small. if these param- +c eters are already large, it may also indicate that s is +c too small +c the approximation returned is the least-squares spline +c according to the current set of knots. the parameter fp +c gives the corresponding sum of squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration proces for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c sum of squared residuals does not satisfy the condition +c abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2, +c nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest, +c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +c my*(ky+1) +max(my,nxest), +c xb<=x(i-1)=0: s>=0 +c if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c regrid does not allow individual weighting of the data-values. +c so, if these were determined to widely different accuracies, then +c perhaps the general data set routine surfit should rather be used +c in spite of efficiency. +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the least-squares polynomial (degrees kx,ky) if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the accuracy of the data values. +c if the user has an idea of the statistical errors on the data, he +c can also find a proper estimate for s. for, by assuming that, if he +c specifies the right s, regrid will return a spline s(x,y) which +c exactly reproduces the function underlying the data he can evaluate +c the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s +c for example, if he knows that the statistical errors on his z(i,j)- +c values is not greater than 0.1, he may expect that a good s should +c have a value not larger than mx*my*(0.1)**2. +c if nothing is known about the statistical error in z(i,j), s must +c be determined by trial and error, taking account of the comments +c above. the best is then to start with a very large value of s (to +c determine the least-squares polynomial and the corresponding upper +c bound fp0 for s) and then to progressively decrease the value of s +c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +c and more carefully as the approximation shows more detail) to +c obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if regrid is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c regrid once more with the selected value for s but now with iopt=0. +c indeed, regrid may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c the number of knots may also depend on the upper bounds nxest and +c nyest. indeed, if at a certain stage in regrid the number of knots +c in one direction (say nx) has reached the value of its upper bound +c (nxest), then from that moment on all subsequent knots are added +c in the other (y) direction. this may indicate that the value of +c nxest is too small. on the other hand, it gives the user the option +c of limiting the number of knots the routine locates in any direction +c for example, by setting nxest=2*kx+2 (the lowest allowable value for +c nxest), the user can indicate that he wants an approximation which +c is a simple polynomial of degree kx in the variable x. +c +c other subroutines required: +c fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec, +c fpknot +c +c references: +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, siam j.numer.anal. +c 19 (1982) 1286-1304. +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, report tw53, dept. +c computer science,k.u.leuven, 1980. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1989 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,yb,ye,s,fp + integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier +c ..array arguments.. + real*8 x(mx),y(my),z(mx*my),tx(nxest),ty(nyest), + * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk) + integer iwrk(kwrk) +c ..local scalars.. + real*8 tol + integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2, + * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz +c ..subroutine references.. +c fpregr,fpchec +c .. +c we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1d-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(kx.le.0 .or. kx.gt.5) go to 70 + kx1 = kx+1 + kx2 = kx1+1 + if(ky.le.0 .or. ky.gt.5) go to 70 + ky1 = ky+1 + ky2 = ky1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 70 + nminx = 2*kx1 + if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70 + nminy = 2*ky1 + if(my.lt.ky1 .or. nyest.lt.nminy) go to 70 + mz = mx*my + nc = (nxest-kx1)*(nyest-ky1) + lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+ + * my*ky1+max(nxest,my) + kwest = 3+mx+my+nxest+nyest + if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70 + if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70 + do 10 i=2,mx + if(x(i-1).ge.x(i)) go to 70 + 10 continue + if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70 + do 20 i=2,my + if(y(i-1).ge.y(i)) go to 70 + 20 continue + if(iopt.ge.0) go to 50 + if(nx.lt.nminx .or. nx.gt.nxest) go to 70 + j = nx + do 30 i=1,kx1 + tx(i) = xb + tx(j) = xe + j = j-1 + 30 continue + call fpchec(x,mx,tx,nx,kx,ier) + if(ier.ne.0) go to 70 + if(ny.lt.nminy .or. ny.gt.nyest) go to 70 + j = ny + do 40 i=1,ky1 + ty(i) = yb + ty(j) = ye + j = j-1 + 40 continue + call fpchec(y,my,ty,ny,ky,ier) + if(ier) 70,60,70 + 50 if(s.lt.0.0d0) go to 70 + if(s.eq.0.0d0 .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) ) + * go to 70 + ier = 0 +c we partition the working space and determine the spline approximation + 60 lfpx = 5 + lfpy = lfpx+nxest + lww = lfpy+nyest + jwrk = lwrk-4-nxest-nyest + knrx = 4 + knry = knrx+mx + kndx = knry+my + kndy = kndx+nxest + call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest, + * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4), + * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx), + * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier) + 70 return + end +c + subroutine parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z, + * wrk,lwrk,iwrk,kwrk,ier) +c subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +c ,my the partial derivative ( order nux,nuy) of a bivariate spline +c s(x,y) of degrees kx and ky, given in the b-spline representation. +c +c calling sequence: +c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c nux : integer values, specifying the order of the partial +c nuy derivative. 0<=nux=1. +c y : real array of dimension (my). +c before entry y(j) must be set to the y co-ordinate of the +c j-th grid point along the y-axis. +c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +c my : on entry my must specify the number of grid points along +c the y-axis. my >=1. +c wrk : real array of dimension lwrk. used as workspace. +c lwrk : integer, specifying the dimension of wrk. +c lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (mx*my). +c on succesful exit z(my*(i-1)+j) contains the value of the +c specified partial derivative of s(x,y) at the point +c (x(i),y(j)),i=1,...,mx;j=1,...,my. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my +c lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,nux,nuy,mx,my,lwrk,kwrk,ier +c ..array arguments.. + integer iwrk(kwrk) + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), + * wrk(lwrk) +c ..local scalars.. + integer i,iwx,iwy,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,m,m0,m1, + * nc,nkx1,nky1,nxx,nyy + real*8 ak,fac +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + nc = nkx1*nky1 + if(nux.lt.0 .or. nux.ge.kx) go to 400 + if(nuy.lt.0 .or. nuy.ge.ky) go to 400 + lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my + if(lwrk.lt.lwest) go to 400 + if(kwrk.lt.(mx+my)) go to 400 + if(mx-1) 400,30,10 + 10 do 20 i=2,mx + if(x(i).lt.x(i-1)) go to 400 + 20 continue + 30 if(my-1) 400,60,40 + 40 do 50 i=2,my + if(y(i).lt.y(i-1)) go to 400 + 50 continue + 60 ier = 0 + nxx = nkx1 + nyy = nky1 + kkx = kx + kky = ky +c the partial derivative of order (nux,nuy) of a bivariate spline of +c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy. +c we calculate the b-spline coefficients of this spline + do 70 i=1,nc + wrk(i) = c(i) + 70 continue + if(nux.eq.0) go to 200 + lx = 1 + do 100 j=1,nux + ak = kkx + nxx = nxx-1 + l1 = lx + m0 = 1 + do 90 i=1,nxx + l1 = l1+1 + l2 = l1+kkx + fac = tx(l2)-tx(l1) + if(fac.le.0.0d0) go to 90 + do 80 m=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + 80 continue + 90 continue + lx = lx+1 + kkx = kkx-1 + 100 continue + 200 if(nuy.eq.0) go to 300 + ly = 1 + do 230 j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do 220 i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac.le.0.0d0) go to 220 + m0 = i + do 210 m=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + 210 continue + 220 continue + ly = ly+1 + kky = kky-1 + 230 continue + m0 = nyy + m1 = nky1 + do 250 m=2,nxx + do 240 i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + 240 continue + m1 = m1+nuy + 250 continue +c we partition the working space and evaluate the partial derivative + 300 iwx = 1+nxx*nyy + iwy = iwx+mx*(kx1-nux) + call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,wrk,kkx,kky, + * x,mx,y,my,z,wrk(iwx),wrk(iwy),iwrk(1),iwrk(mx+1)) + 400 return + end + + + subroutine coeff_parder(tx,nx,ty,ny,c,kx,ky,nux,nuy, + * wrk,lwrk,ier) +c subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +c ,my the partial derivative ( order nux,nuy) of a bivariate spline +c s(x,y) of degrees kx and ky, given in the b-spline representation. +c +c calling sequence: +c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +c * iwrk,kwrk,ier) +c +c input parameters: +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c nux : integer values, specifying the order of the partial +c nuy derivative. 0<=nux= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +c iwrk : integer array of dimension kwrk. used as workspace. +c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +c +c output parameters: +c z : real array of dimension (mx*my). +c on succesful exit z(my*(i-1)+j) contains the value of the +c specified partial derivative of s(x,y) at the point +c (x(i),y(j)),i=1,...,mx;j=1,...,my. +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my +c lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +c +c other subroutines required: +c fpbisp,fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1989 +c +c ..scalar arguments.. + integer nx,ny,kx,ky,nux,nuy,mx,my,lwrk,ier +c ..array arguments.. + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),wrk(lwrk) +c ..local scalars.. + integer i,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,m,m0,m1, + * nc,nkx1,nky1,nxx,nyy + real*8 ak,fac +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + mx=1 + my=1 + ier = 10 + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + nc = nkx1*nky1 + if(nux.lt.0 .or. nux.ge.kx) go to 400 + if(nuy.lt.0 .or. nuy.ge.ky) go to 400 + lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my + if(lwrk.lt.lwest) go to 400 + ier = 0 + nxx = nkx1 + nyy = nky1 + kkx = kx + kky = ky +c the partial derivative of order (nux,nuy) of a bivariate spline of +c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy. +c we calculate the b-spline coefficients of this spline + do 70 i=1,nc + wrk(i) = c(i) + 70 continue + if(nux.eq.0) go to 200 + lx = 1 + do 100 j=1,nux + ak = kkx + nxx = nxx-1 + l1 = lx + m0 = 1 + do 90 i=1,nxx + l1 = l1+1 + l2 = l1+kkx + fac = tx(l2)-tx(l1) + if(fac.le.0.0d0) go to 90 + do 80 m=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + 80 continue + 90 continue + lx = lx+1 + kkx = kkx-1 + 100 continue + 200 if(nuy.eq.0) go to 400 + ly = 1 + do 230 j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do 220 i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac.le.0.0d0) go to 220 + m0 = i + do 210 m=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + 210 continue + 220 continue + ly = ly+1 + kky = kky-1 + 230 continue + m0 = nyy + m1 = nky1 + do 250 m=2,nxx + do 240 i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + 240 continue + m1 = m1+nuy + 250 continue + 400 return + end + +c +c +c + subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp, + * wrk,lwrk,iwrk,ier) +c given the set of data points (x(i),y(i)) and the set of positive +c numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline +c approximation of degree k on the interval xb <= x <= xe. +c if iopt=-1 curfit calculates the weighted least-squares spline +c according to a given set of knots. +c if iopt>=0 the number of knots of the spline s(x) and the position +c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +c ness of s(x) is then achieved by minimalizing the discontinuity +c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., +c n-k-1. the amount of smoothness is determined by the condition that +c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- +c negative constant, called the smoothing factor. +c the fit s(x) is given in the b-spline representation (b-spline coef- +c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of +c subroutine splev. +c +c calling sequence: +c call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk, +c * lwrk,iwrk,ier) +c +c parameters: +c iopt : integer flag. on entry iopt must specify whether a weighted +c least-squares spline (iopt=-1) or a smoothing spline (iopt= +c 0 or 1) must be determined. if iopt=0 the routine will start +c with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,... +c k+1. if iopt=1 the routine will continue with the knots +c found at the last call of the routine. +c attention: a call with iopt=1 must always be immediately +c preceded by another call with iopt=1 or iopt=0. +c unchanged on exit. +c m : integer. on entry m must specify the number of data points. +c m > k. unchanged on exit. +c x : real array of dimension at least (m). before entry, x(i) +c must be set to the i-th value of the independent variable x, +c for i=1,2,...,m. these values must be supplied in strictly +c ascending order. unchanged on exit. +c y : real array of dimension at least (m). before entry, y(i) +c must be set to the i-th value of the dependent variable y, +c for i=1,2,...,m. unchanged on exit. +c w : real array of dimension at least (m). before entry, w(i) +c must be set to the i-th value in the set of weights. the +c w(i) must be strictly positive. unchanged on exit. +c see also further comments. +c xb,xe : real values. on entry xb and xe must specify the boundaries +c of the approximation interval. xb<=x(1), xe>=x(m). +c unchanged on exit. +c k : integer. on entry k must specify the degree of the spline. +c 1<=k<=5. it is recommended to use cubic splines (k=3). +c the user is strongly dissuaded from choosing k even,together +c with a small s-value. unchanged on exit. +c s : real.on entry (in case iopt>=0) s must specify the smoothing +c factor. s >=0. unchanged on exit. +c for advice on the choice of s see further comments. +c nest : integer. on entry nest must contain an over-estimate of the +c total number of knots of the spline returned, to indicate +c the storage space available to the routine. nest >=2*k+2. +c in most practical situation nest=m/2 will be sufficient. +c always large enough is nest=m+k+1, the number of knots +c needed for interpolation (s=0). unchanged on exit. +c n : integer. +c unless ier =10 (in case iopt >=0), n will contain the +c total number of knots of the spline approximation returned. +c if the computation mode iopt=1 is used this value of n +c should be left unchanged between subsequent calls. +c in case iopt=-1, the value of n must be specified on entry. +c t : real array of dimension at least (nest). +c on succesful exit, this array will contain the knots of the +c spline,i.e. the position of the interior knots t(k+2),t(k+3) +c ...,t(n-k-1) as well as the position of the additional knots +c t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for +c the b-spline representation. +c if the computation mode iopt=1 is used, the values of t(1), +c t(2),...,t(n) should be left unchanged between subsequent +c calls. if the computation mode iopt=-1 is used, the values +c t(k+2),...,t(n-k-1) must be supplied by the user, before +c entry. see also the restrictions (ier=10). +c c : real array of dimension at least (nest). +c on succesful exit, this array will contain the coefficients +c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) +c fp : real. unless ier=10, fp contains the weighted sum of +c squared residuals of the spline approximation returned. +c wrk : real array of dimension at least (m*(k+1)+nest*(7+3*k)). +c used as working space. if the computation mode iopt=1 is +c used, the values wrk(1),...,wrk(n) should be left unchanged +c between subsequent calls. +c lwrk : integer. on entry,lwrk must specify the actual dimension of +c the array wrk as declared in the calling (sub)program.lwrk +c must not be too small (see wrk). unchanged on exit. +c iwrk : integer array of dimension at least (nest). +c used as working space. if the computation mode iopt=1 is +c used,the values iwrk(1),...,iwrk(n) should be left unchanged +c between subsequent calls. +c ier : integer. unless the routine detects an error, ier contains a +c non-positive value on exit, i.e. +c ier=0 : normal return. the spline returned has a residual sum of +c squares fp such that abs(fp-s)/s <= tol with tol a relat- +c ive tolerance set to 0.001 by the program. +c ier=-1 : normal return. the spline returned is an interpolating +c spline (fp=0). +c ier=-2 : normal return. the spline returned is the weighted least- +c squares polynomial of degree k. in this extreme case fp +c gives the upper bound fp0 for the smoothing factor s. +c ier=1 : error. the required storage space exceeds the available +c storage space, as specified by the parameter nest. +c probably causes : nest too small. if nest is already +c large (say nest > m/2), it may also indicate that s is +c too small +c the approximation returned is the weighted least-squares +c spline according to the knots t(1),t(2),...,t(n). (n=nest) +c the parameter fp gives the corresponding weighted sum of +c squared residuals (fp>s). +c ier=2 : error. a theoretically impossible result was found during +c the iteration proces for finding a smoothing spline with +c fp = s. probably causes : s too small. +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=3 : error. the maximal number of iterations maxit (set to 20 +c by the program) allowed for finding a smoothing spline +c with fp=s has been reached. probably causes : s too small +c there is an approximation returned but the corresponding +c weighted sum of squared residuals does not satisfy the +c condition abs(fp-s)/s < tol. +c ier=10 : error. on entry, the input data are controlled on validity +c the following restrictions must be satisfied. +c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m +c xb<=x(1)=(k+1)*m+nest*(7+3*k) +c if iopt=-1: 2*k+2<=n<=min(nest,m+k+1) +c xb=0: s>=0 +c if s=0 : nest >= m+k+1 +c if one of these conditions is found to be violated,control +c is immediately repassed to the calling program. in that +c case there is no approximation returned. +c +c further comments: +c by means of the parameter s, the user can control the tradeoff +c between closeness of fit and smoothness of fit of the approximation. +c if s is too large, the spline will be too smooth and signal will be +c lost ; if s is too small the spline will pick up too much noise. in +c the extreme cases the program will return an interpolating spline if +c s=0 and the weighted least-squares polynomial of degree k if s is +c very large. between these extremes, a properly chosen s will result +c in a good compromise between closeness of fit and smoothness of fit. +c to decide whether an approximation, corresponding to a certain s is +c satisfactory the user is highly recommended to inspect the fits +c graphically. +c recommended values for s depend on the weights w(i). if these are +c taken as 1/d(i) with d(i) an estimate of the standard deviation of +c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +c sqrt(2*m)). if nothing is known about the statistical error in y(i) +c each w(i) can be set equal to one and s determined by trial and +c error, taking account of the comments above. the best is then to +c start with a very large value of s ( to determine the least-squares +c polynomial and the corresponding upper bound fp0 for s) and then to +c progressively decrease the value of s ( say by a factor 10 in the +c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +c approximation shows more detail) to obtain closer fits. +c to economize the search for a good s-value the program provides with +c different modes of computation. at the first call of the routine, or +c whenever he wants to restart with the initial set of knots the user +c must set iopt=0. +c if iopt=1 the program will continue with the set of knots found at +c the last call of the routine. this will save a lot of computation +c time if curfit is called repeatedly for different values of s. +c the number of knots of the spline returned and their location will +c depend on the value of s and on the complexity of the shape of the +c function underlying the data. but, if the computation mode iopt=1 +c is used, the knots returned may also depend on the s-values at +c previous calls (if these were smaller). therefore, if after a number +c of trials with different s-values and iopt=1, the user can finally +c accept a fit as satisfactory, it may be worthwhile for him to call +c curfit once more with the selected value for s but now with iopt=0. +c indeed, curfit may then return an approximation of the same quality +c of fit but with fewer knots and therefore better if data reduction +c is also an important objective for the user. +c +c other subroutines required: +c fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota +c +c references: +c dierckx p. : an algorithm for smoothing, differentiation and integ- +c ration of experimental data using spline functions, +c j.comp.appl.maths 1 (1975) 165-184. +c dierckx p. : a fast algorithm for smoothing data on a rectangular +c grid while using spline functions, siam j.numer.anal. +c 19 (1982) 1286-1304. +c dierckx p. : an improved algorithm for curve fitting with spline +c functions, report tw54, dept. computer science,k.u. +c leuven, 1981. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author: +c p.dierckx +c dept. computer science, k.u. leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c creation date : may 1979 +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + real*8 xb,xe,s,fp + integer iopt,m,k,nest,n,lwrk,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk) + integer iwrk(nest) +c ..local scalars.. + real*8 tol + integer i,ia,ib,ifp,ig,iq,iz,j,k1,k2,lwest,maxit,nmin +c .. +c we set up the parameters tol and maxit + maxit = 20 + tol = 0.1d-02 +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + ier = 10 + if(k.le.0 .or. k.gt.5) go to 50 + k1 = k+1 + k2 = k1+1 + if(iopt.lt.(-1) .or. iopt.gt.1) go to 50 + nmin = 2*k1 + if(m.lt.k1 .or. nest.lt.nmin) go to 50 + lwest = m*k1+nest*(7+3*k) + if(lwrk.lt.lwest) go to 50 + if(xb.gt.x(1) .or. xe.lt.x(m) .or. w(1).le.0.0d0) go to 50 + do 10 i=2,m + if(x(i-1).ge.x(i) .or. w(i).le.0.0d0) go to 50 + 10 continue + if(iopt.ge.0) go to 30 + if(n.lt.nmin .or. n.gt.nest) go to 50 + j = n + do 20 i=1,k1 + t(i) = xb + t(j) = xe + j = j-1 + 20 continue + call fpchec(x,m,t,n,k,ier) + if(ier) 50,40,50 + 30 if(s.lt.0.0d0) go to 50 + if(s.eq.0.0d0 .and. nest.lt.(m+k1)) go to 50 + ier = 0 +c we partition the working space and determine the spline approximation. + 40 ifp = 1 + iz = ifp+nest + ia = iz+nest + ib = ia+nest*k1 + ig = ib+nest*k2 + iq = ig+nest*k2 + call fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp, + * wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),iwrk,ier) + 50 return + end +c +c +c + subroutine fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2, + * n,t,c,fp,fpint,z,a,b,g,q,nrdata,ier) +c .. +c ..scalar arguments.. + real*8 xb,xe,s,tol,fp + integer iopt,m,k,nest,maxit,k1,k2,n,ier +c ..array arguments.. + real*8 x(m),y(m),w(m),t(nest),c(nest),fpint(nest), + * z(nest),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) + integer nrdata(nest) +c ..local scalars.. + real*8 acc,con1,con4,con9,cos,half,fpart,fpms,fpold,fp0,f1,f2,f3, + * one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,wi,xi,yi + integer i,ich1,ich3,it,iter,i1,i2,i3,j,k3,l,l0, + * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8 +c ..local arrays.. + real*8 h(7) +c ..function references + real*8 abs,fprati + integer max0,min0 +c ..subroutine references.. +c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota +c .. +c set constants + parameter(one = 1.0d0,half = 0.5d0) + parameter(con1 = 0.1d0,con9 = 0.9d0,con4 = 0.4d-01) +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 1: determination of the number of knots and their position c +c ************************************************************** c +c given a set of knots we compute the least-squares spline sinf(x), c +c and the corresponding sum of squared residuals fp=f(p=inf). c +c if iopt=-1 sinf(x) is the requested approximation. c +c if iopt=0 or iopt=1 we check whether we can accept the knots: c +c if fp <=s we will continue with the current set of knots. c +c if fp > s we will increase the number of knots and compute the c +c corresponding least-squares spline until finally fp<=s. c +c the initial choice of knots depends on the value of s and iopt. c +c if s=0 we have spline interpolation; in that case the number of c +c knots equals nmax = m+k+1. c +c if s > 0 and c +c iopt=0 we first compute the least-squares polynomial of c +c degree k; n = nmin = 2*k+2 c +c iopt=1 we start with the set of knots found at the last c +c call of the routine, except for the case that s > fp0; then c +c we compute directly the least-squares polynomial of degree k. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c determine nmin, the number of knots for polynomial approximation. + nmin = 2*k1 + if(iopt.lt.0) go to 60 +c calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +c determine nmax, the number of knots for spline interpolation. + nmax = m+k1 + if(s.gt.0.0d0) go to 45 +c if s=0, s(x) is an interpolating spline. +c test whether the required storage space exceeds the available one. + n = nmax + if(nmax.gt.nest) go to 420 +c find the position of the interior knots in case of interpolation. + 10 mk1 = m-k1 + if(mk1.eq.0) go to 60 + k3 = k/2 + i = k2 + j = k3+2 + if(k3*2.eq.k) go to 30 + do 20 l=1,mk1 + t(i) = x(j) + i = i+1 + j = j+1 + 20 continue + go to 60 + 30 do 40 l=1,mk1 + t(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + 40 continue + go to 60 +c if s>0 our initial choice of knots depends on the value of iopt. +c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +c polynomial of degree k which is a spline without interior knots. +c if iopt=1 and fp0>s we start computing the least squares spline +c according to the set of knots found at the last call of the routine. + 45 if(iopt.eq.0) go to 50 + if(n.eq.nmin) go to 50 + fp0 = fpint(n) + fpold = fpint(n-1) + nplus = nrdata(n) + if(fp0.gt.s) go to 60 + 50 n = nmin + fpold = 0.0d0 + nplus = 0 + nrdata(1) = m-2 +c main loop for the different sets of knots. m is a save upper bound +c for the number of trials. + 60 do 200 iter = 1,m + if(n.eq.nmin) ier = -2 +c find nrint, tne number of knot intervals. + nrint = n-nmin+1 +c find the position of the additional knots which are needed for +c the b-spline representation of s(x). + nk1 = n-k1 + i = n + do 70 j=1,k1 + t(j) = xb + t(i) = xe + i = i-1 + 70 continue +c compute the b-spline coefficients of the least-squares spline +c sinf(x). the observation matrix a is built up row by row and +c reduced to upper triangular form by givens transformations. +c at the same time fp=f(p=inf) is computed. + fp = 0.0d0 +c initialize the observation matrix a. + do 80 i=1,nk1 + z(i) = 0.0d0 + do 80 j=1,k1 + a(i,j) = 0.0d0 + 80 continue + l = k1 + do 130 it=1,m +c fetch the current data point x(it),y(it). + xi = x(it) + wi = w(it) + yi = y(it)*wi +c search for knot interval t(l) <= xi < t(l+1). + 85 if(xi.lt.t(l+1) .or. l.eq.nk1) go to 90 + l = l+1 + go to 85 +c evaluate the (k+1) non-zero b-splines at xi and store them in q. + 90 call fpbspl(t,n,k,xi,l,h) + do 95 i=1,k1 + q(it,i) = h(i) + h(i) = h(i)*wi + 95 continue +c rotate the new row of the observation matrix into triangle. + j = l-k1 + do 110 i=1,k1 + j = j+1 + piv = h(i) + if(piv.eq.0.0d0) go to 110 +c calculate the parameters of the givens transformation. + call fpgivs(piv,a(j,1),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,z(j)) + if(i.eq.k1) go to 120 + i2 = 1 + i3 = i+1 + do 100 i1 = i3,k1 + i2 = i2+1 +c transformations to left hand side. + call fprota(cos,sin,h(i1),a(j,i2)) + 100 continue + 110 continue +c add contribution of this row to the sum of squares of residual +c right hand sides. + 120 fp = fp+yi**2 + 130 continue + if(ier.eq.(-2)) fp0 = fp + fpint(n) = fp0 + fpint(n-1) = fpold + nrdata(n) = nplus +c backward substitution to obtain the b-spline coefficients. + call fpback(a,z,nk1,k1,c,nest) +c test whether the approximation sinf(x) is an acceptable solution. + if(iopt.lt.0) go to 440 + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c if f(p=inf) < s accept the choice of knots. + if(fpms.lt.0.0d0) go to 250 +c if n = nmax, sinf(x) is an interpolating spline. + if(n.eq.nmax) go to 430 +c increase the number of knots. +c if n=nest we cannot increase the number of knots because of +c the storage capacity limitation. + if(n.eq.nest) go to 420 +c determine the number of knots nplus we are going to add. + if(ier.eq.0) go to 140 + nplus = 1 + ier = 0 + go to 150 + 140 npl1 = nplus*2 + rn = nplus + if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + 150 fpold = fp +c compute the sum((w(i)*(y(i)-s(x(i))))**2) for each knot interval +c t(j+k) <= x(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0.0d0 + i = 1 + l = k2 + new = 0 + do 180 it=1,m + if(x(it).lt.t(l) .or. l.gt.nk1) go to 160 + new = 1 + l = l+1 + 160 term = 0.0d0 + l0 = l-k2 + do 170 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 170 continue + term = (w(it)*(term-y(it)))**2 + fpart = fpart+term + if(new.eq.0) go to 180 + store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + 180 continue + fpint(nrint) = fpart + do 190 l=1,nplus +c add a new knot. + call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) +c if n=nmax we locate the knots as for interpolation. + if(n.eq.nmax) go to 10 +c test whether we cannot further increase the number of knots. + if(n.eq.nest) go to 200 + 190 continue +c restart the computations with the new set of knots. + 200 continue +c test whether the least-squares kth degree polynomial is a solution +c of our approximation problem. + 250 if(ier.eq.(-2)) go to 440 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c part 2: determination of the smoothing spline sp(x). c +c *************************************************** c +c we have determined the number of knots and their position. c +c we now compute the b-spline coefficients of the smoothing spline c +c sp(x). the observation matrix a is extended by the rows of matrix c +c b expressing that the kth derivative discontinuities of sp(x) at c +c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +c ponding weights of these additional rows are set to 1/p. c +c iteratively we then have to determine the value of p such that c +c f(p)=sum((w(i)*(y(i)-sp(x(i))))**2) be = s. we already know that c +c the least-squares kth degree polynomial corresponds to p=0, and c +c that the least-squares spline corresponds to p=infinity. the c +c iteration process which is proposed here, makes use of rational c +c interpolation. since f(p) is a convex and strictly decreasing c +c function of p, it can be approximated by a rational function c +c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +c to calculate the new value of p such that r(p)=s. convergence is c +c guaranteed by taking f1>0 and f3<0. c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c evaluate the discontinuity jump of the kth derivative of the +c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + call fpdisc(t,n,k2,b,nest) +c initial value for p. + p1 = 0.0d0 + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0.0d0 + do 255 i=1,nk1 + p = p+a(i,1) + 255 continue + rn = nk1 + p = rn/p + ich1 = 0 + ich3 = 0 + n8 = n-nmin +c iteration process to find the root of f(p) = s. + do 360 iter=1,maxit +c the rows of matrix b with weight 1/p are rotated into the +c triangularised observation matrix a which is stored in g. + pinv = one/p + do 260 i=1,nk1 + c(i) = z(i) + g(i,k2) = 0.0d0 + do 260 j=1,k1 + g(i,j) = a(i,j) + 260 continue + do 300 it=1,n8 +c the row of matrix b is rotated into triangle by givens transformation + do 270 i=1,k2 + h(i) = b(it,i)*pinv + 270 continue + yi = 0.0d0 + do 290 j=it,nk1 + piv = h(1) +c calculate the parameters of the givens transformation. + call fpgivs(piv,g(j,1),cos,sin) +c transformations to right hand side. + call fprota(cos,sin,yi,c(j)) + if(j.eq.nk1) go to 300 + i2 = k1 + if(j.gt.n8) i2 = nk1-j + do 280 i=1,i2 +c transformations to left hand side. + i1 = i+1 + call fprota(cos,sin,h(i1),g(j,i1)) + h(i) = h(i1) + 280 continue + h(i2+1) = 0.0d0 + 290 continue + 300 continue +c backward substitution to obtain the b-spline coefficients. + call fpback(g,c,nk1,k2,c,nest) +c computation of f(p). + fp = 0.0d0 + l = k2 + do 330 it=1,m + if(x(it).lt.t(l) .or. l.gt.nk1) go to 310 + l = l+1 + 310 l0 = l-k2 + term = 0.0d0 + do 320 j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + 320 continue + fp = fp+(w(it)*(term-y(it)))**2 + 330 continue +c test whether the approximation sp(x) is an acceptable solution. + fpms = fp-s + if(abs(fpms).lt.acc) go to 440 +c test whether the maximal number of iterations is reached. + if(iter.eq.maxit) go to 400 +c carry out one more step of the iteration process. + p2 = p + f2 = fpms + if(ich3.ne.0) go to 340 + if((f2-f3).gt.acc) go to 335 +c our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p.le.p1) p=p1*con9 + p2*con1 + go to 360 + 335 if(f2.lt.0.0d0) ich3=1 + 340 if(ich1.ne.0) go to 350 + if((f1-f2).gt.acc) go to 345 +c our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3.lt.0.0d0) go to 360 + if(p.ge.p3) p = p2*con1 + p3*con9 + go to 360 + 345 if(f2.gt.0.0d0) ich1=1 +c test whether the iteration process proceeds as theoretically +c expected. + 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 +c find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + 360 continue +c error codes and messages. + 400 ier = 3 + go to 440 + 410 ier = 2 + go to 440 + 420 ier = 1 + go to 440 + 430 ier = -1 + 440 return + end +c +c +c + subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier) +c subroutine splder evaluates in a number of points x(i),i=1,2,...,m +c the derivative of order nu of a spline s(x) of degree k,given in +c its b-spline representation. +c +c calling sequence: +c call splder(t,n,c,k,nu,x,y,m,wrk,ier) +c +c input parameters: +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length n, which contains the b-spline coefficients. +c k : integer, giving the degree of s(x). +c nu : integer, specifying the order of the derivative. 0<=nu<=k +c x : array,length m, which contains the points where the deriv- +c ative of s(x) must be evaluated. +c m : integer, giving the number of points where the derivative +c of s(x) must be evaluated +c wrk : real array of dimension n. used as working space. +c +c output parameters: +c y : array,length m, giving the value of the derivative of s(x) +c at the different points. +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c 0 <= nu <= k +c m >= 1 +c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +c +c other subroutines required: fpbspl +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer n,k,nu,m,ier +c ..array arguments.. + real*8 t(n),c(n),x(m),y(m),wrk(n) +c ..local scalars.. + integer i,j,kk,k1,k2,l,ll,l1,l2,nk1,nk2,nn + real*8 ak,arg,fac,sp,tb,te +c ..local arrays .. + real*8 h(6) +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if(nu.lt.0 .or. nu.gt.k) go to 200 + if(m-1) 200,30,10 + 10 do 20 i=2,m + if(x(i).lt.x(i-1)) go to 200 + 20 continue + 30 ier = 0 +c fetch tb and te, the boundaries of the approximation interval. + k1 = k+1 + nk1 = n-k1 + tb = t(k1) + te = t(nk1+1) +c the derivative of order nu of a spline of degree k is a spline of +c degree k-nu,the b-spline coefficients wrk(i) of which can be found +c using the recurrence scheme of de boor. + l = 1 + kk = k + nn = n + do 40 i=1,nk1 + wrk(i) = c(i) + 40 continue + if(nu.eq.0) go to 100 + nk2 = nk1 + do 60 j=1,nu + ak = kk + nk2 = nk2-1 + l1 = l + do 50 i=1,nk2 + l1 = l1+1 + l2 = l1+kk + fac = t(l2)-t(l1) + if(fac.le.0.0d0) go to 50 + wrk(i) = ak*(wrk(i+1)-wrk(i))/fac + 50 continue + l = l+1 + kk = kk-1 + 60 continue + if(kk.ne.0) go to 100 +c if nu=k the derivative is a piecewise constant function + j = 1 + do 90 i=1,m + arg = x(i) + 70 if(arg.lt.t(l+1) .or. l.eq.nk1) go to 80 + l = l+1 + j = j+1 + go to 70 + 80 y(i) = wrk(j) + 90 continue + go to 200 + 100 l = k1 + l1 = l+1 + k2 = k1-nu +c main loop for the different points. + do 180 i=1,m +c fetch a new x-value arg. + arg = x(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te +c search for knot interval t(l) <= arg < t(l+1) + 140 if(arg.lt.t(l1) .or. l.eq.nk1) go to 150 + l = l1 + l1 = l+1 + go to 140 +c evaluate the non-zero b-splines of degree k-nu at arg. + 150 call fpbspl(t,n,kk,arg,l,h) +c find the value of the derivative at x=arg. + sp = 0.0d0 + ll = l-k1 + do 160 j=1,k2 + ll = ll+1 + sp = sp+wrk(ll)*h(j) + 160 continue + y(i) = sp + 180 continue + 200 return + end +c +c +c + subroutine splev(t,n,c,k,x,y,m,ier) +c subroutine splev evaluates in a number of points x(i),i=1,2,...,m +c a spline s(x) of degree k, given in its b-spline representation. +c +c calling sequence: +c call splev(t,n,c,k,x,y,m,ier) +c +c input parameters: +c t : array,length n, which contains the position of the knots. +c n : integer, giving the total number of knots of s(x). +c c : array,length n, which contains the b-spline coefficients. +c k : integer, giving the degree of s(x). +c x : array,length m, which contains the points where s(x) must +c be evaluated. +c m : integer, giving the number of points where s(x) must be +c evaluated. +c +c output parameter: +c y : array,length m, giving the value of s(x) at the different +c points. +c ier : error flag +c ier = 0 : normal return +c ier =10 : invalid input data (see restrictions) +c +c restrictions: +c m >= 1 +c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +c +c other subroutines required: fpbspl. +c +c references : +c de boor c : on calculating with b-splines, j. approximation theory +c 6 (1972) 50-62. +c cox m.g. : the numerical evaluation of b-splines, j. inst. maths +c applics 10 (1972) 134-149. +c dierckx p. : curve and surface fitting with splines, monographs on +c numerical analysis, oxford university press, 1993. +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer n,k,m,ier +c ..array arguments.. + real*8 t(n),c(n),x(m),y(m) +c ..local scalars.. + integer i,j,k1,l,ll,l1,nk1 + real*8 arg,sp,tb,te +c ..local array.. + real*8 h(6) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + ier = 10 + if(m-1) 100,30,10 + 10 do 20 i=2,m + if(x(i).lt.x(i-1)) go to 100 + 20 continue + 30 ier = 0 +c fetch tb and te, the boundaries of the approximation interval. + k1 = k+1 + nk1 = n-k1 + tb = t(k1) + te = t(nk1+1) + l = k1 + l1 = l+1 +c main loop for the different points. + do 80 i=1,m +c fetch a new x-value arg. + arg = x(i) + if(arg.lt.tb) arg = tb + if(arg.gt.te) arg = te +c search for knot interval t(l) <= arg < t(l+1) + 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50 + l = l1 + l1 = l+1 + go to 40 +c evaluate the non-zero b-splines at arg. + 50 call fpbspl(t,n,k,arg,l,h) +c find the value of s(x) at x=arg. + sp = 0.0d0 + ll = l-k1 + do 60 j=1,k1 + ll = ll+1 + sp = sp+c(ll)*h(j) + 60 continue + y(i) = sp + 80 continue + 100 return + end +c +c +c + subroutine sproota(val,t,n,c,zero,mest,m,ier) +c subroutine sproot finds the zeros of a cubic spline s(x),which is +c given in its normalized b-spline representation. +c +c calling sequence: +c call sproot(t,n,c,zero,mest,m,ier) +c +c input parameters: +c t : real array,length n, containing the knots of s(x). +c n : integer, containing the number of knots. n>=8 +c c : real array,length n, containing the b-spline coefficients. +c mest : integer, specifying the dimension of array zero. +c +c output parameters: +c zero : real array,lenth mest, containing the zeros of s(x). +c m : integer,giving the number of zeros. +c ier : error flag: +c ier = 0: normal return. +c ier = 1: the number of zeros exceeds mest. +c ier =10: invalid input data (see restrictions). +c +c other subroutines required: fpcuro +c +c restrictions: +c 1) n>= 8. +c 2) t(4) < t(5) < ... < t(n-4) < t(n-3). +c t(1) <= t(2) <= t(3) <= t(4) +c t(n-3) <= t(n-2) <= t(n-1) <= t(n) +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c .. +c ..scalar arguments.. + integer n,mest,m,ier +c ..array arguments.. + real*8 t(n),c(n),zero(mest) +c ..local scalars.. + integer i,j,j1,l,n4 + real*8 ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2, + * three,two,t1,t2,t3,t4,t5,zz,val + logical z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4 +c ..local array.. + real*8 y(3) +c .. +c set some constants + parameter(two = 0.2d+01,three = 0.3d+01) +c before starting computations a data check is made. if the input data +c are invalid, control is immediately repassed to the calling program. + n4 = n-4 + ier = 10 + if(n.lt.8) go to 800 + j = n + do 10 i=1,3 + if(t(i).gt.t(i+1)) go to 800 + if(t(j).lt.t(j-1)) go to 800 + j = j-1 + 10 continue + do 20 i=4,n4 + if(t(i).ge.t(i+1)) go to 800 + 20 continue +c the problem considered reduces to finding the zeros of the cubic +c polynomials pl(x) which define the cubic spline in each knot +c interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on +c the condition that it belongs to the knot interval. +c the cubic polynomial pl(x) is determined by computing s(t(l)), +c s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute +c s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of +c splines and their derivatives, the value of s(t(l)) and s'(t(l)) +c is already known from the foregoing knot interval. + ier = 0 +c evaluate some constants for the first knot interval + h1 = t(4)-t(3) + h2 = t(5)-t(4) + t1 = t(4)-t(2) + t2 = t(5)-t(3) + t3 = t(6)-t(4) + t4 = t(5)-t(2) + t5 = t(6)-t(3) +c calculate a0 = s(t(4)) and ah = s'(t(4)). + c1 = c(1) + c2 = c(2) + c3 = c(3) + c4 = (c2-c1)/t4 + c5 = (c3-c2)/t5 + d4 = (h2*c1+t1*c2)/t4 + d5 = (t3*c2+h1*c3)/t5 + a0 = (h2*d4+h1*d5)/t2 - val + ah = three*(h2*c4+h1*c5)/t2 + z1 = .true. + if(ah.lt.0.0d0) z1 = .false. + nz1 = .not.z1 + m = 0 +c main loop for the different knot intervals. + do 300 l=4,n4 +c evaluate some constants for the knot interval t(l) <= x <= t(l+1). + h1 = h2 + h2 = t(l+2)-t(l+1) + t1 = t2 + t2 = t3 + t3 = t(l+3)-t(l+1) + t4 = t5 + t5 = t(l+3)-t(l) +c find a0 = s(t(l)), ah = s'(t(l)), b0 = s(t(l+1)) and bh = s'(t(l+1)). + c1 = c2 + c2 = c3 + c3 = c(l) + c4 = c5 + c5 = (c3-c2)/t5 + d4 = (h2*c1+t1*c2)/t4 + d5 = (h1*c3+t3*c2)/t5 + b0 = (h2*d4+h1*d5)/t2 - val + bh = three*(h2*c4+h1*c5)/t2 +c calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial +c pl(x) = ql(y) = a0+a1*y+a2*y**2+a3*y**3 ; y = (x-t(l))/(t(l+1)-t(l)). + a1 = ah*h1 + b1 = bh*h1 + a2 = three*(b0-a0)-b1-two*a1 + a3 = two*(a0-b0)+b1+a1 +c test whether or not pl(x) could have a zero in the range +c t(l) <= x <= t(l+1). + z3 = .true. + if(b1.lt.0.0d0) z3 = .false. + nz3 = .not.z3 + if(a0*b0.le.0.0d0) go to 100 + z0 = .true. + if(a0.lt.0.0d0) z0 = .false. + nz0 = .not.z0 + z2 = .true. + if(a2.lt.0.0d0) z2 = .false. + nz2 = .not.z2 + z4 = .true. + if(3.0d0*a3+a2.lt.0.0d0) z4 = .false. + nz4 = .not.z4 + if(.not.((z0.and.(nz1.and.(z3.or.z2.and.nz4).or.nz2.and. + * z3.and.z4).or.nz0.and.(z1.and.(nz3.or.nz2.and.z4).or.z2.and. + * nz3.and.nz4))))go to 200 +c find the zeros of ql(y). + 100 call fpcuro(a3,a2,a1,a0,y,j) + if(j.eq.0) go to 200 +c find which zeros of pl(x) are zeros of s(x). + do 150 i=1,j + if(y(i).lt.0.0d0 .or. y(i).gt.1.0d0) go to 150 +c test whether the number of zeros of s(x) exceeds mest. + if(m.ge.mest) go to 700 + m = m+1 + zero(m) = t(l)+h1*y(i) + 150 continue + 200 a0 = b0 + ah = bh + z1 = z3 + nz1 = nz3 + 300 continue +c the zeros of s(x) are arranged in increasing order. + if(m.lt.2) go to 800 + do 400 i=2,m + j = i + 350 j1 = j-1 + if(j1.eq.0) go to 400 + if(zero(j).ge.zero(j1)) go to 400 + zz = zero(j) + zero(j) = zero(j1) + zero(j1) = zz + j = j1 + go to 350 + 400 continue + j = m + m = 1 + do 500 i=2,j + if(zero(i).eq.zero(m)) go to 500 + m = m+1 + zero(m) = zero(i) + 500 continue + go to 800 + 700 ier = 1 + 800 return + end + +c + subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) +c if iopt=0 subroutine profil calculates the b-spline coefficients of +c the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of +c degrees kx and ky, given in the b-spline representation. +c if iopt = 1 it calculates the b-spline coefficients of the univariate +c spline g(x) = s(x,u) +c +c calling sequence: +c call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) +c +c input parameters: +c iopt : integer flag, specifying whether the profile f(y) (iopt=0) +c or the profile g(x) (iopt=1) must be determined. +c tx : real array, length nx, which contains the position of the +c knots in the x-direction. +c nx : integer, giving the total number of knots in the x-direction +c ty : real array, length ny, which contains the position of the +c knots in the y-direction. +c ny : integer, giving the total number of knots in the y-direction +c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +c b-spline coefficients. +c kx,ky : integer values, giving the degrees of the spline. +c u : real value, specifying the requested profile. +c tx(kx+1)<=u<=tx(nx-kx), if iopt=0. +c ty(ky+1)<=u<=ty(ny-ky), if iopt=1. +c nu : on entry nu must specify the dimension of the array cu. +c nu >= ny if iopt=0, nu >= nx if iopt=1. +c +c output parameters: +c cu : real array of dimension (nu). +c on succesful exit this array contains the b-spline +c ier : integer error flag +c ier=0 : normal return +c ier=10: invalid input data (see restrictions) +c +c restrictions: +c if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny. +c if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx. +c +c other subroutines required: +c fpbspl +c +c author : +c p.dierckx +c dept. computer science, k.u.leuven +c celestijnenlaan 200a, b-3001 heverlee, belgium. +c e-mail : Paul.Dierckx@cs.kuleuven.ac.be +c +c latest update : march 1987 +c +c ..scalar arguments.. + integer iopt,nx,ny,kx,ky,nu,ier + real*8 u +c ..array arguments.. + real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),cu(nu) +c ..local scalars.. + integer i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1 + real*8 sum +c ..local array + real*8 h(6) +c .. +c before starting computations a data check is made. if the input data +c are invalid control is immediately repassed to the calling program. + kx1 = kx+1 + ky1 = ky+1 + nkx1 = nx-kx1 + nky1 = ny-ky1 + ier = 10 + if(iopt.ne.0) go to 200 + if(nu.lt.ny) go to 300 + if(u.lt.tx(kx1) .or. u.gt.tx(nkx1+1)) go to 300 +c the b-splinecoefficients of f(y) = s(u,y). + ier = 0 + l = kx1 + l1 = l+1 + 110 if(u.lt.tx(l1) .or. l.eq.nkx1) go to 120 + l = l1 + l1 = l+1 + go to 110 + 120 call fpbspl(tx,nx,kx,u,l,h) + m0 = (l-kx1)*nky1+1 + do 140 i=1,nky1 + m = m0 + sum = 0.0d0 + do 130 j=1,kx1 + sum = sum+h(j)*c(m) + m = m+nky1 + 130 continue + cu(i) = sum + m0 = m0+1 + 140 continue + go to 300 + 200 if(nu.lt.nx) go to 300 + if(u.lt.ty(ky1) .or. u.gt.ty(nky1+1)) go to 300 +c the b-splinecoefficients of g(x) = s(x,u). + ier = 0 + l = ky1 + l1 = l+1 + 210 if(u.lt.ty(l1) .or. l.eq.nky1) go to 220 + l = l1 + l1 = l+1 + go to 210 + 220 call fpbspl(ty,ny,ky,u,l,h) + m0 = l-ky + do 240 i=1,nkx1 + m = m0 + sum = 0.0d0 + do 230 j=1,ky1 + sum = sum+h(j)*c(m) + m = m+1 + 230 continue + cu(i) = sum + m0 = m0+nky1 + 240 continue + 300 return + end +c + subroutine fpcuro(a,b,c,d,x,n) +c subroutine fpcuro finds the real zeros of a cubic polynomial +c p(x) = a*x**3+b*x**2+c*x+d. +c +c calling sequence: +c call fpcuro(a,b,c,d,x,n) +c +c input parameters: +c a,b,c,d: real values, containing the coefficients of p(x). +c +c output parameters: +c x : real array,length 3, which contains the real zeros of p(x) +c n : integer, giving the number of real zeros of p(x). +c .. +c ..scalar arguments.. + real*8 a,b,c,d + integer n +c ..array argument.. + real*8 x(3) +c ..local scalars.. + integer i + real*8 a1,b1,c1,df,disc,d1,e3,f,four,half,ovfl,pi3,p3,q,r, + * step,tent,three,two,u,u1,u2,y +c ..function references.. + real*8 abs,max,atan,atan2,cos,sign,sqrt +c set constants + parameter(two = 0.2d+01,three = 0.3d+01,four = 0.4d+01) + parameter(ovfl =0.1d+05,half = 0.5d+0,tent = 0.1d+0) + e3 = tent/0.3d0 + pi3 = atan(0.1d+01)/0.75d0 + a1 = abs(a) + b1 = abs(b) + c1 = abs(c) + d1 = abs(d) +c test whether p(x) is a third degree polynomial. + if(max(b1,c1,d1).lt.a1*ovfl) go to 300 +c test whether p(x) is a second degree polynomial. + if(max(c1,d1).lt.b1*ovfl) go to 200 +c test whether p(x) is a first degree polynomial. + if(d1.lt.c1*ovfl) go to 100 +c p(x) is a constant function. + n = 0 + go to 800 +c p(x) is a first degree polynomial. + 100 n = 1 + x(1) = -d/c + go to 500 +c p(x) is a second degree polynomial. + 200 disc = c*c-four*b*d + n = 0 + if(disc.lt.0.0d0) go to 800 + n = 2 + u = sqrt(disc) + b1 = b+b + x(1) = (-c+u)/b1 + x(2) = (-c-u)/b1 + go to 500 +c p(x) is a third degree polynomial. + 300 b1 = b/a*e3 + c1 = c/a + d1 = d/a + q = c1*e3-b1*b1 + r = b1*b1*b1+(d1-b1*c1)*half + disc = q*q*q+r*r + if(disc.gt.0.0d0) go to 400 + u = sqrt(abs(q)) + if(r.lt.0.0d0) u = -u + p3 = atan2(sqrt(-disc),abs(r))*e3 + u2 = u+u + n = 3 + x(1) = -u2*cos(p3)-b1 + x(2) = u2*cos(pi3-p3)-b1 + x(3) = u2*cos(pi3+p3)-b1 + go to 500 + 400 u = sqrt(disc) + u1 = -r+u + u2 = -r-u + n = 1 + x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1 +c apply a newton iteration to improve the accuracy of the roots. + 500 do 700 i=1,n + y = x(i) + f = ((a*y+b)*y+c)*y+d + df = (three*a*y+two*b)*y+c + step = 0.0d0 + if(abs(f).lt.abs(df)*tent) step = f/df + x(i) = y-step + 700 continue + 800 return + end +c +c +c hybrj1 from MINPACK +c + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + integer n,ldfjac,info,lwa + double precision tol + double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrj1 +c +c the purpose of hybrj1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrj. the user +c must provide a subroutine which calculates the functions +c and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrj +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer j,lr,maxfev,mode,nfev,njev,nprint + double precision factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. (n*(n + 13))/2) go to 20 +c +c call hybrj. +c + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, + * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrj1. +c + end +c + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, + * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, + * wa3,wa4) + integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr + double precision xtol,factor + double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) +c ********** +c +c subroutine hybrj +c +c the purpose of hybrj is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +c mode,factor,nprint,info,nfev,njev,r,lr,qtf, +c wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. fvec and fjac should not be altered. +c if nprint is not positive, no special calls of fcn +c with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dpmpar,enorm, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dpmpar,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero + * .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine hybrj. +c + end +c + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + integer n,lr + double precision delta + double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) +c ********** +c +c subroutine dogleg +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, the +c problem is to determine the convex combination x of the +c gauss-newton and scaled gradient directions that minimizes +c (a*x - b) in the least squares sense, subject to the +c restriction that the euclidean norm of d*x be at most delta. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization of a. that is, if a = q*r, where q has +c orthogonal columns and r is an upper triangular matrix, +c then dogleg expects the full upper triangle of r and +c the first n components of (q transpose)*b. +c +c the subroutine statement is +c +c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an input array of length lr which must contain the upper +c triangular matrix r stored by rows. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c x is an output array of length n which contains the desired +c convex combination of the gauss-newton direction and the +c scaled gradient direction. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jj,jp1,k,l + double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, + * temp,zero + double precision dpmpar,enorm + data one,zero /1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c first, calculate the gauss-newton direction. +c + jj = (n*(n + 1))/2 + 1 + do 50 k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + sum = zero + if (n .lt. jp1) go to 20 + do 10 i = jp1, n + sum = sum + r(l)*x(i) + l = l + 1 + 10 continue + 20 continue + temp = r(jj) + if (temp .ne. zero) go to 40 + l = j + do 30 i = 1, j + temp = dmax1(temp,dabs(r(l))) + l = l + n - i + 30 continue + temp = epsmch*temp + if (temp .eq. zero) temp = epsmch + 40 continue + x(j) = (qtb(j) - sum)/temp + 50 continue +c +c test whether the gauss-newton direction is acceptable. +c + do 60 j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + 60 continue + qnorm = enorm(n,wa2) + if (qnorm .le. delta) go to 140 +c +c the gauss-newton direction is not acceptable. +c next, calculate the scaled gradient direction. +c + l = 1 + do 80 j = 1, n + temp = qtb(j) + do 70 i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + 70 continue + wa1(j) = wa1(j)/diag(j) + 80 continue +c +c calculate the norm of the scaled gradient and test for +c the special case in which the scaled gradient is zero. +c + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm .eq. zero) go to 120 +c +c calculate the point along the scaled gradient +c at which the quadratic is minimized. +c + do 90 j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + 90 continue + l = 1 + do 110 j = 1, n + sum = zero + do 100 i = j, n + sum = sum + r(l)*wa1(i) + l = l + 1 + 100 continue + wa2(j) = sum + 110 continue + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +c +c test whether the scaled gradient direction is acceptable. +c + alpha = zero + if (sgnorm .ge. delta) go to 120 +c +c the scaled gradient direction is not acceptable. +c finally, calculate the point along the dogleg +c at which the quadratic is minimized. +c + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 + * + dsqrt((temp-(delta/qnorm))**2 + * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + 120 continue +c +c form appropriate convex combination of the gauss-newton +c direction and the scaled gradient direction. +c + temp = (one - alpha)*dmin1(sgnorm,delta) + do 130 j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + 130 continue + 140 continue + return +c +c last card of subroutine dogleg. +c + end + double precision function dpmpar(i) + integer i +c ********** +c +c Function dpmpar +c +c This function provides double precision machine parameters +c when the appropriate set of data statements is activated (by +c removing the c from column 1) and all other data statements are +c rendered inactive. Most of the parameter values were obtained +c from the corresponding Bell Laboratories Port Library function. +c +c The function statement is +c +c double precision function dpmpar(i) +c +c where +c +c i is an integer input variable set to 1, 2, or 3 which +c selects the desired machine parameter. If the machine has +c t base b digits and its smallest and largest exponents are +c emin and emax, respectively, then these parameters are +c +c dpmpar(1) = b**(1 - t), the machine precision, +c +c dpmpar(2) = b**(emin - 1), the smallest magnitude, +c +c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c Argonne National Laboratory. MINPACK Project. November 1996. +c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' +c +c ********** + integer mcheps(4) + integer minmag(4) + integer maxmag(4) + double precision dmach(3) + equivalence (dmach(1),mcheps(1)) + equivalence (dmach(2),minmag(1)) + equivalence (dmach(3),maxmag(1)) +c +c Machine constants for the IBM 360/370 series, +c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, +c the Xerox Sigma 5/7/9 and the Sel systems 85/86. +c +c data mcheps(1),mcheps(2) / z34100000, z00000000 / +c data minmag(1),minmag(2) / z00100000, z00000000 / +c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / +c +c Machine constants for the Honeywell 600/6000 series. +c +c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / +c data minmag(1),minmag(2) / o402400000000, o000000000000 / +c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / +c +c Machine constants for the CDC 6000/7000 series. +c +c data mcheps(1) / 15614000000000000000b / +c data mcheps(2) / 15010000000000000000b / +c +c data minmag(1) / 00604000000000000000b / +c data minmag(2) / 00000000000000000000b / +c +c data maxmag(1) / 37767777777777777777b / +c data maxmag(2) / 37167777777777777777b / +c +c Machine constants for the PDP-10 (KA processor). +c +c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / +c data minmag(1),minmag(2) / "033400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / +c +c Machine constants for the PDP-10 (KI processor). +c +c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / +c data minmag(1),minmag(2) / "000400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / +c +c Machine constants for the PDP-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data mcheps(3),mcheps(4) / 0, 0 / +c +c data minmag(1),minmag(2) / 128, 0 / +c data minmag(3),minmag(4) / 0, 0 / +c +c data maxmag(1),maxmag(2) / 32767, -1 / +c data maxmag(3),maxmag(4) / -1, -1 / +c +c Machine constants for the Burroughs 6700/7700 systems. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o7770000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o7777777777777777 / +c +c Machine constants for the Burroughs 5700 system. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o0000000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o0007777777777777 / +c +c Machine constants for the Burroughs 1700 system. +c +c data mcheps(1) / zcc6800000 / +c data mcheps(2) / z000000000 / +c +c data minmag(1) / zc00800000 / +c data minmag(2) / z000000000 / +c +c data maxmag(1) / zdffffffff / +c data maxmag(2) / zfffffffff / +c +c Machine constants for the Univac 1100 series. +c +c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / +c data minmag(1),minmag(2) / o000040000000, o000000000000 / +c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / +c +c Machine constants for the Data General Eclipse S/200. +c +c Note - it may be appropriate to include the following card - +c static dmach(3) +c +c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ +c data mcheps/32020k,3*0/ +c +c Machine constants for the Harris 220. +c +c data mcheps(1),mcheps(2) / '20000000, '00000334 / +c data minmag(1),minmag(2) / '20000000, '00000201 / +c data maxmag(1),maxmag(2) / '37777777, '37777577 / +c +c Machine constants for the Cray-1. +c +c data mcheps(1) / 0376424000000000000000b / +c data mcheps(2) / 0000000000000000000000b / +c +c data minmag(1) / 0200034000000000000000b / +c data minmag(2) / 0000000000000000000000b / +c +c data maxmag(1) / 0577777777777777777777b / +c data maxmag(2) / 0000007777777777777776b / +c +c Machine constants for the Prime 400. +c +c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / +c data minmag(1),minmag(2) / :10000000000, :00000100000 / +c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / +c +c Machine constants for the VAX-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data minmag(1),minmag(2) / 128, 0 / +c data maxmag(1),maxmag(2) / -32769, -1 / +c +c Machine constants for IEEE machines. +c + data dmach(1) /2.22044604926d-16/ + data dmach(2) /2.22507385852d-308/ + data dmach(3) /1.79769313485d+308/ +c + dpmpar = dmach(i) + return +c +c Last card of function dpmpar. +c + end +c + double precision function enorm(n,x) + integer n + double precision x(n) +c ********** +c +c function enorm +c +c given an n-vector x, this function calculates the +c euclidean norm of x. +c +c the euclidean norm is computed by accumulating the sum of +c squares in three different sums. the sums of squares for the +c small and large components are scaled so that no overflows +c occur. non-destructive underflows are permitted. underflows +c and overflows do not occur in the computation of the unscaled +c sum of squares for the intermediate components. +c the definitions of small, intermediate and large components +c depend on two constants, rdwarf and rgiant. the main +c restrictions on these constants are that rdwarf**2 not +c underflow and rgiant**2 not overflow. the constants +c given here are suitable for every known computer. +c +c the function statement is +c +c double precision function enorm(n,x) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i + double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, + * x1max,x3max,zero + data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do 90 i = 1, n + xabs = dabs(x(i)) + if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 + if (xabs .le. rdwarf) go to 30 +c +c sum for large components. +c + if (xabs .le. x1max) go to 10 + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + go to 20 + 10 continue + s1 = s1 + (xabs/x1max)**2 + 20 continue + go to 60 + 30 continue +c +c sum for small components. +c + if (xabs .le. x3max) go to 40 + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + go to 50 + 40 continue + if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 + 50 continue + 60 continue + go to 80 + 70 continue +c +c sum for intermediate components. +c + s2 = s2 + xabs**2 + 80 continue + 90 continue +c +c calculation of norm. +c + if (s1 .eq. zero) go to 100 + enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) + go to 130 + 100 continue + if (s2 .eq. zero) go to 110 + if (s2 .ge. x3max) + * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 .lt. x3max) + * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) + go to 120 + 110 continue + enorm = x3max*dsqrt(s3) + 120 continue + 130 continue + return +c +c last card of function enorm. +c + end +c + subroutine qform(m,n,q,ldq,wa) + integer m,n,ldq + double precision q(ldq,m),wa(m) +c ********** +c +c subroutine qform +c +c this subroutine proceeds from the computed qr factorization of +c an m by n matrix a to accumulate the m by m orthogonal matrix +c q from its factored form. +c +c the subroutine statement is +c +c subroutine qform(m,n,q,ldq,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a and the order of q. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c q is an m by m array. on input the full lower trapezoid in +c the first min(m,n) columns of q contains the factored form. +c on output q has been accumulated into a square matrix. +c +c ldq is a positive integer input variable not less than m +c which specifies the leading dimension of the array q. +c +c wa is a work array of length m. +c +c subprograms called +c +c fortran-supplied ... min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jm1,k,l,minmn,np1 + double precision one,sum,temp,zero + data one,zero /1.0d0,0.0d0/ +c +c zero out upper triangle of q in the first min(m,n) columns. +c + minmn = min0(m,n) + if (minmn .lt. 2) go to 30 + do 20 j = 2, minmn + jm1 = j - 1 + do 10 i = 1, jm1 + q(i,j) = zero + 10 continue + 20 continue + 30 continue +c +c initialize remaining columns to those of the identity matrix. +c + np1 = n + 1 + if (m .lt. np1) go to 60 + do 50 j = np1, m + do 40 i = 1, m + q(i,j) = zero + 40 continue + q(j,j) = one + 50 continue + 60 continue +c +c accumulate q from its factored form. +c + do 120 l = 1, minmn + k = minmn - l + 1 + do 70 i = k, m + wa(i) = q(i,k) + q(i,k) = zero + 70 continue + q(k,k) = one + if (wa(k) .eq. zero) go to 110 + do 100 j = k, m + sum = zero + do 80 i = k, m + sum = sum + q(i,j)*wa(i) + 80 continue + temp = sum/wa(k) + do 90 i = k, m + q(i,j) = q(i,j) - temp*wa(i) + 90 continue + 100 continue + 110 continue + 120 continue + return +c +c last card of subroutine qform. +c + end +c + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + integer m,n,lda,lipvt + integer ipvt(lipvt) + logical pivot + double precision a(lda,n),rdiag(n),acnorm(n),wa(n) +c ********** +c +c subroutine qrfac +c +c this subroutine uses householder transformations with column +c pivoting (optional) to compute a qr factorization of the +c m by n matrix a. that is, qrfac determines an orthogonal +c matrix q, a permutation matrix p, and an upper trapezoidal +c matrix r with diagonal elements of nonincreasing magnitude, +c such that a*p = q*r. the householder transformation for +c column k, k = 1,2,...,min(m,n), is of the form +c +c t +c i - (1/u(k))*u*u +c +c where u has zeros in the first k-1 positions. the form of +c this transformation and the method of pivoting first +c appeared in the corresponding linpack subroutine. +c +c the subroutine statement is +c +c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a contains the matrix for +c which the qr factorization is to be computed. on output +c the strict upper trapezoidal part of a contains the strict +c upper trapezoidal part of r, and the lower trapezoidal +c part of a contains a factored form of q (the non-trivial +c elements of the u vectors described above). +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c pivot is a logical input variable. if pivot is set true, +c then column pivoting is enforced. if pivot is set false, +c then no column pivoting is done. +c +c ipvt is an integer output array of length lipvt. ipvt +c defines the permutation matrix p such that a*p = q*r. +c column j of p is column ipvt(j) of the identity matrix. +c if pivot is false, ipvt is not referenced. +c +c lipvt is a positive integer input variable. if pivot is false, +c then lipvt may be as small as 1. if pivot is true, then +c lipvt must be at least n. +c +c rdiag is an output array of length n which contains the +c diagonal elements of r. +c +c acnorm is an output array of length n which contains the +c norms of the corresponding columns of the input matrix a. +c if this information is not needed, then acnorm can coincide +c with rdiag. +c +c wa is a work array of length n. if pivot is false, then wa +c can coincide with rdiag. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dmax1,dsqrt,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kmax,minmn + double precision ajnorm,epsmch,one,p05,sum,temp,zero + double precision dpmpar,enorm + data one,p05,zero /1.0d0,5.0d-2,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c compute the initial column norms and initialize several arrays. +c + do 10 j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + 10 continue +c +c reduce a to r with householder transformations. +c + minmn = min0(m,n) + do 110 j = 1, minmn + if (.not.pivot) go to 40 +c +c bring the column of largest norm into the pivot position. +c + kmax = j + do 20 k = j, n + if (rdiag(k) .gt. rdiag(kmax)) kmax = k + 20 continue + if (kmax .eq. j) go to 40 + do 30 i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + 30 continue + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + 40 continue +c +c compute the householder transformation to reduce the +c j-th column of a to a multiple of the j-th unit vector. +c + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm .eq. zero) go to 100 + if (a(j,j) .lt. zero) ajnorm = -ajnorm + do 50 i = j, m + a(i,j) = a(i,j)/ajnorm + 50 continue + a(j,j) = a(j,j) + one +c +c apply the transformation to the remaining columns +c and update the norms. +c + jp1 = j + 1 + if (n .lt. jp1) go to 100 + do 90 k = jp1, n + sum = zero + do 60 i = j, m + sum = sum + a(i,j)*a(i,k) + 60 continue + temp = sum/a(j,j) + do 70 i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + 70 continue + if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + 80 continue + 90 continue + 100 continue + rdiag(j) = -ajnorm + 110 continue + return +c +c last card of subroutine qrfac. +c + end +c + subroutine r1mpyq(m,n,a,lda,v,w) + integer m,n,lda + double precision a(lda,n),v(n),w(n) +c ********** +c +c subroutine r1mpyq +c +c given an m by n matrix a, this subroutine computes a*q where +c q is the product of 2*(n - 1) transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c and gv(i), gw(i) are givens rotations in the (i,n) plane which +c eliminate elements in the i-th and n-th planes, respectively. +c q itself is not given, rather the information to recover the +c gv, gw rotations is supplied. +c +c the subroutine statement is +c +c subroutine r1mpyq(m,n,a,lda,v,w) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a must contain the matrix +c to be postmultiplied by the orthogonal matrix q +c described above. on output a*q has replaced a. +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c v is an input array of length n. v(i) must contain the +c information necessary to recover the givens rotation gv(i) +c described above. +c +c w is an input array of length n. w(i) must contain the +c information necessary to recover the givens rotation gw(i) +c described above. +c +c subroutines called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,nmj,nm1 + double precision cos,one,sin,temp + data one /1.0d0/ +c +c apply the first set of givens rotations to a. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 50 + do 20 nmj = 1, nm1 + j = n - nmj + if (dabs(v(j)) .gt. one) cos = one/v(j) + if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(v(j)) .le. one) sin = v(j) + if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) + do 10 i = 1, m + temp = cos*a(i,j) - sin*a(i,n) + a(i,n) = sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 10 continue + 20 continue +c +c apply the second set of givens rotations to a. +c + do 40 j = 1, nm1 + if (dabs(w(j)) .gt. one) cos = one/w(j) + if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(w(j)) .le. one) sin = w(j) + if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) + do 30 i = 1, m + temp = cos*a(i,j) + sin*a(i,n) + a(i,n) = -sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 30 continue + 40 continue + 50 continue + return +c +c last card of subroutine r1mpyq. +c + end +c + subroutine r1updt(m,n,s,ls,u,v,w,sing) + integer m,n,ls + logical sing + double precision s(ls),u(m),v(n),w(m) +c ********** +c +c subroutine r1updt +c +c given an m by n lower trapezoidal matrix s, an m-vector u, +c and an n-vector v, the problem is to determine an +c orthogonal matrix q such that +c +c t +c (s + u*v )*q +c +c is again lower trapezoidal. +c +c this subroutine determines q as the product of 2*(n - 1) +c transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c where gv(i), gw(i) are givens rotations in the (i,n) plane +c which eliminate elements in the i-th and n-th planes, +c respectively. q itself is not accumulated, rather the +c information to recover the gv, gw rotations is returned. +c +c the subroutine statement is +c +c subroutine r1updt(m,n,s,ls,u,v,w,sing) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of s. +c +c n is a positive integer input variable set to the number +c of columns of s. n must not exceed m. +c +c s is an array of length ls. on input s must contain the lower +c trapezoidal matrix s stored by columns. on output s contains +c the lower trapezoidal matrix produced as described above. +c +c ls is a positive integer input variable not less than +c (n*(2*m-n+1))/2. +c +c u is an input array of length m which must contain the +c vector u. +c +c v is an array of length n. on input v must contain the vector +c v. on output v(i) contains the information necessary to +c recover the givens rotation gv(i) described above. +c +c w is an output array of length m. w(i) contains information +c necessary to recover the givens rotation gw(i) described +c above. +c +c sing is a logical output variable. sing is set true if any +c of the diagonal elements of the output s are zero. otherwise +c sing is set false. +c +c subprograms called +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more, +c john l. nazareth +c +c ********** + integer i,j,jj,l,nmj,nm1 + double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, + * zero + double precision dpmpar + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c +c giant is the largest magnitude. +c + giant = dpmpar(3) +c +c initialize the diagonal element pointer. +c + jj = (n*(2*m - n + 1))/2 - (m - n) +c +c move the nontrivial part of the last column of s into w. +c + l = jj + do 10 i = n, m + w(i) = s(l) + l = l + 1 + 10 continue +c +c rotate the vector v into a multiple of the n-th unit vector +c in such a way that a spike is introduced into w. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) .eq. zero) go to 50 +c +c determine a givens rotation which eliminates the +c j-th element of v. +c + if (dabs(v(n)) .ge. dabs(v(j))) go to 20 + cotan = v(n)/v(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 30 + 20 continue + tan = v(j)/v(n) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 30 continue +c +c apply the transformation to v and store the information +c necessary to recover the givens rotation. +c + v(n) = sin*v(j) + cos*v(n) + v(j) = tau +c +c apply the transformation to s and extend the spike in w. +c + l = jj + do 40 i = j, m + temp = cos*s(l) - sin*w(i) + w(i) = sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 40 continue + 50 continue + 60 continue + 70 continue +c +c add the spike from the rank 1 update to w. +c + do 80 i = 1, m + w(i) = w(i) + v(n)*u(i) + 80 continue +c +c eliminate the spike. +c + sing = .false. + if (nm1 .lt. 1) go to 140 + do 130 j = 1, nm1 + if (w(j) .eq. zero) go to 120 +c +c determine a givens rotation which eliminates the +c j-th element of the spike. +c + if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 + cotan = s(jj)/w(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 100 + 90 continue + tan = w(j)/s(jj) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 100 continue +c +c apply the transformation to s and reduce the spike in w. +c + l = jj + do 110 i = j, m + temp = cos*s(l) + sin*w(i) + w(i) = -sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 110 continue +c +c store the information necessary to recover the +c givens rotation. +c + w(j) = tau + 120 continue +c +c test for zero diagonal elements in the output s. +c + if (s(jj) .eq. zero) sing = .true. + jj = jj + (m - j + 1) + 130 continue + 140 continue +c +c move w back into the last column of the output s. +c + l = jj + do 150 i = n, m + s(l) = w(i) + l = l + 1 + 150 continue + if (s(jj) .eq. zero) sing = .true. + return +c +c last card of subroutine r1updt. +c + end +c +c +c + subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag) +c + double precision fun, a, b, abserr, relerr, result, errest, flag + integer nofun +c +c estimate the integral of fun(x) from a to b +c to a user provided tolerance. +c an automatic adaptive routine based on +c the 8-panel newton-cotes rule. +c +c input .. +c +c fun the name of the integrand function subprogram fun(x). +c a the lower limit of integration. +c b the upper limit of integration.(b may be less than a.) +c relerr a relative error tolerance. (should be non-negative) +c abserr an absolute error tolerance. (should be non-negative) +c +c output .. +c +c result an approximation to the integral hopefully satisfying the +c least stringent of the two error tolerances. +c errest an estimate of the magnitude of the actual error. +c nofun the number of function values used in calculation of result. +c flag a reliability indicator. if flag is zero, then result +c probably satisfies the error tolerance. if flag is +c xxx.yyy , then xxx = the number of intervals which have +c not converged and 0.yyy = the fraction of the interval +c left to do when the limit on nofun was approached. +c + double precision w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp + double precision qprev,qnow,qdiff,qleft,esterr,tolerr + double precision qright(31),f(16),x(16),fsave(8,30),xsave(8,30) + double precision dabs,dmax1 + integer levmin,levmax,levout,nomax,nofin,lev,nim,i,j +c +c *** stage 1 *** general initialization +c set constants. +c + levmin = 1 + levmax = 30 + levout = 6 + nomax = 5000 + nofin = nomax - 8*(levmax-levout+2**(levout+1)) +c +c trouble when nofun reaches nofin +c + w0 = 3956.0d0 / 14175.0d0 + w1 = 23552.0d0 / 14175.0d0 + w2 = -3712.0d0 / 14175.0d0 + w3 = 41984.0d0 / 14175.0d0 + w4 = -18160.0d0 / 14175.0d0 +c +c initialize running sums to zero. +c + flag = 0.0d0 + result = 0.0d0 + cor11 = 0.0d0 + errest = 0.0d0 + area = 0.0d0 + nofun = 0 + if (a .eq. b) return +c +c *** stage 2 *** initialization for first interval +c + lev = 0 + nim = 1 + x0 = a + x(16) = b + qprev = 0.0d0 + f0 = fun(x0) + stone = (b - a) / 16.0d0 + x(8) = (x0 + x(16)) / 2.0d0 + x(4) = (x0 + x(8)) / 2.0d0 + x(12) = (x(8) + x(16)) / 2.0d0 + x(2) = (x0 + x(4)) / 2.0d0 + x(6) = (x(4) + x(8)) / 2.0d0 + x(10) = (x(8) + x(12)) / 2.0d0 + x(14) = (x(12) + x(16)) / 2.0d0 + do 25 j = 2, 16, 2 + f(j) = fun(x(j)) + 25 continue + nofun = 9 +c +c *** stage 3 *** central calculation +c requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16. +c calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area. +c + 30 x(1) = (x0 + x(2)) / 2.0d0 + f(1) = fun(x(1)) + do 35 j = 3, 15, 2 + x(j) = (x(j-1) + x(j+1)) / 2.0d0 + f(j) = fun(x(j)) + 35 continue + nofun = nofun + 8 + step = (x(16) - x0) / 16.0d0 + qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) + 1 + w3*(f(3)+f(5)) + w4*f(4)) * step + qright(lev+1)=(w0*(f(8)+f(16))+w1*(f(9)+f(15))+w2*(f(10)+f(14)) + 1 + w3*(f(11)+f(13)) + w4*f(12)) * step + qnow = qleft + qright(lev+1) + qdiff = qnow - qprev + area = area + qdiff +c +c *** stage 4 *** interval convergence test +c + esterr = dabs(qdiff) / 1023.0d0 + tolerr = dmax1(abserr,relerr*dabs(area)) * (step/stone) + if (lev .lt. levmin) go to 50 + if (lev .ge. levmax) go to 62 + if (nofun .gt. nofin) go to 60 + if (esterr .le. tolerr) go to 70 +c +c *** stage 5 *** no convergence +c locate next interval. +c + 50 nim = 2*nim + lev = lev+1 +c +c store right hand elements for future use. +c + do 52 i = 1, 8 + fsave(i,lev) = f(i+8) + xsave(i,lev) = x(i+8) + 52 continue +c +c assemble left hand elements for immediate use. +c + qprev = qleft + do 55 i = 1, 8 + j = -i + f(2*j+18) = f(j+9) + x(2*j+18) = x(j+9) + 55 continue + go to 30 +c +c *** stage 6 *** trouble section +c number of function values is about to exceed limit. +c + 60 nofin = 2*nofin + levmax = levout + flag = flag + (b - x0) / (b - a) + go to 70 +c +c current level is levmax. +c + 62 flag = flag + 1.0d0 +c +c *** stage 7 *** interval converged +c add contributions into running sums. +c + 70 result = result + qnow + errest = errest + esterr + cor11 = cor11 + qdiff / 1023.0d0 +c +c locate next interval. +c + 72 if (nim .eq. 2*(nim/2)) go to 75 + nim = nim/2 + lev = lev-1 + go to 72 + 75 nim = nim + 1 + if (lev .le. 0) go to 80 +c +c assemble elements required for the next interval. +c + qprev = qright(lev) + x0 = x(16) + f0 = f(16) + do 78 i = 1, 8 + f(2*i) = fsave(i,lev) + x(2*i) = xsave(i,lev) + 78 continue + go to 30 +c +c *** stage 8 *** finalize and return +c + 80 result = result + cor11 +c +c make sure errest not less than roundoff level. +c + if (errest .eq. 0.0d0) return + 82 temp = dabs(result) + errest + if (temp .ne. dabs(result)) return + errest = 2.0d0*errest + go to 82 + end diff --git a/src/green_func_p.f90 b/src/green_func_p.f90 new file mode 100644 index 0000000..2fb61ee --- /dev/null +++ b/src/green_func_p.f90 @@ -0,0 +1,437 @@ +!######################################################################## + + MODULE green_func_p + +!######################################################################## +! +! The module contains few subroutines which are requested to calculate +! the current drive value by adjoint approach +! +!######################################################################## + USE const_and_precisions +!------- + IMPLICIT NONE + CHARACTER(Len=1), PRIVATE :: adj_appr(6) ! adjoint approach switcher +!------- + REAL(wp_), PRIVATE :: r2,q2,gp1,Rfactor +!------- + REAL(wp_), PRIVATE, PARAMETER :: delta = 1e-4 ! border for recalculation +!------- for N.M. subroutines (variational principle) ------- + REAL(wp_), PRIVATE :: sfd(1:4) + INTEGER, PRIVATE, PARAMETER :: nre = 2 ! order of rel. correct. + REAL(wp_), PRIVATE, PARAMETER :: vp_mee(0:4,0:4,0:2) = & + RESHAPE((/0.0, 0.0, 0.0, 0.0, 0.0, & + 0.0, 0.184875, 0.484304, 1.06069, 2.26175, & + 0.0, 0.484304, 1.41421, 3.38514, 7.77817, & + 0.0, 1.06069, 3.38514, 8.73232, 21.4005, & + 0.0, 2.26175, 7.77817, 21.4005, 55.5079, & + ! & + 0.0, -1.33059,-2.57431, -5.07771, -10.3884, & + -0.846284,-1.46337, -1.4941, -0.799288, 2.57505, & + -1.1601, -1.4941, 2.25114, 14.159, 50.0534, & + -1.69257, -0.799288, 14.159, 61.4168, 204.389, & + -2.61022, 2.57505, 50.0534, 204.389, 683.756, & + ! & + 0.0, 2.62498, 0.985392,-5.57449, -27.683, & + 0.0, 3.45785, 5.10096, 9.34463, 22.9831, & + -0.652555, 5.10096, 20.5135, 75.8022, 268.944, & + -2.11571, 9.34463, 75.8022, 330.42, 1248.69, & + -5.38358, 22.9831, 268.944, 1248.69, 4876.48/),& + (/5,5,3/)) + REAL(wp_), PRIVATE, PARAMETER :: vp_mei(0:4,0:4,0:2) = & + RESHAPE((/0.0, 0.886227, 1.0, 1.32934, 2.0, & + 0.886227,1.0, 1.32934, 2.0, 3.32335, & + 1.0, 1.32934, 2.0, 3.32335, 6.0, & + 1.32934, 2.0, 3.32335, 6.0, 11.6317, & + 2.0, 3.32335, 6.0, 11.6317, 24.0, & + ! & + 0.0, 0.332335, 1.0, 2.49251, 6.0, & + 1.66168, 1.0, 2.49251, 6.0, 14.5397, & + 3.0, 2.49251, 6.0, 14.5397, 36.0, & + 5.81586, 6.0, 14.5397, 36.0, 91.5999, & + 12.0, 14.5397, 36.0, 91.5999, 240.0, & + ! & + 0.0, -0.103855, 0.0, 1.09047, 6.0, & + 0.726983,0.0, 1.09047, 6.0, 24.5357, & + 3.0, 1.09047, 6.0, 24.5357, 90.0, & + 9.81427, 6.0, 24.5357, 90.0, 314.875, & + 30.0, 24.5357, 90.0, 314.875, 1080.0 /), & + (/5,5,3/)) + REAL(wp_), PRIVATE, PARAMETER :: vp_oee(0:4,0:4,0:2) = & + RESHAPE((/0.0, 0.56419, 0.707107, 1.0073, 1.59099, & + 0.56419, 0.707107, 1.0073, 1.59099, 2.73981, & + 0.707107,1.0073, 1.59099, 2.73981, 5.08233, & + 1.0073, 1.59099, 2.73981, 5.08233, 10.0627, & + 1.59099, 2.73981, 5.08233, 10.0627, 21.1138, & + ! & + 0.0, 1.16832, 1.90035, 3.5758, 7.41357, & + 2.17562, 1.90035, 3.5758, 7.41357, 16.4891, & + 3.49134, 3.5758, 7.41357, 16.4891, 38.7611, & + 6.31562, 7.41357, 16.4891, 38.7611, 95.4472, & + 12.4959, 16.4891, 38.7611, 95.4472, 244.803, & + ! & + 0.0, 2.65931, 4.64177, 9.6032, 22.6941, & + 4.8652, 4.64177, 9.6032, 22.6941, 59.1437, & + 9.51418, 9.6032, 22.6941, 59.1437, 165.282, & + 21.061, 22.6941, 59.1437, 165.282, 485.785, & + 50.8982, 59.1437, 165.282, 485.785, 1483.22/), & + (/5,5,3/)) + REAL(wp_), PRIVATE, PARAMETER :: vp_g(0:4,0:2) = & + RESHAPE((/1.32934, 2.0, 3.32335, 6.0, 11.6317, & + 2.49251, 0.0, 2.90793, 12.0, 39.2571, & + 1.09047, 6.0, 11.45, 30.0, 98.9606/), & + (/5,3/)) +!######################################################################## + + CONTAINS + +!####################################################################### + + SUBROUTINE Setup_SpitzFunc +!======================================================================= + IMPLICIT NONE +!======================================================================= + adj_appr(1) = 'l' ! collisionless limit +! adj_appr(1) = 'c' ! collisional (classical) limit, w/o trap. part. + adj_appr(2) = 'm' ! momentum conservation +! adj_appr(2) = 'h' ! high-speed limit +!--- + adj_appr(3) = 'l' ! DO NOT CHANGE! + adj_appr(4) = 'r' ! DO NOT CHANGE! + adj_appr(5) = 'v' ! DO NOT CHANGE! + adj_appr(6) = 'i' ! DO NOT CHANGE! +!======================================================================= +!..... +!======================================================================= + RETURN + END SUBROUTINE Setup_SpitzFunc + + + SUBROUTINE GenSpitzFunc(Te,Zeff,fc,u,q,gam, K,dKdu) + +!======================================================================= +! Author: N.B.Marushchenko +! June 2005: as start point the subroutine of Ugo Gasparino (198?) +! SpitzFunc() is taken and modified. +! 1. adapted to the Fortran-95 +! 2. derivative of Spitzer function is added +! 3. separation for 2 brunches is done: +! 1st is referenced as 'with conservation of the moment', +! 2nd - as 'high speed limit'. +! The last one is taken from the Lin-Liu formulation +! (Phys.Plasmas 10 (2003) 4064) with K = F*fc. +! The asymptotical high speed limit (Taguchi-Fisch model) +! is also included as the reference case. +! Feb. 2008: non-relativ. version is replaced by the relativistic one; +! the method is the the same, but the trial-function is +! based on the relativistic formulation. +! The relativistic corrections for the collisional operator +! up to the second order, i.e. (1/mu)**2, are applied. +! Sep. 2008: generalized Spitzer function for arbitrary collisionality +! is implemented. The model is based on the concept of +! the "effective trapped particles fraction". +! The different.-integral kinetic equation for the generalized +! Spitzer function is produced with help of subroutines +! ArbColl_TrappFract_Array and ArbColl_SpitzFunc_Array, +! where the subroutines of H. Maassberg are called). +!======================================================================== +! Spitzer function with & w/o trapped particle effects is given by: +! +! K(x) = x/gamma*(d1*x+d2*x^2+d4*x^3+d4*x^4), +! +! where x = v/v_th and gamma=1 for non-relativistic version (Ugo), +! or x = p/p_th for relativistic version (N.M., February 2008). +! Note, that somewhere the function F(x) instead of K(x) is applied, +! +! F(x) = K(x)/fc. +! +! Numerical inversion of the 5x5 symmetric matrix obtained from the +! generalized Spitzer problem (see paper of Taguchi for the equation +! and paper of Hirshman for the variational approach bringing to the +! matrix to be inverted). +! +! The numerical method used is an improved elimination scheme +! (Banachiewiczs-Cholesky-Crout method). +! This method is particularly simple for symmetric matrix. +! As a reference see "Mathematical Handbook" by Korn & Korn, p.635-636. +! +! Refs.: 1. S.P. Hirshman, Phys. Fluids 23 (1980) 1238 +! 2. M. Rome' et al., Plasma Phys. Contr. Fus. 40 (1998) 511 +! 3. N.B. Marushchenko et al., Fusion Sci. Technol. 55 (2009) 180 +!======================================================================== +! INPUTS: +! u - p/sqrt(2mT) +! q - p/mc; +! gam - relativistic factor; +! mu - mc2/Te +! Zeff - effective charge; +! fc - fraction of circulating particles. +! +! OUTPUTS: +! K - Spitzer's function +! dKdu = dK/du, i.e. its derivative over normalized momentum +!======================================================================= + IMPLICIT NONE + REAL(wp_), INTENT(in) :: Te,Zeff,fc,u,q,gam + REAL(wp_), INTENT(out) :: K,dKdu + REAL(wp_) :: mu,gam1,gam2,gam3,w,dwdu +!======================================================================= + K = 0 + dKdu = 0 + IF (u < comp_eps) RETURN +!--- + mu = mc2_/max(Te,1d-3) + SELECT CASE(adj_appr(2)) + CASE('m') !--------------- momentum conservation ------------------! + gam1 = gam ! + IF (adj_appr(4) == 'n') gam1 = 1 ! + gam2 = gam1*gam1 ! + gam3 = gam1*gam2 ! + K = u/gam1*u*(sfd(1)+u*(sfd(2)+u*(sfd(3)+u*sfd(4)))) ! + dKdu = u/gam3* (sfd(1)*(1+ gam2)+u*(sfd(2)*(1+2*gam2)+ & ! + u*(sfd(3)*(1+3*gam2)+u* sfd(4)*(1+4*gam2)))) ! + !--------------------- end momentum conservation -------------------! + CASE('h') !---------------- high-speed-limit ----------------------! + IF (adj_appr(4) == 'n') THEN !- non-relativ. asymptotic form -! + K = u**4 *fc/(Zeff+1+4*fc) !- (Taguchi-Fisch model) -! + dKdu = 4*u**3 *fc/(Zeff+1+4*fc) ! + ELSEIF (adj_appr(4) == 'r') THEN !- relativistic, Lin-Liu form. -! + CALL SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu) ! + ENDIF ! + CASE default !----------------------------------------------------! + PRINT*,'GenSpitzFunc: WARNING! Spitzer function is not defined.' + RETURN + END SELECT +!======================================================================= + RETURN + END SUBROUTINE GenSpitzFunc + +!####################################################################### +!####################################################################### +!####################################################################### + + SUBROUTINE SpitzFuncCoeff(Te,Zeff,fc) +!======================================================================= +! Calculates the matrix coefficients required for the subroutine +! "GenSpitzFunc", where the Spitzer function is defined through the +! variational principle. +! +! Weakly relativistic (upgraded) version (10.09.2008). +! Apart of the non-relativistic matrix coefficients, taken from the +! old subroutine of Ugo Gasparino, the relativistic correction written +! as series in 1/mu^n (mu=mc2/T) powers is added. Two orders are taken +! into account, i.e. n=0,1,2. +! +! In this version, the coefficients "oee", i.e. Omega_ij, are formulated +! for arbitrary collisionality. +! +! INPUT VARIABLES: +! rho = sqrt(SS) with SS - flux-surface label (norm. magn. flux) +! ne - density, 1/m^3 +! Te - temperature, keV +! Zeff - effective charge +! fc - fraction of circulating particles +! +! OUTPUT VARIABLES (defined as a global ones): +! sfd(1),...,sfd(4) - coefficients of the polynomial expansion of the +! "Spitzer"-function (the same as in the Hirshman paper) +!======================================================================= + IMPLICIT NONE + REAL(wp_), INTENT(in) :: Te,Zeff,fc + INTEGER :: n,i,j + REAL(wp_) :: rtc,rtc1,mu,y,tn(1:nre) + REAL(wp_) :: m(0:4,0:4),g(0:4) + REAL(wp_) :: om(0:4,0:4) + REAL(wp_) :: gam11,gam21,gam31,gam41,gam01, & + gam22,gam32,gam42,gam02, & + gam33,gam43,gam03, & + gam44,gam04,gam00 + REAL(wp_) :: alp12,alp13,alp14,alp10, & + alp23,alp24,alp20, & + alp34,alp30,alp40 + REAL(wp_) :: bet0,bet1,bet2,bet3,bet4,d0 + LOGICAL :: renew,rel,newTe,newne,newZ,newfc + REAL(wp_), SAVE :: sfdx(1:4) = 0 + REAL(wp_), SAVE :: ne_old =-1, Te_old =-1, Zeff_old =-1, fc_old =-1 +!======================================================================= + rel = Te > 1 + newTe = abs(Te -Te_old ) > delta*Te + newZ = abs(Zeff-Zeff_old) > delta*Zeff + newfc = abs(fc -fc_old ) > delta*fc + SELECT CASE(adj_appr(1)) + CASE ('l','c') + renew = (newTe .and. rel) .OR. newZ .OR. newfc + END SELECT +!--- + IF (.not.renew) THEN + sfd(:) = sfdx(:) + RETURN + ENDIF +!======================================================================= + tn(:) = 0 + IF (adj_appr(4) == 'r') THEN + IF (nre > 0) THEN + mu = mc2_/max(Te,1d-3) + tn(1) = 1/mu + DO n=2,min(2,nre) + tn(n) = tn(n-1)/mu + ENDDO + ENDIF + ENDIF +!--- + SELECT CASE(adj_appr(1)) + CASE ('l','c') !---- both classical & collisionless limits ----! + rtc = (1-fc)/fc; rtc1 = rtc+1 ! + !--- ! + DO i=0,4 ! + g(i) = vp_g(i,0) ! + DO n=1,min(2,nre) ! + g(i) = g(i) + tn(n)*vp_g(i,n) ! + ENDDO ! + !--- ! + DO j=0,4 ! + IF (i == 0 .or. j == 0 .or. j >= i) THEN ! + y = vp_mee(i,j,0) + rtc *vp_oee(i,j,0) + & ! + Zeff*rtc1*vp_mei(i,j,0) ! + DO n=1,min(2,nre) ! + y = y + (vp_mee(i,j,n) + rtc *vp_oee(i,j,n) + & ! + Zeff*rtc1*vp_mei(i,j,n))*tn(n) ! + ENDDO ! + m(i,j) = y ! + ENDIF ! + ENDDO ! + ENDDO ! + DO i=2,4 ! + DO j=1,i-1 ! + m(i,j) = m(j,i) ! + ENDDO ! + ENDDO ! + m(0,0) = 0 ! + CASE default !------------------------------------------------! + PRINT*,'Green_Func: WARNING! Adjoint approach is not defined.' + RETURN + END SELECT +!======================================================================= + gam11 = m(1,1) + gam21 = m(2,1) + gam31 = m(3,1) + gam41 = m(4,1) + gam01 = m(0,1) +! + alp12 = m(1,2)/m(1,1) + alp13 = m(1,3)/m(1,1) + alp14 = m(1,4)/m(1,1) + alp10 = m(1,0)/m(1,1) +! + gam22 = m(2,2)-gam21*alp12 + gam32 = m(3,2)-gam31*alp12 + gam42 = m(4,2)-gam41*alp12 + gam02 = m(0,2)-gam01*alp12 +! + alp23 = gam32/gam22 + alp24 = gam42/gam22 + alp20 = gam02/gam22 +! + gam33 = m(3,3)-gam31*alp13-gam32*alp23 + gam43 = m(4,3)-gam41*alp13-gam42*alp23 + gam03 = m(0,3)-gam01*alp13-gam02*alp23 +! + alp34 = gam43/gam33 + alp30 = gam03/gam33 +! + gam44 = m(4,4)-gam41*alp14-gam42*alp24-gam43*alp34 + gam04 = m(0,4)-gam01*alp14-gam02*alp24-gam03*alp34 +! + alp40 = gam04/gam44 +! + gam00 = m(0,0)-gam01*alp10-gam02*alp20-gam03*alp30-gam04*alp40 +! + bet1 = g(1)/m(1,1) + bet2 = (g(2)-gam21*bet1)/gam22 + bet3 = (g(3)-gam31*bet1-gam32*bet2)/gam33 + bet4 = (g(4)-gam41*bet1-gam42*bet2-gam43*bet3)/gam44 + bet0 = (g(0)-gam01*bet1-gam02*bet2-gam03*bet3-gam04*bet4)/gam00 +! + d0 = bet0 + sfd(4) = bet4-alp40*d0 + sfd(3) = bet3-alp30*d0-alp34*sfd(4) + sfd(2) = bet2-alp20*d0-alp24*sfd(4)-alp23*sfd(3) + sfd(1) = bet1-alp10*d0-alp14*sfd(4)-alp13*sfd(3)-alp12*sfd(2) +!======================================================================= + fc_old = fc + Te_old = Te + Zeff_old = Zeff +!--- + sfdx(1:4) = sfd(1:4) +!======================================================================= + RETURN + END SUBROUTINE SpitzFuncCoeff + +!####################################################################### +!####################################################################### +!####################################################################### + + SUBROUTINE SpitzFunc_HighSpeedLimit(Zeff,fc,u,q,gam, K,dKdu) +!======================================================================= +! Calculates the "Spitzer function" in high velocity limit, relativistic +! formulation: Lin-Liu et al., Phys.Pl. (2003),v10, 4064, Eq.(33). +! +! Inputs: +! Zeff - effective charge +! fc - fraction of circulating electrons +! u - p/(m*vte) +! q - p/mc +! gam - relativ. factor +! +! Outputs: +! K - Spitzer function +! dKdu - its derivative +!======================================================================= + IMPLICIT NONE + REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam + REAL(wp_), INTENT(out) :: K,dKdu + INTEGER :: nfun + REAL(8) :: gam2,err,flag,Integr + REAL(8), PARAMETER :: a = 0d0, b = 1d0, rtol = 1d-4, atol = 1d-12 +!======================================================================= + r2 = (1+Zeff)/fc ! global parameter needed for integrand, HSL_f(t) +!------------------ + IF (u < 1e-2) THEN + K = u**4/(r2+4) + dKdu = 4*u**3/(r2+4) + RETURN + ENDIF +!======================================================================= + q2 = q*q ! for the integrand, HSL_f + gp1 = gam+1 ! .. +!--- + CALL quanc8(HSL_f,zero,unit,atol,rtol,Integr,err,nfun,flag) +!======================================================================= + gam2 = gam*gam +!--- + K = u**4 * Integr + dKdu = (u/gam)**3 * (1-r2*gam2*Integr) +!======================================================================= + RETURN + END SUBROUTINE SpitzFunc_HighSpeedLimit + +!####################################################################### +!####################################################################### +!####################################################################### + + FUNCTION HSL_f(t) RESULT(f) +!======================================================================= +! Integrand for the high-speed limit approach (Lin-Liu's formulation) +!======================================================================= + IMPLICIT NONE + REAL(8), INTENT(in) :: t + REAL(8) :: f,g + g = sqrt(1+t*t*q2) + f = t**(3+r2)/g**3 * (gp1/(g+1))**r2 + END FUNCTION HSL_f + +!####################################################################### + + END MODULE green_func_p + +!####################################################################### diff --git a/src/itm_constants.f90 b/src/itm_constants.f90 new file mode 100644 index 0000000..a617670 --- /dev/null +++ b/src/itm_constants.f90 @@ -0,0 +1,32 @@ +!> Module implementing the ITM physics constants +!> +!> Source: +!> based on SOLPS b2mod_constants.F +!> '09/12/07 xpb : source CODATA 2006 (http://www.nist.gov/)' +!> pulled from ets r100 +!> +!> \author David Coster +!> +!> \version "$Id: itm_constants.f90 37 2009-08-17 17:15:00Z coster $" + +module itm_constants + + use itm_types + + real (kind = R8), parameter :: itm_pi = 3.141592653589793238462643383280_R8 + real (kind = R8), parameter :: itm_c = 2.99792458e8_R8 ! speed of light, m/s + real (kind = R8), parameter :: itm_me = 9.10938215e-31_R8 ! electron mass, kg + real (kind = R8), parameter :: itm_mp = 1.672621637e-27_R8 ! proton mass, kg + real (kind = R8), parameter :: itm_md = 3.34358320e-27_R8 ! deuteron mass, kg + real (kind = R8), parameter :: itm_mt = 5.00735588e-27_R8 ! triton mass, kg + real (kind = R8), parameter :: itm_ma = 6.64465620e-27_R8 ! alpha mass, kg + real (kind = R8), parameter :: itm_amu = 1.660538782e-27_R8 ! amu, kg + real (kind = R8), parameter :: itm_ev = 1.602176487e-19_R8 + real (kind = R8), parameter :: itm_qe = itm_ev + real (kind = R8), parameter :: itm_mu0 = 4.0e-7_R8 * itm_pi + real (kind = R8), parameter :: itm_eps0 = 1.0_R8 / (itm_mu0 * itm_c * itm_c) + real (kind = R8), parameter :: itm_avogr = 6.02214179e23_R8 + real (kind = R8), parameter :: itm_KBolt = 1.3806504e-23_R8 + character (len=64), parameter :: itm_constants_version = '$Id: itm_constants.f90 37 2009-08-17 17:15:00Z coster $' + +end module itm_constants diff --git a/src/itm_types.f90 b/src/itm_types.f90 new file mode 100644 index 0000000..8a16580 --- /dev/null +++ b/src/itm_types.f90 @@ -0,0 +1,50 @@ +!> Module implementing the ITM basic types +!> +!> Source: +!> based on SOLPS b2mod_types.F +!> pulled from ets r100 and extended with input from C. Konz, T. Ribeiro & B. Scott +!> +!> \author David Coster +!> +!> \version "$Id: itm_types.f90 144 2010-10-07 09:26:24Z konz $" + +module itm_types + + INTEGER, PARAMETER :: ITM_I1 = SELECTED_INT_KIND (2) ! Integer*1 + INTEGER, PARAMETER :: ITM_I2 = SELECTED_INT_KIND (4) ! Integer*2 + INTEGER, PARAMETER :: ITM_I4 = SELECTED_INT_KIND (9) ! Integer*4 + INTEGER, PARAMETER :: ITM_I8 = SELECTED_INT_KIND (18) ! Integer*8 + INTEGER, PARAMETER :: R4 = SELECTED_REAL_KIND (6, 37) ! Real*4 + INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND (15, 300) ! Real*8 + + INTEGER, PARAMETER :: itm_int_invalid = -999999999 + REAL(R8), PARAMETER :: itm_r8_invalid = -9.0D40 + + interface itm_is_valid + module procedure itm_is_valid_int4, itm_is_valid_int8, itm_is_valid_real8 + end interface + +contains + + logical function itm_is_valid_int4(in_int) + implicit none + integer(ITM_I4) in_int + itm_is_valid_int4 = in_int .ne. itm_int_invalid + return + end function itm_is_valid_int4 + + logical function itm_is_valid_int8(in_int) + implicit none + integer(ITM_I8) in_int + itm_is_valid_int8 = in_int .ne. itm_int_invalid + return + end function itm_is_valid_int8 + + logical function itm_is_valid_real8(in_real) + implicit none + real(R8) in_real + itm_is_valid_real8 = abs(in_real - itm_r8_invalid) .gt. abs(itm_r8_invalid) * 1.0e-15_R8 + return + end function itm_is_valid_real8 + +end module itm_types