diff --git a/Makefile b/Makefile index ba1cac4..929579a 100644 --- a/Makefile +++ b/Makefile @@ -2,40 +2,67 @@ EXE=gray # Objects list -OBJ=gray.o grayl.o reflections.o green_func_p.o \ - const_and_precisions.o itm_constants.o itm_types.o - +MAINOBJ=main.o +OTHOBJ= beamdata.o beams.o conical.o const_and_precisions.o coreprofiles.o \ + dierckx.o dispersion.o eccd.o eierf.o graycore.o gray-externals.o \ + gray_params.o equilibrium.o magsurf_data.o math.o minpack.o numint.o \ + pec.o polarization.o quadpack.o reflections.o simplespline.o utils.o + # Alternative search paths vpath %.f90 src vpath %.f src # Fortran compiler name and flags FC=gfortran -FFLAGS=-O3 #-Wall -g -fcheck=all +FFLAGS=-O3 +#FFLAGS=-Wall -g -finit-real=nan -ffpe-trap=invalid -fcheck=all -fbounds-check DIRECTIVES = -DREVISION="'$(shell svnversion src)'" all: $(EXE) # Build executable from object files -$(EXE): $(OBJ) +$(EXE): $(MAINOBJ) $(OTHOBJ) $(FC) $(FFLAGS) -o $@ $^ # Dependencies on modules -gray.o: green_func_p.o reflections.o -green_func_p.o: const_and_precisions.o -const_and_precisions.o: itm_types.o itm_constants.o -itm_constants.o: itm_types.o +main.o: const_and_precisions.o beams.o coreprofiles.o equilibrium.o \ + graycore.o gray_params.o reflections.o +graycore.o: const_and_precisions.o beamdata.o beams.o coreprofiles.o \ + dispersion.o equilibrium.o gray-externals.o gray_params.o \ + pec.o polarization.o reflections.o utils.o +gray-externals.o: const_and_precisions.o beams.o coreprofiles.o dierckx.o \ + dispersion.o eccd.o gray_params.o \ + equilibrium.o magsurf_data.o math.o numint.o quadpack.o \ + reflections.o simplespline.o utils.o beamdata.o +beams.o: const_and_precisions.o dierckx.o reflections.o simplespline.o utils.o +beamdata.o: const_and_precisions.o gray_params.o +conical.o: const_and_precisions.o +coreprofiles.o: const_and_precisions.o dierckx.o gray_params.o simplespline.o \ + utils.o +dierckx.o: const_and_precisions.o +dispersion.o: const_and_precisions.o eierf.o math.o quadpack.o +eccd.o: const_and_precisions.o conical.o magsurf_data.o dierckx.o numint.o +eierf.o: const_and_precisions.o +gray_params.o: const_and_precisions.o utils.o +equilibrium.o: const_and_precisions.o dierckx.o minpack.o simplespline.o \ + utils.o gray_params.o +magsurf_data.o: const_and_precisions.o gray_params.o equilibrium.o dierckx.o \ + reflections.o simplespline.o utils.o +math.o: const_and_precisions.o +minpack.o: const_and_precisions.o +numint.o: const_and_precisions.o +pec.o: const_and_precisions.o beamdata.o equilibrium.o gray_params.o \ + magsurf_data.o utils.o +polarization.o: const_and_precisions.o +quadpack.o: const_and_precisions.o +reflections.o: const_and_precisions.o utils.o +simplespline.o: const_and_precisions.o +utils.o: const_and_precisions.o # General object compilation command %.o: %.f90 - $(FC) $(FFLAGS) -c $< - -gray.o:gray.f green_func_p.o - $(FC) -cpp $(DIRECTIVES) $(FFLAGS) -c $< - -grayl.o:grayl.f - $(FC) $(FFLAGS) -c $^ + $(FC) -cpp $(DIRECTIVES) $(FFLAGS) -c $< .PHONY: clean install # Remove output files diff --git a/src/beamdata.f90 b/src/beamdata.f90 new file mode 100644 index 0000000..c4573fa --- /dev/null +++ b/src/beamdata.f90 @@ -0,0 +1,248 @@ +module beamdata + use const_and_precisions, only : wp_ + implicit none + + integer, save :: nray,nrayr,nrayth,nstep,jray1 + real(wp_), save :: dst,h,hh,h6,rwmax,twodr2 + integer, parameter :: nfileproj0 = 8, nfilew = 12 + +contains + + subroutine init_rtr(rtrparam,ywork,ypwork,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + use gray_params, only : rtrparam_type + use const_and_precisions, only : zero,half,two + implicit none + type(rtrparam_type), intent(in) :: rtrparam + real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, & + gri,psjki,tauv,alphav,ppabs,dids,ccci + real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri + real(wp_), dimension(:), intent(out), allocatable :: p0jk + complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt + integer, dimension(:), intent(out), allocatable :: iiv + + dst=rtrparam%dst + h=dst + hh=h*half + h6=h/6.0_wp_ + + nrayr=rtrparam%nrayr + nrayth=rtrparam%nrayth + if(nrayr==1) nrayth=1 + nray=(nrayr-1)*nrayth+1 + + rwmax=rtrparam%rwmax + if(nrayr>1) then + twodr2 = two*(rwmax/(nrayr-1))**2 + else + twodr2 = two + end if + + nstep=rtrparam%nstep + + call alloc_beam(ywork,ypwork,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + end subroutine init_rtr + + function rayi2jk(i) result(jk) + implicit none + integer, intent(in) :: i + integer, dimension(2) :: jk + integer :: ioff + + if (i>1) then + ioff = i - 2 + jk(1) = ioff/nrayth ! jr-2 + jk(2) = ioff - jk(1)*nrayth + 1 ! kt +! jk(2) = mod(ioff,nrayth) + 1 ! kt + jk(1) = jk(1) + 2 ! jr + else + jk = 1 + end if + end function rayi2jk + + function rayi2j(i) result(jr) + implicit none + integer, intent(in) :: i + integer :: jr + +! jr = max(1, (i-2)/nrayth + 2) + if (i>1) then + jr = (i-2)/nrayth + 2 + else + jr = 1 + end if + end function rayi2j + + function rayi2k(i) result(kt) + implicit none + integer, intent(in) :: i + integer :: kt + +! kt = max(1, mod(i-2,nrayth) + 1) + if (i>1) then + kt = mod(i-2,nrayth) + 1 + else + kt = 1 + end if + end function rayi2k + + function rayjk2i(jr,kt) result(i) + implicit none + integer, intent(in) :: jr,kt + integer :: i + +! i = max(1, (jr-2)*nrayth + kt + 1) + if (jr>1) then + i = (jr-2)*nrayth + kt + 1 + else + i = 1 + end if + end function rayjk2i + + subroutine alloc_beam(ywork,ypwork,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + implicit none + real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, & + gri,psjki,tauv,alphav,ppabs,dids,ccci + real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri + real(wp_), dimension(:), intent(out), allocatable :: p0jk + complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt + integer, dimension(:), intent(out), allocatable :: iiv + + call dealloc_beam(ywork,ypwork,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + + allocate(ywork(6,nray), ypwork(6,nray), gri(3,nray), ggri(3,3,nray), & + xc(3,nrayth,nrayr), du1(3,nrayth,nrayr), & + psjki(nray,nstep), tauv(nray,nstep), alphav(nray,nstep), & + ppabs(nray,nstep), dids(nray,nstep), ccci(nray,nstep), & + p0jk(nray), ext(nray), eyt(nray), iiv(nray)) + end subroutine alloc_beam + + + subroutine dealloc_beam(ywork,ypwork,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + implicit none + real(wp_), dimension(:,:), intent(out), allocatable :: ywork,ypwork, & + gri,psjki,tauv,alphav,ppabs,dids,ccci + real(wp_), dimension(:,:,:), intent(out), allocatable :: xc,du1,ggri + real(wp_), dimension(:), intent(out), allocatable :: p0jk + complex(wp_), dimension(:), intent(out), allocatable :: ext, eyt + integer, dimension(:), intent(out), allocatable :: iiv + + if (allocated(ywork)) deallocate(ywork) + if (allocated(ypwork)) deallocate(ypwork) + if (allocated(xc)) deallocate(xc) + if (allocated(du1)) deallocate(du1) + if (allocated(gri)) deallocate(gri) + if (allocated(ggri)) deallocate(ggri) + if (allocated(psjki)) deallocate(psjki) + if (allocated(tauv)) deallocate(tauv) + if (allocated(alphav)) deallocate(alphav) + if (allocated(ppabs)) deallocate(ppabs) + if (allocated(dids)) deallocate(dids) + if (allocated(ccci)) deallocate(ccci) + if (allocated(p0jk)) deallocate(p0jk) + if (allocated(ext)) deallocate(ext) + if (allocated(eyt)) deallocate(eyt) + if (allocated(iiv)) deallocate(iiv) + end subroutine dealloc_beam + + subroutine pweight(p0,p0jk) +! power associated to jk-th ray p0jk(j) for total beam power p0 + use const_and_precisions, only : wp_, zero, one, half, two + implicit none +! arguments + real(wp_), intent(in) :: p0 + real(wp_), dimension(:), intent(out) :: p0jk +! local variables + integer :: j,jk,jkn + real(wp_) :: dr,r,w,r0,w0,summ + real(wp_), dimension(nrayr) :: q + + if(nray==1) then + q(1) = one + else + dr = rwmax/dble(nrayr - 1) + summ = zero + w0 = one + do j = 1, nrayr + r = (dble(j) - half)*dr + w = exp(-two*r**2) + q(j) = w - w0 + summ = summ + q(j) + r0 = r + w0 = w + end do + q = q/summ + q(2:) = q(2:)/nrayth + end if + + p0jk(1)=q(1)*p0 + jk=2 + do j=2,nrayr + jkn=jk+nrayth + p0jk(jk:jkn-1)=q(j)*p0 + jk=jkn + end do + end subroutine pweight + + subroutine print_projxyzt(st,ywrk,iproj) + use const_and_precisions, only : wp_, comp_huge, zero, one + implicit none +! arguments + real(wp_), intent(in) :: st + real(wp_), dimension(:,:), intent(in) :: ywrk + integer, intent(in) :: iproj +! local variables + integer :: jk,jkz,nfile + integer, dimension(2) ::jkv + real(wp_), dimension(3) :: xv1,dir,dxv + real(wp_) :: dirm,rtimn,rtimx,csth1,snth1,csps1,snps1,xti,yti,zti,rti +! common/external functions/variables + + nfile = nfileproj0 + iproj + + xv1 = ywrk(1:3,1) + dir = ywrk(4:6,1) + dirm = sqrt(dir(1)**2 + dir(2)**2 + dir(3)**2) + dir = dir/dirm + csth1 = dir(3) + snth1 = sqrt(one - csth1**2) + if(snth1 > zero) then + csps1=dir(2)/snth1 + snps1=dir(1)/snth1 + else + csps1=one + snps1=zero + end if + + if(iproj==0) then + jkz = nray - nrayth + 1 + else + jkz = 1 + end if + + rtimn = comp_huge + rtimx = zero + do jk = jkz, nray + dxv = ywrk(1:3,jk) - xv1 + xti = dxv(1)*csps1 - dxv(2)*snps1 + yti =(dxv(1)*snps1 + dxv(2)*csps1)*csth1 - dxv(3)*snth1 + zti =(dxv(1)*snps1 + dxv(2)*csps1)*snth1 + dxv(3)*csth1 + rti = sqrt(xti**2 + yti**2) + + jkv=rayi2jk(jk) + if(.not.(iproj==0 .and. jk==1)) & + write(nfile,'(1x,e16.8e3,2i5,4(1x,e16.8e3))') st,jkv,xti,yti,zti,rti + if(iproj==1 .and. jkv(2)==nrayth) write(nfile,*) ' ' + + if(rti>=rtimx .and. jkv(1)==nrayr) rtimx = rti + if(rti<=rtimn .and. jkv(1)==nrayr) rtimn = rti + end do + write(nfile,*) ' ' + write(nfilew,'(3(1x,e16.8e3))') st,rtimn,rtimx + end subroutine print_projxyzt + +end module beamdata diff --git a/src/beams.f90 b/src/beams.f90 new file mode 100644 index 0000000..0343e1f --- /dev/null +++ b/src/beams.f90 @@ -0,0 +1,763 @@ +module beams + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine read_beam0(file_beam,fghz,x00,y00,z00, & + wcsi,weta,rcicsi,rcieta,phiw,phir,unit) + use const_and_precisions, only : pi,vc=>ccgs_ + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: file_beam + real(wp_), intent(out) :: fGHz,x00,y00,z00 + real(wp_), intent(out) :: wcsi,weta,rcicsi,rcieta,phir,phiw + integer, intent(in), optional :: unit +! local variables + integer :: u + real(wp_) :: ak0,zrcsi,zreta,w0csi,w0eta,d0csi,d0eta + + if (present(unit)) then + u=unit + else + u = get_free_unit() + end if + open(unit=u,file=trim(file_beam),status='OLD',action='READ') + +! fghz wave frequency (GHz) + read(u,*) fGHz +! x00,y00,z00 coordinates of launching point in cm + read(u,*) x00, y00, z00 +! beams parameters in local reference system +! w0 -> waist, d0 -> waist distance from launching point +! phiw angle of spot ellipse + read(u,*) w0csi,w0eta,d0csi,d0eta,phiw + close(u) + + ak0=2.0e9_wp_*pi*fghz/vc + zrcsi=0.5_wp_*ak0*w0csi**2 + zreta=0.5_wp_*ak0*w0eta**2 + + wcsi=w0csi*sqrt(1.0_wp_+(d0csi/zrcsi)**2) + weta=w0eta*sqrt(1.0_wp_+(d0eta/zreta)**2) + rcicsi=-d0csi/(d0csi**2+zrcsi**2) + rcieta=-d0eta/(d0eta**2+zreta**2) + phir=phiw + + end subroutine read_beam0 + + + + subroutine read_beam1(file_beam,alpha0,beta0,fghz,x00,y00,z00, & + wcsi,weta,rcicsi,rcieta,phiw,phir,unit) + use const_and_precisions, only : pi,vc=>ccgs_ + use simplespline, only : spli, difcs + use utils, only : get_free_unit,locate + implicit none +! arguments + character(len=*), intent(in) :: file_beam + real(wp_), intent(in) :: alpha0 + real(wp_), intent(out) :: fghz,x00,y00,z00,beta0 + real(wp_), intent(out) :: wcsi,weta,rcicsi,rcieta,phir,phiw + integer, intent(in), optional :: unit +! local variables + integer :: u,ierr,iopt,ier,nisteer,i,k,ii + real(wp_) :: steer,dal + real(wp_), dimension(:), allocatable :: alphastv,betastv,x00v,y00v, & + z00v,waist1v,waist2v,rci1v,rci2v,phi1v,phi2v, & + cbeta,cx0,cy0,cz0,cwaist1,cwaist2, & + crci1,crci2,cphi1,cphi2 + + if (present(unit)) then + u=unit + else + u = get_free_unit() + end if + open(unit=u,file=file_beam,status='OLD',action='READ') + + read(u,*) fghz + + read(u,*) nisteer + + allocate(alphastv(nisteer),betastv(nisteer),waist1v(nisteer), & + waist2v(nisteer),rci1v(nisteer),rci2v(nisteer), & + phi1v(nisteer),phi2v(nisteer),x00v(nisteer), & + y00v(nisteer),z00v(nisteer),cbeta(4*nisteer), & + cx0(4*nisteer),cy0(4*nisteer),cz0(4*nisteer), & + cwaist1(4*nisteer),cwaist2(4*nisteer),crci1(4*nisteer), & + crci2(4*nisteer),cphi1(4*nisteer),cphi2(4*nisteer), & + stat=ierr) + if (ierr/=0) then + close(u) + deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v, & + phi1v,phi2v,x00v,y00v,z00v,cbeta, & + cx0,cy0,cz0,cwaist1,cwaist2,crci1,crci2,cphi1,cphi2) + write(*,*) 'cannot allocate arrays for beam data' + stop + end if + + do i=1,nisteer + read(u,*) steer,alphastv(i),betastv(i),x00v(i),y00v(i),z00v(i), & + waist1v(i),waist2v(i),rci1v(i),rci2v(i),phi1v(i),phi2v(i) + end do + close(u) +! initial beam data measured in mm -> transformed to cm + x00v = 0.1_wp_*x00v + y00v = 0.1_wp_*y00v + z00v = 0.1_wp_*z00v + waist1v = 0.1_wp_*waist1v + waist2v = 0.1_wp_*waist2v + rci1v = 10._wp_*rci1v + rci2v = 10._wp_*rci2v + + 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) + + if((alpha0 > alphastv(1)).and.(alpha0 < alphastv(nisteer))) then + call locate(alphastv,nisteer,alpha0,k) + dal=alpha0-alphastv(k) + beta0=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 + write(*,*) ' alpha0 outside table range !!!' + if(alpha0 >= alphastv(nisteer)) ii=nisteer + if(alpha0 <= alphastv(1)) ii=1 + beta0=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 + + deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v, & + phi1v,phi2v,x00v,y00v,z00v,cbeta, & + cx0,cy0,cz0,cwaist1,cwaist2,crci1,crci2,cphi1,cphi2) + + end subroutine read_beam1 + + + subroutine read_beam2(file_beam,beamid,alpha0,beta0,fghz,iox,x00,y00,z00, & + wcsi,weta,rcicsi,rcieta,phiw,phir,unit) + use utils, only : get_free_unit, intlin, locate + use reflections, only : inside + use dierckx, only : curfit, splev, surfit, bispev + implicit none + character(len=*), intent(in) :: file_beam + integer, intent(in) :: beamid + real(wp_), intent(inout) :: alpha0,beta0 + real(wp_), intent(out) :: fghz,x00,y00,z00, wcsi,weta,rcicsi,rcieta,phir,phiw + integer, intent(out) :: iox + integer, intent(in), optional :: unit + + character(len=20) :: beamname + integer :: u + integer :: i, ier, nisteer, fdeg, jumprow, nbeam, nalpha, nbeta + integer :: iopt, incheck, nxcoord, nycoord, nxest, nyest, lwrk, kwrk + integer :: nxwaist1, nywaist1, nxwaist2, nywaist2, nxrci1, nyrci1, nxrci2 + integer :: nyrci2, nxphi1, nyphi1, nxphi2, nyphi2, nxx0, nyx0, nxy0, nyy0 + integer :: nxz0, nyz0, kx, ky, ii, npolyg, nmax, lwrk2, in + integer :: nxycoord + integer, DIMENSION(:), ALLOCATABLE :: iwrk + real(wp_) :: alphast,betast, waist1, waist2, rci1, rci2, phi1, phi2 + real(wp_) :: fp, minx, maxx, miny, maxy, eps, xcoord0, ycoord0 + real(wp_), DIMENSION(:), ALLOCATABLE :: x00v, y00v, z00v, alphastv, & + betastv, waist1v, waist2v, rci1v, rci2v, phi1v, phi2v, xcoord, & + ycoord, wrk, txwaist1, tywaist1, txwaist2, tywaist2, & + txrci1, tyrci1, txrci2, tyrci2, txphi1, typhi1, txphi2, typhi2, & + txx0, tyx0, txy0, tyy0, txz0, tyz0, txycoord, cycoord, cwaist1, & + cwaist2, crci1, crci2, cphi1,cphi2, cx0, cy0, cz0, w, wrk2, & + xpolyg, ypolyg, xpolygA, ypolygA, xpolygB, ypolygB, xpolygC, & + ypolygC, xpolygD, ypolygD + real(wp_), DIMENSION(4) :: xvert, yvert + real(wp_), dimension(1) :: fi + integer, parameter :: kspl=1 + real(wp_), parameter :: sspl=0.01_wp_ + + if (present(unit)) then + u=unit + else + u = get_free_unit() + end if + open(unit=u,file=file_beam,status='OLD',action='READ') +!======================================================================================= +! # of beams + read(u,*) nbeam +! +! unused beams' data + jumprow=0 +! c==================================================================================== + do i=1,beamid-1 + read(u,*) beamname, iox, fghz, nalpha, nbeta + jumprow = jumprow+nalpha*nbeta + end do +! c==================================================================================== +! +! beam of interest + read(u,*) beamname, iox, fghz, nalpha, nbeta +! +! c==================================================================================== +! unused beams' data grids + do i=1,(nbeam - beamid) + read(u,*) beamname + end do + do i=1,jumprow + read(u,*) alphast,betast,x00,y00,z00,waist1,waist2,rci1,rci2,phi1,phi2 + end do +! c==================================================================================== +! +! # of elements in beam data grid + nisteer = nalpha*nbeta +! + allocate(alphastv(nisteer),betastv(nisteer),waist1v(nisteer), & + waist2v(nisteer),rci1v(nisteer),rci2v(nisteer),phi1v(nisteer), & + phi2v(nisteer),x00v(nisteer),y00v(nisteer),z00v(nisteer), & + xcoord(nisteer),ycoord(nisteer)) +! +! c==================================================================================== +! beam data grid reading + do i=1,nisteer + read(u,*) alphast,betast,x00,y00,z00,waist1,waist2,rci1,rci2,phi1,phi2 +! +! initial beam data (x00, y00, z00) are measured in mm -> transformed to cm + x00v(i)=0.1d0*x00 + y00v(i)=0.1d0*y00 + z00v(i)=0.1d0*z00 + alphastv(i)=alphast + betastv(i)=betast + waist1v(i)=0.1d0*waist1 + rci1v(i)=1.0d1*rci1 + waist2v(i)=0.1d0*waist2 + rci2v(i)=1.0d1*rci2 + phi1v(i)=phi1 + phi2v(i)=phi2 + end do + close(u) +! c==================================================================================== +! +! fdeg = 0 alpha, beta free variables +! 1 alpha free variable +! 2 beta free variable +! 3 no free variables + fdeg = 2*(1/nalpha) + 1/nbeta + +!####################################################################################### +! +! no free variables + if(fdeg.eq.3) then + alpha0=alphastv(1) + beta0=betastv(1) + x00=x00v(1) + y00=y00v(1) + z00=z00v(1) + wcsi=waist1v(1) + weta=waist2v(1) + rcicsi=rci1v(1) + rcieta=rci2v(1) + phiw=phi1v(1) + phir=phi2v(1) + return + end if +!####################################################################################### +! +! +!####################################################################################### + if(fdeg.eq.2) then +! beta = independent variable +! alpha = dependent variable + xcoord = betastv + ycoord = alphastv + xcoord0 = beta0 + ycoord0 = alpha0 + kx=min(nbeta-1,kspl) +! c==================================================================================== + else +! c==================================================================================== +! alpha = independent variable +! beta = dependent/independent (fdeg = 1/0) + xcoord = alphastv + ycoord = betastv + xcoord0 = alpha0 + ycoord0 = beta0 + nxcoord = nalpha + nycoord = nbeta + kx=min(nalpha-1,kspl) + ky=min(nbeta-1,kspl) + end if +!####################################################################################### +! + iopt = 0 + incheck = 0 +! +!####################################################################################### + if(fdeg.ne.0) then + nxest = kx + nxcoord + 1 + lwrk = (nxcoord*(kx+1)+nxest*(7+3*kx)) + kwrk = nxest + allocate(cycoord(nxest), txycoord(nxest), cwaist1(nxest), & + txwaist1(nxest), cwaist2(nxest), txwaist2(nxest), & + crci1(nxest), txrci1(nxest), crci2(nxest), txrci2(nxest), & + cphi1(nxest), txphi1(nxest), cphi2(nxest), txphi2(nxest), & + cx0(nxest), txx0(nxest), cy0(nxest), txy0(nxest), & + cz0(nxest), txz0(nxest), w(nxcoord), wrk(lwrk), iwrk(kwrk)) +! + w = 1.d0 +! +! 2D interpolation + call curfit(iopt,nxcoord,xcoord,ycoord,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxycoord, & + txycoord,cycoord,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,waist1v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxwaist1, & + txwaist1,cwaist1,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,waist2v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxwaist2, & + txwaist2,cwaist2,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,rci1v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxrci1, & + txrci1,crci1,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,rci2v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxrci2, & + txrci2,crci2,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,phi1v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxphi1, & + txphi1,cphi1,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,phi2v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxphi2, & + txphi2,cphi2,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,x00v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxx0, & + txx0,cx0,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,y00v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxy0, & + txy0,cy0,fp,wrk,lwrk,iwrk,ier) +! + call curfit(iopt,nxcoord,xcoord,z00v,w, & + xcoord(1),xcoord(nxcoord),kx,sspl,nxest,nxz0, & + txz0,cz0,fp,wrk,lwrk,iwrk,ier) +! +! check if xcoord0 is out of table range +! incheck = 1 inside / 0 outside + if(xcoord0.gt.xcoord(1).and.xcoord0.lt.xcoord(nisteer)) incheck=1 +! c==================================================================================== + else +! c==================================================================================== + npolyg = 2*(nxcoord+nycoord-2) + minx = minval(xcoord) + maxx = maxval(xcoord) + miny = minval(ycoord) + maxy = maxval(ycoord) + nxest = kx + 1 + int(sqrt(nisteer/2.)) + nyest = ky + 1 + int(sqrt(nisteer/2.)) + nmax = max(nxest,nyest) + eps = 10.**(-8) + lwrk = (nmax-2)**2*(7*nmax-2)+18*nmax+8*nisteer-19 + lwrk2 = (nmax-2)**2*(4*nmax-1)+4*nmax-2 + kwrk = nisteer+(nmax-3)*(nmax-3) + allocate(cwaist1(nxest*nyest), txwaist1(nmax), tywaist1(nmax), & + cwaist2(nxest*nyest), txwaist2(nmax), tywaist2(nmax), & + crci1(nxest*nyest), txrci1(nmax), tyrci1(nmax), & + crci2(nxest*nyest), txrci2(nmax), tyrci2(nmax), & + cphi1(nxest*nyest), txphi1(nmax), typhi1(nmax), & + cphi2(nxest*nyest), txphi2(nmax), typhi2(nmax), & + cx0(nxest*nyest), txx0(nmax), tyx0(nmax), & + cy0(nxest*nyest), txy0(nmax), tyy0(nmax), & + cz0(nxest*nyest), txz0(nmax), tyz0(nmax), & + wrk(lwrk), wrk2(lwrk2), iwrk(kwrk), & + xpolyg(npolyg), ypolyg(npolyg), w(nisteer)) +! + w = 1.d0 +! +! 3D interpolation + call surfit(iopt,nisteer,xcoord,ycoord,waist1v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxwaist1,txwaist1,nywaist1,tywaist1,cwaist1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,waist2v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxwaist2,txwaist2,nywaist2,tywaist2,cwaist2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,rci1v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxrci1,txrci1,nyrci1,tyrci1,crci1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,rci2v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxrci2,txrci2,nyrci2,tyrci2,crci2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,phi1v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxphi1,txphi1,nyphi1,typhi1,cphi1,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,phi2v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxphi2,txphi2,nyphi2,typhi2,cphi2,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,x00v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxx0,txx0,nyx0,tyx0,cx0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,y00v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxy0,txy0,nyy0,tyy0,cy0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! + call surfit(iopt,nisteer,xcoord,ycoord,z00v,w, & + minx,maxx,miny,maxy,kx,ky,sspl,nxest,nyest,nmax,eps, & + nxz0,txz0,nyz0,tyz0,cz0,fp,wrk,lwrk,wrk2,lwrk2,iwrk,kwrk,ier) +! data range polygon + xpolyg(1:nxcoord) = xcoord(1:nxcoord) + ypolyg(1:nxcoord) = ycoord(1:nxcoord) +! +! c==================================================================================== + do i=1,nycoord-2 + xpolyg(nxcoord+i) = xcoord((i+1)*nxcoord) + xpolyg(2*nxcoord+nycoord-2+i) = xcoord((nycoord-i-1)*nxcoord+1) + ypolyg(nxcoord+i) = ycoord((i+1)*nxcoord) + ypolyg(2*nxcoord+nycoord-2+i) = ycoord((nycoord-i-1)*nxcoord+1) + end do +! c==================================================================================== + do i=1,nxcoord + xpolyg(nxcoord+nycoord-2+i) = xcoord(nxcoord*nycoord-i+1) + ypolyg(nxcoord+nycoord-2+i) = ycoord(nxcoord*nycoord-i+1) + end do +! c==================================================================================== +! +! check if (xcoord0, ycoord0) is out of table range +! incheck = 1 inside / 0 outside + if(inside(xpolyg,ypolyg,npolyg,xcoord0,ycoord0)) incheck = 1 + end if + deallocate(wrk,iwrk) +!####################################################################################### +! +! +!####################################################################################### + if(fdeg.ne.0) then +! c==================================================================================== + if(incheck.eq.1) then + call splev(txycoord,nxycoord,cycoord,kx,(/xcoord0/),fi,1,ier) + ycoord0=fi(1) + call splev(txwaist1,nxwaist1,cwaist1,kx,(/xcoord0/),fi,1,ier) + wcsi=fi(1) + call splev(txwaist2,nxwaist2,cwaist2,kx,(/xcoord0/),fi,1,ier) + weta=fi(1) + call splev(txrci1,nxrci1,crci1,kx,(/xcoord0/),fi,1,ier) + rcicsi=fi(1) + call splev(txrci2,nxrci2,crci2,kx,(/xcoord0/),fi,1,ier) + rcieta=fi(1) + call splev(txphi1,nxphi1,cphi1,kx,(/xcoord0/),fi,1,ier) + phiw=fi(1) + call splev(txphi2,nxphi2,cphi2,kx,(/xcoord0/),fi,1,ier) + phir=fi(1) + call splev(txx0,nxx0,cx0,kx,(/xcoord0/),fi,1,ier) + x00=fi(1) + call splev(txy0,nxy0,cy0,kx,(/xcoord0/),fi,1,ier) + y00=fi(1) + call splev(txz0,nxz0,cz0,kx,(/xcoord0/),fi,1,ier) + z00=fi(1) +! c---------------------------------------------------------------------------------- + else +! c---------------------------------------------------------------------------------- + if(xcoord0.ge.xcoord(nisteer)) ii=nisteer + if(xcoord0.le.xcoord(1)) ii=1 +! + xcoord0=xcoord(ii) + ycoord0=ycoord(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 +! c==================================================================================== + else +! c==================================================================================== + if(incheck.eq.0) then + allocate(xpolygA(nxcoord), ypolygA(nxcoord), xpolygC(nxcoord), & + ypolygC(nxcoord), xpolygB(nycoord), ypolygB(nycoord), & + xpolygD(nycoord), ypolygD(nycoord)) +! coordinates of vertices v1,v2,v3,v4 + xvert(1) = xpolyg(1) + xvert(2) = xpolyg(nxcoord) + xvert(3) = xpolyg(nxcoord+nycoord-1) + xvert(4) = xpolyg(2*nxcoord+nycoord-2) + yvert(1) = ypolyg(1) + yvert(2) = ypolyg(nxcoord) + yvert(3) = ypolyg(nxcoord+nycoord-1) + yvert(4) = ypolyg(2*nxcoord+nycoord-2) +! coordinates of side A,B,C,D + xpolygA = xpolyg(1:nxcoord) + ypolygA = ypolyg(1:nxcoord) + xpolygB = xpolyg(nxcoord:nxcoord+nycoord-1) + ypolygB = ypolyg(nxcoord:nxcoord+nycoord-1) + xpolygC = xpolyg(nxcoord+nycoord-1:2*nxcoord+nycoord-2) + ypolygC = ypolyg(nxcoord+nycoord-1:2*nxcoord+nycoord-2) + xpolygD(1:nycoord-1) = xpolyg(2*nxcoord+nycoord-2:npolyg) + xpolygD(nycoord) = xpolyg(1) + ypolygD(1:nycoord-1) = ypolyg(2*nxcoord+nycoord-2:npolyg) + ypolygD(nycoord) = ypolyg(1) +! c---------------------------------------------------------------------------------- +! search for position of xcoord0, ycoord0 with respect to (alpha,beta) data grid +! +! | | +! (6) (5) (4) +! | | +! _ _ _ v4 _________________v3_ _ _ _ +! | C | (1)->(8) outside regions +! | | +! (7) D | | B (3) v1->v4 grid vertices +! | | +! _ _ _ _ |_________________| _ _ _ _ A-D grid sides +! v1 A v2 +! | | +! (8) (1) (2) +! | | +! + if(xcoord0.gt.xvert(1).and.xcoord0.lt.xvert(2).and.ycoord0.le.maxval(ypolygA)) then + in=1 + else if(ycoord0.gt.yvert(2).and.ycoord0.lt.yvert(3).and.xcoord0.ge.minval(xpolygB)) then + in=3 + else if(xcoord0.lt.xvert(3).and.xcoord0.gt.xvert(4).and.ycoord0.ge.minval(ypolygC)) then + in=5 + else if(ycoord0.lt.yvert(4).and.ycoord0.gt.yvert(1).and.xcoord0.le.maxval(xpolygD)) then + in=7 + else if(xcoord0.ge.xvert(2).and.ycoord0.le.yvert(2)) then + in=2 + else if(xcoord0.ge.xvert(3).and.ycoord0.ge.yvert(3)) then + in=4 + else if(xcoord0.le.xvert(4).and.ycoord0.ge.yvert(4)) then + in=6 + else if(xcoord0.le.xvert(1).and.ycoord0.le.yvert(1)) then + in=8 + endif +! c---------------------------------------------------------------------------------- +! +! c---------------------------------------------------------------------------------- +! (xcoord0,ycoord0) is set to its nearest point on (alpha, beta) grid border +! depending on the region +! 1: xcoord0 unchanged, ycoord0 moved on side A +! 3: xcoord0 moved on side B, ycoord0 unchanged +! 5: xcoord0 unchanged, ycoord0 moved on side C +! 7: xcoord0 moved on side D, ycoord0 unchanged +! 2,4,6,8: (xcoord0,ycoord0) set to nearest vertex coordinates +! in 1,3,5,7 incheck is set back to 1 to evaluate x00,y00,z00,waist,rci,phi in +! new (xcoord0,ycoord0) +! in 2,4,6,8 incheck remains 0 and x00,y00,z00,waist,rci,phi values at the +! (xcoord0,ycoord0) vertex are used + alpha0 = xcoord0 + beta0 = ycoord0 + SELECT CASE (in) + CASE (1) + write(*,*) ' beta0 outside table range !!!' +! locate position of xcoord0 with respect to x coordinates of side A + call locate(xpolygA,nxcoord,xcoord0,ii) +! find corresponding y value on side A for xcoord position + call intlin(xpolygA(ii),ypolygA(ii),xpolygA(ii+1),ypolygA(ii+1),xcoord0,ycoord0) + incheck = 1 + CASE (2) + write(*,*) ' alpha0 and beta0 outside table range !!!' +! xcoord0, ycoord0 set + xcoord0 = xvert(2) + ycoord0 = yvert(2) + ii = nxcoord !indice per assegnare valori waist, rci, phi + CASE (3) + write(*,*) ' alpha0 outside table range !!!' + call locate(ypolygB,nycoord,ycoord0,ii) + call intlin(ypolygB(ii),xpolygB(ii),ypolygB(ii+1),xpolygB(ii+1),ycoord0,xcoord0) + incheck = 1 + CASE (4) + write(*,*) ' alpha0 and beta0 outside table range !!!' + xcoord0 = xvert(3) + ycoord0 = yvert(3) + ii = nxcoord+nycoord-1 + CASE (5) + write(*,*) ' beta0 outside table range !!!' + call locate(xpolygC,nxcoord,xcoord0,ii) + call intlin(xpolygC(ii+1),ypolygC(ii+1),xpolygC(ii),ypolygC(ii),xcoord0,ycoord0) + incheck = 1 + CASE (6) + write(*,*) ' alpha0 and beta0 outside table range !!!' + xcoord0 = xvert(4) + ycoord0 = yvert(4) + ii = 2*nxcoord+nycoord-2 + CASE (7) + write(*,*) ' alpha0 outside table range !!!' + call locate(ypolygD,nycoord,ycoord0,ii) + call intlin(ypolygD(ii),xpolygD(ii),ypolygD(ii+1),xpolygD(ii+1),ycoord0,xcoord0) + incheck = 1 + CASE (8) + write(*,*) ' alpha0 and beta0 outside table range !!!!' + xcoord0 = xvert(1) + ycoord0 = yvert(1) + ii = 1 + END SELECT +! c---------------------------------------------------------------------------------- +! + deallocate(xpolygA, ypolygA, xpolygC, ypolygC, xpolygB, ypolygB, xpolygD, ypolygD) + end if +! c==================================================================================== +! +! c==================================================================================== + if(incheck.eq.1) then + lwrk = 2*(kx+ky+2) + kwrk = 4 + allocate(wrk(lwrk),iwrk(kwrk)) + call bispev(txwaist1,nxwaist1,tywaist1,nywaist1,cwaist1, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + wcsi=fi(1) + call bispev(txwaist2,nxwaist2,tywaist2,nywaist2,cwaist2, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + weta=fi(1) + call bispev(txrci1,nxrci1,tyrci1,nyrci1,crci1, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + rcicsi=fi(1) + call bispev(txrci2,nxrci2,tyrci2,nyrci2,crci2, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + rcieta=fi(1) + call bispev(txphi1,nxphi1,typhi1,nyphi1,cphi1, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + phiw=fi(1) + call bispev(txphi2,nxphi2,typhi2,nyphi2,cphi2, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + phir=fi(1) + call bispev(txx0,nxx0,tyx0,nyx0,cx0, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + x00=fi(1) + call bispev(txy0,nxy0,tyy0,nyy0,cy0, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + y00=fi(1) + call bispev(txz0,nxz0,tyz0,nyz0,cz0, & + kx,ky,(/xcoord0/),1,(/ycoord0/),1,fi,wrk,lwrk,iwrk,kwrk,ier) + z00=fi(1) + deallocate(wrk,iwrk) +! c---------------------------------------------------------------------------------- + else +! c---------------------------------------------------------------------------------- + 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 +! c==================================================================================== + end if +!####################################################################################### +! + if(fdeg.ne.0) then + deallocate(cycoord, txycoord, cwaist1, txwaist1, cwaist2, & + txwaist2, crci1, txrci1, crci2, txrci2, cphi1, txphi1, & + cphi2, txphi2, cx0, txx0, cy0, txy0, cz0, txz0, w) + else + deallocate(cwaist1, txwaist1, tywaist1, cwaist2, txwaist2, tywaist2, & + crci1, txrci1, tyrci1, crci2, txrci2, tyrci2, & + cphi1, txphi1, typhi1, cphi2, txphi2, typhi2, & + cx0, txx0, tyx0, cy0, txy0, tyy0, cz0, txz0, tyz0, & + wrk2, xpolyg, ypolyg, w) + end if +! +!####################################################################################### +! set correct values for alpha, beta + if(fdeg.eq.2) then + alpha0 = ycoord0 + beta0 = xcoord0 + else + alpha0 = xcoord0 + beta0 = ycoord0 + end if +!####################################################################################### + deallocate(alphastv,betastv,waist1v,waist2v,rci1v,rci2v,phi1v, & + phi2v,x00v,y00v,z00v,xcoord,ycoord) +! + end subroutine read_beam2 + + + subroutine launchangles2n(alpha,beta,xv,anv) + use const_and_precisions, only : degree + implicit none +! arguments + real(wp_), intent(in) :: alpha,beta,xv(3) + real(wp_), intent(out) :: anv(3) +! local variables + real(wp_) :: r,anr,anphi,a,b + + r=sqrt(xv(1)**2+xv(2)**2) +! phi=atan2(y,x) + print'(a,2f8.3)','alpha0, beta0 = ',alpha,beta + print'(a,4f8.3)','x00, y00, R00, z00 = ',xv(1:2),r,xv(3) + print*,' ' + a = degree*alpha + b = degree*beta +! +! angles alpha, beta in a local reference system as proposed by Gribov et al +! + anr = -cos(b)*cos(a) + anphi = sin(b) +! anx = -cos(b)*cos(a) +! any = sin(b) + + anv(1) = (anr*xv(1) - anphi*xv(2))/r ! = anx + anv(2) = (anr*xv(2) + anphi*xv(1))/r ! = any +! anr = (anx*xv(1) + any*xv(2))/r +! anphi = (any*xv(1) - anx*xv(2))/r + + anv(3) =-cos(b)*sin(a) ! = anz + end subroutine launchangles2n + + subroutine xgygcoeff(fghz,ak0,bres,xgcn) + use const_and_precisions, only : qe=>ecgs_,me=>mecgs_,vc=>ccgs_,pi,wce1_ + implicit none +! arguments + real(wp_), intent(in) :: fghz + real(wp_), intent(out) :: ak0,bres,xgcn +! local variables + real(wp_) :: omega + + omega=2.0e9_wp_*pi*fghz ! [rad/s] + ak0=omega/vc ! [rad/cm] +! +! yg=btot/bres +! + bres=omega/wce1_ ! [T] +! +! xg=xgcn*dens19 +! + xgcn=4.0e13_wp_*pi*qe**2/(me*omega**2) ! [10^-19 m^3] + end subroutine xgygcoeff +end module beams diff --git a/src/conical.f90 b/src/conical.f90 new file mode 100644 index 0000000..fc9c606 --- /dev/null +++ b/src/conical.f90 @@ -0,0 +1,853 @@ +module conical + + use const_and_precisions, only : wp_ + implicit none + +contains + + function fconic(x,tau,m) +! +! this function subprogram computes the conical functions of the +! first kind P sub(-1/2 + i*tau) (x) for m = 0 and m = 1. +! Ref. in Kolbig, Comp. Phys. Commun. 23 (1981) 51 +! + implicit none + real(wp_), intent(in) :: x, tau + integer, intent(in) :: m + real(wp_) :: fconic + real(wp_) :: t(7),h(9),v(11) + real(wp_) :: aa,a0,a1,a2,a3,a4,a5,a6,b0,b1,fm,fn,fn1,r1,r2,s,s0,s1 + real(wp_) :: x1,y,y2,y3,z + integer :: jp,j,n + real(wp_), parameter :: rpi=1.7724538509055_wp_,pi2=0.63661977236758_wp_ + real(wp_), parameter :: eps=1.0e-14_wp_ + integer, parameter :: nout=2,nmax=200 +! + complex(wp_) a,b,c,ti,r,rr,q,u,u0,u1,u2,uu + complex(wp_) v0,v1,v2,vv,w(19) +! + logical lm0,lm1,lta + + fconic=0.0_wp_ + lm0=m == 0 + lm1=m == 1 + if(.not.(lm0 .or. lm1)) then + write(nout,"(1x,'fconic ... illegal value for m = ',i4)") m + return + end if + fm=m + fconic=1.0_wp_-fm + if(x == 1.0_wp_) return +! + fconic=0.0_wp_ + if(tau == 0.0_wp_ .and. abs(x-1.0_wp_) > 0.01_wp_) then + if(x > 1.0_wp_) then + y=sqrt((x-1.0_wp_)/(x+1.0_wp_)) + z=ellick(y) + s=sqrt(0.5_wp_*(x+1.0_wp_)) + if(lm0) fconic=pi2*z/s + if(lm1) fconic=pi2*s*(ellice(y)-z)/sqrt(x**2-1.0_wp_) + return + else + y=sqrt(0.5_wp_*(1.0_wp_-x)) + z=ellick(y) + if(lm0) fconic=pi2*z + if(lm1) fconic=pi2*(ellice(y)-0.5_wp_*(1.0_wp_+x)*z)/ & + sqrt(1.0_wp_-x**2) + return + end if + else + ti=cmplx(0._wp_,tau,wp_) +! + if((-1._wp_ < x .and. x <= 0.0_wp_).or. & + (0.0_wp_ < x .and. x <= 0.1_wp_ .and.tau<= 17.0_wp_).or. & + (0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 5.0_wp_)) then + lta=tau <= 10.0_wp_ + x1=x**2 + a=0.5_wp_*(0.5_wp_-fm-ti) + b=0.5_wp_*(0.5_wp_-fm+ti) + c=0.5_wp_ + jp=30 + else if((0.1_wp_ < x .and. x <= 0.2_wp_ .and.tau<= 17.0_wp_) & + .or.(0.2_wp_ < x .and. x <= 1.5_wp_ .and.tau<= 20.0_wp_)) & + then + lta=x > 1.0_wp_ .or. x <= 1.0_wp_ .and. tau <= 5.0_wp_ + x1=(1.0_wp_-x)/2._wp_ + a=0.5_wp_+fm-ti + b=0.5_wp_+fm+ti + c=fm+1.0_wp_ + jp=32 + else if(1.5_wp_ < x .and. tau <= max(20.0_wp_,x)) then + lta=.true. + x1=1.0_wp_/x**2 + u=exp((-0.5_wp_+ti)*log(2.0_wp_*x)+clogam(1.0_wp_+ti) & + -clogam(1.5_wp_-fm+ti)) + a=0.5_wp_*(0.5_wp_-fm-ti) + b=0.5_wp_*(1.5_wp_-fm-ti) + c=1.0_wp_-ti + jp=33 + else + if(x > 1.0_wp_) then + s=sqrt(x**2-1.0_wp_) + t(1)=log(x+s) + h(1)=tau*t(1) + b0=besj0l(h(1)) + b1=besj1l(h(1)) + z=1.0_wp_ + else + s=sqrt(1.0_wp_-x**2) + t(1)=acos(x) + h(1)=tau*t(1) + b0=besi0(h(1)) + b1=besi1(h(1)) + z=-1.0_wp_ + end if + h(1)=t(1)*x/s + v(1)=tau + do j = 2,7 + t(j)=t(j-1)*t(1) + h(j)=h(j-1)*h(1) + end do + do j = 2,11 + v(j)=v(j-1)*v(1) + end do +! + if(lm1) then + aa=-1.0_wp_ + a0=3.0_wp_*(1.0_wp_-h(1))/(8.0_wp_*t(1)) + a1=(-15.0_wp_*h(2)+6.0_wp_*h(1)+9.0_wp_+z*8.0_wp_*t(2))/ & + (128.0_wp_*t(2)) + a2=3.0_wp_*(-35.0_wp_*h(3)-15.0_wp_*h(2)+15.0_wp_*h(1)+35.0_wp_ & + +z*t(2)*(32.0_wp_*h(1)+8.0_wp_))/(1024.0_wp_*t(3)) + a3=(-4725.0_wp_*h(4)-6300.0_wp_*h(3)-3150.0_wp_*h(2)+3780.0_wp_*h(1) & + +10395.0_wp_-1216.0_wp_*t(4)+z*t(2)*(6000.0_wp_*h(2) & + +5760.0_wp_*h(1)+1680.0_wp_)) /(32768.0_wp_*t(4)) + a4=7.0_wp_*(-10395.0_wp_*h(5)-23625.0_wp_*h(4)-28350.0_wp_*h(3) & + -14850.0_wp_*h(2)+19305.0_wp_*h(1)+57915.0_wp_ & + -t(4)*(6336.0_wp_*h(1)+6080.0_wp_)+z*t(2)*(16800.0_wp_*h(3) & + +30000.0_wp_*h(2)+25920.0_wp_*h(1)+7920.0_wp_))/ & + (262144.0_wp_*t(5)) + a5=(-2837835.0_wp_*h(6)-9168390.0_wp_*h(5)-16372125.0_wp_*h(4) & + -18918900*h(3) -10135125.0_wp_*h(2)+13783770.0_wp_*h(1) & + +43648605.0_wp_-t(4)*(3044160.0_wp_*h(2)+5588352.0_wp_*h(1) & + +4213440.0_wp_)+z*t(2)*(5556600.0_wp_*h(4)+14817600.0_wp_*h(3) & + +20790000.0_wp_*h(2)+17297280.0_wp_*h(1)+5405400.0_wp_ & + +323072.0_wp_*t(4)))/ (4194304.0_wp_*t(6)) + a6=0.0_wp_ + else + aa=0.0_wp_ + a0=1.0_wp_ + a1=(h(1)-1.0_wp_)/(8.0_wp_*t(1)) + a2=(9.0_wp_*h(2)+6.0_wp_*h(1)-15.0_wp_-z*8.0_wp_*t(2))/ & + (128.0_wp_*t(2)) + a3=5.0_wp_*(15.0_wp_*h(3)+27.0_wp_*h(2)+21.0_wp_*h(1)-63.0_wp_ & + -z*t(2)*(16.0_wp_*h(1)+24.0_wp_))/(1024.0_wp_*t(3)) + a4=7.0_wp_*(525.0_wp_*h(4)+1500.0_wp_*h(3)+2430.0_wp_*h(2) & + +1980.0_wp_*h(1)-6435.0_wp_+192.0_wp_*t(4)-z*t(2)* & + (720.0_wp_*h(2)+1600.0_wp_*h(1)+2160.0_wp_))/(32768.0_wp_*t(4)) + a5=21.0_wp_*(2835.0_wp_*h(5)+11025.0_wp_*h(4)+24750.0_wp_*h(3) & + +38610.0_wp_*h(2)+32175.0_wp_*h(1)-109395.0_wp_+t(4) & + *(1984.0_wp_*h(1)+4032.0_wp_)-z*t(2) & + *(4800.0_wp_*h(3)+15120.0_wp_*h(2)+26400.0_wp_*h(1)+34320.0_wp_)) & + /(262144.0_wp_*t(5)) + a6=11.0_wp_*(218295.0_wp_*h(6)+1071630.0_wp_*h(5)+3009825.0_wp_*h(4) & + +6142500.0_wp_*h(3)+9398025.0_wp_*h(2)+7936110.0_wp_*h(1) & + -27776385.0_wp_+t(4)*(254016.0_wp_*h(2) & + +749952.0_wp_*h(1)+1100736.0_wp_)-z*t(2)*(441000.0_wp_*h(4) & + +1814400.0_wp_*h(3)+4127760.0_wp_*h(2)+6552000.0_wp_*h(1) & + +8353800.0_wp_+31232.0_wp_*t(4)))/(4194304.0_wp_*t(6)) + end if + s0=a0+(-4.0_wp_*a3/t(1)+a4)/v(4)+(-192.0_wp_*a5/t(3) & + +144.0_wp_*a6/t(2))/v(8)+z*(-a2/v(2)+(-24.0_wp_*a4/t(2) & + +12.0_wp_*a5/t(1)-a6)/v(6)+(-1920.0_wp_*a6/t(4))/v(10)) + s1=a1/v(1)+(8.0_wp_*(a3/t(2)-a4/t(1))+a5)/v(5)+(384.0_wp_*a5/t(4) & + -768.0_wp_*a6/t(3))/v(9)+z*(aa*v(1)+(2.0_wp_*a2/t(1)-a3)/v(3) & + +(48.0_wp_*a4/t(3)-72.0_wp_*a5/t(2) & + +18.0_wp_*a6/t(1))/v(7)+(3840.0_wp_*a6/t(5))/v(11)) + fconic=sqrt(t(1)/s)*(b0*s0+b1*s1) + return + end if +! + do + if(lta) then + y=-x1 + y2=y**2 + y3=y**3 + w(1)=a+1.0_wp_ + w(2)=a+2.0_wp_ + w(3)=b+1.0_wp_ + w(4)=b+2.0_wp_ + w(5)=c+1.0_wp_ + 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.0_wp_+(w(11)/(2.0_wp_*w(5)))*y + w(13)=w(7)-6.0_wp_ + w(14)=w(7)+6.0_wp_ + w(15)=2.0_wp_-w(8) + w(16)=w(15)-2.0_wp_*w(7) +! + v0=1.0_wp_ + v1=1.0_wp_+(w(10)/(2.0_wp_*c))*y + v2=w(12)+(w(10)*w(11)/(12.0_wp_*w(6)))*y2 + u0=1.0_wp_ + u1=v1-w(9) + u2=v2-w(9)*w(12)+(w(8)*w(10)/(2.0_wp_*w(6)))*y2 +! + r=1.0_wp_ + n=2 + do + n=n+1 + if(n > nmax) then + write(nout,200) x,tau,m + return + end if + rr=r + fn=n + h(1)=fn-1.0_wp_ + h(2)=fn-2.0_wp_ + h(3)=fn-3.0_wp_ + h(4)=2.0_wp_*fn + h(5)=h(4)-3.0_wp_ + h(6)=2.0_wp_*h(5) + h(7)=4.0_wp_*(h(4)-1.0_wp_)*h(5) + h(8)=8.0_wp_*h(5)**2*(h(4)-5.0_wp_) + h(9)=3.0_wp_*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) +! + w(17)=1.0_wp_+((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))/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) < eps) exit + v0=v1 + v1=v2 + v2=vv + u0=u1 + u1=u2 + u2=uu + end do + else + r=1.0_wp_ + q=1.0_wp_ + do n = 1,nmax + fn=n + fn1=fn-1.0_wp_ + rr=r + q=q*x1*(a+fn1)*(b+fn1)/((c+fn1)*fn) + r=r+q + if(abs(r-rr) < eps) exit + end do + if (n > nmax) then + write(nout,200) x,tau,m + return + end if + end if + if (jp/=30) exit + r1=real(r)/abs(exp(clogam(a+0.5_wp_)))**2 + a=0.5_wp_*(1.5_wp_-fm-ti) + b=0.5_wp_*(1.5_wp_-fm+ti) + c=1.5_wp_ + jp=31 + end do + if (jp==31) then + r2=real(r)/abs(exp(clogam(a-0.5_wp_)))**2 + fconic=rpi*(r1-2.0_wp_*x*r2) + if(lm1) fconic=(2.0_wp_/sqrt(1.0_wp_-x1))*fconic + return + else if (jp==32) then + fconic=real(r) + if(.not.lm0) then + fconic=0.5_wp_*(tau**2+0.25_wp_)*sqrt(abs(x**2-1.0_wp_))*fconic + if(x > 1.0_wp_) fconic=-fconic + end if + return + else if (jp==33) then + fconic=2.0_wp_*real(u*r*(0.5_wp_-fm+ti)/ti)/rpi + if(lm1) fconic=fconic/sqrt(1.0_wp_-x1) + return + end if + end if +! + 200 format(1x,'fconic ... convergence difficulties for c function, x = ', & + e12.4,5x,'tau = ',e12.4,5x,'m = ',i5) +! + end function fconic + + function clogam(z) +! + implicit none + complex(wp_) :: clogam + complex(wp_), intent(in) :: z + complex(wp_) :: v,h,r + integer :: i,n + real(wp_) :: x,t,a,c,d,e,f + integer, parameter :: nout=2 + real(wp_), parameter :: pi=3.1415926535898_wp_ + real(wp_), dimension(10), parameter :: b= & + (/+8.3333333333333e-2_wp_, -2.7777777777778e-3_wp_, & + +7.9365079365079e-4_wp_, -5.9523809523810e-4_wp_, & + +8.4175084175084e-4_wp_, -1.9175269175269e-3_wp_, & + +6.4102564102564e-3_wp_, -2.9550653594771e-2_wp_, & + +1.7964437236883e-1_wp_, -1.3924322169059e+0_wp_/) +! + x=real(z) + t=aimag(z) + if(-abs(x) == aint(x) .and. t == 0.0_wp_) then + write(nout,'(1x,f20.2)') x + clogam=(0.0_wp_,0.0_wp_) + return + end if + f=abs(t) + v=cmplx(x,f,wp_) + if(x < 0.0_wp_) v=1.0_wp_-v + h=(0.0_wp_,0.0_wp_) + c=real(v) + if(c < 7.0_wp_) then + n=6-int(c) + h=v + d=aimag(v) + a=atan2(d,c) + do i = 1,n + c=c+1.0_wp_ + v=cmplx(c,d,wp_) + h=h*v + a=a+atan2(d,c) + end do + h=cmplx(0.5_wp_*log(real(h)**2+aimag(h)**2),a,wp_) + v=v+1.0_wp_ + end if + r=1.0_wp_/v**2 + clogam=0.91893853320467_wp_+(v-0.5_wp_)*log(v)-v+(b(1)+r*(b(2)+r*(b(3) & + +r*(b(4)+r*(b(5)+r*(b(6)+r*(b(7)+r*(b(8)+r*(b(9)+r*b(10)))))))))) & + /v-h + if(x < 0.0_wp_) then +! + a=aint(x)-1.0_wp_ + c=pi*(x-a) + d=pi*f + e=exp(-2.0_wp_*d) + f=sin(c) + e=d+0.5_wp_*log(e*f**2+0.25_wp_*(1.0_wp_-e)**2) + f=atan2(cos(c)*tanh(d),f)-a*pi + clogam=1.1447298858494_wp_-cmplx(e,f,wp_)-clogam +! + end if + if(t < 0.0_wp_) clogam=conjg(clogam) +! + end function clogam + + function ellick(xk) + implicit none + real(wp_), intent(in) :: xk + real(wp_) :: ellick, ellice + integer :: i + real(wp_) :: eta,pa,pb,pc,pd + real(wp_), dimension(10), parameter :: & + a=(/9.6573590280856e-2_wp_, 3.0885146271305e-2_wp_, & + 1.4938013532687e-2_wp_, 8.7898018745551e-3_wp_, & + 6.1796274460533e-3_wp_, 6.8479092826245e-3_wp_, & + 9.8489293221769e-3_wp_, 8.0030039806500e-3_wp_, & + 2.2966348983970e-3_wp_, 1.3930878570066e-4_wp_/), & + b=(/1.2499999999991e-1_wp_, 7.0312499739038e-2_wp_, & + 4.8828041906862e-2_wp_, 3.7377739758624e-2_wp_, & + 3.0124849012899e-2_wp_, 2.3931913323111e-2_wp_, & + 1.5530941631977e-2_wp_, 5.9739042991554e-3_wp_, & + 9.2155463496325e-4_wp_, 2.9700280966556e-5_wp_/), & + c=(/4.4314718056089e-1_wp_, 5.6805194567559e-2_wp_, & + 2.1831811676130e-2_wp_, 1.1569595745295e-2_wp_, & + 7.5950934225594e-3_wp_, 7.8204040609596e-3_wp_, & + 1.0770635039866e-2_wp_, 8.6384421736041e-3_wp_, & + 2.4685033304607e-3_wp_, 1.4946621757181e-4_wp_/), & + d=(/2.4999999999990e-1_wp_, 9.3749999721203e-2_wp_, & + 5.8593661255531e-2_wp_, 4.2717890547383e-2_wp_, & + 3.3478943665762e-2_wp_, 2.6145014700314e-2_wp_, & + 1.6804023346363e-2_wp_, 6.4321465864383e-3_wp_, & + 9.8983328462254e-4_wp_, 3.1859195655502e-5_wp_/) +! + if(abs(xk) >= 1.0_wp_) then + ellick=0.0_wp_ + return + end if + eta=1.0_wp_-xk**2 + pa=a(10) + do i = 1,9 + pa=pa*eta+a(10-i) + end do + pa=pa*eta + pb=b(10) + do i = 1,9 + pb=pb*eta+b(10-i) + end do + pb=pb*eta + ellick=1.3862943611199_wp_+pa-log(eta)*(0.5_wp_+pb) + return +! + entry ellice(xk) +! + if (abs(xk) >= 1.0_wp_) then + if (abs(xk) > 1.0_wp_) then + ellick=0.0_wp_ + else + ellick=1.0_wp_ + end if + return + end if + eta=1.0_wp_-xk**2 + pc=c(10) + do i = 1,9 + pc=pc*eta+c(10-i) + end do + pc=pc*eta + pd=d(10) + do i = 1,9 + pd=pd*eta+d(10-i) + end do + pd=pd*eta + ellick=1.0_wp_+pc-log(eta)*pd + end function ellick + + function besjy(x) + implicit none + real(wp_), intent(in) :: x + real(wp_) :: besjy,besj0l,besj1l + real(wp_) :: besy0,besy1 + logical :: l + real(wp_) :: v,f,a,b,p,q + integer, parameter :: nout=2 +! + entry besj0l(x) +! + l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 4 + 8 f=0.0625_wp_*x**2-2.0_wp_ + a = - 0.0000000000000008_wp_ + b = f * a + 0.0000000000000413_wp_ + a = f * b - a - 0.0000000000019438_wp_ + b = f * a - b + 0.0000000000784870_wp_ + a = f * b - a - 0.0000000026792535_wp_ + b = f * a - b + 0.0000000760816359_wp_ + a = f * b - a - 0.0000017619469078_wp_ + b = f * a - b + 0.0000324603288210_wp_ + a = f * b - a - 0.0004606261662063_wp_ + b = f * a - b + 0.0048191800694676_wp_ + a = f * b - a - 0.0348937694114089_wp_ + b = f * a - b + 0.1580671023320973_wp_ + a = f * b - a - 0.3700949938726498_wp_ + b = f * a - b + 0.2651786132033368_wp_ + a = f * b - a - 0.0087234423528522_wp_ + a = f * a - b + 0.3154559429497802_wp_ + besjy=0.5_wp_*(a-b) + if(l) return +! + a = + 0.0000000000000016_wp_ + b = f * a - 0.0000000000000875_wp_ + a = f * b - a + 0.0000000000040263_wp_ + b = f * a - b - 0.0000000001583755_wp_ + a = f * b - a + 0.0000000052487948_wp_ + b = f * a - b - 0.0000001440723327_wp_ + a = f * b - a + 0.0000032065325377_wp_ + b = f * a - b - 0.0000563207914106_wp_ + a = f * b - a + 0.0007531135932578_wp_ + b = f * a - b - 0.0072879624795521_wp_ + a = f * b - a + 0.0471966895957634_wp_ + b = f * a - b - 0.1773020127811436_wp_ + a = f * b - a + 0.2615673462550466_wp_ + b = f * a - b + 0.1790343140771827_wp_ + a = f * b - a - 0.2744743055297453_wp_ + a = f * a - b - 0.0662922264065699_wp_ + besjy=0.636619772367581_wp_*log(x)*besjy+0.5_wp_*(a-b) + return +! + 4 f=256.0_wp_/x**2-2.0_wp_ + b = + 0.0000000000000007_wp_ + a = f * b - 0.0000000000000051_wp_ + b = f * a - b + 0.0000000000000433_wp_ + a = f * b - a - 0.0000000000004305_wp_ + b = f * a - b + 0.0000000000051683_wp_ + a = f * b - a - 0.0000000000786409_wp_ + b = f * a - b + 0.0000000016306465_wp_ + a = f * b - a - 0.0000000517059454_wp_ + b = f * a - b + 0.0000030751847875_wp_ + a = f * b - a - 0.0005365220468132_wp_ + a = f * a - b + 1.9989206986950373_wp_ + p=a-b + b = - 0.0000000000000006_wp_ + a = f * b + 0.0000000000000043_wp_ + b = f * a - b - 0.0000000000000334_wp_ + a = f * b - a + 0.0000000000003006_wp_ + b = f * a - b - 0.0000000000032067_wp_ + a = f * b - a + 0.0000000000422012_wp_ + b = f * a - b - 0.0000000007271916_wp_ + a = f * b - a + 0.0000000179724572_wp_ + b = f * a - b - 0.0000007414498411_wp_ + a = f * b - a + 0.0000683851994261_wp_ + a = f * a - b - 0.0311117092106740_wp_ + q=8.0_wp_*(a-b)/v + f=v-0.785398163397448_wp_ + a=cos(f) + b=sin(f) + f=0.398942280401432_wp_/sqrt(v) + if(l) go to 6 + besjy=f*(q*a+p*b) + return + 6 besjy=f*(p*a-q*b) + return +! + entry besj1l(x) +! + l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 5 + 3 f=0.0625_wp_*x**2-2.0_wp_ + b = + 0.0000000000000114_wp_ + a = f * b - 0.0000000000005777_wp_ + b = f * a - b + 0.0000000000252812_wp_ + a = f * b - a - 0.0000000009424213_wp_ + b = f * a - b + 0.0000000294970701_wp_ + a = f * b - a - 0.0000007617587805_wp_ + b = f * a - b + 0.0000158870192399_wp_ + a = f * b - a - 0.0002604443893486_wp_ + b = f * a - b + 0.0032402701826839_wp_ + a = f * b - a - 0.0291755248061542_wp_ + b = f * a - b + 0.1777091172397283_wp_ + a = f * b - a - 0.6614439341345433_wp_ + b = f * a - b + 1.2879940988576776_wp_ + a = f * b - a - 1.1918011605412169_wp_ + a = f * a - b + 1.2967175412105298_wp_ + besjy=0.0625_wp_*(a-b)*x + if(l) return +! + b = - 0.0000000000000244_wp_ + a = f * b + 0.0000000000012114_wp_ + b = f * a - b - 0.0000000000517212_wp_ + a = f * b - a + 0.0000000018754703_wp_ + b = f * a - b - 0.0000000568844004_wp_ + a = f * b - a + 0.0000014166243645_wp_ + b = f * a - b - 0.0000283046401495_wp_ + a = f * b - a + 0.0004404786298671_wp_ + b = f * a - b - 0.0051316411610611_wp_ + a = f * b - a + 0.0423191803533369_wp_ + b = f * a - b - 0.2266249915567549_wp_ + a = f * b - a + 0.6756157807721877_wp_ + b = f * a - b - 0.7672963628866459_wp_ + a = f * b - a - 0.1286973843813500_wp_ + a = f * a - b + 0.0406082117718685_wp_ + besjy=0.636619772367581_wp_*log(x)*besjy-0.636619772367581_wp_/x & + +0.0625_wp_*(a-b)*x + return +! + 5 f=256.0_wp_/x**2-2.0_wp_ + b = - 0.0000000000000007_wp_ + a = f * b + 0.0000000000000055_wp_ + b = f * a - b - 0.0000000000000468_wp_ + a = f * b - a + 0.0000000000004699_wp_ + b = f * a - b - 0.0000000000057049_wp_ + a = f * b - a + 0.0000000000881690_wp_ + b = f * a - b - 0.0000000018718907_wp_ + a = f * b - a + 0.0000000617763396_wp_ + b = f * a - b - 0.0000039872843005_wp_ + a = f * b - a + 0.0008989898330859_wp_ + a = f * a - b + 2.0018060817200274_wp_ + p=a-b + b = + 0.0000000000000007_wp_ + a = f * b - 0.0000000000000046_wp_ + b = f * a - b + 0.0000000000000360_wp_ + a = f * b - a - 0.0000000000003264_wp_ + b = f * a - b + 0.0000000000035152_wp_ + a = f * b - a - 0.0000000000468636_wp_ + b = f * a - b + 0.0000000008229193_wp_ + a = f * b - a - 0.0000000209597814_wp_ + b = f * a - b + 0.0000009138615258_wp_ + a = f * b - a - 0.0000962772354916_wp_ + a = f * a - b + 0.0935555741390707_wp_ + q=8.0_wp_*(a-b)/v + f=v-2.356194490192345_wp_ + a=cos(f) + b=sin(f) + f=0.398942280401432_wp_/sqrt(v) + if(l) go to 7 + besjy=f*(q*a+p*b) + return + 7 besjy=f*(p*a-q*b) + if(x < 0.0_wp_) besjy=-besjy + return +! + entry besy0(x) +! + if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(v >= 8.0_wp_) go to 4 + go to 8 + entry besy1(x) +! + if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(v >= 8.0_wp_) go to 5 + go to 3 +! + 9 besjy=0.0_wp_ + write(nout,"(1x,'besjy ... non-positive argument x = ',e15.4)") x + end function besjy + + function besik(x) + implicit none + real(wp_), intent(in) :: x + real(wp_) :: besik,ebesi0,besi0,ebesi1,besi1,ebesk0,besk0,ebesk1,besk1 + logical :: l,e + real(wp_) :: v,f,a,b,z + integer, parameter :: nout=2 +! + entry ebesi0(x) +! + e=.true. + go to 1 +! + entry besi0(x) +! + e=.false. + 1 l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 4 + 8 f=0.0625_wp_*x**2-2.0_wp_ + a = 0.000000000000002_wp_ + b = f * a + 0.000000000000120_wp_ + a = f * b - a + 0.000000000006097_wp_ + b = f * a - b + 0.000000000268828_wp_ + a = f * b - a + 0.000000010169727_wp_ + b = f * a - b + 0.000000326091051_wp_ + a = f * b - a + 0.000008738315497_wp_ + b = f * a - b + 0.000192469359688_wp_ + a = f * b - a + 0.003416331766012_wp_ + b = f * a - b + 0.047718748798174_wp_ + a = f * b - a + 0.509493365439983_wp_ + b = f * a - b + 4.011673760179349_wp_ + a = f * b - a + 22.274819242462231_wp_ + b = f * a - b + 82.489032744024100_wp_ + a = f * b - a + 190.494320172742844_wp_ + a = f * a - b + 255.466879624362167_wp_ + besik=0.5_wp_*(a-b) + if(l .and. e) besik=exp(-v)*besik + if(l) return +! + a = + 0.000000000000003_wp_ + b = f * a + 0.000000000000159_wp_ + a = f * b - a + 0.000000000007658_wp_ + b = f * a - b + 0.000000000318588_wp_ + a = f * b - a + 0.000000011281211_wp_ + b = f * a - b + 0.000000335195256_wp_ + a = f * b - a + 0.000008216025940_wp_ + b = f * a - b + 0.000162708379043_wp_ + a = f * b - a + 0.002536308188086_wp_ + b = f * a - b + 0.030080722420512_wp_ + a = f * b - a + 0.259084432434900_wp_ + b = f * a - b + 1.511535676029228_wp_ + a = f * b - a + 5.283632866873920_wp_ + b = f * a - b + 8.005368868700334_wp_ + a = f * b - a - 4.563433586448395_wp_ + a = f * a - b - 21.057660177402440_wp_ + besik=-log(0.125_wp_*x)*besik+0.5_wp_*(a-b) + if(e) besik=exp(x)*besik + return +! + 4 f=32.0_wp_/v-2.0_wp_ + b = - 0.000000000000001_wp_ + a = f * b - 0.000000000000001_wp_ + b = f * a - b + 0.000000000000004_wp_ + a = f * b - a + 0.000000000000010_wp_ + b = f * a - b - 0.000000000000024_wp_ + a = f * b - a - 0.000000000000104_wp_ + b = f * a - b + 0.000000000000039_wp_ + a = f * b - a + 0.000000000000966_wp_ + b = f * a - b + 0.000000000001800_wp_ + a = f * b - a - 0.000000000004497_wp_ + b = f * a - b - 0.000000000033127_wp_ + a = f * b - a - 0.000000000078957_wp_ + b = f * a - b + 0.000000000029802_wp_ + a = f * b - a + 0.000000001238425_wp_ + b = f * a - b + 0.000000008513091_wp_ + a = f * b - a + 0.000000056816966_wp_ + b = f * a - b + 0.000000513587727_wp_ + a = f * b - a + 0.000007247591100_wp_ + b = f * a - b + 0.000172700630778_wp_ + a = f * b - a + 0.008445122624921_wp_ + a = f * a - b + 2.016558410917480_wp_ + besik=0.199471140200717_wp_*(a-b)/sqrt(v) + if(e) return + besik=exp(v)*besik + return +! + entry ebesi1(x) +! + e=.true. + go to 2 +! + entry besi1(x) +! + e=.false. + 2 l=.true. + v=abs(x) + if(v >= 8.0_wp_) go to 3 + 7 f=0.0625_wp_*x**2-2.0_wp_ + a = + 0.000000000000001_wp_ + b = f * a + 0.000000000000031_wp_ + a = f * b - a + 0.000000000001679_wp_ + b = f * a - b + 0.000000000079291_wp_ + a = f * b - a + 0.000000003227617_wp_ + b = f * a - b + 0.000000111946285_wp_ + a = f * b - a + 0.000003264138122_wp_ + b = f * a - b + 0.000078756785754_wp_ + a = f * b - a + 0.001543019015627_wp_ + b = f * a - b + 0.023993079147841_wp_ + a = f * b - a + 0.287855511804672_wp_ + b = f * a - b + 2.571459906347755_wp_ + a = f * b - a + 16.334550552522066_wp_ + b = f * a - b + 69.395917633734448_wp_ + a = f * b - a + 181.312616040570265_wp_ + a = f * a - b + 259.890237806477292_wp_ + besik=0.0625_wp_*(a-b)*x + if(l .and. e) besik=exp(-v)*besik + if(l) return +! + a = + 0.000000000000001_wp_ + b = f * a + 0.000000000000042_wp_ + a = f * b - a + 0.000000000002163_wp_ + b = f * a - b + 0.000000000096660_wp_ + a = f * b - a + 0.000000003696783_wp_ + b = f * a - b + 0.000000119367971_wp_ + a = f * b - a + 0.000003202510692_wp_ + b = f * a - b + 0.000070010627855_wp_ + a = f * b - a + 0.001217056994516_wp_ + b = f * a - b + 0.016300049289816_wp_ + a = f * b - a + 0.161074301656148_wp_ + b = f * a - b + 1.101461993004852_wp_ + a = f * b - a + 4.666387026862842_wp_ + b = f * a - b + 9.361617831395389_wp_ + a = f * b - a - 1.839239224286199_wp_ + a = f * a - b - 26.688095480862668_wp_ + besik=log(0.125_wp_*x)*besik+1.0_wp_/x-0.0625_wp_*(a-b)*x + if(e) besik=exp(x)*besik + return +! + 3 f=32.0_wp_/v-2.0_wp_ + b = + 0.000000000000001_wp_ + a = f * b + 0.000000000000001_wp_ + b = f * a - b - 0.000000000000005_wp_ + a = f * b - a - 0.000000000000010_wp_ + b = f * a - b + 0.000000000000026_wp_ + a = f * b - a + 0.000000000000107_wp_ + b = f * a - b - 0.000000000000053_wp_ + a = f * b - a - 0.000000000001024_wp_ + b = f * a - b - 0.000000000001804_wp_ + a = f * b - a + 0.000000000005103_wp_ + b = f * a - b + 0.000000000035408_wp_ + a = f * b - a + 0.000000000081531_wp_ + b = f * a - b - 0.000000000047563_wp_ + a = f * b - a - 0.000000001401141_wp_ + b = f * a - b - 0.000000009613873_wp_ + a = f * b - a - 0.000000065961142_wp_ + b = f * a - b - 0.000000629724239_wp_ + a = f * b - a - 0.000009732146728_wp_ + b = f * a - b - 0.000277205360764_wp_ + a = f * b - a - 0.024467442963276_wp_ + a = f * a - b + 1.951601204652572_wp_ + besik=0.199471140200717_wp_*(a-b)/sqrt(v) + if(x < 0.0_wp_) besik=-besik + if(e) return + besik=exp(v)*besik + return +! + entry ebesk0 (x) +! + e=.true. + go to 11 +! + entry besk0(x) +! + e=.false. + 11 if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(x < 5.0_wp_) go to 8 + f=20.0_wp_/x-2.0_wp_ + a = - 0.000000000000002_wp_ + b = f * a + 0.000000000000011_wp_ + a = f * b - a - 0.000000000000079_wp_ + b = f * a - b + 0.000000000000581_wp_ + a = f * b - a - 0.000000000004580_wp_ + b = f * a - b + 0.000000000039044_wp_ + a = f * b - a - 0.000000000364547_wp_ + b = f * a - b + 0.000000003792996_wp_ + a = f * b - a - 0.000000045047338_wp_ + b = f * a - b + 0.000000632575109_wp_ + a = f * b - a - 0.000011106685197_wp_ + b = f * a - b + 0.000269532612763_wp_ + a = f * b - a - 0.011310504646928_wp_ + a = f * a - b + 1.976816348461652_wp_ + besik=0.626657068657750_wp_*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0_wp_ + if(x < 180.0_wp_) besik=exp(-x)*z + return +! + entry ebesk1(x) +! + e=.true. + go to 12 +! + entry besk1(x) +! + e=.false. + 12 if(x <= 0.0_wp_) go to 9 + l=.false. + v=x + if(x < 5.0_wp_) go to 7 + f=20.0_wp_/x-2.0_wp_ + a = + 0.000000000000002_wp_ + b = f * a - 0.000000000000013_wp_ + a = f * b - a + 0.000000000000089_wp_ + b = f * a - b - 0.000000000000663_wp_ + a = f * b - a + 0.000000000005288_wp_ + b = f * a - b - 0.000000000045757_wp_ + a = f * b - a + 0.000000000435417_wp_ + b = f * a - b - 0.000000004645555_wp_ + a = f * b - a + 0.000000057132218_wp_ + b = f * a - b - 0.000000845172048_wp_ + a = f * b - a + 0.000016185063810_wp_ + b = f * a - b - 0.000468475028167_wp_ + a = f * b - a + 0.035465291243331_wp_ + a = f * a - b + 2.071901717544716_wp_ + besik=0.626657068657750_wp_*(a-b)/sqrt(x) + if(e) return + z=besik + besik=0.0_wp_ + if(x < 180.0_wp_) besik=exp(-x)*z + return + 9 besik=0.0_wp_ + write(nout,"(1x,'besik ... non-positive argument x = ',e15.4)") x + end function besik +! +! routines for conical function: end +! +end module conical \ No newline at end of file diff --git a/src/const_and_precisions.f90 b/src/const_and_precisions.f90 index 26ce054..326ae57 100755 --- a/src/const_and_precisions.f90 +++ b/src/const_and_precisions.f90 @@ -1,17 +1,21 @@ !########################################################################! 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 :: i1 = SELECTED_INT_KIND (2) ! Integer*1 +! INTEGER, PARAMETER :: i2 = SELECTED_INT_KIND (4) ! Integer*2 + INTEGER, PARAMETER :: i4 = SELECTED_INT_KIND (9) ! Integer*4 + INTEGER, PARAMETER :: 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 :: sp_ = r4 ! single precision +! INTEGER, PARAMETER :: dp_ = r8 ! double precision + INTEGER, PARAMETER :: wp_ = r8 ! work-precision ! INTEGER, PARAMETER :: odep_ = dp_ ! ODE-solver precision ! INTEGER, PARAMETER :: xp_ = wp_ ! for ext. modules if necessary !------------------------------------------------------------------------ @@ -26,31 +30,36 @@ !!======================================================================== ! Arithmetic constants !======================================================================== + integer, parameter :: izero = 0 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 :: half = 0.5_wp_ + REAL(wp_), PARAMETER :: one = 1.0_wp_ + REAL(wp_), PARAMETER :: two = 2.0_wp_ + real(wp_), parameter :: pi = 3.141592653589793_wp_ ! 3.141592653589793238462643383280 + real(wp_), parameter :: pihalf = 1.57079632679489661923_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 :: degree = pi/180.0_wp_ + REAL(wp_), PARAMETER :: emn1 = 0.367879441171442_wp_ ! exp(-1) !--- -! 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 :: ex(1:3) = (/one ,zero,zero/) +! REAL(wp_), PARAMETER :: ey(1:3) = (/zero,one ,zero/) +! REAL(wp_), PARAMETER :: ez(1:3) = (/zero,zero,one /) !--- -! 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_) +! REAL(wp_), PARAMETER :: kron(3,3) = reshape((/one ,zero,zero, & +! zero,one ,zero, & +! zero,zero,one /),(/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_eps = EPSILON(one) +! REAL(wp_), PARAMETER :: comp_eps2 = comp_eps**2 + REAL(wp_), PARAMETER :: comp_tiny = TINY(one) + REAL(wp_), PARAMETER :: comp_huge = HUGE(one) ! 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 @@ -60,26 +69,42 @@ !------------------------------------------------------------------------ ! Conventional constants !------------------------------------------------------------------------ + INTEGER, PARAMETER :: int_invalid = -999999999 + REAL(R8), PARAMETER :: r8_invalid = -9.0e40_r8 ! 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] + real (wp_), parameter :: e_ = 1.602176487e-19_wp_ ! elementary charge, C + real (wp_), parameter :: me_ = 9.10938215e-31_wp_ ! electron mass, kg +! real (wp_), parameter :: mp_ = 1.672621637e-27_wp_ ! proton mass, kg +! real (wp_), parameter :: md_ = 3.34358320e-27_wp_ ! deuteron mass, kg +! real (wp_), parameter :: mt_ = 5.00735588e-27_wp_ ! triton mass, kg +! real (wp_), parameter :: ma_ = 6.64465620e-27_wp_ ! alpha mass, kg +! real (wp_), parameter :: amu_ = 1.660538782e-27_wp_ ! amu, kg +! REAL (wp_), PARAMETER :: rmpe_ = mp_/me_ ! proton-electron mass ratio + real (wp_), parameter :: c_ = 2.99792458e8_wp_ ! speed of light, m/s + real (wp_), parameter :: mu0_ = 4.0e-7_wp_ * pi ! magnetic permeability of vacuum + real (wp_), parameter :: eps0_ = 1.0_wp_ / (mu0_ * c_**2) ! dielectric constant of vacuum, F/m +! real (wp_), parameter :: avogr = 6.02214179e23_wp_ +! real (wp_), parameter :: KBolt = 1.3806504e-23_wp_ +!======================================================================== +! Physical constants (cgs) +!======================================================================== + real (wp_), parameter :: ccgs_ = c_*1.e2_wp_ ! speed of light, cm/s + real (wp_), parameter :: mecgs_ = me_*1.e3_wp_ ! electron mass, g + real (wp_), parameter :: ecgs_ = e_*c_*10._wp_ ! elementary charge, statcoul !------------------------------------------------------------------------ ! Useful definitions !------------------------------------------------------------------------ - REAL(wp_), PARAMETER :: keV_ = 1000*e_ ! [J] + REAL(wp_), PARAMETER :: keV_ = 1.e3_wp_*e_ ! [J] REAL(wp_), PARAMETER :: mc2_SI = me_*c_**2 ! [J] REAL(wp_), PARAMETER :: mc2_ = mc2_SI/keV_ ! [keV] + REAL(wp_), PARAMETER :: mu0inv = 1._wp_/mu0_ ! ! 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 :: 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] @@ -100,6 +125,33 @@ ! REAL(wp_), PARAMETER :: Npar_min = 1.0d-3 !########################################################################! + interface is_valid + module procedure is_valid_int4, is_valid_int8, is_valid_real8 + end interface + +contains + + logical function is_valid_int4(in_int) + implicit none + integer(i4), intent(in) :: in_int + is_valid_int4 = in_int /= int_invalid + return + end function is_valid_int4 + + logical function is_valid_int8(in_int) + implicit none + integer(i8), intent(in) :: in_int + is_valid_int8 = in_int /= int_invalid + return + end function is_valid_int8 + + logical function is_valid_real8(in_real) + implicit none + real(r8), intent(in) :: in_real + is_valid_real8 = abs(in_real - r8_invalid) > abs(r8_invalid) * 1.0e-15_r8 + return + end function is_valid_real8 + END MODULE const_and_precisions !########################################################################! diff --git a/src/coreprofiles.f90 b/src/coreprofiles.f90 new file mode 100644 index 0000000..95bcfe6 --- /dev/null +++ b/src/coreprofiles.f90 @@ -0,0 +1,328 @@ +module coreprofiles + use const_and_precisions, only : wp_,zero,one + implicit none + + INTEGER, SAVE :: npp,nsfd + REAL(wp_), SAVE :: psdbnd,psnpp,denpp,ddenpp,d2denpp + REAL(wp_), DIMENSION(:), ALLOCATABLE, SAVE :: tfn,cfn,psrad + REAL(wp_), DIMENSION(:,:), ALLOCATABLE, SAVE :: ct,cz + REAL(wp_), SAVE :: dens0,aln1,aln2,te0,dte0,alt1,alt2,zeffan + +contains + + subroutine density(psin,dens,ddens) + use gray_params, only : iprof + use dierckx, only : splev,splder + implicit none +! arguments + real(wp_), intent(in) :: psin + real(wp_), intent(out) :: dens,ddens +! local variables + integer, parameter :: nn=3, nn1=nn+1, nn2=nn+2 + integer :: ier,nu + real(wp_) :: profd,dprofd,dpsib,tt,fp,dfp,fh,dfh + real(wp_), dimension(1) :: xxs,ffs + real(wp_), dimension(npp+4) :: wrkfd + +! +! computation of density [10^19 m^-3] and derivative wrt psi +! + dens=zero + ddens=zero + if((psin >= psdbnd).or.(psin < zero)) return +! + if(iprof == 0) then + if(psin > one) return + profd=(one-psin**aln1)**aln2 + dens=dens0*profd + dprofd=-aln1*aln2*psin**(aln1-one) & + *(one-psin**aln1)**(aln2-one) + ddens=dens0*dprofd + else + if(psin > psnpp) then + +! smooth interpolation for psnpp < psi < psdbnd +! dens = fp * fh +! fp: parabola matched at psi=psnpp with given profile density +! fh=(1-t)^3(1+3t+6t^2) is a smoothing function: +! fh(0)=1, fh(1)=0 and zero first and second deriv at t=0,1 +! + dpsib=psin-psnpp + fp=denpp+dpsib*ddenpp+0.5_wp_*dpsib**2*d2denpp + dfp=ddenpp+dpsib*d2denpp + tt=dpsib/(psdbnd-psnpp) + fh=(one-tt)**3*(one+3.0_wp_*tt+6.0_wp_*tt**2) + dfh=-30.0_wp_*(one-tt)**2*tt**2/(psdbnd-psnpp) + dens=fp*fh + ddens=dfp*fh+fp*dfh + else + xxs(1)=psin + 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 > 0) print*,ier + if(abs(dens) < 1.0e-10_wp_) dens=zero + end if + if(dens < zero) print*,' DENSITY NEGATIVE',dens +! if(dens < zero) then +! dens=zero +! ddens=zero +! end if + end if + end subroutine density + + function temp(psin) + use const_and_precisions, only : wp_,zero,one + use gray_params, only : iprof + use utils, only : locate + use simplespline, only :spli + implicit none +! arguments + real(wp_), intent(in) :: psin + real(wp_) :: temp +! local variables + integer :: k + real(wp_) :: proft,dps + + temp=zero + if((psin >= one).or.(psin < zero)) return + if(iprof == 0) then + proft=(1.0_wp_-psin**alt1)**alt2 + temp=(te0-dte0)*proft+dte0 + else + call locate(psrad,npp,psin,k) + k=max(1,min(k,npp-1)) + dps=psin-psrad(k) + temp=spli(ct,npp,k,dps) + endif + end function temp + + function fzeff(psin) + use const_and_precisions, only : wp_,zero,one + use gray_params, only : iprof + use utils, only : locate + use simplespline, only :spli + implicit none +! arguments + real(wp_), intent(in) :: psin + real(wp_) :: fzeff +! local variables + integer :: k + real(wp_) :: dps + + fzeff=one + if((psin >= one).or.(psin < zero)) return + if(iprof == 0) then + fzeff=zeffan + else + call locate(psrad,npp,psin,k) + k=max(1,min(k,npp-1)) + dps=psin-psrad(k) + fzeff=spli(cz,npp,k,dps) + endif + end function fzeff + + subroutine read_profiles(filenm,psin,te,ne,zeff,unit) + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: filenm + real(wp_), dimension(:), allocatable, intent(out) :: psin,te,ne,zeff + integer, optional, intent(in) :: unit +! local variables + integer :: u, i, n + + if (present(unit)) then + u=unit + else + u=get_free_unit() + end if + open(file=trim(filenm),status='old',action='read',unit=u) + read(u,*) n + if(allocated(psin)) deallocate(psin) + if(allocated(te)) deallocate(te) + if(allocated(ne)) deallocate(ne) + if(allocated(zeff)) deallocate(zeff) + allocate(psin(n),te(n),ne(n),zeff(n)) + do i=1,n + read(u,*) psin(i),te(i),ne(i),zeff(i) + end do + psin(1)=max(psin(1),zero) + close(u) + end subroutine read_profiles + + subroutine read_profiles_an(filenm,te,ne,zeff,unit) + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: filenm + real(wp_), dimension(:), allocatable, intent(out) :: te,ne,zeff + integer, optional, intent(in) :: unit +! local variables + integer :: u + + if (present(unit)) then + u=unit + else + u=get_free_unit() + end if + + if(allocated(te)) deallocate(te) + if(allocated(ne)) deallocate(ne) + if(allocated(zeff)) deallocate(zeff) + allocate(te(4),ne(3),zeff(1)) + + open(file=trim(filenm),status='old',action='read',unit=u) + read(u,*) ne(1:3) ! dens0,aln1,aln2 + read(u,*) te(1:4) ! te0,dte0,alt1,alt2 + read(u,*) zeff(1) ! zeffan + close(u) + end subroutine read_profiles_an + + subroutine tene_scal(te,ne,tfact,nfact,bfact,iscal,iprof) + implicit none +! arguments + real(wp_), dimension(:), intent(inout) :: te,ne + real(wp_), intent(in) :: tfact,nfact,bfact + integer, intent(in) :: iscal,iprof +! local variables + real(wp_) :: aat,aan,ffact + integer :: lastte,lastne + + if (iscal==0) then + aat=2.0_wp_/3.0_wp_ + aan=4.0_wp_/3.0_wp_ + else + aat=1.0_wp_ + aan=1.0_wp_ + end if + if(iscal==2) then + ffact=1.0_wp_ + else + ffact=bfact + end if + if (iprof==0) then + lastte=2 + lastne=1 + else + lastte=size(te) + lastne=size(ne) + end if + te(1:lastte)=te(1:lastte)*ffact**aat*tfact + ne(1:lastne)=ne(1:lastne)*ffact**aan*nfact + end subroutine tene_scal + + subroutine set_prfspl(psin,te,ne,zeff,ssplne,psdbndmx) + use simplespline, only : difcs + use dierckx, only : curfit, splev, splder + implicit none +! arguments + real(wp_), dimension(:), intent(in) :: psin,te,ne,zeff + real(wp_), intent(in) :: ssplne,psdbndmx +! local variables + integer, parameter :: iopt=0, kspl=3 + integer :: n, npest, lwrkf, ier + real(wp_) :: xb, xe, fp, xnv, xxp,xxm,delta2 + real(wp_), dimension(:), allocatable :: wf, wrkf + integer, dimension(:), allocatable :: iwrkf + real(wp_), dimension(1) :: dedge,ddedge,d2dedge + + n=size(psin) + npest=n+4 + lwrkf=n*4+npest*16 + allocate(wrkf(lwrkf),iwrkf(npest),wf(n)) + +! if necessary, reallocate spline arrays + if(.not.allocated(psrad)) then + allocate(psrad(n),ct(n,4),cz(n,4)) + else + if(size(psrad) psnpp) psdbnd=min(psdbnd,xnv) + else + xxm=xnv-sqrt(delta2) + xxp=xnv+sqrt(delta2) + if(xxm > psnpp) then + psdbnd=min(psdbnd,xxm) + else if (xxp > psnpp) then + psdbnd=min(psdbnd,xxp) + end if + end if + + deallocate(iwrkf,wrkf,wf) + end subroutine set_prfspl + + subroutine unset_prfspl + implicit none + + if(allocated(psrad)) deallocate(psrad) + if(allocated(ct)) deallocate(ct) + if(allocated(cz)) deallocate(cz) + if(allocated(tfn)) deallocate(tfn) + if(allocated(cfn)) deallocate(cfn) + end subroutine unset_prfspl + + subroutine set_prfan(te,ne,zeff) + implicit none + REAL(wp_), dimension(:), intent(in) :: te,ne,zeff + + te0=te(1) + dte0=te(2) + alt1=te(3) + alt2=te(4) + dens0=ne(1) + aln1=ne(2) + aln2=ne(3) + zeffan=zeff(1) + + psdbnd=1.0_wp_ + end subroutine set_prfan + +end module coreprofiles diff --git a/src/dierckx.f90 b/src/dierckx.f90 new file mode 100644 index 0000000..6d1f484 --- /dev/null +++ b/src/dierckx.f90 @@ -0,0 +1,4609 @@ +module dierckx + + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk, & + iwrk,kwrk,ier) +! subroutine bispev evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +! ,my a bivariate spline s(x,y) of degrees kx and ky, given in the +! b-spline representation. +! +! calling sequence: +! call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk, +! * iwrk,kwrk,ier) +! +! input parameters: +! tx : real array, length nx, which contains the position of the +! knots in the x-direction. +! nx : integer, giving the total number of knots in the x-direction +! ty : real array, length ny, which contains the position of the +! knots in the y-direction. +! ny : integer, giving the total number of knots in the y-direction +! c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +! b-spline coefficients. +! kx,ky : integer values, giving the degrees of the spline. +! x : real array of dimension (mx). +! before entry x(i) must be set to the x co-ordinate of the +! i-th grid point along the x-axis. +! tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx. +! mx : on entry mx must specify the number of grid points along +! the x-axis. mx >=1. +! y : real array of dimension (my). +! before entry y(j) must be set to the y co-ordinate of the +! j-th grid point along the y-axis. +! ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +! my : on entry my must specify the number of grid points along +! the y-axis. my >=1. +! wrk : real array of dimension lwrk. used as workspace. +! lwrk : integer, specifying the dimension of wrk. +! lwrk >= mx*(kx+1)+my*(ky+1) +! iwrk : integer array of dimension kwrk. used as workspace. +! kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +! +! output parameters: +! z : real array of dimension (mx*my). +! on succesful exit z(my*(i-1)+j) contains the value of s(x,y) +! at the point (x(i),y(j)),i=1,...,mx;j=1,...,my. +! ier : integer error flag +! ier=0 : normal return +! ier=10: invalid input data (see restrictions) +! +! restrictions: +! mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my +! tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +! ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +! +! other subroutines required: +! fpbisp,fpbspl +! +! references : +! de boor c : on calculating with b-splines, j. approximation theory +! 6 (1972) 50-62. +! cox m.g. : the numerical evaluation of b-splines, j. inst. maths +! applics 10 (1972) 134-149. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1987 +! + implicit none +! arguments + integer, intent(in) :: nx, ny, kx, ky, mx, my, lwrk, kwrk + integer, intent(out) :: ier + integer, intent(inout) :: iwrk(kwrk) + real(wp_), intent(in) :: tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx), y(my) + real(wp_), intent(out) :: z(mx*my) + real(wp_), intent(inout) :: wrk(lwrk) +! local variables + integer :: i, iw, lwest +! .. +! before starting computations a data check is made. if the input data +! are invalid control is immediately repassed to the calling program. + ier = 10 + lwest = (kx+1)*mx+(ky+1)*my + if(lwrk= 0 the total numbers nx and ny of these knots and their +! position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +! ally by the routine. the smoothness of s(x,y) is then achieved by +! minimalizing the discontinuity jumps in the derivatives of s(x,y) +! across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +! the amounth of smoothness is determined by the condition that f(p) = +! sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg- +! ative constant, called the smoothing factor. +! the fit is given in the b-spline representation (b-spline coefficients +! c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +! uated by means of subroutine bispev. +! +! calling sequence: +! call 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) +! +! parameters: +! iopt : integer flag. on entry iopt must specify whether a weighted +! least-squares spline (iopt=-1) or a smoothing spline (iopt=0 +! or 1) must be determined. +! if iopt=0 the routine will start with an initial set of knots +! tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +! 1,...,ky+1. if iopt=1 the routine will continue with the set +! of knots found at the last call of the routine. +! attention: a call with iopt=1 must always be immediately pre- +! ceded by another call with iopt=1 or iopt=0. +! unchanged on exit. +! m : integer. on entry m must specify the number of data points. +! m >= (kx+1)*(ky+1). unchanged on exit. +! x : real array of dimension at least (m). +! y : real array of dimension at least (m). +! z : real array of dimension at least (m). +! before entry, x(i),y(i),z(i) must be set to the co-ordinates +! of the i-th data point, for i=1,...,m. the order of the data +! points is immaterial. unchanged on exit. +! w : real array of dimension at least (m). before entry, w(i) must +! be set to the i-th value in the set of weights. the w(i) must +! be strictly positive. unchanged on exit. +! xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +! yb,ye aries of the rectangular approximation domain. +! xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit. +! kx,ky : integer values. on entry kx and ky must specify the degrees +! of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +! (kx=ky=3) splines. unchanged on exit. +! s : real. on entry (in case iopt>=0) s must specify the smoothing +! factor. s >=0. unchanged on exit. +! for advice on the choice of s see further comments +! nxest : integer. unchanged on exit. +! nyest : integer. unchanged on exit. +! on entry, nxest and nyest must specify an upper bound for the +! number of knots required in the x- and y-directions respect. +! these numbers will also determine the storage space needed by +! the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +! in most practical situation nxest = kx+1+sqrt(m/2), nyest = +! ky+1+sqrt(m/2) will be sufficient. see also further comments. +! nmax : integer. on entry nmax must specify the actual dimension of +! the arrays tx and ty. nmax >= nxest, nmax >=nyest. +! unchanged on exit. +! eps : real. +! on entry, eps must specify a threshold for determining the +! effective rank of an over-determined linear system of equat- +! ions. 0 < eps < 1. if the number of decimal digits in the +! computer representation of a real number is q, then 10**(-q) +! is a suitable value for eps in most practical applications. +! unchanged on exit. +! nx : integer. +! unless ier=10 (in case iopt >=0), nx will contain the total +! number of knots with respect to the x-variable, of the spline +! approximation returned. if the computation mode iopt=1 is +! used, the value of nx should be left unchanged between sub- +! sequent calls. +! in case iopt=-1, the value of nx should be specified on entry +! tx : real array of dimension nmax. +! on succesful exit, this array will contain the knots of the +! spline with respect to the x-variable, i.e. the position of +! the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +! position of the additional knots tx(1)=...=tx(kx+1)=xb and +! tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +! if the computation mode iopt=1 is used, the values of tx(1), +! ...,tx(nx) should be left unchanged between subsequent calls. +! if the computation mode iopt=-1 is used, the values tx(kx+2), +! ...tx(nx-kx-1) must be supplied by the user, before entry. +! see also the restrictions (ier=10). +! ny : integer. +! unless ier=10 (in case iopt >=0), ny will contain the total +! number of knots with respect to the y-variable, of the spline +! approximation returned. if the computation mode iopt=1 is +! used, the value of ny should be left unchanged between sub- +! sequent calls. +! in case iopt=-1, the value of ny should be specified on entry +! ty : real array of dimension nmax. +! on succesful exit, this array will contain the knots of the +! spline with respect to the y-variable, i.e. the position of +! the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +! position of the additional knots ty(1)=...=ty(ky+1)=yb and +! ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +! if the computation mode iopt=1 is used, the values of ty(1), +! ...,ty(ny) should be left unchanged between subsequent calls. +! if the computation mode iopt=-1 is used, the values ty(ky+2), +! ...ty(ny-ky-1) must be supplied by the user, before entry. +! see also the restrictions (ier=10). +! c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +! on succesful exit, c contains the coefficients of the spline +! approximation s(x,y) +! fp : real. unless ier=10, fp contains the weighted sum of +! squared residuals of the spline approximation returned. +! wrk1 : real array of dimension (lwrk1). used as workspace. +! if the computation mode iopt=1 is used the value of wrk1(1) +! should be left unchanged between subsequent calls. +! on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will +! contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1) +! with d(i) the i-th diagonal element of the reduced triangular +! matrix for calculating the b-spline coefficients. it includes +! those elements whose square is less than eps,which are treat- +! ed as 0 in the case of presumed rank deficiency (ier<-2). +! lwrk1 : integer. on entry lwrk1 must specify the actual dimension of +! the array wrk1 as declared in the calling (sub)program. +! lwrk1 must not be too small. let +! u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1, +! ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1, +! if(bx<=by) b1 = bx, b2 = b1+v-ky +! if(bx>by) b1 = by, b2 = b1+u-kx then +! lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +! wrk2 : real array of dimension (lwrk2). used as workspace, but +! only in the case a rank deficient system is encountered. +! lwrk2 : integer. on entry lwrk2 must specify the actual dimension of +! the array wrk2 as declared in the calling (sub)program. +! lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2 +! where u,v and b2 are as above. if there are enough data +! points, scattered uniformly over the approximation domain +! and if the smoothing factor s is not too small, there is a +! good chance that this extra workspace is not needed. a lot +! of memory might therefore be saved by setting lwrk2=1. +! (see also ier > 10) +! iwrk : integer array of dimension (kwrk). used as workspace. +! kwrk : integer. on entry kwrk must specify the actual dimension of +! the array iwrk as declared in the calling (sub)program. +! kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1). +! ier : integer. unless the routine detects an error, ier contains a +! non-positive value on exit, i.e. +! ier=0 : normal return. the spline returned has a residual sum of +! squares fp such that abs(fp-s)/s <= tol with tol a relat- +! ive tolerance set to 0.001 by the program. +! ier=-1 : normal return. the spline returned is an interpolating +! spline (fp=0). +! ier=-2 : normal return. the spline returned is the weighted least- +! squares polynomial of degrees kx and ky. in this extreme +! case fp gives the upper bound for the smoothing factor s. +! ier<-2 : warning. the coefficients of the spline returned have been +! computed as the minimal norm least-squares solution of a +! (numerically) rank deficient system. (-ier) gives the rank. +! especially if the rank deficiency which can be computed as +! (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac- +! curate. they could also seriously depend on the value of +! eps. +! ier=1 : error. the required storage space exceeds the available +! storage space, as specified by the parameters nxest and +! nyest. +! probably causes : nxest or nyest too small. if these param- +! eters are already large, it may also indicate that s is +! too small +! the approximation returned is the weighted least-squares +! spline according to the current set of knots. +! the parameter fp gives the corresponding weighted sum of +! squared residuals (fp>s). +! ier=2 : error. a theoretically impossible result was found during +! the iteration proces for finding a smoothing spline with +! fp = s. probably causes : s too small or badly chosen eps. +! there is an approximation returned but the corresponding +! weighted sum of squared residuals does not satisfy the +! condition abs(fp-s)/s < tol. +! ier=3 : error. the maximal number of iterations maxit (set to 20 +! by the program) allowed for finding a smoothing spline +! with fp=s has been reached. probably causes : s too small +! there is an approximation returned but the corresponding +! weighted sum of squared residuals does not satisfy the +! condition abs(fp-s)/s < tol. +! ier=4 : error. no more knots can be added because the number of +! b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds +! the number of data points m. +! probably causes : either s or m too small. +! the approximation returned is the weighted least-squares +! spline according to the current set of knots. +! the parameter fp gives the corresponding weighted sum of +! squared residuals (fp>s). +! ier=5 : error. no more knots can be added because the additional +! knot would (quasi) coincide with an old one. +! probably causes : s too small or too large a weight to an +! inaccurate data point. +! the approximation returned is the weighted least-squares +! spline according to the current set of knots. +! the parameter fp gives the corresponding weighted sum of +! squared residuals (fp>s). +! ier=10 : error. on entry, the input data are controlled on validity +! the following restrictions must be satisfied. +! -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2, +! nyest>=2*ky+2, 0=nxest, nmax>=nyest, +! xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m +! lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 +! kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1) +! if iopt=-1: 2*kx+2<=nx<=nxest +! xb=0: s>=0 +! if one of these conditions is found to be violated,control +! is immediately repassed to the calling program. in that +! case there is no approximation returned. +! ier>10 : error. lwrk2 is too small, i.e. there is not enough work- +! space for computing the minimal least-squares solution of +! a rank deficient system of linear equations. ier gives the +! requested value for lwrk2. there is no approximation re- +! turned but, having saved the information contained in nx, +! ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and +! the dimension of the array wrk2 accordingly, the user can +! continue at the point the program was left, by calling +! surfit with iopt=1. +! +! further comments: +! by means of the parameter s, the user can control the tradeoff +! between closeness of fit and smoothness of fit of the approximation. +! if s is too large, the spline will be too smooth and signal will be +! lost ; if s is too small the spline will pick up too much noise. in +! the extreme cases the program will return an interpolating spline if +! s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is +! very large. between these extremes, a properly chosen s will result +! in a good compromise between closeness of fit and smoothness of fit. +! to decide whether an approximation, corresponding to a certain s is +! satisfactory the user is highly recommended to inspect the fits +! graphically. +! recommended values for s depend on the weights w(i). if these are +! taken as 1/d(i) with d(i) an estimate of the standard deviation of +! z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +! sqrt(2*m)). if nothing is known about the statistical error in z(i) +! each w(i) can be set equal to one and s determined by trial and +! error, taking account of the comments above. the best is then to +! start with a very large value of s ( to determine the least-squares +! polynomial and the corresponding upper bound fp0 for s) and then to +! progressively decrease the value of s ( say by a factor 10 in the +! beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +! approximation shows more detail) to obtain closer fits. +! to choose s very small is strongly discouraged. this considerably +! increases computation time and memory requirements. it may also +! cause rank-deficiency (ier<-2) and endager numerical stability. +! to economize the search for a good s-value the program provides with +! different modes of computation. at the first call of the routine, or +! whenever he wants to restart with the initial set of knots the user +! must set iopt=0. +! if iopt=1 the program will continue with the set of knots found at +! the last call of the routine. this will save a lot of computation +! time if surfit is called repeatedly for different values of s. +! the number of knots of the spline returned and their location will +! depend on the value of s and on the complexity of the shape of the +! function underlying the data. if the computation mode iopt=1 +! is used, the knots returned may also depend on the s-values at +! previous calls (if these were smaller). therefore, if after a number +! of trials with different s-values and iopt=1, the user can finally +! accept a fit as satisfactory, it may be worthwhile for him to call +! surfit once more with the selected value for s but now with iopt=0. +! indeed, surfit may then return an approximation of the same quality +! of fit but with fewer knots and therefore better if data reduction +! is also an important objective for the user. +! the number of knots may also depend on the upper bounds nxest and +! nyest. indeed, if at a certain stage in surfit the number of knots +! in one direction (say nx) has reached the value of its upper bound +! (nxest), then from that moment on all subsequent knots are added +! in the other (y) direction. this may indicate that the value of +! nxest is too small. on the other hand, it gives the user the option +! of limiting the number of knots the routine locates in any direction +! for example, by setting nxest=2*kx+2 (the lowest allowable value for +! nxest), the user can indicate that he wants an approximation which +! is a simple polynomial of degree kx in the variable x. +! +! other subroutines required: +! fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde +! +! references: +! dierckx p. : an algorithm for surface fitting with spline functions +! ima j. numer. anal. 1 (1981) 267-283. +! dierckx p. : an algorithm for surface fitting with spline functions +! report tw50, dept. computer science,k.u.leuven, 1980. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author: +! p.dierckx +! dept. computer science, k.u. leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! creation date : may 1979 +! latest update : march 1987 +! +! .. + implicit none +! ..scalar arguments.. + real(wp_) xb,xe,yb,ye,s,eps,fp + integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier +! ..array arguments.. + real(wp_) 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) +! ..local scalars.. + real(wp_) 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 +! ..function references.. + integer max0 +! ..subroutine references.. +! fpsurf +! .. +! we set up the parameters tol and maxit. + maxit = 20 + tol = 0.1e-02 +! before starting computations a data check is made. if the input data +! are invalid,control is immediately repassed to the calling program. + ier = 10 + if(eps<=0. .or. eps>=1.) return + if(kx<=0 .or. kx>5) return + kx1 = kx+1 + if(ky<=0 .or. ky>5) return + ky1 = ky+1 + kmax = max0(kx,ky) + km1 = kmax+1 + km2 = km1+1 + if(iopt<(-1) .or. iopt>1) return + if(m<(kx1*ky1)) return + nminx = 2*kx1 + if(nxestnmax) return + nminy = 2*ky1 + if(nyestnmax) return + 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>jb1) then + ib1 = jb1 + ib3 = ky1*nxk+1 + end if + lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3 + kwest = m+nreg + if(lwrk1=xe .or. yb>=ye) return + do i=1,m + if(w(i)<=0.) return + if(x(i)xe) return + if(y(i)ye) return + end do + if(iopt<0) then + if(nxnxest) return + nxk = nx-kx1 + tx(kx1) = xb + tx(nxk+1) = xe + do i=kx1,nxk + if(tx(i+1)<=tx(i)) return + end do + if(nynyest) return + nyk = ny-ky1 + ty(ky1) = yb + ty(nyk+1) = ye + do i=ky1,nyk + if(ty(i+1)<=ty(i)) return + end do + else + if(s<0.) return + end if + ier = 0 +! 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) + end subroutine surfit + + 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, & + idx,nummer,wrk,lwrk,ier) +! .. + implicit none +! ..scalar arguments.. + real(wp_) 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 +! ..array arguments.. + real(wp_) 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 idx(nrest),nummer(m) +! ..local scalars.. + real(wp_) acc,arg,cs,dmax,fac1,fac2,fpmax,fpms,f1,f2,f3,hxi,p,pinv, & + piv,p1,p2,p3,sigma,sn,sq,store,wi,x0,x1,y0,y1,zi,eps, & + rn,one,con1,con9,con4,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 +! ..local arrays.. + real(wp_) hx(6),hy(6) +! ..function references.. +! real(8) abs,sqrt +! integer min0 +! ..subroutine references.. +! fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota +! .. +! set constants + one = 0.1e+01 + con1 = 0.1e0 + con9 = 0.9e0 + con4 = 0.4e-01 + ten = 0.1e+02 +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! part 1: determination of the number of knots and their position. c +! **************************************************************** c +! given a set of knots we compute the least-squares spline sinf(x,y), c +! and the corresponding weighted sum of squared residuals fp=f(p=inf). c +! if iopt=-1 sinf(x,y) is the requested approximation. c +! if iopt=0 or iopt=1 we check whether we can accept the knots: c +! if fp <=s we will continue with the current set of knots. c +! if fp > s we will increase the number of knots and compute the c +! corresponding least-squares spline until finally fp<=s. c +! the initial choice of knots depends on the value of s and iopt. c +! if iopt=0 we first compute the least-squares polynomial of degree c +! kx in x and ky in y; nx=nminx=2*kx+2 and ny=nminy=2*ky+2. c +! fp0=f(0) denotes the corresponding weighted sum of squared c +! residuals c +! if iopt=1 we start with the knots found at the last call of the c +! routine, except for the case that s>=fp0; then we can compute c +! the least-squares polynomial directly. c +! eventually the independent variables x and y (and the corresponding c +! parameters) will be switched if this can reduce the bandwidth of the c +! system to be solved. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! ichang denotes whether(1) or not(-1) the directions have been inter- +! 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<0) go to 20 +! calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s + if(iopt==0) go to 10 + if(fp0>s) go to 20 +! initialization for the least-squares polynomial. + 10 continue + nminx = 2*kx1 + nminy = 2*ky1 + nx = nminx + ny = nminy + ier = -2 + go to 30 + 20 continue + nx = nx0 + ny = ny0 +! main loop for the different sets of knots. m is a save upper bound +! for the number of trials. + 30 continue + do iter=1,m +! find the position of the additional knots which are needed for the +! b-spline representation of s(x,y). + l = nx + do i=1,kx1 + tx(i) = x0 + tx(l) = x1 + l = l-1 + end do + l = ny + do i=1,ky1 + ty(i) = y0 + ty(l) = y1 + l = l-1 + end do +! find nrint, the total number of knot intervals and nreg, the number +! of panels in which the approximation domain is subdivided by the +! intersection of knots. + nxx = nx-2*kx1+1 + nyy = ny-2*ky1+1 + nrint = nxx+nyy + nreg = nxx*nyy +! find the bandwidth of the observation matrix a. +! if necessary, interchange the variables x and y, in order to obtain +! a minimal bandwidth. + iband1 = kx*(ny-ky1)+ky + l = ky*(nx-kx1)+kx + if(iband1>l) then + iband1 = l + ichang = -ichang + do i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + end do + store = x0 + x0 = y0 + y0 = store + store = x1 + x1 = y1 + y1 = store + n = min0(nx,ny) + do i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + end do + n1 = n+1 + if(nxny) then + do i=n1,nx + ty(i) = tx(i) + end do + end if + 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 + end if + iband = iband1+1 +! arrange the data points according to the panel they belong to. + call fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,idx,nreg) +! find ncof, the number of b-spline coefficients. + nk1x = nx-kx1 + nk1y = ny-ky1 + ncof = nk1x*nk1y +! initialize the observation matrix a. + do i=1,ncof + f(i) = 0. + do j=1,iband + a(i,j) = 0. + end do + end do +! initialize the sum of squared residuals. + fp = 0. +! fetch the data points in the new order. main loop for the +! different panels. + do num=1,nreg +! fix certain constants for the current panel; jrot records the column +! number of the first non-zero element in a row of the observation +! 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 +! test whether there are still data points in the panel. + in = idx(num) + do + if(in==0) exit +! fetch a new data point. + wi = w(in) + zi = z(in)*wi +! evaluate for the x-direction, the (kx+1) non-zero b-splines at x(in). + call fpbspl(tx,nx,kx,x(in),l1,hx) +! evaluate for the y-direction, the (ky+1) non-zero b-splines at y(in). + call fpbspl(ty,ny,ky,y(in),l2,hy) +! store the value of these b-splines in spx and spy respectively. + do i=1,kx1 + spx(in,i) = hx(i) + end do + do i=1,ky1 + spy(in,i) = hy(i) + end do +! initialize the new row of observation matrix. + do i=1,iband + h(i) = 0. + end do +! calculate the non-zero elements of the new row by making the cross +! products of the non-zero b-splines in x- and y-direction. + i1 = 0 + do i=1,kx1 + hxi = hx(i) + j1 = i1 + do j=1,ky1 + j1 = j1+1 + h(j1) = hxi*hy(j)*wi + end do + i1 = i1+nk1y + end do +! rotate the row into triangle by givens transformations . + irot = jrot + do i=1,iband + irot = irot+1 + piv = h(i) + if(piv==0.) cycle +! calculate the parameters of the givens transformation. + call fpgivs(piv,a(irot,1),cs,sn) +! apply that transformation to the right hand side. + call fprota(cs,sn,zi,f(irot)) + if(i==iband) exit +! apply that transformation to the left hand side. + i2 = 1 + i3 = i+1 + do j=i3,iband + i2 = i2+1 + call fprota(cs,sn,h(j),a(irot,i2)) + end do + end do +! add the contribution of the row to the sum of squares of residual +! right hand sides. + fp = fp+zi**2 +! find the number of the next data point in the panel. + in = nummer(in) + end do + end do +! find dmax, the maximum value for the diagonal elements in the reduced +! triangle. + dmax = 0. + do i=1,ncof + if(a(i,1)<=dmax) cycle + dmax = a(i,1) + end do +! check whether the observation matrix is rank deficient. + sigma = eps*dmax + do i=1,ncof + if(a(i,1)<=sigma) go to 280 + end do +! backward substitution in case of full rank. + call fpback(a,f,ncof,iband,c,nc) + rank = ncof + do i=1,ncof + q(i,1) = a(i,1)/dmax + end do + go to 300 +! in case of rank deficiency, find the minimum norm solution. +! check whether there is sufficient working space + 280 continue + lwest = ncof*iband+ncof+iband + if(lwrk0.0_wp_) then + go to 820 + else + go to 815 + end if + end if +! test whether we can accept the choice of knots. + if(fpms<0.) exit +! test whether we cannot further increase the number of knots. + if(ncof>m) go to 790 + ier = 0 +! search where to add a new knot. +! find for each interval the sum of squared residuals fpint for the +! data points having the coordinate belonging to that knot interval. +! calculate also coord which is the same sum, weighted by the position +! of the data points considered. + do i=1,nrint + fpint(i) = 0. + coord(i) = 0. + end do + do 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 = idx(num) + do + if(in==0) exit + store = 0. + i1 = jrot + do i=1,kx1 + hxi = spx(in,i) + j1 = i1 + do j=1,ky1 + j1 = j1+1 + store = store+hxi*spy(in,j)*c(j1) + end do + i1 = i1+nk1y + end do + 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) + end do + end do +! find the interval for which fpint is maximal on the condition that +! there still can be added a knot. + do + l = 0 + fpmax = 0. + l1 = 1 + l2 = nrint + if(nx==nxe) l1 = nxx+1 + if(ny==nye) l2 = nxx + if(l1>l2) go to 810 + do i=l1,l2 + if(fpmax>=fpint(i)) cycle + l = i + fpmax = fpint(i) + end do +! test whether we cannot further increase the number of knots. + if(l==0) go to 785 +! calculate the position of the new knot. + arg = coord(l)/fpint(l) +! test in what direction the new knot is going to be added. + if(l<=nxx) then +! addition in the x-direction. + jxy = l+kx1 + fpint(l) = 0. + fac1 = tx(jxy)-arg + fac2 = arg-tx(jxy-1) + if(fac1>(ten*fac2) .or. fac2>(ten*fac1)) cycle + j = nx + do i=jxy,nx + tx(j+1) = tx(j) + j = j-1 + end do + tx(jxy) = arg + nx = nx+1 + else +! addition in the y-direction. + jxy = l+ky1-nxx + fpint(l) = 0. + fac1 = ty(jxy)-arg + fac2 = arg-ty(jxy-1) + if(fac1>(ten*fac2) .or. fac2>(ten*fac1)) cycle + j = ny + do i=jxy,ny + ty(j+1) = ty(j) + j = j-1 + end do + ty(jxy) = arg + ny = ny+1 + end if + exit + end do +! restart the computations with the new set of knots. + end do +! test whether the least-squares polynomial is a solution of our +! approximation problem. + if(ier==(-2)) go to 830 +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! part 2: determination of the smoothing spline sp(x,y) c +! ***************************************************** c +! we have determined the number of knots and their position. we now c +! compute the b-spline coefficients of the smoothing spline sp(x,y). c +! the observation matrix a is extended by the rows of a matrix, c +! expressing that sp(x,y) must be a polynomial of degree kx in x and c +! ky in y. the corresponding weights of these additional rows are set c +! to 1./p. iteratively we than have to determine the value of p c +! such that f(p)=sum((w(i)*(z(i)-sp(x(i),y(i))))**2) be = s. c +! we already know that the least-squares polynomial corresponds to c +! p=0 and that the least-squares spline corresponds to p=infinity. c +! the iteration process which is proposed here makes use of rational c +! interpolation. since f(p) is a convex and strictly decreasing c +! function of p, it can be approximated by a rational function r(p)= c +! (u*p+v)/(p+w). three values of p(p1,p2,p3) with corresponding values c +! of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the c +! new value of p such that r(p)=s. convergence is guaranteed by taking c +! f1 > 0 and f3 < 0. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + kx2 = kx1+1 +! test whether there are interior knots in the x-direction. +! and +! evaluate the discotinuity jumps of the kx-th order derivative of +! the b-splines at the knots tx(l),l=kx+2,...,nx-kx-1. + if(nk1x/=kx1) call fpdisc(tx,nx,kx2,bx,nmax) + ky2 = ky1 + 1 +! test whether there are interior knots in the y-direction. +! and +! evaluate the discontinuity jumps of the ky-th order derivative of +! the b-splines at the knots ty(l),l=ky+2,...,ny-ky-1. + if(nk1y/=ky1) call fpdisc(ty,ny,ky2,by,nmax) +! initial value for p. + p1 = 0. + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0. + do i=1,ncof + p = p+a(i,1) + end do + rn = ncof + p = rn/p +! find the bandwidth of the extended observation matrix. + iband3 = kx1*nk1y + iband4 = iband3 +1 + ich1 = 0 + ich3 = 0 +! iteration process to find the root of f(p)=s. + do 770 iter=1,maxit + pinv = one/p +! store the triangularized observation matrix into q. + do i=1,ncof + ff(i) = f(i) + do j=1,iband + q(i,j) = a(i,j) + end do + ibb = iband+1 + do j=ibb,iband4 + q(i,j) = 0. + end do + end do + if(nk1y/=ky1) then +! extend the observation matrix with the rows of a matrix, expressing +! that for x=cst. sp(x,y) must be a polynomial in y of degree ky. + do i=ky2,nk1y + ii = i-ky1 + do j=1,nk1x +! initialize the new row. + do l=1,iband + h(l) = 0. + end do +! fill in the non-zero elements of the row. jrot records the column +! number of the first non-zero element in the row. + do l=1,ky2 + h(l) = by(ii,l)*pinv + end do + zi = 0. + jrot = (j-1)*nk1y+ii +! rotate the new row into triangle by givens transformations without +! square roots. + do irot=jrot,ncof + piv = h(1) + i2 = min0(iband1,ncof-irot) + if(piv/=0.) then +! calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cs,sn) +! apply that givens transformation to the right hand side. + call fprota(cs,sn,zi,ff(irot)) + if(i2==0) exit +! apply that givens transformation to the left hand side. + do l=1,i2 + l1 = l+1 + call fprota(cs,sn,h(l1),q(irot,l1)) + end do + else + if(i2<=0) exit + end if + do l=1,i2 + h(l) = h(l+1) + end do + h(i2+1) = 0. + end do + end do + end do + end if + if(nk1x/=kx1) then +! extend the observation matrix with the rows of a matrix expressing +! that for y=cst. sp(x,y) must be a polynomial in x of degree kx. + do i=kx2,nk1x + ii = i-kx1 + do j=1,nk1y +! initialize the new row + do l=1,iband4 + h(l) = 0. + end do +! fill in the non-zero elements of the row. jrot records the column +! number of the first non-zero element in the row. + j1 = 1 + do l=1,kx2 + h(j1) = bx(ii,l)*pinv + j1 = j1+nk1y + end do + zi = 0. + jrot = (i-kx2)*nk1y+j +! rotate the new row into triangle by givens transformations . + do irot=jrot,ncof + piv = h(1) + i2 = min0(iband3,ncof-irot) + if(piv/=0.) then +! calculate the parameters of the givens transformation. + call fpgivs(piv,q(irot,1),cs,sn) +! apply that givens transformation to the right hand side. + call fprota(cs,sn,zi,ff(irot)) + if(i2==0) exit +! apply that givens transformation to the left hand side. + do l=1,i2 + l1 = l+1 + call fprota(cs,sn,h(l1),q(irot,l1)) + end do + else + if(i2<=0) exit + end if + do l=1,i2 + h(l) = h(l+1) + end do + h(i2+1) = 0. + end do + end do + end do + end if +! find dmax, the maximum value for the diagonal elements in the +! reduced triangle. + dmax = 0. + do i=1,ncof + if(q(i,1)<=dmax) cycle + dmax = q(i,1) + end do +! check whether the matrix is rank deficient. + sigma = eps*dmax + do i=1,ncof + if(q(i,1)<=sigma) go to 670 + end do +! backward substitution in case of full rank. + call fpback(q,ff,ncof,iband4,c,nc) + rank = ncof + go to 675 +! in case of rank deficiency, find the minimum norm solution. + 670 continue + lwest = ncof*iband4+ncof+iband4 + if(lwrkacc) go to 730 +! our initial choice of p is too large. + p3 = p2 + f3 = f2 + p = p*con4 + if(p<=p1) p = p1*con9 + p2*con1 + go to 770 + 730 if(f2<0.) ich3 = 1 + 740 if(ich1/=0) go to 760 + if((f1-f2)>acc) go to 750 +! our initial choice of p is too small + p1 = p2 + f1 = f2 + p = p/con4 + if(p3<0.) go to 770 + if(p>=p3) p = p2*con1 + p3*con9 + go to 770 + 750 if(f2>0.) ich1 = 1 +! test whether the iteration process proceeds as theoretically +! expected. + 760 if(f2>=f1 .or. f2<=f3) go to 800 +! find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + 770 continue +! 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/=rank) ier = -rank +! test whether x and y are in the original order. + 830 if(ichang<0) go to 930 +! if not, interchange x and y once more. + l1 = 1 + do i=1,nk1x + l2 = i + do j=1,nk1y + f(l2) = c(l1) + l1 = l1+1 + l2 = l2+nk1x + end do + end do + do i=1,ncof + c(i) = f(i) + end do + do i=1,m + store = x(i) + x(i) = y(i) + y(i) = store + end do + n = min0(nx,ny) + do i=1,n + store = tx(i) + tx(i) = ty(i) + ty(i) = store + end do + n1 = n+1 + if(nxny) then + do i=n1,nx + ty(i) = tx(i) + end do + end if + l = nx + nx = ny + ny = l + 930 continue + if(iopt>=0) then + nx0 = nx + ny0 = ny + end if + end subroutine fpsurf + + subroutine fpback(a,z,n,k,c,nest) +! subroutine fpback calculates the solution of the system of +! equations a*c = z with a a n x n upper triangular matrix +! of bandwidth k. +! .. + implicit none +! arguments + integer, intent(in) :: n, k, nest + real(wp_), intent(in) :: a(nest,k), z(n) + real(wp_), intent(inout) :: c(n) +! local variables + real(wp_) :: store + integer :: i, i1, j, k1, l, m +! .. + k1 = k-1 + c(n) = z(n)/a(n,1) + i = n-1 + if(i==0) return + do j=2,n + store = z(i) + i1 = k1 + if(j<=k1) i1 = j-1 + m = i + do l=1,i1 + m = m+1 + store = store-c(m)*a(i,l+1) + end do + c(i) = store/a(i,1) + i = i-1 + end do + end subroutine fpback + + subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wx,wy,lx,ly) + implicit none +! arguments + integer, intent(in) :: nx, ny, kx, ky, mx, my + integer, intent(out) :: lx(mx), ly(my) + real(wp_), intent(in) :: tx(nx), ty(ny), c((nx-kx-1)*(ny-ky-1)), & + x(mx), y(my) + real(wp_), intent(out) :: z(mx*my) + real(wp_), intent(out) :: wx(mx,kx+1), wy(my,ky+1) +! local variables + integer :: kx1, ky1, l, l1, l2, m, nkx1, nky1, i, j, i1, j1 + real(wp_) :: arg, sp, tb, te, h(6) +! ..subroutine references.. +! fpbspl +! .. + kx1 = kx+1 + nkx1 = nx-kx1 + tb = tx(kx1) + te = tx(nkx1+1) + l = kx1 + l1 = l+1 + do i=1,mx + arg = x(i) + if(argte) arg = te + do + if(argte) arg = te + do + if(argm) return +! check condition no 2 + j = n + do i=1,k + if(t(i)>t(i+1) .or. t(j)t(nk2)) return +! check condition no 5 + if(x(1)>=t(k2) .or. x(m)<=t(nk1)) return + i = 1 + l = k2 + nk3 = nk1-1 + do j=2,nk3 + tj = t(j) + l = l+1 + tl = t(l) + do + i = i+1 + if(i>=m) return + if(x(i)>tj) exit + end do + if(x(i)>=tl) return + end do + ier = 0 + end subroutine fpchec + + subroutine fpdisc(t,n,k2,b,nest) +! subroutine fpdisc calculates the discontinuity jumps of the kth +! derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1) + implicit none +! arguments + integer, intent(in) :: n, k2, nest + real(wp_), intent(in) :: t(n) + real(wp_), intent(out) :: b(nest,k2) +! local variables + real(wp_) :: an, fac, prod + integer :: i, ik, j, jk, k, k1, l, lj, lk, lmk, lp, nk1, nrint + real(wp_), dimension(12) :: h +! .. + k1 = k2-1 + k = k1-1 + nk1 = n-k1 + nrint = nk1-k + an = nrint + fac = an/(t(nk1+1)-t(k1)) + do l=k2,nk1 + lmk = l-k1 + do j=1,k1 + ik = j+k1 + lj = l+j + lk = lj-k2 + h(j) = t(l)-t(lk) + h(ik) = t(l)-t(lj) + end do + lp = lmk + do j=1,k2 + jk = j + prod = h(j) + do i=1,k + jk = jk+1 + prod = prod*h(jk)*fac + end do + lk = lp+k1 + b(lmk,j) = (t(lk)-t(lp))/prod + lp = lp+1 + end do + end do + end subroutine fpdisc + + subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h) +! subroutine fprank finds the minimum norm solution of a least- +! squares problem in case of rank deficiency. +! +! input parameters: +! a : array, which contains the non-zero elements of the observation +! matrix after triangularization by givens transformations. +! f : array, which contains the transformed right hand side. +! n : integer,wich contains the dimension of a. +! m : integer, which denotes the bandwidth of a. +! tol : real value, giving a threshold to determine the rank of a. +! +! output parameters: +! c : array, which contains the minimum norm solution. +! sq : real value, giving the contribution of reducing the rank +! to the sum of squared residuals. +! rank : integer, which contains the rank of matrix a. +! + implicit none +! ..scalar arguments.. + integer n,m,na,rank + real(wp_) tol,sq +! ..array arguments.. + real(wp_) a(na,m),f(n),c(n),aa(n,m),ff(n),h(m) +! ..local scalars.. + integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl + real(wp_) cs,fac,piv,sn,yi + real(wp_) store,stor1,stor2,stor3 +! ..function references.. + integer min0 +! ..subroutine references.. +! fpgivs,fprota +! .. + m1 = m-1 +! the rank deficiency nl is considered to be the number of sufficient +! small diagonal elements of a. + nl = 0 + sq = 0. + do i=1,n + if(a(i,1)>tol) cycle +! if a sufficient small diagonal element is found, we put it to +! zero. the remainder of the row corresponding to that zero diagonal +! element is then rotated into triangle by givens rotations . +! the rank deficiency is increased by one. + nl = nl+1 + if(i==n) cycle + yi = f(i) + do j=1,m1 + h(j) = a(i,j+1) + end do + h(m) = 0. + i1 = i+1 + do ii=i1,n + i2 = min0(n-ii,m1) + piv = h(1) + if(piv/=0.) then + call fpgivs(piv,a(ii,1),cs,sn) + call fprota(cs,sn,yi,f(ii)) + if(i2==0) exit + do j=1,i2 + j1 = j+1 + call fprota(cs,sn,h(j1),a(ii,j1)) + h(j) = h(j1) + end do + else + if(i2==0) exit + do j=1,i2 + h(j) = h(j+1) + end do + end if + h(i2+1) = 0. + end do +! add to the sum of squared residuals the contribution of deleting +! the row with small diagonal element. + sq = sq+yi**2 + end do +! rank denotes the rank of a. + rank = n-nl +! let b denote the (rank*n) upper trapezoidal matrix which can be +! obtained from the (n*n) upper triangular matrix a by deleting +! the rows and interchanging the columns corresponding to a zero +! diagonal element. if this matrix is factorized using givens +! transformations as b = (r) (u) where +! r is a (rank*rank) upper triangular matrix, +! u is a (rank*n) orthonormal matrix +! then the minimal least-squares solution c is given by c = b' v, +! where v is the solution of the system (r) (r)' v = g and +! g denotes the vector obtained from the old right hand side f, by +! removing the elements corresponding to a zero diagonal element of a. +! initialization. + do i=1,rank + do j=1,m + aa(i,j) = 0. + end do + end do +! form in aa the upper triangular matrix obtained from a by +! removing rows and columns with zero diagonal elements. form in ff +! the new right hand side by removing the elements of the old right +! hand side corresponding to a deleted row. + ii = 0 + do i=1,n + if(a(i,1)<=tol) cycle + ii = ii+1 + ff(ii) = f(i) + aa(ii,1) = a(i,1) + jj = ii + kk = 1 + j = i + j1 = min0(j-1,m1) + do k=1,j1 + j = j-1 + if(a(j,1)<=tol) cycle + kk = kk+1 + jj = jj-1 + aa(jj,kk) = a(j,k+1) + end do + end do +! form successively in h the columns of a with a zero diagonal element. + ii = 0 + do i=1,n + ii = ii+1 + if(a(i,1)>tol) cycle + ii = ii-1 + if(ii==0) cycle + jj = 1 + j = i + j1 = min0(j-1,m1) + do k=1,j1 + j = j-1 + if(a(j,1)<=tol) cycle + h(jj) = a(j,k+1) + jj = jj+1 + end do + do kk=jj,m + h(kk) = 0. + end do +! rotate this column into aa by givens transformations. + jj = ii + do i1=1,ii + j1 = min0(jj-1,m1) + piv = h(1) + if(piv==0.) then + if(j1==0) exit + do j2=1,j1 + j3 = j2+1 + h(j2) = h(j3) + end do + else + call fpgivs(piv,aa(jj,1),cs,sn) + if(j1==0) exit + kk = jj + do j2=1,j1 + j3 = j2+1 + kk = kk-1 + call fprota(cs,sn,h(j3),aa(kk,j3)) + h(j2) = h(j3) + end do + end if + jj = jj-1 + h(j3) = 0. + end do + end do +! solve the system (aa) (f1) = ff + ff(rank) = ff(rank)/aa(rank,1) + i = rank-1 + do j=2,rank + store = ff(i) + i1 = min0(j-1,m1) + k = i + do ii=1,i1 + k = k+1 + stor1 = ff(k) + stor2 = aa(i,ii+1) + store = store-stor1*stor2 + end do + stor1 = aa(i,1) + ff(i) = store/stor1 + i = i-1 + end do +! solve the system (aa)' (f2) = f1 + ff(1) = ff(1)/aa(1,1) + do j=2,rank + store = ff(j) + i1 = min0(j-1,m1) + k = j + do ii=1,i1 + k = k-1 + stor1 = ff(k) + stor2 = aa(k,ii+1) + store = store-stor1*stor2 + end do + stor1 = aa(j,1) + ff(j) = store/stor1 + end do +! premultiply f2 by the transpoze of a. + k = 0 + do i=1,n + store = 0. + if(a(i,1)>tol) k = k+1 + j1 = min0(i,m) + kk = k + ij = i+1 + do j=1,j1 + ij = ij-1 + if(a(ij,1)<=tol) cycle + stor1 = a(ij,j) + stor2 = ff(kk) + store = store+stor1*stor2 + kk = kk-1 + end do + c(i) = store + end do +! add to the sum of squared residuals the contribution of putting +! to zero the small diagonal elements of matrix (a). + stor3 = 0. + do i=1,n + if(a(i,1)>tol) cycle + store = f(i) + i1 = min0(n-i,m1) + do j=1,i1 + ij = i+j + stor1 = c(ij) + stor2 = a(i,j+1) + store = store-stor1*stor2 + end do + fac = a(i,1)*c(i) + stor1 = a(i,1) + stor2 = c(i) + stor1 = stor1*stor2 + stor3 = stor3+stor1*(stor1-store-store) + end do + fac = stor3 + sq = sq+fac + end subroutine fprank + + subroutine fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,idx,nreg) +! subroutine fporde sorts the data points (x(i),y(i)),i=1,2,...,m +! according to the panel tx(l)<=x=ww) dd = store*sqrt(one+(ww/piv)**2) + if(store0.0_wp_) pinv = one/p +! it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on +! the value of p whether the matrices (spx),(spy),(bx) and (by) still +! must be determined. + if(ifsx==0) then +! calculate the non-zero elements of the matrix (spx) which is the +! observation matrix according to the least-squares spline approximat- +! ion problem in the x-direction. + l = kx1 + l1 = kx2 + number = 0 + do it=1,mx + arg = x(it) + do + if(arg0.0_wp_) then +! calculate the non-zero elements of the matrix (bx). + if(ifbx==0 .and. nx/=2*kx1) then + call fpdisc(tx,nx,kx2,bx,nx) + ifbx = 1 + end if +! calculate the non-zero elements of the matrix (by). + if(ifby==0 .and. ny/=2*ky1) then + call fpdisc(ty,ny,ky2,by,ny) + ifby = 1 + end if + end if +! reduce the matrix (ax) to upper triangular form (rx) using givens +! rotations. apply the same transformations to the rows of matrix q +! to obtain the my x (nx-kx-1) matrix g. +! store matrix (rx) into (ax) and g into q. + l = my*nk1x +! initialization. + do i=1,l + q(i) = 0.0_wp_ + end do + do i=1,nk1x + do j=1,kx2 + ax(i,j) = 0.0_wp_ + end do + end do + l = 0 + nrold = 0 +! ibandx denotes the bandwidth of the matrices (ax) and (rx). + ibandx = kx1 + do it=1,mx + number = nrx(it) + do + if(nrold/=number) then + if(p<=0.0_wp_) then + nrold = nrold+1 + cycle + end if + ibandx = kx2 +! fetch a new row of matrix (bx). + n1 = nrold+1 + do j=1,kx2 + h(j) = bx(n1,j)*pinv + end do +! find the appropriate column of q. + do j=1,my + right(j) = 0.0_wp_ + end do + irot = nrold + else +! fetch a new row of matrix (spx). + h(ibandx) = 0.0_wp_ + do j=1,kx1 + h(j) = spx(it,j) + end do +! find the appropriate column of q. + do j=1,my + l = l+1 + right(j) = z(l) + end do + irot = number + end if +! rotate the new row of matrix (ax) into triangle. + do i=1,ibandx + irot = irot+1 + piv = h(i) + if(piv==0.0_wp_) cycle +! calculate the parameters of the givens transformation. + call fpgivs(piv,ax(irot,1),cs,sn) +! apply that transformation to the rows of matrix q. + iq = (irot-1)*my + do j=1,my + iq = iq+1 + call fprota(cs,sn,right(j),q(iq)) + end do +! apply that transformation to the columns of (ax). + if(i==ibandx) exit + i2 = 1 + i3 = i+1 + do j=i3,ibandx + i2 = i2+1 + call fprota(cs,sn,h(j),ax(irot,i2)) + end do + end do + if(nrold==number) exit + nrold = nrold+1 + end do + end do +! reduce the matrix (ay) to upper triangular form (ry) using givens +! rotations. apply the same transformations to the columns of matrix g +! to obtain the (ny-ky-1) x (nx-kx-1) matrix h. +! store matrix (ry) into (ay) and h into c. + ncof = nk1x*nk1y +! initialization. + do i=1,ncof + c(i) = 0.0_wp_ + end do + do i=1,nk1y + do j=1,ky2 + ay(i,j) = 0.0_wp_ + end do + end do + nrold = 0 +! ibandy denotes the bandwidth of the matrices (ay) and (ry). + ibandy = ky1 + do it=1,my + number = nry(it) + do + if(nrold/=number) then + if(p<=0.0_wp_) then + nrold = nrold+1 + cycle + end if + ibandy = ky2 +! fetch a new row of matrix (by). + n1 = nrold+1 + do j=1,ky2 + h(j) = by(n1,j)*pinv + end do +! find the appropiate row of g. + do j=1,nk1x + right(j) = 0.0_wp_ + end do + irot = nrold +! fetch a new row of matrix (spy) + else + h(ibandy) = 0.0_wp_ + do j=1,ky1 + h(j) = spy(it,j) + end do +! find the appropiate row of g. + l = it + do j=1,nk1x + right(j) = q(l) + l = l+my + end do + irot = number + end if +! rotate the new row of matrix (ay) into triangle. + do i=1,ibandy + irot = irot+1 + piv = h(i) + if(piv==0.0_wp_) cycle +! calculate the parameters of the givens transformation. + call fpgivs(piv,ay(irot,1),cs,sn) +! apply that transformation to the colums of matrix g. + ic = irot + do j=1,nk1x + call fprota(cs,sn,right(j),c(ic)) + ic = ic+nk1y + end do +! apply that transformation to the columns of matrix (ay). + if(i==ibandy) exit + i2 = 1 + i3 = i+1 + do j=i3,ibandy + i2 = i2+1 + call fprota(cs,sn,h(j),ay(irot,i2)) + end do + end do + if(nrold==number) exit + nrold = nrold+1 + end do + end do +! backward substitution to obtain the b-spline coefficients as the +! solution of the linear system (ry) c (rx)' = h. +! first step: solve the system (ry) (c1) = h. + k = 1 + do i=1,nk1x + call fpback(ay,c(k),nk1y,ibandy,c(k),ny) + k = k+nk1y + end do +! second step: solve the system c (rx)' = (c1). + k = 0 + do j=1,nk1y + k = k+1 + l = k + do i=1,nk1x + right(i) = c(l) + l = l+nk1y + end do + call fpback(ax,right,nk1x,ibandx,right,nx) + l = k + do i=1,nk1x + c(l) = right(i) + l = l+nk1y + end do + end do +! calculate the quantities +! res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my +! fp = sumi=1,mx(sumj=1,my(res(i,j))) +! fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1 +! tx(r+kx) <= x(i) <= tx(r+kx+1) +! fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1 +! ty(r+ky) <= y(j) <= ty(r+ky+1) + fp = 0.0_wp_ + do i=1,nx + fpx(i) = 0.0_wp_ + end do + do i=1,ny + fpy(i) = 0.0_wp_ + end do + nk1y = ny-ky1 + iz = 0 + nroldx = 0 +! main loop for the different grid points. + do i1=1,mx + numx = nrx(i1) + numx1 = numx+1 + nroldy = 0 + do i2=1,my + numy = nry(i2) + numy1 = numy+1 + iz = iz+1 +! evaluate s(x,y) at the current grid point by making the sum of the +! cross products of the non-zero b-splines at (x,y), multiplied with +! the appropiate b-spline coefficients. + term = 0.0_wp_ + k1 = numx*nk1y+numy + do l1=1,kx1 + k2 = k1 + fac = spx(i1,l1) + do l2=1,ky1 + k2 = k2+1 + term = term+fac*spy(i2,l2)*c(k2) + end do + k1 = k1+nk1y + end do +! calculate the squared residual at the current grid point. + term = (z(iz)-term)**2 +! adjust the different parameters. + fp = fp+term + fpx(numx1) = fpx(numx1)+term + fpy(numy1) = fpy(numy1)+term + fac = term*half + if(numy/=nroldy) then + fpy(numy1) = fpy(numy1)-fac + fpy(numy) = fpy(numy)+fac + end if + nroldy = numy + if(numx/=nroldx) then + fpx(numx1) = fpx(numx1)-fac + fpx(numx) = fpx(numx)+fac + end if + end do + nroldx = numx + end do + end subroutine fpgrre + + subroutine fpknot(x,m,t,n,fpint,nrdata,nrint,nest,istart) +! subroutine fpknot locates an additional knot for a spline of degree +! k and adjusts the corresponding parameters,i.e. +! t : the position of the knots. +! n : the number of knots. +! nrint : the number of knotintervals. +! fpint : the sum of squares of residual right hand sides +! for each knot interval. +! nrdata: the number of data points inside each knot interval. +! istart indicates that the smallest data point at which the new knot +! may be added is x(istart+1) +! .. + implicit none +! arguments + integer, intent(in) :: m, nest, istart + integer, intent(inout) :: n, nrint, nrdata(nest) + real(wp_), intent(in) :: x(m) + real(wp_), intent(inout) :: t(nest), fpint(nest) +! local variables + real(wp_) :: an, am, fpmax + integer :: ihalf, j, jbegin, jj, jk, jpoint, k, maxbeg, maxpt, next, nrx, number +! .. + k = (n-nrint-1)/2 +! search for knot interval t(number+k) <= x <= t(number+k+1) where +! fpint(number) is maximal on the condition that nrdata(number) +! not equals zero. + fpmax = 0.0_wp_ + jbegin = istart + do j=1,nrint + jpoint = nrdata(j) + if(fpmax s we will increase the number of knots and compute the c +! corresponding least-squares spline until finally fp<=s. c +! the initial choice of knots depends on the value of s and iopt. c +! if s=0 we have spline interpolation; in that case the number of c +! knots equals nmaxx = mx+kx+1 and nmaxy = my+ky+1. c +! if s>0 and c +! *iopt=0 we first compute the least-squares polynomial of degree c +! kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2. c +! *iopt=1 we start with the knots found at the last call of the c +! routine, except for the case that s > fp0; then we can compute c +! the least-squares polynomial directly. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! determine the number of knots for polynomial approximation. + nminx = 2*kx1 + nminy = 2*ky1 + if(iopt>=0) then +! acc denotes the absolute tolerance for the root of f(p)=s. + acc = tol*s +! find nmaxx and nmaxy which denote the number of knots in x- and y- +! direction in case of spline interpolation. + nmaxx = mx+kx1 + nmaxy = my+ky1 +! find nxe and nye which denote the maximum number of knots +! allowed in each direction + nxe = min(nmaxx,nxest) + nye = min(nmaxy,nyest) + if(s<=0.0_wp_) then +! if s = 0, s(x,y) is an interpolating spline. + nx = nmaxx + ny = nmaxy +! test whether the required storage space exceeds the available one. + if(ny>nyest .or. nx>nxest) then + ier = 1 + return + end if +! find the position of the interior knots in case of interpolation. +! the knots in the x-direction. + mk1 = mx-kx1 + if(mk1/=0) then + k3 = kx/2 + i = kx1+1 + j = k3+2 + if(k3*2/=kx) then + do l=1,mk1 + tx(i) = x(j) + i = i+1 + j = j+1 + end do + else + do l=1,mk1 + tx(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + end do + end if + end if +! the knots in the y-direction. + mk1 = my-ky1 + if(mk1/=0) then + k3 = ky/2 + i = ky1+1 + j = k3+2 + if(k3*2/=ky) then + do l=1,mk1 + ty(i) = y(j) + i = i+1 + j = j+1 + end do + else + do l=1,mk1 + ty(i) = (y(j)+y(j-1))*half + i = i+1 + j = j+1 + end do + end if + end if + else +! if s > 0 our initial choice of knots depends on the value of iopt. + if(iopt/=0 .and. fp0>s) then +! if iopt=1 and fp0 > s we start computing the least- squares spline +! according to the set of knots found at the last call of the routine. +! we determine the number of grid coordinates x(i) inside each knot +! interval (tx(l),tx(l+1)). + l = kx2 + j = 1 + nrdatx(1) = 0 + mpm = mx-1 + do i=2,mpm + nrdatx(j) = nrdatx(j)+1 + if(x(i)=fp0, we start computing the least-squares +! polynomial of degree kx in x and ky in y (which is a spline without +! interior knots). + nx = nminx + ny = nminy + nrdatx(1) = mx-2 + nrdaty(1) = my-2 + lastdi = 0 + nplusx = 0 + nplusy = 0 + fp0 = 0.0_wp_ + fpold = 0.0_wp_ + reducx = 0.0_wp_ + reducy = 0.0_wp_ + end if + end if + end if + mpm = mx+my + ifsx = 0 + ifsy = 0 + ifbx = 0 + ifby = 0 + p = -one +! main loop for the different sets of knots.mpm=mx+my is a save upper +! bound for the number of trials. + do iter=1,mpm + if(nx==nminx .and. ny==nminy) ier = -2 +! find nrintx (nrinty) which is the number of knot intervals in the +! x-direction (y-direction). + nrintx = nx-nminx+1 + nrinty = ny-nminy+1 +! find ncof, the number of b-spline coefficients for the current set +! of knots. +! nk1x = nx-kx1 +! nk1y = ny-ky1 +! ncof = nk1x*nk1y +! find the position of the additional knots which are needed for the +! b-spline representation of s(x,y). + i = nx + do j=1,kx1 + tx(j) = xb + tx(i) = xe + i = i-1 + end do + i = ny + do j=1,ky1 + ty(j) = yb + ty(i) = ye + i = i-1 + end do +! find the least-squares spline sinf(x,y) and calculate for each knot +! interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum +! of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2, +! ...,ny-2*ky-1) for the data points having their absciss (ordinate)- +! value belonging to that interval. +! 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==(-2)) fp0 = fp +! test whether the least-squares spline is an acceptable solution. + if(iopt<0) return + fpms = fp-s + if(abs(fpms) < acc) return +! if f(p=inf) < s, we accept the choice of knots. + if(fpms<0.0_wp_) exit +! if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline. + if(nx==nmaxx .and. ny==nmaxy) then + ier = -1 + fp = 0.0_wp_ + return + end if +! increase the number of knots. +! if nx=nxe and ny=nye we cannot further increase the number of knots +! because of the storage capacity limitation. + if(nx==nxe .and. ny==nye) then + ier = 1 + return + end if + ier = 0 +! adjust the parameter reducx or reducy according to the direction +! in which the last added knots were located. + if(lastdi<0) then + reducx = fpold-fp + else if(lastdi>0) then + reducy = fpold-fp + end if +! store the sum of squared residuals for the current set of knots. + fpold = fp +! find nplx, the number of knots we should add in the x-direction. + nplx = 1 + if(nx/=nminx) then + npl1 = nplusx*2 + rn = nplusx + if(reducx>acc) npl1 = int(rn*fpms/reducx) + nplx = min(nplusx*2,max(npl1,nplusx/2,1)) + end if +! find nply, the number of knots we should add in the y-direction. + nply = 1 + if(ny/=nminy) then + npl1 = nplusy*2 + rn = nplusy + if(reducy>acc) npl1 = int(rn*fpms/reducy) + nply = min0(nplusy*2,max0(npl1,nplusy/2,1)) + end if + if (ny==nye .or. (nx/=nxe .and. ny/=nye .and.& + (nplx=0)))) then +! addition in the x-direction. + lastdi = -1 + nplusx = nplx + ifsx = 0 + do l=1,nplusx +! add a new knot in the x-direction + call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1) +! test whether we cannot further increase the number of knots in the +! x-direction. + if (nx==nxe) exit + end do + else +! addition in the y-direction. + lastdi = 1 + nplusy = nply + ifsy = 0 + do l=1,nplusy +! add a new knot in the y-direction. + call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1) +! test whether we cannot further increase the number of knots in the +! y-direction. + if (ny==nye) exit + end do + end if +! restart the computations with the new set of knots. + end do +! test whether the least-squares polynomial is a solution of our +! approximation problem. + if(ier==(-2)) return +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! part 2: determination of the smoothing spline sp(x,y) c +! ***************************************************** c +! we have determined the number of knots and their position. we now c +! compute the b-spline coefficients of the smoothing spline sp(x,y). c +! this smoothing spline varies with the parameter p in such a way thatc +! f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2) c +! is a continuous, strictly decreasing function of p. moreover the c +! least-squares polynomial corresponds to p=0 and the least-squares c +! spline to p=infinity. iteratively we then have to determine the c +! positive value of p such that f(p)=s. the process which is proposed c +! here makes use of rational interpolation. f(p) is approximated by a c +! rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c +! with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c +! are used to calculate the new value of p such that r(p)=s. c +! convergence is guaranteed by taking f1 > 0 and f3 < 0. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! initial value for p. + p1 = 0.0_wp_ + f1 = fp0-s + p3 = -one + f3 = fpms + p = one + ich1 = 0 + ich3 = 0 +! iteration process to find the root of f(p)=s. + do iter = 1,maxit +! find the smoothing spline sp(x,y) and the corresponding sum of +! 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) +! test whether the approximation sp(x,y) is an acceptable solution. + fpms = fp-s + if(abs(fpms)=0.0_wp_ .and. p>=p3) p = p2*con1 + p3*con9 + cycle + end if +! test whether the iteration process proceeds as theoretically +! expected. + if(f2>0.0_wp_) ich1 = 1 + end if + if(f2>=f1 .or. f2<=f3) then + ier = 2 + return + end if +! find the new value of p. + p = fprati(p1,f1,p2,f2,p3,f3) + end do + end subroutine fpregr + + subroutine fprota(cs,sn,a,b) +! subroutine fprota applies a givens rotation to a and b. +! .. + implicit none +! arguments + real(wp_), intent(in) :: cs, sn + real(wp_), intent(inout) :: a, b +! local variables + real(wp_) :: stor1,stor2 +! .. + stor1 = a + stor2 = b + b = cs*stor2+sn*stor1 + a = cs*stor1-sn*stor2 + end subroutine fprota + + function fprati(p1,f1,p2,f2,p3,f3) +! given three points (p1,f1),(p2,f2) and (p3,f3), function fprati +! gives the value of p such that the rational interpolating function +! of the form r(p) = (u*p+v)/(p+w) equals zero at p. +! .. + implicit none + real(wp_) :: fprati +! arguments + real(wp_), intent(in) :: p2, f2 + real(wp_), intent(inout) :: p1, f1, p3, f3 +! local variables + real(wp_) :: h1, h2, h3, p +! .. + if(p3<=0.0_wp_) then +! value of p in case p3 = infinity. + p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3) + else +! value of p in case p3 ^= infinity. + 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) +! adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0. + end if + if(f2>=0.0_wp_) then + p1 = p2 + f1 = f2 + else + p3 = p2 + f3 = f2 + end if + fprati = p + end function fprati + + 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) +! given the set of values z(i,j) on the rectangular grid (x(i),y(j)), +! i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar- +! iate spline approximation s(x,y) of degrees kx and ky on the rect- +! angle xb <= x <= xe, yb <= y <= ye. +! if iopt = -1 regrid calculates the least-squares spline according +! to a given set of knots. +! if iopt >= 0 the total numbers nx and ny of these knots and their +! position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- +! ally by the routine. the smoothness of s(x,y) is then achieved by +! minimalizing the discontinuity jumps in the derivatives of s(x,y) +! across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). +! the amounth of smoothness is determined by the condition that f(p) = +! sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative +! constant, called the smoothing factor. +! the fit is given in the b-spline representation (b-spline coefficients +! c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- +! uated by means of subroutine bispev. +! +! calling sequence: +! call 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) +! +! parameters: +! iopt : integer flag. on entry iopt must specify whether a least- +! squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1) +! must be determined. +! if iopt=0 the routine will start with an initial set of knots +! tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= +! 1,...,ky+1. if iopt=1 the routine will continue with the set +! of knots found at the last call of the routine. +! attention: a call with iopt=1 must always be immediately pre- +! ceded by another call with iopt=1 or iopt=0 and +! s/=0. +! unchanged on exit. +! mx : integer. on entry mx must specify the number of grid points +! along the x-axis. mx > kx . unchanged on exit. +! x : real array of dimension at least (mx). before entry, x(i) +! must be set to the x-co-ordinate of the i-th grid point +! along the x-axis, for i=1,2,...,mx. these values must be +! supplied in strictly ascending order. unchanged on exit. +! my : integer. on entry my must specify the number of grid points +! along the y-axis. my > ky . unchanged on exit. +! y : real array of dimension at least (my). before entry, y(j) +! must be set to the y-co-ordinate of the j-th grid point +! along the y-axis, for j=1,2,...,my. these values must be +! supplied in strictly ascending order. unchanged on exit. +! z : real array of dimension at least (mx*my). +! before entry, z(my*(i-1)+j) must be set to the data value at +! the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my. +! unchanged on exit. +! xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- +! yb,ye aries of the rectangular approximation domain. +! xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my. +! unchanged on exit. +! kx,ky : integer values. on entry kx and ky must specify the degrees +! of the spline. 1<=kx,ky<=5. it is recommended to use bicubic +! (kx=ky=3) splines. unchanged on exit. +! s : real. on entry (in case iopt>=0) s must specify the smoothing +! factor. s >=0. unchanged on exit. +! for advice on the choice of s see further comments +! nxest : integer. unchanged on exit. +! nyest : integer. unchanged on exit. +! on entry, nxest and nyest must specify an upper bound for the +! number of knots required in the x- and y-directions respect. +! these numbers will also determine the storage space needed by +! the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). +! in most practical situation nxest = mx/2, nyest=my/2, will +! be sufficient. always large enough are nxest=mx+kx+1, nyest= +! my+ky+1, the number of knots needed for interpolation (s=0). +! see also further comments. +! nx : integer. +! unless ier=10 (in case iopt >=0), nx will contain the total +! number of knots with respect to the x-variable, of the spline +! approximation returned. if the computation mode iopt=1 is +! used, the value of nx should be left unchanged between sub- +! sequent calls. +! in case iopt=-1, the value of nx should be specified on entry +! tx : real array of dimension nmax. +! on succesful exit, this array will contain the knots of the +! spline with respect to the x-variable, i.e. the position of +! the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the +! position of the additional knots tx(1)=...=tx(kx+1)=xb and +! tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. +! if the computation mode iopt=1 is used, the values of tx(1), +! ...,tx(nx) should be left unchanged between subsequent calls. +! if the computation mode iopt=-1 is used, the values tx(kx+2), +! ...tx(nx-kx-1) must be supplied by the user, before entry. +! see also the restrictions (ier=10). +! ny : integer. +! unless ier=10 (in case iopt >=0), ny will contain the total +! number of knots with respect to the y-variable, of the spline +! approximation returned. if the computation mode iopt=1 is +! used, the value of ny should be left unchanged between sub- +! sequent calls. +! in case iopt=-1, the value of ny should be specified on entry +! ty : real array of dimension nmax. +! on succesful exit, this array will contain the knots of the +! spline with respect to the y-variable, i.e. the position of +! the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the +! position of the additional knots ty(1)=...=ty(ky+1)=yb and +! ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. +! if the computation mode iopt=1 is used, the values of ty(1), +! ...,ty(ny) should be left unchanged between subsequent calls. +! if the computation mode iopt=-1 is used, the values ty(ky+2), +! ...ty(ny-ky-1) must be supplied by the user, before entry. +! see also the restrictions (ier=10). +! c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). +! on succesful exit, c contains the coefficients of the spline +! approximation s(x,y) +! fp : real. unless ier=10, fp contains the sum of squared +! residuals of the spline approximation returned. +! wrk : real array of dimension (lwrk). used as workspace. +! if the computation mode iopt=1 is used the values of wrk(1), +! ...,wrk(4) should be left unchanged between subsequent calls. +! lwrk : integer. on entry lwrk must specify the actual dimension of +! the array wrk as declared in the calling (sub)program. +! lwrk must not be too small. +! lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +! my*(ky+1) +u +! where u is the larger of my and nxest. +! iwrk : integer array of dimension (kwrk). used as workspace. +! if the computation mode iopt=1 is used the values of iwrk(1), +! ...,iwrk(3) should be left unchanged between subsequent calls +! kwrk : integer. on entry kwrk must specify the actual dimension of +! the array iwrk as declared in the calling (sub)program. +! kwrk >= 3+mx+my+nxest+nyest. +! ier : integer. unless the routine detects an error, ier contains a +! non-positive value on exit, i.e. +! ier=0 : normal return. the spline returned has a residual sum of +! squares fp such that abs(fp-s)/s <= tol with tol a relat- +! ive tolerance set to 0.001 by the program. +! ier=-1 : normal return. the spline returned is an interpolating +! spline (fp=0). +! ier=-2 : normal return. the spline returned is the least-squares +! polynomial of degrees kx and ky. in this extreme case fp +! gives the upper bound for the smoothing factor s. +! ier=1 : error. the required storage space exceeds the available +! storage space, as specified by the parameters nxest and +! nyest. +! probably causes : nxest or nyest too small. if these param- +! eters are already large, it may also indicate that s is +! too small +! the approximation returned is the least-squares spline +! according to the current set of knots. the parameter fp +! gives the corresponding sum of squared residuals (fp>s). +! ier=2 : error. a theoretically impossible result was found during +! the iteration proces for finding a smoothing spline with +! fp = s. probably causes : s too small. +! there is an approximation returned but the corresponding +! sum of squared residuals does not satisfy the condition +! abs(fp-s)/s < tol. +! ier=3 : error. the maximal number of iterations maxit (set to 20 +! by the program) allowed for finding a smoothing spline +! with fp=s has been reached. probably causes : s too small +! there is an approximation returned but the corresponding +! sum of squared residuals does not satisfy the condition +! abs(fp-s)/s < tol. +! ier=10 : error. on entry, the input data are controlled on validity +! the following restrictions must be satisfied. +! -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2, +! nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest, +! lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ +! my*(ky+1) +max(my,nxest), +! xb<=x(i-1)=0: s>=0 +! if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1 +! if one of these conditions is found to be violated,control +! is immediately repassed to the calling program. in that +! case there is no approximation returned. +! +! further comments: +! regrid does not allow individual weighting of the data-values. +! so, if these were determined to widely different accuracies, then +! perhaps the general data set routine surfit should rather be used +! in spite of efficiency. +! by means of the parameter s, the user can control the tradeoff +! between closeness of fit and smoothness of fit of the approximation. +! if s is too large, the spline will be too smooth and signal will be +! lost ; if s is too small the spline will pick up too much noise. in +! the extreme cases the program will return an interpolating spline if +! s=0 and the least-squares polynomial (degrees kx,ky) if s is +! very large. between these extremes, a properly chosen s will result +! in a good compromise between closeness of fit and smoothness of fit. +! to decide whether an approximation, corresponding to a certain s is +! satisfactory the user is highly recommended to inspect the fits +! graphically. +! recommended values for s depend on the accuracy of the data values. +! if the user has an idea of the statistical errors on the data, he +! can also find a proper estimate for s. for, by assuming that, if he +! specifies the right s, regrid will return a spline s(x,y) which +! exactly reproduces the function underlying the data he can evaluate +! the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s +! for example, if he knows that the statistical errors on his z(i,j)- +! values is not greater than 0.1, he may expect that a good s should +! have a value not larger than mx*my*(0.1)**2. +! if nothing is known about the statistical error in z(i,j), s must +! be determined by trial and error, taking account of the comments +! above. the best is then to start with a very large value of s (to +! determine the least-squares polynomial and the corresponding upper +! bound fp0 for s) and then to progressively decrease the value of s +! ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... +! and more carefully as the approximation shows more detail) to +! obtain closer fits. +! to economize the search for a good s-value the program provides with +! different modes of computation. at the first call of the routine, or +! whenever he wants to restart with the initial set of knots the user +! must set iopt=0. +! if iopt=1 the program will continue with the set of knots found at +! the last call of the routine. this will save a lot of computation +! time if regrid is called repeatedly for different values of s. +! the number of knots of the spline returned and their location will +! depend on the value of s and on the complexity of the shape of the +! function underlying the data. if the computation mode iopt=1 +! is used, the knots returned may also depend on the s-values at +! previous calls (if these were smaller). therefore, if after a number +! of trials with different s-values and iopt=1, the user can finally +! accept a fit as satisfactory, it may be worthwhile for him to call +! regrid once more with the selected value for s but now with iopt=0. +! indeed, regrid may then return an approximation of the same quality +! of fit but with fewer knots and therefore better if data reduction +! is also an important objective for the user. +! the number of knots may also depend on the upper bounds nxest and +! nyest. indeed, if at a certain stage in regrid the number of knots +! in one direction (say nx) has reached the value of its upper bound +! (nxest), then from that moment on all subsequent knots are added +! in the other (y) direction. this may indicate that the value of +! nxest is too small. on the other hand, it gives the user the option +! of limiting the number of knots the routine locates in any direction +! for example, by setting nxest=2*kx+2 (the lowest allowable value for +! nxest), the user can indicate that he wants an approximation which +! is a simple polynomial of degree kx in the variable x. +! +! other subroutines required: +! fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec, +! fpknot +! +! references: +! dierckx p. : a fast algorithm for smoothing data on a rectangular +! grid while using spline functions, siam j.numer.anal. +! 19 (1982) 1286-1304. +! dierckx p. : a fast algorithm for smoothing data on a rectangular +! grid while using spline functions, report tw53, dept. +! computer science,k.u.leuven, 1980. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author: +! p.dierckx +! dept. computer science, k.u. leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! creation date : may 1979 +! latest update : march 1989 +! +! .. + implicit none +! arguments + integer, intent(in) :: iopt, mx, my, kx, ky, nxest, nyest, lwrk, kwrk + integer, intent(out) :: ier + integer, intent(inout) :: nx, ny, iwrk(kwrk) + real(wp_), intent(in) :: xb, xe, yb, ye, x(mx), y(my), z(mx*my), s + real(wp_), intent(out) :: fp, c((nxest-kx-1)*(nyest-ky-1)) + real(wp_), intent(inout) :: tx(nxest), ty(nyest), wrk(lwrk) +! local variables + integer :: i, j, jwrk, kndx, kndy, knrx, knry, kwest, kx1, kx2, & + ky1, ky2, lfpx, lfpy, lwest, lww, nc, nminx, nminy, mz +! parameters + integer, parameter :: maxit = 20 + real(wp_), parameter :: tol = 0.1e-02_wp_ +! ..subroutine references.. +! fpregr,fpchec +! .. +! before starting computations a data check is made. if the input data +! are invalid, control is immediately repassed to the calling program. + ier = 10 + if(kx<=0 .or. kx>5) return + kx1 = kx+1 + kx2 = kx1+1 + if(ky<=0 .or. ky>5) return + ky1 = ky+1 + ky2 = ky1+1 + if(iopt<(-1) .or. iopt>1) return + nminx = 2*kx1 + if(mxx(1) .or. xe=x(i)) return + end do + if(yb>y(1) .or. ye=y(i)) return + end do + if(iopt<0) then + if(nxnxest) return + j = nx + do i=1,kx1 + tx(i) = xb + tx(j) = xe + j = j-1 + end do + call fpchec(x,mx,tx,nx,kx,ier) + if(ier/=0) return + if(nynyest) return + j = ny + do i=1,ky1 + ty(i) = yb + ty(j) = ye + j = j-1 + end do + call fpchec(y,my,ty,ny,ky,ier) + if(ier/=0) return + else + if(s<0.0_wp_) return + if(s==0.0_wp_ .and. (nxest<(mx+kx1) .or. nyest<(my+ky1)) ) & + return + ier = 0 + end if +! we partition the working space and determine the spline approximation + 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) + end subroutine regrid + + subroutine parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z, & + wrk,lwrk,iwrk,kwrk,ier) +! subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +! ,my the partial derivative ( order nux,nuy) of a bivariate spline +! s(x,y) of degrees kx and ky, given in the b-spline representation. +! +! calling sequence: +! call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +! * iwrk,kwrk,ier) +! +! input parameters: +! tx : real array, length nx, which contains the position of the +! knots in the x-direction. +! nx : integer, giving the total number of knots in the x-direction +! ty : real array, length ny, which contains the position of the +! knots in the y-direction. +! ny : integer, giving the total number of knots in the y-direction +! c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +! b-spline coefficients. +! kx,ky : integer values, giving the degrees of the spline. +! nux : integer values, specifying the order of the partial +! nuy derivative. 0<=nux=1. +! y : real array of dimension (my). +! before entry y(j) must be set to the y co-ordinate of the +! j-th grid point along the y-axis. +! ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. +! my : on entry my must specify the number of grid points along +! the y-axis. my >=1. +! wrk : real array of dimension lwrk. used as workspace. +! lwrk : integer, specifying the dimension of wrk. +! lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +! iwrk : integer array of dimension kwrk. used as workspace. +! kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. +! +! output parameters: +! z : real array of dimension (mx*my). +! on succesful exit z(my*(i-1)+j) contains the value of the +! specified partial derivative of s(x,y) at the point +! (x(i),y(j)),i=1,...,mx;j=1,...,my. +! ier : integer error flag +! ier=0 : normal return +! ier=10: invalid input data (see restrictions) +! +! restrictions: +! mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my +! lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +! tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx +! ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my +! +! other subroutines required: +! fpbisp,fpbspl +! +! references : +! de boor c : on calculating with b-splines, j. approximation theory +! 6 (1972) 50-62. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1989 +! + implicit none +! arguments + integer, intent(in) :: nx, ny, kx, ky, nux, nuy, mx, my, lwrk, kwrk + integer, intent(out) :: ier + integer, intent(inout) :: iwrk(kwrk) + real(wp_), intent(in) :: tx(nx), ty(ny), c((nx-kx-1)*(ny-ky-1)), & + x(mx), y(my) + real(wp_), intent(out) :: z(mx*my) + real(wp_), intent(inout) :: wrk(lwrk) +! local variables + integer :: i, iwx, iwy, j, kkx, kky, kx1, ky1, lx, ly, lwest, & + l1, l2, m, m0, m1, nc, nkx1, nky1, nxx, nyy + real(wp_) :: ak, fac +! .. +! before starting computations a data check is made. if the input data +! 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<0 .or. nux>=kx) return + if(nuy<0 .or. nuy>=ky) return + lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my + if(lwrk0.0_wp_) then + do m=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + end do + end if + end do + lx = lx+1 + kkx = kkx-1 + end do + end if + if(nuy/=0) then + ly = 1 + do j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac>0.0_wp_) then + m0 = i + do m=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + end do + end if + end do + ly = ly+1 + kky = kky-1 + end do + m0 = nyy + m1 = nky1 + do m=2,nxx + do i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + end do + m1 = m1+nuy + end do + end if +! we partition the working space and evaluate the partial derivative + 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)) + end subroutine parder + + subroutine coeff_parder(tx,nx,ty,ny,c,kx,ky,nux,nuy, & + wrk,lwrk,ier) +! subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... +! ,my the partial derivative ( order nux,nuy) of a bivariate spline +! s(x,y) of degrees kx and ky, given in the b-spline representation. +! +! calling sequence: +! call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, +! * iwrk,kwrk,ier) +! +! input parameters: +! tx : real array, length nx, which contains the position of the +! knots in the x-direction. +! nx : integer, giving the total number of knots in the x-direction +! ty : real array, length ny, which contains the position of the +! knots in the y-direction. +! ny : integer, giving the total number of knots in the y-direction +! c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +! b-spline coefficients. +! kx,ky : integer values, giving the degrees of the spline. +! nux : integer values, specifying the order of the partial +! nuy derivative. 0<=nux= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) +! +! output parameters: +! ier : integer error flag +! ier=0 : normal return +! ier=10: invalid input data (see restrictions) +! +! restrictions: +! mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky +! lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), +! +! other subroutines required: +! fpbisp,fpbspl +! +! references : +! de boor c : on calculating with b-splines, j. approximation theory +! 6 (1972) 50-62. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1989 +! + implicit none +! arguments + integer, intent(in) :: nx, ny, kx, ky, nux, nuy, lwrk + integer, intent(out) :: ier + real(wp_), intent(in) :: tx(nx), ty(ny), c((nx-kx-1)*(ny-ky-1)) + real(wp_), intent(inout) :: wrk(lwrk) +! local variables + integer :: mx, my, i, j, kkx, kky, kx1, ky1, lx, ly, lwest, & + l1, l2, m, m0, m1, nc, nkx1, nky1, nxx, nyy + real(wp_) :: ak, fac +! .. +! before starting computations a data check is made. if the input data +! 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<0 .or. nux>=kx) return + if(nuy<0 .or. nuy>=ky) return + lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my + if(lwrk0.0_wp_) then + do m=1,nyy + m1 = m0+nyy + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+1 + end do + end if + end do + lx = lx+1 + kkx = kkx-1 + end do + end if + if(nuy/=0) then + ly = 1 + do j=1,nuy + ak = kky + nyy = nyy-1 + l1 = ly + do i=1,nyy + l1 = l1+1 + l2 = l1+kky + fac = ty(l2)-ty(l1) + if(fac>0.0_wp_) then + m0 = i + do m=1,nxx + m1 = m0+1 + wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac + m0 = m0+nky1 + end do + end if + end do + ly = ly+1 + kky = kky-1 + end do + m0 = nyy + m1 = nky1 + do m=2,nxx + do i=1,nyy + m0 = m0+1 + m1 = m1+1 + wrk(m0) = wrk(m1) + end do + m1 = m1+nuy + end do + end if + end subroutine coeff_parder + + subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp, & + wrk,lwrk,iwrk,ier) +! given the set of data points (x(i),y(i)) and the set of positive +! numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline +! approximation of degree k on the interval xb <= x <= xe. +! if iopt=-1 curfit calculates the weighted least-squares spline +! according to a given set of knots. +! if iopt>=0 the number of knots of the spline s(x) and the position +! t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- +! ness of s(x) is then achieved by minimalizing the discontinuity +! jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., +! n-k-1. the amount of smoothness is determined by the condition that +! f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- +! negative constant, called the smoothing factor. +! the fit s(x) is given in the b-spline representation (b-spline coef- +! ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of +! subroutine splev. +! +! calling sequence: +! call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk, +! * lwrk,iwrk,ier) +! +! parameters: +! iopt : integer flag. on entry iopt must specify whether a weighted +! least-squares spline (iopt=-1) or a smoothing spline (iopt= +! 0 or 1) must be determined. if iopt=0 the routine will start +! with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,... +! k+1. if iopt=1 the routine will continue with the knots +! found at the last call of the routine. +! attention: a call with iopt=1 must always be immediately +! preceded by another call with iopt=1 or iopt=0. +! unchanged on exit. +! m : integer. on entry m must specify the number of data points. +! m > k. unchanged on exit. +! x : real array of dimension at least (m). before entry, x(i) +! must be set to the i-th value of the independent variable x, +! for i=1,2,...,m. these values must be supplied in strictly +! ascending order. unchanged on exit. +! y : real array of dimension at least (m). before entry, y(i) +! must be set to the i-th value of the dependent variable y, +! for i=1,2,...,m. unchanged on exit. +! w : real array of dimension at least (m). before entry, w(i) +! must be set to the i-th value in the set of weights. the +! w(i) must be strictly positive. unchanged on exit. +! see also further comments. +! xb,xe : real values. on entry xb and xe must specify the boundaries +! of the approximation interval. xb<=x(1), xe>=x(m). +! unchanged on exit. +! k : integer. on entry k must specify the degree of the spline. +! 1<=k<=5. it is recommended to use cubic splines (k=3). +! the user is strongly dissuaded from choosing k even,together +! with a small s-value. unchanged on exit. +! s : real.on entry (in case iopt>=0) s must specify the smoothing +! factor. s >=0. unchanged on exit. +! for advice on the choice of s see further comments. +! nest : integer. on entry nest must contain an over-estimate of the +! total number of knots of the spline returned, to indicate +! the storage space available to the routine. nest >=2*k+2. +! in most practical situation nest=m/2 will be sufficient. +! always large enough is nest=m+k+1, the number of knots +! needed for interpolation (s=0). unchanged on exit. +! n : integer. +! unless ier =10 (in case iopt >=0), n will contain the +! total number of knots of the spline approximation returned. +! if the computation mode iopt=1 is used this value of n +! should be left unchanged between subsequent calls. +! in case iopt=-1, the value of n must be specified on entry. +! t : real array of dimension at least (nest). +! on succesful exit, this array will contain the knots of the +! spline,i.e. the position of the interior knots t(k+2),t(k+3) +! ...,t(n-k-1) as well as the position of the additional knots +! t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for +! the b-spline representation. +! if the computation mode iopt=1 is used, the values of t(1), +! t(2),...,t(n) should be left unchanged between subsequent +! calls. if the computation mode iopt=-1 is used, the values +! t(k+2),...,t(n-k-1) must be supplied by the user, before +! entry. see also the restrictions (ier=10). +! c : real array of dimension at least (nest). +! on succesful exit, this array will contain the coefficients +! c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) +! fp : real. unless ier=10, fp contains the weighted sum of +! squared residuals of the spline approximation returned. +! wrk : real array of dimension at least (m*(k+1)+nest*(7+3*k)). +! used as working space. if the computation mode iopt=1 is +! used, the values wrk(1),...,wrk(n) should be left unchanged +! between subsequent calls. +! lwrk : integer. on entry,lwrk must specify the actual dimension of +! the array wrk as declared in the calling (sub)program.lwrk +! must not be too small (see wrk). unchanged on exit. +! iwrk : integer array of dimension at least (nest). +! used as working space. if the computation mode iopt=1 is +! used,the values iwrk(1),...,iwrk(n) should be left unchanged +! between subsequent calls. +! ier : integer. unless the routine detects an error, ier contains a +! non-positive value on exit, i.e. +! ier=0 : normal return. the spline returned has a residual sum of +! squares fp such that abs(fp-s)/s <= tol with tol a relat- +! ive tolerance set to 0.001 by the program. +! ier=-1 : normal return. the spline returned is an interpolating +! spline (fp=0). +! ier=-2 : normal return. the spline returned is the weighted least- +! squares polynomial of degree k. in this extreme case fp +! gives the upper bound fp0 for the smoothing factor s. +! ier=1 : error. the required storage space exceeds the available +! storage space, as specified by the parameter nest. +! probably causes : nest too small. if nest is already +! large (say nest > m/2), it may also indicate that s is +! too small +! the approximation returned is the weighted least-squares +! spline according to the knots t(1),t(2),...,t(n). (n=nest) +! the parameter fp gives the corresponding weighted sum of +! squared residuals (fp>s). +! ier=2 : error. a theoretically impossible result was found during +! the iteration proces for finding a smoothing spline with +! fp = s. probably causes : s too small. +! there is an approximation returned but the corresponding +! weighted sum of squared residuals does not satisfy the +! condition abs(fp-s)/s < tol. +! ier=3 : error. the maximal number of iterations maxit (set to 20 +! by the program) allowed for finding a smoothing spline +! with fp=s has been reached. probably causes : s too small +! there is an approximation returned but the corresponding +! weighted sum of squared residuals does not satisfy the +! condition abs(fp-s)/s < tol. +! ier=10 : error. on entry, the input data are controlled on validity +! the following restrictions must be satisfied. +! -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m +! xb<=x(1)=(k+1)*m+nest*(7+3*k) +! if iopt=-1: 2*k+2<=n<=min(nest,m+k+1) +! xb=0: s>=0 +! if s=0 : nest >= m+k+1 +! if one of these conditions is found to be violated,control +! is immediately repassed to the calling program. in that +! case there is no approximation returned. +! +! further comments: +! by means of the parameter s, the user can control the tradeoff +! between closeness of fit and smoothness of fit of the approximation. +! if s is too large, the spline will be too smooth and signal will be +! lost ; if s is too small the spline will pick up too much noise. in +! the extreme cases the program will return an interpolating spline if +! s=0 and the weighted least-squares polynomial of degree k if s is +! very large. between these extremes, a properly chosen s will result +! in a good compromise between closeness of fit and smoothness of fit. +! to decide whether an approximation, corresponding to a certain s is +! satisfactory the user is highly recommended to inspect the fits +! graphically. +! recommended values for s depend on the weights w(i). if these are +! taken as 1/d(i) with d(i) an estimate of the standard deviation of +! y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ +! sqrt(2*m)). if nothing is known about the statistical error in y(i) +! each w(i) can be set equal to one and s determined by trial and +! error, taking account of the comments above. the best is then to +! start with a very large value of s ( to determine the least-squares +! polynomial and the corresponding upper bound fp0 for s) and then to +! progressively decrease the value of s ( say by a factor 10 in the +! beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the +! approximation shows more detail) to obtain closer fits. +! to economize the search for a good s-value the program provides with +! different modes of computation. at the first call of the routine, or +! whenever he wants to restart with the initial set of knots the user +! must set iopt=0. +! if iopt=1 the program will continue with the set of knots found at +! the last call of the routine. this will save a lot of computation +! time if curfit is called repeatedly for different values of s. +! the number of knots of the spline returned and their location will +! depend on the value of s and on the complexity of the shape of the +! function underlying the data. but, if the computation mode iopt=1 +! is used, the knots returned may also depend on the s-values at +! previous calls (if these were smaller). therefore, if after a number +! of trials with different s-values and iopt=1, the user can finally +! accept a fit as satisfactory, it may be worthwhile for him to call +! curfit once more with the selected value for s but now with iopt=0. +! indeed, curfit may then return an approximation of the same quality +! of fit but with fewer knots and therefore better if data reduction +! is also an important objective for the user. +! +! other subroutines required: +! fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota +! +! references: +! dierckx p. : an algorithm for smoothing, differentiation and integ- +! ration of experimental data using spline functions, +! j.comp.appl.maths 1 (1975) 165-184. +! dierckx p. : a fast algorithm for smoothing data on a rectangular +! grid while using spline functions, siam j.numer.anal. +! 19 (1982) 1286-1304. +! dierckx p. : an improved algorithm for curve fitting with spline +! functions, report tw54, dept. computer science,k.u. +! leuven, 1981. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author: +! p.dierckx +! dept. computer science, k.u. leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! creation date : may 1979 +! latest update : march 1987 +! +! .. + implicit none +! arguments + integer, intent(in) :: iopt, m, k, nest, lwrk + integer, intent(out) :: ier + integer, intent(inout) :: n, iwrk(nest) + real(wp_), intent(in) :: xb, xe, s, x(m), y(m), w(m) + real(wp_), intent(out) :: fp, c(nest) + real(wp_), intent(inout) :: t(nest), wrk(lwrk) +! local variables + integer :: i, ia, ib, ifp, ig, iq, iz, j, k1, k2, lwest, nmin +! parameters + integer, parameter :: maxit = 20 + real(wp_), parameter :: tol = 0.1e-02_wp_ +! .. +! before starting computations a data check is made. if the input data +! are invalid, control is immediately repassed to the calling program. + ier = 10 + if(k<=0 .or. k>5) return + k1 = k+1 + k2 = k1+1 + if(iopt<(-1) .or. iopt>1) return + nmin = 2*k1 + if(mx(1) .or. xe=x(i) .or. w(i)<=0.0_wp_) return + end do + if(iopt<0) then + if(nnest) return + j = n + do i=1,k1 + t(i) = xb + t(j) = xe + j = j-1 + end do + call fpchec(x,m,t,n,k,ier) + if(ier/=0) return + else + if(s<0.0_wp_) return + if(s==0.0_wp_ .and. nest<(m+k1)) return + ier = 0 + end if +! we partition the working space and determine the spline approximation. + 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) + end subroutine curfit + + 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) +! .. + implicit none +! arguments + integer, intent(in) :: iopt, m, k, nest, maxit, k1, k2 + integer, intent(out) :: ier + integer, intent(inout) :: n, nrdata(nest) + real(wp_), intent(in) :: xb, xe, s, tol, x(m), y(m), w(m) + real(wp_), intent(out) :: fp, c(nest) + real(wp_), intent(inout) :: t(nest), fpint(nest), z(nest), & + a(nest,k1), b(nest,k2), g(nest,k2), q(m,k1) +! local variables + real(wp_) :: acc, cs, fpart, fpms, fpold, fp0, f1, f2, f3, p, pinv, & + piv, p1, p2, p3, rn, sn, store, term, wi, xi, yi, h(7) + integer :: i, ich1, ich3, it, iter, i1, i2, i3, j, k3, l, l0, mk1, new, & + nk1, nmax, nmin, nplus, npl1, nrint, n8 + logical :: rstart +! parameters + real(wp_), parameter :: one=1.0_wp_,con1=0.1_wp_,con9=0.9_wp_,con4=0.4e-01_wp_,half=0.5_wp_ +! ..function references +! real(8) abs +! integer max0,min0 +! ..subroutine references.. +! fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota +! .. +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! part 1: determination of the number of knots and their position c +! ************************************************************** c +! given a set of knots we compute the least-squares spline sinf(x), c +! and the corresponding sum of squared residuals fp=f(p=inf). c +! if iopt=-1 sinf(x) is the requested approximation. c +! if iopt=0 or iopt=1 we check whether we can accept the knots: c +! if fp <=s we will continue with the current set of knots. c +! if fp > s we will increase the number of knots and compute the c +! corresponding least-squares spline until finally fp<=s. c +! the initial choice of knots depends on the value of s and iopt. c +! if s=0 we have spline interpolation; in that case the number of c +! knots equals nmax = m+k+1. c +! if s > 0 and c +! iopt=0 we first compute the least-squares polynomial of c +! degree k; n = nmin = 2*k+2 c +! iopt=1 we start with the set of knots found at the last c +! call of the routine, except for the case that s > fp0; then c +! we compute directly the least-squares polynomial of degree k. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! determine nmin, the number of knots for polynomial approximation. + nmin = 2*k1 + if(iopt>=0) then +! calculation of acc, the absolute tolerance for the root of f(p)=s. + acc = tol*s +! determine nmax, the number of knots for spline interpolation. + nmax = m+k1 + if(s<=0.0_wp_) then +! if s=0, s(x) is an interpolating spline. +! test whether the required storage space exceeds the available one. + n = nmax + if(nmax>nest) then + ier = 1 + return + end if +! find the position of the interior knots in case of interpolation. + mk1 = m-k1 + if(mk1/=0) then + k3 = k/2 + i = k2 + j = k3+2 + if(k3*2/=k) then + do l=1,mk1 + t(i) = x(j) + i = i+1 + j = j+1 + end do + else + do l=1,mk1 + t(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + end do + end if + end if + else +! if s>0 our initial choice of knots depends on the value of iopt. +! if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares +! polynomial of degree k which is a spline without interior knots. +! if iopt=1 and fp0>s we start computing the least squares spline +! according to the set of knots found at the last call of the routine. + if (iopt==0 .or. n==nmin) then + n = nmin + fpold = 0.0_wp_ + nplus = 0 + nrdata(1) = m-2 + else + fp0 = fpint(n) + if (s>=fp0) then + n = nmin + fpold = 0.0_wp_ + nplus = 0 + nrdata(1) = m-2 + else + fpold = fpint(n-1) + nplus = nrdata(n) + end if + end if + end if + end if + do + rstart=.false. +! main loop for the different sets of knots. m is a save upper bound +! for the number of trials. + do iter = 1,m + if(n==nmin) ier = -2 +! find nrint, tne number of knot intervals. + nrint = n-nmin+1 +! find the position of the additional knots which are needed for +! the b-spline representation of s(x). + nk1 = n-k1 + i = n + do j=1,k1 + t(j) = xb + t(i) = xe + i = i-1 + end do +! compute the b-spline coefficients of the least-squares spline +! sinf(x). the observation matrix a is built up row by row and +! reduced to upper triangular form by givens transformations. +! at the same time fp=f(p=inf) is computed. + fp = 0.0_wp_ +! initialize the observation matrix a. + do i=1,nk1 + z(i) = 0.0_wp_ + do j=1,k1 + a(i,j) = 0.0_wp_ + end do + end do + l = k1 + do it=1,m +! fetch the current data point x(it),y(it). + xi = x(it) + wi = w(it) + yi = y(it)*wi +! search for knot interval t(l) <= xi < t(l+1). + do + if(xiacc) npl1 = int(rn*fpms/(fpold-fp)) + nplus = min0(nplus*2,max0(npl1,nplus/2,1)) + end if + fpold = fp +! compute the sum((w(i)*(y(i)-s(x(i))))**2) for each knot interval +! t(j+k) <= x(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. + fpart = 0.0_wp_ + i = 1 + l = k2 + new = 0 + do it=1,m + if(x(it)>=t(l) .and. l<=nk1) then + new = 1 + l = l+1 + end if + term = 0.0_wp_ + l0 = l-k2 + do j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + end do + term = (w(it)*(term-y(it)))**2 + fpart = fpart+term + if(new==0) cycle + store = term*half + fpint(i) = fpart-store + i = i+1 + fpart = store + new = 0 + end do + fpint(nrint) = fpart + do l=1,nplus +! add a new knot. + call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) +! if n=nmax we locate the knots as for interpolation. + if(n==nmax) then + rstart=.true. + exit + end if +! test whether we cannot further increase the number of knots. + if(n==nest) exit + end do + if(rstart) exit +! restart the computations with the new set of knots. + end do + if(rstart) then +! find the position of the interior knots in case of interpolation. + mk1 = m-k1 + if (mk1/=0) then + k3 = k/2 + i = k2 + j = k3+2 + if(k3*2/=k) then + do l=1,mk1 + t(i) = x(j) + i = i+1 + j = j+1 + end do + else + do l=1,mk1 + t(i) = (x(j)+x(j-1))*half + i = i+1 + j = j+1 + end do + end if + end if + else + exit + end if + end do +! test whether the least-squares kth degree polynomial is a solution +! of our approximation problem. + if(ier==(-2)) return +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! part 2: determination of the smoothing spline sp(x). c +! *************************************************** c +! we have determined the number of knots and their position. c +! we now compute the b-spline coefficients of the smoothing spline c +! sp(x). the observation matrix a is extended by the rows of matrix c +! b expressing that the kth derivative discontinuities of sp(x) at c +! the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c +! ponding weights of these additional rows are set to 1/p. c +! iteratively we then have to determine the value of p such that c +! f(p)=sum((w(i)*(y(i)-sp(x(i))))**2) be = s. we already know that c +! the least-squares kth degree polynomial corresponds to p=0, and c +! that the least-squares spline corresponds to p=infinity. the c +! iteration process which is proposed here, makes use of rational c +! interpolation. since f(p) is a convex and strictly decreasing c +! function of p, it can be approximated by a rational function c +! r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c +! ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c +! to calculate the new value of p such that r(p)=s. convergence is c +! guaranteed by taking f1>0 and f3<0. c +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! evaluate the discontinuity jump of the kth derivative of the +! b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. + call fpdisc(t,n,k2,b,nest) +! initial value for p. + p1 = 0.0_wp_ + f1 = fp0-s + p3 = -one + f3 = fpms + p = 0.0_wp_ + do i=1,nk1 + p = p+a(i,1) + end do + rn = nk1 + p = rn/p + ich1 = 0 + ich3 = 0 + n8 = n-nmin +! iteration process to find the root of f(p) = s. + do iter=1,maxit +! the rows of matrix b with weight 1/p are rotated into the +! triangularised observation matrix a which is stored in g. + pinv = one/p + do i=1,nk1 + c(i) = z(i) + g(i,k2) = 0.0_wp_ + do j=1,k1 + g(i,j) = a(i,j) + end do + end do + do it=1,n8 +! the row of matrix b is rotated into triangle by givens transformation + do i=1,k2 + h(i) = b(it,i)*pinv + end do + yi = 0.0_wp_ + do j=it,nk1 + piv = h(1) +! calculate the parameters of the givens transformation. + call fpgivs(piv,g(j,1),cs,sn) +! transformations to right hand side. + call fprota(cs,sn,yi,c(j)) + if(j==nk1) exit + i2 = k1 + if(j>n8) i2 = nk1-j + do i=1,i2 +! transformations to left hand side. + i1 = i+1 + call fprota(cs,sn,h(i1),g(j,i1)) + h(i) = h(i1) + end do + h(i2+1) = 0.0_wp_ + end do + end do +! backward substitution to obtain the b-spline coefficients. + call fpback(g,c,nk1,k2,c,nest) +! computation of f(p). + fp = 0.0_wp_ + l = k2 + do it=1,m + if(x(it)>=t(l) .and. l<=nk1) l = l+1 + l0 = l-k2 + term = 0.0_wp_ + do j=1,k1 + l0 = l0+1 + term = term+c(l0)*q(it,j) + end do + fp = fp+(w(it)*(term-y(it)))**2 + end do +! test whether the approximation sp(x) is an acceptable solution. + fpms = fp-s + if(abs(fpms)=0.0_wp_ .and. p>=p3) p = p2*con1 + p3*con9 + cycle + end if + if(f2>0.0_wp_) ich1=1 + end if +! test whether the iteration process proceeds as theoretically +! expected. + if(f2>=f1 .or. f2<=f3) then + ier = 2 + return + end if +! find the new value for p. + p = fprati(p1,f1,p2,f2,p3,f3) + end do + end subroutine fpcurf + + subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier) +! subroutine splder evaluates in a number of points x(i),i=1,2,...,m +! the derivative of order nu of a spline s(x) of degree k,given in +! its b-spline representation. +! +! calling sequence: +! call splder(t,n,c,k,nu,x,y,m,wrk,ier) +! +! input parameters: +! t : array,length n, which contains the position of the knots. +! n : integer, giving the total number of knots of s(x). +! c : array,length n, which contains the b-spline coefficients. +! k : integer, giving the degree of s(x). +! nu : integer, specifying the order of the derivative. 0<=nu<=k +! x : array,length m, which contains the points where the deriv- +! ative of s(x) must be evaluated. +! m : integer, giving the number of points where the derivative +! of s(x) must be evaluated +! wrk : real array of dimension n. used as working space. +! +! output parameters: +! y : array,length m, giving the value of the derivative of s(x) +! at the different points. +! ier : error flag +! ier = 0 : normal return +! ier =10 : invalid input data (see restrictions) +! +! restrictions: +! 0 <= nu <= k +! m >= 1 +! t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +! +! other subroutines required: fpbspl +! +! references : +! de boor c : on calculating with b-splines, j. approximation theory +! 6 (1972) 50-62. +! cox m.g. : the numerical evaluation of b-splines, j. inst. maths +! applics 10 (1972) 134-149. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1987 +! + implicit none +! arguments + integer, intent(in) :: n, k, nu, m + integer, intent(out) :: ier + real(wp_), intent(in) :: t(n), c(n), x(m) + real(wp_), intent(out) :: y(m), wrk(n) +! local variables + integer :: i, j, kk, k1, k2, l, ll, l1, l2, nk1, nk2 + real(wp_) :: ak, arg, fac, sp, tb, te, h(6) +! before starting computations a data check is made. if the input data +! are invalid control is immediately repassed to the calling program. + ier = 10 + if(nu<0 .or. nu>k) return + if(m<1) return + do i=2,m + if(x(i)0.0_wp_) wrk(i) = ak*(wrk(i+1)-wrk(i))/fac + end do + l = l+1 + kk = kk-1 + end do + if(kk==0) then +! if nu=k the derivative is a piecewise constant function + j = 1 + do i=1,m + arg = x(i) + do + if(argte) arg = te +! search for knot interval t(l) <= arg < t(l+1) + do + if(arg= 1 +! t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. +! +! other subroutines required: fpbspl. +! +! references : +! de boor c : on calculating with b-splines, j. approximation theory +! 6 (1972) 50-62. +! cox m.g. : the numerical evaluation of b-splines, j. inst. maths +! applics 10 (1972) 134-149. +! dierckx p. : curve and surface fitting with splines, monographs on +! numerical analysis, oxford university press, 1993. +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1987 +! + implicit none +! arguments + integer, intent(in) :: n, k, m + integer, intent(out) :: ier + real(wp_), intent(in) :: t(n), c(n), x(m) + real(wp_), intent(out) :: y(m) +! local variables + integer :: i, j, k1, l, ll, l1, nk1 + real(wp_) :: arg, sp, tb, te, h(6) +! .. +! before starting computations a data check is made. if the input data +! are invalid control is immediately repassed to the calling program. + ier = 10 + if(m<1) return + do i=2,m + if(x(i)te) arg = te +! search for knot interval t(l) <= arg < t(l+1) + do + if(arg=8 +! c : real array,length n, containing the b-spline coefficients. +! mest : integer, specifying the dimension of array zero. +! +! output parameters: +! zero : real array,lenth mest, containing the zeros of s(x). +! m : integer,giving the number of zeros. +! ier : error flag: +! ier = 0: normal return. +! ier = 1: the number of zeros exceeds mest. +! ier =10: invalid input data (see restrictions). +! +! other subroutines required: fpcuro +! +! restrictions: +! 1) n>= 8. +! 2) t(4) < t(5) < ... < t(n-4) < t(n-3). +! t(1) <= t(2) <= t(3) <= t(4) +! t(n-3) <= t(n-2) <= t(n-1) <= t(n) +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1987 +! +! .. + implicit none +! ..scalar arguments.. + integer, intent(in) :: n,mest + integer, intent(out) :: m,ier + real(wp_), intent(in) :: val +! ..array arguments.. + real(wp_), intent(in) :: t(n),c(n) + real(wp_), intent(out) :: zero(mest) +! ..local scalars.. + integer :: i,j,j1,l,n4 + real(wp_) :: ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2, & + t1,t2,t3,t4,t5,zz + logical :: z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4 +! ..local array.. + real(wp_) :: y(3) +! .. +! set some constants + real(wp_), parameter :: two = 0.2e+01_wp_, three = 0.3e+01_wp_ +! before starting computations a data check is made. if the input data +! are invalid, control is immediately repassed to the calling program. + n4 = n-4 + ier = 10 + if(n<8) return + j = n + do i=1,3 + if(t(i)>t(i+1)) return + if(t(j)=t(i+1)) return + end do +! the problem considered reduces to finding the zeros of the cubic +! polynomials pl(x) which define the cubic spline in each knot +! interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on +! the condition that it belongs to the knot interval. +! the cubic polynomial pl(x) is determined by computing s(t(l)), +! s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute +! s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of +! splines and their derivatives, the value of s(t(l)) and s'(t(l)) +! is already known from the foregoing knot interval. + ier = 0 +! 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) +! 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<0.0_wp_) z1 = .false. + nz1 = .not.z1 + m = 0 +! main loop for the different knot intervals. + do l=4,n4 +! 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) +! 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 +! calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial +! 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 +! test whether or not pl(x) could have a zero in the range +! t(l) <= x <= t(l+1). + z3 = .true. + if(b1<0.0_wp_) z3 = .false. + nz3 = .not.z3 + if(a0*b0>0.0_wp_) then + z0 = .true. + if(a0<0.0_wp_) z0 = .false. + nz0 = .not.z0 + z2 = .true. + if(a2<0.0_wp_) z2 = .false. + nz2 = .not.z2 + z4 = .true. + if(3.0_wp_*a3+a2<0.0_wp_) z4 = .false. + nz4 = .not.z4 + else + z0 = .true. + nz0 = .not.z0 + z2 = .true. + nz2 = .not.z2 + z4 = .true. + nz4 = .not.z4 + end if + if(( 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) & + ) .or. (a0*b0<=0.0_wp_) ) then +! find the zeros of ql(y). + call fpcuro(a3,a2,a1,a0,y,j) +! find which zeros of pl(x) are zeros of s(x). + do i=1,j + if(y(i)<0.0_wp_ .or. y(i)>1.0_wp_) cycle +! test whether the number of zeros of s(x) exceeds mest. + if(m>=mest) then + ier = 1 + return + end if + m = m+1 + zero(m) = t(l)+h1*y(i) + end do + end if + a0 = b0 + ah = bh + z1 = z3 + nz1 = nz3 + end do +! the zeros of s(x) are arranged in increasing order. + do i=2,m + j = i + do + j1 = j-1 + if(j1==0) exit + if(zero(j)>=zero(j1)) exit + zz = zero(j) + zero(j) = zero(j1) + zero(j1) = zz + j = j1 + end do + end do + j = m + m = 1 + do i=2,j + if(zero(i)==zero(m)) cycle + m = m+1 + zero(m) = zero(i) + end do + end subroutine sproota + + subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) +! if iopt=0 subroutine profil calculates the b-spline coefficients of +! the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of +! degrees kx and ky, given in the b-spline representation. +! if iopt = 1 it calculates the b-spline coefficients of the univariate +! spline g(x) = s(x,u) +! +! calling sequence: +! call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) +! +! input parameters: +! iopt : integer flag, specifying whether the profile f(y) (iopt=0) +! or the profile g(x) (iopt=1) must be determined. +! tx : real array, length nx, which contains the position of the +! knots in the x-direction. +! nx : integer, giving the total number of knots in the x-direction +! ty : real array, length ny, which contains the position of the +! knots in the y-direction. +! ny : integer, giving the total number of knots in the y-direction +! c : real array, length (nx-kx-1)*(ny-ky-1), which contains the +! b-spline coefficients. +! kx,ky : integer values, giving the degrees of the spline. +! u : real value, specifying the requested profile. +! tx(kx+1)<=u<=tx(nx-kx), if iopt=0. +! ty(ky+1)<=u<=ty(ny-ky), if iopt=1. +! nu : on entry nu must specify the dimension of the array cu. +! nu >= ny if iopt=0, nu >= nx if iopt=1. +! +! output parameters: +! cu : real array of dimension (nu). +! on succesful exit this array contains the b-spline +! ier : integer error flag +! ier=0 : normal return +! ier=10: invalid input data (see restrictions) +! +! restrictions: +! if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny. +! if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx. +! +! other subroutines required: +! fpbspl +! +! author : +! p.dierckx +! dept. computer science, k.u.leuven +! celestijnenlaan 200a, b-3001 heverlee, belgium. +! e-mail : Paul.Dierckx@cs.kuleuven.ac.be +! +! latest update : march 1987 +! + implicit none +! ..scalar arguments.. + integer,intent(in) :: iopt,nx,ny,kx,ky,nu + integer,intent(out) :: ier + real(wp_), intent(in) :: u +! ..array arguments.. + real(wp_),intent(in) :: tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)) + real(wp_),intent(out) :: cu(nu) +! ..local scalars.. + integer :: i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1 + real(wp_) :: summ +! ..local array + real(wp_) :: h(6) +! .. +! before starting computations a data check is made. if the input data +! 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==0) then + if(nutx(nkx1+1)) return +! the b-splinecoefficients of f(y) = s(u,y). + ier = 0 + l = kx1 + l1 = l+1 + do + if(uty(nky1+1)) return +! the b-splinecoefficients of g(x) = s(x,u). + ier = 0 + l = ky1 + l1 = l+1 + do + if(u=a1*ovfl) then +! test whether p(x) is a second degree polynomial. + if(max(c1,d1)>=b1*ovfl) then +! test whether p(x) is a first degree polynomial. + if(d1>=c1*ovfl) then +! p(x) is a constant function. + n = 0 + return + end if +! p(x) is a first degree polynomial. + n = 1 + x(1) = -d/c + else +! p(x) is a second degree polynomial. + disc = c*c-four*b*d + n = 0 + if(disc<0.0_wp_) return + n = 2 + u = sqrt(disc) + b1 = b+b + x(1) = (-c+u)/b1 + x(2) = (-c-u)/b1 + end if + else +! p(x) is a third degree polynomial. + 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<=0.0_wp_) then + u = sqrt(abs(q)) + if(r<0.0_wp_) 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 + else + u = sqrt(disc) + u1 = -r+u + u2 = -r-u + n = 1 + x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1 + end if + end if +! apply a newton iteration to improve the accuracy of the roots. + do i=1,n + y = x(i) + f = ((a*y+b)*y+c)*y+d + df = (three*a*y+two*b)*y+c + step = 0.0_wp_ + if(abs(f) O mode, +1 => X mode) + real(wp_) :: xg,yg,npl,nprf,sox +! local variables + real(wp_) :: yg2,npl2,dnl,del,dxg +! + npl2=npl*npl + dnl=one-npl2 + dxg=one-xg + yg2=yg*yg + del=sqrt(dnl*dnl+4.0_wp_*npl2*dxg/yg2) + nprf=sqrt(dxg-npl2-xg*yg2*(one+npl2+sox*del)/(dxg-yg2)/2.0_wp_) +! +end subroutine colddisp +! +! +! +subroutine harmnumber(yg,mu,npl,nhmin,nhmax,iwr) +! computation of minimum and maximum harmonic +! + implicit none +! local constants +! expcr = maximum value for mu*(gamma-1) above which the distribution function +! is considered to be 0 +! eps = small number to have a correct rounding when ygnc/yg is an integer + real(wp_), parameter :: expcr=16.0_wp_,eps=1.e-8_wp_ +! arguments +! yg = omegac/omega +! npl = parallel N +! mu = mc^2/Te +! nh = number of the armonic (min/max) +! iwr = weakly (iwr=1) or fully relativistic approximation + integer :: nhmin,nhmax,iwr + real(wp_) :: yg,npl,mu +! local variables + integer :: nh,nhc + real(wp_) :: ygc,ygn,npl2,gg,dnl,rdu2,argexp,uu2 +! + nhmin=0 + nhmax=0 + npl2=npl**2 + dnl=one-npl2 +! + if(iwr.eq.1) then + ygc=max(one-0.5_wp_*npl2,zero) + else + ygc=sqrt(max(dnl,zero)) + end if + nhc=int(ygc/yg) + if (nhc*ygimx ',yg,errnpr,i +! + if(dble(sqrt(npr2)).lt.zero.or.npr2.ne.npr2.or.abs(npr2).eq.huge(one).or. & + abs(npr2).le.tiny(one)) then + write(*,"(' X =',f7.4,' Y =',f7.4,' Nperp =',f7.4,'!')") xg,yg,sqrt(abs(npr2)) + npr2=czero + err=99 + end if +! if(dble(npr2).lt.zero) then +! npr2=zero +! print*,' Y =',yg,' npr2 < 0' +! err=99 +! end if +! +! write(11,99) yg,dble(npr2),dimag(npr2),nprf**2,dble(i) +! + npr=sqrt(npr2) + nprr=dble(npr) + npri=dimag(npr) +! + ex=czero + ey=czero + ez=czero +! + if (abs(npl).gt.1.0e-6_wp_) then + den=e12*e23-(e13+npr*npl)*(e22-npr2-npl2) + ey=-(e12*(e13+npr*npl)+(e11-npl2)*e23)/den + ez=(e12*e12+(e22-npr2-npl2)*(e11-npl2))/den + ez2=abs(ez)**2 + ey2=abs(ey)**2 + enx2=one/(one+ey2+ez2) + ex=dcmplx(sqrt(enx2),zero) + ez2=ez2*enx2 + ey2=ey2*enx2 + ez=ez*ex + ey=ey*ex + else + if(sox.lt.zero) then + ez=cunit + ez2=abs(ez)**2 + else + ex2=one/(one+abs(-e11/e12)**2) + ex=sqrt(ex2) + ey=-ex*e11/e12 + ey2=abs(ey)**2 + ez2=zero + end if + end if +! +end subroutine warmdisp +! +! +! +subroutine diel_tens_fr(xg,yg,mu,npl,e330,epsl,lrm,fast) +! Fully relativistic case computation of dielectric tensor elements +! up to third order in Larmor radius for hermitian part +! + use math, only : fact + implicit none +! arguments + integer :: lrm,fast + real(wp_) :: xg,yg,mu,npl + complex(wp_) :: e330 + complex(wp_), dimension(3,3,lrm) :: epsl +! local variables + integer :: i,j,l,is,k,lm + real(wp_) :: cr,ci + real(wp_) :: npl2,dnl,w,asl,bsl,cmxw,fal + real(wp_), dimension(-lrm:lrm,0:2,0:lrm) :: rr + real(wp_), dimension(lrm,0:2,lrm) :: ri + complex(wp_) :: ca11,ca12,ca22,ca13,ca23,ca33,cq0p,cq0m,cq1p,cq1m,cq2p +! + npl2=npl**2 + dnl=one-npl2 +! + cmxw=one+15.0_wp_/(8.0_wp_*mu)+105.0_wp_/(128.0_wp_*mu**2) + cr=-mu*mu/(sqrt_pi*cmxw) + ci=sqrt(2.0_wp_*pi*mu)*mu**2/cmxw +! + do l=1,lrm + do j=1,3 + do i=1,3 + epsl(i,j,l)=czero + end do + end do + end do +! + select case(fast) + + case(2:3) + call hermitian(rr,yg,mu,npl,cr,fast,lrm) + + case(4:) + call hermitian_2(rr,yg,mu,npl,cr,fast,lrm) + + case default + write(*,*) "unexpected value for flag 'fast' in dispersion:", fast + + end select +! + call antihermitian(ri,yg,mu,npl,ci,lrm) +! + do l=1,lrm + lm=l-1 + fal=-0.25_wp_**l*fact(2*l)/(fact(l)**2*yg**(2*lm)) + ca11=czero + ca12=czero + ca13=czero + ca22=czero + ca23=czero + ca33=czero + do is=0,l + k=l-is + w=(-one)**k +! + asl=w/(fact(is+l)*fact(l-is)) + bsl=asl*(is*is+dble(2*k*lm*(l+is))/(2.0_wp_*l-one)) +! + if(is.gt.0) then + cq0p=rr(is,0,l)+rr(-is,0,l)+im*ri(is,0,l) + cq0m=rr(is,0,l)-rr(-is,0,l)+im*ri(is,0,l) + cq1p=rr(is,1,l)+rr(-is,1,l)+im*ri(is,1,l) + cq1m=rr(is,1,l)-rr(-is,1,l)+im*ri(is,1,l) + cq2p=rr(is,2,l)+rr(-is,2,l)+im*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 +! + 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) = + im*xg*ca12*fal + epsl(2,2,l) = - xg*ca22*fal + epsl(1,3,l) = - xg*ca13*fal + epsl(2,3,l) = - im*xg*ca23*fal + epsl(3,3,l) = - xg*ca33*fal + end do +! + cq2p=rr(0,2,0) + e330=one+xg*cq2p +! + epsl(1,1,1) = one + epsl(1,1,1) + epsl(2,2,1) = one + epsl(2,2,1) +! + 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 +! +end subroutine diel_tens_fr +! +! +! +subroutine hermitian(rr,yg,mu,npl,cr,fast,lrm) + use eierf, only : calcei3 + implicit none +! arguments + integer :: lrm,fast + real(wp_) :: yg,mu,npl,cr + real(wp_), dimension(-lrm:lrm,0:2,0:lrm) :: rr +! local variables + integer :: i,k,n,n1,nn,m,llm + real(wp_) :: mu2,mu4,mu6,npl2,npl4,bth,bth2,bth4,bth6,t,rxt,upl2, & + upl,gx,exdx,x,gr,s,zm,zm2,zm3,fe0m,ffe,sy1,sy2,sy3 +! + do n=-lrm,lrm + do k=0,2 + do m=0,lrm + rr(n,k,m)=zero + end do + end do + end do +! + llm=min(3,lrm) +! + bth2=2.0_wp_/mu + bth=sqrt(bth2) + mu2=mu*mu + mu4=mu2*mu2 + mu6=mu4*mu2 +! + do i = 1, npts+1 + t = ttv(i) + rxt=sqrt(one+t*t/(2.0_wp_*mu)) + x = t*rxt + upl2=bth2*x**2 + upl=bth*x + gx=one+t*t/mu + exdx=cr*extv(i)*gx/rxt*dtex +! + n1=1 + if(fast.gt.2) n1=-llm +! + do n=n1,llm + nn=abs(n) + gr=npl*upl+n*yg + zm=-mu*(gx-gr) + s=mu*(gx+gr) + zm2=zm*zm + zm3=zm2*zm + call calcei3(zm,fe0m) +! + 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) then + ffe=(one+s*(one-zm*fe0m))/mu2 + else if (m.eq.2) then + ffe=(6.0_wp_-2.0_wp_*zm+4.0_wp_*s+s*s*(one+zm-zm2*fe0m))/mu4 + else + ffe=(18.0_wp_*s*(s+4.0_wp_-zm)+6.0_wp_* & + (20.0_wp_-8.0_wp_*zm+zm2)+s**3*(2.0_wp_+zm+zm2-zm3*fe0m))/mu6 + end if +! + 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 +! + end do + end do + end do +! + if(fast.gt.2) return +! + sy1=one+yg + sy2=one+yg*2.0_wp_ + sy3=one+yg*3.0_wp_ +! + bth4=bth2*bth2 + bth6=bth4*bth2 +! + npl2=npl*npl + npl4=npl2*npl2 +! + rr(0,2,0) = -(one+bth2*(-1.25_wp_+1.5_wp_*npl2) & + +bth4*(1.71875_wp_-6.0_wp_*npl2+3.75_wp_*npl2*npl2) & + +bth6*3.0_wp_*(-65.0_wp_+456.0_wp_*npl2-660.0_wp_*npl4 & + +280.0_wp_*npl2*npl4)/64.0_wp_+bth6*bth2*15.0_wp_ & + *(252.853e3_wp_-2850.816e3_wp_*npl2+6942.720e3_wp_*npl4 & + -6422.528e3_wp_*npl4*npl2+2064.384e3_wp_*npl4*npl4) & + /524.288e3_wp_) + rr(0,1,1) = -npl*bth2*(one+bth2*(-2.25_wp_+1.5_wp_*npl2) & + +bth4*9.375e-2_wp_*(6.1e1_wp_-9.6e1_wp_*npl2+4.e1_wp_*npl4 & + +bth2*(-184.5_wp_+4.92e2_wp_*npl2-4.5e2_wp_*npl4 & + +1.4e2_wp_*npl2*npl4))) + rr(0,2,1) = -bth2*(one+bth2*(-0.5_wp_+1.5_wp_*npl2)+0.375_wp_*bth4 & + *(3.0_wp_-15.0_wp_*npl2+10.0_wp_*npl4)+3.0_wp_*bth6 & + *(-61.0_wp_+471.0_wp_*npl2-680*npl4+280.0_wp_*npl2*npl4) & + /64.0_wp_) + rr(-1,0,1) = -2.0_wp_/sy1*(one+bth2/sy1*(-1.25_wp_+0.5_wp_*npl2/sy1) & + +bth4/sy1*(-0.46875_wp_+(2.1875_wp_+0.625_wp_*npl2)/sy1 & + -2.625_wp_*npl2/sy1**2+0.75_wp_*npl4/sy1**3)+bth6/sy1 & + *(0.234375_wp_+(1.640625_wp_+0.234375_wp_*npl2)/sy1 & + +(-4.921875_wp_-4.921875_wp_*npl2)/sy1**2 & + +2.25_wp_*npl2*(5.25_wp_+npl2)/sy1**3 - 8.4375_wp_*npl4/sy1**4 & + +1.875_wp_*npl2*npl4/sy1**5)+bth6*bth2/sy1*(0.019826889038*sy1 & + -0.06591796875_wp_+(-0.7177734375_wp_ - 0.1171875_wp_*npl2)/sy1 & + +(-5.537109375_wp_ - 2.4609375_wp_*npl2)/sy1**2 & + +(13.53515625_wp_ + 29.53125_wp_*npl2 + 2.8125_wp_*npl4)/sy1**3 & + +(-54.140625_wp_*npl2 - 32.6953125_wp_*npl4)/sy1**4 & + +(69.609375_wp_*npl4 + 9.84375_wp_*npl2*npl4)/sy1**5 & + -36.09375_wp_*npl2*npl4/sy1**6 + 6.5625_wp_*npl4**2/sy1**7)) + rr(-1,1,1) = -npl*bth2/sy1**2*(one+bth2*(1.25_wp_-3.5_wp_/sy1 & + +1.5_wp_*npl2/sy1**2)+bth4*9.375e-2_wp_*((5.0_wp_-7.e1_wp_/sy1 & + +(126.0_wp_+48.0_wp_*npl2)/sy1**2-144.0_wp_*npl2/sy1**3 & + +4.e1_wp_*npl4/sy1**4)+bth2*(-2.5_wp_-3.5e1_wp_/sy1+(3.15e2_wp_ & + +6.e1_wp_*npl2)/sy1**2+(-4.62e2_wp_-5.58e2_wp_*npl2)/sy1**3 & + +(9.9e2_wp_*npl2+2.1e2_wp_*npl4)/sy1**4-6.6e2_wp_*npl4/sy1**5+ & + 1.4e2_wp_*npl4*npl2/sy1**6))) + rr(-1,2,1) = -bth2/sy1*(one+bth2*(1.25_wp_-1.75_wp_/sy1+1.5_wp_*npl2/sy1**2) & + +bth4*3.0_wp_/32.0_wp_*(5.0_wp_-35.0_wp_/sy1 & + +(42.0_wp_+48.0_wp_*npl2)/sy1**2-108.0_wp_*npl2/sy1**3 & + +40.0_wp_*npl4/sy1**4+0.5_wp_*bth2*(-5.0_wp_-35.0_wp_/sy1 & + +(21.e1_wp_+12.e1_wp_*npl2)/sy1**2-(231.0_wp_+837.0_wp_*npl2) & + /sy1**3+12.0_wp_*npl2*(99.0_wp_+35.0_wp_*npl2)/sy1**4 & + -1100.0_wp_*npl4/sy1**5 + 280.0_wp_*npl2*npl4/sy1**6))) +! + if(llm.gt.1) then +! + rr(0,0,2) = -4.0_wp_*bth2*(one+bth2*(-0.5_wp_+0.5_wp_*npl2)+bth4 & + *(1.125_wp_-1.875_wp_*npl2+0.75_wp_*npl4)+bth6*3.0_wp_ & + *(-61.0_wp_+157.0_wp_*npl2-136.0_wp_*npl4+40.0_wp_*npl2*npl4) & + /64.0_wp_) + rr(0,1,2) = -2.0_wp_*npl*bth4*(one+bth2*(-1.5_wp_+1.5_wp_*npl2)+bth4 & + *(39.0_wp_-69.0_wp_*npl2+30.0_wp_*npl4)/8.0_wp_) + rr(0,2,2) = -2.0_wp_*bth4*(one+bth2*(0.75_wp_+1.5_wp_*npl2)+bth4* & + (13.0_wp_-48.0_wp_*npl2 +40.0_wp_*npl4)*3.0_wp_/32.0_wp_) + rr(-1,0,2) = -4.0_wp_*bth2/sy1*(one+bth2* & + (1.25_wp_-1.75_wp_/sy1+0.5_wp_*npl2/sy1**2)+bth4* & + (0.46875_wp_-3.28125_wp_/sy1+(3.9375_wp_+1.5_wp_*npl2)/sy1**2 & + -3.375_wp_*npl2/sy1**3+0.75_wp_*npl4/sy1**4) & + +bth4*bth2*3.0_wp_/64.0_wp_*(-5.0_wp_-35.0_wp_/sy1 & + +(210.0_wp_+40.0_wp_*npl2)/sy1**2-3.0_wp_* & + (77.0_wp_+93.0_wp_*npl2)/sy1**3+(396.0*npl2+84.0_wp_*npl4) & + /sy1**4-220.0_wp_*npl4/sy1**5+40.0_wp_*npl4*npl2/sy1**6)) + rr(-1,1,2) = -2.0_wp_*bth4*npl/sy1**2*(one+bth2 & + *(3.0_wp_-4.5_wp_/sy1+1.5_wp_*npl2/sy1**2)+bth4 & + *(20.0_wp_-93.0_wp_/sy1+(99.0_wp_+42.0_wp_*npl2)/sy1**2 & + -88.0_wp_*npl2/sy1**3+20.0_wp_*npl4/sy1**4)*3.0_wp_/16.0_wp_) + rr(-1,2,2) = -2.0_wp_*bth4/sy1*(one+bth2 & + *(3.0_wp_-2.25_wp_/sy1+1.5_wp_*npl2/sy1**2)+bth4 & + *(40.0_wp_*npl4/sy1**4-132.0_wp_*npl2/sy1**3 & + +(66.0_wp_+84.0_wp_*npl2)/sy1**2-93.0_wp_/sy1+40.0_wp_) & + *3.0_wp_/32.0_wp_) + rr(-2,0,2) = -4.0_wp_*bth2/sy2*(one+bth2 & + *(1.25_wp_-1.75_wp_/sy2+0.5_wp_*npl2/sy2**2)+bth4 & + *(0.46875_wp_-3.28125_wp_/sy2+(3.9375_wp_+1.5_wp_*npl2) & + /sy2**2-3.375_wp_*npl2/sy2**3+0.75_wp_*npl4/sy2**4)+bth4*bth2 & + *3.0_wp_/64.0_wp_*(-5.0_wp_-35.0_wp_/sy2 & + +(210.0_wp_+40.0_wp_*npl2)/sy2**2-3.0_wp_ & + *(77.0_wp_+93.0_wp_*npl2)/sy2**3 & + +(396.0*npl2+84.0_wp_*npl4)/sy2**4-220.0_wp_*npl4/sy2**5 & + +40.0_wp_*npl4*npl2/sy2**6)) + rr(-2,1,2) =-2.0_wp_*bth4*npl/sy2**2*(one+bth2 & + *(3.0_wp_-4.5_wp_/sy2+1.5_wp_*npl2/sy2**2)+bth4 & + *(20.0_wp_-93.0_wp_/sy2+(99.0_wp_+42.0_wp_*npl2)/sy2**2 & + -88.0_wp_*npl2/sy2**3+20.0_wp_*npl4/sy2**4)*3.0_wp_/16.0_wp_) + rr(-2,2,2) = -2.0_wp_*bth4/sy2*(one+bth2 & + *(3.0_wp_-2.25_wp_/sy2+1.5_wp_*npl2/sy2**2)+bth4 & + *(40.0_wp_*npl4/sy2**4-132.0_wp_*npl2/sy2**3 & + +(66.0_wp_+84.0_wp_*npl2)/sy2**2-93.0_wp_/sy2+40.0_wp_) & + *3.0_wp_/32.0_wp_) +! + if(llm.gt.2) then +! + rr(0,0,3) = -12.0_wp_*bth4*(one+bth2*(0.75_wp_+0.5_wp_*npl2)+bth4 & + *(1.21875_wp_-1.5_wp_*npl2+0.75_wp_*npl2*npl2)) + rr(0,1,3) = -6.0_wp_*npl*bth6*(1+bth2*(-0.25_wp_+1.5_wp_*npl2)) + rr(0,2,3) = -6.0_wp_*bth6*(one+bth2*(2.5_wp_+1.5_wp_*npl2)) + rr(-1,0,3) = -12.0_wp_*bth4/sy1*(one+bth2 & + *(3.0_wp_-2.25_wp_/sy1+0.5_wp_*npl2/sy1**2)+bth4 & + *(3.75_wp_-8.71875_wp_/sy1+(6.1875_wp_+2.625_wp_*npl2) & + /sy1**2-4.125_wp_*npl2/sy1**3+0.75*npl2*npl2/sy1**4)) + rr(-1,1,3) = -6.0_wp_*npl*bth6/sy1**2* & + (one+bth2*(5.25_wp_-5.5_wp_/sy1+1.5_wp_*npl2/sy1**2)) + rr(-1,2,3) = -6.0_wp_*bth6/sy1* & + (one+bth2*(5.25_wp_-2.75_wp_/sy1+1.5_wp_*npl2/sy1**2)) +! + rr(-2,0,3) = -12.0_wp_*bth4/sy2 & + *(one+bth2*(3.0_wp_-2.25_wp_/sy2+0.5_wp_*npl2/sy2**2) & + +bth4*(3.75_wp_-8.71875_wp_/sy2+(6.1875_wp_+2.625_wp_*npl2) & + /sy2**2-4.125_wp_*npl2/sy2**3+0.75*npl2*npl2/sy2**4)) + rr(-2,1,3) = -6.0_wp_*npl*bth6/sy2**2 & + *(one+bth2*(5.25_wp_-5.5_wp_/sy2+1.5_wp_*npl2/sy2**2)) + rr(-2,2,3) = -6.0_wp_*bth6/sy2 & + *(one+bth2*(5.25_wp_-2.75_wp_/sy2+1.5_wp_*npl2/sy2**2)) +! + rr(-3,0,3) = -12.0_wp_*bth4/sy3 & + *(one+bth2*(3.0_wp_-2.25_wp_/sy3+0.5_wp_*npl2/sy3**2) & + +bth4*(3.75_wp_-8.71875_wp_/sy3+(6.1875_wp_+2.625_wp_*npl2) & + /sy3**2-4.125_wp_*npl2/sy3**3+0.75*npl2*npl2/sy3**4)) + rr(-3,1,3) = -6.0_wp_*npl*bth6/sy3**2 & + *(one+bth2*(5.25_wp_-5.5_wp_/sy3+1.5_wp_*npl2/sy3**2)) + rr(-3,2,3) = -6.0_wp_*bth6/sy3 & + *(one+bth2*(5.25_wp_-2.75_wp_/sy3+1.5_wp_*npl2/sy3**2)) +! + end if + end if +! +end subroutine hermitian +! +! +! +subroutine hermitian_2(rr,yg,mu,npl,cr,fast,lrm) + use quadpack, only : dqagsmv !dqagimv + implicit none +! local constants + integer,parameter :: lw=5000,liw=lw/4,npar=7 + real(wp_), parameter :: epsa=zero,epsr=1.0e-4_wp_ +! arguments + integer :: lrm,fast + real(wp_) :: yg,mu,npl,cr + real(wp_), dimension(-lrm:lrm,0:2,0:lrm) :: rr +! local variables + integer :: n,m,ih,k,n1,nn,llm,neval,ier,last,ihmin + integer, dimension(liw) :: iw + real(wp_) :: mu2,mu4,mu6,npl2,bth,bth2,bth4,bth6 + real(wp_) :: sy1,sy2,sy3,resfh,epp + real(wp_), dimension(lw) :: w + real(wp_), dimension(npar) :: apar +! + do n=-lrm,lrm + do k=0,2 + do m=0,lrm + rr(n,k,m)=zero + end do + end do + end do +! + llm=min(3,lrm) +! + bth2=2.0_wp_/mu + bth=sqrt(bth2) + mu2=mu*mu + mu4=mu2*mu2 + mu6=mu4*mu2 +! + n1=1 + if(fast.gt.10) n1=-llm +! + apar(1) = yg + apar(2) = mu + apar(3) = npl + apar(4) = cr +! + do n=n1,llm + nn=abs(n) + apar(5) = real(n,wp_) + do m=nn,llm + apar(6) = real(m,wp_) + ihmin=0 + if(n.eq.0.and.m.eq.0) ihmin=2 + do ih=ihmin,2 + apar(7) = real(ih,wp_) +! call dqagimv(fhermit,bound,2,apar,npar,epsa,epsr,resfh, + call dqagsmv(fhermit,-tmax,tmax,apar,npar,epsa,epsr,resfh, & + epp,neval,ier,liw,lw,last,iw,w) + rr(n,ih,m) = resfh + end do + end do + end do + + if(fast.gt.10) return +! + sy1=one+yg + sy2=one+yg*2.0_wp_ + sy3=one+yg*3.0_wp_ +! + bth4=bth2*bth2 + bth6=bth4*bth2 +! + npl2=npl*npl +! + rr(0,2,0) = -(one+bth2*(-1.25_wp_+1.5_wp_*npl2) & + +bth4*(1.71875_wp_-6.0_wp_*npl2+3.75_wp_*npl2*npl2)) + rr(0,1,1) = -npl*bth2*(one+bth2*(-2.25_wp_+1.5_wp_*npl2)) + rr(0,2,1) = -bth2*(one+bth2*(-0.5_wp_+1.5_wp_*npl2)) + rr(-1,0,1) = -2.0_wp_/sy1*(one+bth2/sy1*(-1.25_wp_+0.5_wp_*npl2 & + /sy1)+bth4/sy1*(-0.46875_wp_+(2.1875_wp_+0.625_wp_*npl2) & + /sy1-2.625_wp_*npl2/sy1**2+0.75_wp_*npl2*npl2/sy1**3)) + rr(-1,1,1) = -npl*bth2/sy1**2*(one+bth2*(1.25_wp_-3.5_wp_/sy1 & + +1.5_wp_*npl2/sy1**2)) + rr(-1,2,1) = -bth2/sy1*(one+bth2*(1.25_wp_-1.75_wp_/sy1+1.5_wp_ & + *npl2/sy1**2)) +! + if(llm.gt.1) then +! + rr(0,0,2) = -4.0_wp_*bth2*(one+bth2*(-0.5_wp_+0.5_wp_*npl2) & + +bth4*(1.125_wp_-1.875_wp_*npl2+0.75_wp_*npl2*npl2)) + rr(0,1,2) = -2.0_wp_*npl*bth4*(one+bth2*(-1.5_wp_+1.5_wp_*npl2)) + rr(0,2,2) = -2.0_wp_*bth4*(one+bth2*(0.75_wp_+1.5_wp_*npl2)) + rr(-1,0,2) = -4.0_wp_*bth2/sy1*(one+bth2 & + *(1.25_wp_-1.75_wp_/sy1+0.5_wp_*npl2/sy1**2)+bth4 & + *(0.46875_wp_-3.28125_wp_/sy1+(3.9375_wp_+1.5_wp_*npl2) & + /sy1**2-3.375_wp_*npl2/sy1**3+0.75_wp_*npl2*npl2/sy1**4)) + rr(-1,1,2) = -2.0_wp_*bth4*npl/sy1**2*(one+bth2 & + *(3.0_wp_-4.5_wp_/sy1+1.5_wp_*npl2/sy1**2)) + rr(-1,2,2) = -2.0_wp_*bth4/sy1*(one+bth2 & + *(3.0_wp_-2.25_wp_/sy1+1.5_wp_*npl2/sy1**2)) + rr(-2,0,2) = -4.0_wp_*bth2/sy2*(one+bth2 & + *(1.25_wp_-1.75_wp_/sy2+0.5_wp_*npl2/sy2**2)+bth4 & + *(0.46875_wp_-3.28125_wp_/sy2+(3.9375_wp_+1.5_wp_*npl2) & + /sy2**2-3.375_wp_*npl2/sy2**3+0.75_wp_*npl2*npl2/sy2**4)) + rr(-2,1,2) = -2.0_wp_*bth4*npl/sy2**2*(one+bth2 & + *(3.0_wp_-4.5_wp_/sy2+1.5_wp_*npl2/sy2**2)) + rr(-2,2,2) = -2.0_wp_*bth4/sy2*(one+bth2 & + *(3.0_wp_-2.25_wp_/sy2+1.5_wp_*npl2/sy2**2)) +! + if(llm.gt.2) then +! + rr(0,0,3) = -12.0_wp_*bth4*(1+bth2*(0.75_wp_+0.5_wp_*npl2)+bth4 & + *(1.21875_wp_-1.5_wp_*npl2+0.75_wp_*npl2*npl2)) + rr(0,1,3) = -6.0_wp_*npl*bth6*(1+bth2*(-0.25_wp_+1.5_wp_*npl2)) + rr(0,2,3) = -6.0_wp_*bth6*(1+bth2*(2.5_wp_+1.5_wp_*npl2)) + rr(-1,0,3) = -12.0_wp_*bth4/sy1 & + *(one+bth2*(3.0_wp_-2.25_wp_/sy1+0.5_wp_*npl2/sy1**2) & + +bth4*(3.75_wp_-8.71875_wp_/sy1 & + +(6.1875_wp_+2.625_wp_*npl2)/sy1**2 & + -4.125_wp_*npl2/sy1**3+0.75_wp_*npl2*npl2/sy1**4)) + rr(-1,1,3) = -6.0_wp_*npl*bth6/sy1**2 & + *(one+bth2*(5.25_wp_-5.5_wp_/sy1+1.5_wp_*npl2/sy1**2)) + rr(-1,2,3) = -6.0_wp_*bth6/sy1 & + *(one+bth2*(5.25_wp_-2.75_wp_/sy1+1.5_wp_*npl2/sy1**2)) +! + rr(-2,0,3) = -12.0_wp_*bth4/sy2 & + *(one+bth2*(3.0_wp_-2.25_wp_/sy2+0.5_wp_*npl2/sy2**2) & + +bth4*(3.75_wp_-8.71875_wp_/sy2 & + +(6.1875_wp_+2.625_wp_*npl2)/sy2**2 & + -4.125_wp_*npl2/sy2**3+0.75_wp_*npl2*npl2/sy2**4)) + rr(-2,1,3) = -6.0_wp_*npl*bth6/sy2**2 & + *(one+bth2*(5.25_wp_-5.5_wp_/sy2+1.5_wp_*npl2/sy2**2)) + rr(-2,2,3) = -6.0_wp_*bth6/sy2 & + *(one+bth2*(5.25_wp_-2.75_wp_/sy2+1.5_wp_*npl2/sy2**2)) +! + rr(-3,0,3) = -12.0_wp_*bth4/sy3 & + *(one+bth2*(3.0_wp_-2.25_wp_/sy3+0.5_wp_*npl2/sy3**2) & + +bth4*(3.75_wp_-8.71875_wp_/sy3 & + +(6.1875_wp_+2.625_wp_*npl2)/sy3**2 & + -4.125_wp_*npl2/sy3**3+0.75_wp_*npl2*npl2/sy3**4)) + rr(-3,1,3) = -6.0_wp_*npl*bth6/sy3**2 & + *(one+bth2*(5.25_wp_-5.5_wp_/sy3+1.5_wp_*npl2/sy3**2)) + rr(-3,2,3) = -6.0_wp_*bth6/sy3 & + *(one+bth2*(5.25_wp_-2.75_wp_/sy3+1.5_wp_*npl2/sy3**2)) +! + end if + end if +! +end subroutine hermitian_2 +! +! +! +function fhermit(t,apar,npar) + use eierf, only : calcei3 + implicit none +! arguments + integer, intent(in) :: npar + real(wp_), intent(in) :: t + real(wp_), dimension(npar), intent(in) :: apar +! local variables + integer :: n,m,ih + real(wp_) :: yg,mu,npl,cr,mu2,mu4,mu6,bth,bth2,rxt,x,upl2, & + upl,gx,exdxdt,gr,zm,s,zm2,zm3,fe0m,ffe,uplh +! external functions/subroutines + real(wp_) :: fhermit +! + yg = apar(1) + mu = apar(2) + npl = apar(3) + cr = apar(4) + n = int(apar(5)) + m = int(apar(6)) + ih = int(apar(7)) +! + bth2=2.0_wp_/mu + bth=sqrt(bth2) + mu2=mu*mu + mu4=mu2*mu2 + mu6=mu4*mu2 +! + rxt=sqrt(one+t*t/(2.0_wp_*mu)) + x = t*rxt + upl2=bth2*x**2 + upl=bth*x + gx=one+t*t/mu + exdxdt=cr*exp(-t*t)*gx/rxt + gr=npl*upl+n*yg + zm=-mu*(gx-gr) + s=mu*(gx+gr) + zm2=zm*zm + zm3=zm2*zm + call calcei3(zm,fe0m) + ffe=zero + uplh=upl**ih + if(n.eq.0.and.m.eq.0) ffe=exdxdt*fe0m*upl2 + if(m.eq.1) ffe=(one+s*(one-zm*fe0m))*uplh/mu2 + if(m.eq.2) ffe=(6.0_wp_-2.0_wp_*zm+4.0_wp_*s+s*s*(one+zm-zm2*fe0m))*uplh/mu4 + if(m.eq.3) ffe=(18.0_wp_*s*(s+4.0_wp_-zm)+6.0_wp_*(20.0_wp_-8.0_wp_*zm+zm2) & + +s**3*(2.0_wp_+zm+zm2-zm3*fe0m))*uplh/mu6 + fhermit= exdxdt*ffe +! +end function fhermit +! +! +! +subroutine antihermitian(ri,yg,mu,npl,ci,lrm) + use math, only : fact + implicit none +! local constants + integer, parameter :: lmx=20,nmx=lmx+2 +! arguments + integer :: lrm + real(wp_) :: yg,mu,npl,ci + real(wp_) :: ri(lrm,0:2,lrm) +! local variables + integer :: n,k,m,mm + real(wp_) :: cmu,npl2,dnl,ygn,rdu2,rdu,du,ub,aa,up,um,gp,gm,xp,xm, & + eep,eem,ee,cm,cim,fi0p0,fi1p0,fi2p0,fi0m0,fi1m0,fi2m0, & + fi0p1,fi1p1,fi2p1,fi0m1,fi1m1,fi2m1,fi0m,fi1m,fi2m + real(wp_), dimension(nmx) :: fsbi +! + do n=1,lrm + do k=0,2 + do m=1,lrm + ri(n,k,m)=zero + end do + end do + end do +! + npl2=npl*npl + dnl=one-npl2 + cmu=npl*mu +! + do n=1,lrm + ygn=n*yg + rdu2=ygn**2-dnl + if(rdu2.gt.zero) then + rdu=sqrt(rdu2) + du=rdu/dnl + ub=npl*ygn/dnl + aa=mu*npl*du + if (abs(aa).gt.5.0_wp_) then + up=ub+du + um=ub-du + gp=npl*up+ygn + gm=npl*um+ygn + xp=up+one/cmu + xm=um+one/cmu + eem=exp(-mu*(gm-one)) + eep=exp(-mu*(gp-one)) + fi0p0=-one/cmu + fi1p0=-xp/cmu + fi2p0=-(one/cmu**2+xp*xp)/cmu + fi0m0=-one/cmu + fi1m0=-xm/cmu + fi2m0=-(one/cmu**2+xm*xm)/cmu + do m=1,lrm + fi0p1=-2.0_wp_*m*(fi1p0-ub*fi0p0)/cmu + fi0m1=-2.0_wp_*m*(fi1m0-ub*fi0m0)/cmu + fi1p1=-((one+2.0_wp_*m)*fi2p0-2.0_wp_*(m+one)*ub*fi1p0 & + +up*um*fi0p0)/cmu + fi1m1=-((one+2.0_wp_*m)*fi2m0-2.0_wp_*(m+one)*ub*fi1m0 & + +up*um*fi0m0)/cmu + fi2p1=(2.0_wp_*(one+m)*fi1p1-2.0_wp_*m* & + (ub*fi2p0-up*um*fi1p0))/cmu + fi2m1=(2.0_wp_*(one+m)*fi1m1-2.0_wp_*m* & + (ub*fi2m0-up*um*fi1m0))/cmu + if(m.ge.n) then + ri(n,0,m)=0.5_wp_*ci*dnl**m*(fi0p1*eep-fi0m1*eem) + ri(n,1,m)=0.5_wp_*ci*dnl**m*(fi1p1*eep-fi1m1*eem) + ri(n,2,m)=0.5_wp_*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(-mu*(ygn-one+npl*ub)) + call ssbi(aa,n,lrm,fsbi) + do m=n,lrm + cm=sqrt_pi*fact(m)*du**(2*m+1) + cim=0.5_wp_*ci*dnl**m + mm=m-n+1 + fi0m=cm*fsbi(mm) + fi1m=-0.5_wp_*aa*cm*fsbi(mm+1) + fi2m=0.5_wp_*cm*(fsbi(mm+1)+0.5_wp_*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.0_wp_*du*ub*fi1m+ub*ub*fi0m) + end do + end if + end if + end do +! +end subroutine antihermitian +! +! +! +subroutine ssbi(zz,n,l,fsbi) + use math, only : gamm + implicit none +! local constants + integer, parameter :: lmx=20,nmx=lmx+2 + real(wp_), parameter :: eps=1.0e-10_wp_ +! arguments + integer :: n,l + real(wp_) :: zz + real(wp_), dimension(nmx) :: fsbi +! local variables + integer :: k,m,mm + real(wp_) :: c0,c1,sbi +! + do m=n,l+2 + c0=one/gamm(dble(m)+1.5_wp_) + sbi=c0 + do k=1,50 + c1=c0*0.25_wp_*zz**2/(dble(m+k)+0.5_wp_)/dble(k) + sbi=sbi+c1 + if(c1/sbi.lt.eps) exit + c0=c1 + end do + mm=m-n+1 + fsbi(mm)=sbi + end do +! +end subroutine ssbi +! +! +! +subroutine expinit + implicit none +! local variables + integer :: i +! + do i = 1, npts+1 + ttv(i) = -tmax+dble(i-1)*dtex + extv(i)=exp(-ttv(i)*ttv(i)) + end do +! +end subroutine expinit +! +! +! +subroutine diel_tens_wr(xg,yg,mu,npl,e330,epsl,lrm) +! Weakly relativistic dielectric tensor computation of dielectric +! tensor elements (Krivenki and Orefice, JPP 30,125 - 1983) +! + use math, only : fact + implicit none +! arguments + integer :: lrm + real(wp_) :: xg,yg,npl,mu + complex(wp_) :: e330,epsl(3,3,lrm) +! local variables + integer :: l,lm,is,k + real(wp_) :: npl2,fcl,w,asl,bsl + complex(wp_) :: ca11,ca12,ca13,ca22,ca23,ca33,cq0p,cq0m,cq1p,cq1m,cq2p + complex(wp_), dimension(0:lrm,0:2) :: cefp,cefm +! + npl2=npl*npl +! + call fsup(cefp,cefm,lrm,yg,npl,mu) +! + do l=1,lrm + lm=l-1 + fcl=0.5_wp_**l*((one/yg)**2/mu)**lm*fact(2*l)/fact(l) + ca11=czero + ca12=czero + ca13=czero + ca22=czero + ca23=czero + ca33=czero + do is=0,l + k=l-is + w=(-one)**k +! + asl=w/(fact(is+l)*fact(l-is)) + bsl=asl*(is*is+dble(2*k*lm*(l+is))/(2.0_wp_*l-one)) +! + cq0p=mu*cefp(is,0) + cq0m=mu*cefm(is,0) + cq1p=mu*npl*(cefp(is,0)-cefp(is,1)) + cq1m=mu*npl*(cefm(is,0)-cefm(is,1)) + cq2p=cefp(is,1)+mu*npl2*(cefp(is,2)+cefp(is,0)-2.0_wp_*cefp(is,1)) +! + 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*fcl + epsl(1,2,l) = +im*xg*ca12*fcl + epsl(2,2,l) = -xg*ca22*fcl + epsl(1,3,l) = -xg*ca13*fcl + epsl(2,3,l) = -im*xg*ca23*fcl + epsl(3,3,l) = -xg*ca33*fcl + end do +! + cq2p=cefp(0,1)+mu*npl2*(cefp(0,2)+cefp(0,0)-2.0_wp_*cefp(0,1)) + e330=one-xg*mu*cq2p +! + epsl(1,1,1) = one + epsl(1,1,1) + epsl(2,2,1) = one + epsl(2,2,1) +! + 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 +! +end subroutine diel_tens_wr +! +! +! +subroutine fsup(cefp,cefm,lrm,yg,npl,mu) + implicit none +! local constants + real(wp_), parameter :: apsicr=0.7_wp_ +! arguments + integer :: lrm + real(wp_) :: yg,npl,mu + complex(wp_), dimension(0:lrm,0:2) :: cefp,cefm +! local variables + integer :: is,l,iq,ir,iflag + real(wp_) :: psi,apsi,alpha,phi2,phim,xp,yp,xm,ym,x0,y0, & + zrp,zip,zrm,zim,zr0,zi0 + complex(wp_) :: czp,czm,cf12,cf32,cphi,cz0,cdz0,cf0,cf1,cf2 +! + psi=sqrt(0.5_wp_*mu)*npl + apsi=abs(psi) +! + do is=0,lrm + alpha=npl*npl/2.0_wp_+is*yg-one + phi2=mu*alpha + phim=sqrt(abs(phi2)) + if (alpha.ge.0) then + xp=psi-phim + yp=zero + xm=-psi-phim + ym=zero + x0=-phim + y0=zero + else + xp=psi + yp=phim + xm=-psi + ym=phim + x0=zero + y0=phim + end if + call zetac (xp,yp,zrp,zip,iflag) + call zetac (xm,ym,zrm,zim,iflag) +! + czp=dcmplx(zrp,zip) + czm=dcmplx(zrm,zim) + cf12=czero + if (alpha.ge.0) then + if (alpha.ne.0) cf12=-(czp+czm)/(2.0_wp_*phim) + else + cf12=-im*(czp+czm)/(2.0_wp_*phim) + end if +! + if(apsi.gt.apsicr) then + cf32=-(czp-czm)/(2.0_wp_*psi) + else + cphi=phim + if(alpha.lt.0) cphi=-im*phim + call zetac (x0,y0,zr0,zi0,iflag) + cz0=dcmplx(zr0,zi0) + cdz0=2.0_wp_*(one-cphi*cz0) + cf32=cdz0 + end if +! + 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=(one+phi2*cf0-(iq+0.5_wp_)*cf1)/psi**2 + else + cf2=(one+phi2*cf1)/dble(iq+1.5_wp_) + 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 +! + if(is.ne.0) then +! + alpha=npl*npl/2.0_wp_-is*yg-one + phi2=mu*alpha + phim=sqrt(abs(phi2)) + if (alpha.ge.zero) then + xp=psi-phim + yp=zero + xm=-psi-phim + ym=zero + x0=-phim + y0=zero + else + xp=psi + yp=phim + xm=-psi + ym=phim + x0=zero + y0=phim + end if + call zetac (xp,yp,zrp,zip,iflag) + call zetac (xm,ym,zrm,zim,iflag) +! + czp=dcmplx(zrp,zip) + czm=dcmplx(zrm,zim) +! + cf12=czero + if (alpha.ge.0) then + if (alpha.ne.zero) cf12=-(czp+czm)/(2.0_wp_*phim) + else + cf12=-im*(czp+czm)/(2.0_wp_*phim) + end if + if(apsi.gt.apsicr) then + cf32=-(czp-czm)/(2.0_wp_*psi) + else + cphi=phim + if(alpha.lt.0) cphi=-im*phim + call zetac (x0,y0,zr0,zi0,iflag) + cz0=dcmplx(zr0,zi0) + cdz0=2.0_wp_*(one-cphi*cz0) + cf32=cdz0 + end if +! + cf0=cf12 + cf1=cf32 + do l=1,is+2 + iq=l-1 + if(apsi.gt.apsicr) then + cf2=(one+phi2*cf0-(iq+0.5_wp_)*cf1)/psi**2 + else + cf2=(one+phi2*cf1)/dble(iq+1.5_wp_) + 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 +! + end if +! + end do +! +end subroutine fsup + +! +! PLASMA DISPERSION FUNCTION Z of complex argument +! Z(z) = i sqrt(pi) w(z) +! Function w(z) from: +! algorithm 680, collected algorithms from acm. +! this work published in transactions on mathematical software, +! vol. 16, no. 1, pp. 47. +! + subroutine zetac (xi, yi, zr, zi, iflag) +! +! given a complex number z = (xi,yi), this subroutine computes +! the value of the faddeeva-function w(z) = exp(-z**2)*erfc(-i*z), +! where erfc is the complex complementary error-function and i +! means sqrt(-1). +! the accuracy of the algorithm for z in the 1st and 2nd quadrant +! is 14 significant digits; in the 3rd and 4th it is 13 significant +! digits outside a circular region with radius 0.126 around a zero +! of the function. +! all real variables in the program are real(8). +! +! +! the code contains a few compiler-dependent parameters : +! rmaxreal = the maximum value of rmaxreal equals the root of +! rmax = the largest number which can still be +! implemented on the computer in real(8) +! floating-point arithmetic +! rmaxexp = ln(rmax) - ln(2) +! rmaxgoni = the largest possible argument of a real(8) +! goniometric function (cos, sin, ...) +! the reason why these parameters are needed as they are defined will +! be explained in the code by means of comments +! +! +! parameter list +! xi = real part of z +! yi = imaginary part of z +! u = real part of w(z) +! v = imaginary part of w(z) +! iflag = an error flag indicating whether overflow will +! occur or not; type integer; +! the values of this variable have the following +! meaning : +! iflag=0 : no error condition +! iflag=1 : overflow will occur, the routine +! becomes inactive +! xi, yi are the input-parameters +! u, v, iflag are the output-parameters +! +! furthermore the parameter factor equals 2/sqrt(pi) +! +! the routine is not underflow-protected but any variable can be +! put to 0 upon underflow; +! +! reference - gpm poppe, cmj wijers; more efficient computation of +! the complex error-function, acm trans. math. software. +! + implicit none + real(wp_), intent(in) :: xi, yi + real(wp_), intent(out) :: zr, zi + integer, intent(out) :: iflag + real(wp_) :: xabs,yabs,x,y,qrho,xabsq,xquad,yquad,xsum,ysum,xaux,daux, & + u,u1,u2,v,v1,v2,h,h2,qlambda,c,rx,ry,sx,sy,tx,ty,w1 + integer :: i,j,n,nu,kapn,np1 + real(wp_), parameter :: factor = 1.12837916709551257388_wp_, & + rpi = 2.0_wp_/factor, & + rmaxreal = 0.5e+154_wp_, & + rmaxexp = 708.503061461606_wp_, & + rmaxgoni = 3.53711887601422e+15_wp_ + iflag=0 + xabs = abs(xi) + yabs = abs(yi) + x = xabs/6.3_wp_ + y = yabs/4.4_wp_ +! +! the following if-statement protects +! qrho = (x**2 + y**2) against overflow +! + if ((xabs>rmaxreal).or.(yabs>rmaxreal)) then + iflag=1 + return + end if + qrho = x**2 + y**2 + xabsq = xabs**2 + xquad = xabsq - yabs**2 + yquad = 2*xabs*yabs + if (qrho<0.085264_wp_) then +! +! if (qrho<0.085264_wp_) then the faddeeva-function is evaluated +! using a power-series (abramowitz/stegun, equation (7.1.5), p.297) +! n is the minimum number of terms needed to obtain the required +! accuracy +! + qrho = (1-0.85_wp_*y)*sqrt(qrho) + n = idnint(6 + 72*qrho) + j = 2*n+1 + xsum = 1.0_wp_/j + ysum = 0.0_wp_ + do i=n, 1, -1 + j = j - 2 + xaux = (xsum*xquad - ysum*yquad)/i + ysum = (xsum*yquad + ysum*xquad)/i + xsum = xaux + 1.0_wp_/j + end do + u1 = -factor*(xsum*yabs + ysum*xabs) + 1.0_wp_ + v1 = factor*(xsum*xabs - ysum*yabs) + daux = exp(-xquad) + u2 = daux*cos(yquad) + v2 = -daux*sin(yquad) + u = u1*u2 - v1*v2 + v = u1*v2 + v1*u2 + else +! +! if (qrho>1.o) then w(z) is evaluated using the laplace +! continued fraction +! nu is the minimum number of terms needed to obtain the required +! accuracy +! +! if ((qrho>0.085264_wp_).and.(qrho<1.0)) then w(z) is evaluated +! by a truncated taylor expansion, where the laplace continued fraction +! is used to calculate the derivatives of w(z) +! kapn is the minimum number of terms in the taylor expansion needed +! to obtain the required accuracy +! nu is the minimum number of terms of the continued fraction needed +! to calculate the derivatives with the required accuracy +! + if (qrho>1.0_wp_) then + h = 0.0_wp_ + kapn = 0 + qrho = sqrt(qrho) + nu = idint(3 + (1442/(26*qrho+77))) + else + qrho = (1-y)*sqrt(1-qrho) + h = 1.88_wp_*qrho + h2 = 2*h + kapn = idnint(7 + 34*qrho) + nu = idnint(16 + 26*qrho) + endif + if (h>0.0_wp_) qlambda = h2**kapn + rx = 0.0_wp_ + ry = 0.0_wp_ + sx = 0.0_wp_ + sy = 0.0_wp_ + do n=nu, 0, -1 + np1 = n + 1 + tx = yabs + h + np1*rx + ty = xabs - np1*ry + c = 0.5_wp_/(tx**2 + ty**2) + rx = c*tx + ry = c*ty + if ((h>0.0_wp_).and.(n<=kapn)) then + tx = qlambda + sx + sx = rx*tx - ry*sy + sy = ry*tx + rx*sy + qlambda = qlambda/h2 + endif + end do + if (h==0.0_wp_) then + u = factor*rx + v = factor*ry + else + u = factor*sx + v = factor*sy + end if + if (yabs==0.0_wp_) u = exp(-xabs**2) + end if +! +! evaluation of w(z) in the other quadrants +! + if (yi<0.0_wp_) then + if (qrho<0.085264_wp_) then + u2 = 2*u2 + v2 = 2*v2 + else + xquad = -xquad +! +! the following if-statement protects 2*exp(-z**2) +! against overflow +! + if ((yquad>rmaxgoni).or. (xquad>rmaxexp)) then + iflag=1 + return + end if + w1 = 2.0_wp_*exp(xquad) + u2 = w1*cos(yquad) + v2 = -w1*sin(yquad) + end if + u = u2 - u + v = v2 - v + if (xi>0.0_wp_) v = -v + else + if (xi<0.0_wp_) v = -v + end if + zr = -v*rpi + zi = u*rpi + end subroutine zetac +! +end module dispersion \ No newline at end of file diff --git a/src/eccd.f90 b/src/eccd.f90 new file mode 100644 index 0000000..ed71c1c --- /dev/null +++ b/src/eccd.f90 @@ -0,0 +1,888 @@ +module eccd + use const_and_precisions, only : wp_ + implicit none + real(wp_), parameter, private :: cst2min=1.0e-6_wp_ ! min width of trap. cone + integer, parameter, private :: nfpp=13, & ! number of extra parameters passed + nfpp1=nfpp+ 1, nfpp2=nfpp+ 2, & ! to the integrand function fpp + nfpp3=nfpp+ 3, nfpp4=nfpp+ 4, & + nfpp5=nfpp+ 5 +!######################################################################## +! the following parameters are used by N.M. subroutines: +! The module contains few subroutines which are requested to calculate +! the current drive value by adjoint approach +!######################################################################## + CHARACTER, PRIVATE, PARAMETER :: adj_appr(1:6) = & ! adj. approach switcher + (/ 'l', & ! (1)='l': collisionless limit + ! (1)='c': collisional (classical) limit, + ! w/o trap. part. + 'm', & ! (2)='m': momentum conservation + ! (2)='h': high-speed limit +!--- + 'l', & ! DO NOT CHANGE! + 'r', & ! DO NOT CHANGE! + 'v', & ! DO NOT CHANGE! + 'i' /) ! DO NOT CHANGE! +!------- + REAL(wp_), PRIVATE :: r2,q2,gp1 ! coefficients for HSL integrand function +!------- + REAL(wp_), PRIVATE, PARAMETER :: delta = 1e-4 ! border for recalculation +!------- for N.M. subroutines (variational principle) ------- + REAL(wp_), PRIVATE :: sfd(1:4) ! polyn. exp. of the "Spitzer"-function + 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/)) +!######################################################################## + + interface setcdcoeff + module procedure setcdcoeff_notrap,setcdcoeff_cohen,setcdcoeff_ncl + end interface setcdcoeff + +contains + + subroutine setcdcoeff_notrap(zeff,cst2,eccdpar) + implicit none + real(wp_), intent(in) :: zeff + real(wp_), intent(out) :: cst2 + real(wp_), dimension(:), allocatable, intent(out) :: eccdpar + + cst2=0.0_wp_ + allocate(eccdpar(1)) + eccdpar(1)=zeff + end subroutine setcdcoeff_notrap + + subroutine setcdcoeff_cohen(zeff,rbn,rbx,cst2,eccdpar) +! cohen model +! rbn=B/B_min +! rbx=B/B_max +! cst2=1.0_wp_-B/B_max +! alams=sqrt(1-B_min/B_max) +! Zeff < 31 !!! +! fp0s= P_a (alams) + use conical, only : fconic + implicit none + real(wp_), intent(in) :: zeff,rbn,rbx + real(wp_), intent(out) :: cst2 + real(wp_), dimension(:), allocatable, intent(out) :: eccdpar + real(wp_) :: alams,pa,fp0s + + cst2=1.0_wp_-rbx + if(cst20) write(*,*) ' Hlambda profil =',ierr + npar=3+2*nlm + allocate(eccdpar(npar)) + eccdpar(1)=zeff + eccdpar(2) = fc + eccdpar(3) = rbx + eccdpar(4:3+nlm) = tlm + eccdpar(4+nlm:npar) = chlm + end subroutine setcdcoeff_ncl + + subroutine eccdeff(yg,anpl,anprre,dens,amu,ex,ey,ez,nhmn,nhmx, & + ithn,cst2,fcur,eccdpar,effjcd,iokhawa,ierr) + use const_and_precisions, only : pi,qesi=>e_,mesi=>me_, & + vcsi=>c_,qe=>ecgs_,me=>mecgs_,vc=>ccgs_,mc2=>mc2_ + use quadpack, only : dqagsmv + implicit none +! local constants + real(wp_), parameter :: mc2m2=1.0_wp_/mc2**2, & + canucc=2.0e13_wp_*pi*qe**4/(me**2*vc**3),ceff=qesi/(mesi*vcsi) + real(wp_), parameter :: epsa=0.0_wp_,epsr=1.0e-2_wp_,xxcr=16.0_wp_ + real(wp_), parameter :: dumin=1.0e-6_wp_ + integer, parameter :: lw=5000,liw=lw/4 +! arguments + integer :: i,nhmn,nhmx,ithn,iokhawa,ierr + real(wp_) :: yg,anpl,anprre,dens,amu,cst2,effjcd + real(wp_), dimension(:) :: eccdpar + complex(wp_) :: ex,ey,ez +! local variables + integer :: nhn,neval,ier,last,npar + integer, dimension(liw) :: iw + real(wp_) :: anpl2,dnl,ygn,ygn2,resji,rdu2,upltp,upltm,uplp,uplm, & + rdu,rdu2t,duu,uu1,uu2,xx1,xx2,resj,resp,eji,epp,anum,denom, & + cstrdut,anucc + real(wp_), dimension(lw) :: w + real(wp_), dimension(nfpp+size(eccdpar)) :: apar + real(wp_), dimension(0:1) :: uleft,uright +! common/external functions/variables + real(wp_), external :: fcur +! +! effjpl = / /(B_min/) [A m /W] +! + apar(1) = yg + apar(2) = anpl + apar(3) = amu + apar(4) = anprre + apar(5) = dble(ex) + apar(6) = dimag(ex) + apar(7) = dble(ey) + apar(8) = dimag(ey) + apar(9) = dble(ez) + apar(10) = dimag(ez) + apar(11) = dble(ithn) + + npar=size(apar) + apar(nfpp+1:npar) = eccdpar + + anpl2=anpl*anpl + + effjcd=0.0_wp_ + anum=0.0_wp_ + denom=0.0_wp_ + iokhawa=0 + ierr=0 + do nhn=nhmn,nhmx + ygn=nhn*yg + ygn2=ygn*ygn + + rdu2=anpl2+ygn2-1.0_wp_ + + if (rdu2.lt.0.0_wp_) cycle + rdu=sqrt(rdu2) + dnl=1.0_wp_-anpl2 + uplp=(anpl*ygn+rdu)/dnl + uplm=(anpl*ygn-rdu)/dnl + + uu1=uplm + uu2=uplp + xx1=amu*(anpl*uu1+ygn-1.0_wp_) + xx2=amu*(anpl*uu2+ygn-1.0_wp_) + + if(xx2.gt.xxcr) uu2=(xxcr/amu-ygn+1.0_wp_)/anpl + if(xx1.gt.xxcr) uu1=(xxcr/amu-ygn+1.0_wp_)/anpl + duu=abs(uu1-uu2) + + if(duu.le.dumin) cycle + + apar(12) = dble(nhn) + apar(13) = ygn + + call dqagsmv(fpp,uu1,uu2,apar(1:nfpp),nfpp,epsa,epsr,resp, & + epp,neval,ier,liw,lw,last,iw,w) + + if (ier.gt.0) then + ierr=90 + return + end if + + rdu2t=cst2*anpl2+ygn2-1.0_wp_ + + if (rdu2t.gt.0.0_wp_.and.cst2.gt.0.0_wp_) then +! +! resonance curve crosses the trapping region +! + iokhawa=1 + cstrdut=sqrt(cst2*rdu2t) + upltm=(cst2*anpl*ygn-cstrdut)/(1.0_wp_-cst2*anpl2) + upltp=(cst2*anpl*ygn+cstrdut)/(1.0_wp_-cst2*anpl2) + uleft(0)=uplm + uright(0)=upltm + uleft(1)=upltp + uright(1)=uplp + else +! +! resonance curve does not cross the trapping region +! + iokhawa=0 + uleft(0)=uplm + uright(0)=uplp + end if + + resj=0.0_wp_ +! do i=0,iokhawa + do i=0,1 + resji=0.0_wp_ + xx1=amu*(anpl*uleft(i)+ygn-1.0_wp_) + xx2=amu*(anpl*uright(i)+ygn-1.0_wp_) + if(xx1.lt.xxcr.or.xx2.lt.xxcr) then + if(xx2.gt.xxcr) uright(i)=(xxcr/amu-ygn+1.0_wp_)/anpl + if(xx1.gt.xxcr) uleft(i)=(xxcr/amu-ygn+1.0_wp_)/anpl + duu=abs(uleft(i)-uright(i)) + if(duu.gt.dumin) then + call dqagsmv(fcur,uleft(i),uright(i),apar,npar,epsa,epsr, & + resji,eji,neval,ier,liw,lw,last,iw,w) + if (ier.gt.0) then + if (abs(resji).lt.1.0e-10_wp_) then + resji=0.0_wp_ + else + ierr=91+iokhawa+i + return + end if + end if + end if + end if + resj=resj+resji + if(iokhawa.eq.0) exit + end do + anum=anum+resj + denom=denom+resp + end do + + if(denom.gt.0.0_wp_) then + anucc=canucc*dens*(48.0_wp_-log(1.0e7_wp_*dens*mc2m2*amu**2)) + effjcd=-ceff*anum/(anucc*denom) + end if + + end subroutine eccdeff + + function fpp(upl,extrapar,npar) +! +! computation of integral for power density, integrand function fpp +! +! ith=0 : polarization term = const +! ith=1 : polarization term Larmor radius expansion to lowest order +! ith=2 : full polarization term (J Bessel) +! +! integration variable upl passed explicitly. other variables passed +! as array of extra parameters of length npar=size(extrapar) +! +! extrapar(1) = yg +! extrapar(2) = anpl +! extrapar(3) = amu +! extrapar(4) = Re(anprw) +! extrapar(5) = Re(ex) +! extrapar(6) = Im(ex) +! extrapar(7) = Re(ey) +! extrapar(8) = Im(ey) +! extrapar(9) = Re(ez) +! extrapar(10) = Im(ez) +! extrapar(11) = double(ithn) +! extrapar(12) = double(nhn) +! extrapar(13) = ygn +! + use const_and_precisions, only : ui=>im + use math, only : fact + implicit none +! arguments + integer :: npar + real(wp_) :: upl,fpp + real(wp_), dimension(npar) :: extrapar +! local variables + integer :: ithn,nhn !,nm,np + real(wp_) :: yg,anpl,amu,anprre,ygn,upr,upr2,gam,ee,thn2,thn2u,bb,cth !, & +! ajbnm,ajbnp,ajbn + real(wp_), dimension(3) :: ajb + complex(wp_) :: ex,ey,ez,emxy,epxy + + yg=extrapar(1) + anpl=extrapar(2) + amu=extrapar(3) + anprre=extrapar(4) + ex=cmplx(extrapar(5),extrapar(6),wp_) + ey=cmplx(extrapar(7),extrapar(8),wp_) + ez=cmplx(extrapar(9),extrapar(10),wp_) + ithn=int(extrapar(11)) + nhn=int(extrapar(12)) + ygn=extrapar(13) + + gam=anpl*upl+ygn + upr2=gam*gam-1.0_wp_-upl*upl + ee=exp(-amu*(gam-1)) + +! thn2=1.0_wp_ + thn2u=upr2 !*thn2 + if(ithn.gt.0) then + emxy=ex-ui*ey + epxy=ex+ui*ey + if(upr2.gt.0.0_wp_) then + upr=sqrt(upr2) + bb=anprre*upr/yg + if(ithn.eq.1) then +! Larmor radius expansion polarization term at lowest order + cth=1.0_wp_ + if(nhn.gt.1) cth=(0.5_wp_*bb)**(nhn-1)*nhn/fact(nhn) + thn2=(0.5_wp_*cth*abs(emxy+ez*anprre*upl/ygn))**2 + thn2u=upr2*thn2 + else +! 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.0_wp_))**2 + ajb=bessel_jn(nhn-1, nhn+1, bb) + thn2u=(abs(ez*ajb(2)*upl+upr*(ajb(3)*epxy+ajb(1)*emxy)/2.0_wp_))**2 + end if + end if + end if + + fpp=ee*thn2u + end function fpp + + function fjch(upl,extrapar,npar) +! +! computation of integral for current density +! integrand for Cohen model with trapping +! +! integration variable upl passed explicitly. Other variables passed +! as array of extra parameters of length npar=size(extrapar). +! variables with index 1..nfpp must be passed to fpp +! variable with index nfpp+1 is zeff +! variables with index gt nfpp+1 are specific of the cd model +! +! extrapar(2) = anpl +! extrapar(4) = Re(anprw) +! extrapar(13) = ygn +! +! extrapar(14) = zeff +! extrapar(15) = rb +! extrapar(16) = alams +! extrapar(17) = pa +! extrapar(18) = fp0s +! + use conical, only : fconic + implicit none +! arguments + integer :: npar + real(wp_) :: upl,fjch + real(wp_), dimension(npar) :: extrapar +! local variables + real(wp_) :: anpl,anprre,ygn,zeff,rb,alams,pa,fp0s, & + upr2,gam,u2,u,z5,xi,xib,xibi,fu2b,fu2,gu,gg,dgg,alam,fp0, & + dfp0,fh,dfhl,eta + + anpl=extrapar(2) + anprre=extrapar(4) + ygn=extrapar(13) + zeff=extrapar(nfpp1) + rb=extrapar(nfpp2) + alams=extrapar(nfpp3) + pa=extrapar(nfpp4) + fp0s=extrapar(nfpp5) + + gam=anpl*upl+ygn + u2=gam*gam-1.0_wp_ + upr2=u2-upl*upl + u=sqrt(u2) + z5=Zeff+5.0_wp_ + xi=1.0_wp_/z5**2 + xib=1.0_wp_-xi + xibi=1.0_wp_/xib + fu2b=1.0_wp_+xib*u2 + fu2=1.0_wp_+xi*u2 + gu=(1.0_wp_-1.0_wp_/fu2b**xibi)/sqrt(fu2) + gg=u*gu/z5 + dgg=(gu+u2*(2.0_wp_/fu2b**(1.0_wp_+xibi)/sqrt(fu2)-xi*gu/fu2))/z5 + + alam=sqrt(1.0_wp_-upr2/u2/rb) + fp0=fconic(alam,pa,0) + dfp0=-(pa*pa/2.0_wp_+0.125_wp_) + if (alam.lt.1.0_wp_) dfp0=-fconic(alam,pa,1)/sqrt(1.0_wp_-alam**2) + fh=alam*(1.0_wp_-alams*fp0/(alam*fp0s)) + dfhl=1.0_wp_-alams*dfp0/fp0s + + eta=gam*fh*(gg/u+dgg)+upl*(anpl*u2-upl*gam)*gg*dfhl/(u2*u*rb*alam) + + if(upl.lt.0.0_wp_) eta=-eta + fjch=eta*fpp(upl,extrapar(1:nfpp),nfpp) + + end function fjch + + function fjch0(upl,extrapar,npar) +! +! computation of integral for current density +! integrand for Cohen model without trapping +! +! integration variable upl passed explicitly. Other variables passed +! as array of extra parameters of length npar=size(extrapar). +! variables with index 1..nfpp must be passed to fpp +! variable with index nfpp+1 is zeff +! variables with index gt nfpp+1 are specific of the cd model +! +! extrapar(2) = anpl +! extrapar(13) = ygn +! +! extrapar(14) = zeff +! + implicit none +! arguments + real(wp_) :: upl,fjch0 + integer :: npar + real(wp_), dimension(npar) :: extrapar +! local variables + real(wp_) :: anpl,ygn,zeff,gam,u2,u,z5,xi,xib,xibi,fu2b,fu2,gu,gg,dgg,eta +! + anpl=extrapar(2) + ygn=extrapar(13) + zeff=extrapar(nfpp1) + + gam=anpl*upl+ygn + u2=gam*gam-1.0_wp_ + u=sqrt(u2) + z5=Zeff+5.0_wp_ + xi=1.0_wp_/z5**2 + xib=1.0_wp_-xi + xibi=1.0_wp_/xib + fu2b=1.0_wp_+xib*u2 + fu2=1.0_wp_+xi*u2 + gu=(1.0_wp_-1.0_wp_/fu2b**xibi)/sqrt(fu2) + gg=u*gu/z5 + dgg=(gu+u2*(2.0_wp_/fu2b**(1.0_wp_+xibi)/sqrt(fu2)-xi*gu/fu2))/z5 + eta=anpl*gg+gam*upl*dgg/u + fjch0=eta*fpp(upl,extrapar(1:nfpp),nfpp) + + end function fjch0 + + function fjncl(upl,extrapar,npar) +! +! computation of integral for current density +! integrand for momentum conserv. model K(u) from Maruschenko +! gg=F(u)/u with F(u) as in Cohen paper +! +! integration variable upl passed explicitly. Other variables passed +! as array of extra parameters of length npar=size(extrapar). +! variables with index 1..nfpp must be passed to fpp +! variable with index nfpp+1 is zeff +! variables with index gt nfpp+1 are specific of the cd model +! +! extrapar(2) = anpl +! extrapar(3) = amu +! extrapar(13) = ygn +! +! extrapar(14) = zeff +! extrapar(15) = fc +! extrapar(16) = rbx +! extrapar(17:16+(npar-16)/2) = tlm +! extrapar(17+(npar-16)/2:npar) = chlm +! + use dierckx, only : splev,splder + implicit none +! arguments + integer :: npar + real(wp_) :: upl,fjncl + real(wp_), dimension(npar) :: extrapar +! local variables + integer :: nlm + real(wp_) :: anpl,amu,ygn,zeff,fc,rbx,gam,u2,u,upr2, & + bth,uth,fk,dfk,alam,fu,dfu,eta +! local variables + integer :: ier + real(wp_), dimension((npar-nfpp3)/2) :: wrk + real(wp_), dimension(1) :: xs,ys +! + anpl=extrapar(2) + amu=extrapar(3) + ygn=extrapar(13) + zeff=extrapar(nfpp1) + fc=extrapar(nfpp2) + rbx=extrapar(nfpp3) + + gam=anpl*upl+ygn + u2=gam*gam-1.0_wp_ + u=sqrt(u2) + upr2=u2-upl*upl + bth=sqrt(2.0_wp_/amu) + uth=u/bth + call GenSpitzFunc(Zeff,fc,uth,u,gam,fk,dfk) + fk=fk*(4.0_wp_/amu**2) + dfk=dfk*(2.0_wp_/amu)*bth + + alam=upr2/u2/rbx + xs(1)=alam + nlm=(npar-nfpp3)/2 +! +! extrapar(17:16+(npar-16)/2) = tlm +! extrapar(17+(npar-16)/2:npar) = chlm +! + call splev(extrapar(nfpp4:nfpp3+nlm),nlm,extrapar(nfpp4+nlm:npar),3, & + xs(1),ys(1),1,ier) + fu=ys(1) + call splder(extrapar(nfpp4:nfpp3+nlm),nlm,extrapar(nfpp4+nlm:npar),3,1, & + xs(1),ys(1),1,wrk,ier) + dfu=ys(1) + + eta=gam*fu*dfk/u-2.0_wp_*(anpl-gam*upl/u2)*fk*dfu*upl/u2/rbx + if(upl.lt.0) eta=-eta + fjncl=eta*fpp(upl,extrapar(1:nfpp),nfpp) + end function fjncl + + SUBROUTINE GenSpitzFunc(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; +! Zeff - effective charge; +! fc - fraction of circulating particles. +! +! OUTPUTS: +! K - Spitzer's function +! dKdu = dK/du, i.e. its derivative over normalized momentum +!======================================================================= + use const_and_precisions, only : comp_eps + IMPLICIT NONE + REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam + REAL(wp_), INTENT(out) :: K,dKdu + REAL(wp_) :: gam1,gam2,gam3 + + K = 0 + dKdu = 0 + IF (u < comp_eps) RETURN + + 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 + END SUBROUTINE GenSpitzFunc + + SUBROUTINE SpitzFuncCoeff(mu,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 +! mu - mc2/Te +! 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) +!======================================================================= + use const_and_precisions, only : mc2_ + IMPLICIT NONE + REAL(wp_), INTENT(in) :: mu,Zeff,fc + INTEGER :: n,i,j + REAL(wp_) :: rtc,rtc1,y,tn(1:nre) + REAL(wp_) :: m(0:4,0:4),g(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,newmu,newZ,newfc + REAL(wp_), SAVE :: sfdx(1:4) = 0 + REAL(wp_), SAVE :: mu_old =-1, Zeff_old =-1, fc_old =-1 + + rel = mu < mc2_ + newmu = abs(mu -mu_old ) > delta*mu + newZ = abs(Zeff-Zeff_old) > delta*Zeff + newfc = abs(fc -fc_old ) > delta*fc + SELECT CASE(adj_appr(1)) + CASE ('l','c') + renew = (newmu .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 = min(mu,1.e3*mc2_) + 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 + mu_old = mu + Zeff_old = Zeff + sfdx(1:4) = sfd(1:4) + + 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 +!======================================================================= + use const_and_precisions, only : zero,one + use numint, only : quanc8 + IMPLICIT NONE + REAL(wp_), INTENT(in) :: Zeff,fc,u,q,gam + REAL(wp_), INTENT(out) :: K,dKdu + INTEGER :: nfun + REAL(wp_) :: gam2,err,flag,Integr + REAL(wp_), PARAMETER :: a = zero, b = one, rtol = 1e-4_wp_, atol = 1e-12_wp_ + + 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,one,atol,rtol,Integr,err,nfun,flag) + + gam2 = gam*gam + K = u**4 * Integr + dKdu = (u/gam)**3 * (1-r2*gam2*Integr) + END SUBROUTINE SpitzFunc_HighSpeedLimit + + FUNCTION HSL_f(t) RESULT(f) +!======================================================================= +! Integrand for the high-speed limit approach (Lin-Liu's formulation) +!======================================================================= + IMPLICIT NONE + REAL(wp_), INTENT(in) :: t + REAL(wp_) :: f,g + g = sqrt(1+t*t*q2) + f = t**(3+r2)/g**3 * (gp1/(g+1))**r2 + END FUNCTION HSL_f + +end module eccd diff --git a/src/eierf.f90 b/src/eierf.f90 new file mode 100644 index 0000000..fe2fb58 --- /dev/null +++ b/src/eierf.f90 @@ -0,0 +1,906 @@ +module eierf + + use const_and_precisions, only : wp_, zero, one + implicit none + real(wp_), parameter, private :: half=0.5_wp_, two=2.0_wp_, three=3.0_wp_, & + four=4.0_wp_, six=6.0_wp_, twelve=12._wp_, sixten=16.0_wp_, & + two4=24.0_wp_, fourty=40.0_wp_ + +contains + +! ====================================================================== +! 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,intt) +!---------------------------------------------------------------------- +! +! this fortran 77 packet computes the exponential integrals ei(x), +! e1(x), and exp(-x)*ei(x) for real arguments x where +! +! integral (from t=-infinity to t=x) (exp(t)/t), x > 0, +! ei(x) = +! -integral (from t=-x to t=infinity) (exp(t)/t), x < 0, +! +! and where the first integral is a principal value integral. +! the packet contains three function type subprograms: ei, eone, +! and expei; and one subroutine type subprogram: calcei. the +! calling statements for the primary entries are +! +! y = ei(x), where x /= 0, +! +! y = eone(x), where x > 0, +! and +! y = expei(x), where x /= 0, +! +! and where the entry points correspond to the functions ei(x), +! e1(x), and exp(-x)*ei(x), respectively. the routine calcei +! is intended for internal packet use only, all computations within +! the packet being concentrated in this routine. the function +! subprograms invoke calcei with the fortran statement +! call calcei(arg,result,intt) +! where the parameter usage is as follows +! +! function parameters for calcei +! call arg result intt +! +! ei(x) x /= 0 ei(x) 1 +! eone(x) x > 0 -ei(-x) 2 +! expei(x) x /= 0 exp(-x)*ei(x) 3 +!---------------------------------------------------------------------- + implicit none + integer, intent(in) :: intt + real(wp_), intent(in) :: arg + real(wp_), intent(out) :: result + integer :: i + real(wp_) :: ei,frac,sump,sumq,t,w,x,xmx0,y,ysq + real(wp_), dimension(10) :: px,qx +!---------------------------------------------------------------------- +! mathematical constants +! exp40 = exp(40) +! x0 = zero of ei +! x01/x11 + x02 = zero of ei to extra precision +!---------------------------------------------------------------------- + real(wp_), parameter :: p037=0.037_wp_, & + exp40=2.3538526683701998541e17_wp_, x01=381.5_wp_, x11=1024.0_wp_, & + x02=-5.1182968633365538008e-5_wp_, x0=3.7250741078136663466e-1_wp_ +!---------------------------------------------------------------------- +! machine-dependent constants +!---------------------------------------------------------------------- + real(wp_), parameter :: xinf=1.79e+308_wp_,xmax=716.351_wp_,xbig=701.84_wp_ +!---------------------------------------------------------------------- +! coefficients for -1.0 <= x < 0.0 +!---------------------------------------------------------------------- + real(wp_), dimension(7), parameter :: & + a=(/1.1669552669734461083368e2_wp_, 2.1500672908092918123209e3_wp_, & + 1.5924175980637303639884e4_wp_, 8.9904972007457256553251e4_wp_, & + 1.5026059476436982420737e5_wp_,-1.4815102102575750838086e5_wp_, & + 5.0196785185439843791020_wp_/) + real(wp_), dimension(6), parameter :: & + b=(/4.0205465640027706061433e1_wp_, 7.5043163907103936624165e2_wp_, & + 8.1258035174768735759855e3_wp_, 5.2440529172056355429883e4_wp_, & + 1.8434070063353677359298e5_wp_, 2.5666493484897117319268e5_wp_/) +!---------------------------------------------------------------------- +! coefficients for -4.0 <= x < -1.0 +!---------------------------------------------------------------------- + real(wp_), dimension(9), parameter :: & + c=(/3.828573121022477169108e-1_wp_, 1.107326627786831743809e+1_wp_, & + 7.246689782858597021199e+1_wp_, 1.700632978311516129328e+2_wp_, & + 1.698106763764238382705e+2_wp_, 7.633628843705946890896e+1_wp_, & + 1.487967702840464066613e+1_wp_, 9.999989642347613068437e-1_wp_, & + 1.737331760720576030932e-8_wp_/), & + d=(/8.258160008564488034698e-2_wp_, 4.344836335509282083360e+0_wp_, & + 4.662179610356861756812e+1_wp_, 1.775728186717289799677e+2_wp_, & + 2.953136335677908517423e+2_wp_, 2.342573504717625153053e+2_wp_, & + 9.021658450529372642314e+1_wp_, 1.587964570758947927903e+1_wp_, & + 1.000000000000000000000e+0_wp_/) +!---------------------------------------------------------------------- +! coefficients for x < -4.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + e=(/1.3276881505637444622987e+2_wp_,3.5846198743996904308695e+4_wp_, & + 1.7283375773777593926828e+5_wp_,2.6181454937205639647381e+5_wp_, & + 1.7503273087497081314708e+5_wp_,5.9346841538837119172356e+4_wp_, & + 1.0816852399095915622498e+4_wp_,1.0611777263550331766871e03_wp_, & + 5.2199632588522572481039e+1_wp_,9.9999999999999999087819e-1_wp_/),& + f=(/3.9147856245556345627078e+4_wp_,2.5989762083608489777411e+5_wp_, & + 5.5903756210022864003380e+5_wp_,5.4616842050691155735758e+5_wp_, & + 2.7858134710520842139357e+5_wp_,7.9231787945279043698718e+4_wp_, & + 1.2842808586627297365998e+4_wp_,1.1635769915320848035459e+3_wp_, & + 5.4199632588522559414924e+1_wp_,1.0_wp_/) +!---------------------------------------------------------------------- +! coefficients for rational approximation to ln(x/a), |1-x/a| < .1 +!---------------------------------------------------------------------- + real(wp_), dimension(4), parameter :: & + plg=(/-2.4562334077563243311e+01_wp_,2.3642701335621505212e+02_wp_, & + -5.4989956895857911039e+02_wp_,3.5687548468071500413e+02_wp_/), & + qlg=(/-3.5553900764052419184e+01_wp_,1.9400230218539473193e+02_wp_, & + -3.3442903192607538956e+02_wp_,1.7843774234035750207e+02_wp_/) +!---------------------------------------------------------------------- +! coefficients for 0.0 < x < 6.0, +! ratio of chebyshev polynomials +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p=(/-1.2963702602474830028590e01_wp_,-1.2831220659262000678155e03_wp_, & + -1.4287072500197005777376e04_wp_,-1.4299841572091610380064e06_wp_, & + -3.1398660864247265862050e05_wp_,-3.5377809694431133484800e08_wp_, & + 3.1984354235237738511048e08_wp_,-2.5301823984599019348858e10_wp_, & + 1.2177698136199594677580e10_wp_,-2.0829040666802497120940e11_wp_/),& + q=(/ 7.6886718750000000000000e01_wp_,-5.5648470543369082846819e03_wp_, & + 1.9418469440759880361415e05_wp_,-4.2648434812177161405483e06_wp_, & + 6.4698830956576428587653e07_wp_,-7.0108568774215954065376e08_wp_, & + 5.4229617984472955011862e09_wp_,-2.8986272696554495342658e10_wp_, & + 9.8900934262481749439886e10_wp_,-8.9673749185755048616855e10_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for 6.0 <= x < 12.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + r=(/-2.645677793077147237806_wp_,-2.378372882815725244124_wp_, & + -2.421106956980653511550e01_wp_, 1.052976392459015155422e01_wp_, & + 1.945603779539281810439e01_wp_,-3.015761863840593359165e01_wp_, & + 1.120011024227297451523e01_wp_,-3.988850730390541057912_wp_, & + 9.565134591978630774217_wp_, 9.981193787537396413219e-1_wp_/) + real(wp_), dimension(9), parameter :: & + s=(/ 1.598517957704779356479e-4_wp_, 4.644185932583286942650_wp_, & + 3.697412299772985940785e02_wp_,-8.791401054875438925029_wp_, & + 7.608194509086645763123e02_wp_, 2.852397548119248700147e01_wp_, & + 4.731097187816050252967e02_wp_,-2.369210235636181001661e02_wp_, & + 1.249884822712447891440_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for 12.0 <= x < 24.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p1=(/-1.647721172463463140042_wp_,-1.860092121726437582253e01_wp_, & + -1.000641913989284829961e01_wp_,-2.105740799548040450394e01_wp_, & + -9.134835699998742552432e-1_wp_,-3.323612579343962284333e01_wp_, & + 2.495487730402059440626e01_wp_, 2.652575818452799819855e01_wp_, & + -1.845086232391278674524_wp_, 9.999933106160568739091e-1_wp_/) + real(wp_), dimension(9), parameter :: & + q1=(/ 9.792403599217290296840e01_wp_, 6.403800405352415551324e01_wp_, & + 5.994932325667407355255e01_wp_, 2.538819315630708031713e02_wp_, & + 4.429413178337928401161e01_wp_, 1.192832423968601006985e03_wp_, & + 1.991004470817742470726e02_wp_,-1.093556195391091143924e01_wp_, & + 1.001533852045342697818_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for x >= 24.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p2=(/ 1.75338801265465972390e02_wp_,-2.23127670777632409550e02_wp_, & + -1.81949664929868906455e01_wp_,-2.79798528624305389340e01_wp_, & + -7.63147701620253630855_wp_,-1.52856623636929636839e01_wp_, & + -7.06810977895029358836_wp_,-5.00006640413131002475_wp_, & + -3.00000000320981265753_wp_, 1.00000000000000485503_wp_/) + real(wp_), dimension(9), parameter :: & + q2=(/ 3.97845977167414720840e04_wp_, 3.97277109100414518365_wp_, & + 1.37790390235747998793e02_wp_, 1.17179220502086455287e02_wp_, & + 7.04831847180424675988e01_wp_,-1.20187763547154743238e01_wp_, & + -7.99243595776339741065_wp_,-2.99999894040324959612_wp_, & + 1.99999999999048104167_wp_/) +!---------------------------------------------------------------------- + x = arg + if (x == zero) then + ei = -xinf + if (intt == 2) ei = -ei + else if ((x < zero) .or. (intt == 2)) then +!---------------------------------------------------------------------- +! calculate ei for negative argument or for e1. +!---------------------------------------------------------------------- + y = abs(x) + if (y <= one) then + sump = a(7) * y + a(1) + sumq = y + b(1) + do i = 2, 6 + sump = sump * y + a(i) + sumq = sumq * y + b(i) + end do + ei = log(y) - sump / sumq + if (intt == 3) ei = ei * exp(y) + else if (y <= four) then + w = one / y + sump = c(1) + sumq = d(1) + do i = 2, 9 + sump = sump * w + c(i) + sumq = sumq * w + d(i) + end do + ei = - sump / sumq + if (intt /= 3) ei = ei * exp(-y) + else + if ((y > xbig) .and. (intt < 3)) then + ei = zero + else + w = one / y + sump = e(1) + sumq = f(1) + do i = 2, 10 + sump = sump * w + e(i) + sumq = sumq * w + f(i) + end do + ei = -w * (one - w * sump / sumq ) + if (intt /= 3) ei = ei * exp(-y) + end if + end if + if (intt == 2) ei = -ei + else if (x < six) then +!---------------------------------------------------------------------- +! to improve conditioning, rational approximations are expressed +! in terms of chebyshev polynomials for 0 <= x < 6, and in +! continued fraction form for larger x. +!---------------------------------------------------------------------- + t = x + x + t = t / three - two + px(1) = zero + qx(1) = zero + px(2) = p(1) + qx(2) = q(1) + do 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) + end do + 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) >= p037) then + ei = log(x/x0) + xmx0 * frac + if (intt == 3) ei = exp(-x) * ei + else +!---------------------------------------------------------------------- +! special approximation to ln(x/x0) for x close to x0 +!---------------------------------------------------------------------- + y = xmx0 / (x + x0) + ysq = y*y + sump = plg(1) + sumq = ysq + qlg(1) + do i = 2, 4 + sump = sump*ysq + plg(i) + sumq = sumq*ysq + qlg(i) + end do + ei = (sump / (sumq*(x+x0)) + frac) * xmx0 + if (intt == 3) ei = exp(-x) * ei + end if + else if (x < twelve) then + frac = zero + do i = 1, 9 + frac = s(i) / (r(i) + x + frac) + end do + ei = (r(10) + frac) / x + if (intt /= 3) ei = ei * exp(x) + else if (x <= two4) then + frac = zero + do i = 1, 9 + frac = q1(i) / (p1(i) + x + frac) + end do + ei = (p1(10) + frac) / x + if (intt /= 3) ei = ei * exp(x) + else + if ((x >= xmax) .and. (intt < 3)) then + ei = xinf + else + y = one / x + frac = zero + do i = 1, 9 + frac = q2(i) / (p2(i) + x + frac) + end do + frac = p2(10) + frac + ei = y + y * y * frac + if (intt /= 3) then + if (x <= xmax-two4) then + ei = ei * exp(x) + else +!---------------------------------------------------------------------- +! calculation reformulated to avoid premature overflow +!---------------------------------------------------------------------- + ei = (ei * exp(x-fourty)) * exp40 + end if + end if + end if + end if + result = ei + end subroutine calcei + + function ei(x) +!-------------------------------------------------------------------- +! +! this function program computes approximate values for the +! exponential integral ei(x), where x is real. +! +! author: w. j. cody +! +! latest modification: january 12, 1988 +! +!-------------------------------------------------------------------- + implicit none + integer :: intt + real(wp_) :: ei + real(wp_), intent(in) :: x + real(wp_) :: result +!-------------------------------------------------------------------- + intt = 1 + call calcei(x,result,intt) + ei = result + end function ei + + function expei(x) +!-------------------------------------------------------------------- +! +! this function program computes approximate values for the +! function exp(-x) * ei(x), where ei(x) is the exponential +! integral, and x is real. +! +! author: w. j. cody +! +! latest modification: january 12, 1988 +! +!-------------------------------------------------------------------- + implicit none + integer :: intt + real(wp_) :: expei + real(wp_), intent(in) :: x + real(wp_) :: result +!-------------------------------------------------------------------- + intt = 3 + call calcei(x,result,intt) + expei = result + end function expei + + function eone(x) +!-------------------------------------------------------------------- +! +! this function program computes approximate values for the +! exponential integral e1(x), where x is real. +! +! author: w. j. cody +! +! latest modification: january 12, 1988 +! +!-------------------------------------------------------------------- + implicit none + integer :: intt + real(wp_) :: eone + real(wp_), intent(in) :: x + real(wp_) :: result +!-------------------------------------------------------------------- + intt = 2 + call calcei(x,result,intt) + eone = result + end function eone + +! ====================================================================== +! calcei3 = calcei for int=3 +! ====================================================================== + subroutine calcei3(arg,result) +!---------------------------------------------------------------------- +! +! this fortran 77 packet computes the exponential integrals ei(x), +! e1(x), and exp(-x)*ei(x) for real arguments x where +! +! integral (from t=-infinity to t=x) (exp(t)/t), x > 0, +! ei(x) = +! -integral (from t=-x to t=infinity) (exp(t)/t), x < 0, +! +! and where the first integral is a principal value integral. +! the packet contains three function type subprograms: ei, eone, +! and expei; and one subroutine type subprogram: calcei. the +! calling statements for the primary entries are +! +! y = ei(x), where x /= 0, +! +! y = eone(x), where x > 0, +! and +! y = expei(x), where x /= 0, +! +! and where the entry points correspond to the functions ei(x), +! e1(x), and exp(-x)*ei(x), respectively. the routine calcei +! is intended for internal packet use only, all computations within +! the packet being concentrated in this routine. the function +! subprograms invoke calcei with the fortran statement +! call calcei(arg,result,int) +! where the parameter usage is as follows +! +! function parameters for calcei +! call arg result int +! +! ei(x) x /= 0 ei(x) 1 +! eone(x) x > 0 -ei(-x) 2 +! expei(x) x /= 0 exp(-x)*ei(x) 3 +!---------------------------------------------------------------------- + implicit none + real(wp_), intent(in) :: arg + real(wp_), intent(out) :: result + integer :: i + real(wp_) :: ei,frac,sump,sumq,t,w,x,xmx0,y,ysq + real(wp_), dimension(10) :: px,qx +!---------------------------------------------------------------------- +! mathematical constants +! exp40 = exp(40) +! x0 = zero of ei +! x01/x11 + x02 = zero of ei to extra precision +!---------------------------------------------------------------------- + real(wp_), parameter :: p037=0.037_wp_, & + x01=381.5_wp_, x11=1024.0_wp_, x02=-5.1182968633365538008e-5_wp_, & + x0=3.7250741078136663466e-1_wp_ +!---------------------------------------------------------------------- +! machine-dependent constants +!---------------------------------------------------------------------- + real(wp_), parameter :: xinf=1.79e+308_wp_ +!---------------------------------------------------------------------- +! coefficients for -1.0 <= x < 0.0 +!---------------------------------------------------------------------- + real(wp_), dimension(7), parameter :: & + a=(/1.1669552669734461083368e2_wp_, 2.1500672908092918123209e3_wp_, & + 1.5924175980637303639884e4_wp_, 8.9904972007457256553251e4_wp_, & + 1.5026059476436982420737e5_wp_,-1.4815102102575750838086e5_wp_, & + 5.0196785185439843791020_wp_/) + real(wp_), dimension(6), parameter :: & + b=(/4.0205465640027706061433e1_wp_, 7.5043163907103936624165e2_wp_, & + 8.1258035174768735759855e3_wp_, 5.2440529172056355429883e4_wp_, & + 1.8434070063353677359298e5_wp_, 2.5666493484897117319268e5_wp_/) +!---------------------------------------------------------------------- +! coefficients for -4.0 <= x < -1.0 +!---------------------------------------------------------------------- + real(wp_), dimension(9), parameter :: & + c=(/3.828573121022477169108e-1_wp_, 1.107326627786831743809e+1_wp_, & + 7.246689782858597021199e+1_wp_, 1.700632978311516129328e+2_wp_, & + 1.698106763764238382705e+2_wp_, 7.633628843705946890896e+1_wp_, & + 1.487967702840464066613e+1_wp_, 9.999989642347613068437e-1_wp_, & + 1.737331760720576030932e-8_wp_/), & + d=(/8.258160008564488034698e-2_wp_, 4.344836335509282083360e+0_wp_, & + 4.662179610356861756812e+1_wp_, 1.775728186717289799677e+2_wp_, & + 2.953136335677908517423e+2_wp_, 2.342573504717625153053e+2_wp_, & + 9.021658450529372642314e+1_wp_, 1.587964570758947927903e+1_wp_, & + 1.000000000000000000000e+0_wp_/) +!---------------------------------------------------------------------- +! coefficients for x < -4.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + e=(/1.3276881505637444622987e+2_wp_,3.5846198743996904308695e+4_wp_, & + 1.7283375773777593926828e+5_wp_,2.6181454937205639647381e+5_wp_, & + 1.7503273087497081314708e+5_wp_,5.9346841538837119172356e+4_wp_, & + 1.0816852399095915622498e+4_wp_,1.0611777263550331766871e03_wp_, & + 5.2199632588522572481039e+1_wp_,9.9999999999999999087819e-1_wp_/), & + f=(/3.9147856245556345627078e+4_wp_,2.5989762083608489777411e+5_wp_, & + 5.5903756210022864003380e+5_wp_,5.4616842050691155735758e+5_wp_, & + 2.7858134710520842139357e+5_wp_,7.9231787945279043698718e+4_wp_, & + 1.2842808586627297365998e+4_wp_,1.1635769915320848035459e+3_wp_, & + 5.4199632588522559414924e+1_wp_,1.0_wp_/) +!---------------------------------------------------------------------- +! coefficients for rational approximation to ln(x/a), |1-x/a| < .1 +!---------------------------------------------------------------------- + real(wp_), dimension(4), parameter :: & + plg=(/-2.4562334077563243311e+01_wp_,2.3642701335621505212e+02_wp_, & + -5.4989956895857911039e+02_wp_,3.5687548468071500413e+02_wp_/), & + qlg=(/-3.5553900764052419184e+01_wp_,1.9400230218539473193e+02_wp_, & + -3.3442903192607538956e+02_wp_,1.7843774234035750207e+02_wp_/) +!---------------------------------------------------------------------- +! coefficients for 0.0 < x < 6.0, +! ratio of chebyshev polynomials +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p=(/-1.2963702602474830028590e01_wp_,-1.2831220659262000678155e03_wp_, & + -1.4287072500197005777376e04_wp_,-1.4299841572091610380064e06_wp_, & + -3.1398660864247265862050e05_wp_,-3.5377809694431133484800e08_wp_, & + 3.1984354235237738511048e08_wp_,-2.5301823984599019348858e10_wp_, & + 1.2177698136199594677580e10_wp_,-2.0829040666802497120940e11_wp_/),& + q=(/ 7.6886718750000000000000e01_wp_,-5.5648470543369082846819e03_wp_, & + 1.9418469440759880361415e05_wp_,-4.2648434812177161405483e06_wp_, & + 6.4698830956576428587653e07_wp_,-7.0108568774215954065376e08_wp_, & + 5.4229617984472955011862e09_wp_,-2.8986272696554495342658e10_wp_, & + 9.8900934262481749439886e10_wp_,-8.9673749185755048616855e10_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for 6.0 <= x < 12.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + r=(/-2.645677793077147237806_wp_,-2.378372882815725244124_wp_, & + -2.421106956980653511550e01_wp_, 1.052976392459015155422e01_wp_, & + 1.945603779539281810439e01_wp_,-3.015761863840593359165e01_wp_, & + 1.120011024227297451523e01_wp_,-3.988850730390541057912_wp_, & + 9.565134591978630774217_wp_, 9.981193787537396413219e-1_wp_/) + real(wp_), dimension(9), parameter :: & + s=(/ 1.598517957704779356479e-4_wp_, 4.644185932583286942650_wp_, & + 3.697412299772985940785e02_wp_,-8.791401054875438925029_wp_, & + 7.608194509086645763123e02_wp_, 2.852397548119248700147e01_wp_, & + 4.731097187816050252967e02_wp_,-2.369210235636181001661e02_wp_, & + 1.249884822712447891440_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for 12.0 <= x < 24.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p1=(/-1.647721172463463140042_wp_,-1.860092121726437582253e01_wp_, & + -1.000641913989284829961e01_wp_,-2.105740799548040450394e01_wp_, & + -9.134835699998742552432e-1_wp_,-3.323612579343962284333e01_wp_, & + 2.495487730402059440626e01_wp_, 2.652575818452799819855e01_wp_, & + -1.845086232391278674524_wp_, 9.999933106160568739091e-1_wp_/) + real(wp_), dimension(9), parameter :: & + q1=(/ 9.792403599217290296840e01_wp_, 6.403800405352415551324e01_wp_, & + 5.994932325667407355255e01_wp_, 2.538819315630708031713e02_wp_, & + 4.429413178337928401161e01_wp_, 1.192832423968601006985e03_wp_, & + 1.991004470817742470726e02_wp_,-1.093556195391091143924e01_wp_, & + 1.001533852045342697818_wp_/) +!---------------------------------------------------------------------- +! j-fraction coefficients for x >= 24.0 +!---------------------------------------------------------------------- + real(wp_), dimension(10), parameter :: & + p2=(/ 1.75338801265465972390e02_wp_,-2.23127670777632409550e02_wp_, & + -1.81949664929868906455e01_wp_,-2.79798528624305389340e01_wp_, & + -7.63147701620253630855_wp_,-1.52856623636929636839e01_wp_, & + -7.06810977895029358836_wp_,-5.00006640413131002475_wp_, & + -3.00000000320981265753_wp_, 1.00000000000000485503_wp_/) + real(wp_), dimension(9), parameter :: & + q2=(/ 3.97845977167414720840e04_wp_, 3.97277109100414518365_wp_, & + 1.37790390235747998793e02_wp_, 1.17179220502086455287e02_wp_, & + 7.04831847180424675988e01_wp_,-1.20187763547154743238e01_wp_, & + -7.99243595776339741065_wp_,-2.99999894040324959612_wp_, & + 1.99999999999048104167_wp_/) +!---------------------------------------------------------------------- + x = arg + if (x == zero) then + ei = -xinf + else if ((x < zero)) then +!---------------------------------------------------------------------- +! calculate ei for negative argument or for e1. +!---------------------------------------------------------------------- + y = abs(x) + if (y <= one) then + sump = a(7) * y + a(1) + sumq = y + b(1) + do i = 2, 6 + sump = sump * y + a(i) + sumq = sumq * y + b(i) + end do + ei = (log(y) - sump / sumq ) * exp(y) + else if (y <= four) then + w = one / y + sump = c(1) + sumq = d(1) + do i = 2, 9 + sump = sump * w + c(i) + sumq = sumq * w + d(i) + end do + ei = - sump / sumq + else + w = one / y + sump = e(1) + sumq = f(1) + do i = 2, 10 + sump = sump * w + e(i) + sumq = sumq * w + f(i) + end do + ei = -w * (one - w * sump / sumq ) + end if + else if (x < six) then +!---------------------------------------------------------------------- +! to improve conditioning, rational approximations are expressed +! in terms of chebyshev polynomials for 0 <= x < 6, and in +! continued fraction form for larger x. +!---------------------------------------------------------------------- + t = x + x + t = t / three - two + px(1) = zero + qx(1) = zero + px(2) = p(1) + qx(2) = q(1) + do 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) + end do + 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) >= p037) then + ei = exp(-x) * ( log(x/x0) + xmx0 * frac ) + else +!---------------------------------------------------------------------- +! special approximation to ln(x/x0) for x close to x0 +!---------------------------------------------------------------------- + y = xmx0 / (x + x0) + ysq = y*y + sump = plg(1) + sumq = ysq + qlg(1) + do i = 2, 4 + sump = sump*ysq + plg(i) + sumq = sumq*ysq + qlg(i) + end do + ei = exp(-x) * (sump / (sumq*(x+x0)) + frac) * xmx0 + end if + else if (x < twelve) then + frac = zero + do i = 1, 9 + frac = s(i) / (r(i) + x + frac) + end do + ei = (r(10) + frac) / x + else if (x <= two4) then + frac = zero + do i = 1, 9 + frac = q1(i) / (p1(i) + x + frac) + end do + ei = (p1(10) + frac) / x + else + y = one / x + frac = zero + do i = 1, 9 + frac = q2(i) / (p2(i) + x + frac) + end do + frac = p2(10) + frac + ei = y + y * y * frac + end if + result = ei + end subroutine calcei3 + +! subroutine calerf(arg,result,jintt) +!!------------------------------------------------------------------ +!! +!! this packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) +!! for a real argument x. it contains three function type +!! subprograms: erf, erfc, and erfcx (or derf, derfc, and derfcx), +!! and one subroutine type subprogram, calerf. the calling +!! statements for the primary entries are: +!! +!! y=erf(x) (or y=derf(x)), +!! +!! y=erfc(x) (or y=derfc(x)), +!! and +!! y=erfcx(x) (or y=derfcx(x)). +!! +!! the routine calerf is intended for internal packet use only, +!! all computations within the packet being concentrated in this +!! routine. the function subprograms invoke calerf with the +!! statement +!! +!! call calerf(arg,result,jintt) +!! +!! where the parameter usage is as follows +!! +!! function parameters for calerf +!! call arg result jintt +!! +!! erf(arg) any real argument erf(arg) 0 +!! erfc(arg) abs(arg) < xbig erfc(arg) 1 +!! erfcx(arg) xneg < arg < xmax erfcx(arg) 2 +!! +!!******************************************************************* +!!******************************************************************* +!! +!! Explanation of machine-dependent constants +!! +!! XMIN = the smallest positive floating-point number. +!! XINF = the largest positive finite floating-point number. +!! XNEG = the largest negative argument acceptable to ERFCX; +!! the negative of the solution to the equation +!! 2*exp(x*x) = XINF. +!! XSMALL = argument below which erf(x) may be represented by +!! 2*x/sqrt(pi) and above which x*x will not underflow. +!! A conservative value is the largest machine number X +!! such that 1.0 + X = 1.0 to machine precision. +!! XBIG = largest argument acceptable to ERFC; solution to +!! the equation: W(x) * (1-0.5/x**2) = XMIN, where +!! W(x) = exp(-x*x)/[x*sqrt(pi)]. +!! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to +!! machine precision. A conservative value is +!! 1/[2*sqrt(XSMALL)] +!! XMAX = largest acceptable argument to ERFCX; the minimum +!! of XINF and 1/[sqrt(pi)*XMIN]. +!! +!!******************************************************************* +!!******************************************************************* +!! +!! error returns +!! +!! the program returns erfc = 0 for arg >= xbig; +!! +!! erfcx = xinf for arg < xneg; +!! and +!! erfcx = 0 for arg >= xmax. +!! +!! +!! intrinsic functions required are: +!! +!! abs, aint, exp +!! +!! +!! author: w. j. cody +!! mathematics and computer science division +!! argonne national laboratory +!! argonne, il 60439 +!! +!! latest modification: march 19, 1990 +!! +!!------------------------------------------------------------------ +! implicit none +! real(wp_), intent(in) :: arg +! real(wp_), intent(out) :: result +! integer, intent(in) :: jintt +! integer :: i +! real(wp_) :: del,x,xden,xnum,y,ysq +!!------------------------------------------------------------------ +!! mathematical constants +!!------------------------------------------------------------------ +! real(wp_), parameter :: sqrpi=5.6418958354775628695e-1_wp_, & +! thresh=0.46875_wp_ +!!------------------------------------------------------------------ +!! machine-dependent constants +!!------------------------------------------------------------------ +! real(wp_), parameter :: xinf=1.79e308_wp_, & ! ~huge +! xneg=-26.628_wp_, & ! ? +! xsmall=1.11e-16_wp_, & ! ~epsilon/2 +! xbig=26.543_wp_, & ! ? +! xhuge=6.71e7_wp_, & ! ~1/sqrt(epsilon) +! xmax=2.53e307_wp_ ! ? +!!------------------------------------------------------------------ +!! coefficients for approximation to erf in first interval +!!------------------------------------------------------------------ +! real(wp_), dimension(5), parameter :: & +! a=(/3.16112374387056560_wp_,1.13864154151050156e02_wp_, & +! 3.77485237685302021e02_wp_,3.20937758913846947e03_wp_, & +! 1.85777706184603153e-1_wp_/) +! real(wp_), dimension(4), parameter :: & +! b=(/2.36012909523441209e01_wp_,2.44024637934444173e02_wp_, & +! 1.28261652607737228e03_wp_,2.84423683343917062e03_wp_/) +!!------------------------------------------------------------------ +!! coefficients for approximation to erfc in second interval +!!------------------------------------------------------------------ +! real(wp_), dimension(9), parameter :: & +! c=(/5.64188496988670089e-1_wp_,8.88314979438837594_wp_, & +! 6.61191906371416295e01_wp_,2.98635138197400131e02_wp_, & +! 8.81952221241769090e02_wp_,1.71204761263407058e03_wp_, & +! 2.05107837782607147e03_wp_,1.23033935479799725e03_wp_, & +! 2.15311535474403846e-8_wp_/) +! real(wp_), dimension(8), parameter :: & +! d=(/1.57449261107098347e01_wp_,1.17693950891312499e02_wp_, & +! 5.37181101862009858e02_wp_,1.62138957456669019e03_wp_, & +! 3.29079923573345963e03_wp_,4.36261909014324716e03_wp_, & +! 3.43936767414372164e03_wp_,1.23033935480374942e03_wp_/) +!!------------------------------------------------------------------ +!! coefficients for approximation to erfc in third interval +!!------------------------------------------------------------------ +! real(wp_), dimension(6), parameter :: & +! p=(/3.05326634961232344e-1_wp_,3.60344899949804439e-1_wp_, & +! 1.25781726111229246e-1_wp_,1.60837851487422766e-2_wp_, & +! 6.58749161529837803e-4_wp_,1.63153871373020978e-2_wp_/) +! real(wp_), dimension(5), parameter :: & +! q=(/2.56852019228982242_wp_,1.87295284992346047_wp_, & +! 5.27905102951428412e-1_wp_,6.05183413124413191e-2_wp_, & +! 2.33520497626869185e-3_wp_/) +!!------------------------------------------------------------------ +! x = arg +! y = abs(x) +! if (y <= thresh) then +!!------------------------------------------------------------------ +!! evaluate erf for |x| <= 0.46875 +!!------------------------------------------------------------------ +! ysq = zero +! if (y > xsmall) ysq = y * y +! xnum = a(5)*ysq +! xden = ysq +! do i = 1, 3 +! xnum = (xnum + a(i)) * ysq +! xden = (xden + b(i)) * ysq +! end do +! result = x * (xnum + a(4)) / (xden + b(4)) +! if (jintt /= 0) result = one - result +! if (jintt == 2) result = exp(ysq) * result +! return +!!------------------------------------------------------------------ +!! evaluate erfc for 0.46875 <= |x| <= 4.0 +!!------------------------------------------------------------------ +! else if (y <= four) then +! xnum = c(9)*y +! xden = y +! do i = 1, 7 +! xnum = (xnum + c(i)) * y +! xden = (xden + d(i)) * y +! end do +! result = (xnum + c(8)) / (xden + d(8)) +! if (jintt /= 2) then +! ysq = aint(y*sixten)/sixten +! del = (y-ysq)*(y+ysq) +! result = exp(-ysq*ysq) * exp(-del) * result +! end if +!!------------------------------------------------------------------ +!! evaluate erfc for |x| > 4.0 +!!------------------------------------------------------------------ +! else if (y < xbig .or. (y < xmax .and. jintt == 2)) then +! ysq = one / (y * y) +! xnum = p(6)*ysq +! xden = ysq +! do i = 1, 4 +! xnum = (xnum + p(i)) * ysq +! xden = (xden + q(i)) * ysq +! end do +! result = ysq *(xnum + p(5)) / (xden + q(5)) +! result = (sqrpi - result) / y +! if (jintt /= 2) then +! ysq = aint(y*sixten)/sixten +! del = (y-ysq)*(y+ysq) +! result = exp(-ysq*ysq) * exp(-del) * result +! end if +! else if (y >= xhuge) then +! result = sqrpi / y +! else +! result = zero +! end if +!!------------------------------------------------------------------ +!! fix up for negative argument, erf, etc. +!!------------------------------------------------------------------ +! if (jintt == 0) then +! result = (half - result) + half +! if (x < zero) result = -result +! else if (jintt == 1) then +! if (x < zero) result = two - result +! else +! if (x < zero) then +! if (x < 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 +! end subroutine calerf +! +! function derf(x) +!!-------------------------------------------------------------------- +!! +!! this subprogram computes approximate values for erf(x). +!! (see comments heading calerf). +!! +!! author/date: w. j. cody, january 8, 1985 +!! +!!-------------------------------------------------------------------- +! implicit none +! real(wp_) :: derf +! real(wp_), intent(in) :: x +! integer :: jintt +! real(wp_) :: result +!!------------------------------------------------------------------ +! jintt = 0 +! call calerf(x,result,jintt) +! derf = result +! end function derf +! +! function derfc(x) +!!-------------------------------------------------------------------- +!! +!! this subprogram computes approximate values for erfc(x). +!! (see comments heading calerf). +!! +!! author/date: w. j. cody, january 8, 1985 +!! +!!-------------------------------------------------------------------- +! implicit none +! real(wp_) :: derfc +! real(wp_), intent(in) :: x +! integer :: jintt +! real(wp_) :: result +!!------------------------------------------------------------------ +! jintt = 1 +! call calerf(x,result,jintt) +! derfc = result +! end function derfc +! +! function derfcx(x) +!!------------------------------------------------------------------ +!! +!! this subprogram computes approximate values for exp(x*x) * erfc(x). +!! (see comments heading calerf). +!! +!! author/date: w. j. cody, march 30, 1987 +!! +!!------------------------------------------------------------------ +! implicit none +! real(wp_) :: derfcx +! real(wp_), intent(in) :: x +! integer :: jintt +! real(wp_) :: result +!!------------------------------------------------------------------ +! jintt = 2 +! call calerf(x,result,jintt) +! derfcx = result +! end function derfcx + +end module eierf \ No newline at end of file diff --git a/src/equilibrium.f90 b/src/equilibrium.f90 new file mode 100644 index 0000000..3c66e0b --- /dev/null +++ b/src/equilibrium.f90 @@ -0,0 +1,1085 @@ +module equilibrium + use const_and_precisions, only : wp_ + implicit none + + real(wp_), save :: btaxis,rmaxis,zmaxis,sgnbphi + real(wp_), save :: btrcen ! used only for jcd_astra def. + real(wp_), save :: rcen ! computed as fpol(a)/btrcen + real(wp_), save :: rmnm,rmxm,zmnm,zmxm + real(wp_), save :: zbinf,zbsup +! real(wp_), save :: rup,zup,rlw,zlw + + integer, parameter :: kspl=3,ksplp=kspl+1 + +! === 2d spline psi(r,z), normalization and derivatives ========== + integer, save :: nsr, nsz + real(wp_), save :: psia, psiant, psinop + real(wp_), dimension(:), allocatable, save :: tr,tz + real(wp_), dimension(:), allocatable, save :: cceq, cceq01, cceq10, & + cceq20, cceq02, cceq11 + +! === 1d spline fpol(psi) ======================================== +! integer, save :: npsiest + integer, save :: nsf + real(wp_), dimension(:), allocatable, save :: tfp, cfp + real(wp_), save :: fpolas + +! === 1d spline rhot(rhop), rhop(rhot), q(psi) =================== +! computed on psinr,rhopnr [,rhotnr] arrays + integer, save :: nq,nrho + real(wp_), dimension(:), allocatable, save :: psinr,rhopr,rhotr + real(wp_), dimension(:,:), allocatable, save :: cq,crhop,crhot + real(wp_), save :: phitedge,aminor + real(wp_), save :: q0,qa,alq + +contains + + subroutine read_eqdsk(filenm,rv,zv,psin,psia,psinr,fpol,q,rvac,rax,zax, & + rbnd,zbnd,rlim,zlim,ipsinorm,idesc,ifreefmt,unit) + use const_and_precisions, only : one + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: filenm + real(wp_), intent(out) :: psia,rvac,rax,zax + real(wp_), dimension(:), allocatable, intent(out) :: rv,zv,psinr,fpol,q + real(wp_), dimension(:), allocatable, intent(out) :: rbnd,zbnd,rlim,zlim + real(wp_), dimension(:,:), allocatable, intent(out) :: psin + integer, optional, intent(in) :: ipsinorm,idesc,ifreefmt,unit +! local variables + integer, parameter :: indef=0,iddef=1,iffdef=0 + integer :: in,id,iffmt,u,idum,i,j,nr,nz,nbnd,nlim + character(len=48) :: string + real(wp_) :: dr,dz,dps,rleft,zmid,zleft,xdum,psiedge,psiaxis + +! set default values if optional arguments are absent + in=indef; id=iddef; iffmt=iffdef + if(present(ipsinorm)) in=ipsinorm + if(present(idesc)) id=idesc + if(present(ifreefmt)) iffmt=ifreefmt + if (present(unit)) then + u=unit + else + u=get_free_unit() + end if + +! open G EQDSK file (see http://fusion.gat.com/efit/g_eqdsk.html) + open(file=trim(filenm),status='old',action='read',unit=u) + +! get size of main arrays and allocate them + if (id==1) then + read (u,'(a48,3i4)') string,idum,nr,nz + else + read (u,*) nr,nz + end if + if (allocated(rv)) deallocate(rv) + if (allocated(zv)) deallocate(zv) + if (allocated(psin)) deallocate(psin) + if (allocated(psinr)) deallocate(psinr) + if (allocated(fpol)) deallocate(fpol) + if (allocated(q)) deallocate(q) + allocate(rv(nr),zv(nz),psin(nr,nz),psinr(nr),fpol(nr),q(nr)) + +! store 0D data and main arrays + if (iffmt==1) then + read (u,*) dr,dz,rvac,rleft,zmid + read (u,*) rax,zax,psiaxis,psiedge,xdum + read (u,*) xdum,xdum,xdum,xdum,xdum + read (u,*) xdum,xdum,xdum,xdum,xdum + read (u,*) (fpol(i),i=1,nr) + read (u,*) (xdum,i=1,nr) + read (u,*) (xdum,i=1,nr) + read (u,*) (xdum,i=1,nr) + read (u,*) ((psin(i,j),i=1,nr),j=1,nz) + read (u,*) (q(i),i=1,nr) + else + read (u,'(5e16.9)') dr,dz,rvac,rleft,zmid + read (u,'(5e16.9)') rax,zax,psiaxis,psiedge,xdum + read (u,'(5e16.9)') xdum,xdum,xdum,xdum,xdum + read (u,'(5e16.9)') xdum,xdum,xdum,xdum,xdum + read (u,'(5e16.9)') (fpol(i),i=1,nr) + read (u,'(5e16.9)') (xdum,i=1,nr) + read (u,'(5e16.9)') (xdum,i=1,nr) + read (u,'(5e16.9)') (xdum,i=1,nr) + read (u,'(5e16.9)') ((psin(i,j),i=1,nr),j=1,nz) + read (u,'(5e16.9)') (q(i),i=1,nr) + end if + +! get size of boundary and limiter arrays and allocate them + read (u,*) nbnd,nlim + if (allocated(rbnd)) deallocate(rbnd) + if (allocated(zbnd)) deallocate(zbnd) + if (allocated(rlim)) deallocate(rlim) + if (allocated(zlim)) deallocate(zlim) + +! store boundary and limiter data + if(nbnd>0) then + allocate(rbnd(nbnd),zbnd(nbnd)) + if (iffmt==1) then + read(u,*) (rbnd(i),zbnd(i),i=1,nbnd) + else + read(u,'(5e16.9)') (rbnd(i),zbnd(i),i=1,nbnd) + end if + end if + if(nlim>0) then + allocate(rlim(nlim),zlim(nlim)) + if (iffmt==1) then + read(u,*) (rlim(i),zlim(i),i=1,nlim) + else + read(u,'(5e16.9)') (rlim(i),zlim(i),i=1,nlim) + end if + end if + +! reading of G EQDSK file completed + close(u) + +! build rv,zv,psinr arrays and normalize psin + zleft=zmid-0.5_wp_*dz + dr=dr/(nr-1) + dz=dz/(nz-1) + dps=one/(nr-1) + do i=1,nr + psinr(i)=(i-1)*dps + rv(i)=rleft+(i-1)*dr + end do + do i=1,nz + zv(i)=zleft+(i-1)*dz + end do + psia=psiedge-psiaxis + if(in==0) psin=(psin-psiaxis)/psia + end subroutine read_eqdsk + + + + subroutine read_equil_an(filenm,rv,zv,fpol,q,unit) + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: filenm + integer, optional, intent(in) :: unit + real(wp_), dimension(:), allocatable, intent(out) :: rv,zv,fpol,q +! local variables + integer :: u + real(wp_) :: rr0m,zr0m,rpam,b0,q0,qa,alq !,rcen,btrcen + + if (present(unit)) then + u=unit + else + u=get_free_unit() + end if + open(file=trim(filenm),status='old',action='read',unit=u) + read(u,*) rr0m,zr0m,rpam + read(u,*) b0 + read(u,*) q0,qa,alq +! rcen=rr0m +! btrcen=b0 +! b0=isgnbphi*b0*factb +! rvac=rr0m +! rax=rr0m +! zax=zr0m +! zbmin=(zr0-rpa)/1.0e2_wp_ +! zbmax=(zr0+rpa)/1.0e2_wp_ + if(allocated(rv)) deallocate(rv) + if(allocated(zv)) deallocate(zv) + if(allocated(fpol)) deallocate(fpol) + if(allocated(q)) deallocate(q) + allocate(rv(2),zv(1),fpol(1),q(3)) + rv(1)=rr0m + rv(2)=rpam + zv(1)=zr0m + fpol(1)=b0*rr0m + q(1)=q0 + q(2)=qa + q(3)=alq + close(u) + end subroutine read_equil_an + + subroutine change_cocos(psia,fpol,q,cocosin,cocosout,ierr) + use const_and_precisions, only : zero,one,pi + implicit none +! arguments + real(wp_), intent(inout) :: psia + real(wp_), dimension(:), intent(inout) :: fpol,q + integer, intent(in) :: cocosin, cocosout + integer, intent(out), optional :: ierr +! local variables + real(wp_) :: isign,bsign + integer :: exp2pi,exp2piout + logical :: phiccw,psiincr,qpos,phiccwout,psiincrout,qposout + + call decode_cocos(cocosin,exp2pi,phiccw,psiincr,qpos) + call decode_cocos(cocosout,exp2piout,phiccwout,psiincrout,qposout) + +! check sign consistency + isign=sign(one,psia) + if (.not.psiincr) isign=-isign + bsign=sign(one,fpol(size(fpol))) + if (qpos.neqv.isign*bsign*q(size(q))>zero) then +! warning: sign inconsistency found among q, Ipla and Bref + q=-q + if(present(ierr)) ierr=1 + else + if(present(ierr)) ierr=0 + end if + +! convert cocosin to cocosout + +! opposite direction of toroidal angle phi in cocosin and cocosout + if (phiccw.neqv.phiccwout) fpol=-fpol +! q has opposite sign for given sign of Bphi*Ip + if (qpos .neqv. qposout) q=-q +! psi and Ip signs don't change accordingly + if ((phiccw.eqv.phiccwout) .neqv. (psiincr.eqv.psiincrout)) psia=-psia +! convert Wb to Wb/rad or viceversa + psia=psia*(2.0_wp_*pi)**(exp2piout-exp2pi) + end subroutine change_cocos + + subroutine decode_cocos(cocos,exp2pi,phiccw,psiincr,qpos) + implicit none + integer, intent(in) :: cocos + integer, intent(out) :: exp2pi + logical, intent(out) :: phiccw,psiincr,qpos + integer :: cmod10,cmod4 + + cmod10=mod(cocos,10) + cmod4=mod(cmod10,4) +! cocos>10 psi in Wb, cocos<10 psi in Wb/rad + exp2pi=(cocos-cmod10)/10 +! cocos mod 10 = 1,3,5,7: toroidal angle phi increasing CCW + phiccw=(mod(cmod10,2)==1) +! cocos mod 10 = 1,2,5,6: psi increasing with positive Ip + psiincr=(cmod4==1 .or. cmod4==2) +! cocos mod 10 = 1,2,7,8: q positive for positive Bphi*Ip + qpos=(cmod10<3 .or. cmod10>6) + end subroutine decode_cocos + + subroutine eq_scal(psia,fpol,isign,bsign,factb) + use const_and_precisions, only : one + implicit none + real(wp_), intent(inout) :: psia + integer, intent(inout) :: isign,bsign + real(wp_), dimension(:), intent(inout) :: fpol + real(wp_), intent(in) :: factb + + ! isign and bsign ignored on input if equal to 0 + ! used to assign the direction of Bphi and Ipla BEFORE scaling + ! cocos=3 assumed: CCW direction is >0 + ! Bphi and Ipla scaled by the same factor factb to keep q unchanged + ! factb<0 reverses the directions of Bphi and Ipla + if(isign/=0) psia=sign(psia,real(-isign,wp_)) + if(bsign/=0 .and. bsign*fpol(size(fpol))<0) fpol=-fpol + psia=psia*factb + fpol=fpol*factb + isign=int(sign(one,-psia)) + bsign=int(sign(one,fpol(size(fpol)))) + end subroutine eq_scal + + subroutine set_eqspl(rv,zv,psin,psiwbrad,psinr,fpol,sspl,ssfp, & + r0,rax,zax,rbnd,zbnd,ixp) + use const_and_precisions, only : zero,one + use dierckx, only : regrid,coeff_parder,curfit,splev + use utils, only : vmaxmin,vmaxmini + implicit none +! arguments + real(wp_), dimension(:), intent(in) :: rv,zv,psinr,fpol + real(wp_), dimension(:,:), intent(in) :: psin + real(wp_), intent(in) :: psiwbrad + real(wp_), intent(in) :: sspl,ssfp + real(wp_), intent(in), optional :: r0,rax,zax + real(wp_), dimension(:), intent(in), optional :: rbnd,zbnd + integer, intent(in), optional :: ixp +! local constants + integer, parameter :: iopt=0 +! local variables + integer :: liwrk,lwrk,lw10,lw01,lw20,lw02,lw11,lwrkf + integer :: nr,nz,nrest,nzest,npsest,nrz,npsi,nbnd,ibinf,ibsup + real(wp_) :: sspln,fp,rax0,zax0,psinoptmp,psinxptmp + real(wp_) :: rbmin,rbmax,rbinf,rbsup,r1,z1 + real(wp_), dimension(1) :: fpoli + real(wp_), dimension(:), allocatable :: fvpsi,wf,wrk + integer, dimension(:), allocatable :: iwrk + integer :: ier,ixploc,info + +! compute array sizes and prepare working space arrays + nr=size(rv) + nz=size(zv) + nrz=nr*nz + nrest=nr+ksplp + nzest=nz+ksplp + lwrk=4+nrest*nz+(nrest+nzest)*(2*kspl+5)+(nr+nz)*ksplp+max(nz,nrest) + liwrk=nz+nr+nrest+nzest+kspl + + npsi=size(psinr) + npsest=npsi+ksplp + lwrkf=npsi*ksplp+npsest*(7+3*kspl) + + allocate(wrk(max(lwrk,lwrkf)),iwrk(max(liwrk,npsest))) + +! spline fitting/interpolation of psin(i,j) and derivatives + +! length in m !!! + + rmnm=rv(1) + rmxm=rv(nr) + zmnm=zv(1) + zmxm=zv(nz) +! allocate knots and spline coefficients arrays + if (allocated(tr)) deallocate(tr) + if (allocated(tz)) deallocate(tz) + allocate(tr(nrest),tz(nzest),cceq(nrz)) +! allocate work arrays +! reshape 2D psi array to 1D (transposed) array and compute spline coeffs + allocate(fvpsi(nrz)) + fvpsi=reshape(transpose(psin),(/nrz/)) + sspln=sspl + call regrid(iopt,nr,rv,nz,zv,fvpsi,rmnm,rmxm,zmnm,zmxm, & + kspl,kspl,sspln,nrest,nzest,nsr,tr,nsz,tz,cceq,fp, & + wrk(1:lwrk),lwrk,iwrk(1:liwrk),liwrk,ier) +! if ier=-1 data are re-fitted using sspl=0 + if(ier==-1) then + sspln=0.0_wp_ + call regrid(iopt,nr,rv,nz,zv,fvpsi,rmnm,rmxm,zmnm,zmxm, & + kspl,kspl,sspln,nrest,nzest,nsr,tr,nsz,tz,cceq,fp, & + wrk(1:lwrk),lwrk,iwrk(1:liwrk),liwrk,ier) + end if + deallocate(fvpsi) +! compute spline coefficients for psi partial derivatives + lw10 = nr*(ksplp-1) + nz*ksplp + nrz + lw01 = nr*ksplp + nz*(ksplp-1) + nrz + lw20 = nr*(ksplp-2) + nz*ksplp + nrz + lw02 = nr*ksplp + nz*(ksplp-2) + nrz + lw11 = nr*(ksplp-1) + nz*(ksplp-1) + nrz + if (allocated(cceq10)) deallocate(cceq10) + if (allocated(cceq01)) deallocate(cceq01) + if (allocated(cceq20)) deallocate(cceq20) + if (allocated(cceq02)) deallocate(cceq02) + if (allocated(cceq11)) deallocate(cceq11) + allocate(cceq10(lw10),cceq01(lw01),cceq20(lw20),cceq02(lw02),cceq11(lw11)) + call coeff_parder(tr,nsr,tz,nsz,cceq,kspl,kspl,1,0,cceq10,lw10,ier) + call coeff_parder(tr,nsr,tz,nsz,cceq,kspl,kspl,0,1,cceq01,lw01,ier) + call coeff_parder(tr,nsr,tz,nsz,cceq,kspl,kspl,2,0,cceq20,lw20,ier) + call coeff_parder(tr,nsr,tz,nsz,cceq,kspl,kspl,0,2,cceq02,lw02,ier) + call coeff_parder(tr,nsr,tz,nsz,cceq,kspl,kspl,1,1,cceq11,lw11,ier) + +! spline interpolation of fpol(i) + +! allocate knots and spline coefficients arrays + if (allocated(tfp)) deallocate(tfp) + if (allocated(cfp)) deallocate(cfp) + allocate(tfp(npsest),cfp(npsest)) + allocate(wf(npsi)) + wf(1:npsi-1)=one + wf(npsi)=1.0e2_wp_ + call curfit(iopt,npsi,psinr,fpol,wf,zero,one,kspl,ssfp,npsest,nsf, & + tfp,cfp,fp,wrk(1:lwrkf),lwrkf,iwrk(1:npsest),ier) + call splev(tfp,nsf,cfp,kspl,psinr(npsi:npsi),fpoli,1,ier) +! set vacuum value used outside 0<=psin<=1 range + fpolas=fpoli(1) + sgnbphi=sign(one,fpolas) +! free temporary arrays + deallocate(wrk,iwrk,wf) + +! re-normalize psi after spline computation + +! start with un-corrected psi + + psia=psiwbrad + psinop=0.0_wp_ + psiant=1.0_wp_ + +! use provided boundary to set an initial guess for the search of O/X points + + nbnd=0 + if(present(rbnd).and.present(zbnd)) then + nbnd=min(size(rbnd),size(zbnd)) + end if + if (nbnd>0) then + call vmaxmini(zbnd,nbnd,zbinf,zbsup,ibinf,ibsup) + rbinf=rbnd(ibinf) + rbsup=rbnd(ibsup) + call vmaxmin(rbnd,nbnd,rbmin,rbmax) + else + zbinf=zv(2) + zbsup=zv(nz-1) + rbinf=rv((nr+1)/2) + rbsup=rbinf + rbmin=rv(2) + rbmax=rv(nr-1) + end if + +! search for exact location of the magnetic axis + + if(present(rax)) then + rax0=rax + else + rax0=0.5_wp_*(rbmin+rbmax) + end if + if(present(zax)) then + zax0=zax + else + zax0=0.5_wp_*(zbinf+zbsup) + end if + call points_ox(rax0,zax0,rmaxis,zmaxis,psinoptmp,info) + print'(a,2f8.4,es12.5)','O-point',rmaxis,zmaxis,psinoptmp + +! search for X-point if ixp not = 0 + + if(present(ixp)) then + ixploc=ixp + else + ixploc=0 + end if + if(ixploc/=0) then + if(ixploc<0) then + call points_ox(rbinf,zbinf,r1,z1,psinxptmp,info) + if(psinxptmp/=-1.0_wp_) then + print'(a,2f8.4,es12.5)','X-point',r1,z1,psinxptmp + zbinf=z1 + psinop=psinoptmp + psiant=psinxptmp-psinop + call points_tgo(rmaxis,0.5_wp_*(zmaxis+zbsup),r1,z1,one,info) + zbsup=z1 + else + ixploc=0 + end if + else + call points_ox(rbsup,zbsup,r1,z1,psinxptmp,info) + if(psinxptmp.ne.-1.0_wp_) then + print'(a,2f8.4,e16.8)','X-point',r1,z1,psinxptmp + zbsup=z1 + psinop=psinoptmp + psiant=psinxptmp-psinop + call points_tgo(rmaxis,0.5_wp_*(zmaxis+zbinf),r1,z1,one,info) + zbinf=z1 + else + ixploc=0 + end if + end if + end if + + if (ixploc==0) then + psinop=psinoptmp + psiant=one-psinop +! find upper horizontal tangent point + call points_tgo(rmaxis,0.5_wp_*(zmaxis+zbsup),r1,z1,one,info) + zbsup=z1 + rbsup=r1 +! find lower horizontal tangent point + call points_tgo(rmaxis,0.5_wp_*(zmaxis+zbinf),r1,z1,one,info) + zbinf=z1 + rbinf=r1 + print'(a,4f8.4)','no X-point ',rbinf,zbinf,rbsup,zbsup + end if + print*,' ' + +! save Bt value on axis (required in flux_average and used in Jcd def) +! and vacuum value B0 at ref. radius R0 (used in Jcd_astra def) + + call equinum_fpol(0.0_wp_,btaxis) + btaxis=btaxis/rmaxis + if(present(r0)) then + btrcen=fpolas/r0 + rcen=r0 + else + btrcen=fpolas/rmaxis + rcen=rmaxis + end if + print'(a,f8.4)','BT_centr= ',btrcen + print'(a,f8.4)','BT_axis = ',btaxis + end subroutine set_eqspl + + subroutine unset_eqspl + implicit none + if(allocated(tr)) deallocate(tr) + if(allocated(tz)) deallocate(tz) + if(allocated(tfp)) deallocate(tfp) + if(allocated(cfp)) deallocate(cfp) + if(allocated(cceq)) deallocate(cceq) + if(allocated(cceq01)) deallocate(cceq01) + if(allocated(cceq10)) deallocate(cceq10) + if(allocated(cceq02)) deallocate(cceq02) + if(allocated(cceq20)) deallocate(cceq20) + if(allocated(cceq11)) deallocate(cceq11) + nsr=0 + nsz=0 + nsf=0 + end subroutine unset_eqspl + + subroutine equinum_psi(rpsim,zpsim,psinv,dpsidr,dpsidz, & + ddpsidrr,ddpsidzz,ddpsidrz) + use dierckx, only : fpbisp + implicit none +! local constants + integer, parameter :: lwrk=8,liwrk=2 +! arguments + real(wp_), intent(in) :: rpsim,zpsim + real(wp_), intent(out), optional :: psinv,dpsidr,dpsidz, & + ddpsidrr,ddpsidzz,ddpsidrz + +! local variables + integer, dimension(liwrk) :: iwrk + real(wp_), dimension(1) :: rrs,zzs,ffspl + real(wp_), dimension(lwrk) :: wrk + +! here lengths are measured in meters + + if (rpsim.le.rmxm .and. rpsim.ge.rmnm .and. & + zpsim.le.zmxm .and. zpsim.ge.zmnm) then + + if (present(psinv)) then + rrs(1)=rpsim + zzs(1)=zpsim + call fpbisp(tr,nsr,tz,nsz,cceq,3,3,rrs,1,zzs,1,ffspl, & + wrk(1),wrk(5),iwrk(1),iwrk(2)) + psinv=(ffspl(1)-psinop)/psiant + end if + if (present(dpsidr)) then + call sub_derpsi(rpsim,zpsim,1,0,dpsidr,cceq10) + end if + if (present(dpsidz)) then + call sub_derpsi(rpsim,zpsim,0,1,dpsidz,cceq01) + end if + if (present(ddpsidrr)) then + call sub_derpsi(rpsim,zpsim,2,0,ddpsidrr,cceq20) + end if + if (present(ddpsidzz)) then + call sub_derpsi(rpsim,zpsim,0,2,ddpsidzz,cceq02) + end if + if (present(ddpsidrz)) then + call sub_derpsi(rpsim,zpsim,1,1,ddpsidrz,cceq11) + end if + else + if(present(psinv)) psinv=-1.0_wp_ + if(present(dpsidr)) dpsidr=0.0_wp_ + if(present(dpsidz)) dpsidz=0.0_wp_ + if(present(ddpsidrr)) ddpsidrr=0.0_wp_ + if(present(ddpsidzz)) ddpsidzz=0.0_wp_ + if(present(ddpsidrz)) ddpsidrz=0.0_wp_ + end if + end subroutine equinum_psi + + subroutine sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc) + use dierckx, only : fpbisp + implicit none +! arguments + real(wp_), intent(in) :: rpsim,zpsim + integer, intent(in) :: nur,nuz + real(wp_), intent(out) :: derpsi + real(wp_), dimension(:) :: cc +! local variables + integer, dimension(1) :: iwrkr,iwrkz + real(wp_), dimension(1) :: rrs,zzs,ffspl + real(wp_), dimension(1,ksplp) :: wrkr + real(wp_), dimension(1,ksplp) :: wrkz + + rrs(1)=rpsim + zzs(1)=zpsim + call fpbisp(tr(nur+1),nsr-2*nur,tz(nuz+1),nsz-2*nuz,cc,kspl-nur,kspl-nuz, & + rrs,1,zzs,1,ffspl,wrkr,wrkz,iwrkr,iwrkz) + derpsi=ffspl(1)*psia + end subroutine sub_derpsi + + subroutine equinum_fpol(psinv,fpolv,dfpv) + use dierckx, only : splev,splder + implicit none +! arguments + real(wp_), intent(in) :: psinv + real(wp_), intent(out) :: fpolv + real(wp_), intent(out), optional :: dfpv +! local variables + integer :: ier + real(wp_), dimension(1) :: rrs,ffspl + real(wp_), dimension(nsf) :: wrkfd +! + if(psinv.le.1.0_wp_.and.psinv.ge.0.0_wp_) then + rrs(1)=psinv + call splev(tfp,nsf,cfp,3,rrs,ffspl,1,ier) + fpolv=ffspl(1) + if(present(dfpv)) then + call splder(tfp,nsf,cfp,3,1,rrs,ffspl,1,wrkfd,ier) + dfpv=ffspl(1)/psia + end if + else + fpolv=fpolas + if (present(dfpv)) dfpv=0._wp_ + end if + end subroutine equinum_fpol + + subroutine bfield(rpsim,zpsim,bphi,br,bz) + use gray_params, only : iequil + implicit none +! arguments + real(wp_), intent(in) :: rpsim,zpsim + real(wp_), intent(out), optional :: bphi,br,bz +! local variables + real(wp_) :: psin,fpol + + if (iequil < 2) then + call equian(rpsim,zpsim,fpolv=bphi,dpsidr=bz,dpsidz=br) + if (present(bphi)) bphi=bphi/rpsim + else + call equinum_psi(rpsim,zpsim,psinv=bphi,dpsidr=bz,dpsidz=br) + if (present(bphi)) then + psin=bphi + call equinum_fpol(psin,fpol) + bphi=fpol/rpsim + end if + end if + if (present(br)) br=-br/rpsim + if (present(bz)) bz= bz/rpsim + end subroutine bfield + + subroutine setqphi_num(psinq,q,psia,rhotn) + use const_and_precisions, only : pi + use simplespline, only : difcs + implicit none +! arguments + real(wp_), dimension(:), intent(in) :: psinq,q + real(wp_), intent(in) :: psia + real(wp_), dimension(:), intent(out), optional :: rhotn +! local variables + real(wp_), dimension(size(q)) :: phit + real(wp_) :: dx + integer, parameter :: iopt=0 + integer :: k,ier + + nq=size(q) + if(allocated(psinr)) deallocate(psinr) + if(allocated(cq)) deallocate(cq) + allocate(psinr(nq),cq(nq,4)) + + psinr=psinq + call difcs(psinr,q,nq,iopt,cq,ier) + +! Toroidal flux phi = 2*pi*Integral q dpsi + phit(1)=0.0_wp_ + do k=1,nq-1 + dx=psinr(k+1)-psinr(k) + phit(k+1)=phit(k) + dx*(cq(k,1) + dx*(cq(k,2)/2.0_wp_ + & + dx*(cq(k,3)/3.0_wp_ + dx* cq(k,4)/4.0_wp_) ) ) + end do + phitedge=phit(nq) + if(present(rhotn)) rhotn(1:nq)=sqrt(phit/phitedge) + phitedge=2*pi*psia*phitedge + end subroutine setqphi_num + + subroutine unset_q + implicit none + + if(allocated(psinr)) deallocate(psinr) + if(allocated(cq)) deallocate(cq) + nq=0 + end subroutine unset_q + + function fq(psin) + use const_and_precisions, only : wp_ + use gray_params, only : iequil + use simplespline, only :spli + use utils, only : locate + implicit none +! arguments + real(wp_), intent(in) :: psin + real(wp_) :: fq +! local variables + integer :: i + real(wp_) :: dps,rn + + if (iequil<2) then + rn=frhotor(sqrt(psin)) + fq=q0+(qa-q0)*rn**alq + else + call locate(psinr,nq,psin,i) + i=min(max(1,i),nq-1) + dps=psin-psinr(i) + fq=spli(cq,nq,i,dps) + end if + end function fq + + subroutine set_rhospl(rhop,rhot) + use simplespline, only : difcs + implicit none +! arguments + real(wp_), dimension(:), intent(in) :: rhop, rhot +! local variables + integer, parameter :: iopt=0 + integer :: ier + + nrho=size(rhop) + + if(allocated(rhopr)) deallocate(rhopr) + if(allocated(rhotr)) deallocate(rhotr) + if(allocated(crhop)) deallocate(crhop) + if(allocated(crhot)) deallocate(crhot) + allocate(rhopr(nrho),rhotr(nrho),crhop(nrho,4),crhot(nrho,4)) + + rhopr=rhop + rhotr=rhot + call difcs(rhotr,rhopr,nrho,iopt,crhop,ier) + call difcs(rhopr,rhotr,nrho,iopt,crhot,ier) + end subroutine set_rhospl + + subroutine unset_rhospl + implicit none + + if(allocated(rhopr)) deallocate(rhopr) + if(allocated(rhotr)) deallocate(rhotr) + if(allocated(crhop)) deallocate(crhop) + if(allocated(crhot)) deallocate(crhot) + nrho=0 + end subroutine unset_rhospl + + function frhopol(rhot) + use utils, only : locate + use simplespline, only : spli + implicit none +! arguments + real(wp_), intent(in) :: rhot + real(wp_) :: frhopol +! local variables + integer :: i + real(wp_) :: dr + + call locate(rhotr,nrho,rhot,i) + i=min(max(1,i),nrho-1) + dr=rhot-rhotr(i) + frhopol=spli(crhop,nrho,i,dr) + end function frhopol + + function frhopolv(rhot) + use utils, only : locate + use simplespline, only : spli + implicit none +! arguments + real(wp_), dimension(:), intent(in) :: rhot + real(wp_), dimension(size(rhot)) :: frhopolv +! local variables + integer :: i,i0,j + real(wp_) :: dr + + i0=1 + do j=1,size(rhot) + call locate(rhotr(i0:),nrho-i0+1,rhot(j),i) + i=min(max(1,i),nrho-i0)+i0-1 + dr=rhot(j)-rhotr(i) + frhopolv(j)=spli(crhop,nrho,i,dr) + i0=i + end do + end function frhopolv + + function frhotor(rhop) + use utils, only : locate + use simplespline, only : spli + implicit none +! arguments + real(wp_), intent(in) :: rhop + real(wp_) :: frhotor +! local variables + integer :: i + real(wp_) :: dr + + call locate(rhopr,nrho,rhop,i) + i=min(max(1,i),nrho-1) + dr=rhop-rhopr(i) + frhotor=spli(crhot,nrho,i,dr) + end function frhotor + + subroutine points_ox(rz,zz,rf,zf,psinvf,info) + use const_and_precisions, only : comp_eps + use minpack, only : hybrj1 + implicit none +! local constants + integer, parameter :: n=2,ldfjac=n,lwa=(n*(n+13))/2 +! arguments + real(wp_), intent(in) :: rz,zz + real(wp_), intent(out) :: rf,zf,psinvf + integer, intent(out) :: info +! local variables + real(wp_) :: tol + real(wp_), dimension(n) :: xvec,fvec + real(wp_), dimension(lwa) :: wa + real(wp_), dimension(ldfjac,n) :: fjac + + xvec(1)=rz + xvec(2)=zz + tol = sqrt(comp_eps) + 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) + call equinum_psi(rf,zf,psinvf) + end subroutine points_ox + + subroutine fcnox(n,x,fvec,fjac,ldfjac,iflag) + implicit none +! arguments + integer, intent(in) :: n,iflag,ldfjac + real(wp_), dimension(n), intent(in) :: x + real(wp_), dimension(n), intent(inout) :: fvec + real(wp_), dimension(ldfjac,n), intent(inout) :: fjac +! local variables + real(wp_) :: dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz + + select case(iflag) + case(1) + call equinum_psi(x(1),x(2),dpsidr=dpsidr,dpsidz=dpsidz) + fvec(1) = dpsidr/psia + fvec(2) = dpsidz/psia + case(2) + call equinum_psi(x(1),x(2),ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz, & + ddpsidrz=ddpsidrz) + fjac(1,1) = ddpsidrr/psia + fjac(1,2) = ddpsidrz/psia + fjac(2,1) = ddpsidrz/psia + fjac(2,2) = ddpsidzz/psia + case default + print*,'iflag undefined' + end select + end subroutine fcnox + + subroutine points_tgo(rz,zz,rf,zf,psin0,info) + use const_and_precisions, only : comp_eps + use minpack, only : hybrj1mv + implicit none +! local constants + integer, parameter :: n=2,ldfjac=n,lwa=(n*(n+13))/2 +! arguments + real(wp_), intent(in) :: rz,zz,psin0 + real(wp_), intent(out) :: rf,zf + integer, intent(out) :: info +! local variables + real(wp_) :: tol + real(wp_), dimension(n) :: xvec,fvec,f0 + real(wp_), dimension(lwa) :: wa + real(wp_), dimension(ldfjac,n) :: fjac + + xvec(1)=rz + xvec(2)=zz + f0(1)=psin0 + f0(2)=0.0_wp_ + tol = sqrt(comp_eps) + call hybrj1mv(fcntgo,n,xvec,f0,fvec,fjac,ldfjac,tol,info,wa,lwa) + if(info.gt.1) then + print'(a,i2,a,5f8.4)',' info subr points_tgo =',info, & + ' R,z coord.',xvec,rz,zz,psin0 + end if + rf=xvec(1) + zf=xvec(2) + end + + subroutine fcntgo(n,x,f0,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none +! arguments + integer, intent(in) :: n,ldfjac,iflag + real(wp_), dimension(n), intent(in) :: x,f0 + real(wp_), dimension(n), intent(inout) :: fvec + real(wp_), dimension(ldfjac,n), intent(inout) :: fjac +! internal variables + real(wp_) :: psinv,dpsidr,dpsidz,ddpsidrr,ddpsidrz + + select case(iflag) + case(1) + call equinum_psi(x(1),x(2),psinv,dpsidr) + fvec(1) = psinv-f0(1) + fvec(2) = dpsidr/psia-f0(2) + case(2) + call equinum_psi(x(1),x(2),dpsidr=dpsidr,dpsidz=dpsidz, & + ddpsidrr=ddpsidrr,ddpsidrz=ddpsidrz) + fjac(1,1) = dpsidr/psia + fjac(1,2) = dpsidz/psia + fjac(2,1) = ddpsidrr/psia + fjac(2,2) = ddpsidrz/psia + case default + print*,'iflag undefined' + end select + end subroutine fcntgo + + subroutine set_equian(rax,zax,a,bax,qax,q1,qexp,n) + use const_and_precisions, only : pi,zero,one + implicit none +! arguments + real(wp_), intent(in) :: rax,zax,a,bax,qax,q1,qexp + integer, intent(in), optional :: n +! local variables + integer, parameter :: nqdef=101 + integer :: i + real(wp_) :: dr,fq0,fq1,qq,res,rn + real(wp_), dimension(:), allocatable :: rhotn,rhopn + + btaxis=bax + rmaxis=rax + zmaxis=zax + btrcen=bax + rcen=rax + aminor=a + zbinf=zmaxis-a + zbsup=zmaxis+a + q0=qax + qa=q1 + alq=qexp + sgnbphi=sign(one,bax) + + if (present(n)) then + nq=n + else + nq=nqdef + end if + if (allocated(psinr)) deallocate(psinr) + allocate(psinr(nq),rhotn(nq),rhopn(nq)) + + dr=one/(nq-1) + rhotn(1)=zero + psinr(1)=zero + res=zero + fq0=zero + do i=2,nq + rn=(i-1)*dr + qq=q0+(q1-q0)*rn**qexp + fq1=rn/qq + res=res+0.5_wp_*(fq1+fq0)*dr + fq0=fq1 + rhotn(i)=rn + psinr(i)=res + end do + + phitedge=btaxis*aminor**2 ! temporary + psia=res*phitedge + phitedge=pi*phitedge ! final + psinr=psinr/res + rhopn=sqrt(psinr) + + call set_rhospl(rhopn,rhotn) + end subroutine set_equian + + subroutine equian(rrm,zzm,psinv,fpolv,dfpv,dpsidr,dpsidz, & + ddpsidrr,ddpsidzz,ddpsidrz) + use const_and_precisions, only : wp_ + implicit none +! arguments + real(wp_), intent(in) :: rrm,zzm + real(wp_), intent(out), optional :: psinv,fpolv,dfpv,dpsidr,dpsidz, & + ddpsidrr,ddpsidzz,ddpsidrz +! local variables + real(wp_) :: cst,dpsidrp,d2psidrp,dqq,qq,rn,rpm,snt,rhop,rhot,btaxqq + +! simple model for equilibrium: large aspect ratio +! outside plasma: analytical continuation, not solution Maxwell eqs + + rpm=sqrt((rrm-rmaxis)**2+(zzm-zmaxis)**2) !!! rpm==rho_tor[m], rn=rho_tor_norm + rn=rpm/aminor + + snt=0.0_wp_ + cst=1.0_wp_ + if (rpm > 0.0_wp_) then + snt=(zzm-zmaxis)/rpm + cst=(rrm-rmaxis)/rpm + end if + + if (present(psinv)) then + rhot=rn + if(rn <= 1.0_wp_) then + rhop=frhopol(rhot) + psinv=rhop**2 + else + psinv=1.0_wp_+btaxis/(2.0_wp_*psia*qa)*(rpm**2-aminor**2) + rhop=sqrt(psinv) + end if + end if + + if(rn <= 1.0_wp_) then + qq=q0+(qa-q0)*rn**alq + btaxqq=btaxis/qq + dpsidrp=btaxqq*rpm + dqq=alq*(qa-q0)*rn**(alq-1.0_wp_) + d2psidrp=btaxqq*(1.0_wp_-rn*dqq/qq) + else + btaxqq=btaxis/qa + dpsidrp=btaxqq*rpm + d2psidrp=btaxqq + end if + + if(present(fpolv)) fpolv=btaxis*rmaxis + if(present(dfpv)) dfpv=0.0_wp_ + + if(present(dpsidr)) dpsidr=dpsidrp*cst + if(present(dpsidz)) dpsidz=dpsidrp*snt + if(present(ddpsidrr)) ddpsidrr=btaxqq*snt**2+cst**2*d2psidrp + if(present(ddpsidrz)) ddpsidrz=cst*snt*(d2psidrp-btaxqq) + if(present(ddpsidzz)) ddpsidzz=btaxqq*cst**2+snt**2*d2psidrp + end subroutine equian + + + + subroutine tor_curr(rpsim,zpsim,ajphi) + use const_and_precisions, only : wp_,ccj=>mu0inv + use gray_params, only : iequil + implicit none +! arguments + real(wp_) :: rpsim,zpsim,ajphi +! local variables + real(wp_) :: bzz,dbvcdc13,dbvcdc31 + real(wp_) :: dpsidr,ddpsidrr,ddpsidzz + + if(iequil < 2) then + call equian(rpsim,zpsim,dpsidr=dpsidr, & + ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz) + else + call equinum_psi(rpsim,zpsim,dpsidr=dpsidr, & + ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz) + end if + bzz= dpsidr/rpsim + dbvcdc13=-ddpsidzz/rpsim + dbvcdc31= ddpsidrr/rpsim-bzz/rpsim + ajphi=ccj*(dbvcdc13-dbvcdc31) + end subroutine tor_curr + + + + subroutine psi_raxis(psin,r1,r2) + use const_and_precisions, only : wp_ + use gray_params, only : iequil + use dierckx, only : profil,sproota + implicit none +! local constants + integer, parameter :: mest=4 +! arguments + real(wp_) :: psin,r1,r2 +! local variables + integer :: iopt,ier,m + real(wp_) :: zc,val + real(wp_), dimension(mest) :: zeroc + real(wp_), dimension(nsr) :: czc + + if (iequil < 2) then + val=frhotor(sqrt(psin)) + r1=rmaxis-val*aminor + r2=rmaxis+val*aminor + else + iopt=1 + zc=zmaxis + call profil(iopt,tr,nsr,tz,nsz,cceq,kspl,kspl,zc,nsr,czc,ier) + if(ier.gt.0) print*,' profil =',ier + val=psin*psiant+psinop + call sproota(val,tr,nsr,czc,zeroc,mest,m,ier) + r1=zeroc(1) + r2=zeroc(2) + end if + end subroutine psi_raxis + + + + subroutine tor_curr_psi(psin,ajphi) + use const_and_precisions, only : wp_ + implicit none +! arguments + real(wp_) :: psin,ajphi +! local variables + real(wp_) :: r1,r2 + call psi_raxis(psin,r1,r2) + call tor_curr(r2,zmaxis,ajphi) + end subroutine tor_curr_psi + +end module equilibrium diff --git a/src/gray-externals.f90 b/src/gray-externals.f90 new file mode 100644 index 0000000..5cc4be0 --- /dev/null +++ b/src/gray-externals.f90 @@ -0,0 +1,891 @@ +! program gray +! use gray_params, only : ipass,igrad +! implicit none +!! local variables +! real(wp_) :: p0mw1 +!! common/external functions/variables +! integer :: ierr,index_rt +! real(wp_) :: sox,p0mw,powrfl,taumn,taumx,pabstot,currtot, +!! +! common/ierr/ierr +! common/mode/sox +! common/p0/p0mw +! common/powrfl/powrfl +! common/index_rt/index_rt +! common/taumnx/taumn,taumx,pabstot,currtot +!! +! if (ipass.gt.1) then +!! second pass into plasma +! p0mw1=p0mw +! igrad=0 +!! +! index_rt=2 +! p0mw=p0mw1*powrfl +! call prfile +! call vectinit2 +! call paraminit +! call ic_rt2 +! call gray_integration +! call after_gray_integration +! pabstott=pabstott+pabstot +! currtott=currtott+currtot +!! +! index_rt=3 +! sox=-sox +! p0mw=p0mw1*(1.0_wp_-powrfl) +! call prfile +! call vectinit2 +! call paraminit +! call ic_rt2 +! call gray_integration +! call after_gray_integration +! pabstott=pabstott+pabstot +! currtott=currtott+currtot +! end if +!! +! end program gray +! +! +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ins_pl=inside_plasma(rrm,zzm) +! if (mod(iop(j,k),2).eq.0 .and. ins_pl) then +! iop(j,k)=iop(j,k)+1 +! call pol_limit(sox,ext(j,k,iop(j,k)),eyt(j,k,iop(j,k))) +! +! if (ipass.gt.1 .and. index_rt.eq.1 .and. +! . iowmax.gt.1 .and. istore(j,k).eq.0) then +! istore(j,k)=istore(j,k)+1 +! yyrfl(j,k,1:3)=xv +! yyrfl(j,k,4:6)=anv +! ihcd(j,k)=0 +! end if +! else if (mod(iop(j,k),2).eq.1.and. +! . .not.ins_pl) then +! iop(j,k)=iop(j,k)+1 +! call pol_limit(sox,ext(j,k,iop(j,k)),eyt(j,k,iop(j,k))) +! end if +! +! if (ipass.gt.1) then +! if (iow(j,k).eq.0 .and. inside(rlim,zlim,nlim,rrm,zzm)) then +! iow(j,k)=1 +! else if (iow(j,k).eq.1 .and. +! . .not.inside(rlim,zlim,nlim,rrm,zzm)) then +! iow(j,k)=2 +! if (ins_pl) then +! iop(j,k)=iop(j,k)+1 +! call pol_limit(sox,ext(j,k,iop(j,k)),eyt(j,k,iop(j,k))) +! end if +! call wall_refl(xv-dst*anv,anv,ext(j,k,iop(j,k)), +! . eyt(j,k,iop(j,k)),xvrfl,anvrfl,extr,eytr,anw,irfl) +! istore(j,k)=istore(j,k)+1 +! yyrfl(j,k,1:3)=xvrfl +! yyrfl(j,k,4:6)=anvrfl +! tau1v(j,k)=tauv(j,k,iiv(j,k)) +! ext(j,k,iop(j,k))=extr +! eyt(j,k,iop(j,k))=eytr +! if (j.lt.jclosest) then +! jclosest=j +! anwcl=anw +! xwcl=xvrfl +! end if +! xv=xvrfl +! anv=anvrfl +! rrm=1.0e-2_wp_*sqrt(xv(1)**2+xv(2)**2) +! zzm=1.0e-2_wp_*xv(3) +! ywrk(1:3,j,k)=xv +! ywrk(4:6,j,k)=anv +! igrad=0 +! call gwork(sox,xgcn,bres,j,k) +! if (ins_pl) then +! iop(j,k)=iop(j,k)+1 +! call pol_limit(sox,ext(j,k,iop(j,k)),eyt(j,k,iop(j,k))) +! if (index_rt.eq.1) ihcd(j,k)=0 +! end if +! end if +! end if +! +! if(index_rt.eq.1 .and. j.eq.1) psinv11=psinv +! if(iop(j,k).lt.iopmin) iopmin=iop(j,k) +! if(iow(j,k).lt.iowmin) iowmin=iow(j,k) +! if(iow(j,k).gt.iowmax) iowmax=iow(j,k) +! +! xvjk(:,j,k)=xv +! anvjk(:,j,k)=anv +! +! end do +! end do +! if(jclosest.le.nrayr) then +! aknmin=1.0_wp_ +! do j=1,nrayr +! kkk=nrayth +! if(j.eq.1) kkk=1 +! do k=1,kkk +! print*,i,j,k +! print*,anwcl,xwcl,anvjk(1:2,j,k) +! anwclr=(anwcl(1)*xwcl(1)+anwcl(2)*xwcl(2)) +! . /sqrt(xwcl(1)**2+xwcl(2)**2) +! anvjkr=(anvjk(1,j,k)*xvjk(1,j,k)+anvjk(2,j,k)*xvjk(2,j,k)) +! . /sqrt(xvjk(1,j,k)**2+xvjk(2,j,k)**2) +! akdotn=anwclr*anvjkr+anwcl(3)*anvjk(3,j,k) +! if(akdotn.lt.aknmin) aknmin=akdotn +! end do +! end do +! else +! aknmin=-1.0_wp_ +! end if +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!! single pass is stopped when all the rays have crossed the plasma +!! or complete absorption has occurred +!! same for successive passes of multi-pass simulations (here exit +!! from vessel is detected too +!! first pass in multi-pass simulation is stopped when at least one +!! ray has reflected and all rays are directed away from +!! reflection point, or when no reflection has occurred and +!! central ray re-enters the plasma +! +! if((ipass.eq.1 .and. ((iopmin.gt.1) .or. +! . (taumn.lt.1.0e+30_wp_.and.taumn.gt.taucr))) +! . .or.(index_rt.gt.1 .and. (iopmin.gt.1 .or. iowmin.gt.1 .or. +! . (taumn.lt.1.0e+30_wp_.and.taumn.gt.taucr)))) then +! istop=1 +! else if(ipass.gt.1 .and. index_rt.eq.1 .and. +! . ((iowmin.gt.1 .and. aknmin.gt.0) .or. +! . (iowmax.le.1 .and. iop(1,1).gt.2))) then +!! flag second pass mode coupling as unset +! powrfl=-1.0_wp_ +! qqout=0.0_wp_ +! uuout=0.0_wp_ +! vvout=0.0_wp_ +! do j=1,nrayr +! kkk=nrayth +! if(j.eq.1) kkk=1 +! do k=1,kkk +!! store missing initial conditions for the second pass +! if (istore(j,k).eq.0) then +! istore(j,k)=istore(j,k)+1 +! yyrfl(j,k,1:3)=xvjk(:,j,k) +! yyrfl(j,k,4:6)=anvjk(:,j,k) +! tau1v(j,k)=tauv(j,k,iiv(j,k)) +! end if +!! determine mode coupling at the plasma boundary +! if (powrfl.lt.0.0_wp_) then +! call vacuum_rt(xvjk(:,j,k),anvjk(:,j,k),xvvac,ivac) +!! look for first ray hitting the plasma, starting from the central +!! and evaluate polarization +! if (ivac.eq.1) then +! y(1:3)=xvjk(:,j,k) +! y(4:6)=anvjk(:,j,k) +! call fwork(sox,xgcn,bres,y,dery) +! call pol_limit(sox,exin2,eyin2) +! call stokes(exin2,eyin2,qqin2,uuin2,vvin2) +! powloop: do j1=1,nrayr +! kkkk=nrayth +! if(j1.eq.1) kkkk=1 +! do k1=1,kkkk +!! look for first ray which completed the first pass in the plasma +! if (iop(j1,k1).gt.1) then +!! if found, use its polarization state to compute mode coupling +! call stokes(ext(j1,k1,2),eyt(j1,k1,2), +! . qqout,uuout,vvout) +! exit powloop +! end if +! end do +! end do powloop +!! if no ray completed a first pass in the plasma, use central ray +!! initial polarization (possibly reflected) +! if (qqout.le.0.0_wp_) then +! call stokes(ext(1,1,0),eyt(1,1,0),qqout,uuout,vvout) +! end if +! powrfl=0.5_wp_*(1.0_wp_+vvout*vvin2+ +! . uuout*uuin2+qqout*qqin2) +! end if +! end if +! end do +! end do +! strfl11=i*dst +! write(6,*) ' ' +! write(6,*) 'Reflected power fraction =',powrfl +! write(66,*) psipol,chipol,powrfl +! istop=1 +! end if +! +! return +! end +! +! +! +! subroutine ic_rt(x00,y00,z00,anx0c,any0c,anz0c,ak0,xgcn,bres, +! . wcsi,weta,rcicsi,rcieta,phiw,phir,sox,psipol0,chipol0) +!! ray tracing initial conditions igrad=0 +!! +! use const_and_precisions, only : wp_,izero,zero,one,pi, +! . cvdr=>degree,ui=>im +! use gray_params, only : ipol +! use beamdata, only : nrayr,nrayth,rwmax,ywrk0=>ywrk,ypwrk0=>ypwrk, +! . xc0=>xc,du10=>du1,dffiu,ddffiu,grad2,dgrad2v,gri,ggri,ext,eyt +! implicit none +!! arguments +! real(wp_), intent(in) :: x00,y00,z00,anx0c,any0c,anz0c +! real(wp_), intent(in) :: ak0,xgcn,bres +! real(wp_), intent(in) :: wcsi,weta,rcicsi,rcieta,phiw,phir +! real(wp_), intent(in) :: sox,psipol0,chipol0 +!! local constants +! integer, parameter :: ndim=6,ndimm=3 +!! local variables +! integer :: j,k,iv,jv,iproj,nfilp +! real(wp_) :: csth,snth,csps,snps,phiwrad,csphiw,snphiw,dr,da,u, +! . alfak,dcsiw,detaw,dx0t,dy0t,x0t,y0t,z0t,dx0,dy0,dz0,x0,y0,z0, +! . anzt,anxt,anyt,anx,any,anz,an20,an0,anx0,any0,anz0,vgradi,r0, +! . x0m,y0m,r0m,z0m,ancsi,aneta,ppcsi,ppeta,deltapol,qq,uu,vv +! real(wp_), dimension(ndim) :: ytmp,yptmp +!! common/external functions/variables +! real(wp_) :: dd,an2s,an2,fdia,bdotgr,ddi,ddr11,psinv,dens,ddens, +! . tekev,anpl,anpr,brr,bphi,bzz,ajphi,psipol,chipol,psinv11 +! +!! +! common/ddd/dd,an2s,an2,fdia,bdotgr,ddi,ddr11 +! common/nplr/anpl,anpr +! common/psival/psinv +! common/parpl/brr,bphi,bzz,ajphi +! common/dens/dens,ddens +! common/tete/tekev +! common/polcof/psipol,chipol +! common/psinv11/psinv11 +!! +! csth=anz0c +! snth=sqrt(1.0_wp_-csth**2) +! csps=1.0_wp_ +! snps=0.0_wp_ +! if(snth.gt.0.0_wp_) then +! csps=any0c/snth +! snps=anx0c/snth +! end if +!! +! phiwrad=phiw*cvdr +! csphiw=cos(phiwrad) +! snphiw=sin(phiwrad) +!! +! dr=1.0_wp_ +! if(nrayr.gt.1) dr=rwmax/dble(nrayr-1) +! da=2.0_wp_*pi/dble(nrayth) +! z0t=0.0_wp_ +!! +! do j=1,nrayr +! u=dble(j-1) +! dffiu(j)=0.0_wp_ +! ddffiu(j)=0.0_wp_ +! do k=1,nrayth +! 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 +!! +!! csiw=u*dcsiw +!! etaw=u*detaw +!! csir=csiw +!! etar=etaw +!! +! dx0= x0t*csps+snps*(y0t*csth+z0t*snth) +! dy0=-x0t*snps+csps*(y0t*csth+z0t*snth) +! dz0= z0t*csth-y0t*snth +!! +! x0=x00+dx0 +! y0=y00+dy0 +! z0=z00+dz0 +!! +! ppcsi=u*dr*cos(alfak)*rcicsi +! ppeta=u*dr*sin(alfak)*rcieta +!! +! anzt=1.0_wp_/sqrt(1.0_wp_+ppcsi**2+ppeta**2) +! ancsi=ppcsi*anzt +! aneta=ppeta*anzt +!! +! anxt=ancsi*csphiw-aneta*snphiw +! anyt=ancsi*snphiw+aneta*csphiw +!! +! anx= anxt*csps+snps*(anyt*csth+anzt*snth) +! any=-anxt*snps+csps*(anyt*csth+anzt*snth) +! anz= anzt*csth-anyt*snth +!! +! an20=1.0_wp_ +! an0=sqrt(an20) +! anx0=anx +! any0=any +! anz0=anz +!! +! xc0(1,j,k)=x0 +! xc0(2,j,k)=y0 +! xc0(3,j,k)=z0 +!! +! 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 +!! +! ypwrk0(1,j,k) = anx0/an0 +! ypwrk0(2,j,k) = any0/an0 +! ypwrk0(3,j,k) = anz0/an0 +! ypwrk0(4,j,k) = 0.0_wp_ +! ypwrk0(5,j,k) = 0.0_wp_ +! ypwrk0(6,j,k) = 0.0_wp_ +!! +! ytmp=ywrk0(:,j,k) +! yptmp=ypwrk0(:,j,k) +! call fwork(sox,xgcn,bres,ytmp,yptmp) +! +! if(ipol.eq.0) then +! call pol_limit(sox,ext(j,k,0),eyt(j,k,0)) +! qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2 +! uu=2.0_wp_*dble(ext(j,k,0)*dconjg(eyt(j,k,0))) +! vv=2.0_wp_*dimag(ext(j,k,0)*dconjg(eyt(j,k,0))) +! call polellipse(qq,uu,vv,psipol0,chipol0) +! else +! qq=cos(2.0_wp_*chipol0*cvdr)*cos(2.0_wp_*psipol0*cvdr) +! uu=cos(2.0_wp_*chipol0*cvdr)*sin(2.0_wp_*psipol0*cvdr) +! vv=sin(2.0_wp_*chipol0*cvdr) +! if(qq**2.lt.1.0_wp_) then +!! deltapol=phix-phiy, phix =0 +! deltapol=atan2(vv,uu) +! ext(j,k,0)= sqrt((1.0_wp_+qq)/2) +! eyt(j,k,0)= sqrt((1.0_wp_-qq)/2)*exp(-ui*deltapol) +! else +! if(qq.gt.0.0_wp_) then +! ext(j,k,0)= 1.0_wp_ +! eyt(j,k,0)= 0.0_wp_ +! else +! eyt(j,k,0)= 1.0_wp_ +! ext(j,k,0)= 0.0_wp_ +! end if +! end if +! endif +! psipol=psipol0 +! chipol=chipol0 +!! +! do iv=1,3 +! gri(iv,j,k)=0.0_wp_ +! dgrad2v(iv,j,k)=0.0_wp_ +! du10(iv,j,k)=0.0_wp_ +! do jv=1,3 +! ggri(iv,jv,j,k)=0.0_wp_ +! end do +! end do +! grad2(j,k)=0.0_wp_ +!! +! dd=anx0**2+any0**2+anz0**2-an20 +! vgradi=0.0_wp_ +! ddi=2.0_wp_*vgradi +!! +! r0=sqrt(x0**2+y0**2) +! x0m=x0/1.0e2_wp_ +! y0m=y0/1.0e2_wp_ +! r0m=r0/1.0e2_wp_ +! z0m=z0/1.0e2_wp_ +! if(j.eq.nrayr) then +! write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m, +! . psinv,zero,anpl,zero,one +! end if +! if(j.eq.1.and.k.eq.1) then +! psinv11=psinv +! write(17,99) zero,zero,zero,zero +! write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0_wp_/pi, +! . psinv,one,dens,tekev,brr,bphi,bzz, +! . ajphi*1.0e-6_wp_,sqrt(anpl**2+anpr**2),anpl,zero, +! . zero,zero,zero,zero,zero,zero,zero,one +! end if +! end do +! end do +! +! call pweigth +!! +! if(nrayr.gt.1) then +! iproj=0 +! nfilp=8 +! call projxyzt(iproj,nfilp) +! end if +!! +! return +!99 format(24(1x,e16.8e3)) +!111 format(3i5,20(1x,e16.8e3)) +! end + + + + subroutine prfile + implicit none + write(4,*)' #sst R z phi psi rhot ne Te Btot '// & + 'Nperp Npl ki alpha tau Pt dIds nh iohkw index_rt ddr' + write(8,*) ' #istep j k xt yt zt rt psin' + write(9,*) ' #istep j k xt yt zt rt psin' + write(17,*) ' #sst Dr_Nr1 Di_Nr1' + write(33,*) ' #i jk sst x y R z psi tauv Npl alpha index_rt' + write(12,*) ' #i sst psi w1 w2' + write(7,*)'#Icd Pa Jphip dPdVp rhotj rhotjava rhotp rhotpav '// & + 'drhotjava drhotpav ratjamx ratjbmx stmx psipol chipol index_rt '// & + 'Jphimx dPdVmx drhotj drhotp' + write(48,*) '#rhop rhot Jphi Jcdb dPdV Icdins Pins' + write(66,*) "# psipol0 chipol0 powrfl" + end subroutine prfile + + + + subroutine print_prof + use const_and_precisions, only : wp_ + use equilibrium, only : psinr,nq,fq,frhotor,tor_curr_psi + use coreprofiles, only : density, temp + implicit none +! local constants + real(wp_), parameter :: eps=1.e-4_wp_ +! local variables + integer :: i + real(wp_) :: psin,rhop,rhot,ajphi,te,qq + real(wp_) :: dens,ddens + + write(55,*) ' #psi rhot ne Te q Jphi' + do i=1,nq + psin=psinr(i) + rhop=sqrt(psin) + + call density(psin,dens,ddens) + te=temp(psin) + qq=fq(psin) + rhot=frhotor(rhop) + call tor_curr_psi(max(eps,psin),ajphi) + write(55,"(12(1x,e12.5))") psin,rhot,dens,te,qq,ajphi*1.e-6_wp_ + end do + end subroutine print_prof + + subroutine print_prof_an + use const_and_precisions, only : wp_ + use coreprofiles, only : density, temp + use equilibrium, only : frhotor + implicit none +! local constants + integer, parameter :: nst=51 +! local variables + integer :: i + real(wp_) :: psin,rhop,rhot,te + real(wp_) :: dens,ddens + + write(55,*) ' #psi rhot ne Te' + do i=1,nst + psin=dble(i-1)/dble(nst-1) + rhop=sqrt(psin) + rhot=frhotor(rhop) + call density(psin,dens,ddens) + te=temp(psin) + write(55,"(12(1x,e12.5))") psin,rhot,dens,te + end do + end subroutine print_prof_an + + + + subroutine surfq(psinq,qpsi,nq,qval) + use const_and_precisions, only : wp_ + use equilibrium, only : rmaxis,zmaxis,zbinf,zbsup,frhotor + use magsurf_data, only : npoints,contours_psi + use utils, only : locate, intlin + implicit none +! arguments + integer, intent(in) :: nq + real(wp_), dimension(nq), intent(in) :: psinq,qpsi + real(wp_) :: qval +! local variables + integer :: ncnt,i1,ipr + real(wp_) :: rup,zup,rlw,zlw,rhot,psival + real(wp_), dimension(npoints) :: rcn,zcn + + ncnt=(npoints-1)/2 + +! locate psi surface for q=qval + call locate(abs(qpsi),nq,qval,i1) + if (i1>0.and.i1 h .or. & + ah > 0.0_wp_ .and. a(jm) <= h) then + ix=ix+1 + lx(ix)=-j + end if + if (ah <= 0.0_wp_ .and. a(j-1) > h .or. & + ah > 0.0_wp_ .and. a(j-1) <= h) then + ix=ix+1 + lx(ix)=j + end if + end do + end do + + do jm=nr,mxr,nrqmax + j = jm + nrqmax + ah=a(j)-h + if (ah <= 0.0_wp_ .and. a(j-1) > h .or. & + ah > 0.0_wp_ .and. a(j-1) <= h) then + ix=ix+1 + lx(ix)=j + end if + if (ah <= 0.0_wp_ .and. a(jm) > h .or. & + ah > 0.0_wp_ .and. a(jm) <= h) then + ix=ix+1 + lx(ix)=-j + end if + end do + + do jm=1,mxr,nrqmax + j = jm + nrqmax + if (a(j) <= h .and. a(jm) > h .or. & + a(j) > h .and. a(jm) <= h) then + ix=ix+1 + lx(ix) =-j + end if + end do + + do j=2,nr + if (a(j) <= h .and. a(j-1) > h .or. & + a(j) > h .and. a(j-1) <= h) then + ix=ix+1 + lx(ix)=j + end if + end do + + if(ix<=0) return + +bb: do + in=ix + jx=lx(in) + jfor=0 + lda=1 + ldb=2 + + do + if(jx<0) then + jabs=-jx + jnb = jabs - nrqmax + else + jabs=jx + jnb=jabs-1 + end if + + adn=a(jabs)-a(jnb) + if(adn/=0) px=(a(jabs)-h)/adn + kx = (jabs - 1) / nrqmax + ikx = jabs - nrqmax * kx - 1 + + if(jx<0) then + x = drgrd * ikx + y = dzgrd * (kx - px) + else + x = drgrd * (ikx - px) + y = dzgrd * kx + end if + + 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<=0) then + ja(1,1) = -jabs-1 + j=2 + end if + + 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<=0 .or. ikx<=0) then + lda=1 + ldb=lda + else if (ikx + 1 - nr >= 0 .and. jx <= 0) then + lda=2 + ldb=lda + else if(jfor/=0) then + lda=2 + do i=1,3 + if(jfor==ja(i,2)) then + lda=1 + exit + end if + end do + ldb=lda + end if + + flag1=.false. + aa: do k=1,3 + do l=lda,ldb + do i=1,ix + if(lx(i)==ja(k,l)) then + itm=itm+1 + inext= i + if(jfor/=0) exit aa + if(itm .gt. 3) then + flag1=.true. + exit aa + end if + end if + end do + end do + end do aa + + if(.not.flag1) then + lx(in)=0 + if(itm .eq. 1) exit + end if + + jfor=jx + jx=lx(inext) + in = inext + end do + + do + if(lx(ix)/=0) then + if(mpl>=4) then + ncon = ncon + 1 + npts(ncon) = icount - iclast + iclast = icount + end if + exit + end if + ix= ix-1 + if(ix<=0) exit bb + end do + + end do bb + + if(mpl >= 4) then + ncon = ncon + 1 + npts(ncon) = icount - iclast + iclast = icount + end if + end subroutine cniteq + + + + logical function inside_plasma(rrm,zzm) + use const_and_precisions, only : wp_, zero, one + use gray_params, only : iequil + use coreprofiles, only : psdbnd + use equilibrium, only : zbinf,zbsup,equinum_psi,equian + implicit none +! arguments + real(wp_), intent(in) :: rrm,zzm +! local variables + real(wp_) :: psinv + + if(iequil.eq.1) then + call equian(rrm,zzm,psinv) + else + call equinum_psi(rrm,zzm,psinv) + end if + + inside_plasma = (psinv >= zero .and. psinv < psdbnd) .and. & + (psinv >= one .or. (zzm >= zbinf .and. zzm <= zbsup)) + end function inside_plasma + + + + subroutine vacuum_rt(xv0,anv0,xvend,dstvac,ivac) + use const_and_precisions, only : wp_ + use reflections, only : inters_linewall,inside,rlim,zlim,nlim + use beamdata, only : dst + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: xv0,anv0 + real(wp_), dimension(3), intent(out) :: xvend + real(wp_), intent(out) :: dstvac + integer, intent(out) :: ivac +! local variables + integer :: i + real(wp_) :: st,rrm,zzm,smax + real(wp_), dimension(3) :: walln + logical :: plfound +! common/external functions/variables + logical, external :: inside_plasma + +! ivac=1 plasma hit before wall reflection +! ivac=2 wall hit before plasma +! ivac=-1 vessel (and thus plasma) never crossed + + call inters_linewall(xv0/1.0e2_wp_,anv0,rlim(1:nlim),zlim(1:nlim), & + nlim,smax,walln) + smax=smax*1.0e2_wp_ + rrm=1.0e-2_wp_*sqrt(xv0(1)**2+xv0(2)**2) + zzm=1.0e-2_wp_*xv0(3) + if (.not.inside(rlim,zlim,nlim,rrm,zzm)) then + ! first wall interface is outside-inside + if (dot_product(walln,walln) ray at radius = waist -c - read(2,*) nrayr,nrayth,rwmax - if(nrayr.eq.1) then - nrayth= 1 - jray1 = 1 - else - jray1 = 1+nint((nrayr-1)/rwmax) - rwmax = dble(nrayr-1)/dble(jray1-1) - end if -c -c x00,y00,z00 coordinates of launching point -c - read(2,*) x00,y00,z00 -c -c beams parameters in local reference system -c w0 -> waist, d0 -> waist distance from launching point -c phiw angle of beam ellipse -c - read(2,*) w0csi,w0eta,d0csi,d0eta,phiw -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 imx :max n of iterations in dispersion, imx<0 uses 1st -c iteration in case of failure after |imx| iterations - - read(2,*) iwarm,ilarm,imx -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 psipol0,chipol0 polarization angles -c ipol=0 compute mode polarization at antenna, ipol=1 use polariz angles -c - read(2,*) dst,nstep,istpr0,istpl0,idst - read(2,*) igrad,ipass,rwallm - read(2,*) iox, psipol0,chipol0,ipol -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 - rcen=rr0m - btrcen=b0 - zbmin=(zr0-rpa)/100.d0 - zbmax=(zr0+rpa)/100.d0 - b0=b0*factb - call flux_average_an -c call print_prof_an - else - read(2,*) dummy,dummy,dummy - read(2,*) dummy - read(2,*) dummy,dummy,dummy - end if -c - close(unit=2) -c - if(nrayr.eq.1) igrad=0 - if (nrayr.lt.5) then - igrad=0 - print*,' nrayr < 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 - zrcsi=0.5d0*ak0*w0csi**2 - zreta=0.5d0*ak0*w0eta**2 - if(igrad.gt.0) then - wcsi=w0csi*sqrt(1.0d0+(d0csi/zrcsi)**2) - weta=w0eta*sqrt(1.0d0+(d0eta/zreta)**2) - rcicsi=-d0csi/(d0csi**2+zrcsi**2) - rcieta=-d0eta/(d0eta**2+zreta**2) - phir=phiw - else - d0eta=d0csi - wcsi=w0csi*abs(d0csi/zrcsi) - weta=w0eta*abs(d0eta/zreta) - rcicsi=w0csi/zrcsi - rcieta=w0eta/zreta - if(d0csi.gt.0) then - rcicsi=-rcicsi - rcieta=-rcieta - end if - phir=phiw - end if - end if -c - print'(a,2f8.3)','alpha0, beta0 = ',alpha0,beta0 -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 alpha0, beta0 in a local reference system as proposed by Gribov et al -c -c anr0c=-cos(cvdr*beta0)*cos(cvdr*alpha0) -c anphi0c=sin(cvdr*beta0) -c anz0c=-cos(cvdr*beta0)*sin(cvdr*alpha0) - - anr0c=-cos(cvdr*beta0)*cos(cvdr*alpha0) - anphi0c=sin(cvdr*beta0) - anz0c=-cos(cvdr*beta0)*sin(cvdr*alpha0) - - 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 print density, temperature, safecty factor, toroidal current dens -c versus psi, rhop, rhot - call print_prof - end if - - if (iequil.eq.1) call bres_anal - - if (iequil.ne.2.or.ipass.lt.0) then -c set simple limiter as two cylindrical walls at rwallm and r00 - nlim=5 - rlim(1)=rwallm - rlim(2)=max(r00*1.d-2,rmxm) - rlim(3)=rlim(2) - rlim(4)=rlim(1) - rlim(5)=rlim(1) - zlim(1)=(z00-dst*nmx)*1.d-2 - zlim(2)=zlim(1) - zlim(3)=(z00+dst*nmx)*1.d-2 - zlim(4)=zlim(3) - zlim(5)=zlim(1) - ipass=abs(ipass) - end if - - nfil=78 - - open(nfil,file='headers.txt',status= 'unknown') - call date_and_time(wdat,wtim) - write(nfil,916) wdat(1:4),wdat(5:6),wdat(7:8), - . wtim(1:2),wtim(3:4),wtim(5:6) - write(nfil,904) REVISION - if (iequil.eq.2) then - write(nfil,905) trim(filenmeqq) - else - if (iequil.eq.1) write(nfil,912) rr0,zr0,rpa,B0,q0,qa,alq - if (iequil.eq.0) write(nfil,'("# VACUUM CASE")') - end if - if (iprof.eq.1) then - write(nfil,907) trim(filenmprf) - else - write(nfil,913) dens0,aln1,aln2,te0,dte0,alt1,alt2,zeff - end if - write(nfil,911) fghz,p0mw,iox - write(nfil,902) x00,y00,z00 - write(nfil,908) alpha0,beta0 - if(ibeam.ge.1) write(nfil,909) trim(filenmbm) - if(ibeam.eq.0) write(nfil,903) w0csi,w0eta,d0csi,d0eta,phiw - write(nfil,900) nrayr, nrayth, rwmax - write(nfil,901) igrad,iwarm,ilarm,ieccd,idst - write(nfil,915) dst,nstep - write(nfil,914) sgnbphi,sgniphi,icocos - write(nfil,906) factb,factt,factn,iscal - write(nfil,910) sspl,psdbnd,nnd,ipec,ipsinorm - write(nfil,*) ' ' - close(nfil) - - return - -900 format('# Nray_r Nray_th rwmax : ',2i5,1x,es12.5) -901 format('# igrad iwarm ilarm ieccd idst ipol: ',7i5) -902 format('# X0 Y0 Z0 launching point (cm) : ',3(1x,es12.5)) -903 format('# w0xi w0eta d0xi d0eta (cm) phiw (deg) : ',5(1x,es12.5)) -904 format('# GRAY revision : ',a) -905 format('# EQUILIBRIUM file : ',a) -906 format('# fact_B fact_T fact_n iscal : ',(3(1x,es12.5),i5)) -907 format('# PROFILES file : ',a) -908 format('# alpha0 beta0 launch angles (deg) CYL : ',2(1x,es12.5)) -909 format('# LAUNCHER file : ',a24) -910 format('# sspl psdbnd nd ipec ipsinorm : ',2(1x,es12.5),3i5) -911 format('# fghz P0 IOX : ',2(1x,es12.5),i5) -912 format('# AN. EQUILIBRIUM R0 z0 a B0 q0 qa alq : ',7(1x,es12.5)) -913 format('# AN. PROFILES ne0 aln1 aln2 Te0 Tea alt1 alt2 Zeff : ' - . ,8(1x,es12.5)) -914 format('# sgnB_phi sgnI_phi icocos : ',2(1x,es12.5),i5) -915 format('# dst nstep : ',1x,es12.5,i5) -916 format('# Date : ',a4,2('/',a2),1x,a2,2(':',a2)) - - 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 psin 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=b0*rr0m/bres - 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 - - subroutine bres_anal - implicit real*8(a-h,o-z) - parameter(pi=3.14159265358979d0) - common/parban/b0,rr0m,zr0m,rpam - common/parbres/bres -c -c print resonant B iequil=1 -c - write(70,*)'#i Btot R z' - rres=b0*rr0m/bres - 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*255 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/alpha0,beta0 - common/parwv/ak0,akinv,fhz -c -c for given alpha0 -> beta0 + 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(alpha0.gt.alphastv(1).and.alpha0.lt.alphastv(nisteer)) then - call locate(alphastv,nisteer,alpha0,k) - dal=alpha0-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*,' alpha0 outside table range !!!' - if(alpha0.ge.alphastv(nisteer)) ii=nisteer - if(alpha0.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 - beta0=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=5000) -c parameter(np=100) - 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) - dimension rlim(nbb),zlim(nbb) -c dimension rcon(2*np+1),zcon(2*np+1) -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) - 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/pareq1t/psiant,psinop - 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/phitedge/phitedge - common/cnt/rup,zup,rlw,zlw - common/limiter/rlim,zlim,nlim -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,psiaxis,psiedge,btrcen - read (neqdsk,2020) current,xdum,xdum,xdum,xdum - read (neqdsk,2020) xdum,xdum,xdum,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,psiaxis,psiedge,btrcen - read (neqdsk,*) current,xdum,xdum,xdum,xdum - read (neqdsk,*) xdum,xdum,xdum,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 - psiaxis=-psiaxis - 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,psiaxis-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 psi function - - psia0=psiedge-psiaxis -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) -c -c do j=1,nz -c do i=1,nr -c write(80,2021) rv(i),zv(j),psi(i,j) -c enddo -c write(80,*) ' ' -c enddo - - do j=1,nz - do i=1,nr - if(ipsinorm.eq.0) then - psin(i,j)=(psi(i,j)-psiaxis)/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 fitting/interpolation of psin(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) -c if ier=-1 data are fitted using sspl=0 - if(ier.eq.-1) then - sspl=0.0d0 - 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) - end if - 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 -c2021 format(5(1x,e16.9)) -c - nur=1 - nuz=0 - call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz, - . cc10,lw10,ier) -c - nur=0 - nuz=1 - call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz, - . cc01,lw01,ier) -c - nur=2 - nuz=0 - call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz, - . cc20,lw20,ier) -c - nur=0 - nuz=2 - call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz, - . cc02,lw02,ier) -c - nur=1 - nuz=1 - call coeff_parder(tr,nsr,tz,nsz,cc,kspl,kspl,nur,nuz, - . cc11,lw11,ier) -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 read plasma boundaries from eqdsk file -c - read (neqdsk,*) nbbbs,nlim - 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) -c do i=1,nbbbs -c write(51,*) rbbbs(i),zbbbs(i) -c end do - end if - if(nlim.gt.0) then - if(ipsinorm.eq.1) - . read (neqdsk,*) (rlim(i),zlim(i),i=1,nlim) - if(ipsinorm.eq.0) - . read (neqdsk,2020) (rlim(i),zlim(i),i=1,nlim) - end if -c -c compute max and min z of last closed surface -c - rbmin=rmaxis - rbmax=rmaxis - if (nbbbs.gt.1) then - zbmin=1.0d+30 - zbmax=-1.0d+30 - 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 - else - zbmin=-1.0d+30 - zbmax=1.0d+30 - end if - if(zbmin.le.zmnm) zbmin=zbmin+dz - if(rbmin.le.rmnm) rbmin=rbmin+dr - if(zbmax.ge.zmxm) zbmax=zbmax-dz - if(rbmax.ge.rmxm) rbmax=rbmax-dr -c -c start with uncorrected normalized psi -c - psinop=0.0d0 - psinxp=1.0d0 - psiant=1.0d0 -c -c search for O-point -c - call points_ox(rmaxis,zmaxis,rmop,zmop,psinoptmp,info) - rmaxis=rmop - zmaxis=zmop - print'(a,2f8.4,es12.5)','O-point',rmop,zmop,psinoptmp -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,psinxptmp,info) - if(psinxp.ne.-1.0d0) then - print'(a,2f8.4,es12.5)','X-point',rxp,zxp,psinxptmp - rbmin=rxp - zbmin=zxp - psinop=psinoptmp - psinxp=psinxptmp - psiant=psinxp-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,psinxptmp,info) - if(psinxp.ne.-1.0d0) then - print'(a,2f8.4,e16.8)','X-point',rxp,zxp,psinxptmp - zbmax=zxp - psinop=psinoptmp - psinxp=psinxptmp - psiant=psinxp-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 - psinop=psinoptmp - psiant=psin1-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 compute B_toroidal on axis - - 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 = ',btaxis - -c compute normalized rho_tor from eqdsk q profile - call rhotor(nr) - phitedge=abs(psia)*rhotsx*2*pi -c rrtor=sqrt(phitedge/abs(btrcen)/pi) - call rhopol -c print*,rhotsx,phitedge,rrtor,abs(psia) - -c compute flux surface averaged quantities - - rup=rmaxis - rlw=rmaxis - zup=zmaxis+(zbmax-zmaxis)/10.0d0 - zlw=zmaxis-(zmaxis-zbmin)/10.0d0 - call flux_average -c ipr=1 -c call contours_psi(1.0d0,np,rcon,zcon,ipr) -c do ii=1,2*np+1 -c write(52,*) rcon(ii), zcon(ii) -c end do -c - -c locate psi surface for q=1.5 and q=2 - - 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) - call equinum_psi(rf,zf) - 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/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - common/pareq1/psia - - select case(iflag) - case(1) - call equinum_derpsi(x(1),x(2),iflag) - fvec(1) = dpsidr/psia - fvec(2) = dpsidz/psia - case(2) - call equinum_derpsi(x(1),x(2),iflag) - fjac(1,1) = ddpsidrr/psia - fjac(1,2) = ddpsidrz/psia - fjac(2,1) = ddpsidrz/psia - fjac(2,2) = ddpsidzz/psia - case default - print*,'iflag undefined' - end select - - 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 - 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/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - common/psival/psinv - common/cnpsi/h - common/pareq1/psia - - select case(iflag) - case(1) - call equinum_psi(x(1),x(2)) - call equinum_derpsi(x(1),x(2),iflag) - fvec(1) = psinv-h - fvec(2) = dpsidr/psia - case(2) - ii=iflag+1 - call equinum_derpsi(x(1),x(2),ii) - fjac(1,1) = dpsidr/psia - fjac(1,2) = dpsidz/psia - fjac(2,1) = ddpsidrr/psia - fjac(2,2) = ddpsidrz/psia - case default - print*,'iflag undefined' - end select - - 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 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,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,rhot,dens,te,qq,ajphi*1.d-6 - end do -c - return - 111 format(12(1x,e12.5)) - end - - subroutine print_prof_an - implicit real*8 (a-h,o-z) - parameter(nst=51) - common/dens/dens,ddens - - write(55,*) ' #psi rhot ne Te' - do i=1,nst - psin=dble(i-1)/dble(nst-1) - rhop=sqrt(psin) - rhot=frhotor(psin) - call density(psin) - te=temp(psin) - write(55,111) psin,rhot,dens,te - end do - - 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),rhopnr(nnw),qpsi(nnw),rhotnr(nnw),cq(nnw,4), - * crhot(nnw,4) - common/psinr/psinr - common/rhopnr/rhopnr - common/qpsi/qpsi - common/rhotsx/rhotsx - common/crhot/crhot - common/cq/cq -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 - rhopnr=sqrt(psinr) - call difcs(rhopnr,rhotnr,nr,iopt,crhot,ier) - return - end - - function fq_eq(psi) - implicit real*8(a-h,o-z) - parameter(nnw=501) - dimension psinr(nnw),cq(nnw,4) - common/psinr/psinr - common/eqnn/nr,nz,npp,nintp - common/cq/cq - irt=int((nr-1)*psi+1) - if(irt.eq.0) irt=1 - if(irt.eq.nr) irt=nr-1 - dps=psi-psinr(irt) - fq_eq=spli(cq,nr,irt,dps) - return - end - - function frhotor_eq(rhop) - implicit real*8(a-h,o-z) - parameter(nnw=501) - dimension rhopnr(nnw),crhot(nnw,4) - common/rhopnr/rhopnr - common/eqnn/nr,nz,npp,nintp - common/crhot/crhot -c -c irt=int((nr-1)*psi+1) -c if(irt.eq.0) irt=1 -c if(irt.eq.nr) irt=nr-1 - call locate(rhopnr,nr,rhop,irt) - irt=min(max(1,irt),nr-1) - drh=rhop-rhopnr(irt) - frhotor_eq=spli(crhot,nr,irt,drh) - return - end - - function frhotor(psi) - implicit real*8(a-h,o-z) - common/iieq/iequil - if(iequil.eq.2) frhotor=frhotor_eq(sqrt(psi)) - if(iequil.eq.1) frhotor=frhotor_an(sqrt(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) -c if(ip.eq.0) ip=1 -c if(ip.eq.nintp) ip=nintp-1 - ip=min(max(1,ip),nintp-1) - dps=rpsi-rpstab(ip) - frhotor_av=spli(crhotq,nintp,ip,dps) - return - end - - subroutine rhopol - implicit real*8(a-h,o-z) - parameter(nnr=101,nrest=nnr+4) - parameter(lwrkp=nnr*4+nrest*16) - dimension rhop(nnr),rhot(nnr),rhopi(nnr) - dimension trp(nrest),crp(nrest),wp(nrest) - dimension wrkp(lwrkp),iwrkp(nrest) - common/coffrtp/trp - common/coffrn/nsrp - common/coffrp/crp - - dr=1.0d0/dble(nnr-1) - do i=1,nnr - rhop(i)=(i-1)*dr - psin=rhop(i)*rhop(i) - rhot(i)=frhotor(psin) - wp(i)=1.0d0 - end do - wp(1)=1.0d3 - wp(nnr)=1.0d3 - -c spline interpolation of rhopol versus rhotor - iopt=0 - xb=0.0d0 - xe=1.0d0 - ss=0.00001d0 - kspl=3 - call curfit(iopt,nnr,rhot,rhop,wp,xb,xe,kspl,ss,nrest,nsrp, - . trp,crp,rp,wrkp,lwrkp,iwrkp,ier) -c print*,ier - call splev(trp,nsrp,crp,3,rhot,rhopi,nnr,ier) -c do i=1,nnr -c write(54,*) rhop(i),rhot(i),rhopi(i) -c end do - - return - end - - function frhopol(rhot) - implicit real*8(a-h,o-z) - parameter(nnr=101,nrest=nnr+4) - dimension trp(nrest),crp(nrest),rrs(1),ffspl(1) - common/coffrtp/trp - common/coffrn/nsrp - common/coffrp/crp - rrs(1)=rhot - call splev(trp,nsrp,crp,3,rrs,ffspl,1,ier) - frhopol=ffspl(1) - 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/pareq1t/psiant,psinop - 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*psiant+psinop - 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)) - 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=41) - 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 dadrhotv(nnintp),cdadrhot(nnintp,4) - dimension dvdrhotv(nnintp),cdvdrhot(nnintp,4) - 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 cratjpl(nnintp,4),cratja(nnintp,4),cratjb(nnintp,4) - dimension cfc(nnintp,4),crhotq(nnintp,4) - dimension vratjpl(nnintp),vratja(nnintp),vratjb(nnintp) - 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/fpol/fpolv,ffpv -c - common/pstab/rpstab - common/flav/vvol,rri,rbav,bmxpsi,bmnpsi - common/cflav/cvol,crri,crbav,cbmx,cbmn,carea,cfc - common/cratj/cratja,cratjb,cratjpl - common/crhotq/crhotq - common/phitedge/phitedge - common/cdadrhot/cdadrhot - common/cdvdrhot/cdvdrhot -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 psin 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_cdbtor=1.0d0 - 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 - vratjpl(1)=ratio_pltor - vratja(1)=ratio_cdator - vratjb(1)=ratio_cdbtor - ffc(1)=fc - rhot2q=0.0d0 - qqv(1)=1.0d0 - -C rup=rmaxis -C rlw=rmaxis -C zup=(zbmax+zmaxis)/2.0d0 -C 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 tor_curr(rcon(1),zcon(1),ajphi0) - call bpol(rcon(1),zcon(1),brr,bzz) - call equinum_fpol(0) - bphi=fpolv/rcon(1) - 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 compute length, area and volume defined by psi=height^2 - - 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 compute line integral on the contour psi=height^2 - - rpsim=rcon(inc1) - zpsim=zcon(inc1) - call bpol(rpsim,zpsim,brr,bzz) - call tor_curr(rpsim,zpsim,ajphi) - call equinum_fpol(0) - bphi=fpolv/rpsim - 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 computation maximum/minimum B values on given flux surface - - if(btot.le.bmmn) bmmn=btot - if(btot.ge.bmmx) bmmx=btot - end do - -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 - - 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 area == varea, volume == vvol -c flux surface minor radius == (area/pi)^1/2 -c ratio_cdator = Jcd_astra/J_phi Jcd_astra = /B0 -c ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = / -c ratio_pltor = Jcd_||/J_phi Jcd_|| = - - 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_cdbtor=abs(b2av*riav/(fpolv*r2iav*bbav)) - ratio_pltor=abs(bbav*riav/(fpolv*r2iav)) - vratjpl(jp)=ratio_pltor - vratja(jp)=ratio_cdator - vratjb(jp)=ratio_cdbtor - qq=abs(dvdpsi*fpolv*r2iav/(4*pi*pi)) - qqv(jp)=qq - - dadrhotv(jp)=phitedge*frhotor_eq(height)/fq_eq(height2) - . *dadpsi/pi - dvdrhotv(jp)=phitedge*frhotor_eq(height)/fq_eq(height2) - . *dvdpsi/pi -c -c write(57,99) sqrt(pstab(jp)),pstab(jp),riav,dvdpsi,area,vvol(jp) - -c computation of rhot from calculated q profile - - 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/ - - fc=0.0d0 - shlam=0.0d0 - do l=nlam,1,-1 - lam=alam(l) - srl=0.0d0 - rl2=1.0d0-lam*bv(1)/bmmx - rl0=0.d0 - if(rl2.gt.0) rl0=sqrt(rl2) - do inc=1,ncntt-1 - rl2=1.0d0-lam*bv(inc+1)/bmmx - rl=0.0d0 - 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 - do l=1,nlam - ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l) - dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l) - end do - end do - - write(56,*)' #psi rhot_eq rhot_av || |Bmx| |Bmn|'// - .' Area Vol |I_pl| qq fc ratioJa ratioJb' - - 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 - rhot_eq=frhotor_eq(sqrt(pstab(jp))) - write(56,99) pstab(jp),rhot_eq,rhotqv(jp), - . bav(jp),bmxpsi(jp),bmnpsi(jp),varea(jp),vvol(jp), - . vcurrp(jp),vajphiav(jp),qqv(jp),ffc(jp) - . ,vratja(jp),vratjb(jp) - end do - -c rarea=sqrt(varea(nintp)/pi) - -c spline coefficients of vvol,rbav,rri,bmxpsi,bmnpsi -c used for computations of dP/dV and J_cd -c spline coefficients of rhot - - 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,vratja,nintp,iopt,cratja,ier) - iopt=0 - call difcs(rpstab,vratjb,nintp,iopt,cratjb,ier) - iopt=0 - call difcs(rpstab,vratjpl,nintp,iopt,cratjpl,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) - iopt=0 - call difcs(rpstab,dadrhotv,nintp,iopt,cdadrhot,ier) - iopt=0 - call difcs(rpstab,dvdrhotv,nintp,iopt,cdvdrhot,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 - - function fdadrhot(rpsi) - implicit real*8(a-h,o-z) - parameter(nnintp=101) - dimension rpstab(nnintp),cdadrhot(nnintp,4) - common/pstab/rpstab - common/eqnn/nr,nz,npp,nintp - common/cdadrhot/cdadrhot - ip=int((nintp-1)*rpsi+1) -c if(ip.eq.0) ip=1 -c if(ip.eq.nintp) ip=nintp-1 - ip=min(max(1,ip),nintp-1) - dps=rpsi-rpstab(ip) - fdadrhot=spli(cdadrhot,nintp,ip,dps) - return - end - - function fdvdrhot(rpsi) - implicit real*8(a-h,o-z) - parameter(nnintp=101) - dimension rpstab(nnintp),cdvdrhot(nnintp,4) - common/pstab/rpstab - common/eqnn/nr,nz,npp,nintp - common/cdvdrhot/cdvdrhot - ip=int((nintp-1)*rpsi+1) - ip=min(max(1,ip),nintp-1) - dps=rpsi-rpstab(ip) - fdvdrhot=spli(cdvdrhot,nintp,ip,dps) - return - end - - subroutine flux_average_an - implicit real*8 (a-h,o-z) - real*8 lam - - parameter(nnintp=101,ncnt=100,ncntt=2*ncnt+1,nlam=41) - 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 dadrhotv(nnintp),cdadrhot(nnintp,4) - dimension dvdrhotv(nnintp),cdvdrhot(nnintp,4) - 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 cratjpl(nnintp,4),cratja(nnintp,4),cratjb(nnintp,4) - dimension cfc(nnintp,4),crhotq(nnintp,4) - dimension vratjpl(nnintp),vratja(nnintp),vratjb(nnintp) - 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/parban/b0,rr0m,zr0m,rpam - common/parqq/q0,qa,alq - common/eqnn/nr,nz,npp,nintp - common/fpol/fpolv,ffpv -c common/psival/psin - - common/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz -c - common/pstab/rpstab - common/flav/vvol,rri,rbav,bmxpsi,bmnpsi - common/cflav/cvol,crri,crbav,cbmx,cbmn,carea,cfc - common/cratj/cratja,cratjb,cratjpl - common/crhotq/crhotq - common/phitedge/phitedge - common/cdadrhot/cdadrhot - common/cdvdrhot/cdvdrhot -c - common/coffvl/ch - common/coffdvl/ch01 - common/coffvlt/tjp,tlm - common/coffvln/njpt,nlmt - -c computation of flux surface averaged quantities - - rmaxis=rr0m - zmaxis=zr0m - btaxis=b0 - - call rhopol_an - phitedge=pi*rpam*rpam*btaxis - - write(71,*)' #i psin 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_cdbtor=1.0d0 - 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 - vratjpl(1)=ratio_pltor - vratja(1)=ratio_cdator - vratjb(1)=ratio_cdbtor - ffc(1)=fc - rhot2q=0.0d0 - dadrhotv(1)=0.0d0 - dvdrhotv(1)=0.0d0 - qqv(1)=1.0d0 - -C rup=rmaxis -C rlw=rmaxis -C zup=(zbmax+zmaxis)/2.0d0 -C zlw=(zmaxis+zbmin)/2.0d0 - - do jp=2,nintp - height=dble(jp-1)/dble(nintp-1) - if(jp.eq.nintp) height=0.9999d0 - height2=height*height - ipr=0 - jpr=mod(jp,ninpr) - if(jpr.eq.1) ipr=1 - call contours_psi_an(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 equian(rcon(1),zcon(1)) - dbvcdc13=-ddpsidzz/rcon(1) - dbvcdc31= ddpsidrr/rcon(1)-bzz/rcon(1) - ajphi=ccj*(dbvcdc13-dbvcdc31) - brr=-dpsidz/rcon(1) - bzz= dpsidr/rcon(1) - bphi=fpolv/rcon(1) - 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 compute length, area and volume defined by psi=height^2 - - 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 compute line integral on the contour psi=height^2 - - rpsim=rcon(inc1) - zpsim=zcon(inc1) - call equian(rpsim,zpsim) - brr=-dpsidz/rpsim - bzz= dpsidr/rpsim - dbvcdc13=-ddpsidzz/rpsim - dbvcdc31= ddpsidrr/rpsim-bzz/rpsim - ajphi=ccj*(dbvcdc13-dbvcdc31) - bphi=fpolv/rpsim - 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 computation maximum/minimum B values on given flux surface - - if(btot.le.bmmn) bmmn=btot - if(btot.ge.bmmx) bmmx=btot - end do - -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 - - 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 area == varea, volume == vvol -c flux surface minor radius == (area/pi)^1/2 -c ratio_cdator = Jcd_astra/J_phi Jcd_astra = /B0 -c ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = / -c ratio_pltor = Jcd_||/J_phi Jcd_|| = - - 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_cdbtor=abs(b2av*riav/(fpolv*r2iav*bbav)) - ratio_pltor=abs(bbav*riav/(fpolv*r2iav)) - vratjpl(jp)=ratio_pltor - vratja(jp)=ratio_cdator - vratjb(jp)=ratio_cdbtor - qq=abs(dvdpsi*fpolv*r2iav/(4.0d0*pi*pi)) - qqv(jp)=qq - - rn=frhotor_an(sqrt(pstab(jp))) - qqan=q0+(qa-q0)*rn**alq - - dadr=2.0d0*pi*rn*rpam*rpam - dvdr=4.0d0*pi*pi*rn*rmaxis*rpam*rpam - -c dadrhotv(jp)=rpam*rpam*btaxis*rn/qqan*dadpsi -c dvdrhotv(jp)=rpam*rpam*btaxis*rn/qqan*dvdpsi - dadrhotv(jp)=phitedge*rn*dadpsi/pi/qqan - dvdrhotv(jp)=phitedge*rn*dvdpsi/pi/qqan - -c computation of rhot from calculated q profile - rhot2q=rhot2q+(qqv(jp)*rpstab(jp)+qqv(jp-1)*rpstab(jp-1)) - . /dble(nintp-1) -c print*,jp,rhot2q,qqv(jp),rpstab(jp),qqv(jp-1),rpstab(jp-1) - rhotqv(jp)=sqrt(rhot2q) -c rhotqv(jp)=rn -c - write(57,99) rpstab(jp),rn,rhotqv(jp),qqv(jp),qqan,r2iav, - . dadr,dadrhotv(jp),dadpsi,dvdpsi,fpolv - -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/ - - fc=0.0d0 - shlam=0.0d0 - do l=nlam,1,-1 - lam=alam(l) - srl=0.0d0 - rl2=1.0d0-lam*bv(1)/bmmx - rl0=0.d0 - if(rl2.gt.0) rl0=sqrt(rl2) - do inc=1,ncntt-1 - rl2=1.0d0-lam*bv(inc+1)/bmmx - rl=0.0d0 - 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 - do l=1,nlam - ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l) - dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l) - end do - end do - - write(56,*)' #psi rhot_eq rhot_av || |Bmx| |Bmn|'// - .' Area Vol |I_pl| qq fc ratioJa ratioJb dadr dvdr' - - 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 - rhot_eq=frhotor_an(sqrt(pstab(jp))) - write(56,99) pstab(jp),rhot_eq,rhotqv(jp), - . bav(jp),bmxpsi(jp),bmnpsi(jp),varea(jp),vvol(jp), - . vcurrp(jp),vajphiav(jp),qqv(jp),ffc(jp) - . ,vratja(jp),vratjb(jp),dadrhotv(jp),dvdrhotv(jp) - end do - -c rarea=sqrt(varea(nintp)/pi) - -c spline coefficients of vvol,rbav,rri,bmxpsi,bmnpsi -c used for computations of dP/dV and J_cd -c spline coefficients of rhot - - 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,vratja,nintp,iopt,cratja,ier) - iopt=0 - call difcs(rpstab,vratjb,nintp,iopt,cratjb,ier) - iopt=0 - call difcs(rpstab,vratjpl,nintp,iopt,cratjpl,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) - iopt=0 - call difcs(rpstab,dadrhotv,nintp,iopt,cdadrhot,ier) - iopt=0 - call difcs(rpstab,dvdrhotv,nintp,iopt,cdvdrhot,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 - - - subroutine rhopol_an - implicit real*8(a-h,o-z) - parameter(nnr=101,nrest=nnr+4) - parameter(lwrk=nnr*4+nrest*16) - dimension rhop(nnr),rhot(nnr),rhopi(nnr),rhoti(nnr) - dimension psin(nnr) - dimension trp(nrest),crp(nrest) - dimension trot(nrest),crot(nrest) - dimension wrk(lwrk),iwrk(nrest),wp(nrest) - common/coffrtp/trp - common/coffrn/nsrp - common/coffrp/crp - common/coffrptt/trot - common/coffrnt/nsrot - common/coffrpt/crot - common/parqq/q0,qa,alq - common/parban/b0,rr0m,zr0m,rpam - common/pareq1/psia - common/sgnib/sgnbphi,sgniphi - - - dr=1.0d0/dble(nnr-1) - rhot(1)=0.0d0 - psin(1)=0.0d0 - res=0.0d0 - fq0=0.0d0 - do i=2,nnr - rhot(i)=(i-1)*dr - rn=rhot(i) - qq=q0+(qa-q0)*rn**alq - fq1=rn/qq - res=res+0.5d0*(fq1+fq0)*dr - fq0=fq1 - psin(i)=res - end do - - wp=1.0d0 - psin=psin/res - rhop=sqrt(psin) - psia=-sgniphi*abs(res*rpam*rpam*b0) - print*,psia,log(8.0d0*rr0m/rpam)-2.0d0 - wp(1)=1.0d3 - wp(nnr)=1.0d3 - -c spline interpolation of rhopol versus rhotor - iopt=0 - xb=0.0d0 - xe=1.0d0 - ss=0.00001d0 - kspl=3 - call curfit(iopt,nnr,rhot,rhop,wp,xb,xe,kspl,ss,nrest,nsrp, - . trp,crp,rp,wrk,lwrk,iwrk,ier) - call splev(trp,nsrp,crp,3,rhot,rhopi,nnr,ier) - -c spline interpolation of rhotor versus rhopol - iopt=0 - xb=0.0d0 - xe=1.0d0 - ss=0.00001d0 - kspl=3 - call curfit(iopt,nnr,rhop,rhot,wp,xb,xe,kspl,ss,nrest,nsrot, - . trot,crot,rp,wrk,lwrk,iwrk,ier) - call splev(trot,nsrot,crot,3,rhop,rhoti,nnr,ier) - - do i=1,nnr - write(54,*) rhop(i),rhot(i),rhopi(i),rhoti(i) - end do - - return - end - - - function frhotor_an(rhop) - implicit real*8(a-h,o-z) - parameter(nnr=101,nrest=nnr+4) - dimension trot(nrest),crot(nrest),rrs(1),ffspl(1) - common/coffrptt/trot - common/coffrnt/nsrot - common/coffrpt/crot - rrs(1)=rhop - call splev(trot,nsrot,crot,3,rrs,ffspl,1,ier) - frhotor_an=ffspl(1) - return - end - - - subroutine contours_psi_an(h,np,rcn,zcn,ipr) - implicit real*8 (a-h,o-z) - parameter(pi=3.14159265358979d0) - parameter(mest=4,kspl=3) - dimension rcn(2*np+1),zcn(2*np+1) - common/parban/b0,rr0m,zr0m,rpam - - th=pi/dble(np) - rn=frhotor_an(sqrt(h)) - do ic=1,2*np+1 - zcn(ic)=zr0m+rpam*rn*sin(th*(ic-1)) - rcn(ic)=rr0m+rpam*rn*cos(th*(ic-1)) - - if (ipr.gt.0) then - write(71,111) ic,h,rcn(ic),zcn(ic) - end if - end do - write(71,*) - -111 format(i6,12(1x,e12.5)) - return - end - - - - - 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),tau1v(jmx,kmx) - dimension currj(jmx,kmx,nmx),didst(jmx,kmx,nmx),ccci(jmx,kmx,nmx) - dimension iiv(jmx,kmx),iop(jmx,kmx),iow(jmx,kmx),ihcd(jmx,kmx) - dimension istore(jmx,kmx),anwcl(3),xwcl(3) - 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/iop,iow,ihcd,istore - common/psjki/psjki - common/atjki/tauv,alphav - common/dpjjki/pdjki,currj - common/pcjki/ppabs,ccci - common/dcjki/didst - common/nray/nrayr,nrayth - common/nstep/nstep - common/tau1v/tau1v - common/refln/anwcl,xwcl,jclosest -c - if(nstep.gt.nmx) nstep=nmx - if(nrayr.gt.jmx) nrayr=jmx - if(nrayth.gt.kmx) nrayth=kmx - jclosest=nrayr+1 - anwcl(1:3)=0.0d0 - xwcl(1:3)=0.0d0 -c - do i=1,nstep - do k=1,nrayth - do j=1,nrayr - 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 - iop(j,k)=0 - iow(j,k)=0 - ihcd(j,k)=1 - istore(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),iop(jmx,kmx),iow(jmx,kmx),ihcd(jmx,kmx) - dimension istore(jmx,kmx) - - common/iiv/iiv - common/iov/iop,iow,ihcd,istore - common/psjki/psjki - common/atjki/tauv,alphav - common/dpjjki/pdjki,currj - common/pcjki/ppabs,ccci - common/dcjki/didst - common/nray/nrayr,nrayth - common/nstep/nstep - - do i=1,nstep - do k=1,nrayth - do j=1,nrayr - 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 - iop(j,k)=0 - iow(j,k)=0 - ihcd(j,k)=1 - 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 - - istpr=0 - istpl=1 - ierr=0 - istep=0 - istop=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/nray/nrayr,nrayth - common/grco/xco,du1o - common/grc/xc,du1 - common/wrk/ywrk,ypwrk -c - do j=1,nrayr - do k=1,nrayth - 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/nray/nrayr,nrayth - 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,nrayth - do j=1,nrayr - 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=nrayth - kp=k+1 - if(k.eq.nrayth) 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=nrayth - kp=k+1 - if(k.eq.nrayth) 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,nrayth - do j=1,nrayr - if(j.eq.1) then - jp=j+1 - km=k-1 - if(k.eq.1) km=nrayth - kp=k+1 - if(k.eq.nrayth) 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=nrayth - kp=k+1 - if(k.eq.nrayth) 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/nray/nrayr,nrayth - 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,nrayr - kkk=nrayth - if(j.eq.1) kkk=1 - do k=1,kkk - 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,ddr11 - 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 - 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)=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/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - common/fpol/fpolv,ffpv - common/psival/psinv - common/sgnib/sgnbphi,sgniphi - - 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) - end if -c - if(iequil.eq.2) then - call equinum_psi(rrm,zzm) - call equinum_derpsi(rrm,zzm,3) - call equinum_fpol(1) - end if - - call sub_xg_derxg - yg=fpolv/(rrm*bres) - bphi=fpolv/rrm - btot=abs(bphi) - if(psinv.lt.0.0d0) return -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/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - common/fpol/fpolv,ffpv - common/xgxg/xg - common/dxgdps/dxgdpsi - common/xgcn/xgcn - common/dens/dens,ddens - common/sgnib/sgnbphi,sgniphi - - dpsidrp=0.0d0 - d2psidrp=0.0d0 -c -c simple model for equilibrium: large aspect ratio -c outside plasma: analytical continuation, not solution Maxwell eqs -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 - rhot=rn - if(rn.le.1) then - rhop=frhopol(rhot) - psinv=rhop*rhop - else - psinv=1.0d0+B0*rpam**2/2.0d0/abs(psia)/qa*(rn*rn-1.0d0) - rhop=sqrt(psinv) - end if -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*sgn - end if -c - fpolv=sgnbphi*b0*rr0m - dfpolv=0.0d0 - ffpv=0.0d0 -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 - - return - end - - - subroutine equinum_psi(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(nrs=1,nzs=1) -c - common/psival/psinv - common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz - common/pareq1t/psiant,psinop -c - common/coffeqt/tr,tz - common/coffeq/ccspl - common/coffeqn/nsrt,nszt,nsft -c - psinv=-1.0d0 -c -c here lengths are measured in meters -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)-psinop)/psiant -c - return - end - - subroutine equinum_derpsi(rpsim,zpsim,iderpsi) - implicit real*8 (a-h,o-z) - parameter(nnw=501,nnh=501) - 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) - dimension cc01(lw01),cc10(lw10),cc02(lw02),cc20(lw20),cc11(lw11) - integer*4 iderpsi -c - common/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - common/pareq2/btaxis,rmaxis,zmaxis,rmnm,rmxm,zmnm,zmxm,dr,dz - common/coffeqd/cc01,cc10,cc20,cc02,cc11 -c - dpsidr=0.0d0 - dpsidz=0.0d0 - ddpsidrr=0.0d0 - ddpsidzz=0.0d0 - ddpsidrz=0.0d0 - -c here lengths are measured in meters - if (rpsim.gt.rmxm.or.rpsim.lt.rmnm) return - if (zpsim.gt.zmxm.or.zpsim.lt.zmnm) return - - select case(iderpsi) - - case(1) - nur=1 - nuz=0 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc10,lw10) - dpsidr=derpsi - nur=0 - nuz=1 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc01,lw01) - dpsidz=derpsi - - case(2) - nur=2 - nuz=0 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc20,lw20) - ddpsidrr=derpsi - nur=0 - nuz=2 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc02,lw02) - ddpsidzz=derpsi - nur=1 - nuz=1 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc11,lw11) - ddpsidrz=derpsi - - case(3) - nur=1 - nuz=0 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc10,lw10) - dpsidr=derpsi - nur=0 - nuz=1 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc01,lw01) - dpsidz=derpsi - nur=2 - nuz=0 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc20,lw20) - ddpsidrr=derpsi - nur=0 - nuz=2 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc02,lw02) - ddpsidzz=derpsi - nur=1 - nuz=1 - call sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc11,lw11) - ddpsidrz=derpsi - - case default - print*,'iderpsi undefined' - - end select - - return - end - - subroutine sub_derpsi(rpsim,zpsim,nur,nuz,derpsi,cc,lw) - implicit real*8 (a-h,o-z) - parameter(nnw=501,nnh=501) - parameter(nrest=nnw+4,nzest=nnh+4) - parameter(liwrk=2) - parameter(nrs=1,nzs=1) - dimension tr(nrest),tz(nzest),iwrk(liwrk) - dimension rrs(1),zzs(1),ffspl(1) - dimension cc(lw) - - common/pareq1/psia - common/coffeqt/tr,tz - common/coffeqn/nsrt,nszt,nsft - common/eqnn/nr,nz,npp,nintp - - rrs(1)=rpsim - zzs(1)=zpsim - nsr=nsrt - nsz=nszt - 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,cc,kkr,kkz - . ,rrs,nrs,zzs,nzs,ffspl,cc(iwr),cc(iwz),iwrk(1),iwrk(2)) - derpsi=ffspl(1)*psia - - return - end - - subroutine equinum_fpol(iderfpol) - implicit real*8 (a-h,o-z) - parameter(nnw=501) - parameter(nrest=nnw+4) - dimension rrs(1),ffspl(1) - dimension tfp(nrest),cfp(nrest),wrkfd(nrest) - integer*4 iderfpol -c - common/psival/psinv - common/fpol/fpolv,ffpv - common/pareq1/psia - common/coffeqtp/tfp - common/coffeqn/nsrt,nszt,nsft - common/cofffp/cfp - common/fpas/fpolas - - fpolv=fpolas - dfpolv=0.0d0 - ffpv=0.0d0 - if(iderfpol.lt.0.or.iderfpol.gt.1) return - - 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) - if(iderfpol.eq.1) then - call splder(tfp,nsft,cfp,3,1,rrs,ffspl,1,wrkfd,ier) - dfpolv=ffspl(1) - ffpv=fpolv*dfpolv/psia - end if - end if - - return - end - - subroutine bfield(rpsim,zpsim,bphi,brr,bzz) - implicit real*8 (a-h,o-z) - call btor(rpsim,zpsim,bphi) - call bpol(rpsim,zpsim,brr,bzz) - return - end - - subroutine btor(rpsim,zpsim,bphi) - implicit real*8 (a-h,o-z) - common/psival/psinv - common/fpol/fpolv,ffpv - call equinum_psi(rpsim,zpsim) - call equinum_fpol(0) - bphi=fpolv/rpsim - return - end - - subroutine bpol(rpsim,zpsim,brr,bzz) - implicit real*8 (a-h,o-z) - common/derip1/dpsidr,dpsidz - call equinum_derpsi(rpsim,zpsim,1) - brr=-dpsidz/rpsim - bzz= dpsidr/rpsim - return - end - - 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/derip1/dpsidr,dpsidz - common/derip2/ddpsidrr,ddpsidzz,ddpsidrz - call equinum_derpsi(rpsim,zpsim,3) - 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/pareq1t/psiant,psinop - 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*psiant+psinop - 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) - k=max(1,min(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,one=1.0d0) - parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) - dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) - dimension ytmp(ndim),yptmp(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) - complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4) - 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 - common/nray/nrayr,nrayth - common/rwmax/rwmax - 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,ddr11 - common/evt/ext,eyt - common/pol0/psipol0,chipol0 - common/ipol/ipol - common/nplr/anpl,anpr - common/psival/psinv - common/parpl/brr,bphi,bzz,ajphi - common/dens/dens,ddens - common/tete/tekev - common/idst/idst - -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) - - 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 - - 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) - 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(nrayr.gt.1) dr=rwmax/dble(nrayr-1) - da=2.0d0*pi/dble(nrayth) -c - ddfu=2.0d0*dr**2*akinv - do j=1,nrayr - u=dble(j-1) -c ffi=u**2*ddfu/2.0d0 - dffiu(j)=u*ddfu - ddffiu(j)=ddfu - do k=1,nrayth - 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 - 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 - pppx=x0t*rcixx+y0t*rcixy - pppy=x0t*rcixy+y0t*rciyy - denpp=pppx*gxt+pppy*gyt - if (denpp.ne.0.0d0) then - ppx=-pppx*gzt/denpp - ppy=-pppy*gzt/denpp - else - ppx=0.0d0 - ppy=0.0d0 - end if -c - 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 - - select case(idst) - case(1) -! integration variable: c*t - denom=1.0d0 - case(2) -! integration variable: Sr - denom=an20 - case default ! idst=0 -! integration variable: s - denom=an0 - end select -c - ypwrk0(1,j,k) = anx0/denom - ypwrk0(2,j,k) = any0/denom - ypwrk0(3,j,k) = anz0/denom - ypwrk0(4,j,k) = dgr2x/(2.0d0*denom) - ypwrk0(5,j,k) = dgr2y/(2.0d0*denom) - ypwrk0(6,j,k) = dgr2z/(2.0d0*denom) -c - ytmp=ywrk0(:,j,k) - yptmp=ypwrk0(:,j,k) - call fwork(ytmp,yptmp) - - if(ipol.eq.0) then - call pol_limit(ext(j,k,0),eyt(j,k,0)) - qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2 - uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0))) - vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0))) - call polellipse(qq,uu,vv,psipol0,chipol0) - else - qq=cos(2.0d0*chipol0*cvdr)*cos(2.0d0*psipol0*cvdr) - uu=cos(2.0d0*chipol0*cvdr)*sin(2.0d0*psipol0*cvdr) - vv=sin(2.0d0*chipol0*cvdr) - if(qq**2.lt.1) then - deltapol=asin(vv/sqrt(1.0d0-qq**2)) - ext(j,k,0)= sqrt((1.0d0+qq)/2) - eyt(j,k,0)= sqrt((1.0d0-qq)/2)*exp(-ui*deltapol) - else - ext(j,k,0)= 1.0d0 - eyt(j,k,0)= 0.0d0 - end if - endif -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 - 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.nrayr) then - write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m, - . psinv,zero,anpl,zero,one - end if - if(j.eq.1.and.k.eq.1) then - write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi, - . psinv,one,dens,tekev,brr,bphi,bzz, - . ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero, - . zero,zero,zero,zero,zero,zero,zero,one - - ddr110=dd - end if - if(j.eq.nrayr.and.k.eq.1) then - write(17,99) zero,ddr110,dd,ddi - end if - end do - end do - - call pweigth -c - if(nrayr.gt.1) then - iproj=0 - nfilp=8 - call projxyzt(iproj,nfilp) - end if -c - return - 99 format(24(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) - complex*16 ui - parameter(ndim=6,ndimm=3) - parameter(jmx=31,kmx=36,zero=0.0d0,izero=0,one=1.0d0) - parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) - parameter(ui=(0.0d0,1.0d0)) - dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) - dimension ytmp(ndim),yptmp(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) - complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4) -c - common/nray/nrayr,nrayth - common/rwmax/rwmax - 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,ddr11 - common/evt/ext,eyt - common/pol0/psipol0,chipol0 - common/ipol/ipol - common/nplr/anpl,anpr - common/psival/psinv - common/parpl/brr,bphi,bzz,ajphi - common/dens/dens,ddens - common/tete/tekev -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(nrayr.gt.1) dr=rwmax/dble(nrayr-1) - da=2.0d0*pi/dble(nrayth) - z0t=0.0d0 -c - do j=1,nrayr - u=dble(j-1) - dffiu(j)=0.0d0 - ddffiu(j)=0.0d0 - do k=1,nrayth - 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 - ytmp=ywrk0(:,j,k) - yptmp=ypwrk0(:,j,k) - call fwork(ytmp,yptmp) - - if(ipol.eq.0) then - call pol_limit(ext(j,k,0),eyt(j,k,0)) - qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2 - uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0))) - vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0))) - call polellipse(qq,uu,vv,psipol0,chipol0) - else - qq=cos(2.0d0*chipol0*cvdr)*cos(2.0d0*psipol0*cvdr) - uu=cos(2.0d0*chipol0*cvdr)*sin(2.0d0*psipol0*cvdr) - vv=sin(2.0d0*chipol0*cvdr) - if(qq**2.lt.1.0d0) then -c deltapol=phix-phiy, phix =0 - deltapol=atan2(vv,uu) - ext(j,k,0)= sqrt((1.0d0+qq)/2) - eyt(j,k,0)= sqrt((1.0d0-qq)/2)*exp(-ui*deltapol) - else - if(qq.gt.0.0d0) then - ext(j,k,0)= 1.0d0 - eyt(j,k,0)= 0.0d0 - else - eyt(j,k,0)= 1.0d0 - ext(j,k,0)= 0.0d0 - end if - end if - endif -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 - 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.nrayr) then - write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m, - . psinv,zero,anpl,zero,one - end if - if(j.eq.1.and.k.eq.1) then - write(17,99) zero,zero,zero,zero - write(4,99) zero,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi, - . psinv,one,dens,tekev,brr,bphi,bzz, - . ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero, - . zero,zero,zero,zero,zero,zero,zero,one - end if - end do - end do - - call pweigth -c - if(nrayr.gt.1) then - iproj=0 - nfilp=8 - call projxyzt(iproj,nfilp) - end if -c - return - 99 format(24(1x,e16.8e3)) -111 format(3i5,20(1x,e16.8e3)) - end - - - - subroutine ic_rt2 - implicit real*8 (a-h,o-z) - parameter(ndim=6,ndimm=3) - parameter(jmx=31,kmx=36,zero=0.0d0,izero=0,one=1.0d0) - parameter(pi=3.14159265358979d0,cvdr=pi/180.0d0) - dimension ywrk0(ndim,jmx,kmx),ypwrk0(ndim,jmx,kmx) - dimension ytmp(ndim),yptmp(ndim) - dimension yyrfl(jmx,kmx,ndim) - dimension xc0(ndimm,jmx,kmx),du10(ndimm,jmx,kmx) - dimension grad2(jmx,kmx),dgrad2v(ndimm,jmx,kmx) - dimension gri(3,jmx,kmx),ggri(3,3,jmx,kmx) - complex*16 ext(jmx,kmx,0:4),eyt(jmx,kmx,0:4) -c - common/nray/nrayr,nrayth - 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,ddr11 - common/yyrfl/yyrfl - common/evt/ext,eyt - common/pol0/psipol0,chipol0 - common/nplr/anpl,anpr - common/psival/psinv - common/parpl/brr,bphi,bzz,ajphi - common/dens/dens,ddens - common/tete/tekev - - do j=1,nrayr - do k=1,nrayth - 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 - ytmp=ywrk0(:,j,k) - yptmp=ypwrk0(:,j,k) - call fwork(ytmp,yptmp) - - call pol_limit(ext(j,k,0),eyt(j,k,0)) - qq=abs(ext(j,k,0))**2-abs(eyt(j,k,0))**2 - uu=2.0d0*dble(ext(j,k,0)*dconjg(eyt(j,k,0))) - vv=2.0d0*dimag(ext(j,k,0)*dconjg(eyt(j,k,0))) - call polellipse(qq,uu,vv,psipol0,chipol0) -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 - 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.nrayr) then - write(33,111) izero,j,k,zero,x0m,y0m,r0m,z0m, - . psinv,zero,anpl,zero,one - end if - if(j.eq.1.and.k.eq.1) then - write(17,99) zero,zero,zero,zero - write(4,99) strfl11,r0m,z0m,atan2(y0m,x0m)*180.0d0/pi, - . psinv,one,dens,tekev,brr,bphi,bzz, - . ajphi*1.0d-6,sqrt(anpl**2+anpr**2),anpl,zero, - . zero,zero,zero,zero,zero,zero,zero,one - end if - end do - end do -c - call pweigth -c - if(nrayr.gt.1) then - iproj=0 - nfilp=8 - call projxyzt(iproj,nfilp) - end if -c - return - 99 format(24(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/nray/nrayr,nrayth - common/rwmax/rwmax -c - dr=1.0d0 - if(nrayr.gt.1) dr=rwmax/dble(nrayr-1) - r1=0.0d0 - summ=0.0d0 - q(1)=1.0d0 - if(nrayr.gt.1) then - do j=1,nrayr - 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,nrayr - q(j)=q(j)/nrayth/summ - do k=1,nrayth - 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) -c if(ip.eq.0) ip=1 -c if(ip.eq.nintp) ip=nintp-1 - ip=min(max(1,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,ratjai,ratjbi,ratjpli) - implicit real*8 (a-h,o-z) - parameter(nnintp=101) - dimension rpstab(nnintp) - dimension cratja(nnintp,4),cratjb(nnintp,4),cratjpl(nnintp,4) - common/pstab/rpstab - common/eqnn/nr,nz,npp,nintp - common/cratj/cratja,cratjb,cratjpl - ip=int((nintp-1)*rpsi+1) -c if(ip.eq.0) ip=1 -c if(ip.eq.nintp) ip=nintp-1 - ip=min(max(1,ip),nintp-1) - dps=rpsi-rpstab(ip) - ratjai=spli(cratja,nintp,ip,dps) - ratjbi=spli(cratjb,nintp,ip,dps) - ratjpli=spli(cratjpl,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)) - 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) - 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 - end -c -c -c - subroutine dispersion(lrm) - implicit real*8(a-h,o-z) - parameter(one=1.0d0) - 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/xgxg/xg - common/nplr/anpl,anprf - common/mode/sox - common/warm/iwarm,ilarm - common/nprw/anprr,anpri - common/epolar/ex,ey,ez - common/imx/imx - - 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 - imxx=abs(imx) -c loop to disable convergence if failure detected - do - do i=1,imxx -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 - 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 - errnpr=abs(1.0d0-abs(anpr2)/abs(anpr2a)) - if(i.gt.1.and.errnpr.lt.1.0d-5) exit - anpr2a=anpr2 - end do - if(i.gt.imxx .and. imxx.gt.1) then - if (imx.lt.0) then - write(*,"(' X =',f7.4,' Y =',f10.7,' Nperp =',f7.4,"// - ."': convergence disabled.',e12.5)") xg,yg,sqrt(abs(anpr2)),anpl - imxx=1 - else - write(*,"(' X =',f7.4,' Y =',f10.7,' Nperp =',f7.4,"// - ."': convergence failed.',e12.5)") xg,yg,sqrt(abs(anpr2)),anpl - exit - end if - else - exit - end if - print*,yg,imx,imxx - end do -c end loop to disable convergence - if(sqrt(dble(anpr2)).lt.0.0d0 .or. anpr2.ne.anpr2 - . .or. abs(anpr2).eq.huge(one) .or. abs(anpr2).le.tiny(one)) then - write(*,"(' X =',f7.4,' Y =',f7.4,"// - . "' Nperp =',f7.4,'!')") xg,yg,sqrt(abs(anpr2)) - ierr=99 - anpr2=(0.0d0,0.0d0) - end if -c - anpr=sqrt(anpr2) - anprr=dble(anpr) - anpri=dimag(anpr) -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 - common/warm/iwarm,ilarm -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 - if(iwarm.eq.2) call hermitian(rr,lrm) - if(iwarm.eq.4) call hermitian_2(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 - ffe=0.0d0 - 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 - - - - subroutine hermitian_2(rr,lrm) - implicit real*8(a-h,o-z) - parameter(tmax=5) - dimension rr(-lrm:lrm,0:2,0:lrm) - parameter(epsa=0.0d0,epsr=1.0d-4) - parameter (lw=5000,liw=lw/4) - dimension w(lw),iw(liw) - external fhermit -c - common/ygyg/yg - common/amut/amu - common/nplr/anpl,anpr - common/warm/iwarm,ilarm - common/nmhermit/n,m,ih -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 - bth2=2.0d0/amu -c - n1=1 - if(iwarm.gt.10) n1=-llm -c - do n=n1,llm - nn=abs(n) - do m=nn,llm - if(n.eq.0.and.m.eq.0) then - ih=2 -c call dqagi(fhermit,bound,2,epsa,epsr,resfh, - call dqags(fhermit,-tmax,tmax,epsa,epsr,resfh, - . epp,neval,ier,liw,lw,last,iw,w) - rr(n,2,m) = resfh - else - do ih=0,2 -c call dqagi(fhermit,bound,2,epsa,epsr,resfh, - call dqags(fhermit,-tmax,tmax,epsa,epsr,resfh, - . epp,neval,ier,liw,lw,last,iw,w) - rr(n,ih,m) = resfh - end do - end if - end do - end do - - if(iwarm.gt.10) 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 - - - - function fhermit(t) - implicit real*8 (a-h,o-z) -c - common/ygyg/yg - common/amut/amu - common/nplr/anpl,anpr - common/cri/cr,ci - common/nmhermit/n,m,ih - - bth2=2.0d0/amu - bth=sqrt(bth2) - amu2=amu*amu - amu4=amu2*amu2 - amu6=amu4*amu2 - - 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 - exdxdt=cr*exp(-t*t)*gx/rxt - gr=anpl*upl+n*yg - zm=-amu*(gx-gr) - s=amu*(gx+gr) - zm2=zm*zm - zm3=zm2*zm - call calcei3(zm,fe0m) - ffe=0.0d0 - uplh=upl**ih - if(n.eq.0.and.m.eq.0) ffe=exdxdt*fe0m*upl2 - if(m.eq.1) ffe=(1.0d0+s*(1.0d0-zm*fe0m))*uplh/amu2 - if(m.eq.2) ffe=(6.0d0-2.0d0*zm+4.0d0*s - . +s*s*(1.0d0+zm-zm2*fe0m))*uplh/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))*uplh/amu6 - fhermit= exdxdt*ffe - 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,ierp, - . liw,lw,last,iw,w) - if (ierp.gt.0) ierr=90 - end if -c - rdu2t=cst2*anpl2+ygn2-1.0d0 - nevalj0=0 - nevalj1=0 - nevalj2=0 - lastj0=0 - lastj1=0 - lastj2=0 -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,nevalj0,ier,liw,lw,lastj0,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,nevalj1,ier,liw,lw,lastj1,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,nevalj2,ier,liw,lw,lastj2,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 - write(90,1) yg,nhn,ierp,last,neval,lastj0,nevalj0, - . lastj1,nevalj1,lastj2,nevalj2 - - return - 1 format(e12.5,20i5) - 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=41) - 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/nray/nrayr,nrayth - common/jray1/jray1 - 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 - jf=nrayr - if(iproj.eq.0) then - jd=jray1-1 - jf=jray1 - end if - do j=1,jf,jd - kkk=nrayth - if(j.eq.1) kkk=1 - do k=1,kkk -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) -Cc -C dirxt= (dirx*csps1-diry*snps1)/dir -C diryt=((dirx*snps1+diry*csps1)*csth1-dirz*snth1)/dir -C dirzt=((dirx*snps1+diry*csps1)*snth1+dirz*csth1)/dir -Cc -C if(k.eq.1) then -C xti1=xti -C yti1=yti -C zti1=zti -C rti1=rti -C end if - - if(.not.(iproj.eq.0.and.j.eq.1)) - . write(nfile,111) istep,j,k,xti,yti,zti,rti,psinv11 -c - if(rti.ge.rtimx.and.j.eq.jray1) rtimx=rti - if(rti.le.rtimn.and.j.eq.jray1) rtimn=rti -c - end do -c -c if(.not.(iproj.eq.0.and.j.eq.1)) -c . write(nfile,111) istep,j,k,xti,yti,zti,rti,psinv11 - if(iproj.eq.1) write(nfile,*) ' ' - end do -c - write(nfile,*) ' ' -c - write(12,99) istep,st,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 ratjav(nndmx),ratjbv(nndmx),ratjplv(nndmx) - dimension ajplv(nndmx),ajcdav(nndmx),ajcdbv(nndmx) - dimension pins(nndmx),currins(nndmx),fi(nndmx) - parameter(llmx=21) - dimension isev(llmx) -c - common/nray/nrayr,nrayth - 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/angles/alpha0,beta0 - common/iieq/iequil - common/parban/b0,rr0m,zr0m,rpam - common/taumnx/taumn,taumx,pabstot,currtot -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 - 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),ratjai,ratjbi,ratjpli) - ratjav(it)=ratjai - ratjbv(it)=ratjbi - ratjplv(it)=ratjpli - end do - - kkk=1 - do j=1,nrayr - if(j.gt.1) kkk=nrayth - do k=1,kkk - ise0=0 - ii=iiv(j,k) - if (ii.lt.nmx) then - if(psjki(j,k,ii+1).ne.0.0d0) ii=ii+1 - end if - 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 !!!!!!!!!! it should be isev(is)=i-1 - isev(is)=i-1 - 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 - indi=ind - if (idecr.eq.-1) indi=ind-1 - rt1=rtab1(indi) - call locatex(xxi,iise,iise0,iise,rt1,itb1) - if(itb1.ge.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 - - do i=1,nd - dpdv(i)=facpds*dpdv(i) - ajphiv(i)=facjs*ajphiv(i) - ajcdav(i)=ajphiv(i)*ratjav(i) - ajcdbv(i)=ajphiv(i)*ratjbv(i) - ajplv(i)=ajphiv(i)*ratjplv(i) - end do - - rhpp=frhopol(rhotpav) - rhpj=frhopol(rhotjava) - dpdvp=pabs*2.0d0/(sqrt(pi)*drhotpav*fdvdrhot(rhpp)) - ajphip=currt*2.0d0/(sqrt(pi)*drhotjava*fdadrhot(rhpj)) - call ratioj(rhpj,ratjamx,ratjbmx,ratjplmx) - - 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 - ajphip=0.0d0 - drhotjfi=0.0d0 - drhopfi=0.0d0 - xps=rhopp - ratjamx=1.0d0 - ratjbmx=1.0d0 - ratjplmx=1.0d0 - 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 - ajphip=0.0d0 - dpdvp=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 - ratjamx=1.0d0 - ratjbmx=1.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 dPdV [MW/m^3], Jcd [MA/m^2] - - if(ieccd.eq.0) currt=0.0d0 - currtka=currt*1.0d3 - - write(6,*)' ' - write(6,*)'#beta0 alpha0 Icd Pa Jphip dPdVp '// - .'rhotj rhotjava rhotp rhotpav drhotjava drhotpav ratjamx '// - .'ratjbmx stmx psipol chipol index_rt Jphimx dPdVmx drhotj drhotp' - write(6,99) beta0,alpha0,currtka,pabstot,ajphip,dpdvp, - . rhotjfi,rhotjava,rhotp,rhotpav, - . drhotjava,drhotpav,ratjamx,ratjbmx,stmx,psipol,chipol, - . real(index_rt),ajmxfi,dpdvmx,drhotjfi,drhotp - - write(7,99) currtka,pabstot,ajphip,dpdvp, - . rhotjfi,rhotjava,rhotp,rhotpav, - . drhotjava,drhotpav,ratjamx,ratjbmx,stmx,psipol,chipol, - . real(index_rt),ajmxfi,dpdvmx,drhotjfi,drhotp - - do i=1,nd - if (ipec.eq.0) then - psin=rtab(i) - rhop=sqrt(rtab(i)) - else - psin=rtab(i)**2 - rhop=rtab(i) - end if - pinsr=0.0d0 - if(pabstot.gt.0) pinsr=pins(i)/pabstot - write(48,99) psin,rhotv(i),ajphiv(i),ajcdbv(i),dpdv(i), - . currins(i),pins(i),pinsr,real(index_rt) - end do - - return - 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) - if(ie2.gt.0.and.ie2.lt.nd) then - call intlin(yy(ie2),xx(ie2),yy(ie2+1),xx(ie2+1),yye,rte2) - else - rte2=0.0d0 - end if - 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 - psie1=0.0d0 - psie2=1.0d0 - rhopmx=1.0d0 - rhopmn=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 - rhotmx=frhotor(rhopmx**2) - rhotmn=frhotor(rhopmn**2) - rhote2=frhotor(psie2) - rhote1=frhotor(psie1) - drhot=rhote2-rhote1 -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(ext,eyt) - implicit none - 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 pi,gam - real*8 sox - 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/mode/sox -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) -c - exxm=(ffx*csgam-ui*anpl*sngam)/sqrt(denx) - eyxm=(-ffx*sngam-ui*anpl*csgam)/sqrt(denx) -c - if (sox.lt.0.0d0) then - ext=exom - eyt=eyom - else - ext=exxm - eyt=eyxm - endif - - gam=atan(sngam/csgam)*180.d0/pi - - return - end - - subroutine stokes(ext,eyt,qq,uu,vv) - implicit none - complex*16 ext,eyt - real*8 qq,uu,vv - qq=abs(ext)**2-abs(eyt)**2 - uu=2.0d0*dble(ext*dconjg(eyt)) - vv=2.0d0*dimag(ext*dconjg(eyt)) - end subroutine stokes - - subroutine polellipse(qq,uu,vv,psipol,chipol) - implicit none - real*8 qq,uu,vv,psipol,chipol -c real*8 llm,aa,bb,ell - real*8 pi - parameter(pi=3.14159265358979d0) -c llm=sqrt(qq**2+uu**2) -c aa=sqrt((1+llm)/2.0d0) -c bb=sqrt((1-llm)/2.0d0) -c ell=bb/aa - psipol=0.5d0*atan2(uu,qq)*180.d0/pi - chipol=0.5d0*asin(vv)*180.d0/pi - end subroutine polellipse - - - logical function inside_plasma(rrm,zzm) - implicit none - real*8 rrm,zzm,psdbnd,psinv,zbmin,zbmax - integer iequil - - common/densbnd/psdbnd - common/bound/zbmin,zbmax - common/psival/psinv - common/iieq/iequil - - if(iequil.eq.1) then - call equian(rrm,zzm) - else - call equinum_psi(rrm,zzm) - end if - - if (psinv.ge.0.0d0.and.psinv.lt.psdbnd) then - if (psinv.lt.1.0d0.and.zzm.lt.zbmin.or.zzm.gt.zbmax) then - inside_plasma=.false. - else - inside_plasma=.true. - end if - else - inside_plasma=.false. - end if - - end function inside_plasma - - - subroutine wall_refl(xv,anv,ext,eyt,xvrfl,anvrfl,extr,eytr,walln, - . irfl) - use reflections, only : inters_linewall,inside - implicit none - integer*4 irfl - real*8 anv(3),anv0(3),xv(3),xvrfl(3) - real*8 walln(3),anvrfl(3),vv1(3),vv2(3),vv3(3) - real*8 smax,rrm,zzm - complex*16 extr,eytr,eztr,ext,eyt - complex*16 evin(3),evrfl(3) - integer nbb,nlim - parameter(nbb=5000) - real*8 rlim(nbb),zlim(nbb) - - common/limiter/rlim,zlim,nlim - - anv0=anv/sqrt(anv(1)**2+anv(2)**2+anv(3)**2) - rrm=1.d-2*sqrt(xv(1)**2+xv(2)**2) - zzm=1.d-2*xv(3) - -c computation of reflection coordinates and normal to the wall - call inters_linewall(xv/1.d2,anv0,rlim(1:nlim),zlim(1:nlim), - . nlim,smax,walln) - smax=smax*1.d2 - xvrfl=xv+smax*anv0 - irfl=1 - if (.not.inside(rlim,zlim,nlim,rrm,zzm)) then - ! first wall interface is outside-inside - if (dot_product(walln,walln)0 :numerical density and temp. profiles + read(u,*) prfparam%iprof, prfparam%irho ! irho=0,1,2 -> num profiles vs rhot,rhop,psin + read(u,*) prfparam%filenm +! psbnd value of psi ( > 1 ) of density boundary + read(u,*) prfparam%psnbnd !, prfparam%sspld + prfparam%sspld=0.001_wp_ +! iscal ne Te scaling 0: nustar=const, 1: n_greenw=const; 2 no rescaling +! factT factn factor for Te&ne scaling + read(u,*) prfparam%factte, prfparam%factne, prfparam%iscal + +! ipec=0/1 :pec profiles grid in psi/rhop +! nrho :number of grid steps for pec profiles +1 + read(u,*) outparam%ipec, outparam%nrho +! istpr0 projection step = dsdt*istprj +! istpl0 plot step = dsdt*istpl + read(u,*) outparam%istpr, outparam%istpl + close(u) + end subroutine read_inputs + + subroutine read_params(filenm,rtrparam,hcdparam,unit) + use utils, only : get_free_unit + implicit none +! arguments + character(len=*), intent(in) :: filenm + type(rtrparam_type), intent(out) :: rtrparam + type(hcdparam_type), intent(out) :: hcdparam + integer, intent(in), optional :: unit +! local variables + integer :: u + + if (present(unit)) then + u=unit + else + u = get_free_unit() + end if + open(u,file=filenm,status= 'old',action='read') + +! nrayr number of rays in radial direction +! nrayth number of rays in angular direction +! rwmax normalized maximum radius of beam power +! rwmax=1 -> last ray at radius = waist + read(u,*) rtrparam%nrayr, rtrparam%nrayth, rtrparam%rwmax +! igrad=0 optical ray-tracing, initial conditions as for beam +! igrad=1 quasi-optical ray-tracing +! igrad=-1 ray-tracing, init. condit. +! from center of mirror and with angular spread +! ipass=1/2 1 or 2 passes into plasma +! ipol=0 compute mode polarization at antenna, ipol=1 use polariz angles + read(u,*) rtrparam%igrad, rtrparam%ipass, rtrparam%ipol +! dst integration step +! nstep maximum number of integration steps +! idst=0/1/2 0 integration in s, 1 integr. in ct, 2 integr. in Sr + read(u,*) rtrparam%dst, rtrparam%nstep, rtrparam%idst + +! iwarm=0 :no absorption and cd +! iwarm=1 :weakly relativistic absorption +! iwarm=2 :relativistic absorption, n<1 asymptotic expansion +! iwarm=3 :relativistic absorption, numerical integration +! ilarm :order of larmor expansion +! imx :max n of iterations in dispersion, imx<0 uses 1st +! iteration in case of failure after |imx| iterations + read(u,*) hcdparam%iwarm,hcdparam%ilarm,hcdparam%imx + +! ieccd 0/1 NO/YES ECCD calculation ieccd>0 different CD models + read(u,*) hcdparam%ieccd + close(u) + end subroutine read_params + + subroutine set_codepar(eqparam,prfparam,outparam,rtrparam,hcdparam) + implicit none + type(eqparam_type), intent(in) :: eqparam + type(prfparam_type), intent(in) :: prfparam + type(outparam_type), intent(in) :: outparam + type(rtrparam_type), intent(in) :: rtrparam + type(hcdparam_type), intent(in) :: hcdparam + + iequil=eqparam%iequil + iprof=prfparam%iprof + + ipec=outparam%ipec + nnd=outparam%nrho + istpr0=outparam%istpr + istpl0=outparam%istpl + + ipol=rtrparam%ipol + igrad=rtrparam%igrad + idst=rtrparam%idst + ipass=rtrparam%ipass + if (rtrparam%nrayr<5) then + igrad=0 + print*,' nrayr < 5 ! => OPTICAL CASE ONLY' + print*,' ' + end if + + iwarm=hcdparam%iwarm + ilarm=hcdparam%ilarm + imx=hcdparam%imx + ieccd=hcdparam%ieccd + + end subroutine set_codepar + +end module gray_params diff --git a/src/graycore.f90 b/src/graycore.f90 new file mode 100644 index 0000000..2765e51 --- /dev/null +++ b/src/graycore.f90 @@ -0,0 +1,1389 @@ +module graycore + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine gray(rv,zv,psin,psia,psinr,fpol,qpsi,rvac,rax,zax,rbnd,zbnd,eqp, & + psrad,terad,derad,zfc,prfp, rlim,zlim, & + p0,fghz,alpha0,beta0,xv0,w1,w2,ri1,ri2,phiw,phir,iox0, & + psipol0,chipol0, dpdv,jcd,pabs,icd, outp,rtrp,hcdp,ierr) + use const_and_precisions, only : zero, one + use coreprofiles, only : set_prfan, set_prfspl, temp, fzeff + use dispersion, only : expinit + use gray_params, only : eqparam_type, prfparam_type, outparam_type, & + rtrparam_type, hcdparam_type, set_codepar, iequil, iprof, ieccd, & + iwarm, ipec, istpr0, igrad + use beams, only : read_beam0, read_beam1, launchangles2n, xgygcoeff + use beamdata, only : pweight, print_projxyzt, rayi2jk + use equilibrium, only : set_equian, set_eqspl, setqphi_num, set_rhospl, & + zbinf, zbsup + use magsurf_data, only : flux_average + use beamdata, only : init_rtr, dealloc_beam, nray, nstep, dst + use pec, only : pec_init, spec, postproc_profiles, dealloc_pec, & + rhop_tab, rhot_tab + use reflections, only : set_lim + use utils, only : vmaxmin + implicit none +! arguments + type(eqparam_type), intent(in) :: eqp + type(prfparam_type), intent(in) :: prfp + type(outparam_type), intent(in) :: outp + type(rtrparam_type), intent(in) :: rtrp + type(hcdparam_type), intent(in) :: hcdp + + real(wp_), dimension(:), allocatable, intent(in) :: psrad, terad, derad, zfc + real(wp_), dimension(:), allocatable, intent(in) :: rv, zv, psinr, fpol, qpsi + real(wp_), dimension(:), allocatable, intent(in) :: rbnd, zbnd, rlim, zlim + real(wp_), dimension(:,:), allocatable, intent(in) :: psin + real(wp_), intent(in) :: psia, rvac, rax, zax + integer, intent(in) :: iox0 + real(wp_), intent(in) :: p0, fghz, psipol0, chipol0 + real(wp_), intent(in) :: alpha0,beta0, w1,w2, ri1,ri2, phiw,phir + real(wp_), dimension(3), intent(in) :: xv0 + + real(wp_), intent(out) :: pabs,icd + real(wp_), dimension(:), intent(out) :: dpdv,jcd + + integer, intent(out) :: ierr +! local variables + real(wp_), parameter :: anplth1 = 0.99_wp_, anplth2 = 1.05_wp_ + real(wp_), parameter :: taucr = 12._wp_ + + real(wp_), dimension(:), allocatable :: rhotn + + real(wp_) :: sox,ak0,bres,xgcn,xg,yg,zzm,alpha,didp,anpl,anpr,anprim,anprre + real(wp_) :: chipol,psipol,btot,psinv,dens,tekev,zeff,dersdst,derdnm,st,st0 + real(wp_) :: tau0,alphaabs0,dids0,ccci0 + real(wp_) :: tau,pow,ddr,ddi,taumn,taumx + real(wp_) :: rhotpav,drhotpav,rhotjava,drhotjava + real(wp_), dimension(3) :: xv,anv0,anv + real(wp_), dimension(:,:), allocatable :: yw,ypw,gri + real(wp_), dimension(:,:,:), allocatable :: xc,du1,ggri + integer :: i,jk,iox,nharm,nhf,nnd,iokhawa,istop,index_rt=1 + logical :: ins_pl, somein, allout + + real(wp_), dimension(:,:), allocatable :: psjki,tauv,alphav,ppabs,dids,ccci + real(wp_), dimension(:), allocatable :: p0jk + complex(wp_), dimension(:), allocatable :: ext, eyt + integer, dimension(:), allocatable :: iiv + + real(wp_), dimension(:), allocatable :: jphi,pins,currins + +! ======= set environment BEGIN ====== + call set_codepar(eqp,prfp,outp,rtrp,hcdp) + + call set_lim(rlim,zlim) + + if(iequil<2) then + call set_equian(rv(1),zv(1),rv(2), fpol(1)/rv(1), qpsi(1),qpsi(2),qpsi(3)) + call flux_average + else + call set_eqspl(rv,zv,psin, psia, psinr,fpol, eqp%ssplps,eqp%ssplf, rvac, & + rax,zax, rbnd,zbnd, eqp%ixp) + +! compute rho_pol/rho_tor mapping + allocate(rhotn(size(qpsi))) + call setqphi_num(psinr,abs(qpsi),abs(psia),rhotn) + call set_rhospl(sqrt(psinr),rhotn) + deallocate(rhotn) + +! compute flux surface averaged quantities + call flux_average ! requires frhotor for dadrhot,dvdrhot +! print psi surface for q=1.5 and q=2 + call surfq(psinr,qpsi,size(qpsi),1.5_wp_) + call surfq(psinr,qpsi,size(qpsi),2.0_wp_) + end if + + if(iprof==0) then + call set_prfan(terad,derad,zfc) + else + call set_prfspl(psrad, terad, derad, zfc, prfp%sspld, prfp%psnbnd) + end if + + call xgygcoeff(fghz,ak0,bres,xgcn) + call launchangles2n(alpha0,beta0,xv0,anv0) + call init_rtr(rtrp,yw,ypw,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) + + if(iwarm > 1) call expinit + +! ======= set environment END ====== + +! ======= pre-proc prints BEGIN ====== +! print Btot=Bres +! print ne, Te, q, Jphi versus psi, rhop, rhot + if (iequil<2) then + call bres_anal(bres) + call print_prof_an + else + call bfield_res(rv,zv,size(rv),size(zv),bres) + call print_prof + end if + call prfile +! ======= pre-proc prints END ====== + +! ======= main loop BEGIN ====== + iox=iox0 + sox=-1.0_wp_ + if(iox==2) sox=1.0_wp_ + call vectinit(psjki,tauv,alphav,ppabs,dids,ccci,iiv) + call ic_gb(xv0,anv0,ak0,w1,w2,ri1,ri2,phiw,phir,yw,ypw,xc,du1,gri,ggri) + + psipol=psipol0 + chipol=chipol0 + call set_pol(yw,bres,sox,psipol,chipol,ext,eyt) + call pweight(p0,p0jk) + + st0 = zero + if(nray>1) call print_projxyzt(st0,yw,0) ! iproj=0 ==> nfilp=8 + +! test if at least part of the beam has entered the plsama + somein = .false. + istop = 0 +! beam/ray propagation + do i=1,nstep + +! advance one step with "frozen" grad(S_I) + st=i*dst+st0 + do jk=1,nray + call rkstep(sox,bres,xgcn,yw(:,jk),ypw(:,jk),gri(:,jk),ggri(:,:,jk)) + end do + +! update position and grad + if(igrad == 1) call gradi_upd(yw,ak0,xc,du1,gri,ggri) + +! test if the beam is completely out of the plsama + allout = .true. + do jk=1,nray +! compute derivatives with updated gradient and local plasma values + xv = yw(1:3,jk) + anv = yw(4:6,jk) + call ywppla_upd(xv,anv,gri(:,jk),ggri(:,:,jk),sox,bres,xgcn,ypw(:,jk), & + psinv,dens,btot,xg,yg,anpl,anpr,ddr,ddi,dersdst,derdnm) + + if( abs(anpl) > anplth1) then + if(abs(anpl) <= anplth2) then + ierr=97 +! igrad=0 + else + ierr=98 + istop=1 + end if + else + ierr=0 + end if + + if(i==1) then + tau0=zero + alphaabs0=zero + dids0=zero + ccci0=zero + else + tau0=tauv(jk,i-1) + alphaabs0=alphav(jk,i-1) + dids0=dids(jk,i-1) + ccci0=ccci(jk,i-1) + end if + zzm = xv(3)*0.01_wp_ + ins_pl = (psinv>=zero .and. psinv=zbinf .and. zzm<=zbsup) + allout = allout .and. .not.ins_pl + somein = somein .or. ins_pl + +! compute ECRH&CD + if(ierr==0 .and. iwarm>0 .and. ins_pl .and. tau0<=taucr) then +! print*,i,jk,rayi2jk(jk),psinv,zzm,anpl + tekev=temp(psinv) + if (ieccd> 0) zeff=fzeff(psinv) + call alpha_effj(psinv,xg,yg,dens,tekev,zeff,ak0,bres,derdnm, & + anpl,anpr,sox,anprre,anprim,alpha,didp,nharm,nhf,iokhawa,ierr) + else + tekev=zero + zeff=zero + alpha=zero + didp=zero + anprim=zero + anprre=anpr + nharm=0 + nhf=0 + iokhawa=0 + end if + if(nharm>0) iiv(jk)=i + +! full storage required only for psjki,ppabs,ccci +! (jk,i) indexing can be removed from tauv,alphav,dids +! adding (jk) indexing to alphaabs0,tau0,dids0,ccci0 + psjki(jk,i) = psinv +! computation of optical depth tau, dP/ds, P(s), dI/ds, I(s) + tau=tau0+0.5_wp_*(alpha+alphaabs0)*dersdst*dst + tauv(jk,i)=tau + alphav(jk,i)=alpha + pow=p0jk(jk)*exp(-tau) !*exp(-tau1v(jk)) + ppabs(jk,i)=p0jk(jk)-pow + + dids(jk,i)=didp*pow*alpha + ccci(jk,i)=ccci0+0.5_wp_*(dids0+dids(jk,i))*dersdst*dst + + call print_output(i,jk,st,p0jk(jk)/p0,xv,psinv,btot,ak0,anpl,anpr, & + anprim,dens,tekev,alpha,tau,dids(jk,i),nhf,iokhawa, & + index_rt,ddr,ddi) + +! print error code + select case (ierr) + case(97) !+1 + print*,i,jk,' IERR = ', ierr,' N// = ',anpl + case(98) !+2 + print*,i,jk,' IERR = ', ierr,' N// = ',anpl + case(99) !+1*4 + print*,i,jk,' IERR = ', ierr,' Nwarm = ',anprre,anprim + case(94) !+2*4 + print*,i,jk,' IERR = ', ierr,' alpha < 0' + case(90) !+1*16 + print*,i,jk,' IERR = ', ierr,' fpp integration error' + case(91:93) !+2..4*16 + print*,i,jk,' IERR = ', ierr,' fcur integration error' + end select + + end do + +! print ray positions for j=nrayr in local reference system + if (mod(i,istpr0) == 0) then + if(nray > 1) call print_projxyzt(st,yw,0) + end if + +! test if trajectory integration must be stopped + call vmaxmin(tauv(:,i),nray,taumn,taumx) + if ((taumn > taucr) .or. (somein .and. allout)) then + pabs = sum(ppabs(:,i)) + icd = sum(ccci(:,i)) + istop = 1 + end if + if(istop == 1) exit + end do +! ======= main loop END ====== + +! ======= post-proc BEGIN ====== +! print all ray positions in local reference system + if(nray > 1) call print_projxyzt(st,yw,1) +! print final results on screen + write(*,*) + write(*,'(a,f9.4)') 'final step (s, ct, Sr) = ',st + write(*,'(a,2e12.5)') 'taumn, taumx = ', taumn,taumx + write(*,'(a,f9.4)') 'Pabs_tot (MW) = ',pabs + write(*,'(a,f9.4)') 'I_tot (kA) = ',icd*1.0e3_wp_ + +! compute power and current density profiles for all rays + call pec_init(ipec) !,sqrt(psinr)) + nnd=size(rhop_tab) + allocate(jphi(nnd),pins(nnd),currins(nnd)) + call spec(psjki,ppabs,ccci,iiv,pabs,icd,dpdv,jphi,jcd,pins,currins) + + call postproc_profiles(pabs,icd,rhot_tab,dpdv,jphi, & + rhotpav,drhotpav,rhotjava,drhotjava) + +! print power and current density profiles + do i=1,nnd + write(48,'(7(1x,e16.8e3))') rhop_tab(i),rhot_tab(i), & + jphi(i),jcd(i),dpdv(i),currins(i),pins(i) + end do +! ======= post-proc END ====== + +! ======= free memory BEGIN ====== + call dealloc_beam(yw,ypw,xc,du1,gri,ggri, & + psjki,tauv,alphav,ppabs,dids,ccci,p0jk,ext,eyt,iiv) +! call unset_eqspl +! call unset_q +! call unset_rhospl +! call unset_prfspl + call dealloc_pec + deallocate(jphi,pins,currins) +! ======= free memory END ====== + end subroutine gray + + + subroutine vectinit(psjki,tauv,alphav,ppabs,dids,ccci,iiv) + use const_and_precisions, only : wp_, zero + implicit none +! arguments + real(wp_), dimension(:,:), intent(out) :: psjki,tauv,alphav,ppabs,dids,ccci + integer, dimension(:), intent(out) :: iiv +!! common/external functions/variables +! integer :: jclosest +! real(wp_), dimension(3) :: anwcl,xwcl +! +! common/refln/anwcl,xwcl,jclosest +! +! jclosest=nrayr+1 +! anwcl(1:3)=0.0_wp_ +! xwcl(1:3)=0.0_wp_ + + psjki = zero + tauv = zero + alphav = zero + ppabs = zero + dids = zero + ccci = zero + iiv = 1 + + end subroutine vectinit + + + subroutine ic_gb(xv0c,anv0c,ak0,wcsi,weta,rcicsi,rcieta,phiw,phir, & + ywrk0,ypwrk0,xc0,du10,gri,ggri) +! beam tracing initial conditions igrad=1 +! !!!!!! check ray tracing initial conditions igrad=0 !!!!!! + use const_and_precisions, only : wp_,izero,zero,one,pi,half,two,degree,ui=>im + use math, only : catand + use gray_params, only : idst + use beamdata, only : nray,nrayr,nrayth,rwmax + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: xv0c,anv0c + real(wp_), intent(in) :: ak0 + real(wp_), intent(in) :: wcsi,weta,rcicsi,rcieta,phiw,phir + real(wp_), dimension(6,nray), intent(out) :: ywrk0,ypwrk0 + real(wp_), dimension(3,nray), intent(out) :: gri + real(wp_), dimension(3,3,nray), intent(out) :: ggri + real(wp_), dimension(3,nrayth,nrayr), intent(out) :: xc0,du10 + +! local variables + integer :: j,k,jk + real(wp_) :: csth,snth,csps,snps,phiwrad,phirrad,csphiw,snphiw,alfak + real(wp_) :: wwcsi,wweta,sk,sw,dk,dw,rci1,ww1,rci2,ww2,wwxx,wwyy,wwxy + real(wp_) :: rcixx,rciyy,rcixy,dwwxx,dwwyy,dwwxy,d2wwxx,d2wwyy,d2wwxy + real(wp_) :: drcixx,drciyy,drcixy,dr,da,ddfu,dcsiw,detaw,dx0t,dy0t + real(wp_) :: x0t,y0t,z0t,dx0,dy0,dz0,x0,y0,z0,gxt,gyt,gzt,gr2 + real(wp_) :: gxxt,gyyt,gzzt,gxyt,gxzt,gyzt,dgr2xt,dgr2yt,dgr2zt + real(wp_) :: dgr2x,dgr2y,dgr2z,pppx,pppy,denpp,ppx,ppy + real(wp_) :: anzt,anxt,anyt,anx,any,anz,an20,an0 + real(wp_) :: du1tx,du1ty,du1tz,denom,ddr,ddi + real(wp_), dimension(nrayr) :: uj + real(wp_), dimension(nrayth) :: sna,csa + complex(wp_) :: sss,ddd,phic,qi1,qi2,tc,ts,qqxx,qqxy,qqyy,dqi1,dqi2 + complex(wp_) :: dqqxx,dqqyy,dqqxy,d2qi1,d2qi2,d2qqxx,d2qqyy,d2qqxy + + csth=anv0c(3) + snth=sqrt(one-csth**2) + if(snth > zero) then + csps=anv0c(2)/snth + snps=anv0c(1)/snth + else + csps=one + snps=zero + end if + + phiwrad = phiw*degree + phirrad = phir*degree + csphiw = cos(phiwrad) + snphiw = sin(phiwrad) +! csphir = cos(phirrad) +! snphir = sin(phirrad) + + wwcsi = two/(ak0*wcsi**2) + wweta = two/(ak0*weta**2) + + if(phir/=phiw) then + sk = rcicsi + rcieta + sw = wwcsi + wweta + dk = rcicsi - rcieta + dw = wwcsi - wweta + ts = -(dk*sin(2*phirrad) - ui*dw*sin(2*phiwrad)) + tc = (dk*cos(2*phirrad) - ui*dw*cos(2*phiwrad)) + phic = half*catand(ts/tc) + ddd = dk*cos(2*(phirrad+phic)) - ui*dw*cos(2*(phiwrad+phic)) + sss = sk - ui*sw + qi1 = half*(sss + ddd) + qi2 = half*(sss - ddd) + rci1 = dble(qi1) + rci2 = dble(qi2) + ww1 =-dimag(qi1) + ww2 =-dimag(qi2) + else + rci1 = rcicsi + rci2 = rcieta + ww1 = wwcsi + ww2 = wweta + phic = -phiwrad + qi1 = rci1 - ui*ww1 + qi2 = rci2 - ui*ww2 + end if + +! w01=sqrt(2.0_wp_/(ak0*ww1)) +! d01=-rci1/(rci1**2+ww1**2) +! w02=sqrt(2.0_wp_/(ak0*ww2)) +! d02=-rci2/(rci2**2+ww2**2) + + qqxx = qi1*cos(phic)**2 + qi2*sin(phic)**2 + qqyy = qi1*sin(phic)**2 + qi2*cos(phic)**2 + qqxy = -(qi1 - qi2)*sin(2*phic) + wwxx = -dimag(qqxx) + wwyy = -dimag(qqyy) + wwxy = -half*dimag(qqxy) + rcixx = dble(qqxx) + rciyy = dble(qqyy) + rcixy = half* dble(qqxy) + + 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*phic) + d2qqxx = d2qi1*cos(phic)**2 + d2qi2*sin(phic)**2 + d2qqyy = d2qi1*sin(phic)**2 + d2qi2*cos(phic)**2 + d2qqxy = -(d2qi1 - d2qi2)*sin(2*phic) + + dwwxx = -dimag(dqqxx) + dwwyy = -dimag(dqqyy) + dwwxy = -half*dimag(dqqxy) + d2wwxx = -dimag(d2qqxx) + d2wwyy = -dimag(d2qqyy) + d2wwxy = -half*dimag(d2qqxy) + drcixx = dble(dqqxx) + drciyy = dble(dqqyy) + drcixy = half* dble(dqqxy) + + if(nrayr > 1) then + dr = rwmax/dble(nrayr-1) + else + dr = one + end if + ddfu = two*dr**2/ak0 ! twodr2 = 2*dr**2 = 2*rwmax/dble(nrayr-1) + do j = 1, nrayr + uj(j) = dble(j-1) + end do + + da=2*pi/dble(nrayth) + do k=1,nrayth + alfak = (k-1)*da + sna(k) = sin(alfak) + csa(k) = cos(alfak) + end do + +! central ray + jk=1 + gri(:,1) = zero + ggri(:,:,1) = zero + + ywrk0(1:3,1) = xv0c + ywrk0(4:6,1) = anv0c + ypwrk0(1:3,1) = anv0c + ypwrk0(4:6,1) = zero + + do k=1,nrayth + dcsiw = dr*csa(k)*wcsi + detaw = dr*sna(k)*weta + dx0t = dcsiw*csphiw - detaw*snphiw + dy0t = dcsiw*snphiw + detaw*csphiw + du1tx = (dx0t*wwxx + dy0t*wwxy)/ddfu + du1ty = (dx0t*wwxy + dy0t*wwyy)/ddfu + + xc0(:,k,1) = xv0c + du10(1,k,1) = du1tx*csps + snps*du1ty*csth + du10(2,k,1) = -du1tx*snps + csps*du1ty*csth + du10(3,k,1) = -du1ty*snth + end do + ddr = zero + ddi = zero + +! loop on rays jk>1 + j=2 + k=0 + do jk=2,nray + k=k+1 + if(k > nrayth) then + j=j+1 + k=1 + end if + +! csiw=u*dcsiw +! etaw=u*detaw +! csir=x0t*csphir+y0t*snphir +! etar=-x0t*snphir+y0t*csphir + dcsiw = dr*csa(k)*wcsi + detaw = dr*sna(k)*weta + dx0t = dcsiw*csphiw - detaw*snphiw + dy0t = dcsiw*snphiw + detaw*csphiw + x0t = uj(j)*dx0t + y0t = uj(j)*dy0t + z0t = -half*(rcixx*x0t**2 + rciyy*y0t**2 + 2*rcixy*x0t*y0t) + + dx0 = x0t*csps + snps*(y0t*csth + z0t*snth) + dy0 = -x0t*snps + csps*(y0t*csth + z0t*snth) + dz0 = z0t*csth - y0t*snth + x0 = xv0c(1) + dx0 + y0 = xv0c(2) + dy0 + z0 = xv0c(3) + dz0 + + gxt = x0t*wwxx + y0t*wwxy + gyt = x0t*wwxy + y0t*wwyy + gzt = half*(x0t**2*dwwxx + y0t**2*dwwyy ) + x0t*y0t*dwwxy + gr2 = gxt*gxt + gyt*gyt + gzt*gzt + gxxt = wwxx + gyyt = wwyy + gzzt = half*(x0t**2*d2wwxx + y0t**2*d2wwyy) + x0t*y0t*d2wwxy + gxyt = wwxy + gxzt = x0t*dwwxx + y0t*dwwxy + gyzt = x0t*dwwxy + y0t*dwwyy + dgr2xt = 2*(gxt*gxxt + gyt*gxyt + gzt*gxzt) + dgr2yt = 2*(gxt*gxyt + gyt*gyyt + gzt*gyzt) + dgr2zt = 2*(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,jk) = gxt*csps + snps*(gyt*csth + gzt*snth) + gri(2,jk) = -gxt*snps + csps*(gyt*csth + gzt*snth) + gri(3,jk) = gzt*csth - gyt*snth + ggri(1,1,jk) = gxxt*csps**2 & + + snps**2 *(gyyt*csth**2 + gzzt*snth**2 + 2*snth*csth*gyzt) & + +2*snps*csps*(gxyt*csth + gxzt*snth) + ggri(2,1,jk) = csps*snps & + *(-gxxt+csth**2*gyyt + snth**2*gzzt + 2*csth*snth*gyzt) & + +(csps**2 - snps**2)*(snth*gxzt + csth*gxyt) + ggri(3,1,jk) = csth*snth*snps*(gzzt - gyyt) + (csth**2 - snth**2) & + *snps*gyzt + csps*(csth*gxzt - snth*gxyt) + ggri(1,2,jk) = ggri(2,1,jk) + ggri(2,2,jk) = gxxt*snps**2 & + + csps**2 *(gyyt*csth**2 + gzzt*snth**2 + 2*snth*csth*gyzt) & + -2*snps*csps*(gxyt*csth + gxzt*snth) + ggri(3,2,jk) = csth*snth*csps*(gzzt - gyyt) + (csth**2-snth**2) & + *csps*gyzt + snps*(snth*gxyt - csth*gxzt) + ggri(1,3,jk) = ggri(3,1,jk) + ggri(2,3,jk) = ggri(3,2,jk) + ggri(3,3,jk) = gzzt*csth**2 + gyyt*snth**2 - 2*csth*snth*gyzt + + du1tx = (dx0t*wwxx + dy0t*wwxy)/ddfu + du1ty = (dx0t*wwxy + dy0t*wwyy)/ddfu + du1tz = half*uj(j)*(dx0t**2*dwwxx + dy0t**2*dwwyy + 2*dx0t*dy0t*dwwxy)/ddfu + + du10(1,k,j) = du1tx*csps + snps*(du1ty*csth + du1tz*snth) + du10(2,k,j) = -du1tx*snps + csps*(du1ty*csth + du1tz*snth) + du10(3,k,j) = du1tz*csth - du1ty*snth + + pppx = x0t*rcixx + y0t*rcixy + pppy = x0t*rcixy + y0t*rciyy + denpp = pppx*gxt + pppy*gyt + if (denpp/=zero) then + ppx = -pppx*gzt/denpp + ppy = -pppy*gzt/denpp + else + ppx = zero + ppy = zero + end if + + anzt = sqrt((one + gr2)/(one + ppx**2 + ppy**2)) + anxt = ppx*anzt + anyt = ppy*anzt + + anx = anxt*csps + snps*(anyt*csth + anzt*snth) + any =-anxt*snps + csps*(anyt*csth + anzt*snth) + anz = anzt*csth - anyt*snth + + an20 = one + gr2 + an0 = sqrt(an20) + + xc0(1,k,j) = x0 + xc0(2,k,j) = y0 + xc0(3,k,j) = z0 + + ywrk0(1,jk) = x0 + ywrk0(2,jk) = y0 + ywrk0(3,jk) = z0 + ywrk0(4,jk) = anx + ywrk0(5,jk) = any + ywrk0(6,jk) = anz + + select case(idst) + case(1) +! integration variable: c*t + denom = one + case(2) +! integration variable: Sr + denom = an20 + case default ! idst=0 +! integration variable: s + denom = an0 + end select + ypwrk0(1,jk) = anx/denom + ypwrk0(2,jk) = any/denom + ypwrk0(3,jk) = anz/denom + ypwrk0(4,jk) = dgr2x/(2*denom) + ypwrk0(5,jk) = dgr2y/(2*denom) + ypwrk0(6,jk) = dgr2z/(2*denom) + + ddr = anx**2 + any**2 + anz**2 - an20 + ddi = 2*(anxt*gxt + anyt*gyt + anzt*gzt) + end do + write(17,'(3(1x,e16.8e3))') zero,ddr,ddi + end subroutine ic_gb + + subroutine rkstep(sox,bres,xgcn,y,yp,dgr,ddgr) +! Runge-Kutta integrator + use const_and_precisions, only : wp_ +! use gray_params, only : igrad + use beamdata, only : h,hh,h6 + implicit none + real(wp_), intent(in) :: sox,bres,xgcn + real(wp_), dimension(6), intent(inout) :: y + real(wp_), dimension(6), intent(in) :: yp + real(wp_), dimension(3), intent(in) :: dgr + real(wp_), dimension(3,3), intent(in) :: ddgr + + real(wp_), dimension(6) :: yy,fk1,fk2,fk3,fk4 + real(wp_) :: gr2 + real(wp_), dimension(3) :: dgr2 + +! if(igrad.eq.1) then + gr2 = dgr(1)**2 + dgr(2)**2 + dgr(3)**2 + dgr2 = 2*(dgr(1)*ddgr(:,1) + dgr(2)*ddgr(:,2) + dgr(3)*ddgr(:,3)) +! end if + fk1 = yp + + yy = y + fk1*hh + call rhs(sox,bres,xgcn,yy,gr2,dgr2,dgr,ddgr,fk2) + yy = y + fk2*hh + call rhs(sox,bres,xgcn,yy,gr2,dgr2,dgr,ddgr,fk3) + yy = y + fk3*h + call rhs(sox,bres,xgcn,yy,gr2,dgr2,dgr,ddgr,fk4) + + y = y + h6*(fk1 + 2*fk2 + 2*fk3 + fk4) + end subroutine rkstep + + subroutine rhs(sox,bres,xgcn,y,gr2,dgr2,dgr,ddgr,dery) +! Compute right-hand side terms of the ray equations (dery) +! used in R-K integrator + use const_and_precisions, only : wp_ + implicit none +! arguments + real(wp_), dimension(6), intent(in) :: y + real(wp_), intent(in) :: sox,bres,xgcn,gr2 + real(wp_), dimension(3), intent(in) :: dgr2,dgr + real(wp_), dimension(3,3), intent(in) :: ddgr + real(wp_), dimension(6), intent(out) :: dery +! local variables + real(wp_) :: psinv,dens,btot,xg,yg,anpl,anpr,ajphi + real(wp_) :: ddr,ddi,dersdst,derdnm + real(wp_), dimension(3) :: xv,anv,bv,derxg,deryg + real(wp_), dimension(3,3) :: derbv + + xv = y(1:3) + call plas_deriv(xv,bres,xgcn,psinv,dens,btot,bv,derbv,xg,yg,derxg,deryg, & + ajphi) + + anv = y(4:6) + call disp_deriv(anv,sox,xg,yg,derxg,deryg,bv,derbv,gr2,dgr2,dgr,ddgr, & + dery,anpl,anpr,ddr,ddi,dersdst,derdnm) + end subroutine rhs + + + subroutine ywppla_upd(xv,anv,dgr,ddgr,sox,bres,xgcn,dery,psinv,dens,btot, & + xg,yg,anpl,anpr,ddr,ddi,dersdst,derdnm) +! Compute right-hand side terms of the ray equations (dery) +! used after full R-K step and grad(S_I) update +! use gray_params, only : igrad + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: xv,anv + real(wp_), dimension(3), intent(in) :: dgr + real(wp_), dimension(3,3), intent(in) :: ddgr + real(wp_), intent(in) :: sox,bres,xgcn + real(wp_), dimension(6), intent(out) :: dery + real(wp_), intent(out) :: psinv,dens,btot,xg,yg,anpl,anpr + real(wp_), intent(out) :: ddr,ddi,dersdst,derdnm +! local variables + real(wp_) :: gr2,ajphi + real(wp_), dimension(3) :: dgr2,bv,derxg,deryg + real(wp_), dimension(3,3) :: derbv + +! if(igrad == 1) then + gr2 = dgr(1)**2 + dgr(2)**2 + dgr(3)**2 + dgr2 = 2*(dgr(1)*ddgr(:,1) + dgr(2)*ddgr(:,2) + dgr(3)*ddgr(:,3)) +! end if + call plas_deriv(xv,bres,xgcn,psinv,dens,btot,bv,derbv,xg,yg,derxg,deryg,ajphi) + call disp_deriv(anv,sox,xg,yg,derxg,deryg,bv,derbv,gr2,dgr2,dgr,ddgr, & + dery,anpl,anpr,ddr,ddi,dersdst,derdnm) + end subroutine ywppla_upd + + + subroutine gradi_upd(ywrk,ak0,xc,du1,gri,ggri) + use const_and_precisions, only : wp_,zero,half + use beamdata, only : nray,nrayr,nrayth,twodr2 + implicit none + real(wp_), intent(in) :: ak0 + real(wp_), dimension(6,nray), intent(in) :: ywrk + real(wp_), dimension(3,nrayth,nrayr), intent(inout) :: xc,du1 + real(wp_), dimension(3,nray), intent(out) :: gri + real(wp_), dimension(3,3,nray), intent(out) :: ggri +! local variables + real(wp_), dimension(3,nrayth,nrayr) :: xco,du1o + integer :: jk,j,jm,jp,k,km,kp + real(wp_) :: ux,uxx,uxy,uxz,uy,uyy,uyz,uz,uzz + real(wp_) :: dfuu,dffiu,gx,gxx,gxy,gxz,gy,gyy,gyz,gz,gzz + real(wp_), dimension(3) :: dxv1,dxv2,dxv3,dgu + real(wp_), dimension(3,3) :: dgg,dff + +! update position and du1 vectors + xco = xc + du1o = du1 + + jk = 1 + do j=1,nrayr + do k=1,nrayth + if(j>1) jk=jk+1 + xc(1:3,k,j)=ywrk(1:3,jk) + end do + end do + +! compute grad u1 for central ray + j = 1 + jp = 2 + do k=1,nrayth + if(k == 1) then + km = nrayth + else + km = k-1 + end if + if(k == nrayth) then + kp = 1 + else + kp = k+1 + end if + dxv1 = xc(:,k ,jp) - xc(:,k ,j) + dxv2 = xc(:,kp,jp) - xc(:,km,jp) + dxv3 = xc(:,k ,j) - xco(:,k ,j) + call solg0(dxv1,dxv2,dxv3,dgu) + du1(:,k,j) = dgu + end do + gri(:,1) = zero + +! compute grad u1 and grad(S_I) for all the other rays + dfuu=twodr2/ak0 ! twodr2 = 2*dr**2 = 2*(rwmax/(nrayr-1))**2 + jm=1 + j=2 + k=0 + dffiu = dfuu + do jk=2,nray + k=k+1 + if(k > nrayth) then + jm = j + j = j+1 + k = 1 + dffiu = dfuu*jm + end if + kp = k+1 + km = k-1 + if (k == 1) then + km=nrayth + else if (k == nrayth) then + kp=1 + end if + dxv1 = xc(:,k ,j) - xc(:,k ,jm) + dxv2 = xc(:,kp,j) - xc(:,km,j) + dxv3 = xc(:,k ,j) - xco(:,k ,j) + call solg0(dxv1,dxv2,dxv3,dgu) + du1(:,k,j) = dgu + gri(:,jk) = dgu(:)*dffiu + end do + +! compute derivatives of grad u and grad(S_I) for rays jk>1 + ggri(:,:,1) = zero + jm=1 + j=2 + k=0 + dffiu = dfuu + do jk=2,nray + k=k+1 + if(k > nrayth) then + jm=j + j=j+1 + k=1 + dffiu = dfuu*jm + end if + kp=k+1 + km=k-1 + if (k == 1) then + km=nrayth + else if (k == nrayth) then + kp=1 + end if + dxv1 = xc(:,k ,j) - xc(:,k ,jm) + dxv2 = xc(:,kp,j) - xc(:,km,j) + dxv3 = xc(:,k ,j) - xco(:,k ,j) + dff(:,1) = du1(:,k ,j) - du1(:,k ,jm) + dff(:,2) = du1(:,kp,j) - du1(:,km,j) + dff(:,3) = du1(:,k ,j) - du1o(:,k ,j) + call solg3(dxv1,dxv2,dxv3,dff,dgg) + +! derivatives of u + ux = du1(1,k,j) + uy = du1(2,k,j) + uz = du1(3,k,j) + uxx = dgg(1,1) + uyy = dgg(2,2) + uzz = dgg(3,3) + uxy = (dgg(1,2) + dgg(2,1))*half + uxz = (dgg(1,3) + dgg(3,1))*half + uyz = (dgg(2,3) + dgg(3,2))*half + +! derivatives of S_I and Grad(S_I) + gx = ux*dffiu + gy = uy*dffiu + gz = uz*dffiu + gxx = dfuu*ux*ux + dffiu*uxx + gyy = dfuu*uy*uy + dffiu*uyy + gzz = dfuu*uz*uz + dffiu*uzz + gxy = dfuu*ux*uy + dffiu*uxy + gxz = dfuu*ux*uz + dffiu*uxz + gyz = dfuu*uy*uz + dffiu*uyz + + ggri(1,1,jk)=gxx + ggri(2,1,jk)=gxy + ggri(3,1,jk)=gxz + ggri(1,2,jk)=gxy + ggri(2,2,jk)=gyy + ggri(3,2,jk)=gyz + ggri(1,3,jk)=gxz + ggri(2,3,jk)=gyz + ggri(3,3,jk)=gzz + end do + + end subroutine gradi_upd + + subroutine solg0(dxv1,dxv2,dxv3,dgg) +! solution of the linear system of 3 eqs : dgg . dxv = dff +! input vectors : dxv1, dxv2, dxv3, dff +! output vector : dgg +! dff=(1,0,0) + use const_and_precisions, only : wp_ + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: dxv1,dxv2,dxv3 + real(wp_), dimension(3), intent(out) :: dgg +! local variables + real(wp_) :: denom,aa1,aa2,aa3 + + aa1 = (dxv2(2)*dxv3(3) - dxv3(2)*dxv2(3)) + aa2 = (dxv1(2)*dxv3(3) - dxv3(2)*dxv1(3)) + aa3 = (dxv1(2)*dxv2(3) - dxv2(2)*dxv1(3)) + + 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 + end subroutine solg0 + + subroutine solg3(dxv1,dxv2,dxv3,dff,dgg) +! rhs "matrix" dff, result in dgg + use const_and_precisions, only : wp_ + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: dxv1,dxv2,dxv3 + real(wp_), dimension(3,3), intent(in) :: dff + real(wp_), dimension(3,3), intent(out) :: dgg +! local variables + real(wp_) denom,a11,a21,a31,a12,a22,a32,a13,a23,a33 + + a11 = (dxv2(2)*dxv3(3) - dxv3(2)*dxv2(3)) + a21 = (dxv1(2)*dxv3(3) - dxv3(2)*dxv1(3)) + a31 = (dxv1(2)*dxv2(3) - dxv2(2)*dxv1(3)) + + a12 = (dxv2(1)*dxv3(3) - dxv3(1)*dxv2(3)) + a22 = (dxv1(1)*dxv3(3) - dxv3(1)*dxv1(3)) + a32 = (dxv1(1)*dxv2(3) - dxv2(1)*dxv1(3)) + + a13 = (dxv2(1)*dxv3(2) - dxv3(1)*dxv2(2)) + a23 = (dxv1(1)*dxv3(2) - dxv3(1)*dxv1(2)) + a33 = (dxv1(1)*dxv2(2) - dxv2(1)*dxv1(2)) + + denom = dxv1(1)*a11 - dxv2(1)*a21 + dxv3(1)*a31 + + dgg(:,1) = ( dff(:,1)*a11 - dff(:,2)*a21 + dff(:,3)*a31)/denom + dgg(:,2) = (-dff(:,1)*a12 + dff(:,2)*a22 - dff(:,3)*a32)/denom + dgg(:,3) = ( dff(:,1)*a13 - dff(:,2)*a23 + dff(:,3)*a33)/denom + end subroutine solg3 + + + subroutine plas_deriv(xv,bres,xgcn,psinv,dens,btot,bv,derbv, & + xg,yg,derxg,deryg,ajphi) + use const_and_precisions, only : wp_,zero,pi,ccj=>mu0inv + use gray_params, only : iequil + use equilibrium, only : psia,equinum_fpol,equinum_psi,equian,sgnbphi + use coreprofiles, only : density + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: xv + real(wp_), intent(in) :: xgcn,bres + real(wp_), intent(out) :: psinv,dens,btot,xg,yg + real(wp_), dimension(3), intent(out) :: bv,derxg,deryg + real(wp_), dimension(3,3), intent(out) :: derbv +! local variables + integer :: jv + real(wp_) :: xx,yy,zz + real(wp_) :: b2tot,csphi,drrdx,drrdy,dphidx,dphidy,rr,rr2,rrm,snphi,zzm + real(wp_), dimension(3) :: dbtot,bvc + real(wp_), dimension(3,3) :: dbvcdc,dbvdc,dbv + real(wp_) :: brr,bphi,bzz,ajphi,dxgdpsi + real(wp_) :: dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz,fpolv,dfpv,ddenspsin + + xg = zero + yg = 99._wp_ + psinv = -1._wp_ + dens = zero + btot = zero + ajphi = zero + derxg = zero + deryg = zero + bv = zero + derbv = zero + + if(iequil==0) return + + dbtot = zero + dbv = zero + dbvcdc = zero + dbvcdc = zero + dbvdc = zero + + xx = xv(1) + yy = xv(2) + zz = xv(3) + +! cylindrical coordinates + rr2 = xx**2 + yy**2 + rr = sqrt(rr2) + csphi = xx/rr + snphi = yy/rr + + bv(1) = -snphi*sgnbphi + bv(2) = csphi*sgnbphi + +! convert from cm to meters + zzm = 1.0e-2_wp_*zz + rrm = 1.0e-2_wp_*rr + + if(iequil==1) then + call equian(rrm,zzm,psinv,fpolv,dfpv,dpsidr,dpsidz, & + ddpsidrr,ddpsidzz,ddpsidrz) + else + call equinum_psi(rrm,zzm,psinv,dpsidr,dpsidz,ddpsidrr,ddpsidzz,ddpsidrz) + call equinum_fpol(psinv,fpolv,dfpv) + end if + +! compute yg and derivative + if(psinv < zero) then + bphi = fpolv/rrm + btot = abs(bphi) + yg = btot/bres + return + end if + +! compute xg and derivative + call density(psinv,dens,ddenspsin) + xg = xgcn*dens + dxgdpsi = xgcn*ddenspsin/psia + +! B = f(psi)/R e_phi+ grad psi x e_phi/R + bphi = fpolv/rrm + brr =-dpsidz/rrm + bzz = dpsidr/rrm + +! bvc(i) = B_i in cylindrical coordinates + bvc(1) = brr + bvc(2) = bphi + bvc(3) = bzz + +! bv(i) = B_i in cartesian coordinates + bv(1)=bvc(1)*csphi - bvc(2)*snphi + bv(2)=bvc(1)*snphi + bvc(2)*csphi + bv(3)=bvc(3) + +! dbvcdc(iv,jv) = d Bcil(iv) / dxvcil(jv) + dbvcdc(1,1) = -ddpsidrz/rrm - brr/rrm + dbvcdc(2,1) = dfpv*dpsidr/rrm - bphi/rrm + dbvcdc(3,1) = ddpsidrr/rrm - bzz/rrm + dbvcdc(1,3) = -ddpsidzz/rrm + dbvcdc(2,3) = dfpv*dpsidz/rrm + dbvcdc(3,3) = ddpsidrz/rrm + +! dbvdc(iv,jv) = d Bcart(iv) / dxvcil(jv) + dbvdc(1,1) = dbvcdc(1,1)*csphi - dbvcdc(2,1)*snphi + dbvdc(2,1) = dbvcdc(1,1)*snphi + dbvcdc(2,1)*csphi + dbvdc(3,1) = dbvcdc(3,1) + dbvdc(1,2) = -bv(2) + dbvdc(2,2) = bv(1) + dbvdc(3,2) = dbvcdc(3,2) + dbvdc(1,3) = dbvcdc(1,3)*csphi - dbvcdc(2,3)*snphi + dbvdc(2,3) = dbvcdc(1,3)*snphi + dbvcdc(2,3)*csphi + dbvdc(3,3) = dbvcdc(3,3) + + drrdx = csphi + drrdy = snphi + dphidx = -snphi/rrm + dphidy = csphi/rrm + +! dbv(iv,jv) = d Bcart(iv) / dxvcart(jv) + dbv(:,1) = drrdx*dbvdc(:,1) + dphidx*dbvdc(:,2) + dbv(:,2) = drrdy*dbvdc(:,1) + dphidy*dbvdc(:,2) + dbv(:,3) = dbvdc(:,3) + +! B magnitude and derivatives + b2tot = bv(1)**2 + bv(2)**2 + bv(3)**2 + btot = sqrt(b2tot) + + dbtot = (bv(1)*dbv(1,:) + bv(2)*dbv(2,:) + bv(3)*dbv(3,:))/btot + + yg = btot/Bres + +! convert spatial derivatives from dummy/m -> dummy/cm +! to be used in rhs + +! bv(i) = B_i / B ; derbv(i,j) = d (B_i / B) /d x,y,z + deryg = 1.0e-2_wp_*dbtot/Bres + bv = bv/btot + do jv=1,3 + derbv(:,jv) = 1.0e-2_wp_*(dbv(:,jv) - bv(:)*dbtot(jv))/btot + end do + + derxg(1) = 1.0e-2_wp_*drrdx*dpsidr*dxgdpsi + derxg(2) = 1.0e-2_wp_*drrdy*dpsidr*dxgdpsi + derxg(3) = 1.0e-2_wp_*dpsidz *dxgdpsi + +! current density computation in Ampere/m^2, ccj==1/mu_0 + ajphi = ccj*(dbvcdc(1,3) - dbvcdc(3,1)) +! ajr=ccj*(dbvcdc(3,2)/rrm-dbvcdc(2,3)) +! ajz=ccj*(bvc(2)/rrm+dbvcdc(2,1)-dbvcdc(1,2)) + + end subroutine plas_deriv + + + subroutine disp_deriv(anv,sox,xg,yg,derxg,deryg,bv,derbv,gr2,dgr2,dgr,ddgr, & + dery,anpl,anpr,ddr,ddi,dersdst,derdnm) + use const_and_precisions, only : wp_,zero,one,half,two + use gray_params, only : idst,igrad + implicit none +! arguments + real(wp_), intent(in) :: xg,yg,gr2,sox + real(wp_), intent(out) :: anpl,anpr,ddr,ddi,derdnm,dersdst + real(wp_), dimension(3), intent(in) :: anv,bv,derxg,deryg + real(wp_), dimension(3), intent(in) :: dgr2,dgr + real(wp_), dimension(3,3), intent(in) :: ddgr,derbv + real(wp_), dimension(6), intent(out) :: dery +! local variables + integer :: iv + real(wp_) :: yg2,anpl2,anpr2,del,dnl,duh,dan2sdnpl,an2,an2s + real(wp_) :: dan2sdxg,dan2sdyg,ddelnpl2,ddelnpl2x,ddelnpl2y,denom,derdel + real(wp_) :: derdom,dfdiadnpl,dfdiadxg,dfdiadyg,fdia,bdotgr !,vgm + real(wp_), dimension(3) :: derdxv,danpldxv,derdnv,dbgr !,vgv + + 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) + + anpl2 = anpl**2 + dnl = one - anpl2 + anpr2 = max(an2-anpl2,zero) + anpr = sqrt(anpr2) + yg2 = yg**2 + + an2s = one + dan2sdxg = zero + dan2sdyg = zero + dan2sdnpl = zero + del = zero + fdia = zero + dfdiadnpl = zero + dfdiadxg = zero + dfdiadyg = zero + + duh = one - xg - yg2 + if(xg > zero) then + del = sqrt(dnl**2 + 4.0_wp_*anpl2*(one - xg)/yg2) + an2s = one - xg - half*xg*yg2*(one + anpl2 + sox*del)/duh + + dan2sdxg = - half*yg2*(one - yg2)*(one + anpl2 + sox*del)/duh**2 & + + sox*xg*anpl2/(del*duh) - one + dan2sdyg = - xg*yg*(one - xg)*(one + anpl2 + sox*del)/duh**2 & + + two*sox*xg*(one - xg)*anpl2/(yg*del*duh) + dan2sdnpl = - xg*yg2*anpl/duh & + - sox*xg*anpl*(two*(one - xg) - yg2*dnl)/(del*duh) + + if(igrad > 0) then + ddelnpl2 = two*(two*(one - xg)*(one + 3.0_wp_*anpl2**2) & + - yg2*dnl**3)/yg2/del**3 + fdia = - xg*yg2*(one + half*sox*ddelnpl2)/duh + derdel = two*(one - xg)*anpl2*(one + 3.0_wp_*anpl2**2) & + - dnl**2*(one + 3.0_wp_*anpl2)*yg2 + derdel = 4.0_wp_*derdel/(yg*del)**5 + ddelnpl2y = two*(one - xg)*derdel + ddelnpl2x = yg*derdel + dfdiadnpl = 24.0_wp_*sox*xg*(one - xg)*anpl*(one - anpl2**2) & + /(yg2*del**5) + dfdiadxg = - yg2*(one - yg2)/duh**2 - sox*yg2*((one - yg2) & + *ddelnpl2 + xg*duh*ddelnpl2x)/(two*duh**2) + dfdiadyg = - two*yg*xg*(one - xg)/duh**2 & + - sox*xg*yg*(two*(one - xg)*ddelnpl2 & + + yg*duh*ddelnpl2y)/(two*duh**2) + end if + end if + + bdotgr = bv(1)*dgr(1) + bv(2)*dgr(2) + bv(3)*dgr(3) + do iv=1,3 + dbgr(iv) = dgr(1)*derbv(1,iv) + bv(1)*ddgr(1,iv) & + + dgr(2)*derbv(2,iv) + bv(2)*ddgr(2,iv) & + + dgr(3)*derbv(3,iv) + bv(3)*ddgr(3,iv) + danpldxv(iv) = anv(1)*derbv(1,iv) + anv(2)*derbv(2,iv) + anv(3)*derbv(3,iv) + end do + + derdxv = -(derxg*dan2sdxg + deryg*dan2sdyg + danpldxv*dan2sdnpl + & + igrad*dgr2) & + + fdia*bdotgr*dbgr + half*bdotgr**2 & + *(derxg*dfdiadxg + deryg*dfdiadyg + danpldxv*dfdiadnpl) + derdnv = two*anv + (half*bdotgr**2*dfdiadnpl - dan2sdnpl)*bv + + derdnm = sqrt(derdnv(1)**2 + derdnv(2)**2 + derdnv(3)**2) + + derdom = -two*an2 + two*xg*dan2sdxg + yg*dan2sdyg + anpl*dan2sdnpl & + + two*igrad*gr2 - bdotgr**2*(fdia + xg*dfdiadxg & + + half*yg*dfdiadyg & + + half*anpl*dfdiadnpl) + + if (idst == 0) then +! integration variable: s + denom = derdnm + else if (idst == 1) then +! integration variable: c*t + denom = -derdom + else +! integration variable: Sr + denom = anv(1)*derdnv(1) + anv(2)*derdnv(2) + anv(3)*derdnv(3) + end if + +! coefficient for integration in s +! ds/dst, where st is the integration variable + dersdst = derdnm/denom + +! rhs vector + dery(1:3) = derdnv(:)/denom + dery(4:6) = -derdxv(:)/denom + +! vgv : ~ group velocity +! vgm=0 +! do iv=1,3 +! vgv(iv)=-derdnv(iv)/derdom +! vgm=vgm+vgv(iv)**2 +! end do +! vgm=sqrt(vgm) + +! ddr : dispersion relation (real part) +! ddi : dispersion relation (imaginary part) + ddr = an2 - an2s - igrad*(gr2 - half*bdotgr**2*fdia) + ddi = derdnv(1)*dgr(1) + derdnv(2)*dgr(2) + derdnv(3)*dgr(3) + + end subroutine disp_deriv + + + subroutine alpha_effj(psinv,xg,yg,dens,tekev,zeff,ak0,bres,derdnm,anpl,anpr, & + sox,anprre,anprim,alpha,didp,nhmin,nhmax,iokhawa,ierr) + use const_and_precisions, only : wp_,zero,pi,mc2=>mc2_ + use gray_params, only : iwarm,ilarm,ieccd,imx + use equilibrium, only : sgnbphi + use dispersion, only : harmnumber, warmdisp + use eccd, only : setcdcoeff,eccdeff,fjch0,fjch,fjncl + use magsurf_data, only : fluxval + implicit none +! arguments + real(wp_),intent(in) ::psinv,ak0,bres + real(wp_),intent(in) :: xg,yg,tekev,dens,zeff,anpl,anpr,derdnm,sox + real(wp_),intent(out) :: anprre,anprim,alpha,didp + integer, intent(out) :: nhmin,nhmax,iokhawa + integer, intent(out) :: ierr +! local constants + real(wp_), parameter :: taucr=12.0_wp_,xxcr=16.0_wp_,eps=1.e-8_wp_ +! local variables + real(wp_) :: rbavi,rrii,rhop + integer :: lrm,ithn + real(wp_) :: amu,ratiovgr,rbn,rbx + real(wp_) :: cst2,bmxi,bmni,fci + real(wp_), dimension(:), allocatable :: eccdpar + real(wp_) :: effjcd,effjcdav,akim,btot + complex(wp_) :: ex,ey,ez + + alpha=zero + anprim=zero + anprre=zero + didp=zero + nhmin=0 + nhmax=0 + iokhawa=0 + ierr=0 + + if(tekev>zero) then +! absorption computation + amu=mc2/tekev + call harmnumber(yg,amu,anpl,nhmin,nhmax,iwarm) + if(nhmin.gt.0) then + lrm=max(ilarm,nhmax) + call warmdisp(xg,yg,amu,anpl,anpr,sox,lrm,ierr,anprre,anprim, & + iwarm,imx,ex,ey,ez) + akim=ak0*anprim + ratiovgr=2.0_wp_*anpr/derdnm!*vgm + alpha=2.0_wp_*akim*ratiovgr + if(alpha: effjcdav [A m/W ] + if(ieccd>0) then +! current drive computation + ithn=1 + if(lrm>nhmin) ithn=2 + rhop=sqrt(psinv) + call fluxval(rhop,rri=rrii,rbav=rbavi,bmn=bmni,bmx=bmxi,fc=fci) + btot=yg*bres + rbn=btot/bmni + rbx=btot/bmxi + + select case(ieccd) + case(1) +! cohen model + call setcdcoeff(zeff,rbn,rbx,cst2,eccdpar) + call eccdeff(yg,anpl,anprre,dens,amu,ex,ey,ez,nhmin,nhmax, & + ithn,cst2,fjch,eccdpar,effjcd,iokhawa,ierr) + case(2) +! no trapping + call setcdcoeff(zeff,cst2,eccdpar) + call eccdeff(yg,anpl,anprre,dens,amu,ex,ey,ez,nhmin,nhmax, & + ithn,cst2,fjch0,eccdpar,effjcd,iokhawa,ierr) + case default +! neoclassical model + call setcdcoeff(zeff,rbx,fci,amu,rhop,cst2,eccdpar) + call eccdeff(yg,anpl,anprre,dens,amu,ex,ey,ez,nhmin,nhmax, & + ithn,cst2,fjncl,eccdpar,effjcd,iokhawa,ierr) + end select + !deallocate(eccdpar) + effjcdav=rbavi*effjcd + didp=sgnbphi*effjcdav/(2.0_wp_*pi*rrii) + end if + end if + end if + end subroutine alpha_effj + + + + subroutine set_pol(ywrk0,bres,sox,psipol0,chipol0,ext0,eyt0) + use const_and_precisions, only : wp_,degree,zero,one,half,im + use beamdata, only : nray,nrayth + use equilibrium, only : bfield + use gray_params, only : ipol + use polarization, only : pol_limit, polellipse, stokes_ce, stokes_ell + implicit none +! arguments + real(wp_), dimension(6,nray), intent(in) :: ywrk0 + real(wp_), intent(in) :: sox,bres + real(wp_), intent(inout) :: psipol0, chipol0 + complex(wp_), dimension(nray), intent(out) :: ext0, eyt0 +! local variables + integer :: j,k,jk + real(wp_), dimension(3) :: xmv, anv, bv + real(wp_) :: rm, csphi, snphi, bphi, br, bz, qq, uu, vv, deltapol + + j=1 + k=0 + do jk=1,nray + k=k+1 + if(jk == 2 .or. k > nrayth) then + j=j+1 + k=1 + end if + + if(ipol == 0) then + xmv=ywrk0(1:3,jk)*0.01_wp_ ! convert from cm to m + anv=ywrk0(4:6,jk) + rm=sqrt(xmv(1)**2+xmv(2)**2) + csphi=xmv(1)/rm + snphi=xmv(2)/rm + call bfield(rm,xmv(3),bphi,br,bz) +! bv(i) = B_i in cartesian coordinates + bv(1)=br*csphi-bphi*snphi + bv(2)=br*snphi+bphi*csphi + bv(3)=bz + call pol_limit(anv,bv,bres,sox,ext0(jk),eyt0(jk)) + + if (jk == 1) then + call stokes_ce(ext0(jk),eyt0(jk),qq,uu,vv) + call polellipse(qq,uu,vv,psipol0,chipol0) + psipol0=psipol0/degree ! convert from rad to degree + chipol0=chipol0/degree + end if + else + call stokes_ell(chipol0*degree,psipol0*degree,qq,uu,vv) + if(qq**2 < one) then + deltapol=asin(vv/sqrt(one - qq**2)) + ext0(jk)= sqrt(half*(one + qq)) + eyt0(jk)= sqrt(half*(one - qq))*exp(-im*deltapol) + else + ext0(jk)= one + eyt0(jk)= zero + end if + endif + end do + end subroutine set_pol + + subroutine print_output(i,jk,st,qj,xv,psinv,btot,ak0,anpl,anpr,anprim, & + dens,tekev,alpha,tau,dids,nhf,iokhawa,index_rt,ddr,ddi) + use const_and_precisions, only : degree,zero,one + use equilibrium, only : frhotor + use gray_params, only : istpl0 + use beamdata, only : nray,nrayth + implicit none +! arguments + integer, intent(in) :: i,jk,nhf,iokhawa,index_rt + real(wp_), dimension(3), intent(in) :: xv + real(wp_), intent(in) :: st,qj,psinv,btot,ak0,anpl,anpr,anprim + real(wp_), intent(in) :: dens,tekev,alpha,tau,dids,ddr,ddi +! local variables + real(wp_) :: stm,xxm,yym,zzm,rrm,phideg,rhot,akim,pt,didsn + integer :: k + + stm=st*1.0e-2_wp_ + xxm=xv(1)*1.0e-2_wp_ + yym=xv(2)*1.0e-2_wp_ + zzm=xv(3)*1.0e-2_wp_ + rrm=sqrt(xxm**2 + yym**2) + +! central ray only begin +! print dIds in A/m/W, ki in m^-1 + if(jk.eq.1) then + phideg=atan2(yym,xxm)/degree + if(psinv>=zero .and. psinv<=one) then + rhot=frhotor(psinv) + else + rhot=1.0_wp_ + end if + akim=anprim*ak0*1.0e2_wp_ + pt=exp(-tau) + didsn=dids*1.0e2_wp_/qj + + write(4,'(30(1x,e16.8e3))') stm,rrm,zzm,phideg,psinv,rhot,dens,tekev, & + btot,anpr,anpl,akim,alpha,tau,pt,didsn,dble(nhf),dble(iokhawa), & + dble(index_rt),ddr + end if +! central ray only end + +! print conservation of dispersion relation + if(jk==nray) write(17,'(30(1x,e16.8e3))') st,ddr,ddi + +! print outer trajectories + if(mod(i,istpl0)==0) then + k = jk + nrayth - nray + if(k>0) then + write(33,'(2i5,16(1x,e16.8e3))') i,k,stm,xxm,yym,rrm,zzm, & + psinv,tau,anpl,alpha,dble(index_rt) + end if + end if + end subroutine print_output + +end module graycore diff --git a/src/grayl.f b/src/grayl.f deleted file mode 100644 index 0f0a9f6..0000000 --- a/src/grayl.f +++ /dev/null @@ -1,11681 +0,0 @@ - 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 - - subroutine dqagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, - * neval,ier,leniw,lenw,last,iwork,work) -c***begin prologue dqagp -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, 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 break points of the integration interval, where local -c difficulties of the integrand may occur (e.g. -c singularities, discontinuities), are provided by the user. -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 npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - double precision -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -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 -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 (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must 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 presumed that the requested -c tolerance cannot be achieved, and that -c the returned result is the best which -c 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.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c result, abserr, neval, last are set to -c zero. exept when leniw or lenw or npts2 is -c invalid, iwork(1), iwork(limit+1), -c work(limit*2+1) and work(limit*3+1) -c are set to zero. -c work(1) is set to a and work(limit+1) -c to b (where limit = (leniw-npts2)/2). -c -c dimensioning parameters -c leniw - integer -c dimensioning parameter for iwork -c leniw determines limit = (leniw-npts2)/2, -c which is the maximum number of subintervals in the -c partition of the given integration interval (a,b), -c leniw.ge.(3*npts2-2). -c if leniw.lt.(3*npts2-2), the routine will end with -c ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least leniw*2-npts2. -c if lenw.lt.leniw*2-npts2, 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 leniw. on return, -c the first k elements of which contain -c pointers to the error estimates over the -c subintervals, 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 iwork(limit+1), ...,iwork(limit+last) contain the -c subdivision levels of the subintervals, i.e. -c if (aa,bb) is a subinterval of (p1,p2) -c where p1 as well as p2 is a user-provided -c break point or integration limit, then (aa,bb) has -c level l if abs(bb-aa) = abs(p2-p1)*2**(-l), -c iwork(limit*2+1), ..., iwork(limit*2+npts2) have -c no significance for the user, -c note that limit = (leniw-npts2)/2. -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 corresponding error estimates, -c work(limit*4+1), ..., work(limit*4+npts2) -c contain the integration limits and the -c break points sorted in an ascending sequence. -c note that limit = (leniw-npts2)/2. -c -c***references (none) -c***routines called dqagpe,xerror -c***end prologue dqagp -c - double precision a,abserr,b,epsabs,epsrel,f,points,result,work - integer ier,iwork,last,leniw,lenw,limit,lvl,l1,l2,l3,l4,neval, - * npts2 -c - dimension iwork(leniw),points(npts2),work(lenw) -c - external f -c -c check validity of limit and lenw. -c -c***first executable statement dqagp - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(leniw.lt.(3*npts2-2).or.lenw.lt.(leniw*2-npts2).or.npts2.lt.2) - * go to 10 -c -c prepare call for dqagpe. -c - limit = (leniw-npts2)/2 - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 - l4 = limit+l3 -c - call dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, - * neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), - * iwork(1),iwork(l1),iwork(l2),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 dqaps',ier,lvl - return - end - - subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, - * abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin, - * last) -c***begin prologue dqagpe -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a2a1 -c***keywords automatic integrator, general-purpose, -c singularities at user specified points, -c extrapolation, 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), hopefully -c satisfying following claim for accuracy abs(i-result).le. -c max(epsabs,epsrel*abs(i)). break points of the integration -c interval, where local difficulties of the integrand may -c occur(e.g. singularities,discontinuities),provided by user. -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 npts2 - integer -c number equal to two more than the number of -c user-supplied break points within the integration -c range, npts2.ge.2. -c if npts2.lt.2, the routine will end with ier = 6. -c -c points - double precision -c vector of dimension npts2, the first (npts2-2) -c elements of which are the user provided break -c points. if these points do not constitute an -c ascending sequence there will be an automatic -c sorting. -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.npts2 -c if limit.lt.npts2, the routine will end with -c 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 -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 (i.e. singularity, -c discontinuity within the interval), it -c should be supplied to the routine as an -c element of the vector points. if necessary -c an appropriate special-purpose integrator -c must 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. 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.gt.0. -c = 6 the input is invalid because -c npts2.lt.2 or -c break points are specified outside -c the integration range or -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.npts2. -c result, abserr, neval, last, rlist(1), -c and elist(1) are set to zero. alist(1) and -c blist(1) are set to a and b 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 given -c 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 pts - double precision -c vector of dimension at least npts2, containing the -c integration limits and the break points of the -c interval in ascending sequence. -c -c level - integer -c vector of dimension at least limit, containing the -c subdivision levels of the subinterval, i.e. if -c (aa,bb) is a subinterval of (p1,p2) where p1 as -c well as p2 is a user-provided break point or -c integration limit, then (aa,bb) has level l if -c abs(bb-aa) = abs(p2-p1)*2**(-l). -c -c ndin - integer -c vector of dimension at least npts2, after first -c integration over the intervals (pts(i)),pts(i+1), -c i = 0,1, ..., npts2-2, the error estimates over -c some of the intervals may have been increased -c artificially, in order to put their subdivision -c forward. if this happens for the subinterval -c numbered k, ndin(k) is put to 1, otherwise -c ndin(k) = 0. -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 subdivisions process -c -c***references (none) -c***routines called d1mach,dqelg,dqk21,dqpsrt -c***end prologue dqagpe - double precision a,abseps,abserr,alist,area,area1,area12,area2,a1, - * a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,dmax1,dmin1, - * dres,d1mach,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd, - * errmax,error1,erro12,error2,errsum,ertest,f,oflow,points,pts, - * resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp,uflow - integer i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2,iroff3,j, - * jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr, - * ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2 - logical extrap,noext -c -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * level(limit),ndin(npts2),points(npts2),pts(npts2),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 epsalg (rlist2 should be of dimension -c (limexp+2) at least). -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 which -c 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 in rlist2. if an appropriate -c approximation to the compounded integral has -c been obtained, it is put in rlist2(numrl2) after -c numrl2 has been increased by one. -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 is -c 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 dqagpe - 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) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - level(1) = 0 - npts = npts2-2 - if(npts2.lt.2.or.limit.le.npts.or.(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 if any break points are provided, sort them into an -c ascending sequence. -c - sign = 1.0d+00 - if(a.gt.b) sign = -1.0d+00 - pts(1) = dmin1(a,b) - if(npts.eq.0) go to 15 - do 10 i = 1,npts - pts(i+1) = points(i) - 10 continue - 15 pts(npts+2) = dmax1(a,b) - nint = npts+1 - a1 = pts(1) - if(npts.eq.0) go to 40 - nintp1 = nint+1 - do 20 i = 1,nint - ip1 = i+1 - do 20 j = ip1,nintp1 - if(pts(i).le.pts(j)) go to 20 - temp = pts(i) - pts(i) = pts(j) - pts(j) = temp - 20 continue - if(pts(1).ne.dmin1(a,b).or.pts(nintp1).ne.dmax1(a,b)) ier = 6 - if(ier.eq.6) go to 999 -c -c compute first integral and error approximations. -c ------------------------------------------------ -c - 40 resabs = 0.0d+00 - do 50 i = 1,nint - b1 = pts(i+1) - call dqk21(f,a1,b1,area1,error1,defabs,resa) - abserr = abserr+error1 - result = result+area1 - ndin(i) = 0 - if(error1.eq.resa.and.error1.ne.0.0d+00) ndin(i) = 1 - resabs = resabs+defabs - level(i) = 0 - elist(i) = error1 - alist(i) = a1 - blist(i) = b1 - rlist(i) = area1 - iord(i) = i - a1 = b1 - 50 continue - errsum = 0.0d+00 - do 55 i = 1,nint - if(ndin(i).eq.1) elist(i) = abserr - errsum = errsum+elist(i) - 55 continue -c -c test on accuracy. -c - last = nint - neval = 21*nint - dres = dabs(result) - errbnd = dmax1(epsabs,epsrel*dres) - if(abserr.le.0.1d+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2 - if(nint.eq.1) go to 80 - do 70 i = 1,npts - jlow = i+1 - ind1 = iord(i) - do 60 j = jlow,nint - ind2 = iord(j) - if(elist(ind1).gt.elist(ind2)) go to 60 - ind1 = ind2 - k = j - 60 continue - if(ind1.eq.iord(i)) go to 70 - iord(k) = iord(i) - iord(i) = ind1 - 70 continue - if(limit.lt.npts2) ier = 1 - 80 if(ier.ne.0.or.abserr.le.errbnd) go to 210 -c -c initialization -c -------------- -c - rlist2(1) = result - maxerr = iord(1) - errmax = elist(maxerr) - area = result - nrmax = 1 - nres = 0 - numrl2 = 1 - ktmin = 0 - extrap = .false. - noext = .false. - erlarg = errsum - ertest = errbnd - levmax = 1 - iroff1 = 0 - iroff2 = 0 - iroff3 = 0 - ierro = 0 - uflow = d1mach(1) - oflow = d1mach(2) - abserr = oflow - ksgn = -1 - if(dres.ge.(0.1d+01-0.5d+02*epmach)*resabs) ksgn = 1 -c -c main do-loop -c ------------ -c - do 160 last = npts2,limit -c -c bisect the subinterval with the nrmax-th largest error -c estimate. -c - levcur = level(maxerr)+1 - 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,resa,defab1) - call dqk21(f,a2,b2,area2,error2,resa,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - neval = neval+42 - 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 95 - if(dabs(rlist(maxerr)-area12).gt.0.1d-04*dabs(area12) - * .or.erro12.lt.0.99d+00*errmax) go to 90 - if(extrap) iroff2 = iroff2+1 - if(.not.extrap) iroff1 = iroff1+1 - 90 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 - 95 level(maxerr) = levcur - level(last) = levcur - 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 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 100 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 110 - 100 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 - 110 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(errsum.le.errbnd) go to 190 -c ***jump out of do-loop - if(ier.ne.0) go to 170 - if(noext) go to 160 - erlarg = erlarg-erlast - if(levcur+1.le.levmax) erlarg = erlarg+erro12 - if(extrap) go to 120 -c -c test whether the interval to be bisected next is the -c smallest interval. -c - if(level(maxerr)+1.le.levmax) go to 160 - extrap = .true. - nrmax = 2 - 120 if(ierro.eq.3.or.erlarg.le.ertest) go to 140 -c -c the smallest interval has the largest error. -c before bisecting decrease the sum of the errors over -c the larger intervals (erlarg) and perform extrapolation. -c - id = nrmax - jupbnd = last - if(last.gt.(2+limit/2)) jupbnd = limit+3-last - do 130 k = id,jupbnd - maxerr = iord(nrmax) - errmax = elist(maxerr) -c ***jump out of do-loop - if(level(maxerr)+1.le.levmax) go to 160 - nrmax = nrmax+1 - 130 continue -c -c perform extrapolation. -c - 140 numrl2 = numrl2+1 - rlist2(numrl2) = area - if(numrl2.le.2) go to 155 - 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 150 - ktmin = 0 - abserr = abseps - result = reseps - correc = erlarg - ertest = dmax1(epsabs,epsrel*dabs(reseps)) -c ***jump out of do-loop - if(abserr.lt.ertest) go to 170 -c -c prepare bisection of the smallest interval. -c - 150 if(numrl2.eq.1) noext = .true. - if(ier.ge.5) go to 170 - 155 maxerr = iord(1) - errmax = elist(maxerr) - nrmax = 1 - extrap = .false. - levmax = levmax+1 - erlarg = errsum - 160 continue -c -c set the final result. -c --------------------- -c -c - 170 if(abserr.eq.oflow) go to 190 - if((ier+ierro).eq.0) go to 180 - 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 175 - if(abserr.gt.errsum)go to 190 - if(area.eq.0.0d+00) go to 210 - go to 180 - 175 if(abserr/dabs(result).gt.errsum/dabs(area))go to 190 -c -c test on divergence. -c - 180 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le. - * resabs*0.1d-01) go to 210 - if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03.or. - * errsum.gt.dabs(area)) ier = 6 - go to 210 -c -c compute global integral sum. -c - 190 result = 0.0d+00 - do 200 k = 1,last - result = result+rlist(k) - 200 continue - abserr = errsum - 210 if(ier.gt.2) ier = ier-1 - result = result*sign - 999 return - end diff --git a/src/green_func_p.f90 b/src/green_func_p.f90 deleted file mode 100644 index 2fb61ee..0000000 --- a/src/green_func_p.f90 +++ /dev/null @@ -1,437 +0,0 @@ -!######################################################################## - - 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 deleted file mode 100644 index a617670..0000000 --- a/src/itm_constants.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!> 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 deleted file mode 100644 index 8a16580..0000000 --- a/src/itm_types.f90 +++ /dev/null @@ -1,50 +0,0 @@ -!> 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 diff --git a/src/magsurf_data.f90 b/src/magsurf_data.f90 new file mode 100644 index 0000000..eaf80b5 --- /dev/null +++ b/src/magsurf_data.f90 @@ -0,0 +1,572 @@ +module magsurf_data + use const_and_precisions, only : wp_ + implicit none + + integer, save :: npsi, npoints !# sup mag, # punti per sup + integer, save :: njpt, nlmt + + real(wp_), save :: rarea + + real(wp_), dimension(:), allocatable, save :: psicon,pstab,rhot_eq, & + rhotqv,bav,varea,vcurrp,vajphiav,qqv,ffc,vratja,vratjb + real(wp_), dimension(:), allocatable, save :: rpstab + real(wp_), dimension(:), allocatable, save :: vvol,rri,rbav,bmxpsi,bmnpsi + real(wp_), dimension(:), allocatable, save :: tjp,tlm,ch,ch01 + + real(wp_), dimension(:,:), allocatable, save :: rcon,zcon + real(wp_), dimension(:,:), allocatable, save :: cdadrhot,cdvdrhot + + real(wp_), dimension(:,:), allocatable, save :: cvol,crri,crbav,cbmx,cbmn,carea,cfc + real(wp_), dimension(:,:), allocatable, save :: crhotq + real(wp_), dimension(:,:), allocatable, save :: cratja,cratjb,cratjpl + + +contains + + subroutine alloc_surf_anal(ierr) + implicit none + integer, intent(out) :: ierr + + if(npsi.le.0.or.npoints.le.0) then + ierr = -1 + return + end if + + call dealloc_surf_anal + allocate(psicon(npsi),rcon(npsi,npoints), & + zcon(npsi,npoints),stat=ierr) + if (ierr/=0) call dealloc_surf_anal + end subroutine alloc_surf_anal + + subroutine dealloc_surf_anal + implicit none + if(allocated(psicon)) deallocate(psicon) + if(allocated(rcon)) deallocate(rcon) + if(allocated(zcon)) deallocate(zcon) + end subroutine dealloc_surf_anal + + + subroutine alloc_surfvec(ierr) + implicit none + integer, intent(out) :: ierr + + if(npsi.le.0.or.npoints.le.0) then + ierr = -1 + return + end if + + call dealloc_surfvec + allocate(psicon(npsi),rcon(npsi,npoints),zcon(npsi,npoints),pstab(npsi), & + rhot_eq(npsi),rhotqv(npsi),bav(npsi),bmxpsi(npsi),bmnpsi(npsi),varea(npsi), & + vvol(npsi),vcurrp(npsi),vajphiav(npsi),qqv(npsi),ffc(npsi),vratja(npsi), & + vratjb(npsi),rpstab(npsi),rri(npsi),rbav(npsi),cdadrhot(npsi,4), & + cdvdrhot(npsi,4),cbmx(npsi,4),cbmn(npsi,4),crbav(npsi,4),cvol(npsi,4), & + crri(npsi,4),carea(npsi,4),cfc(npsi,4),crhotq(npsi,4),cratjpl(npsi,4), & + cratja(npsi,4),cratjb(npsi,4),stat=ierr) + if (ierr/=0) call dealloc_surf_anal + end subroutine alloc_surfvec + + subroutine dealloc_surfvec + implicit none + if(allocated(psicon)) deallocate(psicon) + if(allocated(rcon)) deallocate(rcon) + if(allocated(zcon)) deallocate(zcon) + if(allocated(pstab)) deallocate(pstab) + if(allocated(rhot_eq)) deallocate(rhot_eq) + if(allocated(rhotqv)) deallocate(rhotqv) + if(allocated(bav)) deallocate(bav) + if(allocated(bmxpsi)) deallocate(bmxpsi) + if(allocated(bmnpsi)) deallocate(bmnpsi) + if(allocated(varea)) deallocate(varea) + if(allocated(vvol)) deallocate(vvol) + if(allocated(vcurrp)) deallocate(vcurrp) + if(allocated(vajphiav)) deallocate(vajphiav) + if(allocated(qqv)) deallocate(qqv) + if(allocated(ffc)) deallocate(ffc) + if(allocated(vratja)) deallocate(vratja) + if(allocated(vratjb)) deallocate(vratjb) + if(allocated(rpstab)) deallocate(rpstab) + if(allocated(rri)) deallocate(rri) + if(allocated(rbav)) deallocate(rbav) + if(allocated(cdadrhot)) deallocate(cdadrhot) + if(allocated(cdvdrhot)) deallocate(cdvdrhot) + if(allocated(cbmx)) deallocate(cbmx) + if(allocated(cbmn)) deallocate(cbmn) + if(allocated(crbav)) deallocate(crbav) + if(allocated(cvol)) deallocate(cvol) + if(allocated(crri)) deallocate(crri) + if(allocated(carea)) deallocate(carea) + if(allocated(cfc)) deallocate(cfc) + if(allocated(crhotq)) deallocate(crhotq) + if(allocated(cratjpl)) deallocate(cratjpl) + if(allocated(cratja)) deallocate(cratja) + if(allocated(cratjb)) deallocate(cratjb) + end subroutine dealloc_surfvec + + + + subroutine contours_psi(h,rup,zup,rlw,zlw,rcn,zcn,ipr) + use const_and_precisions, only : wp_,pi + use equilibrium, only : psiant,psinop,nsr,nsz,cc=>cceq,tr,tz,kspl, & + points_tgo + use dierckx, only : profil,sproota + use reflections, only : rwallm + implicit none +! local constants + integer, parameter :: mest=4 +! arguments + integer, intent(in) :: ipr + real(wp_), intent(in) :: h + real(wp_), intent(inout) :: rup,zup,rlw,zlw + real(wp_), dimension(npoints), intent(out) :: rcn,zcn +! local variables + integer :: np,info,ic,ier,ii,iopt,m + real(wp_) :: ra,rb,za,zb,th,zc,val + real(wp_), dimension(mest) :: zeroc + real(wp_), dimension(nsr) :: czc + + np=(npoints-1)/2 + + 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(npoints)=rlw + zcn(npoints)=zlw + rcn(np+1)=rup + zcn(np+1)=zup + do ic=2,np + zc=zlw+(zup-zlw)*(1.0_wp_-cos(th*(ic-1)))/2.0_wp_ + 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*psiant+psinop + call sproota(val,tr,nsr,czc,zeroc,mest,m,ier) + if (zeroc(1).gt.rwallm) then + rcn(ic)=zeroc(1) + rcn(npoints+1-ic)=zeroc(2) + else + rcn(ic)=zeroc(2) + rcn(npoints+1-ic)=zeroc(3) + end if + zcn(ic)=zc + zcn(npoints+1-ic)=zc + end do + + if (ipr.gt.0) then + do ii=1,npoints + write(71,'(i6,12(1x,e12.5))') ii,h,rcn(ii),zcn(ii) + end do + write(71,*) + write(71,*) + end if + end subroutine contours_psi + + + + subroutine contours_psi_an(h,rcn,zcn,ipr) + use const_and_precisions, only : wp_,pi + use equilibrium, only : frhotor,aminor,rmaxis,zmaxis + implicit none +! arguments + integer :: ipr + real(wp_) :: h + real(wp_), dimension(npoints) :: rcn,zcn +! local variables + integer :: np,ic + real(wp_) :: rn,th + + np=(npoints-1)/2 + th=pi/dble(np) + rn=frhotor(sqrt(h)) + + do ic=1,npoints + zcn(ic)=zmaxis+aminor*rn*sin(th*(ic-1)) + rcn(ic)=rmaxis+aminor*rn*cos(th*(ic-1)) + + if (ipr.gt.0) write(71,'(i6,12(1x,e12.5))') ic,h,rcn(ic),zcn(ic) + end do + if (ipr.gt.0) write(71,*) + end subroutine contours_psi_an + + + + subroutine flux_average + use const_and_precisions, only : wp_,zero,one,pi,ccj=>mu0inv + use gray_params, only : iequil + use equilibrium, only : btrcen,btaxis,rmaxis,zmaxis,phitedge,zbsup,zbinf, & + equian,equinum_psi,bfield,frhotor,fq,tor_curr + use simplespline, only : difcs + use dierckx, only : regrid,coeff_parder + use utils, only : get_free_unit + implicit none +! local constants + integer, parameter :: nnintp=101,ncnt=100,nlam=101,ksp=3, & + njest=nnintp+ksp+1,nlest=nlam+ksp+1, & + lwrk=4*(nnintp+nlam)+11*(njest+nlest)+njest*nnintp+nlest+54, & + kwrk=nnintp+nlam+njest+nlest+3,lw01=nnintp*4+nlam*3+nnintp*nlam +! local variables + integer :: ier,ierr,l,jp,ipr,jpr,inc,inc1,iopt,njp,nlm,ninpr + integer, dimension(kwrk) :: iwrk + real(wp_) :: lam,dlam,anorm,b2av,dvdpsi,dadpsi,ratio_cdator, & + ratio_cdbtor,ratio_pltor,fc,height,r2iav,currp, & + area,volume,ajphiav,bbav,bmmx,bmmn,btot0,bpoloid0,rpsim0,dla,dlb, & + dlp,drc,ph,area2,rzp,rz,rpsim,zpsim,btot,bpoloid,dlph,ajphi0, & + shlam,srl,rl2,rl0,rl,dhlam,dhlam0,ccfh,s,ajphi, & + bphi,brr,bzz,riav,fp,psinjp,rhopjp,rhotjp,qq,rup,rlw,zup,zlw + real(wp_), dimension(nnintp) :: dadrhotv,dvdrhotv,vratjpl + real(wp_), dimension(2*ncnt) :: dlpv + real(wp_), dimension(2*ncnt+1) :: bv,bpv + real(wp_), dimension(nlam) :: alam,weights + real(wp_), dimension(nnintp,nlam) :: fhlam + real(wp_), dimension(nnintp*nlam) :: ffhlam,dffhlam + real(wp_), dimension(lwrk) :: wrk + real(wp_), dimension(:), allocatable :: rctemp,zctemp +! common/external functions/variables + real(wp_) :: fpolv,ddpsidrr,ddpsidzz + + npsi=nnintp + ninpr=(npsi-1)/10 + npoints = 2*ncnt+1 + + call alloc_surfvec(ierr) + if(allocated(tjp)) deallocate(tjp) + if(allocated(tlm)) deallocate(tlm) + if(allocated(ch)) deallocate(ch) + allocate(tjp(njest),tlm(nlest),ch((njest-4)*(nlest-4)), & + rctemp(npoints),zctemp(npoints),stat=ierr) + if (ierr.ne.0) return + +! computation of flux surface averaged quantities + + write(71,*)' #i psin R z' + + dlam=1.0_wp_/dble(nlam-1) + do l=1,nlam-1 + alam(l)=dble(l-1)*dlam + fhlam(1,l)=sqrt(1.0_wp_-alam(l)) + ffhlam(l)=fhlam(1,l) + dffhlam(l)=-0.5_wp_/sqrt(1.0_wp_-alam(l)) + weights(l)=1.0_wp_ + end do + weights(1)=0.5_wp_ + weights(nlam)=0.5_wp_ + alam(nlam)=1.0_wp_ + fhlam(1,nlam)=0.0_wp_ + ffhlam(nlam)=0.0_wp_ + dffhlam(nlam)=-99999.0_wp_ + + jp=1 + anorm=2.0_wp_*pi*rmaxis/abs(btaxis) + dvdpsi=2.0_wp_*pi*anorm + dadpsi=2.0_wp_*pi/abs(btaxis) + b2av=btaxis**2 + ratio_cdator=abs(btaxis/btrcen) + ratio_cdbtor=1.0_wp_ + ratio_pltor=1.0_wp_ + fc=1.0_wp_ + if(iequil < 2) then + call equian(rmaxis,zmaxis,ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz) + else + call equinum_psi(rmaxis,zmaxis,ddpsidrr=ddpsidrr,ddpsidzz=ddpsidzz) + end if + qq=btaxis/sqrt(ddpsidrr*ddpsidzz) + ajphiav=-ccj*(ddpsidrr+ddpsidzz)/rmaxis + + psicon(1)=0.0_wp_ + rcon(1,:)=rmaxis + zcon(1,:)=zmaxis + pstab(1)=0.0_wp_ + rpstab(1)=0.0_wp_ + vcurrp(1)=0.0_wp_ + vajphiav(1)=ajphiav + bmxpsi(1)=abs(btaxis) + bmnpsi(1)=abs(btaxis) + bav(1)=abs(btaxis) + rbav(1)=1.0_wp_ + rri(1)=rmaxis + varea(1)=0.0_wp_ + vvol(1)=0.0_wp_ + vratjpl(1)=ratio_pltor + vratja(1)=ratio_cdator + vratjb(1)=ratio_cdbtor + ffc(1)=fc + qqv(1)=qq + dadrhotv(1)=0.0_wp_ + dvdrhotv(1)=0.0_wp_ + + rup=rmaxis + rlw=rmaxis + zup=zmaxis+(zbsup-zmaxis)/10.0_wp_ + zlw=zmaxis-(zmaxis-zbinf)/10.0_wp_ + + do jp=2,npsi + height=dble(jp-1)/dble(npsi-1) + if(jp.eq.npsi) height=0.9999_wp_ + ipr=0 + jpr=mod(jp,ninpr) + if(jpr.eq.1) ipr=1 + rhopjp=height + psinjp=height*height + rhotjp=frhotor(rhopjp) + psicon(jp)=height + + if(iequil<2) then + call contours_psi_an(psinjp,rctemp,zctemp,ipr) + else + call contours_psi(psinjp,rup,zup,rlw,zlw,rctemp,zctemp,ipr) + end if + rcon(jp,:) = rctemp + zcon(jp,:) = zctemp + + r2iav=0.0_wp_ + anorm=0.0_wp_ + dadpsi=0.0_wp_ + currp=0.0_wp_ + b2av=0.0_wp_ + area=0.0_wp_ + volume=0.0_wp_ + ajphiav=0.0_wp_ + bbav=0.0_wp_ + bmmx=-1.0e+30_wp_ + bmmn=1.0e+30_wp_ + + call tor_curr(rctemp(1),zctemp(1),ajphi0) + call bfield(rctemp(1),zctemp(1),bphi,br=brr,bz=bzz) + fpolv=bphi*rctemp(1) + btot0=sqrt(bphi**2+brr**2+bzz**2) + bpoloid0=sqrt(brr**2+bzz**2) + bv(1)=btot0 + bpv(1)=bpoloid0 + rpsim0=rctemp(1) + + do inc=1,npoints-1 + inc1=inc+1 + dla=sqrt((rctemp(inc)-rmaxis)**2+(zctemp(inc)-zmaxis)**2) + dlb=sqrt((rctemp(inc1)-rmaxis)**2+(zctemp(inc1)-zmaxis)**2) + dlp=sqrt((rctemp(inc1)-rctemp(inc))**2+(zctemp(inc1)-zctemp(inc))**2) + drc=(rctemp(inc1)-rctemp(inc)) + +! compute length, area and volume defined by psi=psinjp=height^2 + ph=0.5_wp_*(dla+dlb+dlp) + area2=ph*(ph-dla)*(ph-dlb)*(ph-dlp) + area=area+sqrt(area2) + rzp=rctemp(inc1)*zctemp(inc1) + rz=rctemp(inc)*zctemp(inc) + volume=pi*(rzp+rz)*drc+volume + +! compute line integrals on the contour psi=psinjp=height^2 + rpsim=rctemp(inc1) + zpsim=zctemp(inc1) + call bfield(rpsim,zpsim,br=brr,bz=bzz) + call tor_curr(rpsim,zpsim,ajphi) + bphi=fpolv/rpsim + 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.5_wp_*dlp + anorm=anorm+dlph*(1.0_wp_/bpoloid+1.0_wp_/bpoloid0) + dadpsi=dadpsi+dlph*(1.0_wp_/(bpoloid*rpsim)+1.0_wp_/(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.0_wp_/(bpoloid*rpsim**2)+1.0_wp_/(bpoloid0*rpsim0**2)) + ajphiav=ajphiav+dlph*(ajphi0/(bpoloid0*rpsim0)+ajphi/(bpoloid*rpsim)) + + ajphi0=ajphi + rpsim0=rpsim + bpoloid0=bpoloid + btot0=btot + +! computation maximum/minimum B values on given flux surface + if(btot.le.bmmn) bmmn=btot + if(btot.ge.bmmx) bmmx=btot + end do + +! bav= [T] , b2av= [T^2] , rbav=/b_min +! anorm = int d l_p/B_p = dV/dpsi/(2pi) +! r2iav=<1/R^2> [m^-2] , +! riav=<1/R> [m^-1] = dA/dpsi/(dV/dpsi/(2pi)), +! rri = /(|R B_tor|<1/R^2>) , used to compute I_tor [m^-1] +! currp = plasma current within psi=const + + bbav=bbav/anorm + r2iav=r2iav/anorm + dvdpsi=2.0_wp_*pi*anorm + riav=dadpsi/anorm + b2av=b2av/anorm + vcurrp(jp)=ccj*currp + vajphiav(jp)=ajphiav/dadpsi + +! area == varea, volume == vvol +! flux surface minor radius == (area/pi)^1/2 +! ratio_cdator = Jcd_astra/J_phi Jcd_astra = /B0 +! ratio_cdbtor = Jcd_jintrac/J_phi Jcd_jintrac = / +! ratio_pltor = Jcd_||/J_phi Jcd_|| = + pstab(jp)=psinjp + rpstab(jp)=rhopjp + 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_cdbtor=abs(b2av*riav/(fpolv*r2iav*bbav)) + ratio_pltor=abs(bbav*riav/(fpolv*r2iav)) + vratjpl(jp)=ratio_pltor + vratja(jp)=ratio_cdator + vratjb(jp)=ratio_cdbtor + qq=abs(dvdpsi*fpolv*r2iav/(4.0_wp_*pi*pi)) + qqv(jp)=qq + dadrhotv(jp)=phitedge*frhotor(rhopjp)/fq(psinjp)*dadpsi/pi + dvdrhotv(jp)=phitedge*frhotor(rhopjp)/fq(psinjp)*dvdpsi/pi + +! computation of fraction of circulating/trapped fraction fc, ft +! and of function H(lambda,rhop) +! ffhlam = Bmn/Bmx/fc integral_lambda^1 dlam/ + fc=0.0_wp_ + shlam=0.0_wp_ + do l=nlam,1,-1 + lam=alam(l) + srl=0.0_wp_ + rl2=1.0_wp_-lam*bv(1)/bmmx + rl0=0.0_wp_ + if(rl2.gt.0) rl0=sqrt(rl2) + do inc=1,npoints-1 + rl2=1.0_wp_-lam*bv(inc+1)/bmmx + rl=0.0_wp_ + if(rl2.gt.0) rl=sqrt(rl2) + srl=srl+0.5_wp_*dlpv(inc)*(rl/bpv(inc+1)+rl0/bpv(inc)) + rl0=rl + end do + srl=srl/anorm + dhlam=0.5_wp_/srl + fc=fc+lam/srl*weights(l) + if(l.eq.nlam) then + fhlam(jp,l)=0.0_wp_ + ffhlam(nlam*(jp-1)+l)=0.0_wp_ + dffhlam(nlam*(jp-1)+l)=-dhlam + dhlam0=dhlam + else + shlam=shlam+0.5_wp_*(dhlam+dhlam0)*dlam + fhlam(jp,l)=shlam + dffhlam(nlam*(jp-1)+l)=-dhlam + dhlam0=dhlam + end if + end do + fc=0.75_wp_*b2av/bmmx**2*fc*dlam + ffc(jp)=fc + + ccfh=bmmn/bmmx/fc + do l=1,nlam + ffhlam(nlam*(jp-1)+l)=ccfh*fhlam(jp,l) + dffhlam(nlam*(jp-1)+l)=ccfh*dffhlam(nlam*(jp-1)+l) + end do + end do + + write(56,*)' #rhop rhot || |Bmx| |Bmn| Area Vol |I_pl| fc ratJa ratJb' + + do jp=1,npsi + if(jp.eq.npsi) then + rpstab(jp)=1.0_wp_ + pstab(jp)=1.0_wp_ + end if + rhotjp=frhotor(rpstab(jp)) + write(56,99) rpstab(jp),rhotjp,bav(jp),bmxpsi(jp),bmnpsi(jp), & + varea(jp),vvol(jp),vcurrp(jp),vajphiav(jp),ffc(jp), & + vratja(jp),vratjb(jp) + end do + +! spline coefficients of area,vol,rbav,rri,bmxpsi,bmnpsi,fc,dadrhot,dvdrhot,ratioJs +! used for computations of dP/dV and J_cd + iopt=0 + call difcs(rpstab,vvol,npsi,iopt,cvol,ier) + iopt=0 + call difcs(rpstab,rbav,npsi,iopt,crbav,ier) + iopt=0 + call difcs(rpstab,rri,npsi,iopt,crri,ier) + iopt=0 + call difcs(rpstab,bmxpsi,npsi,iopt,cbmx,ier) + iopt=0 + call difcs(rpstab,bmnpsi,npsi,iopt,cbmn,ier) + iopt=0 + call difcs(rpstab,vratja,npsi,iopt,cratja,ier) + iopt=0 + call difcs(rpstab,vratjb,npsi,iopt,cratjb,ier) + iopt=0 + call difcs(rpstab,vratjpl,npsi,iopt,cratjpl,ier) + iopt=0 + call difcs(rpstab,varea,npsi,iopt,carea,ier) + iopt=0 + call difcs(rpstab,ffc,npsi,iopt,cfc,ier) + iopt=0 + call difcs(rpstab,dadrhotv,npsi,iopt,cdadrhot,ier) + iopt=0 + call difcs(rpstab,dvdrhotv,npsi,iopt,cdvdrhot,ier) +! iopt=0 +! call difcs(rpstab,qqv,npsi,iopt,cqq,ier) + +! spline interpolation of H(lambda,rhop) and dH/dlambda + iopt=0 + s=0.0_wp_ + call regrid(iopt,npsi,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 + + 99 format(20(1x,e12.5)) + + end subroutine flux_average + + + + subroutine fluxval(rhop,area,vol,dervol,dadrhot,dvdrhot, & + rri,rbav,bmn,bmx,fc,ratja,ratjb,ratjpl) + use const_and_precisions, only : wp_ + use utils, only : locate + use simplespline, only :spli,splid + implicit none +! arguments + real(wp_), intent(in) :: rhop + real(wp_), intent(out), optional :: vol,area,rri,rbav,dervol,bmn,bmx,fc, & + ratja,ratjb,ratjpl,dadrhot,dvdrhot +! local variables + integer :: ip + real(wp_) :: drh + + call locate(rpstab,npsi,rhop,ip) + ip=min(max(1,ip),npsi-1) + drh=rhop-rpstab(ip) + + if (present(area)) area=spli(carea,npsi,ip,drh) + if (present(vol)) vol=spli(cvol,npsi,ip,drh) + + if (present(dervol)) dervol=splid(cvol,npsi,ip,drh) + if (present(dadrhot)) dadrhot=spli(cdadrhot,npsi,ip,drh) + if (present(dvdrhot)) dvdrhot=spli(cdvdrhot,npsi,ip,drh) + + if (present(rri)) rri=spli(crri,npsi,ip,drh) + if (present(rbav)) rbav=spli(crbav,npsi,ip,drh) + if (present(bmn)) bmn=spli(cbmn,npsi,ip,drh) + if (present(bmx)) bmx=spli(cbmx,npsi,ip,drh) + if (present(fc)) fc=spli(cfc,npsi,ip,drh) + + if (present(ratja)) ratja=spli(cratja,npsi,ip,drh) + if (present(ratjb)) ratjb=spli(cratjb,npsi,ip,drh) + if (present(ratjpl)) ratjpl=spli(cratjpl,npsi,ip,drh) + + end subroutine fluxval + +end module magsurf_data diff --git a/src/main.f90 b/src/main.f90 new file mode 100644 index 0000000..3eb97e9 --- /dev/null +++ b/src/main.f90 @@ -0,0 +1,133 @@ +program gray_main + use const_and_precisions, only : wp_,one + use graycore, only : gray + use gray_params, only : read_inputs,read_params, antctrl_type,eqparam_type, & + prfparam_type,outparam_type,rtrparam_type,hcdparam_type + use beams, only : read_beam0, read_beam1, read_beam2 + use equilibrium, only : read_equil_an,read_eqdsk,change_cocos,eq_scal, & + set_rhospl,setqphi_num,frhopolv + use coreprofiles, only : read_profiles_an,read_profiles,tene_scal + use reflections, only : range2rect + implicit none + type(antctrl_type) :: antp + type(eqparam_type) :: eqp + type(prfparam_type) :: prfp + type(outparam_type) :: outp + type(rtrparam_type) :: rtrp + type(hcdparam_type) :: hcdp + + real(wp_), dimension(:), allocatable :: psrad, terad, derad, zfc + real(wp_), dimension(:), allocatable :: rv, zv, psinr, fpol, qpsi + real(wp_), dimension(:), allocatable :: rbnd, zbnd, rlim, zlim + real(wp_), dimension(:,:), allocatable :: psin + real(wp_) :: psia, rvac, rax, zax + integer :: iox0 + real(wp_) :: p0mw, fghz, psipol0, chipol0 + real(wp_) :: alpha0, beta0, x0, y0, z0, w1, w2, ri1, ri2, phiw, phir + + real(wp_) :: pec,icd + + integer :: ierr + real(wp_), dimension(:), allocatable :: xrad, rhot, dpdv, jcd + real(wp_) :: rwallm, rmxm, r0m, z0m, dzmx + +! ======= read parameters BEGIN ======= + call read_inputs('graynew.data',antp,eqp,rwallm,prfp,outp) + call read_params('gray_params.data',rtrp,hcdp) +! ======= read parameters END ======= + +! ======= read input data BEGIN ======= +!------------ equilibrium ------------ + if(eqp%iequil<2) then + call read_equil_an(eqp%filenm, rv, zv, fpol, qpsi) +! psia sign set to give the correct sign to Iphi (COCOS=3: psia<0 for Iphi>0) + psia = sign(one,qpsi(2)*fpol(1)) + else + call read_eqdsk(eqp%filenm, rv,zv,psin, psia, psinr,fpol,qpsi, rvac, & + rax,zax, rbnd,zbnd, rlim,zlim, eqp%ipsinorm,eqp%idesc,eqp%ifreefmt) + call change_cocos(psia, fpol, qpsi, eqp%icocos, 3) + end if +! re-scale B/I and/or force signs. If sgn=0 on input, set to fpol/-psia signs on output + call eq_scal(psia, fpol, eqp%sgni, eqp%sgnb, eqp%factb) + qpsi(1) = sign(qpsi(1),qpsi(1)*qpsi(2)*psia*fpol(1)) + qpsi(2) = sign(qpsi(2),psia*fpol(1)) +!------------- profiles ------------- + if(prfp%iprof==0) then + call read_profiles_an(prfp%filenm, terad, derad, zfc) + else + call read_profiles(prfp%filenm, xrad, terad, derad, zfc) + allocate(psrad(size(xrad))) + if(prfp%irho==0) then + call setqphi_num(psinr,qpsi,psia,rhot) + call set_rhospl(sqrt(psinr),rhot) + psrad=frhopolv(xrad) + else if(prfp%irho == 1) then + psrad=xrad**2 + else + psrad=xrad + end if + deallocate(xrad) + end if +! re-scale input data + call tene_scal(terad,derad,prfp%factte,prfp%factne,eqp%factb,prfp%iscal, & + prfp%iprof) +!------------- antenna -------------- +! interpolate beam table if antctrl%ibeam>0 + select case (antp%ibeam) + case (2) +! to be completed: now 1st beamd always selected, iox read from table + call read_beam2(antp%filenm,1,antp%alpha,antp%beta,fghz,antp%iox,x0,y0,z0, & + w1,w2,ri1,ri2,phiw,phir) + case (1) + call read_beam1(antp%filenm,antp%alpha,antp%beta,fghz,x0,y0,z0, & + w1,w2,ri1,ri2,phiw,phir) + case default + call read_beam0(antp%filenm,fghz,x0,y0,z0,w1,w2,ri1,ri2,phiw,phir) + end select + alpha0=antp%alpha + beta0=antp%beta + p0mw=antp%power + psipol0=antp%psi + chipol0=antp%chi + iox0=antp%iox +!--------------- wall --------------- +! set simple limiter if not read from EQDSK +! need to clean up... + r0m=sqrt(x0**2+y0**2)*0.01_wp_ + dzmx=rtrp%dst*rtrp%nstep*0.01_wp_ + z0m=z0*0.01_wp_ + if (.not.allocated(rlim).or.rtrp%ipass<0) then + rtrp%ipass=abs(rtrp%ipass) + if(eqp%iequil<2) then + rmxm=(rv(1)+rv(2))*0.01_wp_ + else + rmxm=rv(size(rv)) + end if + call range2rect(rwallm,max(r0m,rmxm),z0m-dzmx,z0m+dzmx,rlim,zlim) + end if +! ======= read input data END ======= + +! ========================= MAIN SUBROUTINE CALL ========================= + allocate(dpdv(outp%nrho),jcd(outp%nrho)) + call gray(rv,zv,psin,psia,psinr,fpol,qpsi,rvac,rax,zax,rbnd,zbnd,eqp, & + psrad,terad,derad,zfc,prfp, rlim,zlim, & + p0mw,fghz,alpha0,beta0,(/x0,y0,z0/),w1,w2,ri1,ri2,phiw,phir,iox0, & + psipol0,chipol0, dpdv,jcd,pec,icd, outp,rtrp,hcdp,ierr) +! ======================================================================== + +! ======= control prints BEGIN ======= + if(ierr/=0) print*,' IERR = ', ierr + print*,' ' + print*,'Pabs (MW), Icd (kA) = ', pec,icd*1.0e3_wp_ +! ======= control prints END ======= + +! ======= free memory BEGIN ======= + if(allocated(psrad)) deallocate(psrad) + if(allocated(terad)) deallocate(terad, derad, zfc) + if(allocated(rv)) deallocate(rv, zv, fpol, qpsi) + if(allocated(psin)) deallocate(psin, psinr) + if(allocated(rbnd)) deallocate(rbnd,zbnd) + if(allocated(rlim)) deallocate(rlim,zlim) + if(allocated(dpdv)) deallocate(dpdv, jcd) +! ======= free memory END ====== +end program gray_main \ No newline at end of file diff --git a/src/math.f90 b/src/math.f90 new file mode 100644 index 0000000..4e4662e --- /dev/null +++ b/src/math.f90 @@ -0,0 +1,125 @@ +module math + + use const_and_precisions, only : wp_, zero, one + implicit none + +contains + + function catand(z) +!***begin prologue catan +!***purpose compute the complex arc tangent. +!***library slatec (fnlib) +!***category c4a +!***type complex (catan-c) +!***keywords arc tangent, elementary functions, fnlib, trigonometric +!***author fullerton, w., (lanl) +!***description +! +! catan(z) calculates the complex trigonometric arc tangent of z. +! the result is in units of radians, and the real part is in the first +! or fourth quadrant. +! +!***references (none) +!***routines called (none) +!***revision history (yymmdd) +! 770801 date written +! 890531 changed all specific intrinsics to generic. (wrb) +! 890531 revision date from version 3.2 +! 891214 prologue converted to version 4.0 format. (bab) +! 900315 calls to xerror changed to calls to xermsg. (thj) +! 900326 removed duplicate information from description section. +! (wrb) +!***end prologue catan + use const_and_precisions, only : comp_eps, pi2=>pihalf, czero, cunit + implicit none + complex(wp_) :: catand + complex(wp_), intent(in) :: z + complex(wp_) :: z2 + real(wp_) :: r,x,y,r2,xans,yans,twoi + integer :: i + logical, save :: first=.true. + integer, save :: nterms + real(wp_), save :: rmin, rmax, sqeps +!***first executable statement catan + if (first) then +! nterms = log(eps)/log(rbnd) where rbnd = 0.1 + nterms = int(-0.4343_wp_*log(0.5_wp_*comp_eps) + 1.0_wp_) + sqeps = sqrt(comp_eps) + rmin = sqrt (1.5_wp_*comp_eps) + rmax = 2.0_wp_/comp_eps + endif + first = .false. +! + r = abs(z) + if (r<=0.1_wp_) then +! + catand = z + if (r 0. + INTEGER :: j + real(wp_) :: ser,tmp,x,y + real(wp_), parameter :: stp=2.5066282746310005_wp_ + real(wp_), dimension(6), parameter :: cof=(/76.18009172947146_wp_, & + -86.50532032941677_wp_,24.01409824083091_wp_,-1.231739572450155_wp_, & + .1208650973866179e-2_wp_,-.5395239384953e-5_wp_/) + x=xx + y=x + tmp=x+5.5_wp_ + tmp=(x+0.5_wp_)*log(tmp)-tmp + ser=1.000000000190015_wp_ + do j=1,6 + y=y+1._wp_ + ser=ser+cof(j)/y + end do + gamm=exp(tmp)*(stp*ser/x) + end function gamm + +end module math \ No newline at end of file diff --git a/src/minpack.f90 b/src/minpack.f90 new file mode 100644 index 0000000..6229b34 --- /dev/null +++ b/src/minpack.f90 @@ -0,0 +1,1985 @@ +module minpack + + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + use const_and_precisions, only : zero, one + implicit none +! arguments + integer, intent(in) :: n, ldfjac, lwa + integer, intent(out) :: info + real(wp_), intent(in) :: tol + real(wp_), intent(out) :: wa(lwa) + real(wp_), intent(inout) :: fvec(n), fjac(ldfjac,n), x(n) +! ********** +! +! subroutine hybrj1 +! +! the purpose of hybrj1 is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. this is done by using the +! more general nonlinear equation solver hybrj. the user +! must provide a subroutine which calculates the functions +! and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj1. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! tol is a nonnegative input variable. termination occurs +! when the algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached 100*(n+1). +! +! info = 3 tol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress. +! +! wa is a work array of length lwa. +! +! lwa is a positive integer input variable not less than +! (n*(n+13))/2. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... hybrj +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: j, lr, maxfev, mode, nfev, njev, nprint + real(wp_) :: xtol +! parameters + real(wp_), parameter :: factor=1.0e2_wp_ + + interface + subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer, intent(in) :: n,ldfjac,iflag + real(wp_), intent(in) :: x(n) + real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface + + info = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. tol < zero & + .or. lwa < (n*(n + 13))/2) return +! +! call hybrj. +! + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do j = 1, n + wa(j) = one + end do + 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 == 5) info = 4 + end subroutine hybrj1 + + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, & + factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, & + wa3,wa4) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: n, ldfjac, maxfev, mode, nprint, lr + integer, intent(out) :: info, nfev, njev + real(wp_), intent(in) :: xtol, factor + real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), r(lr), qtf(n), & + wa1(n), wa2(n), wa3(n), wa4(n) + real(wp_), intent(inout) :: x(n), diag(n) +! ********** +! +! subroutine hybrj +! +! the purpose of hybrj is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. the user must provide a +! subroutine which calculates the functions and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +! mode,factor,nprint,info,nfev,njev,r,lr,qtf, +! wa1,wa2,wa3,wa4) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! xtol is a nonnegative input variable. termination +! occurs when the relative error between two consecutive +! iterates is at most xtol. +! +! maxfev is a positive integer input variable. termination +! occurs when the number of calls to fcn with iflag = 1 +! has reached maxfev. +! +! diag is an array of length n. if mode = 1 (see +! below), diag is internally set. if mode = 2, diag +! must contain positive entries that serve as +! multiplicative scale factors for the variables. +! +! mode is an integer input variable. if mode = 1, the +! variables will be scaled internally. if mode = 2, +! the scaling is specified by the input diag. other +! values of mode are equivalent to mode = 1. +! +! factor is a positive input variable used in determining the +! initial step bound. this bound is set to the product of +! factor and the euclidean norm of diag*x if nonzero, or else +! to factor itself. in most cases factor should lie in the +! interval (.1,100.). 100. is a generally recommended value. +! +! nprint is an integer input variable that enables controlled +! printing of iterates if it is positive. in this case, +! fcn is called with iflag = 0 at the beginning of the first +! iteration and every nprint iterations thereafter and +! immediately prior to return, with x and fvec available +! for printing. fvec and fjac should not be altered. +! if nprint is not positive, no special calls of fcn +! with iflag = 0 are made. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 relative error between two consecutive iterates +! is at most xtol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached maxfev. +! +! info = 3 xtol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress, as +! measured by the improvement from the last +! five jacobian evaluations. +! +! info = 5 iteration is not making good progress, as +! measured by the improvement from the last +! ten iterations. +! +! nfev is an integer output variable set to the number of +! calls to fcn with iflag = 1. +! +! njev is an integer output variable set to the number of +! calls to fcn with iflag = 2. +! +! r is an output array of length lr which contains the +! upper triangular matrix produced by the qr factorization +! of the final approximate jacobian, stored rowwise. +! +! lr is a positive integer input variable not less than +! (n*(n+1))/2. +! +! qtf is an output array of length n which contains +! the vector (q transpose)*fvec. +! +! wa1, wa2, wa3, and wa4 are work arrays of length n. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... dogleg,enorm, +! qform,qrfac,r1mpyq,r1updt +! +! fortran-supplied ... abs,dmax1,dmin1,mod +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, iflag, iter, j, jm1, l, ncfail, ncsuc, nslow1, nslow2 + integer, dimension(1) :: iwa + logical :: jeval, sing + real(wp_) :: actred, delta, fnorm, fnorm1, pnorm, prered, & + ratio, summ, temp, xnorm +! parameters + real(wp_), parameter :: p1 = 1.0e-1_wp_, p5 = 5.0e-1_wp_, & + p001 = 1.0e-3_wp_, p0001 = 1.0e-4_wp_ + + interface + subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer, intent(in) :: n,ldfjac,iflag + real(wp_), intent(in) :: x(n) + real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface +! + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. xtol < zero & + .or. maxfev <= 0 .or. factor <= zero & + .or. lr < (n*(n + 1))/2) go to 300 + if (mode == 2) then + do j = 1, n + if (diag(j) <= zero) go to 300 + end do + end if +! +! evaluate the function at the starting point +! and calculate its norm. +! + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag < 0) go to 300 + fnorm = enorm(n,fvec) +! +! initialize iteration counter and monitors. +! + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +! +! beginning of the outer loop. +! + do + jeval = .true. +! +! calculate the jacobian matrix. +! + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag < 0) go to 300 +! +! compute the qr factorization of the jacobian. +! + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +! +! on the first iteration and if mode is 1, scale according +! to the norms of the columns of the initial jacobian. +! + if (iter == 1) then + if (mode /= 2) then + do j = 1, n + diag(j) = wa2(j) + if (wa2(j) == zero) diag(j) = one + end do + end if +! +! on the first iteration, calculate the norm of the scaled x +! and initialize the step bound delta. +! + do j = 1, n + wa3(j) = diag(j)*x(j) + end do + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta == zero) delta = factor + end if +! +! form (q transpose)*fvec and store in qtf. +! + do i = 1, n + qtf(i) = fvec(i) + end do + do j = 1, n + if (fjac(j,j) /= zero) then + summ = zero + do i = j, n + summ = summ + fjac(i,j)*qtf(i) + end do + temp = -summ/fjac(j,j) + do i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + end do + end if + end do +! +! copy the triangular factor of the qr factorization into r. +! + sing = .false. + do j = 1, n + l = j + jm1 = j - 1 + do i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + end do + r(l) = wa1(j) + if (wa1(j) == zero) sing = .true. + end do +! +! accumulate the orthogonal factor in fjac. +! + call qform(n,n,fjac,ldfjac,wa1) +! +! rescale if necessary. +! + if (mode /= 2) then + do j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + end do + end if +! +! beginning of the inner loop. +! + do +! +! if requested, call fcn to enable printing of iterates. +! + if (nprint > 0) then + iflag = 0 + if (mod(iter-1,nprint) == 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag < 0) go to 300 + end if +! +! determine the direction p. +! + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +! +! store the direction p and x + p. calculate the norm of p. +! + do j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + end do + pnorm = enorm(n,wa3) +! +! on the first iteration, adjust the initial step bound. +! + if (iter == 1) delta = dmin1(delta,pnorm) +! +! evaluate the function at x + p and calculate its norm. +! + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag < 0) go to 300 + fnorm1 = enorm(n,wa4) +! +! compute the scaled actual reduction. +! + actred = -one + if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2 +! +! compute the scaled predicted reduction. +! + l = 1 + do i = 1, n + summ = zero + do j = i, n + summ = summ + r(l)*wa1(j) + l = l + 1 + end do + wa3(i) = qtf(i) + summ + end do + temp = enorm(n,wa3) + prered = zero + if (temp < fnorm) prered = one - (temp/fnorm)**2 +! +! compute the ratio of the actual to the predicted +! reduction. +! + ratio = zero + if (prered > zero) ratio = actred/prered +! +! update the step bound. +! + if (ratio < p1) then + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + else + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio >= p5 .or. ncsuc > 1) delta = dmax1(delta,pnorm/p5) + if (abs(ratio-one) <= p1) delta = pnorm/p5 + end if +! +! test for successful iteration. +! + if (ratio >= p0001) then +! +! successful iteration. update x, fvec, and their norms. +! + do j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + end do + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + end if +! +! determine the progress of the iteration. +! + nslow1 = nslow1 + 1 + if (actred >= p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred >= p1) nslow2 = 0 +! +! test for convergence. +! + if (delta <= xtol*xnorm .or. fnorm == zero) info = 1 + if (info /= 0) go to 300 +! +! tests for termination and stringent tolerances. +! + if (nfev >= maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) <= epsmch*xnorm) info = 3 + if (nslow2 == 5) info = 4 + if (nslow1 == 10) info = 5 + if (info /= 0) go to 300 +! +! criterion for recalculating jacobian. +! + if (ncfail == 2) exit +! +! calculate the rank one modification to the jacobian +! and update qtf if necessary. +! + do j = 1, n + summ = zero + do i = 1, n + summ = summ + fjac(i,j)*wa4(i) + end do + wa2(j) = (summ - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio >= p0001) qtf(j) = summ + end do +! +! compute the qr factorization of the updated jacobian. +! + 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) +! +! end of the inner loop. +! + jeval = .false. + end do +! +! end of the outer loop. +! + end do + 300 continue +! +! termination, either normal or user imposed. +! + if (iflag < 0) info = iflag + iflag = 0 + if (nprint > 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + end subroutine hybrj + + subroutine hybrj1mv(fcn,n,x,f0,fvec,fjac,ldfjac,tol,info,wa,lwa) + use const_and_precisions, only : zero, one + implicit none +! arguments + integer, intent(in) :: n, ldfjac, lwa + integer, intent(out) :: info + real(wp_), intent(in) :: tol,f0(n) + real(wp_), intent(out) :: wa(lwa) + real(wp_), intent(inout) :: fvec(n), fjac(ldfjac,n), x(n) +! ********** +! +! subroutine hybrj1mv +! +! the purpose of hybrj1mv is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. this is done by using the +! more general nonlinear equation solver hybrjmv. the user +! must provide a subroutine which calculates the functions +! and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj1mv(fcn,n,x,f0,fvec,fjac,ldfjac,tol,info,wa,lwa) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj1mv. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! tol is a nonnegative input variable. termination occurs +! when the algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 algorithm estimates that the relative error +! between x and the solution is at most tol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached 100*(n+1). +! +! info = 3 tol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress. +! +! wa is a work array of length lwa. +! +! lwa is a positive integer input variable not less than +! (n*(n+13))/2. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... hybrjmv +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: j, lr, maxfev, mode, nfev, njev, nprint + real(wp_) :: xtol +! parameters + real(wp_), parameter :: factor=1.0e2_wp_ + + interface + subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer, intent(in) :: n,ldfjac,iflag + real(wp_), intent(in) :: x(n),f0(n) + real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface + + info = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. tol < zero & + .or. lwa < (n*(n + 13))/2) return +! +! call hybrjmv. +! + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do j = 1, n + wa(j) = one + end do + nprint = 0 + lr = (n*(n + 1))/2 + call hybrjmv(fcn,n,x,f0,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 == 5) info = 4 + end subroutine hybrj1mv + + subroutine hybrjmv(fcn,n,x,f0,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, & + factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, & + wa3,wa4) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: n, ldfjac, maxfev, mode, nprint, lr + integer, intent(out) :: info, nfev, njev + real(wp_), intent(in) :: xtol, factor, f0(n) + real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), r(lr), qtf(n), & + wa1(n), wa2(n), wa3(n), wa4(n) + real(wp_), intent(inout) :: x(n), diag(n) +! ********** +! +! subroutine hybrj +! +! the purpose of hybrj is to find a zero of a system of +! n nonlinear functions in n variables by a modification +! of the powell hybrid method. the user must provide a +! subroutine which calculates the functions and the jacobian. +! +! the subroutine statement is +! +! subroutine hybrj(fcn,n,x,f0,fvec,fjac,ldfjac,xtol,maxfev,diag, +! mode,factor,nprint,info,nfev,njev,r,lr,qtf, +! wa1,wa2,wa3,wa4) +! +! where +! +! fcn is the name of the user-supplied subroutine which +! calculates the functions and the jacobian. fcn must +! be declared in an external statement in the user +! calling program, and should be written as follows. +! +! subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag) +! integer n,ldfjac,iflag +! real(8) x(n),f0(n),fvec(n),fjac(ldfjac,n) +! ---------- +! if iflag = 1 calculate the functions at x and +! return this vector in fvec. do not alter fjac. +! if iflag = 2 calculate the jacobian at x and +! return this matrix in fjac. do not alter fvec. +! --------- +! return +! end +! +! the value of iflag should not be changed by fcn unless +! the user wants to terminate execution of hybrj. +! in this case set iflag to a negative integer. +! +! n is a positive integer input variable set to the number +! of functions and variables. +! +! x is an array of length n. on input x must contain +! an initial estimate of the solution vector. on output x +! contains the final estimate of the solution vector. +! +! fvec is an output array of length n which contains +! the functions evaluated at the output x. +! +! fjac is an output n by n array which contains the +! orthogonal matrix q produced by the qr factorization +! of the final approximate jacobian. +! +! ldfjac is a positive integer input variable not less than n +! which specifies the leading dimension of the array fjac. +! +! xtol is a nonnegative input variable. termination +! occurs when the relative error between two consecutive +! iterates is at most xtol. +! +! maxfev is a positive integer input variable. termination +! occurs when the number of calls to fcn with iflag = 1 +! has reached maxfev. +! +! diag is an array of length n. if mode = 1 (see +! below), diag is internally set. if mode = 2, diag +! must contain positive entries that serve as +! multiplicative scale factors for the variables. +! +! mode is an integer input variable. if mode = 1, the +! variables will be scaled internally. if mode = 2, +! the scaling is specified by the input diag. other +! values of mode are equivalent to mode = 1. +! +! factor is a positive input variable used in determining the +! initial step bound. this bound is set to the product of +! factor and the euclidean norm of diag*x if nonzero, or else +! to factor itself. in most cases factor should lie in the +! interval (.1,100.). 100. is a generally recommended value. +! +! nprint is an integer input variable that enables controlled +! printing of iterates if it is positive. in this case, +! fcn is called with iflag = 0 at the beginning of the first +! iteration and every nprint iterations thereafter and +! immediately prior to return, with x and fvec available +! for printing. fvec and fjac should not be altered. +! if nprint is not positive, no special calls of fcn +! with iflag = 0 are made. +! +! info is an integer output variable. if the user has +! terminated execution, info is set to the (negative) +! value of iflag. see description of fcn. otherwise, +! info is set as follows. +! +! info = 0 improper input parameters. +! +! info = 1 relative error between two consecutive iterates +! is at most xtol. +! +! info = 2 number of calls to fcn with iflag = 1 has +! reached maxfev. +! +! info = 3 xtol is too small. no further improvement in +! the approximate solution x is possible. +! +! info = 4 iteration is not making good progress, as +! measured by the improvement from the last +! five jacobian evaluations. +! +! info = 5 iteration is not making good progress, as +! measured by the improvement from the last +! ten iterations. +! +! nfev is an integer output variable set to the number of +! calls to fcn with iflag = 1. +! +! njev is an integer output variable set to the number of +! calls to fcn with iflag = 2. +! +! r is an output array of length lr which contains the +! upper triangular matrix produced by the qr factorization +! of the final approximate jacobian, stored rowwise. +! +! lr is a positive integer input variable not less than +! (n*(n+1))/2. +! +! qtf is an output array of length n which contains +! the vector (q transpose)*fvec. +! +! wa1, wa2, wa3, and wa4 are work arrays of length n. +! +! subprograms called +! +! user-supplied ...... fcn +! +! minpack-supplied ... dogleg,enorm, +! qform,qrfac,r1mpyq,r1updt +! +! fortran-supplied ... abs,dmax1,dmin1,mod +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, iflag, iter, j, jm1, l, ncfail, ncsuc, nslow1, nslow2 + integer, dimension(1) :: iwa + logical :: jeval, sing + real(wp_) :: actred, delta, fnorm, fnorm1, pnorm, prered, & + ratio, summ, temp, xnorm +! parameters + real(wp_), parameter :: p1 = 1.0e-1_wp_, p5 = 5.0e-1_wp_, & + p001 = 1.0e-3_wp_, p0001 = 1.0e-4_wp_ + + interface + subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + use const_and_precisions, only : wp_ + implicit none + integer, intent(in) :: n,ldfjac,iflag + real(wp_), intent(in) :: x(n),f0(n) + real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n) + end subroutine fcn + end interface +! + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +! +! check the input parameters for errors. +! + if (n <= 0 .or. ldfjac < n .or. xtol < zero & + .or. maxfev <= 0 .or. factor <= zero & + .or. lr < (n*(n + 1))/2) go to 300 + if (mode == 2) then + do j = 1, n + if (diag(j) <= zero) go to 300 + end do + end if +! +! evaluate the function at the starting point +! and calculate its norm. +! + iflag = 1 + call fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag < 0) go to 300 + fnorm = enorm(n,fvec) +! +! initialize iteration counter and monitors. +! + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +! +! beginning of the outer loop. +! + do + jeval = .true. +! +! calculate the jacobian matrix. +! + iflag = 2 + call fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag < 0) go to 300 +! +! compute the qr factorization of the jacobian. +! + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +! +! on the first iteration and if mode is 1, scale according +! to the norms of the columns of the initial jacobian. +! + if (iter == 1) then + if (mode /= 2) then + do j = 1, n + diag(j) = wa2(j) + if (wa2(j) == zero) diag(j) = one + end do + end if +! +! on the first iteration, calculate the norm of the scaled x +! and initialize the step bound delta. +! + do j = 1, n + wa3(j) = diag(j)*x(j) + end do + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta == zero) delta = factor + end if +! +! form (q transpose)*fvec and store in qtf. +! + do i = 1, n + qtf(i) = fvec(i) + end do + do j = 1, n + if (fjac(j,j) /= zero) then + summ = zero + do i = j, n + summ = summ + fjac(i,j)*qtf(i) + end do + temp = -summ/fjac(j,j) + do i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + end do + end if + end do +! +! copy the triangular factor of the qr factorization into r. +! + sing = .false. + do j = 1, n + l = j + jm1 = j - 1 + do i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + end do + r(l) = wa1(j) + if (wa1(j) == zero) sing = .true. + end do +! +! accumulate the orthogonal factor in fjac. +! + call qform(n,n,fjac,ldfjac,wa1) +! +! rescale if necessary. +! + if (mode /= 2) then + do j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + end do + end if +! +! beginning of the inner loop. +! + do +! +! if requested, call fcn to enable printing of iterates. +! + if (nprint > 0) then + iflag = 0 + if (mod(iter-1,nprint) == 0) call fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + if (iflag < 0) go to 300 + end if +! +! determine the direction p. +! + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +! +! store the direction p and x + p. calculate the norm of p. +! + do j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + end do + pnorm = enorm(n,wa3) +! +! on the first iteration, adjust the initial step bound. +! + if (iter == 1) delta = dmin1(delta,pnorm) +! +! evaluate the function at x + p and calculate its norm. +! + iflag = 1 + call fcn(n,wa2,f0,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag < 0) go to 300 + fnorm1 = enorm(n,wa4) +! +! compute the scaled actual reduction. +! + actred = -one + if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2 +! +! compute the scaled predicted reduction. +! + l = 1 + do i = 1, n + summ = zero + do j = i, n + summ = summ + r(l)*wa1(j) + l = l + 1 + end do + wa3(i) = qtf(i) + summ + end do + temp = enorm(n,wa3) + prered = zero + if (temp < fnorm) prered = one - (temp/fnorm)**2 +! +! compute the ratio of the actual to the predicted +! reduction. +! + ratio = zero + if (prered > zero) ratio = actred/prered +! +! update the step bound. +! + if (ratio < p1) then + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + else + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio >= p5 .or. ncsuc > 1) delta = dmax1(delta,pnorm/p5) + if (abs(ratio-one) <= p1) delta = pnorm/p5 + end if +! +! test for successful iteration. +! + if (ratio >= p0001) then +! +! successful iteration. update x, fvec, and their norms. +! + do j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + end do + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + end if +! +! determine the progress of the iteration. +! + nslow1 = nslow1 + 1 + if (actred >= p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred >= p1) nslow2 = 0 +! +! test for convergence. +! + if (delta <= xtol*xnorm .or. fnorm == zero) info = 1 + if (info /= 0) go to 300 +! +! tests for termination and stringent tolerances. +! + if (nfev >= maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) <= epsmch*xnorm) info = 3 + if (nslow2 == 5) info = 4 + if (nslow1 == 10) info = 5 + if (info /= 0) go to 300 +! +! criterion for recalculating jacobian. +! + if (ncfail == 2) exit +! +! calculate the rank one modification to the jacobian +! and update qtf if necessary. +! + do j = 1, n + summ = zero + do i = 1, n + summ = summ + fjac(i,j)*wa4(i) + end do + wa2(j) = (summ - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio >= p0001) qtf(j) = summ + end do +! +! compute the qr factorization of the updated jacobian. +! + 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) +! +! end of the inner loop. +! + jeval = .false. + end do +! +! end of the outer loop. +! + end do + 300 continue +! +! termination, either normal or user imposed. +! + if (iflag < 0) info = iflag + iflag = 0 + if (nprint > 0) call fcn(n,x,f0,fvec,fjac,ldfjac,iflag) + end subroutine hybrjmv + + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: n, lr + real(wp_), intent(in) :: delta, r(lr), diag(n), qtb(n) + real(wp_), intent(out) :: x(n), wa1(n), wa2(n) +! ********** +! +! subroutine dogleg +! +! given an m by n matrix a, an n by n nonsingular diagonal +! matrix d, an m-vector b, and a positive number delta, the +! problem is to determine the convex combination x of the +! gauss-newton and scaled gradient directions that minimizes +! (a*x - b) in the least squares sense, subject to the +! restriction that the euclidean norm of d*x be at most delta. +! +! this subroutine completes the solution of the problem +! if it is provided with the necessary information from the +! qr factorization of a. that is, if a = q*r, where q has +! orthogonal columns and r is an upper triangular matrix, +! then dogleg expects the full upper triangle of r and +! the first n components of (q transpose)*b. +! +! the subroutine statement is +! +! subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +! +! where +! +! n is a positive integer input variable set to the order of r. +! +! r is an input array of length lr which must contain the upper +! triangular matrix r stored by rows. +! +! lr is a positive integer input variable not less than +! (n*(n+1))/2. +! +! diag is an input array of length n which must contain the +! diagonal elements of the matrix d. +! +! qtb is an input array of length n which must contain the first +! n elements of the vector (q transpose)*b. +! +! delta is a positive input variable which specifies an upper +! bound on the euclidean norm of d*x. +! +! x is an output array of length n which contains the desired +! convex combination of the gauss-newton direction and the +! scaled gradient direction. +! +! wa1 and wa2 are work arrays of length n. +! +! subprograms called +! +! minpack-supplied ... enorm +! +! fortran-supplied ... abs,dmax1,dmin1,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jj, jp1, k, l + real(wp_) :: alpha, bnorm, gnorm, qnorm, sgnorm, summ, temp +! +! first, calculate the gauss-newton direction. +! + jj = (n*(n + 1))/2 + 1 + do k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + summ = zero + do i = jp1, n + summ = summ + r(l)*x(i) + l = l + 1 + end do + temp = r(jj) + if (temp == zero) then + l = j + do i = 1, j + temp = dmax1(temp,abs(r(l))) + l = l + n - i + end do + temp = epsmch*temp + if (temp == zero) temp = epsmch + end if + x(j) = (qtb(j) - summ)/temp + end do +! +! test whether the gauss-newton direction is acceptable. +! + do j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + end do + qnorm = enorm(n,wa2) + if (qnorm <= delta) return +! +! the gauss-newton direction is not acceptable. +! next, calculate the scaled gradient direction. +! + l = 1 + do j = 1, n + temp = qtb(j) + do i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + end do + wa1(j) = wa1(j)/diag(j) + end do +! +! calculate the norm of the scaled gradient and test for +! the special case in which the scaled gradient is zero. +! + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm /= zero) then +! +! calculate the point along the scaled gradient +! at which the quadratic is minimized. +! + do j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + end do + l = 1 + do j = 1, n + summ = zero + do i = j, n + summ = summ + r(l)*wa1(i) + l = l + 1 + end do + wa2(j) = summ + end do + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +! +! test whether the scaled gradient direction is acceptable. +! + alpha = zero + if (sgnorm < delta) then +! +! the scaled gradient direction is not acceptable. +! finally, calculate the point along the dogleg +! at which the quadratic is minimized. +! + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 & + + sqrt((temp-(delta/qnorm))**2 & + +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + end if + end if +! +! form appropriate convex combination of the gauss-newton +! direction and the scaled gradient direction. +! + temp = (one - alpha)*dmin1(sgnorm,delta) + do j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + end do + end subroutine dogleg + + function enorm(n,x) + use const_and_precisions, only : zero, one + implicit none + real(wp_) :: enorm + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: x +! ********** +! +! function enorm +! +! given an n-vector x, this function calculates the +! euclidean norm of x. +! +! the euclidean norm is computed by accumulating the sum of +! squares in three different sums. the sums of squares for the +! small and large components are scaled so that no overflows +! occur. non-destructive underflows are permitted. underflows +! and overflows do not occur in the computation of the unscaled +! sum of squares for the intermediate components. +! the definitions of small, intermediate and large components +! depend on two constants, rdwarf and rgiant. the main +! restrictions on these constants are that rdwarf**2 not +! underflow and rgiant**2 not overflow. the constants +! given here are suitable for every known computer. +! +! the function statement is +! +! real(8) function enorm(n,x) +! +! where +! +! n is a positive integer input variable. +! +! x is an input array of length n. +! +! subprograms called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** + integer :: i + real(wp_) :: agiant,floatn,s1,s2,s3,xabs,x1max,x3max + real(wp_), parameter :: rdwarf=3.834e-20_wp_,rgiant=1.304e19_wp_ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do i = 1, n + xabs = abs(x(i)) + if (xabs <= rdwarf .or. xabs >= agiant) then + if (xabs > rdwarf) then +! +! sum for large components. +! + if (xabs > x1max) then + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + else + s1 = s1 + (xabs/x1max)**2 + end if + else +! +! sum for small components. +! + if (xabs > x3max) then + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + else + if (xabs /= zero) s3 = s3 + (xabs/x3max)**2 + end if + end if + else +! +! sum for intermediate components. +! + s2 = s2 + xabs**2 + end if + end do +! +! calculation of norm. +! + if (s1 /= zero) then + enorm = x1max*sqrt(s1+(s2/x1max)/x1max) + else + if (s2 /= zero) then + if (s2 >= x3max) enorm = sqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 < x3max) enorm = sqrt(x3max*((s2/x3max)+(x3max*s3))) + else + enorm = x3max*sqrt(s3) + end if + end if + end function enorm + + subroutine qform(m,n,q,ldq,wa) + use const_and_precisions, only : zero, one + implicit none +! arguments + integer, intent(in) :: m,n,ldq + real(wp_), intent(out) :: wa(m) + real(wp_), intent(inout) :: q(ldq,m) +! ********** +! +! subroutine qform +! +! this subroutine proceeds from the computed qr factorization of +! an m by n matrix a to accumulate the m by m orthogonal matrix +! q from its factored form. +! +! the subroutine statement is +! +! subroutine qform(m,n,q,ldq,wa) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a and the order of q. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! q is an m by m array. on input the full lower trapezoid in +! the first min(m,n) columns of q contains the factored form. +! on output q has been accumulated into a square matrix. +! +! ldq is a positive integer input variable not less than m +! which specifies the leading dimension of the array q. +! +! wa is a work array of length m. +! +! subprograms called +! +! fortran-supplied ... min0 +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jm1, k, l, minmn, np1 + real(wp_) :: summ, temp +! +! zero out upper triangle of q in the first min(m,n) columns. +! + minmn = min0(m,n) + do j = 2, minmn + jm1 = j - 1 + do i = 1, jm1 + q(i,j) = zero + end do + end do +! +! initialize remaining columns to those of the identity matrix. +! + np1 = n + 1 + do j = np1, m + do i = 1, m + q(i,j) = zero + end do + q(j,j) = one + end do +! +! accumulate q from its factored form. +! + do l = 1, minmn + k = minmn - l + 1 + do i = k, m + wa(i) = q(i,k) + q(i,k) = zero + end do + q(k,k) = one + if (wa(k) /= zero) then + do j = k, m + summ = zero + do i = k, m + summ = summ + q(i,j)*wa(i) + end do + temp = summ/wa(k) + do i = k, m + q(i,j) = q(i,j) - temp*wa(i) + end do + end do + end if + end do + end subroutine qform + + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + use const_and_precisions, only : zero, one, epsmch=>comp_eps + implicit none +! arguments + integer, intent(in) :: m, n, lda, lipvt + integer, intent(out) :: ipvt(lipvt) + logical, intent(in) :: pivot + real(wp_), intent(out) :: rdiag(n), acnorm(n), wa(n) + real(wp_), intent(inout) :: a(lda,n) +! ********** +! +! subroutine qrfac +! +! this subroutine uses householder transformations with column +! pivoting (optional) to compute a qr factorization of the +! m by n matrix a. that is, qrfac determines an orthogonal +! matrix q, a permutation matrix p, and an upper trapezoidal +! matrix r with diagonal elements of nonincreasing magnitude, +! such that a*p = q*r. the householder transformation for +! column k, k = 1,2,...,min(m,n), is of the form +! +! t +! i - (1/u(k))*u*u +! +! where u has zeros in the first k-1 positions. the form of +! this transformation and the method of pivoting first +! appeared in the corresponding linpack subroutine. +! +! the subroutine statement is +! +! subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! a is an m by n array. on input a contains the matrix for +! which the qr factorization is to be computed. on output +! the strict upper trapezoidal part of a contains the strict +! upper trapezoidal part of r, and the lower trapezoidal +! part of a contains a factored form of q (the non-trivial +! elements of the u vectors described above). +! +! lda is a positive integer input variable not less than m +! which specifies the leading dimension of the array a. +! +! pivot is a logical input variable. if pivot is set true, +! then column pivoting is enforced. if pivot is set false, +! then no column pivoting is done. +! +! ipvt is an integer output array of length lipvt. ipvt +! defines the permutation matrix p such that a*p = q*r. +! column j of p is column ipvt(j) of the identity matrix. +! if pivot is false, ipvt is not referenced. +! +! lipvt is a positive integer input variable. if pivot is false, +! then lipvt may be as small as 1. if pivot is true, then +! lipvt must be at least n. +! +! rdiag is an output array of length n which contains the +! diagonal elements of r. +! +! acnorm is an output array of length n which contains the +! norms of the corresponding columns of the input matrix a. +! if this information is not needed, then acnorm can coincide +! with rdiag. +! +! wa is a work array of length n. if pivot is false, then wa +! can coincide with rdiag. +! +! subprograms called +! +! minpack-supplied ... enorm +! +! fortran-supplied ... dmax1,sqrt,min0 +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, jp1, k, kmax, minmn + real(wp_) :: ajnorm, summ, temp +! parameters + real(wp_), parameter :: p05=5.0e-2_wp_ +! +! compute the initial column norms and initialize several arrays. +! + do j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + end do +! +! reduce a to r with householder transformations. +! + minmn = min0(m,n) + do j = 1, minmn + if (pivot) then +! +! bring the column of largest norm into the pivot position. +! + kmax = j + do k = j, n + if (rdiag(k) > rdiag(kmax)) kmax = k + end do + if (kmax /= j) then + do i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + end do + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + end if + end if +! +! compute the householder transformation to reduce the +! j-th column of a to a multiple of the j-th unit vector. +! + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm /= zero) then + if (a(j,j) < zero) ajnorm = -ajnorm + do i = j, m + a(i,j) = a(i,j)/ajnorm + end do + a(j,j) = a(j,j) + one +! +! apply the transformation to the remaining columns +! and update the norms. +! + jp1 = j + 1 + do k = jp1, n + summ = zero + do i = j, m + summ = summ + a(i,j)*a(i,k) + end do + temp = summ/a(j,j) + do i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + end do + if (pivot .and. rdiag(k) /= zero) then + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*sqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 <= epsmch) then + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + end if + end if + end do + end if + rdiag(j) = -ajnorm + end do + end subroutine qrfac + + subroutine r1mpyq(m,n,a,lda,v,w) + use const_and_precisions, only : one + implicit none +! arguments + integer, intent(in) :: m, n, lda + real(wp_), intent(in) :: v(n),w(n) + real(wp_), intent(inout) :: a(lda,n) +! ********** +! +! subroutine r1mpyq +! +! given an m by n matrix a, this subroutine computes a*q where +! q is the product of 2*(n - 1) transformations +! +! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +! +! and gv(i), gw(i) are givens rotations in the (i,n) plane which +! eliminate elements in the i-th and n-th planes, respectively. +! q itself is not given, rather the information to recover the +! gv, gw rotations is supplied. +! +! the subroutine statement is +! +! subroutine r1mpyq(m,n,a,lda,v,w) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of a. +! +! n is a positive integer input variable set to the number +! of columns of a. +! +! a is an m by n array. on input a must contain the matrix +! to be postmultiplied by the orthogonal matrix q +! described above. on output a*q has replaced a. +! +! lda is a positive integer input variable not less than m +! which specifies the leading dimension of the array a. +! +! v is an input array of length n. v(i) must contain the +! information necessary to recover the givens rotation gv(i) +! described above. +! +! w is an input array of length n. w(i) must contain the +! information necessary to recover the givens rotation gw(i) +! described above. +! +! subroutines called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more +! +! ********** +! local variables + integer :: i, j, nmj, nm1 + real(wp_) :: cs, sn, temp +! +! apply the first set of givens rotations to a. +! + nm1 = n - 1 + if (nm1 < 1) return + do nmj = 1, nm1 + j = n - nmj + if (abs(v(j)) > one) cs = one/v(j) + if (abs(v(j)) > one) sn = sqrt(one-cs**2) + if (abs(v(j)) <= one) sn = v(j) + if (abs(v(j)) <= one) cs = sqrt(one-sn**2) + do i = 1, m + temp = cs*a(i,j) - sn*a(i,n) + a(i,n) = sn*a(i,j) + cs*a(i,n) + a(i,j) = temp + end do + end do +! +! apply the second set of givens rotations to a. +! + do j = 1, nm1 + if (abs(w(j)) > one) cs = one/w(j) + if (abs(w(j)) > one) sn = sqrt(one-cs**2) + if (abs(w(j)) <= one) sn = w(j) + if (abs(w(j)) <= one) cs = sqrt(one-sn**2) + do i = 1, m + temp = cs*a(i,j) + sn*a(i,n) + a(i,n) = -sn*a(i,j) + cs*a(i,n) + a(i,j) = temp + end do + end do + end subroutine r1mpyq + + subroutine r1updt(m,n,s,ls,u,v,w,sing) + use const_and_precisions, only : zero, one, giant=>comp_huge + implicit none +! arguments + integer, intent(in) :: m, n, ls + logical, intent(out) :: sing + real(wp_), intent(in) :: u(m) + real(wp_), intent(out) :: w(m) + real(wp_), intent(inout) :: s(ls), v(n) +! ********** +! +! subroutine r1updt +! +! given an m by n lower trapezoidal matrix s, an m-vector u, +! and an n-vector v, the problem is to determine an +! orthogonal matrix q such that +! +! t +! (s + u*v )*q +! +! is again lower trapezoidal. +! +! this subroutine determines q as the product of 2*(n - 1) +! transformations +! +! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +! +! where gv(i), gw(i) are givens rotations in the (i,n) plane +! which eliminate elements in the i-th and n-th planes, +! respectively. q itself is not accumulated, rather the +! information to recover the gv, gw rotations is returned. +! +! the subroutine statement is +! +! subroutine r1updt(m,n,s,ls,u,v,w,sing) +! +! where +! +! m is a positive integer input variable set to the number +! of rows of s. +! +! n is a positive integer input variable set to the number +! of columns of s. n must not exceed m. +! +! s is an array of length ls. on input s must contain the lower +! trapezoidal matrix s stored by columns. on output s contains +! the lower trapezoidal matrix produced as described above. +! +! ls is a positive integer input variable not less than +! (n*(2*m-n+1))/2. +! +! u is an input array of length m which must contain the +! vector u. +! +! v is an array of length n. on input v must contain the vector +! v. on output v(i) contains the information necessary to +! recover the givens rotation gv(i) described above. +! +! w is an output array of length m. w(i) contains information +! necessary to recover the givens rotation gw(i) described +! above. +! +! sing is a logical output variable. sing is set true if any +! of the diagonal elements of the output s are zero. otherwise +! sing is set false. +! +! subprograms called +! +! fortran-supplied ... abs,sqrt +! +! argonne national laboratory. minpack project. march 1980. +! burton s. garbow, kenneth e. hillstrom, jorge j. more, +! john l. nazareth +! +! ********** +! local variables + integer :: i, j, jj, l, nmj, nm1 + real(wp_) :: cs, cotan, sn, tn, tau, temp +! parameters + real(wp_), parameter :: p5=5.0e-1_wp_, p25=2.5e-1_wp_ +! +! initialize the diagonal element pointer. +! + jj = (n*(2*m - n + 1))/2 - (m - n) +! +! move the nontrivial part of the last column of s into w. +! + l = jj + do i = n, m + w(i) = s(l) + l = l + 1 + end do +! +! rotate the vector v into a multiple of the n-th unit vector +! in such a way that a spike is introduced into w. +! + nm1 = n - 1 + do nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) /= zero) then +! +! determine a givens rotation which eliminates the +! j-th element of v. +! + if (abs(v(n)) < abs(v(j))) then + cotan = v(n)/v(j) + sn = p5/sqrt(p25+p25*cotan**2) + cs = sn*cotan + tau = one + if (abs(cs)*giant > one) tau = one/cs + else + tn = v(j)/v(n) + cs = p5/sqrt(p25+p25*tn**2) + sn = cs*tn + tau = sn + end if +! +! apply the transformation to v and store the information +! necessary to recover the givens rotation. +! + v(n) = sn*v(j) + cs*v(n) + v(j) = tau +! +! apply the transformation to s and extend the spike in w. +! + l = jj + do i = j, m + temp = cs*s(l) - sn*w(i) + w(i) = sn*s(l) + cs*w(i) + s(l) = temp + l = l + 1 + end do + end if + end do +! +! add the spike from the rank 1 update to w. +! + do i = 1, m + w(i) = w(i) + v(n)*u(i) + end do +! +! eliminate the spike. +! + sing = .false. + do j = 1, nm1 + if (w(j) /= zero) then +! +! determine a givens rotation which eliminates the +! j-th element of the spike. +! + if (abs(s(jj)) < abs(w(j))) then + cotan = s(jj)/w(j) + sn = p5/sqrt(p25+p25*cotan**2) + cs = sn*cotan + tau = one + if (abs(cs)*giant > one) tau = one/cs + else + tn = w(j)/s(jj) + cs = p5/sqrt(p25+p25*tn**2) + sn = cs*tn + tau = sn + end if +! +! apply the transformation to s and reduce the spike in w. +! + l = jj + do i = j, m + temp = cs*s(l) + sn*w(i) + w(i) = -sn*s(l) + cs*w(i) + s(l) = temp + l = l + 1 + end do +! +! store the information necessary to recover the +! givens rotation. +! + w(j) = tau + end if +! +! test for zero diagonal elements in the output s. +! + if (s(jj) == zero) sing = .true. + jj = jj + (m - j + 1) + end do +! +! move w back into the last column of the output s. +! + l = jj + do i = n, m + s(l) = w(i) + l = l + 1 + end do + if (s(jj) == zero) sing = .true. +! + end subroutine r1updt + +end module minpack \ No newline at end of file diff --git a/src/numint.f90 b/src/numint.f90 new file mode 100644 index 0000000..c8b2474 --- /dev/null +++ b/src/numint.f90 @@ -0,0 +1,257 @@ +module numint + + use const_and_precisions, only : wp_, zero, one + implicit none + +contains + + subroutine simpson (n,h,fi,s) +! subroutine for integration over f(x) with the simpson rule. fi: +! integrand f(x); h: interval; s: integral. copyright (c) tao pang 1997. + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: h + real(wp_), dimension(n), intent(in) :: fi + real(wp_), intent(out) :: s + integer :: i + real(wp_) :: s0,s1,s2 + + s = zero + s0 = zero + s1 = zero + s2 = zero + 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.0_wp_*s0+s2)/3.0_wp_ +! if n is even, add the last slice separately + if (mod(n,2).eq.0) s = s+h*(5.0_wp_*fi(n)+8.0_wp_*fi(n-1)-fi(n-2))/12.0_wp_ + end subroutine simpson + + subroutine trapezoid(n,xi,fi,s) +! subroutine for integration with the trapezoidal rule. +! fi: integrand f(x); xi: abscissa x; +! s: integral Int_{xi(1)}^{xi(n)} f(x)dx + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: xi,fi + real(wp_), intent(out) :: s + integer :: i + + s = zero + do i = 1, n-1 + s = s+(xi(i+1)-xi(i))*(fi(i+1)-fi(i)) + end do + s = 0.5_wp_*s + end subroutine trapezoid + + subroutine quanc8(fun,a,b,abserr,relerr,result,errest,nofun,flag) + implicit none + real(wp_), intent(in) :: a, b, abserr, relerr + real(wp_), intent(out) :: result, errest, flag + integer, intent(out) :: nofun +! +! estimate the integral of fun(x) from a to b +! to a user provided tolerance. +! an automatic adaptive routine based on +! the 8-panel newton-cotes rule. +! +! input .. +! +! fun the name of the integrand function subprogram fun(x). +! a the lower limit of integration. +! b the upper limit of integration.(b may be less than a.) +! relerr a relative error tolerance. (should be non-negative) +! abserr an absolute error tolerance. (should be non-negative) +! +! output .. +! +! result an approximation to the integral hopefully satisfying the +! least stringent of the two error tolerances. +! errest an estimate of the magnitude of the actual error. +! nofun the number of function values used in calculation of result. +! flag a reliability indicator. if flag is zero, then result +! probably satisfies the error tolerance. if flag is +! xxx.yyy , then xxx = the number of intervals which have +! not converged and 0.yyy = the fraction of the interval +! left to do when the limit on nofun was approached. +! + real(wp_) :: w0,w1,w2,w3,w4,area,x0,f0,stone,step,cor11,temp + real(wp_) :: qprev,qnow,qdiff,qleft,esterr,tolerr + real(wp_), dimension(31) :: qright + real(wp_), dimension(16) :: f,x + real(wp_), dimension(8,30) :: fsave,xsave + integer :: levmin,levmax,levout,nomax,nofin,lev,nim,i,j + + interface + function fun(x) + use const_and_precisions, only : wp_ + implicit none + real(wp_), intent(in) :: x + real(wp_) :: fun + end function fun + end interface +! +! *** stage 1 *** general initialization +! set constants. +! + levmin = 1 + levmax = 30 + levout = 6 + nomax = 5000 + nofin = nomax - 8*(levmax-levout+2**(levout+1)) +! +! trouble when nofun reaches nofin +! + w0 = 3956.0_wp_ / 14175.0_wp_ + w1 = 23552.0_wp_ / 14175.0_wp_ + w2 = -3712.0_wp_ / 14175.0_wp_ + w3 = 41984.0_wp_ / 14175.0_wp_ + w4 = -18160.0_wp_ / 14175.0_wp_ +! +! initialize running sums to zero. +! + flag = zero + result = zero + cor11 = zero + errest = zero + area = zero + nofun = 0 + if (a .eq. b) return +! +! *** stage 2 *** initialization for first interval +! + lev = 0 + nim = 1 + x0 = a + x(16) = b + qprev = zero + f0 = fun(x0) + stone = (b - a) / 16.0_wp_ + x(8) = (x0 + x(16)) / 2.0_wp_ + x(4) = (x0 + x(8)) / 2.0_wp_ + x(12) = (x(8) + x(16)) / 2.0_wp_ + x(2) = (x0 + x(4)) / 2.0_wp_ + x(6) = (x(4) + x(8)) / 2.0_wp_ + x(10) = (x(8) + x(12)) / 2.0_wp_ + x(14) = (x(12) + x(16)) / 2.0_wp_ + do j = 2, 16, 2 + f(j) = fun(x(j)) + end do + nofun = 9 +! +! *** stage 3 *** central calculation +! requires qprev,x0,x2,x4,...,x16,f0,f2,f4,...,f16. +! calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,qnow,qdiff,area. +! + do + do + x(1) = (x0 + x(2)) / 2.0_wp_ + f(1) = fun(x(1)) + do j = 3, 15, 2 + x(j) = (x(j-1) + x(j+1)) / 2.0_wp_ + f(j) = fun(x(j)) + end do + nofun = nofun + 8 + step = (x(16) - x0) / 16.0_wp_ + qleft = (w0*(f0 + f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) & + + 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)) & + + w3*(f(11)+f(13)) + w4*f(12)) * step + qnow = qleft + qright(lev+1) + qdiff = qnow - qprev + area = area + qdiff +! +! *** stage 4 *** interval convergence test +! + esterr = abs(qdiff) / 1023.0_wp_ + tolerr = max(abserr,relerr*abs(area)) * (step/stone) + if (lev .ge. levmin) then +! +! *** stage 6 *** trouble section +! number of function values is about to exceed limit. +! + if (lev .ge. levmax) then +! +! current level is levmax. +! + flag = flag + one + exit + end if + if (nofun .gt. nofin) then + nofin = 2*nofin + levmax = levout + flag = flag + (b - x0) / (b - a) + exit + end if + if (esterr .le. tolerr) exit + end if +! +! *** stage 5 *** no convergence +! locate next interval. +! + nim = 2*nim + lev = lev+1 +! +! store right hand elements for future use. +! + do i = 1, 8 + fsave(i,lev) = f(i+8) + xsave(i,lev) = x(i+8) + end do +! +! assemble left hand elements for immediate use. +! + qprev = qleft + do i = 1, 8 + j = -i + f(2*j+18) = f(j+9) + x(2*j+18) = x(j+9) + end do + end do +! +! *** stage 7 *** interval converged +! add contributions into running sums. +! + result = result + qnow + errest = errest + esterr + cor11 = cor11 + qdiff / 1023.0_wp_ +! +! locate next interval. +! + do + if (nim .eq. 2*(nim/2)) exit + nim = nim/2 + lev = lev-1 + end do + nim = nim + 1 + if (lev .le. 0) exit +! +! assemble elements required for the next interval. +! + qprev = qright(lev) + x0 = x(16) + f0 = f(16) + do i = 1, 8 + f(2*i) = fsave(i,lev) + x(2*i) = xsave(i,lev) + end do + end do +! +! *** stage 8 *** finalize and return +! + result = result + cor11 +! +! make sure errest not less than roundoff level. +! + if (errest .eq. zero) return + do + temp = abs(result) + errest + if (temp .ne. abs(result)) return + errest = 2.0_wp_*errest + end do + end subroutine quanc8 + +end module numint \ No newline at end of file diff --git a/src/pec.f90 b/src/pec.f90 new file mode 100644 index 0000000..61d3eb6 --- /dev/null +++ b/src/pec.f90 @@ -0,0 +1,387 @@ +module pec + use const_and_precisions, only : wp_,zero,one + implicit none + real(wp_), dimension(:), allocatable, save :: rhop_tab,rhot_tab + real(wp_), dimension(:), allocatable, save :: rtabpsi1 + real(wp_), dimension(:), allocatable, save :: dvol,darea + real(wp_), dimension(:), allocatable, save :: ratjav,ratjbv,ratjplv + +contains + + subroutine pec_init(ipec,rt_in) + use equilibrium, only : frhotor,frhopol + use gray_params, only : nnd + use magsurf_data, only : fluxval + implicit none +! arguments + integer, intent(in) :: ipec + real(wp_), dimension(nnd), intent(in), optional :: rt_in +! local variables + integer :: it + real(wp_) :: drt,rt,rt1,rhop1 + real(wp_) :: ratjai,ratjbi,ratjpli + real(wp_) :: voli0,voli1,areai0,areai1 + +! rt_in present: read input grid +! else: build equidistant grid dimension nnd + +! ipec=1 rho_pol grid +! ipec=2 rho_tor grid + call dealloc_pec + allocate(rhop_tab(nnd),rhot_tab(nnd),rtabpsi1(0:nnd),dvol(nnd),darea(nnd), & + ratjav(nnd),ratjbv(nnd),ratjplv(nnd)) + + voli0 = zero + areai0 = zero + rtabpsi1(0) = zero + + do it=1,nnd + if(present(rt_in)) then +! read radial grid from input + rt = rt_in(it) + if(it zero) facpds=pabs/spds + if(sccs /= zero) facjs=currt/sccs + + dpdv=facpds*(dpdv/dvol) + ajphiv=facjs*(ajphiv/darea) + ajcd=ajphiv*ratjbv + +! now dpdv is dP/dV [MW/m^3] +! now ajphiv is J_phi=dI/dA [MA/m^2] + end subroutine spec + + + + subroutine pec_tab(xxi,ypt,yamp,ii,xtab1,wdpdv,wajphiv) +! Power and current projected on psi grid - mid points + use const_and_precisions, only : wp_,one,zero + use gray_params, only : nnd + use utils, only : locatex,intlin +! arguments + integer, intent(in) :: ii + real(wp_), dimension(ii), intent(in) :: xxi,ypt,yamp + real(wp_), dimension(0:nnd), intent(in) :: xtab1 + real(wp_), dimension(nnd), intent(out) :: wdpdv,wajphiv +! local variables + integer, parameter :: llmx = 21 + integer, dimension(llmx) ::isev + real(wp_) :: ppa1,ppa2,cci1,cci2,dppa,didst,rt1 + integer :: i,is,ise0,idecr,iise0,iise,iis,iis1 + integer :: ind1,ind2,iind,ind,indi,itb1 + + isev = 0 + ise0 = 0 + idecr = -1 + is = 1 + wdpdv = zero + wajphiv = zero + do i=1,ii + if(ise0 == 0) then + if(xxi(i) < one) then + ise0 = i + isev(is) = i - 1 + is = is + 1 + end if + else + if (idecr == -1) then + if(xxi(i) > xxi(i-1)) then + isev(is) = i - 1 + is = is + 1 + idecr = 1 + end if + else + if(xxi(i) > one) exit + if(xxi(i) < xxi(i-1)) then + isev(is) = i - 1 + is = is + 1 + idecr = -1 + end if + end if + end if + end do + + isev(is) = i-1 + ppa1 = zero + cci1 = zero + + do iis=1,is-1 + iis1 = iis + 1 + iise0 = isev(iis) + iise = isev(iis1) + if (mod(iis,2) /= 0) then + idecr = -1 + ind1 = nnd + ind2 = 2 + iind = -1 + else + idecr = 1 + ind1 = 1 + ind2 = nnd + iind = 1 + end if + do ind=ind1,ind2,iind + indi = ind + if (idecr == -1) indi = ind - 1 + rt1 = xtab1(indi) + call locatex(xxi,iise,iise0,iise,rt1,itb1) + if(itb1 >= iise0 .and. itb1 < 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 + didst = cci2 - cci1 + wdpdv(ind) = wdpdv(ind) + dppa + wajphiv(ind) = wajphiv(ind) + didst + ppa1 = ppa2 + cci1 = cci2 + end if + end do + end do + end subroutine pec_tab + + + subroutine postproc_profiles(pabs,currt,rhot_tab,dpdv,ajphiv, & + rhotpav,drhotpav,rhotjava,drhotjava) +! radial average values over power and current density profile + use const_and_precisions, only : pi + use gray_params, only : nnd + use equilibrium, only : frhopol + use magsurf_data, only : fluxval + implicit none + real(wp_), intent(in) :: pabs,currt + real(wp_), dimension(nnd), intent(in) :: rhot_tab + real(wp_), dimension(nnd), intent(in) :: dpdv,ajphiv + real(wp_), intent(out) :: rhotpav,rhotjava + real(wp_), intent(out) :: drhotpav,drhotjava + real(wp_) :: rhopjava,rhoppav + real(wp_) :: dpdvp,dpdvmx,rhotp,drhotp + real(wp_) :: ajphip,ajmxfi,rhotjfi,drhotjfi + real(wp_) :: ratjamx,ratjbmx,ratjplmx + + real(wp_) :: sccsa + real(wp_) :: rhotjav,rhot2pav,rhot2java,dvdrhotav,dadrhotava + + rhotpav=zero + rhot2pav=zero + rhotjav=zero + rhotjava=zero + rhot2java=zero + + if (pabs > zero) then + rhotpav = sum(rhot_tab *dpdv*dvol)/pabs + rhot2pav = sum(rhot_tab**2*dpdv*dvol)/pabs + end if + + if (abs(currt) > zero) then + rhotjav = sum(rhot_tab*ajphiv*darea)/currt + end if + sccsa = sum(abs(ajphiv)*darea) + if (sccsa > zero) then + rhotjava = sum(rhot_tab *abs(ajphiv)*darea)/sccsa + rhot2java = sum(rhot_tab**2*abs(ajphiv)*darea)/sccsa + end if + +! factor sqrt(8) = 2sqrt(2) to match full width of gaussian profile + drhotpav = sqrt(8._wp_*(rhot2pav -rhotpav**2)) + drhotjava = sqrt(8._wp_*(rhot2java-rhotjava**2)) + + rhoppav = frhopol(rhotpav) + rhopjava = frhopol(rhotjava) + + if (pabs > zero) then + call fluxval(rhoppav,dvdrhot=dvdrhotav) + dpdvp = pabs*2.0_wp_/(sqrt(pi)*drhotpav*dvdrhotav) + call profwidth(nnd,rhot_tab,dpdv,rhotp,dpdvmx,drhotp) + else + dpdvp = zero + rhotp = zero + dpdvmx = zero + drhotp = zero + end if + + if (sccsa > zero) then + call fluxval(rhopjava,dadrhot=dadrhotava,ratja=ratjamx,ratjb=ratjbmx, & + ratjpl=ratjplmx) + ajphip = currt*2.0_wp_/(sqrt(pi)*drhotjava*dadrhotava) + call profwidth(nnd,rhot_tab,ajphiv,rhotjfi,ajmxfi,drhotjfi) + else + ajphip = zero + rhotjfi = zero + ajmxfi = zero + drhotjfi = zero + end if + end subroutine postproc_profiles + + + + subroutine profwidth(nd,xx,yy,xpk,ypk,dxxe) + use const_and_precisions, only : wp_,emn1 + use utils, only : locatex, locate, intlin, vmaxmini + implicit none +! arguments + integer :: nd + real(wp_), dimension(nd) :: xx,yy + real(wp_), intent(out) :: xpk,ypk,dxxe +! local variables + integer :: imn,imx,ipk,ie + real(wp_) :: xmn,xmx,ymn,ymx,xpkp,xpkm,yye,rte1,rte2 + real(wp_) :: ypkp,ypkm + + call vmaxmini(yy,nd,ymn,ymx,imn,imx) + ypk = zero + xmx = xx(imx) + xmn = xx(imn) + if (abs(ymx) > abs(ymn)) then + ipk = imx + ypkp = ymx + xpkp = xmx + if(abs(ymn/ymx) < 1.0e-2_wp_) ymn = 0.0_wp_ + ypkm = ymn + xpkm = xmn + else + ipk = imn + ypkp = ymn + xpkp = xmn + if(abs(ymx/ymn) < 1.0e-2_wp_) ymx = 0.0_wp_ + ypkm = ymx + xpkm = xmx + end if + if(xpkp > zero) then + xpk = xpkp + ypk = ypkp + yye = ypk*emn1 + call locatex(yy,nd,1,ipk,yye,ie) + if(ie > 0 .and. ie < nd) then + call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte1) + else + rte1 = zero + end if + call locatex(yy,nd,ipk,nd,yye,ie) + if(ie > 0 .and. ie < nd) then + call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte2) + else + rte2 = zero + end if + else + ipk=2 + xpk=xx(2) + ypk=yy(2) + rte1=0.0_wp_ + yye=ypk*emn1 + call locate(yy,nd,yye,ie) + if(ie > 0 .and. ie < nd) then + call intlin(yy(ie),xx(ie),yy(ie+1),xx(ie+1),yye,rte2) + else + rte2 = zero + end if + end if + dxxe = rte2 - rte1 + if(ymx /= zero .and. ymn /= zero) dxxe = -dxxe + end subroutine profwidth + + subroutine dealloc_pec + implicit none + + if (allocated(rhop_tab)) deallocate(rhop_tab) + if (allocated(rhot_tab)) deallocate(rhot_tab) + if (allocated(rtabpsi1)) deallocate(rtabpsi1) + if (allocated(dvol)) deallocate(dvol) + if (allocated(darea)) deallocate(darea) + if (allocated(ratjav)) deallocate(ratjav) + if (allocated(ratjbv)) deallocate(ratjbv) + if (allocated(ratjplv)) deallocate(ratjplv) + end subroutine dealloc_pec + +end module pec diff --git a/src/polarization.f90 b/src/polarization.f90 new file mode 100644 index 0000000..75c0390 --- /dev/null +++ b/src/polarization.f90 @@ -0,0 +1,152 @@ +module polarization + interface stokes + module procedure stokes_ce,stokes_ell + end interface + +contains + subroutine stokes_ce(ext,eyt,qq,uu,vv) + use const_and_precisions, only : wp_,two + implicit none +! arguments + complex(wp_), intent(in) :: ext,eyt + real(wp_), intent(out) :: qq,uu,vv + + qq = abs(ext)**2 - abs(eyt)**2 + uu = two* dble(ext*dconjg(eyt)) + vv = two*dimag(ext*dconjg(eyt)) + end subroutine stokes_ce + + + subroutine stokes_ell(chi,psi,qq,uu,vv) + use const_and_precisions, only : wp_,two + implicit none +! arguments + real(wp_), intent(in) :: chi,psi + real(wp_), intent(out) :: qq,uu,vv + + qq=cos(two*chi)*cos(two*psi) + uu=cos(two*chi)*sin(two*psi) + vv=sin(two*chi) + end subroutine stokes_ell + + + subroutine polellipse(qq,uu,vv,psi,chi) + use const_and_precisions, only : wp_,half + implicit none +! arguments + real(wp_), intent(in) :: qq,uu,vv + real(wp_), intent(out) :: psi,chi +! real(wp_) :: ll,aa,bb,ell + +! ll = sqrt(qq**2 + uu**2) +! aa = sqrt(half*(1 + ll)) +! bb = sqrt(half*(1 - ll)) +! ell = bb/aa + psi = half*atan2(uu,qq) + chi = half*asin(vv) + end subroutine polellipse + + subroutine pol_limit(anv,bv,bres,sox,ext,eyt) !,gam) + use const_and_precisions, only : wp_,ui=>im,pi,zero,one + implicit none +! arguments + real(wp_), dimension(3), intent(in) :: anv,bv + real(wp_), intent(in) :: bres,sox + complex(wp_), intent(out) :: ext,eyt +! real(wp_), optional, intent(out) :: gam +! local variables + real(wp_), dimension(3) :: bnv + real(wp_) :: anx,any,anz,an2,an,anpl2,anpl,anpr,anxy, & + btot,yg,den,dnl,del0,ff,ff2,sngam,csgam +! + btot = sqrt(bv(1)**2+bv(2)**2+bv(3)**2) + bnv = bv/btot + yg = btot/bres + + anx = anv(1) + any = anv(2) + anz = anv(3) + an2 = anx**2 + any**2 + anz**2 + an = sqrt(an2) + anxy = sqrt(anx**2 + any**2) + + anpl = (anv(1)*bnv(1) + anv(2)*bnv(2) + anv(3)*bnv(3)) + anpl2= anpl**2 + anpr = sqrt(an2 - anpl2) + + dnl = one - anpl2 + del0 = sqrt(dnl**2 + 4.0_wp_*anpl2/yg**2) + + sngam = (anz*anpl - an2*bnv(3))/(an*anxy*anpr) + csgam = -(any*bnv(1) - anx*bnv(2))/ (anxy*anpr) + + ff = 0.5_wp_*yg*(dnl - sox*del0) + ff2 = ff**2 + den = ff2 + anpl2 + if (den>zero) then + ext = (ff*csgam - ui*anpl*sngam)/sqrt(den) + eyt = (-ff*sngam - ui*anpl*csgam)/sqrt(den) + else ! only for XM (sox=+1) when N//=0 + ext = -ui*sngam + eyt = -ui*csgam + end if + +! gam = atan2(sngam,csgam)/degree + end subroutine pol_limit + + subroutine polarcold(anpl,anpr,xg,yg,sox,exf,eyif,ezf,elf,etf) + use const_and_precisions, only : wp_,zero,one + implicit none +! arguments + real(wp_), intent(in) :: anpl,anpr,xg,yg,sox + real(wp_), intent(out) :: exf,eyif,ezf,elf,etf +! local variables + real(wp_) :: anpl2,anpr2,an2,yg2,dy2,aa,e3,qq,p + + if(xg <= zero) then + exf = zero + if(sox < zero) then + ezf = one + eyif = zero + else + ezf = zero + eyif = one + end if + elf = zero + etf = one + else + anpl2 = anpl**2 + anpr2 = anpr**2 + an2 = anpl2 + anpr2 + + yg2=yg**2 + aa=1.0_wp_-xg-yg2 + + dy2 = one - yg2 + qq = xg*yg/(an2*dy2 - aa) + + if (anpl == zero) then + if(sox < zero) then + exf = zero + eyif = zero + ezf = one + else + qq = -aa/(xg*yg) + exf = one/sqrt(one + qq**2) + eyif = qq*exf + ezf = zero + end if + else + e3 = one - xg + p = (anpr2 - e3)/(anpl*anpr) ! undef for anpr==0 + exf = p*ezf + eyif = qq*exf + ezf = one/sqrt(one + p**2*(one + qq**2)) + end if + + elf = (anpl*ezf + anpr*exf)/sqrt(an2) + etf = sqrt(one - elf**2) + end if + end subroutine polarcold + +end module polarization diff --git a/src/quadpack.f90 b/src/quadpack.f90 new file mode 100644 index 0000000..3279453 --- /dev/null +++ b/src/quadpack.f90 @@ -0,0 +1,4541 @@ +module quadpack + + use const_and_precisions, only : wp_ + implicit none + +contains + + subroutine dqags(f,a,b,epsabs,epsrel,result,abserr,neval,ier, & + limit,lenw,last,iwork,work) +!***begin prologue dqags +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end-point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & prog. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account. however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be +! achieved, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagse. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 + end if + if(ier==6) lvl = 1 + if(ier/=0) print*,'habnormal return from dqags',ier,lvl + end subroutine dqags + + subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagse +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved, and that the +! returned result is the best which can be +! obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! epsabs<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: limit + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: neval,ier,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f +! + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,b1,b2,correc,abs, & + defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg (rlist2 should be of dimension +! (limexp+2) at least). +! +! list of major variables +! ----------------------- +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 containing +! the part of the epsilon table which is still +! needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left interval +! *****2 - variable for the right interval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine is +! attempting to perform extrapolation i.e. before +! subdividing the smallest interval we try to +! decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true value) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! +!***first executable statement dqagse +! +! test on validity of parameters +! ------------------------------ + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 140 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error +! estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(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) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call subroutine dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +! ***jump out of do-loop + if(errsum<=errbnd) go to 115 +! ***jump out of do-loop + if(ier/=0) exit + if(last==2) then + small = abs(b-a)*0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +! ***jump out of do-loop + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + end if + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum) go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence. +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + if(ier>2) ier = ier-1 + 140 continue + neval = 42*last-21 + end subroutine dqagse + + subroutine dqelg(n,epstab,result,abserr,res3la,nres) +!***begin prologue dqelg +!***refer to dqagie,dqagoe,dqagpe,dqagse +!***routines called (none) +!***revision date 830518 (yymmdd) +!***keywords epsilon algorithm, convergence acceleration, +! extrapolation +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math & progr. div. - k.u.leuven +!***purpose the routine determines the limit of a given sequence of +! approximations, by means of the epsilon algorithm of +! p.wynn. an estimate of the absolute error is also given. +! the condensed epsilon table is computed. only those +! elements needed for the computation of the next diagonal +! are preserved. +!***description +! +! epsilon algorithm +! standard fortran subroutine +! real(8) version +! +! parameters +! n - integer +! epstab(n) contains the new element in the +! first column of the epsilon table. +! +! epstab - real(8) +! vector of dimension 52 containing the elements +! of the two lower diagonals of the triangular +! epsilon table. the elements are numbered +! starting at the right-hand corner of the +! triangle. +! +! result - real(8) +! resulting approximation to the integral +! +! abserr - real(8) +! estimate of the absolute error computed from +! result and the 3 previous results +! +! res3la - real(8) +! vector of dimension 3 containing the last 3 +! results +! +! nres - integer +! number of calls to the routine +! (should be zero at first call) +! +!***end prologue dqelg +! + use const_and_precisions, only : epmach=>comp_eps, oflow=>comp_huge + implicit none + real(wp_), intent(out) :: abserr,result + real(wp_), dimension(52), intent(inout) :: epstab + real(wp_), dimension(3), intent(inout) :: res3la + integer, intent(inout) :: n,nres + real(wp_) :: abs,delta1,delta2,delta3,dmax1,epsinf,error, & + err1,err2,err3,e0,e1,e1abs,e2,e3,res,ss,tol1,tol2,tol3 + integer i,ib,ib2,ie,indx,k1,k2,k3,limexp,newelm,num +! +! list of major variables +! ----------------------- +! +! e0 - the 4 elements on which the computation of a new +! e1 element in the epsilon table is based +! e2 +! e3 e0 +! e3 e1 new +! e2 +! newelm - number of elements to be computed in the new +! diagonal +! error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) +! result - the element in the new diagonal with least value +! of error +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! oflow is the largest positive magnitude. +! limexp is the maximum number of elements the epsilon +! table can contain. if this number is reached, the upper +! diagonal of the epsilon table is deleted. +! +!***first executable statement dqelg + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n<3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + do i = 1,newelm + k2 = k1-1 + k3 = k1-2 + res = epstab(k1+2) + e0 = epstab(k3) + e1 = epstab(k2) + e2 = res + e1abs = abs(e1) + delta2 = e2-e1 + err2 = abs(delta2) + tol2 = dmax1(abs(e2),e1abs)*epmach + delta3 = e1-e0 + err3 = abs(delta3) + tol3 = dmax1(e1abs,abs(e0))*epmach + if(err2<=tol2.and.err3<=tol3) then +! +! if e0, e1 and e2 are equal to within machine +! accuracy, convergence is assumed. +! result = e2 +! abserr = abs(e1-e0)+abs(e2-e1) +! + result = res + abserr = err2+err3 +! ***jump out of do-loop + go to 100 + end if + e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = abs(delta1) + tol1 = dmax1(e1abs,abs(e3))*epmach +! +! if two elements are very close to each other, omit +! a part of the table by adjusting the value of n +! + if(err1<=tol1.or.err2<=tol2.or.err3<=tol3) go to 20 + ss = 0.1e+01_wp_/delta1+0.1e+01_wp_/delta2-0.1e+01_wp_/delta3 + epsinf = abs(ss*e1) +! +! test to detect irregular behaviour in the table, and +! eventually omit a part of the table adjusting the value +! of n. +! + if(epsinf>0.1e-03_wp_) go to 30 +! ***jump out of do-loop + 20 continue + n = i+i-1 + exit +! +! compute a new element and eventually adjust +! the value of result. +! + 30 continue + res = e1+0.1e+01_wp_/ss + epstab(k1) = res + k1 = k1-2 + error = err2+abs(res-e2)+err3 + if(error<=abserr) then + abserr = error + result = res + end if + end do +! +! shift the table. +! + if(n==limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2==num) ib = 2 + ie = newelm+1 + do i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + end do + if(num/=n) then + indx = num-n+1 + do i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + end do + end if + if(nres<4) then + res3la(nres) = result + abserr = oflow + else +! +! compute error estimate +! + abserr = abs(result-res3la(3))+abs(result-res3la(2)) & + +abs(result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result + end if + 100 continue + abserr = dmax1(abserr,0.5e+01_wp_*epmach*abs(result)) + end subroutine dqelg + + subroutine dqk21(f,a,b,result,abserr,resabs,resasc) +!***begin prologue dqk21 +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a2 +!***keywords 21-point gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +!***description +! +! integration rules +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! on return +! result - real(8) +! approximation to the integral i +! result is computed by applying the 21-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the 10-point gauss rule (resg). +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk21 +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,centr,abs,dhlgth,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh + real(wp_), dimension(10) :: fv1,fv2 + integer :: j,jtw,jtwm1 +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 21-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 10-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 10-point gauss rule +! +! wgk - weights of the 21-point kronrod rule +! +! wg - weights of the 10-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! + real(wp_), dimension(5), parameter :: & + wg = (/ 0.066671344308688137593568809893332_wp_, & + 0.149451349150580593145776339657697_wp_, & + 0.219086362515982043995534934228163_wp_, & + 0.269266719309996355091226921569469_wp_, & + 0.295524224714752870173892994651338_wp_ /) +! + real(wp_), dimension(11), parameter :: & + xgk = (/ 0.995657163025808080735527280689003_wp_, & + 0.973906528517171720077964012084452_wp_, & + 0.930157491355708226001207180059508_wp_, & + 0.865063366688984510732096688423493_wp_, & + 0.780817726586416897063717578345042_wp_, & + 0.679409568299024406234327365114874_wp_, & + 0.562757134668604683339000099272694_wp_, & + 0.433395394129247190799265943165784_wp_, & + 0.294392862701460198131126603103866_wp_, & + 0.148874338981631210884826001129720_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.011694638867371874278064396062192_wp_, & + 0.032558162307964727478818972459390_wp_, & + 0.054755896574351996031381300244580_wp_, & + 0.075039674810919952767043140916190_wp_, & + 0.093125454583697605535065465083366_wp_, & + 0.109387158802297641899210590325805_wp_, & + 0.123491976262065851077958109831074_wp_, & + 0.134709217311473325928054001771707_wp_, & + 0.142775938577060080797094273138717_wp_, & + 0.147739104901338491374841515972068_wp_, & + 0.149445554002916905664936468389821_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 10-point gauss formula +! resk - result of the 21-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! +!***first executable statement dqk21 + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + dhlgth = abs(hlgth) +! +! compute the 21-point kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0e+00_wp_ + fc = f(centr) + resk = wgk(11)*fc + resabs = abs(resk) + do 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)*(abs(fval1)+abs(fval2)) + end do + do 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)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5e+00_wp_ + resasc = wgk(11)*abs(fc-reskh) + do j=1,10 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs((resk-resg)*hlgth) + if(resasc/=0.0e+00_wp_.and.abserr/=0.0e+00_wp_) & + abserr = resasc*dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk21 + + subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) +!***begin prologue dqpsrt +!***refer to dqage,dqagie,dqagpe,dqawse +!***routines called (none) +!***revision date 810101 (yymmdd) +!***keywords sequential sorting +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose this routine maintains the descending ordering in the +! list of the local error estimated resulting from the +! interval subdivision process. at each call two error +! estimates are inserted using the sequential search +! method, top-down for the largest error estimate and +! bottom-up for the smallest error estimate. +!***description +! +! ordering routine +! standard fortran subroutine +! real(8) version +! +! parameters (meaning at output) +! limit - integer +! maximum number of error estimates the list +! can contain +! +! last - integer +! number of error estimates currently in the list +! +! maxerr - integer +! maxerr points to the nrmax-th largest error +! estimate currently in the list +! +! ermax - real(8) +! nrmax-th largest error estimate +! ermax = elist(maxerr) +! +! elist - real(8) +! vector of dimension last containing +! the error estimates +! +! iord - integer +! vector of dimension last, the first k elements +! of which contain pointers to the error +! estimates, such that +! elist(iord(1)),..., elist(iord(k)) +! form a decreasing sequence, with +! k = last if last<=(limit/2+2), and +! k = limit+1-last otherwise +! +! nrmax - integer +! maxerr = iord(nrmax) +! +!***end prologue dqpsrt +! + implicit none + integer, intent(in) :: last,limit + real(wp_), intent(out) :: ermax + integer, intent(inout) :: maxerr,nrmax + real(wp_), dimension(last), intent(inout) :: elist + integer, dimension(last), intent(inout) :: iord + real(wp_) :: errmax,errmin + integer :: i,ibeg,ido,isucc,j,jbnd,jupbn,k +! +! check whether the list contains more than +! two error estimates. +! +!***first executable statement dqpsrt + if(last<=2) then + iord(1) = 1 + iord(2) = 2 + go to 90 + end if +! +! this part of the routine is only executed if, due to a +! difficult integrand, subdivision increased the error +! estimate. in the normal case the insert procedure should +! start after the nrmax-th largest error estimate. +! + errmax = elist(maxerr) + if(nrmax/=1) then + ido = nrmax-1 + do i = 1,ido + isucc = iord(nrmax-1) +! ***jump out of do-loop + if(errmax<=elist(isucc)) exit + iord(nrmax) = isucc + nrmax = nrmax-1 + end do + end if +! +! compute the number of elements in the list to be maintained +! in descending order. this number depends on the number of +! subdivisions still allowed. +! + jupbn = last + if(last>(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) +! +! insert errmax by traversing the list top-down, +! starting comparison from the element elist(iord(nrmax+1)). +! + jbnd = jupbn-1 + ibeg = nrmax+1 + do i=ibeg,jbnd + isucc = iord(i) +! ***jump out of do-loop + if(errmax>=elist(isucc)) then +! +! insert errmin by traversing the list bottom-up. +! + iord(i-1) = maxerr + k = jbnd + do j=i,jbnd + isucc = iord(k) +! ***jump out of do-loop + if(errmin0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagie. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! + end if + if(ier/=0) print*,'habnormal return from dqagi' + end subroutine dqagi + + subroutine dqagie(f,bound,inf,epsabs,epsrel,limit,result,abserr, & + neval,ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagie +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math & progr. div - k.u.leuven +! de doncker,elise,appl. math & progr. div - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! integral i = integral of f over (bound,+infinity) +! or i = integral of f over (-infinity,bound) +! or i = integral of f over (-infinity,+infinity), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)) +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! f - real(8) +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - real(8) +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel=1 +! +! on return +! result - real(8) +! approximation to the integral +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier>0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however,if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. +! if the position of a local difficulty can +! be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + integer, intent(in) :: limit,inf + real(wp_), intent(in) :: bound,epsabs,epsrel + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: ier,neval,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,boun,b1,b2,correc, & + abs,defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg. +! +! +! list of major variables +! ----------------------- +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least (limexp+2), +! containing the part of the epsilon table +! wich is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained, it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine +! is attempting to perform extrapolation. i.e. +! before subdividing the smallest interval we +! try to decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true-value) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! +!***first executable statement dqagie +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = 0.0e+00_wp_ + blist(1) = 0.1e+01_wp_ + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + iord(1) = 0 + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 130 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(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) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at some points of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call subroutine dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum<=errbnd) go to 115 + if(ier/=0) exit + if(last==2) then + small = 0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum)go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + neval = 30*last-15 + if(inf==2) neval = 2*neval + if(ier>2) ier=ier-1 + end subroutine dqagie + + subroutine dqk15i(f,boun,inf,a,b,result,abserr,resabs,resasc) +!***begin prologue dqk15i +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a2,h2a4a2 +!***keywords 15-point transformed gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the original (infinite integration range is mapped +! onto the interval (0,1) and (a,b) is a part of (0,1). +! it is the purpose to compute +! i = integral of transformed integrand over (a,b), +! j = integral of abs(transformed integrand) over (a,b). +!***description +! +! integration rule +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! fuction subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! boun - real(8) +! finite bound of original integration +! range (set to zero if inf = +2) +! +! inf - integer +! if inf = -1, the original interval is +! (-infinity,bound), +! if inf = +1, the original interval is +! (bound,+infinity), +! if inf = +2, the original interval is +! (-infinity,+infinity) and +! the integral is computed as the sum of two +! integrals, one over (-infinity,0) and one over +! (0,+infinity). +! +! a - real(8) +! lower limit for integration over subrange +! of (0,1) +! +! b - real(8) +! upper limit for integration over subrange +! of (0,1) +! +! on return +! result - real(8) +! approximation to the integral i +! result is computed by applying the 15-point +! kronrod rule(resk) obtained by optimal addition +! of abscissae to the 7-point gauss rule(resg). +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of +! abs((transformed integrand)-i/(b-a)) over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk15i +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b,boun + integer, intent(in) :: inf + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,absc1,absc2,centr,abs,dinf,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh,tabsc1,tabsc2 + real(wp_), dimension(7) :: fv1,fv2 + integer :: j +! +! the abscissae and weights are supplied for the interval +! (-1,1). because of symmetry only the positive abscissae and +! their corresponding weights are given. +! +! xgk - abscissae of the 15-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 7-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 7-point gauss rule +! +! wgk - weights of the 15-point kronrod rule +! +! wg - weights of the 7-point gauss rule, corresponding +! to the abscissae xgk(2), xgk(4), ... +! wg(1), wg(3), ... are set to zero. +! + real(wp_), dimension(8), parameter :: & + wg = (/ 0.000000000000000000000000000000000_wp_, & + 0.129484966168869693270611432679082_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.279705391489276667901467771423780_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.381830050505118944950369775488975_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.417959183673469387755102040816327_wp_ /), & + xgk = (/ 0.991455371120812639206854697526329_wp_, & + 0.949107912342758524526189684047851_wp_, & + 0.864864423359769072789712788640926_wp_, & + 0.741531185599394439863864773280788_wp_, & + 0.586087235467691130294144838258730_wp_, & + 0.405845151377397166906606412076961_wp_, & + 0.207784955007898467600689403773245_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.022935322010529224963732008058970_wp_, & + 0.063092092629978553290700663189204_wp_, & + 0.104790010322250183839876322541518_wp_, & + 0.140653259715525918745189590510238_wp_, & + 0.169004726639267902826583426598550_wp_, & + 0.190350578064785409913256402421014_wp_, & + 0.204432940075298892414161999234649_wp_, & + 0.209482141084727828012999174891714_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc* - abscissa +! tabsc* - transformed abscissa +! fval* - function value +! resg - result of the 7-point gauss formula +! resk - result of the 15-point kronrod formula +! reskh - approximation to the mean value of the transformed +! integrand over (a,b), i.e. to i/(b-a) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! +!***first executable statement dqk15i + dinf = min0(1,inf) +! + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + tabsc1 = boun+dinf*(0.1e+01_wp_-centr)/centr + fval1 = f(tabsc1) + if(inf==2) fval1 = fval1+f(-tabsc1) + fc = (fval1/centr)/centr +! +! compute the 15-point kronrod approximation to +! the integral, and estimate the error. +! + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = abs(resk) + do j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1e+01_wp_-absc1)/absc1 + tabsc2 = boun+dinf*(0.1e+01_wp_-absc2)/absc2 + fval1 = f(tabsc1) + fval2 = f(tabsc2) + if(inf==2) fval1 = fval1+f(-tabsc1) + if(inf==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)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5e+00_wp_ + resasc = wgk(8)*abs(fc-reskh) + do j=1,7 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + end do + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = abs((resk-resg)*hlgth) + if(resasc/=0.0e+00_wp_.and.abserr/=0._wp_) abserr = resasc* & + dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk15i + + subroutine dqagp(f,a,b,npts2,points,epsabs,epsrel,result,abserr, & + neval,ier,leniw,lenw,last,iwork,work) +!***begin prologue dqagp +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a2a1 +!***keywords automatic integrator, general-purpose, +! singularities at user specified points, +! extrapolation, globally adaptive +!***author piessens,robert,appl. math. & progr. div - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! break points of the integration interval, where local +! difficulties of the integrand may occur (e.g. +! singularities, discontinuities), are provided by the user. +!***description +! +! computation of a definite integral +! standard fortran subroutine +! double precision version +! +! parameters +! on entry +! f - double precision +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - double precision +! lower limit of integration +! +! b - double precision +! upper limit of integration +! +! npts2 - integer +! number equal to two more than the number of +! user-supplied break points within the integration +! range, npts.ge.2. +! if npts2.lt.2, the routine will end with ier = 6. +! +! points - double precision +! vector of dimension npts2, the first (npts2-2) +! elements of which are the user provided break +! points. if these points do not constitute an +! ascending sequence there will be an automatic +! sorting. +! +! epsabs - double precision +! absolute accuracy requested +! epsrel - double precision +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! on return +! result - double precision +! approximation to the integral +! +! abserr - double precision +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (i.e. singularity, +! discontinuity within the interval), it +! should be supplied to the routine as an +! element of the vector points. if necessary +! an appropriate special-purpose integrator +! must be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved, and that +! the returned result is the best which +! can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier.gt.0. +! = 6 the input is invalid because +! npts2.lt.2 or +! break points are specified outside +! the integration range or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! result, abserr, neval, last are set to +! zero. exept when leniw or lenw or npts2 is +! invalid, iwork(1), iwork(limit+1), +! work(limit*2+1) and work(limit*3+1) +! are set to zero. +! work(1) is set to a and work(limit+1) +! to b (where limit = (leniw-npts2)/2). +! +! dimensioning parameters +! leniw - integer +! dimensioning parameter for iwork +! leniw determines limit = (leniw-npts2)/2, +! which is the maximum number of subintervals in the +! partition of the given integration interval (a,b), +! leniw.ge.(3*npts2-2). +! if leniw.lt.(3*npts2-2), the routine will end with +! ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least leniw*2-npts2. +! if lenw.lt.leniw*2-npts2, the routine will end +! with ier = 6. +! +! last - integer +! on return, last equals the number of subintervals +! produced in the subdivision process, which +! determines the number of significant elements +! actually in the work arrays. +! +! work arrays +! iwork - integer +! vector of dimension at least leniw. on return, +! the first k elements of which contain +! pointers to the error estimates over the +! subintervals, such that work(limit*3+iwork(1)),..., +! work(limit*3+iwork(k)) form a decreasing +! sequence, with k = last if last.le.(limit/2+2), and +! k = limit+1-last otherwise +! iwork(limit+1), ...,iwork(limit+last) contain the +! subdivision levels of the subintervals, i.e. +! if (aa,bb) is a subinterval of (p1,p2) +! where p1 as well as p2 is a user-provided +! break point or integration limit, then (aa,bb) has +! level l if abs(bb-aa) = abs(p2-p1)*2**(-l), +! iwork(limit*2+1), ..., iwork(limit*2+npts2) have +! no significance for the user, +! note that limit = (leniw-npts2)/2. +! +! work - double precision +! vector of dimension at least lenw +! on return +! work(1), ..., work(last) contain the left +! end points of the subintervals in the +! partition of (a,b), +! work(limit+1), ..., work(limit+last) contain +! the right end points, +! work(limit*2+1), ..., work(limit*2+last) contain +! the integral approximations over the subintervals, +! work(limit*3+1), ..., work(limit*3+last) +! contain the corresponding error estimates, +! work(limit*4+1), ..., work(limit*4+npts2) +! contain the integration limits and the +! break points sorted in an ascending sequence. +! note that limit = (leniw-npts2)/2. +! +!***references (none) +!***routines called dqagpe,xerror +!***end prologue dqagp +! + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: npts2,lenw,leniw + real(wp_), intent(in), dimension(npts2) ::points + real(wp_), intent(out) :: abserr,result + integer, intent(out) :: neval,ier,last + integer :: limit,lvl,l1,l2,l3,l4 +! + real(wp_), dimension(lenw) :: work + integer, dimension(leniw) :: iwork +! + real(wp_), external :: f +! +! check validity of limit and lenw. +! +!***first executable statement dqagp + ier = 6 + neval = 0 + last = 0 + result = 0.0_wp_ + abserr = 0.0_wp_ + if(leniw.ge.(3*npts2-2).and.lenw.ge.(leniw*2-npts2).and.npts2.ge.2) then +! +! prepare call for dqagpe. +! + limit = (leniw-npts2)/2 + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + l4 = limit+l3 +! + call dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),work(l4), & + iwork(1),iwork(l1),iwork(l2),last) +! +! call error handler if necessary. +! + lvl = 0 + end if + if(ier.eq.6) lvl = 1 + if(ier.ne.0) print*,'habnormal return from dqaps',ier,lvl + end subroutine dqagp + + subroutine dqagpe(f,a,b,npts2,points,epsabs,epsrel,limit,result, & + abserr,neval,ier,alist,blist,rlist,elist,pts,iord,level,ndin,last) +!***begin prologue dqagpe +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a2a1 +!***keywords automatic integrator, general-purpose, +! singularities at user specified points, +! extrapolation, globally adaptive. +!***author piessens,robert ,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), hopefully +! satisfying following claim for accuracy abs(i-result).le. +! max(epsabs,epsrel*abs(i)). break points of the integration +! interval, where local difficulties of the integrand may +! occur(e.g. singularities,discontinuities),provided by user. +!***description +! +! computation of a definite integral +! standard fortran subroutine +! double precision version +! +! parameters +! on entry +! f - double precision +! function subprogram defining the integrand +! function f(x). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - double precision +! lower limit of integration +! +! b - double precision +! upper limit of integration +! +! npts2 - integer +! number equal to two more than the number of +! user-supplied break points within the integration +! range, npts2.ge.2. +! if npts2.lt.2, the routine will end with ier = 6. +! +! points - double precision +! vector of dimension npts2, the first (npts2-2) +! elements of which are the user provided break +! points. if these points do not constitute an +! ascending sequence there will be an automatic +! sorting. +! +! epsabs - double precision +! absolute accuracy requested +! epsrel - double precision +! relative accuracy requested +! if epsabs.le.0 +! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +! the routine will end with ier = 6. +! +! limit - integer +! gives an upper bound on the number of subintervals +! in the partition of (a,b), limit.ge.npts2 +! if limit.lt.npts2, the routine will end with +! ier = 6. +! +! on return +! result - double precision +! approximation to the integral +! +! abserr - double precision +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! ier.gt.0 abnormal termination of the routine. +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (i.e. singularity, +! discontinuity within the interval), it +! should be supplied to the routine as an +! element of the vector points. if necessary +! an appropriate special-purpose integrator +! must be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be +! achieved, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier.gt.0. +! = 6 the input is invalid because +! npts2.lt.2 or +! break points are specified outside +! the integration range or +! (epsabs.le.0 and +! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +! or limit.lt.npts2. +! result, abserr, neval, last, rlist(1), +! and elist(1) are set to zero. alist(1) and +! blist(1) are set to a and b respectively. +! +! alist - double precision +! vector of dimension at least limit, the first +! last elements of which are the left end points +! of the subintervals in the partition of the given +! integration range (a,b) +! +! blist - double precision +! vector of dimension at least limit, the first +! last elements of which are the right end points +! of the subintervals in the partition of the given +! integration range (a,b) +! +! rlist - double precision +! vector of dimension at least limit, the first +! last elements of which are the integral +! approximations on the subintervals +! +! elist - double precision +! vector of dimension at least limit, the first +! last elements of which are the moduli of the +! absolute error estimates on the subintervals +! +! pts - double precision +! vector of dimension at least npts2, containing the +! integration limits and the break points of the +! interval in ascending sequence. +! +! level - integer +! vector of dimension at least limit, containing the +! subdivision levels of the subinterval, i.e. if +! (aa,bb) is a subinterval of (p1,p2) where p1 as +! well as p2 is a user-provided break point or +! integration limit, then (aa,bb) has level l if +! abs(bb-aa) = abs(p2-p1)*2**(-l). +! +! ndin - integer +! vector of dimension at least npts2, after first +! integration over the intervals (pts(i)),pts(i+1), +! i = 0,1, ..., npts2-2, the error estimates over +! some of the intervals may have been increased +! artificially, in order to put their subdivision +! forward. if this happens for the subinterval +! numbered k, ndin(k) is put to 1, otherwise +! ndin(k) = 0. +! +! iord - integer +! vector of dimension at least limit, the first k +! elements of which are pointers to the +! error estimates over the subintervals, +! such that elist(iord(1)), ..., elist(iord(k)) +! form a decreasing sequence, with k = last +! if last.le.(limit/2+2), and k = limit+1-last +! otherwise +! +! last - integer +! number of subintervals actually produced in the +! subdivisions process +! +!***references (none) +!***routines called dqelg,dqk21,dqpsrt +!***end prologue dqagpe + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_) :: a,abseps,abserr,alist,area,area1,area12,area2,a1, & + a2,b,blist,b1,b2,correc,dabs,defabs,defab1,defab2,dmax1,dmin1, & + dres,elist,epsabs,epsrel,erlarg,erlast,errbnd, & + errmax,error1,erro12,error2,errsum,ertest,points,pts, & + resa,resabs,reseps,result,res3la,rlist,rlist2,sign,temp + integer :: i,id,ier,ierro,ind1,ind2,iord,ip1,iroff1,iroff2,iroff3,j, & + jlow,jupbnd,k,ksgn,ktmin,last,levcur,level,levmax,limit,maxerr, & + ndin,neval,nint,nintp1,npts,npts2,nres,nrmax,numrl2 + logical :: extrap,noext +! +! + dimension alist(limit),blist(limit),elist(limit),iord(limit), & + level(limit),ndin(npts2),points(npts2),pts(npts2),res3la(3), & + rlist(limit),rlist2(52) +! + real(wp_), external :: f +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine epsalg (rlist2 should be of dimension +! (limexp+2) at least). +! +! +! list of major variables +! ----------------------- +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 +! containing the part of the epsilon table which +! is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements in rlist2. if an appropriate +! approximation to the compounded integral has +! been obtained, it is put in rlist2(numrl2) after +! numrl2 has been increased by one. +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine +! is attempting to perform extrapolation. i.e. +! before subdividing the smallest interval we +! try to decrease the value of erlarg. +! noext - logical variable denoting that extrapolation is +! no longer allowed (true-value) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! +!***first executable statement dqagpe +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0_wp_ + abserr = 0.0_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0_wp_ + elist(1) = 0.0_wp_ + iord(1) = 0 + level(1) = 0 + npts = npts2-2 + if(npts2.lt.2.or.limit.le.npts.or.(epsabs.le.0.0_wp_.and. & + epsrel.lt.dmax1(0.5e+02_wp_*epmach,0.5e-28_wp_))) ier = 6 + if(ier.eq.6) return +! +! if any break points are provided, sort them into an +! ascending sequence. +! + sign = 1.0_wp_ + if(a.gt.b) sign = -1.0_wp_ + pts(1) = dmin1(a,b) + do i = 1,npts + pts(i+1) = points(i) + end do + pts(npts+2) = dmax1(a,b) + nint = npts+1 + a1 = pts(1) + if(npts.ne.0) then + nintp1 = nint+1 + do i = 1,nint + ip1 = i+1 + do j = ip1,nintp1 + if(pts(i).gt.pts(j)) then + temp = pts(i) + pts(i) = pts(j) + pts(j) = temp + end if + end do + end do + if(pts(1).ne.dmin1(a,b).or.pts(nintp1).ne.dmax1(a,b)) ier = 6 + if(ier.eq.6) return + end if +! +! compute first integral and error approximations. +! ------------------------------------------------ +! + resabs = 0.0_wp_ + do i = 1,nint + b1 = pts(i+1) + call dqk21(f,a1,b1,area1,error1,defabs,resa) + abserr = abserr+error1 + result = result+area1 + ndin(i) = 0 + if(error1.eq.resa.and.error1.ne.0.0_wp_) ndin(i) = 1 + resabs = resabs+defabs + level(i) = 0 + elist(i) = error1 + alist(i) = a1 + blist(i) = b1 + rlist(i) = area1 + iord(i) = i + a1 = b1 + end do + errsum = 0.0_wp_ + do i = 1,nint + if(ndin(i).eq.1) elist(i) = abserr + errsum = errsum+elist(i) + end do +! +! test on accuracy. +! + last = nint + neval = 21*nint + dres = dabs(result) + errbnd = dmax1(epsabs,epsrel*dres) + if(abserr.le.0.1d+03*epmach*resabs.and.abserr.gt.errbnd) ier = 2 + if(nint.ne.1) then + do i = 1,npts + jlow = i+1 + ind1 = iord(i) + do j = jlow,nint + ind2 = iord(j) + if(elist(ind1).le.elist(ind2)) then + ind1 = ind2 + k = j + end if + end do + if(ind1.ne.iord(i)) then + iord(k) = iord(i) + iord(i) = ind1 + end if + end do + if(limit.lt.npts2) ier = 1 + end if + if(ier.eq.0.and.abserr.gt.errbnd) then +! +! initialization +! -------------- +! + rlist2(1) = result + maxerr = iord(1) + errmax = elist(maxerr) + area = result + nrmax = 1 + nres = 0 + numrl2 = 1 + ktmin = 0 + extrap = .false. + noext = .false. + erlarg = errsum + ertest = errbnd + levmax = 1 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ierro = 0 + abserr = oflow + ksgn = -1 + if(dres.ge.(0.1d+01-0.5d+02*epmach)*resabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = npts2,limit +! +! bisect the subinterval with the nrmax-th largest error +! estimate. +! + levcur = level(maxerr)+1 + 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,resa,defab1) + call dqk21(f,a2,b2,area2,error2,resa,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + neval = neval+42 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.ne.error1.and.defab2.ne.error2) then + if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) & + .and.erro12.ge.0.99d+00*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + end if + level(maxerr) = levcur + level(last) = levcur + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last.eq.limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range +! + if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*epmach)* & + (dabs(a2)+0.1d+04*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2.le.error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call subroutine dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +! ***jump out of do-loop + if(errsum.le.errbnd) go to 190 +! ***jump out of do-loop + if(ier.ne.0) exit + if(noext) cycle + erlarg = erlarg-erlast + if(levcur+1.le.levmax) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(level(maxerr)+1.le.levmax) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro.ne.3.and.erlarg.gt.ertest) then +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over +! the larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +! ***jump out of do-loop + if(level(maxerr)+1.le.levmax) go to 160 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + if(numrl2.gt.2) then + 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.lt.abserr) then + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = dmax1(epsabs,epsrel*dabs(reseps)) +! ***jump out of do-loop + if(abserr.lt.ertest) exit + end if +! +! prepare bisection of the smallest interval. +! + if(numrl2.eq.1) noext = .true. + if(ier.ge.5) exit + end if + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + levmax = levmax+1 + erlarg = errsum + 160 continue + end do +! +! set the final result. +! --------------------- +! +! + if(abserr.eq.oflow) go to 190 + if((ier+ierro).ne.0) then + 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) then + if(abserr/dabs(result).gt.errsum/dabs(area))go to 190 + else + if(abserr.gt.errsum)go to 190 + if(area.eq.0.0d+00) go to 210 + end if +! +! test on divergence. +! + end if + if(ksgn.ne.(-1).or.dmax1(dabs(result),dabs(area)).gt.resabs*0.1d-01) then + if(0.1d-01.gt.(result/area).or.(result/area).gt.0.1d+03.or. & + errsum.gt.dabs(area)) ier = 6 + end if + go to 210 +! +! compute global integral sum. +! + 190 result = 0.0d+00 + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + end if + 210 if(ier.gt.2) ier = ier-1 + result = result*sign + end subroutine dqagpe +! +! +! Integration routine dqags.f from quadpack and dependencies: BEGIN +! Modified version for functions f(x,yi) with more than one variable +! +! + subroutine dqagsmv(f,a,b,apar,np,epsabs,epsrel,result,abserr,neval,ier, & + limit,lenw,last,iwork,work) +!***begin prologue dqagsmv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end-point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & prog. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account. however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. it is presumed that +! the requested tolerance cannot be +! achieved, and that the returned result is +! the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagse. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! +! call error handler if necessary. +! + lvl = 0 + end if + if(ier==6) lvl = 1 + if(ier/=0) print*,'habnormal return from dqags',ier,lvl + end subroutine dqagsmv + + subroutine dqagsemv(f,a,b,apar,np,epsabs,epsrel,limit,result,abserr,neval, & + ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagsemv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a1 +!***keywords automatic integrator, general-purpose, +! (end point) singularities, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! definite integral i = integral of f over (a,b), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)). +!***description +! +! computation of a definite integral +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 abnormal termination of the routine +! the estimates for integral and error are +! less reliable. it is assumed that the +! requested accuracy has not been achieved. +! error messages +! = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more sub- +! divisions by increasing the value of limit +! (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is detec- +! ted, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour +! occurs at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is presumed that the requested +! tolerance cannot be achieved, and that the +! returned result is the best which can be +! obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! epsabs<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + real(wp_), intent(in) :: a,b,epsabs,epsrel + integer, intent(in) :: limit,np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: neval,ier,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f +! + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,b1,b2,correc,abs, & + defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg (rlist2 should be of dimension +! (limexp+2) at least). +! +! list of major variables +! ----------------------- +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least limexp+2 containing +! the part of the epsilon table which is still +! needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left interval +! *****2 - variable for the right interval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine is +! attempting to perform extrapolation i.e. before +! subdividing the smallest interval we try to +! decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true value) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! +!***first executable statement dqagsemv +! +! test on validity of parameters +! ------------------------------ + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = a + blist(1) = b + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 140 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with the nrmax-th largest error +! estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk21mv(f,a1,b1,apar,np,area1,error1,resabs,defab1) + call dqk21mv(f,a2,b2,apar,np,area2,error2,resabs,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of subintervals +! equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at a point of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call subroutine dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +! ***jump out of do-loop + if(errsum<=errbnd) go to 115 +! ***jump out of do-loop + if(ier/=0) exit + if(last==2) then + small = abs(b-a)*0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) +! ***jump out of do-loop + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do +! +! perform extrapolation. +! + end if + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum) go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence. +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + if(ier>2) ier = ier-1 + 140 continue + neval = 42*last-21 + end subroutine dqagsemv + + subroutine dqk21mv(f,a,b,apar,np,result,abserr,resabs,resasc) +!***begin prologue dqk21mv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a1a2 +!***keywords 21-point gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose to compute i = integral of f over (a,b), with error +! estimate +! j = integral of abs(f) over (a,b) +!***description +! +! integration rules +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! a - real(8) +! lower limit of integration +! +! b - real(8) +! upper limit of integration +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! on return +! result - real(8) +! approximation to the integral i +! result is computed by applying the 21-point +! kronrod rule (resk) obtained by optimal addition +! of abscissae to the 10-point gauss rule (resg). +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should not exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of abs(f-i/(b-a)) +! over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk21mv +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b + integer, intent(in) :: np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,centr,abs,dhlgth,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh + real(wp_), dimension(10) :: fv1,fv2 + integer :: j,jtw,jtwm1 +! +! the abscissae and weights are given for the interval (-1,1). +! because of symmetry only the positive abscissae and their +! corresponding weights are given. +! +! xgk - abscissae of the 21-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 10-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 10-point gauss rule +! +! wgk - weights of the 21-point kronrod rule +! +! wg - weights of the 10-point gauss rule +! +! +! gauss quadrature weights and kronron quadrature abscissae and weights +! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +! bell labs, nov. 1981. +! + real(wp_), dimension(5), parameter :: & + wg = (/ 0.066671344308688137593568809893332_wp_, & + 0.149451349150580593145776339657697_wp_, & + 0.219086362515982043995534934228163_wp_, & + 0.269266719309996355091226921569469_wp_, & + 0.295524224714752870173892994651338_wp_ /) +! + real(wp_), dimension(11), parameter :: & + xgk = (/ 0.995657163025808080735527280689003_wp_, & + 0.973906528517171720077964012084452_wp_, & + 0.930157491355708226001207180059508_wp_, & + 0.865063366688984510732096688423493_wp_, & + 0.780817726586416897063717578345042_wp_, & + 0.679409568299024406234327365114874_wp_, & + 0.562757134668604683339000099272694_wp_, & + 0.433395394129247190799265943165784_wp_, & + 0.294392862701460198131126603103866_wp_, & + 0.148874338981631210884826001129720_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.011694638867371874278064396062192_wp_, & + 0.032558162307964727478818972459390_wp_, & + 0.054755896574351996031381300244580_wp_, & + 0.075039674810919952767043140916190_wp_, & + 0.093125454583697605535065465083366_wp_, & + 0.109387158802297641899210590325805_wp_, & + 0.123491976262065851077958109831074_wp_, & + 0.134709217311473325928054001771707_wp_, & + 0.142775938577060080797094273138717_wp_, & + 0.147739104901338491374841515972068_wp_, & + 0.149445554002916905664936468389821_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc - abscissa +! fval* - function value +! resg - result of the 10-point gauss formula +! resk - result of the 21-point kronrod formula +! reskh - approximation to the mean value of f over (a,b), +! i.e. to i/(b-a) +! +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! +!***first executable statement dqk21mv + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + dhlgth = abs(hlgth) +! +! compute the 21-point kronrod approximation to +! the integral, and estimate the absolute error. +! + resg = 0.0e+00_wp_ + fc = f(centr,apar,np) + resk = wgk(11)*fc + resabs = abs(resk) + do j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,apar,np) + fval2 = f(centr+absc,apar,np) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2)) + end do + do j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,apar,np) + fval2 = f(centr+absc,apar,np) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5e+00_wp_ + resasc = wgk(11)*abs(fc-reskh) + do j=1,10 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = abs((resk-resg)*hlgth) + if(resasc/=0.0e+00_wp_.and.abserr/=0.0e+00_wp_) & + abserr = resasc*dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk21mv + + subroutine dqagimv(f,bound,inf,apar,np,epsabs,epsrel,result,abserr,neval, & + ier,limit,lenw,last,iwork,work) +!***begin prologue dqagimv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. -k.u.leuven +!***purpose the routine calculates an approximation result to a given +! integral i = integral of f over (bound,+infinity) +! or i = integral of f over (-infinity,bound) +! or i = integral of f over (-infinity,+infinity) +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)). +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! parameters +! on entry +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - integer +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however, if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. if +! the position of a local difficulty can be +! determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrel=1. +! if limit<1, the routine will end with ier = 6. +! +! lenw - integer +! dimensioning parameter for work +! lenw must be at least limit*4. +! if lenw=1.and.lenw>=limit*4) then +! +! prepare call for dqagie. +! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +! + call dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) +! + end if + if(ier/=0) print*,'habnormal return from dqagi' + end subroutine dqagimv + + subroutine dqagiemv(f,bound,inf,apar,np,epsabs,epsrel,limit,result,abserr, & + neval,ier,alist,blist,rlist,elist,iord,last) +!***begin prologue dqagiemv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a1,h2a4a1 +!***keywords automatic integrator, infinite intervals, +! general-purpose, transformation, extrapolation, +! globally adaptive +!***author piessens,robert,appl. math & progr. div - k.u.leuven +! de doncker,elise,appl. math & progr. div - k.u.leuven +!***purpose the routine calculates an approximation result to a given +! integral i = integral of f over (bound,+infinity) +! or i = integral of f over (-infinity,bound) +! or i = integral of f over (-infinity,+infinity), +! hopefully satisfying following claim for accuracy +! abs(i-result)<=max(epsabs,epsrel*abs(i)) +!***description +! +! integration over infinite intervals +! standard fortran subroutine +! +! f - real(8) +! function subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the driver program. +! +! bound - real(8) +! finite bound of integration range +! (has no meaning if interval is doubly-infinite) +! +! inf - real(8) +! indicating the kind of integration range involved +! inf = 1 corresponds to (bound,+infinity), +! inf = -1 to (-infinity,bound), +! inf = 2 to (-infinity,+infinity). +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! epsabs - real(8) +! absolute accuracy requested +! epsrel - real(8) +! relative accuracy requested +! if epsabs<=0 +! and epsrel=1 +! +! on return +! result - real(8) +! approximation to the integral +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! neval - integer +! number of integrand evaluations +! +! ier - integer +! ier = 0 normal and reliable termination of the +! routine. it is assumed that the requested +! accuracy has been achieved. +! - ier>0 abnormal termination of the routine. the +! estimates for result and error are less +! reliable. it is assumed that the requested +! accuracy has not been achieved. +! error messages +! ier = 1 maximum number of subdivisions allowed +! has been achieved. one can allow more +! subdivisions by increasing the value of +! limit (and taking the according dimension +! adjustments into account). however,if +! this yields no improvement it is advised +! to analyze the integrand in order to +! determine the integration difficulties. +! if the position of a local difficulty can +! be determined (e.g. singularity, +! discontinuity within the interval) one +! will probably gain from splitting up the +! interval at this point and calling the +! integrator on the subranges. if possible, +! an appropriate special-purpose integrator +! should be used, which is designed for +! handling the type of difficulty involved. +! = 2 the occurrence of roundoff error is +! detected, which prevents the requested +! tolerance from being achieved. +! the error may be under-estimated. +! = 3 extremely bad integrand behaviour occurs +! at some points of the integration +! interval. +! = 4 the algorithm does not converge. +! roundoff error is detected in the +! extrapolation table. +! it is assumed that the requested tolerance +! cannot be achieved, and that the returned +! result is the best which can be obtained. +! = 5 the integral is probably divergent, or +! slowly convergent. it must be noted that +! divergence can occur with any other value +! of ier. +! = 6 the input is invalid, because +! (epsabs<=0 and +! epsrelcomp_eps, uflow=>comp_tiny, & + oflow=>comp_huge + implicit none + integer, intent(in) :: limit,inf,np + real(wp_), intent(in) :: bound,epsabs,epsrel + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr + integer, intent(out) :: ier,neval,last + real(wp_), dimension(limit), intent(inout) :: alist,blist,elist,rlist + integer, dimension(limit), intent(inout) :: iord + real(wp_), external :: f + real(wp_) :: abseps,area,area1,area12,area2,a1,a2,boun,b1,b2,correc, & + abs,defabs,defab1,defab2,dmax1,dres,erlarg,erlast,errbnd,errmax, & + error1,error2,erro12,errsum,ertest,resabs,reseps,small + real(wp_) :: res3la(3),rlist2(52) + integer :: id,ierro,iroff1,iroff2,iroff3,jupbnd,k,ksgn, & + ktmin,maxerr,nres,nrmax,numrl2 + logical :: extrap,noext +! +! the dimension of rlist2 is determined by the value of +! limexp in subroutine dqelg. +! +! +! list of major variables +! ----------------------- +! +! alist - list of left end points of all subintervals +! considered up to now +! blist - list of right end points of all subintervals +! considered up to now +! rlist(i) - approximation to the integral over +! (alist(i),blist(i)) +! rlist2 - array of dimension at least (limexp+2), +! containing the part of the epsilon table +! wich is still needed for further computations +! elist(i) - error estimate applying to rlist(i) +! maxerr - pointer to the interval with largest error +! estimate +! errmax - elist(maxerr) +! erlast - error on the interval currently subdivided +! (before that subdivision has taken place) +! area - sum of the integrals over the subintervals +! errsum - sum of the errors over the subintervals +! errbnd - requested accuracy max(epsabs,epsrel* +! abs(result)) +! *****1 - variable for the left subinterval +! *****2 - variable for the right subinterval +! last - index for subdivision +! nres - number of calls to the extrapolation routine +! numrl2 - number of elements currently in rlist2. if an +! appropriate approximation to the compounded +! integral has been obtained, it is put in +! rlist2(numrl2) after numrl2 has been increased +! by one. +! small - length of the smallest interval considered up +! to now, multiplied by 1.5 +! erlarg - sum of the errors over the intervals larger +! than the smallest interval considered up to now +! extrap - logical variable denoting that the routine +! is attempting to perform extrapolation. i.e. +! before subdividing the smallest interval we +! try to decrease the value of erlarg. +! noext - logical variable denoting that extrapolation +! is no longer allowed (true-value) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! oflow is the largest positive magnitude. +! +!***first executable statement dqagie +! +! test on validity of parameters +! ----------------------------- +! + ier = 0 + neval = 0 + last = 0 + result = 0.0e+00_wp_ + abserr = 0.0e+00_wp_ + alist(1) = 0.0e+00_wp_ + blist(1) = 0.1e+01_wp_ + rlist(1) = 0.0e+00_wp_ + elist(1) = 0.0e+00_wp_ + iord(1) = 0 + if(epsabs<=0.0e+00_wp_.and.epsrelerrbnd) ier = 2 + if(limit==1) ier = 1 + if(ier/=0.or.(abserr<=errbnd.and.abserr/=resabs).or. & + abserr==0.0e+00_wp_) go to 130 +! +! initialization +! -------------- +! + 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>=(0.1e+01_wp_-0.5e+02_wp_*epmach)*defabs) ksgn = 1 +! +! main do-loop +! ------------ +! + do last = 2,limit +! +! bisect the subinterval with nrmax-th largest error estimate. +! + a1 = alist(maxerr) + b1 = 0.5e+00_wp_*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk15imv(f,boun,inf,a1,b1,apar,np,area1,error1,resabs,defab1) + call dqk15imv(f,boun,inf,a2,b2,apar,np,area2,error2,resabs,defab2) +! +! improve previous approximations to integral +! and error and test for accuracy. +! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1/=error1.and.defab2/=error2) then + if(abs(rlist(maxerr)-area12)<=0.1e-04_wp_*abs(area12) & + .and.erro12>=0.99e+00_wp_*errmax) then + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + end if + if(last>10.and.erro12>errmax) iroff3 = iroff3+1 + end if + rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*abs(area)) +! +! test for roundoff error and eventually set error flag. +! + if(iroff1+iroff2>=10.or.iroff3>=20) ier = 2 + if(iroff2>=5) ierro = 3 +! +! set error flag in the case that the number of +! subintervals equals limit. +! + if(last==limit) ier = 1 +! +! set error flag in the case of bad integrand behaviour +! at some points of the integration range. +! + if(dmax1(abs(a1),abs(b2))<=(0.1e+01_wp_+0.1e+03_wp_*epmach)* & + (abs(a2)+0.1e+04_wp_*uflow)) ier = 4 +! +! append the newly-created intervals to the list. +! + if(error2<=error1) then + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + else + alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + end if +! +! call subroutine dqpsrt to maintain the descending ordering +! in the list of error estimates and select the subinterval +! with nrmax-th largest error estimate (to be bisected next). +! + call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum<=errbnd) go to 115 + if(ier/=0) exit + if(last==2) then + small = 0.375e+00_wp_ + erlarg = errsum + ertest = errbnd + rlist2(2) = area + cycle + end if + if(noext) cycle + erlarg = erlarg-erlast + if(abs(b1-a1)>small) erlarg = erlarg+erro12 + if(.not.extrap) then +! +! test whether the interval to be bisected next is the +! smallest interval. +! + if(abs(blist(maxerr)-alist(maxerr))>small) cycle + extrap = .true. + nrmax = 2 + end if + if(ierro/=3.and.erlarg>ertest) then +! +! the smallest interval has the largest error. +! before bisecting decrease the sum of the errors over the +! larger intervals (erlarg) and perform extrapolation. +! + id = nrmax + jupbnd = last + if(last>(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(abs(blist(maxerr)-alist(maxerr))>small) go to 90 + nrmax = nrmax+1 + end do + end if +! +! perform extrapolation. +! + numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres) + ktmin = ktmin+1 + if(ktmin>5.and.abserr<0.1e-02_wp_*errsum) ier = 5 + if(absepserrsum)go to 115 + if(area==0.0e+00_wp_) go to 130 + go to 110 + 105 continue + if(abserr/abs(result)>errsum/abs(area)) go to 115 +! +! test on divergence +! + 110 continue + if(ksgn==(-1).and.dmax1(abs(result),abs(area))<= & + defabs*0.1e-01_wp_) go to 130 + if(0.1e-01_wp_>(result/area).or.(result/area)>0.1e+03_wp_ & + .or.errsum>abs(area)) ier = 6 + go to 130 +! +! compute global integral sum. +! + 115 continue + result = 0.0e+00_wp_ + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum + 130 continue + neval = 30*last-15 + if(inf==2) neval = 2*neval + if(ier>2) ier=ier-1 + end subroutine dqagiemv + + subroutine dqk15imv(f,boun,inf,a,b,apar,np,result,abserr,resabs,resasc) +!***begin prologue dqk15imv +!***date written 800101 (yymmdd) +!***revision date 830518 (yymmdd) +!***category no. h2a3a2,h2a4a2 +!***keywords 15-point transformed gauss-kronrod rules +!***author piessens,robert,appl. math. & progr. div. - k.u.leuven +! de doncker,elise,appl. math. & progr. div. - k.u.leuven +!***purpose the original (infinite integration range is mapped +! onto the interval (0,1) and (a,b) is a part of (0,1). +! it is the purpose to compute +! i = integral of transformed integrand over (a,b), +! j = integral of abs(transformed integrand) over (a,b). +!***description +! +! integration rule +! standard fortran subroutine +! real(8) version +! +! parameters +! on entry +! f - real(8) +! fuction subprogram defining the integrand +! function f(x,apar,np). the actual name for f needs to be +! declared e x t e r n a l in the calling program. +! +! boun - real(8) +! finite bound of original integration +! range (set to zero if inf = +2) +! +! inf - integer +! if inf = -1, the original interval is +! (-infinity,bound), +! if inf = +1, the original interval is +! (bound,+infinity), +! if inf = +2, the original interval is +! (-infinity,+infinity) and +! the integral is computed as the sum of two +! integrals, one over (-infinity,0) and one over +! (0,+infinity). +! +! a - real(8) +! lower limit for integration over subrange +! of (0,1) +! +! b - real(8) +! upper limit for integration over subrange +! of (0,1) +! +! apar - array of parameters of the integrand function f +! +! np - number of parameters. size of apar +! +! on return +! result - real(8) +! approximation to the integral i +! result is computed by applying the 15-point +! kronrod rule(resk) obtained by optimal addition +! of abscissae to the 7-point gauss rule(resg). +! +! abserr - real(8) +! estimate of the modulus of the absolute error, +! which should equal or exceed abs(i-result) +! +! resabs - real(8) +! approximation to the integral j +! +! resasc - real(8) +! approximation to the integral of +! abs((transformed integrand)-i/(b-a)) over (a,b) +! +!***references (none) +!***routines called (none) +!***end prologue dqk15imv +! + use const_and_precisions, only : epmach=>comp_eps, uflow=>comp_tiny + implicit none + real(wp_), intent(in) :: a,b,boun + integer, intent(in) :: inf,np + real(wp_), dimension(np), intent(in) :: apar + real(wp_), intent(out) :: result,abserr,resabs,resasc + real(wp_), external :: f + real(wp_) :: absc,absc1,absc2,centr,abs,dinf,dmax1,dmin1,fc,fsum, & + fval1,fval2,hlgth,resg,resk,reskh,tabsc1,tabsc2 + real(wp_), dimension(7) :: fv1,fv2 + integer :: j +! +! the abscissae and weights are supplied for the interval +! (-1,1). because of symmetry only the positive abscissae and +! their corresponding weights are given. +! +! xgk - abscissae of the 15-point kronrod rule +! xgk(2), xgk(4), ... abscissae of the 7-point +! gauss rule +! xgk(1), xgk(3), ... abscissae which are optimally +! added to the 7-point gauss rule +! +! wgk - weights of the 15-point kronrod rule +! +! wg - weights of the 7-point gauss rule, corresponding +! to the abscissae xgk(2), xgk(4), ... +! wg(1), wg(3), ... are set to zero. +! + real(wp_), dimension(8), parameter :: & + wg = (/ 0.000000000000000000000000000000000_wp_, & + 0.129484966168869693270611432679082_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.279705391489276667901467771423780_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.381830050505118944950369775488975_wp_, & + 0.000000000000000000000000000000000_wp_, & + 0.417959183673469387755102040816327_wp_ /), & + xgk = (/ 0.991455371120812639206854697526329_wp_, & + 0.949107912342758524526189684047851_wp_, & + 0.864864423359769072789712788640926_wp_, & + 0.741531185599394439863864773280788_wp_, & + 0.586087235467691130294144838258730_wp_, & + 0.405845151377397166906606412076961_wp_, & + 0.207784955007898467600689403773245_wp_, & + 0.000000000000000000000000000000000_wp_ /), & + wgk = (/ 0.022935322010529224963732008058970_wp_, & + 0.063092092629978553290700663189204_wp_, & + 0.104790010322250183839876322541518_wp_, & + 0.140653259715525918745189590510238_wp_, & + 0.169004726639267902826583426598550_wp_, & + 0.190350578064785409913256402421014_wp_, & + 0.204432940075298892414161999234649_wp_, & + 0.209482141084727828012999174891714_wp_ /) +! +! +! list of major variables +! ----------------------- +! +! centr - mid point of the interval +! hlgth - half-length of the interval +! absc* - abscissa +! tabsc* - transformed abscissa +! fval* - function value +! resg - result of the 7-point gauss formula +! resk - result of the 15-point kronrod formula +! reskh - approximation to the mean value of the transformed +! integrand over (a,b), i.e. to i/(b-a) +! +! machine dependent constants +! --------------------------- +! +! epmach is the largest relative spacing. +! uflow is the smallest positive magnitude. +! +!***first executable statement dqk15imv + dinf = min0(1,inf) +! + centr = 0.5e+00_wp_*(a+b) + hlgth = 0.5e+00_wp_*(b-a) + tabsc1 = boun+dinf*(0.1e+01_wp_-centr)/centr + fval1 = f(tabsc1,apar,np) + if(inf==2) fval1 = fval1+f(-tabsc1,apar,np) + fc = (fval1/centr)/centr +! +! compute the 15-point kronrod approximation to +! the integral, and estimate the error. +! + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = abs(resk) + do j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1e+01_wp_-absc1)/absc1 + tabsc2 = boun+dinf*(0.1e+01_wp_-absc2)/absc2 + fval1 = f(tabsc1,apar,np) + fval2 = f(tabsc2,apar,np) + if(inf==2) fval1 = fval1+f(-tabsc1,apar,np) + if(inf==2) fval2 = fval2+f(-tabsc2,apar,np) + 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)*(abs(fval1)+abs(fval2)) + end do + reskh = resk*0.5e+00_wp_ + resasc = wgk(8)*abs(fc-reskh) + do j=1,7 + resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh)) + end do + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = abs((resk-resg)*hlgth) + if(resasc/=0.0e+00_wp_.and.abserr/=0._wp_) abserr = resasc* & + dmin1(0.1e+01_wp_,(0.2e+03_wp_*abserr/resasc)**1.5e+00_wp_) + if(resabs>uflow/(0.5e+02_wp_*epmach)) abserr = dmax1 & + ((epmach*0.5e+02_wp_)*resabs,abserr) + end subroutine dqk15imv + +end module quadpack \ No newline at end of file diff --git a/src/reflections.f90 b/src/reflections.f90 index 6e04214..1a3391e 100644 --- a/src/reflections.f90 +++ b/src/reflections.f90 @@ -1,21 +1,28 @@ module reflections + use const_and_precisions, only : wp_, comp_tiny, comp_eps, comp_huge, zero, one implicit none + + ! === 1D array limiter Rlim_i, Zlim_i + integer, public, save :: nlim + real(wp_), public, save :: rwallm + real(wp_), public, dimension(:), allocatable, save :: rlim,zlim + private - integer, parameter :: r8=selected_real_kind(15,300) - real(r8), parameter :: tinyr8=tiny(1._r8) public :: reflect,inters_linewall,inside public :: linecone_coord,interssegm_coord,interssegm + public :: alloc_lim,wall_refl,range2rect,set_lim + contains subroutine reflect(ki,nsurf,ko) implicit none - real(r8), intent(in), dimension(3) :: ki - real(r8), intent(in), dimension(3) :: nsurf - real(r8), intent(out), dimension(3) :: ko - real(r8) :: twokn,norm2 + real(wp_), intent(in), dimension(3) :: ki + real(wp_), intent(in), dimension(3) :: nsurf + real(wp_), intent(out), dimension(3) :: ko + real(wp_) :: twokn,norm2 norm2 = dot_product(nsurf,nsurf) - if (norm2>0.0_r8) then - twokn = 2.0_r8*dot_product(ki,nsurf)/norm2 + if (norm2>zero) then + twokn = 2.0_wp_*dot_product(ki,nsurf)/norm2 ko=ki-twokn*nsurf else ko=ki @@ -24,30 +31,38 @@ end subroutine reflect subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw) implicit none - real(r8), intent(in), dimension(3) :: xv,kv + real(wp_), intent(in), dimension(3) :: xv,kv integer, intent(in) :: nw - real(r8), dimension(nw), intent(in) :: rw,zw - real(r8), intent(out) :: sint - real(r8), dimension(3), intent(out) :: normw - integer :: i,j,ni,iint - real(r8), dimension(2) :: si,ti - real(r8) :: drw,dzw,xint,yint,rint,l,kxy - real(r8) :: tol - tol=sqrt(epsilon(1.0_r8)) - sint=huge(sint) + real(wp_), dimension(nw), intent(in) :: rw,zw + real(wp_), intent(out) :: sint + real(wp_), dimension(3), intent(out) :: normw + integer :: i,j,ni,iint,nneg + real(wp_), dimension(2) :: si,ti + real(wp_) :: drw,dzw,xint,yint,rint,l,kxy + real(wp_) :: tol + tol=sqrt(comp_eps) + sint=comp_huge iint=0 - normw=0.0_r8 + normw=zero do i=1,nw-1 !search intersections with i-th wall segment call linecone_coord(xv,kv,rw(i:i+1),zw(i:i+1),si,ti,ni) - do while (ni>0 .and. si(1)<=tol) - !remove solutions with s<=0 - ni = ni-1 - si(1) = si(2) - ti(1) = ti(2) - end do + !discard solutions with s<=0 + nneg=0 do j=1,ni - if ((si(j)=0._r8 .and. ti(j)<=1._r8) then + if (si(j)<=tol) then + nneg=j + else + exit + end if + end do +! do while (ni>0 .and. si(1)<=tol) +! ni = ni-1 +! si(1) = si(2) ??? +! ti(1) = ti(2) ??? +! end do + do j=nneg+1,ni + if ((si(j)=zero .and. ti(j)<=one) then !check intersection is in r,z range and keep the closest sint = si(j) iint = i @@ -64,7 +79,7 @@ subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw) l = sqrt(drw**2+dzw**2) kxy = sqrt(kv(1)**2+kv(2)**2) normw(3) = -drw/l - if (rint>0.0_r8) then + if (rint>zero) then normw(1) = xint/rint*dzw/l normw(2) = yint/rint*dzw/l else @@ -72,17 +87,18 @@ subroutine inters_linewall(xv,kv,rw,zw,nw,sint,normw) normw(2) = kv(2)/kxy*dzw/l end if !reverse normal if k.n>0 - if (dot_product(normw,kv)>0.0_r8) normw=-normw + if (dot_product(normw,kv)>zero) normw=-normw end subroutine inters_linewall subroutine linecone_coord(xv,kv,rs,zs,s,t,n) + use utils, only : bubble implicit none - real(r8), intent(in), dimension(3) :: xv,kv - real(r8), intent(in), dimension(2) :: rs,zs - real(r8), dimension(2), intent(out) :: s,t + real(wp_), intent(in), dimension(3) :: xv,kv + real(wp_), intent(in), dimension(2) :: rs,zs + real(wp_), dimension(2), intent(out) :: s,t integer, intent(out) :: n - real(r8) :: x0,y0,z0,kx,ky,kz - real(r8) :: dr,dz,r,a,bhalf,c,delta,tvertex,zvertex,srmin,rmin,zrmin + real(wp_) :: x0,y0,z0,kx,ky,kz + real(wp_) :: dr,dz,r,a,bhalf,c,delta,tvertex,zvertex,srmin,rmin,zrmin x0=xv(1) y0=xv(2) z0=xv(3) @@ -93,9 +109,9 @@ subroutine linecone_coord(xv,kv,rs,zs,s,t,n) dz = zs(2)-zs(1) s = 0 t = 0 - if (abs(dz)=0._r8 .and. s<=1._r8 .and. & - t>=0._r8 .and. t<=1._r8) interssegm = .true. + if (ierr==0 .and. s>=zero .and. s<=one .and. & + t>=zero .and. t<=one) interssegm = .true. end function interssegm function inside(xc,yc,n,x,y) + use utils, only : locatef, locate_unord, intlinf, bubble implicit none integer, intent(in) :: n - real(r8), dimension(n), intent(in) :: xc,yc - real(r8), intent(in) :: x,y + real(wp_), dimension(n), intent(in) :: xc,yc + real(wp_), intent(in) :: x,y logical :: inside integer, dimension(n) :: jint - real(r8), dimension(n) :: xint - real(r8), dimension(n+1) :: xclosed,yclosed + real(wp_), dimension(n) :: xint + real(wp_), dimension(n+1) :: xclosed,yclosed integer :: i,nj xclosed(1:n)=xc(1:n) yclosed(1:n)=yc(1:n) @@ -197,92 +214,130 @@ function inside(xc,yc,n,x,y) inside=.false. if (nj==0) return do i=1,nj - xint(i)=intlin(yclosed(jint(i)),xclosed(jint(i)), & + xint(i)=intlinf(yclosed(jint(i)),xclosed(jint(i)), & yclosed(jint(i)+1),xclosed(jint(i)+1),y) end do call bubble(xint,nj) - inside=(mod(locate(xint,nj,x),2)==1) + inside=(mod(locatef(xint,nj,x),2)==1) end function inside -function intlin(x1,y1,x2,y2,x) result(y) - !linear interpolation - !must be x1 != x2 +subroutine alloc_lim(ier) implicit none - real(r8),intent(in) :: x1,y1,x2,y2,x - real(r8) :: y - real(r8) :: a - a=(x2-x)/(x2-x1) - y=a*y1+(1._r8-a)*y2 -end function intlin - -subroutine locate_unord(a,n,x,j,m,nj) - implicit none - integer, intent(in) :: n,m - integer, intent(out) :: nj - real(r8), dimension(n), intent(in) :: a - real(r8), intent(in) :: x - integer, dimension(m), intent(inout) :: j - integer :: i - nj=0 - do i=1,n-1 - if (x>a(i).neqv.x>a(i+1)) then - nj=nj+1 - if (nj<=m) j(nj)=i - end if - end do -end subroutine locate_unord - -function locate(a,n,x) result(j) - !Given an array a(n), and a value x, with a(n) monotonic, either - !increasing or decreasing, returns a value j such that - !a(j) < x <= a(j+1) for a increasing, and such that - !a(j+1) < x <= a(j) for a decreasing. - !j=0 or j=n indicate that x is out of range (Numerical Recipes) - implicit none - integer, intent(in) :: n - real(r8), dimension(n), intent(in) :: a - real(r8), intent(in) :: x - integer :: j - integer :: jl,ju,jm - logical :: incr - jl=0 - ju=n+1 - incr=a(n)>a(1) - do while ((ju-jl)>1) - jm=(ju+jl)/2 - if(incr.eqv.(x>a(jm))) then - jl=jm - else - ju=jm - endif - end do - j=jl -end function locate - -subroutine order(p,q) - !returns p,q in ascending order - implicit none - real(r8), intent(inout) :: p,q - real(r8) :: temp - if (p>q) then - temp=p - p=q - q=temp + integer, intent(out) :: ier + + if(nlim.lt.0) then + ier = -1 + return end if -end subroutine order + + call dealloc_lim + allocate(rlim(nlim),zlim(nlim), & + stat=ier) + if (ier/=0) call dealloc_lim +end subroutine alloc_lim -subroutine bubble(a,n) - !bubble sorting of array a +subroutine dealloc_lim implicit none - integer, intent(in) :: n - real(r8), dimension(n), intent(inout) :: a - integer :: i, j - do i=1,n - do j=n,i+1,-1 - call order(a(j-1), a(j)) - end do - end do -end subroutine bubble + if(allocated(rlim)) deallocate(rlim) + if(allocated(zlim)) deallocate(zlim) +end subroutine dealloc_lim + +subroutine wall_refl(xv,anv,ext,eyt,xvrfl,anvrfl,extr,eytr,walln,irfl) + implicit none +! arguments + integer :: irfl + real(wp_), dimension(3) :: xv,anv,xvrfl,anvrfl,walln + complex(wp_) :: ext,eyt,extr,eytr +! local variables + real(wp_) :: smax,rrm,zzm + real(wp_), dimension(3) :: anv0,vv1,vv2,vv3 + complex(wp_) :: eztr + complex(wp_), dimension(3) :: evin,evrfl +! + anv0=anv/sqrt(anv(1)**2+anv(2)**2+anv(3)**2) + rrm=1.0e-2_wp_*sqrt(xv(1)**2+xv(2)**2) + zzm=1.0e-2_wp_*xv(3) +! +! computation of reflection coordinates and normal to the wall + call inters_linewall(xv/1.0e2_wp_,anv0,rlim(1:nlim),zlim(1:nlim), & + nlim,smax,walln) + smax=smax*1.0e2_wp_ + xvrfl=xv+smax*anv0 + irfl=1 + if (.not.inside(rlim,zlim,nlim,rrm,zzm)) then + ! first wall interface is outside-inside + if (dot_product(walln,walln)=n) then +! +! set derivative dy2 at last point +! + dyb =dy2 + h =0.0_wp_ + if (ioh/=0) then + dyb =dya + goto 13 + end if + else + j =j+jmp + xb =xc + xc =x(j) + h =xc-xb +! +! ii=0 - increasing abscissae +! ii=1 - decreasing abscissae +! + ii =0 + if (h==0) return + if (h<0) ii =1 + ya =yb + yb =y(j) + dyb =(yb-ya)/h + if (i<=1) then + j1 =ii + if (iol/=0) goto 13 + dya =c(1) + end if + end if + if (j1-ii /= 0) return + a =1.0_wp_/(h+h+a) + 13 continue + r =a*(dyb-dya) + c(j3)=r + a =h*a + c(j2)=a + c(i) =dyb + end do +! +! back substitution of the system of linear equations +! and computation of the other coefficients +! + a =1.0_wp_ + j1 =j3+n+ii-ii*n + i =n + do 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.0_wp_ + j =j-jmp + i =i-1 + j2 =j2-1 + j3 =j3-1 + j1 =j3+n+ii + end do + ier =0 +end subroutine difcs + +subroutine difcsn(xx,yy,nmx,n,iopt,cc,ier) +! +! same as difcs but with dimension(xx,yy) = nmx > n +! + implicit none + integer, intent(in) :: nmx, n, iopt + real(wp_), intent(in) :: xx(nmx), yy(nmx) + real(wp_), intent(inout) :: cc(nmx,4) + integer :: ier + integer :: jmp,iol,ioh,i,ii,j,j1,j2,j3 + real(wp_) :: x(n),y(n),c(n*4),xb,xc,ya,yb,h,a,r,dya,dyb,dy2 +! + 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 +! + jmp =1 + if (n>1) then +! +! initialization +! + xc =x(1) + yb =y(1) + h =0.0_wp_ + a =0.0_wp_ + r =0.0_wp_ + dyb =0.0_wp_ +! +! iol=0 - given derivative at first point +! ioh=0 - given derivative at last point +! + iol =iopt-1 + ioh =iopt-2 + if (ioh==1) then + iol =0 + ioh =0 + end if + dy2 =c(2) +! +! form the system of linear equations +! and eliminate subsequentially +! + j =1 + do i=1,n + j2 =n+i + j3 =j2+n + a =h*(2.0_wp_-a) + dya =dyb+h*r + if (i>=n) then +! +! set derivative dy2 at last point +! + dyb =dy2 + h =0.0_wp_ + if (ioh/=0) then + dyb =dya + goto 13 + end if + else + j =j+jmp + xb =xc + xc =x(j) + h =xc-xb +! +! ii=0 - increasing abscissae +! ii=1 - decreasing abscissae +! + ii =0 + if (h==0) goto 16 + if (h<0) ii =1 + ya =yb + yb =y(j) + dyb =(yb-ya)/h + if (i<=1) then + j1 =ii + if (iol/=0) goto 13 + dya =c(1) + end if + end if + if (j1/=ii) goto 16 + a =1.0_wp_/(h+h+a) + 13 continue + r =a*(dyb-dya) + c(j3)=r + a =h*a + c(j2)=a + c(i) =dyb + end do +! +! back substitution of the system of linear equations +! and computation of the other coefficients +! + a =1.0_wp_ + j1 =j3+n+ii-ii*n + i =n + do 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.0_wp_ + j =j-jmp + i =i-1 + j2 =j2-1 + j3 =j3-1 + j1 =j3+n+ii + end do + ier =0 + end if +! + 16 continue + ii=0 + do j=1,4 + do i=1,nmx + if(i<=n) then + ii=ii+1 + cc(i,j)=c(ii) + else + cc(i,j)=0.0_wp_ + end if + end do + end do +! +end subroutine difcsn + +end module simplespline \ No newline at end of file diff --git a/src/utils.f90 b/src/utils.f90 new file mode 100644 index 0000000..04a3157 --- /dev/null +++ b/src/utils.f90 @@ -0,0 +1,278 @@ +module utils + + use const_and_precisions, only : wp_ + implicit none + +contains + + function locatef(a,n,x) result(j) +! Given an array a(n), and a value x, with a(n) monotonic, either +! increasing or decreasing, returns a value j such that +! a(j) < x <= a(j+1) for a increasing, and such that +! a(j+1) < x <= a(j) for a decreasing. +! j=0 or j=n indicate that x is out of range (Numerical Recipes) + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(in) :: a + real(wp_), intent(in) :: x + integer :: j + integer :: jl,ju,jm + logical :: incr + jl=0 + ju=n+1 + incr=a(n)>a(1) + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if(incr.eqv.(x>a(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end function locatef + + subroutine locate(xx,n,x,j) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: xx(n), x + integer, intent(out) :: j + integer :: jl,ju,jm + logical :: incr +! +! Given an array xx(n), and a value x +! returns a value j such that xx(j) < x < xx(j+1) +! xx(n) must be monotonic, either increasing or decreasing. +! j=0 or j=n indicate that x is out of range (Numerical Recipes) +! + jl=0 + ju=n+1 + incr=xx(n)>xx(1) + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if(incr .eqv. (x>xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end subroutine locate + + subroutine locatex(xx,n,n1,n2,x,j) + implicit none + integer, intent(in) :: n,n1,n2 + real(wp_), intent(in) :: xx(n), x + integer, intent(out) :: j + integer :: jl,ju,jm +! +! Given an array xx(n), and a value x +! returns a value j such that xx(j) < x < xx(j+1) +! xx(n) must be monotonic, either increasing or decreasing. +! j=n1-1or j=n2+1 indicate that x is out of range +! modified from subr. locate (Numerical Recipes) +! + jl=n1-1 + ju=n2+1 + do while ((ju-jl)>1) + jm=(ju+jl)/2 + if((xx(n2)>xx(n1)) .eqv. (x>xx(jm))) then + jl=jm + else + ju=jm + endif + end do + j=jl + end subroutine locatex + + subroutine locate_unord(a,n,x,j,m,nj) + implicit none + integer, intent(in) :: n,m + integer, intent(out) :: nj + real(wp_), dimension(n), intent(in) :: a + real(wp_), intent(in) :: x + integer, dimension(m), intent(inout) :: j + integer :: i + nj=0 + do i=1,n-1 + if (x>a(i).neqv.x>a(i+1)) then + nj=nj+1 + if (nj<=m) j(nj)=i + end if + end do + end subroutine locate_unord + + function intlinf(x1,y1,x2,y2,x) result(y) + !linear interpolation + !must be x1 != x2 + use const_and_precisions, only : one + implicit none + real(wp_),intent(in) :: x1,y1,x2,y2,x + real(wp_) :: y + real(wp_) :: a + a=(x2-x)/(x2-x1) + y=a*y1+(one-a)*y2 + end function intlinf + + subroutine intlin(x1,y1,x2,y2,x,y) + implicit none + real(wp_), intent(in) :: x1,y1,x2,y2,x + real(wp_), intent(out) :: y + real(wp_) :: dx,aa,bb +! +! linear interpolation +! (x1,y1) < (x,y) < (x2,y2) +! + dx=x2-x1 + aa=(x2-x)/dx + bb=1.0_wp_-aa + y=aa*y1+bb*y2 + end subroutine intlin + + subroutine vmax(x,n,xmax,imx) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmax + integer, intent(out) :: imx + integer :: i + + if (n<1) then + imx=0 + return + end if + imx=1 + xmax=x(1) + do i=2,n + if(x(i)>xmax) then + xmax=x(i) + imx=i + end if + end do + end subroutine vmax + + subroutine vmin(x,n,xmin,imn) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmin + integer, intent(out) :: imn + integer :: i + + if (n<1) then + imn=0 + return + end if + imn=1 + xmin=x(1) + do i=2,n + if(x(i)xmax) then + xmax=x(i) + imx=i + end if + end do + end subroutine vmaxmini + + subroutine vmaxmin(x,n,xmin,xmax) + implicit none + integer, intent(in) :: n + real(wp_), intent(in) :: x(n) + real(wp_), intent(out) :: xmin, xmax + integer :: i + + if (n<1) then + return + end if + xmin=x(1) + xmax=x(1) + do i=2,n + if(x(i)xmax) then + xmax=x(i) + end if + end do + end subroutine vmaxmin + + subroutine order(p,q) +! returns p,q in ascending order + implicit none + real(wp_), intent(inout) :: p,q + real(wp_) :: temp + if (p>q) then + temp=p + p=q + q=temp + end if + end subroutine order + + subroutine bubble(a,n) +! bubble sorting of array a + implicit none + integer, intent(in) :: n + real(wp_), dimension(n), intent(inout) :: a + integer :: i, j + do i=1,n + do j=n,i+1,-1 + call order(a(j-1), a(j)) + end do + end do + end subroutine bubble + + function get_free_unit(umin,umax) result(i) + implicit none + integer :: i + integer, intent(in), optional :: umin, umax + integer, parameter :: max_allowed = 999 + integer :: ierr, iend + logical :: ex, op + + if (present(umin)) then + i = max(0,umin) ! start searching from unit min + else + i = 0 + end if + if (present(umax)) then + iend = min(max(0,umax),max_allowed) + else + iend = max_allowed + end if + do + if (i>iend) then + i=-1 ! no free units found + exit + end if + inquire(unit=i,exist=ex,opened=op,iostat=ierr) + if (ierr==0.and.ex.and..not.op) exit ! unit i exists and is not open + i = i + 1 + end do + end function get_free_unit + +end module utils \ No newline at end of file